Excel deki resimleri kayıt etmek

[Mikdad]

s.a dostlarım,
6000 kişilik resimli bir excel dosyam var.
R Sutununda bulunan resimleri S sutununda bulanan isim ile bilgisayarda verdiğim bir klasöre kayıt etmek istiyorum.
örneğin
a b R S
Adı Soyadı Resim Sicil No
1 ali veli 0254563215545

kayıt diye bir button olsa ve kayıt et dediğimde c:\ProResimler adı altındaki klasöre
0254563215545.jpg diye kayıt edecek. ve 6000 kayıt için de aynı işlemi yapacak.

Hakkınızı Helal Edin.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Resim_Kaydet()

    Dim rsm As Shape, yol As String, sat As Long, grf As Object
    
    yol = "C:\ProResimler\"
    
    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

.

 

[Mikdad]

hocam Allah Razı Olsun ama şöyle bir hata alıyorum.

 

[Ömer]

Kodları sayfanın kod bölümüne değil, Insert menüsünden Module ekleyip bu bölüme yapıştırın.
Sayfadaki kodları silin.

 

[Mikdad]

Allah Razı Olsun Hocam Şuan Aktarmaya Başladı.6000 kaydı bakalım ne zaman aktaracak. hakkınızı tekrar helal edin.
Peki bunu bir buttonun altına sıra numarası bildirerek nasıl yapabiliriz.
örneğin:
1000 satırdan başlayıp 2000 inci satıra kadar olanı aktaracak şekilde

 

[Ömer]

Bu şekilde deneyin.

Sub Resim_Kaydet()

    Dim rsm As Shape, yol As String, sat As Long, grf As Object
    
    yol = "C:\ProResimler\"
    
    Application.ScreenUpdating = False

    For Each rsm In ActiveSheet.Shapes
        sat = rsm.TopLeftCell.Row
        [COLOR="Red"]If sat >= 1000 And sat <= 2000 Then[/COLOR]
            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
        [COLOR="red"]End If[/COLOR]
    Next rsm
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[Mikdad]

Hocam bu şekilde direk kod içinde yazıp çalıştıracağız. peki buttona tıklandığında
tümünümü aktarmak istiyorsunuz
belli aralığı mı diye sorsa
belli aralığı diyence iki kutucuk çıksa ve o kısma başlangıc ve bitiş sıra nolarını yazsak olur mu?

 

[Ömer]

Bu şekilde deneyin.

Sub Resim_Kaydet()
    
    Dim rsm As Shape, yol As String, sat As Long, grf As Object
    Dim sor1 As String, sor2 As String, ilk As Long, son As Double
    
    yol = "D:\ProResimler\"
    Application.ScreenUpdating = False
    

    sor1 = MsgBox("Tümünümü aktaracaksınız, yoksa belli bir aralığımı?" & Chr(10) _
        & Chr(10) & "Tümü İçin ... ""Evet"" butonunu kullanın" & Chr(10) _
        & Chr(10) & "Belli bir kısım için ""Hayır"" butonunu kullanın", vbCritical + vbYesNo, "Dikkat !")
        
    If sor1 = vbYes Then
        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
    End If
        
    If sor1 = vbNo Then
        sor2 = InputBox("Başlagıç ve Bitiş Satırını Arada Tire("" - "") Kullanarak Ve Boşluk " & _
            "Bırakmadan Girin Ve Ok Butonuna Basın." & Chr(10) & Chr(10) & "Örneğin 10-20 gibi.", "Aralık Belirleme")
            
        If sor2 = "" Then Exit Sub
        ilk = Split(sor2, "-")(0)
        son = Split(sor2, "-")(1)
        If ilk < 1 Then MsgBox "Biden küçük değer girilmez": Exit Sub
        If son > Rows.Count Then MsgBox "Satır sayısından büyük değer girilmez": Exit Sub
        
        On Error GoTo atla
        For Each rsm In ActiveSheet.Shapes
            sat = rsm.TopLeftCell.Row
            If sat >= ilk And sat <= son Then
                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
            End If
        Next rsm
        Exit Sub
