VBA ile Eklenen Fotoğrafı Dışarıya Aktarma

[fatiheryildiz]

Herkese merhabalar.. Aşağıdaki kod ile dosya içerisinde sayfa1 isimli sayfada bulunan fotoğrafı dışarıya aktaramıyorum.
Aslında daha doğrusu şöyle makroyu adım adım oynattığım zaman .Export Dosya alanınını işleyince aktarıyor ancak makroyu hızlı çalıştırdığı zaman aktaramıyorum.
Acaba nasıl bir işlem yapmak gerekir.

Sub resim_kaydet()

Dim objTemp As Object
Dim chtMyChart As Chart

Range("A1:L5").Copy

Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete

klasor = ThisWorkbook.Path
say = CreateObject("Scripting.FileSystemObject").GetFolder(klasor).Files.Count + 1
dosya = klasor & "\Resim " & say & ".jpg"


With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
With chtMyChart
.Paste
.Export dosya
.Parent.Delete
End With
.Delete
End With
MsgBox dosya & Chr(10) & " olarak kaydedildi.", , "UAYRI"

Set objTemp = Nothing
End Sub

 

[Biolightant]

Merhaba,
Kodlara açıklama ekledim.

Sub ResKaydet()
    Dim TargetAdres As Range ' Görüntüsü alınacak adres
    Dim say As Long ' Resim isminin hep farklı bir isim olması için bir sayı
    Dim FotoAdres As String ' Resmin kayıt edileceği adres
    Dim Grafik As ChartObject ' Resmi dışarıya çıkartmaya yarayan grafik
    
    ' Hedef aralık (görüntüsü kopyalanacak alan)
    Set TargetAdres = Range("A1:L5")
    
    ' Excel dosyasının içinde bulunduğu klasördeki toplam dosya sayısına 1 ekle
    say = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count + 1
    FotoAdres = ThisWorkbook.Path & "\Resim " & say & ".jpg"
    
    ' Hedef aralığı resim olarak kopyala
    TargetAdres.CopyPicture xlScreen, xlBitmap
    
    ' Grafik oluştur
    Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=1, Height:=1)
    
    With Grafik
        .Activate
        .Chart.Paste ' Resmi doğrudan grafiğin içine yapıştır
        .Width = TargetAdres.Width ' Hedef aralığın genişliği
        .Height = TargetAdres.Height ' Hedef aralığın yüksekliği
        .Chart.Export FotoAdres ' Resmi FotoAdres adresine kaydet
        .Delete ' Grafiği sil
    End With
    
    MsgBox FotoAdres & vbCrLf & " olarak kaydedildi.", vbInformation, "UYARI"
    
End Sub

 

[fatiheryildiz]

Merhaba,
Kodlara açıklama ekledim.

Sub ResKaydet()
    Dim TargetAdres As Range ' Görüntüsü alınacak adres
    Dim say As Long ' Resim isminin hep farklı bir isim olması için bir sayı
    Dim FotoAdres As String ' Resmin kayıt edileceği adres
    Dim Grafik As ChartObject ' Resmi dışarıya çıkartmaya yarayan grafik
   
    ' Hedef aralık (görüntüsü kopyalanacak alan)
    Set TargetAdres = Range("A1:L5")
   
    ' Excel dosyasının içinde bulunduğu klasördeki toplam dosya sayısına 1 ekle
    say = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count + 1
    FotoAdres = ThisWorkbook.Path & "\Resim " & say & ".jpg"
   
    ' Hedef aralığı resim olarak kopyala
    TargetAdres.CopyPicture xlScreen, xlBitmap
   
    ' Grafik oluştur
    Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=1, Height:=1)
   
    With Grafik
        .Activate
        .Chart.Paste ' Resmi doğrudan grafiğin içine yapıştır
        .Width = TargetAdres.Width ' Hedef aralığın genişliği
        .Height = TargetAdres.Height ' Hedef aralığın yüksekliği
        .Chart.Export FotoAdres ' Resmi FotoAdres adresine kaydet
        .Delete ' Grafiği sil
    End With
   
    MsgBox FotoAdres & vbCrLf & " olarak kaydedildi.", vbInformation, "UYARI"
   
End Sub

Hocam harika bir çalışma olmuş, elinize emeğinize sağlık..
Bu çalışmayı bir şahsıma ait bir ilan sitesinde 6 Şubat 2023 tarihinde yaşanan depremde hayatını kaybeden vatandaşlarımız için kullanacağım.

Elime ulaşan tüm isimler için bir anma ilanı listesi oluşturmayı planlıyorum. Bu desteklerinizden dolayı teşekkürler..

 

[Biolightant]

Bu çalışmayı bir şahsıma ait bir ilan sitesinde 6 Şubat 2023 tarihinde yaşanan depremde hayatını kaybeden vatandaşlarımız için kullanacağım.