Masaüstüne JPG olarak kayıt etme

[aras90]

İyi Bayramlar, Excel sayfamı masaüstüne kayıt etmek istiyorum. Aşağıda bulunan kod çalışıyor yalnız beyaz bir sayfa olarak kayıt ediyor sebebi nedir?

Sub foto()
Dim obce As Object
Dim caart As Chart
Dim jipeg As Range
masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
ad = "test"
For x = 1 To 20000
    If Dir(masaustu & "\" & "ad" & x & ".jpg") = "" Then
        Yol = masaustu & "\" & "ad" & x & ".jpg"
        Exit For
    End If
Next
Application.ScreenUpdating = False
Set jipeg = ActiveSheet.Range("A1:U23")
jipeg.Copy
Set obce = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
obce.Select
ActiveSheet.Paste
obce.Delete
With Selection
.CopyPicture 1, 2
Set caart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
Range("a1").Select
With caart
.Paste
.Export Yol 'nereye çıkartılacaksa
.Parent.Delete
End With
.Delete
End With
Set jipeg = Nothing
Set obce = Nothing
End Sub

 

[Ömer]

Merhaba,

İyi bayramlar. Deneyiniz.

Sub foto()
Dim obce As Object
Dim caart As Chart
Dim jipeg As Range
masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
ad = "test"
For x = 1 To 2000
    If Dir(masaustu & "\" & "ad" & x & ".jpg") = "" Then
        Yol = masaustu & "\" & "ad" & x & ".jpg"
        Exit For
    End If
Next
Application.ScreenUpdating = False
Set jipeg = ActiveSheet.Range("A1:U23")
'jipeg.Copy
jipeg.Select
Selection.CopyPicture
'Set obce = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
'obce.Select
'ActiveSheet.Paste
'obce.Delete
With Selection
'.CopyPicture 1, 2
Set caart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
Range("a1").Select
With caart
    .ChartArea.Select
    .Paste
    .Export Yol 'nereye çıkartılacaksa
    .Parent.Delete
End With
'.Delete
End With
Set jipeg = Nothing
Set obce = Nothing
End Sub

 

[aras90]

Merhaba,

İyi bayramlar. Deneyiniz.

Sub foto()
Dim obce As Object
Dim caart As Chart
Dim jipeg As Range
masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
ad = "test"
For x = 1 To 2000
    If Dir(masaustu & "\" & "ad" & x & ".jpg") = "" Then
        Yol = masaustu & "\" & "ad" & x & ".jpg"
        Exit For
    End If
Next
Application.ScreenUpdating = False
Set jipeg = ActiveSheet.Range("A1:U23")
'jipeg.Copy
jipeg.Select
Selection.CopyPicture
'Set obce = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
'obce.Select
'ActiveSheet.Paste
'obce.Delete
With Selection
'.CopyPicture 1, 2
Set caart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
Range("a1").Select
With caart
    .ChartArea.Select
    .Paste
    .Export Yol 'nereye çıkartılacaksa
    .Parent.Delete
End With
'.Delete
End With
Set jipeg = Nothing
Set obce = Nothing
End Sub

Teşekkür ederim Ömer bey