Seçilen alanı jpg olarak kaydetmek..

[EKREM1661]

Ömer hocam..Gayet güzel oldu, fakat 1.nci satır üzerinde var olan butonları sildi yok etti.. bunun da bir çaresini bulsak, tamam olacak..

 

[Ömer]

Butonları görebilmem için küçük bir dosya eklermisiniz.

 

[EKREM1661]

Saygıdeğer hocam..! 21 nolu mesajımda, Resim Çağır kodunun çalışmasında, sayfa üstü butonları yok etmesi durumunda; butonları UserForm üzerine alınca kod'da değişiklik yapmaya gerek kalmadı, fakat yinede durumu görme açısından örnek dosya ekledim.. Bununla birlikte örnek dosyada;

1-Araçlar-Kamera aracı ile alınan resmin kenar çizgilerinin kaldırılabildiği, ancak JPG dosyasından çağrılan resmin kenar çizgilerinin kaldırılamadığının sebebini soracaktım.

2-Son olarak; çağrılan resmin B15 adresine getirilmesi gerekiyor..

 

[Ömer]

Sayfa çizgisi ile sorduğunuz sorudaki farklılığı şu şekilde açıklayayım.

Klasöre resim gönderirken önce grafik alanı çizip üzerine resim kopyalanıyor ve bu şekilde klasöre aktarılıyor. Bu yüzden kenarlıkları çizilen resim gibi değiştiremiyorsunuz.

Kenarlık için geleni değil, önce gideni çizgisiz yaparsak istediğimiz olur. ( İlave kırmızı ile işaretli )

Sub CopyRangeToGIF()
 
    Dim rng As Range, cht As ChartObject, say As Double, obj As Object
    Const strPath As String = "C:\rsm\"
 
    Application.ScreenUpdating = False
 
    Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
    say = obj.Files.Count + 1
 
    Set rng = Range(Selection.Address)
 
    rng.CopyPicture xlScreen, xlPicture
    Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
    [COLOR=red]cht.Border.LineStyle = 0[/COLOR]
    cht.Chart.Paste
    cht.Chart.Export strPath & "" & say & ".jpg"
    cht.Delete
 
ExitProc:
    Set obj = Nothing: Set rng = Nothing: Set cht = Nothing
    Application.ScreenUpdating = True
 
End Sub

Resmin B15 koordinatlarına gelmesi ve buton silinmesinin önlenmesi.

Sub ResimCagir()
 
    Dim yol As String, adres As String, rsm As Shape
    Dim a As Double, b As Double
 
    yol = "C:\rsm\"
    adres = yol & "" & Sheets("Sayfa2").Range("A1") & ".jpg"
 
    On Error Resume Next
 
    For Each rsm In ActiveSheet.Shapes
       If rsm.Name Like "*Picture*" Then rsm.Delete
    Next rsm
 
    ActiveSheet.Pictures.Insert adres
 
    With Range("B15")
        a = .Top
        b = .Left
    End With
 
    With ActiveSheet.Pictures
        .Top = a
        .Left = b
    End With
 
End Sub

.

 

[EKREM1661]

Saygıdeğer hocam..! Sizi de baya meşgul ettim, fakat kendi adıma da önemli bir konuyu sayenizde aşmış oldum.. İlginden ve sabrından dolayı müteşekkirim.. ALLAH razı olsun.. Sağlık ve müvaffakiyetler dileğiyle, hayırlı çalışmalar..

 

[EKREM1661]

Hocam..! Adres konusunda bir değişiklik yapmak istedim, fakat bir türlü düzenleyemedim..

Bazı uygulamalarda görüyorum..Makro içerisinde kullanılan yol adresini,

yol = "C:\rsm\"

gibi nokta tayin şeklinde değilde,
Adres kodunu; bulunduğu klasör içerisindeki klasöre yönlendiriyor. Örneğin;

yol = ThisWorkbook.Path & "\rsm\"

gibi.. Bundaki maksat; klasörün adresi konusunda daha özgür olmak için.. Aksi durumda, klasörün yeri değişince makro yol adresinde değiştirmek gerekiyor..
Bunu; bu şekilde yapabilir miyiz, hocam..

 