atla:
        MsgBox "Hatalı Veri Girişi Yaptınız"
        
    End If
   
    Application.ScreenUpdating = True
 
End Sub

.

 

[Mikdad]

Allah Razı Olsun İnşallah, Hakkınızı Helal Edin Hocam

 

[Mikdad]

s.a hocam, yukardaki kodu kullandığım zaman resimdeki hatayı veriyor. yardımcı olursanız çok sevinirim.

 

[Ömer]

Hata aldığınız çalışmayı kodlarda içindeyken kaydedip ekler misiniz.

.

 

[Mikdad]

Selamun Aleykum dostlarım,
yukardaki kodu daha önce kullandım sıkıntı olmadı. ama şuan kullanmak istediğimde resimleri aktarıyor ama resimler boş geçiyor. sorun ne olabilir acaba. örnek oluşturduğu resimlerden bir tanesini ekte sunuyorum.

 

[Mikdad]

Hata aldığınız çalışmayı kodlarda içindeyken kaydedip ekler misiniz.

.

Selamun Aleykum Dostlarım, örnek dosyayı ekte sundum, resimleri bir türlü aktaramadım. bu konuda yardımcı olurmusunuz. hatanın nereden kaynaklandığını bildirebilirseniz çok sevinirim.

 

[merakli_72]

Selam,
ekteki şekilde denermisiniz

Sub Resim_Kaydet()

Dim rsm As Shape, yol As String, sat As Long, grf As Object

yol = "C:\ProResimler\"

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, "B") & ".jpg" grf.Delete
Next rsm

Application.ScreenUpdating = True

End Sub

 

[Mikdad]

Selam,
ekteki şekilde denermisiniz

Sub Resim_Kaydet()

Dim rsm As Shape, yol As String, sat As Long, grf As Object

yol = "C:\ProResimler\"

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, "B") & ".jpg" grf.Delete
Next rsm

Application.ScreenUpdating = True

End Sub

hocam hata veriyor S Sütününu ben B sutun yaptığım zaman sicil numarası ile resim oluşturuyor. ama A hücresindeki resmi almıyor. boş bir resim atıyor. onu da ekte sunuyorum.

 

[merakli_72]

grf.Delete
bir alt satırda olacaktı, kopyalarken yanlışlık olmuş
14 nolu posta eklediğim dosyayı indirip denermisiniz,
bu örnek bende sorunsuz çalışıyor
eğer sizde çalışmazsa sorun kodlardan değil başka birşeyden demektir,
hata mesajınıda yollarsınız

 

[Mikdad]

grf.Delete
bir alt satırda olacaktı, kopyalarken yanlışlık olmuş
14 nolu posta eklediğim dosyayı indirip denermisiniz,
bu örnek bende sorunsuz çalışıyor
eğer sizde çalışmazsa sorun kodlardan değil başka birşeyden demektir,
hata mesajınıda yollarsınız

Selamun Aleykum Hocam, Post 14 teki dosyayı indirdim tekrar. grf.delete alt satırda
denediğim zaman hiç bir hata mesajı vermiyor. ama resimleri oluştururken isimleri doğru bir şekilde sicilleri kopyalıyor. ama resim boş oluşturduğu resimleri ekte veriyorum. sorun ne olabilir acaba

 

[Mikdad]

Selamun Aleykum Hocam, Aynı Dosyayı Ben office 2010 kurulu Farklı Bir Bilgisayarda Denedim Sizin de söylediğiniz gibi sorunsuz bir şekilde çalıştı. ama benim bilgisayarda Office 2016 var onda çalışmadı. bunun sorunu ne olabilir acaba

 

[turist]

Ekli dosyayı deneyiniz.

 

[Mikdad]

Ekli dosyayı deneyiniz.

hocam office 2010 ile çalışıyor ama bende ofice 2016 var onda resimleri boş bir şekilde aktarıyor.
bu sorunu nasıl çözebiliriz