Excel Sayfayı Resim Olarak Kayıt Etmek

[aras10]

Merhaba arkadaşlar excelde makro ile A1:U23 hücreleri arasında bulunan görüntüyü butona tıklayarak ekran görüntüsü (screenshot) olarak masaüstünde bir klasöre kayıt etmek istiyorum böyle birşey mümkün müdür?

Yani kısacası excelde sayfamda bulunan butona tıklayınca A1:U23 hücreleri arasındaki görüntüyü resim olarak masaustunde bır klasore kayıt edecek.

Şimdiden cevaplarınız için teşekkürler.

 

[leumruk]

Selamlar,
Linki inceleyiniz.
http://www.excel.web.tr/f50/excel-tablosunu-jpeg-olarak-kaydetmek-t127827.html

 

[aras10]

Selamlar,
Linki inceleyiniz.
http://www.excel.web.tr/f50/excel-tablosunu-jpeg-olarak-kaydetmek-t127827.html

malesef linkte bulunan kodlar çalışmıyor run time error hatası alıyorum zip halindeki dosyalarıda indiremiyorum gold ğye olmadığım için

 

[leumruk]

Merhaba,
Doğrudan masaüstüne kopyalıyor. Klasör içine kopyalamak için masaüstünüzdeki klasör adını Export kısmındaki dosya yoluna ekleyiniz.

Sub foto()
Dim obce As Object
Dim caart As Chart
Dim jipeg As Range
masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
Set jipeg = ActiveSheet.Range("A1:U23")
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
Range("a1").Select
With caart
.Paste
.Export masaustu & "\test.jpg" 'nereye çıkartılacaksa
.Parent.Delete
End With
.Delete
End With
Set jipeg = Nothing
Set obce = Nothing
End Sub

 

[aras10]

Merhaba,
Doğrudan masaüstüne kopyalıyor. Klasör içine kopyalamak için masaüstünüzdeki klasör adını Export kısmındaki dosya yoluna ekleyiniz.

Sub foto()
Dim obce As Object
Dim caart As Chart
Dim jipeg As Range
masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
Set jipeg = ActiveSheet.Range("A1:U23")
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
Range("a1").Select
With caart
.Paste
.Export masaustu & "\test.jpg" 'nereye çıkartılacaksa
.Parent.Delete
End With
.Delete
End With
Set jipeg = Nothing
Set obce = Nothing
End Sub

çok teşekkür ederim kod çalışıyor son bir ricam daha var peki birden fazla kez resim kayıt etmem gerekiyor sadece test.jpg adında kaydettıgı ıcın sonrakı kayıt edılen resımlerıde bu resmın uzerıne yazıyor. kayıt edılen resımlerın ısımlerı 1-2-3-4-5 seklınde kayıt edebılırmı? örneğin bir resım kayıt ettiğimde adı test.jpg oluyor 2.ci bir resım kayıt ettıgımdede test.jpg nın uzerıne yapıstırıyor test.jpg resmı zaten varsa dıger kayıt ettıgımı test1.jpg test2.jpg olarak kayıt edebılır mı?

 

[leumruk]

İsteğiniz farklı şekillerde yapılabilir. Fikir vermesi açısından döngü yoluyla dosya ismi kontrolü yaptım. 20000 dosya olarak ayarladım. Azaltabilir ya da artırabilirsiniz.

Sub foto()
Dim obce As Object
Dim caart As Chart
Dim jipeg As Range
masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
ad = "test"
For x = 1 To 20000
    If Dir(masaustu & "\" & "ad" & x & ".jpg") = "" Then
        yol = masaustu & "\" & "ad" & x & ".jpg"
        Exit For
    End If
Next
Application.ScreenUpdating = False
Set jipeg = ActiveSheet.Range("A1:U23")
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
Range("a1").Select
With caart
.Paste
.Export yol 'nereye çıkartılacaksa
.Parent.Delete
End With
.Delete
End With
Set jipeg = Nothing
Set obce = Nothing
End Sub

 

[aras10]

Sub foto()
Dim obce As Object
Dim caart As Chart
Dim jipeg As Range
masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
Application.ScreenUpdating = False
For x = 1 To 5
Set jipeg = ActiveSheet.Range("A1:U23")
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
Range("a1").Select
With caart
.Paste
.Export masaustu & "\" & x & ".jpg" 'nereye çıkartılacaksa
.Parent.Delete
End With
.Delete
End With
Set jipeg = Nothing
Set obce = Nothing
Next
End Sub

Çok teşekkür ederim hocam ancak sımdı butona 1 kez tıkladıgımda aynı resmı bes kez kayıt edıyor kayıt edecegım resımler farklı farklı olacagı ıcın ılk kayıta 1 ıkıncı kayıta 2 olarak adlandırabılır mı? farklı farklı resımler kayıt edecegım ıcın 1.jpg var ise 2.jpg, 2.jpg var ise 3.jpg olarak kayıt etmesı mumkun mu?

 

[leumruk]

Sonradan farkettim, kodu güncelledim. 6. mesajı yeniden inceleyiniz.

 

[aras10]

Sonradan farkettim, kodu güncelledim. 6. mesajı yeniden inceleyiniz.

Allah razı olsun hocam yardımlarınız için çok teşekkür ederim.

 

[leumruk]

Allah razı olsun hocam yardımlarınız için çok teşekkür ederim.

Rica ederim.