[Ömer]

Bu şekilde deneyin.

yol = ThisWorkbook.Path & "\"

.

 

[EKREM1661]

Ömer hocam..! Resim Çağır makrosunda sorun yok, uygulandı.. Fakat CopyRangeToGIF makrosunda;

Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
say = obj.Files.Count + 1

satırlarında takılıyor ve error5 hatası veriyor..
Yoksa; kaldırılan Const strPath As String = ...satırın da düzenlenmesi mi gerekiyor..

 

[Ömer]

Kodları aşağıdaki gibi değiştirin.

Sub CopyRangeToGIF()
 
    Dim rng As Range, cht As ChartObject, say As Double, obj As Object
    Dim strPath As String
 
    strPath = ThisWorkbook.Path & "\"
 
    Application.ScreenUpdating = False
 
    Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
    say = obj.Files.Count + 1
 
    Set rng = Range(Selection.Address)
 
    rng.CopyPicture xlScreen, xlPicture
   Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
    cht.Border.LineStyle = 0
    cht.Chart.Paste
    cht.Chart.Export strPath & "" & say & ".jpg"
    cht.Delete
 
ExitProc:
    Set obj = Nothing: Set rng = Nothing: Set cht = Nothing
    Application.ScreenUpdating = True
 
End Sub

.

 

[EKREM1661]

Ömer bey..! Ziyadesiyle tekrar tekrar teşekkür ediyorum.. Bu iyiliğinizi unutmayacağım..

 

[EKREM1661]

Ömer hocam..! Konuyu bu kadar uzatmak istememiş olmama rağmen tekrar size yönelmek zorunda kaldım. Malum ya, pürüzler kullandıkça ve zamanla ortaya çıkıyor..

Yukarıda ki VeriCagir kodu ile klasörden sayfaya resim çağrıldığı zaman; söz konusu resim nesnesi, adlandırma kutusunda, adının sonuna devamlı artan numara ekliyor. Örneğin; "Resim 49768..gibi (Dosya adı değil adlandırma kutusundaki adı)

Bu adı devamlı "Resim 1" adı ile anlandırarak sayfaya alabilir miyiz.. Ne gerek derseniz; "Resim 1" adına sabitlenmiş başka kodlar mevcut da onun için.. Böyle olursa, kodları revize etmekle uğraşmamış oluruz..

 

[Ömer]

Bu istediğinizi #14 numaralı mesajdaki dosyada bulabilirsiniz.

 

[EKREM1661]

Hocam..! En son oluşturulan 24 nolu mesajdaki ResimÇagir kodunun yapısını bozmadan, kodun içerisine Selection.Name="Resim 1" kodunu bir türlü entegre edemesem de (kod etkisiz durumda oluyor), size karşı da ayıp oldu, konuyu noktalıyorum. Her şey için teşekkürler..

 

[Ömer]

Bu şekilde deneyin.

Not: Sayfada eski resim varsa önce eski resmi sildikten sonra kodları çalıştırın.

Sub ResimCagir()
 
    Dim yol As String, adres As String, rsm As Shape
    Dim a As Double, b As Double
 
    yol = "C:\rsm\"
    adres = yol & "" & Sheets("Sayfa2").Range("A1") & ".jpg"
 
    On Error Resume Next
 
    For Each rsm In ActiveSheet.Shapes
       If rsm.Name [COLOR=blue]= "Resim 1"[/COLOR] Then rsm.Delete
    Next rsm
 
    ActiveSheet.Pictures.Insert adres
 
    With Range("B15")
        a = .Top
        b = .Left
    End With
 
    With ActiveSheet.Pictures
[COLOR=blue]        .Select[/COLOR]
[COLOR=blue]         Selection.Name = "Resim 1"[/COLOR]
        .Top = a
        .Left = b
    End With
[COLOR=blue]    Range("B15").Select[/COLOR]
 
End Sub

.

 

[EKREM1661]

