• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Seçili alanın resmini duvar kağıdı (WallPaper) atama

.
Ekteki dosya da seçili hücre aralığını duvar kağıdı yapmak isteyen üyelerimiz için.
.

Kod: 
Private Declare Function DuvarKagidi Lib "user32" Alias _
                        "SystemParametersInfoA" ( _
                        ByVal A As Long, _
                        ByVal B As Long, _
                        ByVal C As Any, _
                        ByVal D As Long) As Long

Private Enum RESIM_STILI
    Dose = 0
    Ortala = 1
    Uzat = 2
End Enum

Sub test()
    Call Hucreden_DuvarKagidina(Selection, "C:\", Uzat)
End Sub

Private Sub Hucreden_DuvarKagidina(hucre As Range, _
                    Hedef_Konum As String, _
                    Optional Stil As RESIM_STILI = 1)
                    
Const OPERATION     As Long = 20 'WallPaper
Const UPDATEINIFILE As Long = 1   'Ya da 0
Const JPG           As String = "tmp.jpg"
Const BMP           As String = "tmp.bmp"
                    
Dim graf As Chart
Dim pic  As IPictureDisp

    hucre.CopyPicture
    
    Set graf = ActiveSheet.ChartObjects.Add( _
    1, 1, hucre.Width, hucre.Height).Chart
    
    With graf
        .Paste
        .Export Hedef_Konum & JPG
        .Parent.Delete
    End With
    
    Set pic = LoadPicture(Hedef_Konum & JPG)
    SavePicture pic, Hedef_Konum & BMP
    
    Kill Hedef_Konum & JPG
    
    Set Wsh = CreateObject("WScript.Shell")
    
    Select Case Stil
        Case 0
            Wsh.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", "0", "REG_SZ"
            Wsh.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", "1", "REG_SZ"
        Case 1
            Wsh.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", "0", "REG_SZ"
            Wsh.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", "0", "REG_SZ"
        Case 2
            Wsh.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", "2", "REG_SZ"
            Wsh.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", "0", "REG_SZ"
    End Select
    
    Call DuvarKagidi(OPERATION, 0, Hedef_Konum & BMP, UPDATEINIFILE)
End Sub
 

Ekli dosyalar

Hocam tek kelimeyle harika oldu.Sekreterin pc ile ilgili kodları Salı günü deneyeceğim.Bence belli bir sayfayı sürekli takip etmesi gereken arkadaşlar olursa onlar için de çok güzel bir dosya yapmış oldunuz.

Kısa zamanda böyle güzel bir çalışmayla yardımcı olduğunuz için,bu güzel dosya için çok teşekkür ederim.

ister istemez konu başlığından biraz uzak bir sonuca ulaşmış olduk.İlgilenecek olanlar için izninizle wallpaper başlıklı bir konu açıp buraya link veriyorum.

Emekleriniz için tekrar teşekkürler.
 
Rica ederim. Müsadenizle konu başlığını değiştiryorum.

"Seçili alanın resmini duvar kağıdı (WallPaper) atama"
 
Hocam malesef bir konu açıp link vermiştim ama konuyu silmeye çalıştım nasıl sileceğim bulamadım.Ben de kapattım ama konu bana gözüküyor diğer üyelere de görünüyor mu bilmiyorum.Siz silebiliyorsanız bir de bunu rica edeyim sizden.

Tekrar teşekkürler..
 
Hocam bir de şöyle bir duru oluştu..Seçili alandaki nesneleri de wallpaper olarak atadığı için excelde hoş bir wallpaper düzenleme programı yapmış oldunuz.İlgili çizelgeme bir aile resmimi ekledim harika ve işlevsel bir masaüstü resmi oluşmuş oldu.
 
Zeki Gürsoy' Alıntı:
.
Ekteki dosya da seçili hücre aralığını duvar kağıdı yapmak isteyen üyelerimiz için.
.

Kod: 
Private Declare Function DuvarKagidi Lib "user32" Alias _
                        "SystemParametersInfoA" ( _
                        ByVal A As Long, _
                        ByVal B As Long, _
                        ByVal C As Any, _
                        ByVal D As Long) As Long

Private Enum RESIM_STILI
    Dose = 0
    Ortala = 1
    Uzat = 2
End Enum

Sub test()
    Call Hucreden_DuvarKagidina(Selection, "C:\", Uzat)
End Sub

Private Sub Hucreden_DuvarKagidina(hucre As Range, _
                    Hedef_Konum As String, _
                    Optional Stil As RESIM_STILI = 1)
                    
Const OPERATION     As Long = 20 'WallPaper
Const UPDATEINIFILE As Long = 1   'Ya da 0
Const JPG           As String = "tmp.jpg"
Const BMP           As String = "tmp.bmp"
                    
Dim graf As Chart
Dim pic  As IPictureDisp

    hucre.CopyPicture
    
    Set graf = ActiveSheet.ChartObjects.Add( _
    1, 1, hucre.Width, hucre.Height).Chart
    
    With graf
        .Paste
        .Export Hedef_Konum & JPG
        .Parent.Delete
    End With
    
    Set pic = LoadPicture(Hedef_Konum & JPG)
    SavePicture pic, Hedef_Konum & BMP
    
    Kill Hedef_Konum & JPG
    
    Set Wsh = CreateObject("WScript.Shell")
    
    Select Case Stil
        Case 0
            Wsh.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", "0", "REG_SZ"
            Wsh.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", "1", "REG_SZ"
        Case 1
            Wsh.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", "0", "REG_SZ"
            Wsh.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", "0", "REG_SZ"
        Case 2
            Wsh.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", "2", "REG_SZ"
            Wsh.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", "0", "REG_SZ"
    End Select
    
    Call DuvarKagidi(OPERATION, 0, Hedef_Konum & BMP, UPDATEINIFILE)
End Sub
Genişletmek için tıkla ...

Sn. Zeki GÜRSOY;
Çekilen resmi userform üzerine getirmemiz mümkünmü?
Mesela, örnek dosyamdaki vardiya planının sarı olan "A1:M46" bölümünün userform üzerindeki botona tıklabığımda userform üzerinde görünmesi mümkünmü?
 

Ekli dosyalar

Ben de benzer birşeyle uğraşıyordum..Örneğin sayfa1 üzerinde "Picture 1" isimli bir resmim olsun bu resmi userform üzerindeki Image1 nesnesine nasıl bir kodla alabilirim?
 
Sn ynmcany;

Image nesnesi değilde form üzerinde olarak sorduğunuz için form üzerine aktardım.Formu boyutlandırma işini size bıraktım.Form üzerindeki "güncelle" butonuna bastığınızda belirttiğiniz aralığın güncel resmi formun arkaplan resmi olarak atanıyor.
 

Ekli dosyalar

Son düzenleme:
peleryn' Alıntı:
Sn ynmcany;

Image nesnesi değilde form üzerinde olarak sorduğunuz için form üzerine aktardım.Formu boyutlandırma işini size bıraktım.Form üzerindeki "güncelle" butonuna bastığınızda belirttiğiniz aralığın güncel resmi formun arkaplan resmi olarak atanıyor.
Genişletmek için tıkla ...

Sn.Peleryn;
Elinize sağlık. Boyutlarını ben ayarladım, bayağda güzel oldu. Teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst