Sayfada yer alan gruplandırılmış şekli resim olarak kaydetme

[pNouma]

Kıymetli Hocalarım merhaba,
Ekli dosyada resim üzerine metinler eklemek suretiyle "grup" olarak oluşturulan şekli;
aşaıdaki kod burada göründüğü şekliye resim olarak kaydetmek istiyorum ama; boş beyaz bir sayfa geliyor.

https://dosya.co/fmt48scaisam/Kitap1.xlsm.html

yardımlarınız için şimdiden teşekkürler,
iyi hafta sonları ....

Sub SaveImage()
    Dim WS As Worksheet
    Dim myPath As String
    Dim myFile As String
   
    Set WS = ActiveSheet
    Set shp = WS.Shapes.Range(Array("Grup4"))

myPath = ThisWorkbook.Path
myFile = myPath & "\Test.jpg"

    Set ch = WS.ChartObjects.Add(shp.Left, shp.Top, shp.Width, shp.Height)
    shp.Select
    Selection.Copy

    ch.Chart.Paste
    Set tt = ch.Chart

    tt.Export Filename:=myFile, filtername:="JPG"

    ch.Delete

End Sub

 

[pitchoute]

Merhaba, iyi haftasonları iyi çalışmalar hocam;

Sub SaveImage()
    Dim WS As Worksheet
    Dim myPath As String
    Dim myFile As String
    Dim shp As Shape
    Dim ch As ChartObject
    
    Set WS = ActiveSheet
    
    On Error Resume Next
    Set shp = WS.Shapes("Grup4")
    On Error GoTo 0
    
    If shp Is Nothing Then
        MsgBox "Grup4 adında bir şekil bulunamadı!", vbCritical
        Exit Sub
    End If

    myPath = ThisWorkbook.Path & "\"
    myFile = myPath & "Test.jpg"
    
    Set ch = WS.ChartObjects.Add( _
    Left:=shp.Left, _
    Top:=shp.Top, _
    Width:=shp.Width, _
    Height:=shp.Height _
)
    
    shp.Copy
    ch.Activate
    ch.Chart.Paste
    ch.Chart.Export Filename:=myFile, Filtername:="JPG"
    
    ch.Delete
    MsgBox "Resim başarıyla kaydedildi: " & myFile, vbInformation
End Sub

 

[pNouma]

Merhaba, iyi haftasonları iyi çalışmalar hocam;

Sub SaveImage()
    Dim WS As Worksheet
    Dim myPath As String
    Dim myFile As String
    Dim shp As Shape
    Dim ch As ChartObject
   
    Set WS = ActiveSheet
   
    On Error Resume Next
    Set shp = WS.Shapes("Grup4")
    On Error GoTo 0
   
    If shp Is Nothing Then
        MsgBox "Grup4 adında bir şekil bulunamadı!", vbCritical
        Exit Sub
    End If

    myPath = ThisWorkbook.Path & "\"
    myFile = myPath & "Test.jpg"
   
    Set ch = WS.ChartObjects.Add( _
    Left:=shp.Left, _
    Top:=shp.Top, _
    Width:=shp.Width, _
    Height:=shp.Height _
)
   
    shp.Copy
    ch.Activate
    ch.Chart.Paste
    ch.Chart.Export Filename:=myFile, Filtername:="JPG"
   
    ch.Delete
    MsgBox "Resim başarıyla kaydedildi: " & myFile, vbInformation
End Sub

Çok teşekkür ederim Hocam
iyi akşamlar...

 

[pNouma]

Çok teşekkür ederim Hocam
iyi akşamlar...

Hocam ekli dosyada görüleceği gibi, kayıt yapıldığı zaman resim üzerine eklenen metinlerde bir miktar kayma olmakta;
bu durumu önlemenin bir yolu var mıdır?
özetle ekran görüntüsü alınmış gibi olabilir mi?

https://dosya.co/72othl8jqtbb/Kitap1.xlsm.html

her şey için tekrar teşekkürler,

 

[pitchoute]

Merhaba, PNG formatında kaydederek ve çözünürlük arttırılarak sorun çözülür. Bu şekilde dener misiniz;

Sub SaveImage()
    Dim WS As Worksheet
    Dim myPath As String
    Dim myFile As String
    Dim shp As Shape
    Dim ch As ChartObject
    
    Set WS = ActiveSheet
    
    On Error Resume Next
    Set shp = WS.Shapes("Grup4")
    On Error GoTo 0
    
    If shp Is Nothing Then
        MsgBox "Grup4 adında bir şekil bulunamadı!", vbCritical
        Exit Sub
    End If
    
    myPath = ThisWorkbook.Path & "\"
    myFile = myPath & "Test.png"
    
    Set ch = WS.ChartObjects.Add( _
        Left:=shp.Left, _
        Top:=shp.Top, _
        Width:=shp.Width, _
        Height:=shp.Height _
    )
    
    shp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ch.Activate
    ch.Chart.Paste
    ch.Chart.Export Filename:=myFile, Filtername:="PNG"
    ch.Delete
    MsgBox "Resim başarıyla kaydedildi: " & myFile, vbInformation
End Sub

 

[pNouma]

Merhaba, PNG formatında kaydederek ve çözünürlük arttırılarak sorun çözülür. Bu şekilde dener misiniz;

Sub SaveImage()
    Dim WS As Worksheet
    Dim myPath As String
    Dim myFile As String
    Dim shp As Shape
    Dim ch As ChartObject
   
    Set WS = ActiveSheet
   
    On Error Resume Next
    Set shp = WS.Shapes("Grup4")
    On Error GoTo 0
   
    If shp Is Nothing Then
        MsgBox "Grup4 adında bir şekil bulunamadı!", vbCritical
        Exit Sub
    End If
   
    myPath = ThisWorkbook.Path & "\"
    myFile = myPath & "Test.png"
   
    Set ch = WS.ChartObjects.Add( _
        Left:=shp.Left, _
        Top:=shp.Top, _
        Width:=shp.Width, _
        Height:=shp.Height _
    )
   
    shp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ch.Activate
    ch.Chart.Paste
    ch.Chart.Export Filename:=myFile, Filtername:="PNG"
    ch.Delete
    MsgBox "Resim başarıyla kaydedildi: " & myFile, vbInformation
End Sub

Çok teşekkür ederim Hocam Bu şekilde daha düzgün oldu.
iyi pazarlar...

 

[pitchoute]

Rica ederim hocam, iyi çalışmalar