Tamam işte çözüm bu...Bu pürüzden de kurtulduk.. Tekrar tekrar teşekkürler, Ömer hocam..!

 

[baydeniro]

Paylaşımlar için teşekkürler.

 

[CelikBey]

Ekrem bey,

İşlerimin yoğunluğu nedeniyle akşam yanıtlarım diye bırakmıştım fakat unutmuşum. Geçmişi kontrol ederken konuyu şimdi gördüm.

Sadece aktif sayfa için ve sıralı resim adları için kodları aşağıdaki gibi değiştirin.

Sub CopyRangeToGIF()
 
    Dim rng As Range, cht As ChartObject, say As Double, obj As Object
    Const strPath As String = "C:\rsm\"
 
    Application.ScreenUpdating = False
 
    Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
    say = obj.Files.Count + 1
 
    Set rng = Range(Selection.Address)
 
    rng.CopyPicture xlScreen, xlPicture
    Set cht =ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
    cht.Chart.Paste
    cht.Chart.Export strPath & "myfile" & say & ".jpg"
    cht.Delete
 
ExitProc:
    Set obj = Nothing: Set rng = Nothing: Set cht = Nothing
    Application.ScreenUpdating = True
 
End Sub

.

Merhabalar.

Yukarıda yazdığınız satırları, bir makro oluşturup kaydettim. Hatta 2 alttaki mesajınızda yazan düzeltmeyi de yaptım (dosya ismini bir hücreden almak istedim). Hücrelerimi de seçtim her defasında fakat makroyu çalıştırdığımda şu hatayı aldım:

Run-time error '1004':
Mathod 'paste' of object '_Chart' failed.

Yardımcı olabilir misiniz? Çok teşekkür ederim.

 

[BedriA]

Bu istediğinizi #14 numaralı mesajdaki dosyada bulabilirsiniz.

Ömer Hocam,

İmage nesnesine sayfadan çağrılan resmi, jpg formatında bilgisayara ihraç etmek mümkün mü?

 

[CelikBey]

Sorunumun çözümünü tam bulamamakla birlikte sorunu buldum gibi.
Office 2010'da denedim; bu başlıkta verilen örnekler çalışıyor fakat office 2016'da
chart Paste iştemi yapılamıyor. Daha doğrusu; jpg dosyası oluşuyor ama içi boş. Kopyalamıyor resmi içine.

Çözümünü bilen var mı?
Çok yardımcı olacaksınız...
Yardım

 

[cem116]

uzman yardımına ihtiyaç var..

Ekrem bey,

İşlerimin yoğunluğu nedeniyle akşam yanıtlarım diye bırakmıştım fakat unutmuşum. Geçmişi kontrol ederken konuyu şimdi gördüm.

Sadece aktif sayfa için ve sıralı resim adları için kodları aşağıdaki gibi değiştirin.

Sub CopyRangeToGIF()
 
    Dim rng As Range, cht As ChartObject, say As Double, obj As Object
    Const strPath As String = "C:\rsm\"
 
    Application.ScreenUpdating = False
 
    Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
    say = obj.Files.Count + 1
 
    Set rng = Range(Selection.Address)
 
    rng.CopyPicture xlScreen, xlPicture
    Set cht =ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
    cht.Chart.Paste
    cht.Chart.Export strPath & "myfile" & say & ".jpg"
    cht.Delete
 
ExitProc:
    Set obj = Nothing: Set rng = Nothing: Set cht = Nothing
    Application.ScreenUpdating = True
 
End Sub

.

Kıymetli üstadlar seçili alanları jpeg yapma ile ilgili bu konu başlığı altında katıkıda bulunan herkese çok teşekkürler öncelikle. Benim de aynı konuda iki isteğim ricam olacak, 1.si jpeg yaparak kaydettiğimiz dosyaya bizim istediğimiz alandan isim verebilir miyiz? 2. si benim sayfamda bir sayfada birden fazla alan var jpeg yapmak istediğimiz. Her defasında alan seçip jpeg yapmak yerine tek bir kodla istediğimiz jpeg donüştürme işlemlerinin hepsini gerçekleştirebilir miyiz?