Seçilen alanı jpg olarak kaydetmek..

[EKREM1661]

Saygıdeğer Arkadaşlar.. (Hayırlı çalışmalar)

Elimde; excel.web.tr sitemizden edindiğim bir dosya var.. belli bir alanı jpg olarak c\de belirlenen bir klasöre kaydediyor..
Bunu mouse ile istenilen alanın seçilip de kaydedilebilecek bir şekle dönüştürebilir miyiz.. Şimdiden teşekkür ederek, söz konusu dosyayı ekliyorum..

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

İlave ve değişiklik kırmızı ile işaretli. Yeşil satır pasifleştirildi.

Sub CopyRangeToGIF()
    Dim rng As Excel.Range
    Dim cht As Excel.ChartObject
    [COLOR=red]Dim alan As String[/COLOR]
    Const strPath As String = "C:\rsm\"
    Application.ScreenUpdating = False
    [COLOR=red]alan = Selection.Address[/COLOR]
    For i = 1 To 4 'Sayfa sayısını buradan attırabilirsiniz.
       [COLOR=darkgreen]'Set rng = Sheets(i).Range("b2:b5")[/COLOR]
        [COLOR=red]Set rng = Sheets(i).Range(alan)[/COLOR]
        rng.CopyPicture xlScreen, xlPicture
        Set cht = Sheets(i).ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
        cht.Chart.Paste
        cht.Chart.Export strPath & "myfile" & i & ".jpg"
        cht.Delete
ExitProc:
        Application.ScreenUpdating = True
        Set cht = Nothing
        Set rng = Nothing
        Next
End Sub

 

[EKREM1661]

Saygıdeğer Ömer hocam.. Öncelikle teşekkür ederim.. istediğim oldu.. Ancak;
Örnek dosya içerisine yazmıştım.. Tüm sayfaların aynı alanlarını kopya yapıyor ve her tıklamada üzerine kopya yapıyor, önceki kopya yok oluyor...

Sadece bulunduğum sayfadan (Sayfa1) kopya yapsın ve her tıklama sonucu yaptığı her kopyaya ardışık sıra numarası versin dersek..bu mümkün olur mu..

 

[Ömer]

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

.

 

[EKREM1661]

Ömer bey..! Gerçekten güzel olmuş, ellerine sağlık.. Bu benim çok işimi görecek. Sadece bu değil, sizin çok yardımlarınızı bilirim, dolayısıyla minnettarım..

Hocam; konuyu size açmışken, ileri aşamasında hayal ettiğim uygulamayı bir örnekle dosya içerisinde ifade ettim. Uğraş verecek bir iş ise, sizi de yormak istemiyorum. En azından olup olmayacağını bilmiş olurum. Şöyle ki; resmi kaydederken, resimlerin aldığı bu sıra numarasını Sayfa2 A1 hücresinden aldırtabilir miyiz, diye..?

 

[Ömer]

Tam olarak anlayamadım.

cht.Chart.Export strPath & "myfile" & say & ".jpg"

yerine aşağıdaki kodu kullanırsanız, resimlerdeki sayı numarasını Sayfa2 A1 hücresinden alır.

cht.Chart.Export strPath & "myfile" & Sheets("Sayfa2").Range("A1") & ".jpg"

İstediğiniz bu mu?

 

[EKREM1661]

Hocam, süpersiniz..ve ancak bu kadar olur.. Sağlık ve muvaffakiyetler dileğiyle hoşça kalınız..

 

[EKREM1661]

Hocam nasıl desem, fazla rahatsızlık verdim, fakat, yapmak istediğim son bir şey kaldı.
Bu ekli excel uygulama dosyası ile birlikte, jpg kayıtları yapılan resim dosyasını personel isimli bir klasör içerisinde bulunduracağım . "C\rsm" adresi yerine nasıl bir düzenleme yaparız..

 

[Ömer]

Const strPath As String = "C:\rsm\"

yerine aşağıdaki satırı yazın.

Const strPath As String = "C:\personel\rsm\"

 

[EKREM1661]

Saygıdeğer Ömer hocam..! bu konu ile ilgili olarak, size inşallah son kez rahatsızlık veriyorum. Çünkü bu talebim ile birlikte projemi tamamlamış olacağım..

Eklediğim dosya içerisinde açıkladım.. Resim klasöründen, excel sayfasına resim çağırmak için yazılmış bir makro kodu (excel web.tr sitemizden alıntı ) uyarlanması gerekiyor..
Resmi diyalog kutusu ile arattırıyor, bunu makronun kendisine buldurtabilir miyiz..?

 

[Ömer]

Buldurabiliriz.

Sayfaya önce bir image nesnesi ekleyin ve aşağıdaki kodları kullanın. Bu şekilde çağırdığımız resmi bu nesne üzerinde görüntüleyebiliriz. Farklı yollarda var fakat bu şekilde kullanmanızı tavsiye ederim.

Image nesnesi eklemek için: Form çubuklarından "Formları" seçerek buradan "Görüntü" adındaki nesneyi işaretleyip sayfaya çizmeniz yeterli olur. Bu nesnenin Formlardaki şekli küçük bir resme benzer. Bulamazsanız ben eklerim. Yalnız iyice araştırıp siz eklerseniz farklı dosyalarda kullanırken zorluk çekmezsiniz.

