Hücreleri Resim olarak kaydetmek

[ozgretmen]

İyi akşamlar arkadaşlar ;
Biraz TUHAF bir soru olacak ama merak ediyorum da.Diyelimki B2:J10 da veriler var bu kısmı resim olarak bir dosyaya kaydedecek bir macro var mı ?
İyi çalışmalar..

 

[Zeki Gürsoy]

Daha önce de bu konu işlendiği için pek tuhaf sayılmaz.

Sub Hucre_ScreenShot()
'ChartObjects.Add(Left, Top, Width, Height)
Dim Pic As Picture, graf As Chart
    
    On Error Resume Next
    Kill "C:\Hücreresim.jpg"
    
    Range("B2:J10").CopyPicture
    
    Set Pic = ActiveSheet.Pictures.Paste
    
    With Pic
        .Copy
        .Delete
    End With
    
Set graf = ActiveSheet.ChartObjects.Add(1, 1, 700, 200).Chart
    
    With graf
        .Paste
        .Export "C:\Hücreresim.jpg"
        .Parent.Delete
    End With
    
End Sub

 

[ozgretmen]

Teşekkürler arkadaşım.Peki bu resmi istediğimiz dosyaya istediğimiz bir adla kaydettirebilirmiyiz ?

 

[ECYavuz]

Sayın Anemos'un yazdığı kodlardaki

Kill "C:\Hücreresim.jpg"
ve
.Export "C:\Hücreresim.jpg"

satırlarında yer alan kısımdan (Hücreresim) istediğiniz ismi yazabilirsiniz.

 

[ozgretmen]

demek istediğim şey o değildi sayın ECYavuz Bey ! Makroyu çalıştırdığımda EXCELDEKİ gibi bir farklı kaydet seçeneği çıksın ve yerini ve adını seçip kaydedeyim.
Saygılar

 

[halilbay2]

Merhabalar
Farklı bir hücre resmi çekme yoluda Excel in kendi yöntemidir.
Ekteki resimden de anlaşılacağı gibi özelleştir menüsü açılır Komtlar/Araçlar/Kamera menüsü mausun sol tuşu ile tutulup yine resimde olduğu gibi yardım menüsünün yanına sürüklenip bırakılır. Özelleştir menüsünden çıkılır.
Resmini çekmek istediğiniz hücreler seçilerek kamera ya tıklanır, herhangi bir resim programı açılarak yapıştırılır. Resim programında istediğimiz isim verilerek kayıt yapılır.

 

[Zeki Gürsoy]

Teşekkürler arkadaşım.Peki bu resmi istediğimiz dosyaya istediğimiz bir adla kaydettirebilirmiyiz ?

Sub Hucre_ScreenShot()
'ChartObjects.Add(Left, Top, Width, Height)
Dim Pic As Picture, graf As Chart, FSO As Boolean
 
    DosyaAdi = Application.GetSaveAsFilename( _
                fileFilter:="Resim Dosyası (*.jpg), *.jpg")
 
    If DosyaAdi = False Then Exit Sub
    
    FSO = CreateObject("Scripting.FileSystemObject").FileExists(DosyaAdi)
    
    If FSO = True Then
        Kill DosyaAdi
    End If
    
    Range("B2:J10").CopyPicture
    
    Set Pic = ActiveSheet.Pictures.Paste
    
    With Pic
        .Copy
        .Delete
    End With
    
Set graf = ActiveSheet.ChartObjects.Add(1, 1, 700, 200).Chart
    
    With graf
        .Paste
        .Export DosyaAdi
        .Parent.Delete
    End With
    
End Sub

 

[halilbay2]

resim formatı farklı olduğu için almamış dikkat etmemişim özür dilerim

 

[ozgretmen]

Heekeze teşekkürler...anemos un kodları işime yaradı.halilbay2 ın önerdiği yöntem de güzel. Saygılar.iyi çalışmalar