resimleri klasöre save etmek

[ankara34]

iyi geceler

excel sayfamda png uzantılı resimlerim var ,
hepsinin başlangıç koordinatı a1 hücresinden başlıyor.

bu resimleri vba ile klasöre nasıl save ettirebiliriz .?

 

[Korhan Ayhan]

İnceleyiniz.

Arama Sonuçları

 

[ankara34]

İnceleyiniz.

Arama Sonuçları

Korhan bey , ilginiz için teşekkür ederim.
verdiğiniz linktekilerin bir kısmı hücrelerdeki resimleri kaydediyor,
emin değilim ama bir tanesi benim işim görecek gibi , kodlara fazla aşina değilim.
bundada nasıl yaptıysam ilkinde kayıtlı kalem resmini ilgili klasöre kalem resmi olarak kaydetti,
daha sonra ki denemelerimde kalem resmini BEYAZ resim olarak kaydediyor.

örnek dosyayı ekledim.
nerde hata yapmış olabilirim ?

webtr.xlsm dosyasını indir - download

webtr.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

Sub Resim_Kaydet() 
    Dim rsm As Shape, yol As String, sat As Long, grf As Object
    
    yol = "C:\Users\sami\"
    
    Application.ScreenUpdating = False

    For Each rsm In ActiveSheet.Shapes
        sat = rsm.TopLeftCell.Row
        rsm.Copy
        Set grf = ActiveSheet.ChartObjects.Add(0, 0, rsm.Width, rsm.Height)
        grf.Chart.Paste
        grf.Chart.Export yol & Cells(sat, "S") & ".jpg"
        grf.Delete
    Next rsm
    
    Application.ScreenUpdating = True
    
End Sub

 

[ankara34]

çok ilginç bi durum oldu

vba normal run dan çalıştırdığımda resim kaydetmiyor
ama F8 ile adım adım çalıştırdığımda resim kaydediliyor
neden olabilir çok ilginç bir durum ?

Sub Resim_Kaydet()
    Dim rsm As Shape, yol As String, sat As Long, grf As Object
    
    yol = "C:\Users\sami\"
    
    Application.ScreenUpdating = False

    For Each rsm In ActiveSheet.Shapes
        sat = rsm.TopLeftCell.Row
        rsm.Copy
        Set grf = ActiveSheet.ChartObjects.Add(0, 0, rsm.Width, rsm.Height)
        grf.Chart.Paste
        grf.Chart.Export yol & Cells(sat, "S") & ".jpg"
        grf.Delete
    Next rsm
    
    Application.ScreenUpdating = True
    
End Sub

 

[Korhan Ayhan]

İnceleyiniz.

Sorgu için arama sonuçları: chartobjects+beyaz

www.excel.web.tr

 

[ankara34]

Korhan bey , verdiğiniz linkteki yerlere baktım copy pate vs yaptım olmadı ,
kodların içerisinde kayboldum..

hata nerde ben bulamadım , yardımcı olursanız sevinirim

 

[ankara34]

Sub foto()
    Dim masaustu As String
    Dim ad As String
    Dim yol As String
    Dim caart As Chart
    Dim jipeg As Range
    Dim x As Long

    masaustu = "C:\Users\sami\"
    ad = "test"

  
    For x = 1 To 2000
        If Dir(masaustu & ad & x & ".PNG") = "" Then
            yol = masaustu & ad & x & ".PNG"
            Exit For
        End If
    Next x

    Application.ScreenUpdating = False

    Set jipeg = ActiveSheet.Range("A1:M21")
    jipeg.CopyPicture
 
    Set caart = ActiveSheet.ChartObjects.Add(1, 1, jipeg.Width, jipeg.Height).Chart
    caart.Paste

    caart.Export yol, "PNG"
    caart.Parent.Delete
    Application.ScreenUpdating = True

    Set jipeg = Nothing
    Set caart = Nothing
End Sub

en son boyle bır kod buldum
f8 ile çalıştırınca resmı kaydedıyor,
run ıle çalıştırınca beyaz renklı resım kaydedıyor

 

[Korhan Ayhan]

Küçük bir örnek dosya paylaşırsanız deneme fırsatımız olacaktır.

 

[ankara34]

Küçük bir örnek dosya paylaşırsanız deneme fırsatımız olacaktır.

Korhan bey altta var buyrun ,

webtr.xlsm dosyasını indir - download

webtr.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[Korhan Ayhan]

Linkte paylaştığım kodlardan faydalandım.

Eki deneyiniz..

"Makro Dosyası" isimli dosyayı açıp butona tıklayınız..

Not : Kodun çalışması için sisteminizde 64 Bit Winrar programının yüklü olması gerekir. Eğer sizde 32 bit yüklüyse makroda değişiklik yapmak gerekecektir.

Harici Link (Silinebilir) ; https://s2.dosya.tc/server25/9dktxa/Deneme.rar.html

 

[Asri]

F8 olmadan direkt bu kodu dener misiniz.

Sub foto()
    Dim masaustu As String
    Dim ad As String
    Dim yol As String
    Dim caart As Chart
    Dim jipeg As Range
    Dim x As Long

    masaustu = "C:\Users\sami\"
    ad = "test"


    For x = 1 To 2000
        If Dir(masaustu & ad & x & ".PNG") = "" Then
            yol = masaustu & ad & x & ".PNG"
            Exit For
        End If
    Next x

    Application.ScreenUpdating = False

    Set jipeg = ActiveSheet.Range("A1:M21")
    jipeg.CopyPicture

    Set caart = ActiveSheet.ChartObjects.Add(1, 1, jipeg.Width, jipeg.Height).Chart

    Application.Wait (Now + TimeValue("0:00:02"))
    caart.Paste
    Application.Wait (Now + TimeValue("0:00:02"))

    caart.Export yol, "PNG"
    caart.Parent.Delete
    Application.ScreenUpdating = True

    Set jipeg = Nothing
    Set caart = Nothing
End Sub

 

[ankara34]

Linkte paylaştığım kodlardan faydalandım.

Eki deneyiniz..

"Makro Dosyası" isimli dosyayı açıp butona tıklayınız..

Not : Kodun çalışması için sisteminizde 64 Bit Winrar programının yüklü olması gerekir. Eğer sizde 32 bit yüklüyse makroda değişiklik yapmak gerekecektir.

Harici Link (Silinebilir) ; https://s2.dosya.tc/server25/9dktxa/Deneme.rar.html

F8 olmadan direkt bu kodu dener misiniz.

Sub foto()
    Dim masaustu As String
    Dim ad As String
    Dim yol As String
    Dim caart As Chart
    Dim jipeg As Range
    Dim x As Long

    masaustu = "C:\Users\sami\"
    ad = "test"


    For x = 1 To 2000
        If Dir(masaustu & ad & x & ".PNG") = "" Then
            yol = masaustu & ad & x & ".PNG"
            Exit For
        End If
    Next x

    Application.ScreenUpdating = False

    Set jipeg = ActiveSheet.Range("A1:M21")
    jipeg.CopyPicture

    Set caart = ActiveSheet.ChartObjects.Add(1, 1, jipeg.Width, jipeg.Height).Chart

    Application.Wait (Now + TimeValue("0:00:02"))
    caart.Paste
    Application.Wait (Now + TimeValue("0:00:02"))

    caart.Export yol, "PNG"
    caart.Parent.Delete
    Application.ScreenUpdating = True

    Set jipeg = Nothing
    Set caart = Nothing
End Sub

ilgi ve alakanız için teşekkür ederim.

pc de bi problem mevcut düzeltir düzeltmez deneyeceğim ..