VBA ile Fotoğraf Ekle ve İsmini Yazdır

[Astalavista58]

Merhabalar herkese hayırlı günler dilerim.
PNG formatında bayağı bir fotoğraf var.
Bu fotoğrafları seçip 8 tanesi yan yana olacak şekilde eklemek istiyorum.
Fotoğrafların altına ise fotoğrafın ismini yazdırmak istiyorum.
8 fotoğraftan sonra alt satırlarda aynı şekilde devam etmesi gerekiyor. Yardımcı olabilir misiniz

 

[Korhan Ayhan]

Merhaba,

Bu bahsettiğiniz fotoğraflar nereye eklenecek?

Örnek dosya paylaşarak işlemi tarif edebilirmisiniz.

 

[Astalavista58]

Dialog penceresinden kaç tane fotoğraf seçildiyse sırayla eklesin.
A1'e fotoğraf gelecek, B1 boş, C1 fotoğraf gelecek D1 boş gibi. Hemen alt satırlarına fotoğrafların isimleri gelecek A2-C2'ye.
Daha sonra bir satır boş bırakıp son fotoğrafı ekleyene kadar işlemi tekrar etsin gibi. Eklediğim dosya daha anlaşılır.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Insert_Picture()
    Dim S1 As Worksheet, My_Files As Variant, My_File As Variant
    Dim X As Long, Y As Integer, Rng As Range, My_Picture As Object
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    S1.Pictures.Delete
    S1.Cells.ClearContents
    
    My_Files = Application.GetOpenFilename(FileFilter:="," & _
              "*.jpeg;*.png;*.bmp;*.jpg;*.gif", _
              Title:="Resim seçimi yapınız...", MultiSelect:=True)
    
    If IsArray(My_Files) Then
        X = 1
        Y = 1
        For Each My_File In My_Files
            Set Rng = S1.Cells(X, Y)
            Set My_Picture = S1.Shapes.AddPicture(My_File, msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
            Rng.Offset(1) = CreateObject("Scripting.FileSystemObject").GetBaseName(My_File)
            Y = Y + 2
            If Y > 15 Then
                Y = 1
                X = X + 3
            End If
        Next
        
        Erase My_Files
        Set Rng = Nothing
        Set My_Picture = Nothing
        Set S1 = Nothing
        
        Application.ScreenUpdating = True
        
        MsgBox "Seçtiğiniz resimler sayfaya eklenmiştir.", vbInformation
    Else
        MsgBox "Resim seçmediğiniz için işlem iptal edilmiştir.", vbExclamation, "Dikkat !"
    End If
End Sub

 

[Astalavista58]

Sayın hocam ne kadar teşekkür etsem azdır. Allah sizden razı olsun çok teşekkür ederim