Dosyadan resim çekme

[Leturc]

Merhaba,

Birkaç gündür belirli bir dosyada yer alan resim dosyalarını otomatik olarak çağırmak için bir makro üzerinde çalışıyorum. Belirli bir yere kadar geldim ve son aşamada takılı kaldım.

Kod şu şekilde:

Sub AddOlEObject()
     
    Dim mainWorkBook As Workbook
     
     
    Set mainWorkBook = ActiveWorkbook
    ActiveSheet.Activate
    Folderpath = ThisWorkbook.Path & "\Resimler\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
        strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                counter = counter + 2
[B][U]                ActiveSheet.Range("A" & counter).Activate
                Call insert(strCompFilePath, counter)
                ActiveSheet.Range("C" & counter).Activate[/U][/B]
                Call insert(strCompFilePath, counter)
                ActiveSheet.Activate
            End If
        End If
    Next
    mainWorkBook.Save
End Sub
 
 
Function insert(PicPath, counter)
     'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        
        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
        
        XRatio = ActiveCell.Width / Img.Width
        YRatio = ActiveCell.Height / Img.Height
        
        With Img
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = ActiveCell.Left + 1
            .Top = ActiveCell.Top + 1
            .Placement = xlMoveAndSize
        End With
        
        If (XRatio < YRatio) Then
            Img.Width = (Img.Width * XRatio) - 1
            Img.Height = (Img.Height * XRatio) - 1
        Else
            Img.Width = (Img.Width * YRatio) - 1
            Img.Height = (Img.Height * YRatio) - 1
        End If
        
        If (Img.Width < ActiveCell.Width) Then
             Img.Left = ActiveCell.Left + 1 + ((ActiveCell.Width - Img.Width) / 2)
        End If
        .PrintObject = True
    End With
End Function

Resimler istediğim gibi geliyor ancak A ve C sütunlarına resimleri sıralı olarak değil de aynılarını ekliyor.

Benim yapmaya çalıştığım ise A sütununa ilk resmi C sütununa ikinci resmi sonra A + 2 sütununa üçüncü resmi C + 2 sütununa dördüncü resmi ekleyerek devam edecek bir döngü oluşturmak.

Yardımcı olabilir misiniz?

 

[Leturc]

Merhaba,

EK'li dosya

http://we.tl/XMzVRVR3jx