Sub ResimCagir()
 
    Dim yol As String, adres As String
 
    yol = "C:\personel\rsm\"
    adres = yol & "myfile" & Sheets("Sayfa2").Range("A1") & ".jpg"
 
    With Sheets("Sayfa1").Image1
        .PictureSizeMode = fmPictureSizeModeZoom
        .Picture = LoadPicture("")
        .Picture = LoadPicture(adres)
    End With
 
End Sub

.

 

[EKREM1661]

Ömer hocam..! Dediğinizi yaptım, çok güzel oldu ve normal koşullarda sizin önerdiğiniz image nesnesi en ideali..(ilerisi için saklıyacağım bir kod oldu).. Fakat ben ne yapmak istediğimi biraz farklı olduğu için.. İmage nesnesi olmadan (direk sayfa üzerine), alınırsa daha iyi olacak..

Çünkü ben bunu gerektiğinde manuel olarak (sayfanın veya sayfadaki yazının durumuna göre) boyutlandıracağım ve sonra da çıktı alacağım. Anlıyacağın küçük tablo veya gragikleri resim olarak kaydedip, gerektiğinde geri çağırarak metin sonlarına ekleme yapacağım. Tabiiki yazının şekli ve boyutu değişeceği için duruma göre ayarlama yapılabilecek..

 

[asuzen]

Buldurabiliriz.

Sayfaya önce bir image nesnesi ekleyin ve aşağıdaki kodları kullanın. Bu şekilde çağırdığımız resmi bu nesne üzerinde görüntüleyebiliriz. Farklı yollarda var fakat bu şekilde kullanmanızı tavsiye ederim.

Image nesnesi eklemek için: Form çubuklarından "Formları" seçerek buradan "Görüntü" adındaki nesneyi işaretleyip sayfaya çizmeniz yeterli olur. Bu nesnenin Formlardaki şekli küçük bir resme benzer. Bulamazsanız ben eklerim. Yalnız iyice araştırıp siz eklerseniz farklı dosyalarda kullanırken zorluk çekmezsiniz.

Sub ResimCagir()
 
    Dim yol As String, adres As String
 
    yol = "C:\personel\rsm\"
    adres = yol & "myfile" & Sheets("Sayfa2").Range("A1") & ".jpg"
 
    With Sheets("Sayfa1").Image1
        .PictureSizeMode = fmPictureSizeModeZoom
        .Picture = LoadPicture("")
        .Picture = LoadPicture(adres)
    End With
 
End Sub

.

Hocam konuyu takip ediyordum. Belirttiğiniz Image nesnesini bulamadım bir türlü. Dediğiniz formlar çubuğunda görüntü diye bir nesne yok. Ya da ben yanlış bir yere bakıyorum. Sizde eklenmiş hali varsa paylaşabilir misiniz?
Bir de kodun "fmPictureSizeModeZoom" kısmı "Compile error: Variable not definied" şeklinde hata veriyor nedense.

 

[Ömer]

Image ve Resim eklenmiş dosyalar ayrı ayrı ektedir.

.

 

[asuzen]

Image ve Resim eklenmiş dosyalar ayrı ayrı ektedir.

.

Hocam çok teşekkür ederim ikisi de çok güzel çalışıyor. Ancak ben bu image nesnesi hakkında hiçbir şey bilmiyorum. Mevcut dosyadaki nesne, ne taşınabiliyor ne kopyalanabiliyor ne de silinebiliyor. Bu nesneyi nasıl ekleyip nasıl çıkartıyoruz ya da birden fazla ekleyebiliyor muyuz?
Dediğiniz formlar çubuğunda (Ekteki resim dosyasında da görüldüğü gibi) görüntü diye bir nesne yok. Muhtemelen ben yanlış yerde arıyorum. Bu konuda da yardımcı olabilirseniz sevinirim.

 

[Ömer]

Araç Çubukları / Denetim Araç Kutusu, seçeneğine girin. Buradan bulabilirsiniz. Image nesnesini düzenlemek içinse, yine Denetim Araç Kutusu seçeneğinde bulunan "Tasarım Modu" ( Çetvele benzer bir nesnedir ) seçeneğini seçerseniz nesne üzerinde düzenleme yapabilirsiniz.

 

[asuzen]

Hocam çok teşekkürler...

 

[EKREM1661]

Ömer hocam ..! İçtenlikle teşekkür ederim. Hoşça kalınız..

 

[EKREM1661]

Hocam..! Sayenizde çözümlenmiş bulunan, iş bu konu ile ilgili olarak öğrenmek istediğim;

1-Çağrılan resmi; ilgili makro ile boyutlandırılıyor..
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 20, 100, 50).Select
Bunda; boyutlandırma yapmadan, yani alan seçerek kaydedilen boyut ne ise, seçilen boyut ile kaydedilebilir mi?

2-Bir de; çağrılan resim kenarları, çizgi çerçeveli olarak geliyor, bu çizgi kaldırılabilir mi?

 

[Ömer]

Resim çağıran kodlar aşağıdakilerle değiştirin.

Sub ResimCagir()
 
    Dim yol As String, adres As String, rsm As Shape
 
    yol = "C:\personel\rsm\"
    adres = yol & "myfile" & Sheets("Sayfa2").Range("A1") & ".jpg"
 
    On Error Resume Next
    
    For Each rsm In ActiveSheet.Shapes
       If rsm.Name <> "*Resim*" Then rsm.Delete
    Next rsm
    
    ActiveSheet.Pictures.Insert adres
 
End Sub

.