Ekran Resmi Alma

[hamza02]

İndir Günlük İcmal xlsm

Dosyayı indir Günlük İcmal xlsm

dosya.co

Arkadaşlar merhaba,
Bu dosyamda iki adet ekran resmi alma butonu var.
Birincisinde sayfa içine kaydediyor, sorun yok.
İkinci butonda masaüstüne kaydediyor ancak sadece kenar çizgileri olan boş bir resim oluşturuyor.

Yapmak istediğim, ikinci butonun birinci buton gibi belirtilen hücre aralığının resmini alması ve dosya adına mevcut tarih ve saati yazması.
Şimdiden teşekkürler.

 

[muhasebeciyiz]

Private Sub CommandButton2_Click()
    Dim jipeg As Range
    Dim caartObj As ChartObject
    Dim masaustu As String
    Dim timestamp As String
    Dim dosyaYolu As String
    
    masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
    timestamp = Format(Now, "yyyy-mm-dd_hh-mm-ss")
    dosyaYolu = masaustu & "\screenshot_" & timestamp & ".jpg"
    
    Set jipeg = ActiveSheet.Range("A1:F23")
    jipeg.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Set caartObj = ActiveSheet.ChartObjects.Add(Left:=jipeg.Left, Top:=jipeg.Top, _
                                              Width:=jipeg.Width, Height:=jipeg.Height)
    
    With caartObj
        .Select
        .Chart.Paste
        
        DoEvents
        .Chart.Export Filename:=dosyaYolu, FilterName:="JPG"
        
        .Delete
    End With
    
    Set jipeg = Nothing
    Set caartObj = Nothing
    
End Sub

Buton2 kodunu silip bunu kullanınız