Bir hücre grubunu seçtikten sonra o seçilen alanı masaüstüne resim olarak kaydediyor. Gerçi çıktı biraz kalitesiz oluyor ama 1000 satırlık tablo için de deneme yaptım, yine aynı kalitesizliğe rağmen güzel sonuç veriyor aslında.
Option Explicit
Sub SecilenAlaniResimOlarakKaydet()
'--------------------------------------------------
'Değişkenler
'--------------------------------------------------
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Dim WshShell As Object
Dim strDesktop As String
'--------------------------------------------------
'Hazırlık
'--------------------------------------------------
Set rngImg = Selection
Set WshShell = CreateObject("WScript.Shell")
strDesktop = WshShell.SpecialFolders("Desktop") & "/"
rngImg.Copy
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 0)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete
'--------------------------------------------------
'Resim Oluştur
'--------------------------------------------------
With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
With chtMyChart
.Paste
.Export strDesktop & "\excel-alan-resim.jpg"
.Parent.Delete
End With
.Delete
End With
'--------------------------------------------------
'Bilgi Mesajı
'--------------------------------------------------
MsgBox "Resim oluşturuldu ve kaydedildi."
'--------------------------------------------------
'Değişken Temizle
'--------------------------------------------------
Set rngImg = Nothing
Set objTemp = Nothing
End Sub
Option Explicit
Sub SecilenAlaniResimOlarakKaydet()
'--------------------------------------------------
'Değişkenler
'--------------------------------------------------
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Dim WshShell As Object
Dim strDesktop As String
'--------------------------------------------------
'Görüntüsü alınacak alanı ayarla.
'--------------------------------------------------
Set rngImg = Selection
'--------------------------------------------------
'Masaüstü klasörünü dinamik olarak belirlemek
'için kullanacağımız nesne örneği.
'--------------------------------------------------
Set WshShell = CreateObject("WScript.Shell")
'--------------------------------------------------
'Masaüstü klasörünün tam yolunu al.
'--------------------------------------------------
strDesktop = WshShell.SpecialFolders("Desktop") & "/"
'--------------------------------------------------
'Alanı kopyalıyoruz.
'--------------------------------------------------
rngImg.Copy
'--------------------------------------------------
'Bir adet boyutları 1 olan bir şekil oluşturduk ve seçtik.
'Amacımız şekil oluşturmaktan ziyade Shape sınıfının
'özelliklerinden faydalanarak resim oluşturmak olacak.
'--------------------------------------------------
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 0)
objTemp.Select
'--------------------------------------------------
'Yukarıdaki kodlar çalıştıktan sonra bu yapıştırma işlemini
'yaptığımızda tam seçili alanın olduğu bölgenin hemen üstünde
'bir resim oluşuyor.
'--------------------------------------------------
ActiveSheet.Paste
'--------------------------------------------------
'Nesneyle işimiz bitti, siliyoruz.
'--------------------------------------------------
objTemp.Delete
'--------------------------------------------------
'Şimdi yukarıdaki kodlar çalıştıktan sonra
'alanımız seçili ama resmimiz de (sanki üzerine tıklanmış
'gibi) aktif olduğundan aktif seçim o. Bu yüzden Selection
'işlemi Range sınıfı yerine Picture sınıfına göre çalışacak.
'--------------------------------------------------
With Selection
'--------------------------------------------------
'Resmi kopyala.
'Function CopyPicture([Appearance As XlPictureAppearance = xlScreen],
' [Format As XlCopyPictureFormat = xlPicture])
'--------------------------------------------------
.CopyPicture 1, 2
'--------------------------------------------------
'Şimdi bu grafik nesnesi nereden çıktı ona bakalım.
'
'Aslında bizim grafikle de alakamız yok ama şu var:
'Bu grafikleri resim olarak dışarı çıkarabiliyoruz.
'Madem öyle bir şey var ben bunu kendi oluşturduğum
'resmi dışarı aktarmak için kullanırım. Temiz olur.
'--------------------------------------------------
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
'--------------------------------------------------
'Grafik nesnesinin örneğini oluşturduktan
'sonra birkaç işlem yaptırıyoruz.
'--------------------------------------------------
With chtMyChart
'--------------------------------------------------
'Oluşturduğumuz resmi grafik arka planı olarak
'çıkan nesneye yabıştırdık. Güzelcene yabışıyo o.
'--------------------------------------------------
.Paste
'--------------------------------------------------
'Masaüstüne excel-alan-resim.jpg olarak kaydettirdik.
'masaustu bir fonksiyon ve bu kodların hemen altında
'fonksiyonun kendisi var. İsterseniz siz bu fonksiyonu
'hiç karıştırmadan kendi yolunuzu ekleyebilirsiniz.
'--------------------------------------------------
.Export strDesktop & "\excel-alan-resim.jpg"
'--------------------------------------------------
'Grafik nesnesi için bir altyapı penceresi gibi
'bir pencere oluşuyor ya, biz ona resim ekledik
've dışarı çıkardık. İşimiz bittiği için artık onu
'silebiliriz.
'--------------------------------------------------
.Parent.Delete
End With
'--------------------------------------------------
'Seçtiğimiz alanın resmi var ya, bu da onu siliyor.
'--------------------------------------------------
.Delete
End With
'--------------------------------------------------
'Bilgi mesajı ver.
'--------------------------------------------------
MsgBox "Resim oluşturuldu ve kaydedildi."
'--------------------------------------------------
'Nesne örneklerini RAM'den temizle.
'--------------------------------------------------
Set rngImg = Nothing
Set objTemp = Nothing
End Sub