Vba Projeyi Resim Olarak Kaydetme

[5rize3]

Merhaba arkadaşlar,

Sub foto()

Dim obce As Object, caart As Chart, jipeg As Range, yol As String, ds As Object
Set ds = CreateObject("Scripting.FileSystemObject")

Sheets("yrt").Select

yol = ThisWorkbook.Path & "\" & Range("N4").Value & ".jpeg"

If ds.FileExists(yol) = True Then
soru = MsgBox(yol & " dosyası zaten var. Üzerine yazılsın mı?", vbYesNo, "Dikkat")
If soru = vbNo Then
GoTo bitiş
End If
End If

Set jipeg = ActiveSheet.Range("A1:K27")
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
With caart
.Paste
.Export yol 'nereye çıkartılacak
.Parent.Delete
End With
.Delete
End With
bitiş:
Set jipeg = Nothing: Set obce = Nothing: Set ds = Nothing
End Sub

kodu denediğimde oluşan resim boş beyaz bir sayfadan ibaret oluyor. Acaba nerede bir eksiklik var .

belirlediğim alan kaydedince aşağıdaki görseldeki gibi boş olarak kaydediyor. Belirlediğim alandaki verileri kaydetmiyor.

Görsel

Yardımcı olursanız sevinirim.

İyi Çalışmalar Dilerim.

 

[Levent Menteşoğlu]

Aşağıdaki kodları deneyin.

Sub foto()

Dim obce As Object, caart As Object, jipeg As Range, yol As String, ds As Object
Set ds = CreateObject("Scripting.FileSystemObject")

Sheets("yrt").Select

yol = ThisWorkbook.Path & "\" & Range("N4").Value & ".jpeg"

If ds.FileExists(yol) = True Then
soru = MsgBox(yol & " dosyası zaten var. Üzerine yazılsın mı?", vbYesNo, "Dikkat")
If soru = vbNo Then
GoTo bitiş
End If
End If

Set jipeg = ActiveSheet.Range("A1:K27")
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)
With caart
.Activate
.Chart.Paste
.Chart.Export yol 'nereye çıkartılacak
.Delete
End With
.Delete
'.Shapes("resim").Delete
End With
bitiş:
Set jipeg = Nothing: Set obce = Nothing: Set ds = Nothing
End Sub

 

[5rize3]

Aşağıdaki kodları deneyin.

Sub foto()

Dim obce As Object, caart As Object, jipeg As Range, yol As String, ds As Object
Set ds = CreateObject("Scripting.FileSystemObject")

Sheets("yrt").Select

yol = ThisWorkbook.Path & "\" & Range("N4").Value & ".jpeg"

If ds.FileExists(yol) = True Then
soru = MsgBox(yol & " dosyası zaten var. Üzerine yazılsın mı?", vbYesNo, "Dikkat")
If soru = vbNo Then
GoTo bitiş
End If
End If

Set jipeg = ActiveSheet.Range("A1:K27")
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)
With caart
.Activate
.Chart.Paste
.Chart.Export yol 'nereye çıkartılacak
.Delete
End With
.Delete
'.Shapes("resim").Delete
End With
bitiş:
Set jipeg = Nothing: Set obce = Nothing: Set ds = Nothing
End Sub

Levent hocam çok teşekkür ederim. Allah razı olsun. çözüme kavuştu.