Klasörden JPG Resim Çağrılması "Kodu"

[EKREM1661]

Saygıdeğer hocalarım..! Vaktiyle Moderatör Ömer hocamın, "Seçilen alanın JPG olarak kaydedilmesi ve kaydedildiği klasörden numarasına göre tekrar çağrılabilmesi" konusunda yazdığı makro kodunu kullanmaktaydım..

Ancak, 2010 Excel versiyonunda, klasörden çağrılan resmi boş olarak çağırıyor. Sanırım makro kodunda bir düzenleme gerekiyor. Bir bakabilirseniz, minnettarım..

Örnek dosyayı, mümkün olduğunca sade ve anlaşılır şekilde hazırlayarak ekledim..

 

[Korhan Ayhan]

İnceleyiniz.

Açıklama'ya makro ile Resim Almak

Merhaba, Ek'li dosyada Modül1'de kayıtlı makro ile ; "ANA_LİSTE" isimli sayfaya, "ALINACAK_ÇİZELGE" isimli sayfadaki A2:U48 aralığını, "ANA_LİSTE" G1 hücresine açıklama olarak almaya çalışıyorum, Makro hata vermemesine rağmen "G1" e resim olarak alamadım, boş geldi. Resim yolu, C:\RESİM...

www.excel.web.tr

 

[Ömer]

Merhaba,

Alternatif:

Sub alan_resim_kaydet()

    Dim dosya As String, alan As Range, Chrt As ChartObject, obj As Object, s As Long
 
    dosya = ThisWorkbook.Path & "\NsnJPG\"
    Set alan = Sheets("Sayfa1").Range(Selection.Address)
 
    Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(dosya)
    s = obj.Files.Count + 1
    
    alan.CopyPicture xlScreen, xlBitmap
    Set Chrt = ActiveSheet.ChartObjects.Add(1, 1, alan.Width, alan.Height)
 
    Chrt.Activate
    ActiveChart.Paste
    ActiveChart.Export dosya & s & ".jpg"
    Chrt.Delete
 
End Sub

 

[EKREM1661]

Korhan hocam..! Öncelikle teşekkürler.. Eklemiş olduğunuz örnek, bendeki konuya çok yakın, (bendeki sadece açıklama kutusuna değil de hücre alanına olması idi).. Buna rağmen uyarlamaya çalıştım, ancak yine boş olarak geliyor..

Ömer hocam..! Size de çok teşekkürler.. Eklediğim dosyadaki kodlar vakti zamanıyla size aitti.. Ancak yukarıdaki kod, resim çağırmadı..
Bir de eklenen JPG'lere kendisi sıra numarası veriyor. Normalde, numarayı VeriForm!A1 sayfasından alması lazım..
(Bu numara her işlem yaptıkça artan bir numara idi..) Önceki kod'da, aynı numara olursa üzerine yapıştırıyordu, yani çoğaltmıyordu..
Neticede, sayfadan aldığı numara ile isimlendiriliyordu ve resim çağırma işini, numaraya göre çağırıyordum..

 

[Korhan Ayhan]

Benim şuan kullandığım laptopta 2010 versiyon var. Kod sorun çıkmadan çalışıyor.

 

[Ömer]

Deneyiniz.

Sub CopyRangeToGIF()
 
    Dim dosya As String, alan As Range, Chrt As ChartObject, obj As Object, s As Long
 
    dosya = ThisWorkbook.Path & "\NsnJPG\"
    Set alan = Sheets("Sayfa1").Range(Selection.Address)
 
    'Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(dosya)
    's = obj.Files.Count + 1
    
    alan.CopyPicture xlScreen, xlBitmap
    Set Chrt = ActiveSheet.ChartObjects.Add(1, 1, alan.Width + 10, alan.Height + 10)
 
    Chrt.Activate
    ActiveChart.Paste
    ActiveChart.Export dosya & Sheets("VeriForm").Range("A1") & ".jpg"
    Chrt.Delete

End Sub

 

[EKREM1661]

Ömer hocam..! Küçük bir prüz dışında her şey tamam.. Sadece resim tekrar çağrıldığında (Sayfa2 butonu ile) alt ve sağ kenarlıkları çıkıyor.. Çok da önemli olmamakla birlikte, Nesnede alt ve sağ kenarlıkları kaldırılabilirse her şey tamam olacak..

Korhan hocam.. Benim ilk mesajda yüklediğim dosya çalışıyor ise, ?? Bilemiyorum.. Başka bilgisayarlarda deneyeceğim. Ama Ömer beyin en son kodu şimdi çalıştı..

 

[Ömer]

Set Chrt = ActiveSheet.ChartObjects.Add(1, 1, alan.Width + 10, alan.Height + 10)

+10 ları silerek deneyiniz.

 

[EKREM1661]

Ömer hocam, JPG tablonun alt ve sağ kısmında fazlalık vardı, o düzeldi..
(Küçük tabloları JPG olarak, Sayfa2'ye aktarımda sorun yok..
Sadece, Sayfa2'den JPG'yi silip, tekrar klasörden çağırınca, tablonun üst ve sol çizgilerini almıyor)
Ama çok da önemli değil, sorun halledildi sayılır, sizi uğraştırmak istemiyorum..
Ziyadesiyle teşekkürler hocam, elinize sağlık..