Excel'deki resimleri isimlendirerek dışarıya çıkartma

[moonty]

Arkadaşlar merhaba, bir kamu kurumunda görev yapıyorum. Bizim yıllardır excelde tutmuş olduğumuz personele ilişkin bir excel tablosu var. Birinci sütunda her hücrede kişinin fotoğrafı, yandaki ikinci sütunda ise her hücrede ilgilinin TC kimlik numarası var. Yeni bir sisteme geçeceğiz ve bizden tüm personelin (yaklaşık 2800 kişinin) TC kimlik no şeklinde isimlendirilmiş fotoğraflarını istediler. Normalde excelde fotoğrafları export etmek kolay ve bir çok yolu var bildiğiniz üzere. Ancak export edilen o fotoğrafları yandaki hücrede bulunan Tc kimlik no ile adlandırarak export etme noktasında sıkıntı yaşıyoruz. Buna uygun bir makro yazarak yardımcı olabilir misiniz acaba. Örnek dosya ektedir. (A2 hücresindeki fotoğraf klasöre çıkartıldığında fotoğrafın ismi B2 hücresindeki TC kimlik no olacak - "12345678912.jpeg" şeklinde) İlgilenen veya çözüm üreten arkadaşlara şimdiden çok teşekkür ediyorum. Saygılarımla.

Örnek dosya:

İndir deneme

Dosyayı indir deneme

dosya.co

 

[Haluk]

Resimler, bilgisayarda C:\TestFolder klasörüne kaydedilir....

Sub Test()
'   Haluk - 29/03/2021
    Dim objTemp As Object
    Dim chtMyChart As Chart
   
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
      Range("A" & i).Copy
      Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
      objTemp.Select
      ActiveSheet.Paste
      objTemp.Delete
     
      With Selection
          .CopyPicture 1, 2
          Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
          With chtMyChart
              .ChartArea.Border.LineStyle = xlNone
              .Paste
              .Export "C:\TestFolder\" & Range("B" & i).Text & ".jpg"
              .Parent.Delete
          End With
      .Delete
      End With
    Next
   
    MsgBox "Resimler aktarıldı..."
    Set objTemp = Nothing
End Sub

.

 

[moonty]

tşk ederim haluk hocam. çok makbule geçti. emeğinize sağlık

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Resimler boş olarak geliyor.
Saygılarımla

 

[Haluk]

Birşeyi yanlış yapıyorsunuz ama neyi, bilmiyorum....

.

 

[Tevfik_Kursun]

Merhaba,
Gönderdiğiniz dosyanın hiçbir noktasına dokunmadım. Diğerleri de örnekteki gibi.
Saygılarımla

 

[Haluk]

Bilemiyorum.... bende bir problem yok.

.

 

[Tevfik_Kursun]

Makinemi kapatıp açtım, durum değişmedi. F8 ile takip ettiğimde oluşan ektedir.
Lütfen israr ediyor diye düşünmeyin. Nedenini anlamaya çalışıyorum.
Saygılarımla

 

[Ömer]

Haluk Hocam;

Kodları çalıştırınca bende de boş resimler geldi. Yalnız F8 ile tek tek yapınca resimler doğru geliyor. Hata almadım.

"Win10 Pro 64 Bit, Excel 2016 Tr 64 Bit"

 

[Haluk]

Ömer bey, dediğim gibi .... maalesef bir fikrim yok.

MS Excel veya Windows'un saçmalığı herhalde ..... İkisini de kullanmamak lazım aslında.

Bendeki klasörün durumu böyle;






.

 

[Haluk]

Ömer Bey, problem sizdeki Excel versiyonundan kaynaklı gibi geliyor... Tevfik Beyin profilinde versiyon 2010 gözüküyor ama, eklediği ekran görüntüsü başka bir versiyon.

Her neyse.... aşağıdaki versiyon kontrolu yapılmış revizyon, problemi çözebilir, benim deneme şansım yok.

Sub Test()
'   Haluk - 29/03/2021
    Dim objTemp As Object
    Dim chtMyChart As Chart
  
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
      Range("A" & i).Copy
      Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
      objTemp.Select
      ActiveSheet.Paste
      objTemp.Delete
    
      With Selection
          .CopyPicture 1, 2
          Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
          
          If Int(Val(Application.Version)) >= 16 Then
            chtMyChart.Activate
          End If
          
          With chtMyChart
              .ChartArea.Border.LineStyle = xlNone
              .Paste
              .Export "C:\TestFolder\" & Range("B" & i).Text & ".jpg"
              .Parent.Delete
          End With
      .Delete
      End With
    Next
  
    MsgBox "Resimler aktarıldı..."
    Set objTemp = Nothing
End Sub

.

 

[Ömer]

Haluk Bey,

Son verdiğiniz kodları denediğimdeki hata resmini paylaşıyorum.





Ayrıca sizin ilk kodları aşağıdaki gibi revize ederek denedim bende çalıştı.

Sub test1()

    Dim son As Long, n As Shape, chtMyChart As Object

    son = Range("B" & Rows.Count).End(xlUp).Row

    For Each n In ActiveSheet.Shapes
        If Not Intersect(n.TopLeftCell, Range("A2:A" & son)) Is Nothing Then
            n.Select
            Selection.CopyPicture
            Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, n.Width, n.Height).Chart
            With chtMyChart
                .ChartArea.Select
                .Paste
                .Export "C:\TestFolder\" & n.TopLeftCell.Offset(0, 1).Text & ".jpg"
                .Parent.Delete
            End With
        End If
    Next

End Sub

 

[Tevfik_Kursun]

Sayın Ömer Hocam,
Sizin makro bende de çalıştı. Hem size hem de Haluk hocama çok teşekkür ederim.
Saygılarımla

 

[muygun]

Haluk Bey'in ilk verdiği kod (excel 2003-32 bit) sorunsuz çalıştı.