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

[Zeki Gürsoy]

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

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

 

[peleryn]

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.

 

[Zeki Gürsoy]

Rica ederim. Müsadenizle konu başlığını değiştiryorum.

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

 

[peleryn]

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..

 

[peleryn]

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.

 

[ynmcan]

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

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

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ü?

 

[peleryn]

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?

 

[peleryn]

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.

 

[peleryn]

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?

Bu soruyu iptal ettim ilgilenenlere teşekkür ederim..

 

[ynmcan]

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.

Sn.Peleryn;
Elinize sağlık. Boyutlarını ben ayarladım, bayağda güzel oldu. Teşekkür ederim.

 

[peleryn]

Sn.Peleryn;
Elinize sağlık. Boyutlarını ben ayarladım, bayağda güzel oldu. Teşekkür ederim.

Rica ederim.İyi çalışmalar