• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

excelden döngü ile resim kaydetme

Z

zahitsen

Katılım
22 Kasım 2012
Mesajlar
102
Excel Vers. ve Dili
excel 2007
türkçe
İyi günler arkadaşlar benim excel dosyamda a sutununda her hücrede resmim var b şutunundada isimleri yazıyor aşağıdaki kod bilgisayarıma bu resimleri jpeg olarak kaydediyor yalnız benim a1 den a150 ye kadar resmim var hepsi için tek tek kod yazmam uzun sürecek resim isimleri de b1 den b 150 ye kadar bi döngü oluşturmam gerekiyor tek seferde bütün resimleri kaydetmem lazım yardımlarınızı bekliyorum.


Kod: 
Sub security()
  Dim objTemp As Object
  Dim chtMyChart As Chart
  Dim rngImg As Range
  Dim No As Long
  Dim TempName As String
  No = Range("AA1") + 1
  Range("AA1") = No
  Range("AA1").NumberFormat = "000"
  Set rngImg = Range("A1:A2")
  rngImg.Copy
  Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
  objTemp.Select
  ActiveSheet.Paste
  objTemp.Delete
  TempName = "\\Dolu2008\doluortak\ÜRETİM ORTAK\resimler1\" & Range("B1").Text & ".jpg"
  With Selection
      .CopyPicture 1, 2
      Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
  With chtMyChart
      .Paste
      .Export TempName
      .Parent.Delete
  End With
  .Delete
  End With
  MsgBox "Resim, " & TempName & " olarak kaydedildi...", , "                    Security"
  Set rngImg = Nothing
  Set objTemp = Nothing
End Sub
 
kod:

Kod: 
Sub resimkaydet()
Dim sat1
sat1 = 0
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Application.DisplayAlerts = False
sat = Picture.BottomRightCell.Row
dosyaadı = Cells(sat, 2).Value & ".jpg"

ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Shapes(Picture.Name).CopyPicture
SavePicture PastePicture, Kaynak & dosyaadı

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:5"))
MsgBox "devam et"
'Exit Sub
sat1 = 0
End If
End If

Next Picture

Application.DisplayAlerts = True
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 
halit3' Alıntı:
kod:

Kod: 
Sub resimkaydet()
Dim sat1
sat1 = 0
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Application.DisplayAlerts = False
sat = Picture.BottomRightCell.Row
dosyaadı = Cells(sat, 2).Value & ".jpg"

ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Shapes(Picture.Name).CopyPicture
SavePicture PastePicture, Kaynak & dosyaadı

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:5"))
MsgBox "devam et"
'Exit Sub
sat1 = 0
End If
End If

Next Picture

Application.DisplayAlerts = True
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Genişletmek için tıkla ...



ŞU ŞEKİLDE YAPTIM AMA RUN TİME -424 DİYE BİR HATA ALIYORUM NE DENİ NE OLABİLİR ACABA


Kod: 
Sub resimkaydet()
Dim sat1
sat1 = 1

Kaynak = "\\Dolu2008\doluortak\ÜRETİM ORTAK\resimler1\"

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Application.DisplayAlerts = False
sat = Picture.BottomRightCell.Row
dosyaadı = Cells(sat, 2).Value & ".jpg"

ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Shapes(Picture.Name).CopyPicture
SavePicture PastePicture, Kaynak & dosyaadı

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("00:00:10"))
MsgBox "devam et"
'Exit Sub
sat1 = 0
End If
End If

Next Picture

Application.DisplayAlerts = True
MsgBox "işlem tamam"



End Sub
 
zahitsen' Alıntı:
ŞU ŞEKİLDE YAPTIM AMA RUN TİME -424 DİYE BİR HATA ALIYORUM NE DENİ NE OLABİLİR ACABA
Genişletmek için tıkla ...

Bu hata bir kaç sebep ten kaynaklanıyor olabilir hedef klasörün var olup olmadığı veya izin yasağı bulunup bulunmadığı yada sayfadaki resim nesnelerine ait isimler olmadığından veya nesnelerin yapısı farklı olabilir.

örnek dosyanızın küçük bir kısmını buraya ekleyin bakalım.
 
halit3' Alıntı:
Bu hata bir kaç sebep ten kaynaklanıyor olabilir hedef klasörün var olup olmadığı veya izin yasağı bulunup bulunmadığı yada sayfadaki resim nesnelerine ait isimler olmadığından veya nesnelerin yapısı farklı olabilir.

örnek dosyanızın küçük bir kısmını buraya ekleyin bakalım.
Genişletmek için tıkla ...

ilginiz için teşekkürler dosya ekte.
 

Ekli dosyalar

zahitsen' Alıntı:
ilginiz için teşekkürler dosya ekte.
Genişletmek için tıkla ...

Kodları gönderirken eksik göndermişim birde örnek dosyanızda aynı satırda ve sütünda iki resim nesnesi var kod bunları tek olarak algıladığından ben bunları a ve b olarak resim adına ilave yaparak çözdüm.
 

Ekli dosyalar

halit3' Alıntı:
Kodları gönderirken eksik göndermişim birde örnek dosyanızda aynı satırda ve sütünda iki resim nesnesi var kod bunları tek olarak algıladığından ben bunları a ve b olarak resim adına ilave yaparak çözdüm.
Genişletmek için tıkla ...

elinize sağlık ama şöyle bir problem var benim tek resimde ikisinin bir arada olması lazım ilk yazdığım kod onu yapıyordu çünkü ben açıklma hücresinine çektircem ikisinin tek resimde olması mümkün değil mi ilk yazdığım kodda ikisini beraber alıyordu çünkü.
 
Benim yazdığım kod resimleri kayıt yapıyor yukarıdaki bahsettiğiniz kod hücreyi resim olarak kayıt yapıyor.

sizin kodunuzu döngüye aldım buyurun.
kod en son dolu B sutunundaki değere göre çalışıyor.

kod:

Kod: 
Sub security2()
  Dim objTemp As Object
  Dim chtMyChart As Chart
  Dim rngImg As Range
  Dim No As Long
  Dim TempName As String

 For i = 1 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value & ".jpg"
  
  Set rngImg = Range("A" & i)
  rngImg.Copy
  Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
  objTemp.Select
  ActiveSheet.Paste
  objTemp.Delete
  TempName = "\\Dolu2008\doluortak\ÜRETİM ORTAK\resimler1\" & isim
  
  With Selection
      .CopyPicture 1, 2
      Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
  With chtMyChart
      .Paste
      .Export TempName
      .Parent.Delete
  End With
  .Delete
  End With
  Next
  MsgBox "işlem tamam"
  Set rngImg = Nothing
  Set objTemp = Nothing
End Sub
 
Arkadaşlar sonuç ne oldu anlayamadım.
Yb®
 
zahitsen' Alıntı:
şuan baktım ve süper oldu ellerine sağlık halit3 arkadaşımın sorun çözüldü tek hücreye 3 tane resim koyup aynı kodda kaydediyorum.
Genişletmek için tıkla ...

Teşekkürler iyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst