Otomatik Resim Ekleme

[anemis]

Merhabalar,

Ekli dosyada detaylıca anlatmaya çalıştım. İnşallah yeterli açıklamam olmuştur.

Özet olarak;
Bilgisayarımdaki herhangi bir klasördeki çokça resimi belirli bir düzende excel içine atmak istiyorum. (her bir resimi ekleneceği hücre pattern i aynı. Örneğin 01.jpg resmi B52:Y98 hücreleri arasında strechlenecek ise (bu hücreler birleştirilerek tek bir hücre de olabilir) 02.jpg resmi B52 den 50 satır sonra yani B102 ve Y98 den yine 50 satır sonra Y148 e yani B102:Y148 e gelmeli.
Aynı şekilde 03.jpg resmi yine 50 satır sonrasına B152:Y198 e gelmeli vs.

Onlarca resmi tek tek ekleyip çıktıya hazır hale getirmek inanılmaz yorucu olmaya başladı. Yardımcı olabilicek, fikir verebilecek herkese sonsuz teşekkürler.

 

[askm]

Resimleri sırası ile alması için sizin resimlerin isimlerini farklı bir sheete sırası ile alt alta yazmanız gerekir. Ya da öncelikle resim isimlerini başka bir sayfaya çektirip sıralam yaptırıp ona göre ekleme yapmak gerekir. (Bu şekilde belki istediğiniz sonucu tam olarak vermez.) Sonrasında belirttiğiniz gibi hücre birleştirip resim eklenebilir.

 

[anemis]

Değerli katkınız için teşekkür ederim sayın askm, resimlerin isimlerinin de bir şablonu var aslında, gerçi çok önemli de değil. gerekli ise isimleri bir sayfaya yada belli bir yere elle girebilirim. yada listeleme makrosu da bu işimi çöze diye düşünüyorum.

 

[askm]

Belirttiğiniz gibi isimleri girerek tekrar dosyanızı ekleyebilir misiniz?

 

[anemis]

Belirttiğiniz gibi isimleri girerek tekrar dosyanızı ekleyebilir misiniz?

Tabii ki,

Belirli bir formülasyonla excel dosyasının içine ekledim. Oradan zaten şablonu algılayabilirsiniz.

Zamanınız ve yardımınız için teşekkürler.

 

[askm]

Aşağıdaki kodları bir modüle yapıştırıp deneyin. Belirttiğiniz formatta değil de resim isimleri 01-02 şeklinde gittiğiniz varsayarak kod yazdım.

Sub askm()
Call Belirli_Bir_Alandaki_Resimleri_Sil
Klasor = ThisWorkbook.Path & "\"
On Error Resume Next
Satir = 52
For i = 1 To 6
    If i < 10 Then
        dosya = Klasor & "0" & i & ".jpg"
    Else
        dosya = Klasor & i & ".jpg"
    End If
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Select
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Merge
    ActiveSheet.Pictures.Insert(dosya).Select
    With Selection
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Top
            .Left = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Left
            .Width = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Width
            .Height = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Height
    End With
    Satir = Satir + 50
Next i
End Sub


Sub Belirli_Bir_Alandaki_Resimleri_Sil()
    Dim Resim As Picture, Alan As Range
    Set Alan = Range("B52:Y65536")
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
    Set Alan = Nothing
End Sub

 

[anemis]

Emeklerinize sağlık üstadım, ancak ne yazık ki modüle ekleyip çalıştır diyorum kodları, bir sonuç alamıyorum.

 

[askm]

Dosyanız ektedir.

 

[anemis]

Sayın askm üstadım çok teşekkür ederim. Harikasınız. Aslında bu benim işimi oldukça kolaylaştıracak. Emeklerinize sağlık.

Artık bir miktar daha şımararak biraz kodu geliştirebilir miyiz acaba diye sormak istiyorum?

1) Resimlerin ekleneceği klasörü ben seçemez miyim? excel ile resimler aynı klasörde olmuyor her zaman.
2) Resim ekleme gibi bir button olsa dosyanın içerisinde. ona tıklayınca resimleri seçtirse ve otomatik eklese olur mu?

 

[askm]

Dosyadaki kodları aşağıdaki kodlar ile değiştirin. Sayfanıza AA sütunundan sonra olmak üzere bir şekil ekleyin. Şekli istediğiniz gibi biçimlendirin. Sağ tıklayın.Makro ata deyin ve makro olarak "ASKM_RESİM_GETİR" seçin.

Sub ASKM_RESİM_GETİR()
Dim Kaynak As String
Dim askm As FileDialog

    Set askm = Application.FileDialog(msoFileDialogFolderPicker)
    askm.AllowMultiSelect = False
    askm.Show
    Kaynak = askm.SelectedItems(1)
    If Kaynak = Empty Or InStr(1, Kaynak, "{") > 0 Then GoTo Atla


Call Belirli_Bir_Alandaki_Resimleri_Sil

On Error Resume Next
Satir = 52
For i = 1 To 6
    If i < 10 Then
        Dosya = Kaynak & "\" & "0" & i & ".jpg"
    Else
        Dosya = Kaynak & "\" & i & ".jpg"
    End If
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Select
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Merge
    ActiveSheet.Pictures.Insert(Dosya).Select
    With Selection
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Top
            .Left = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Left
            .Width = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Width
            .Height = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Height
    End With
    Satir = Satir + 50
Next i
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız!", vbInformation, "ASKM"
End Sub


Sub Belirli_Bir_Alandaki_Resimleri_Sil()
    Dim Resim As Picture, Alan As Range
    
    Set Alan = Range("B52:Y65536")
    
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
    
    Set Alan = Nothing
    
End Sub

 

[anemis]

Üstadım süpersiniz harika olmuş.. Aşırı kolaylaştıracak işimi gerçekten.. Lakin resimleri ekledikten sonra Lütfen Kaynak Klasör Seçimi yapınız gibi bir hata mesajı alıyorum (çok önemli değil gerçi tamam a basıp çıkıyorum resimler de eklenmiş oluyor ama.)

 

[askm]

Atla: satırından önce exit sub komutunu ekleyin.

 

[anemis]

Süpersiniz hocam. Tam istediğim gibi oldu. Beni çok ciddi bir yükten kurtardınız allah razı olsun.

 

[askm]

Allah cümlemizden razı olsun. Kolay gelsin.

 

[Komou]

Merhaba,
Konu ile alakalı farklı bir soru soracağım acaba aynı işlemi hücre için nasıl yapabiliriz.
Yani A sütunundaki kolonda yazan değere göre aynı isimli görseli yanındaki b hücresine istenilen ölçüde getirmeyi.
Saygılarımla