Vba Projeyi Resim Olarak Kaydetme

Katılım
25 Kasım 2019
Mesajlar
11
Excel Vers. ve Dili
Excel 2021, Türkçe
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

Administrator
Yönetici
Admin
Katılım
13 Ekim 2004
Mesajlar
16,057
Excel Vers. ve Dili
Excel 2010-32 bit-Türkçe
Excel 365 -32 bit-Türkçe
Aşağıdaki kodları deneyin.

Kod:
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
 
Katılım
25 Kasım 2019
Mesajlar
11
Excel Vers. ve Dili
Excel 2021, Türkçe
Aşağıdaki kodları deneyin.

Kod:
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.
 
Üst