sandeep
sandeep

Reputation: 31

Copy images from Folder and paste it to Excel through VBA

We have Pictures (Jpeg,Jpg,PNG) in a folder, I need to copy these pictures to excel worksheet like A2, B2, C2, D2 cells.

Using below code i am able to copy as A2,A3,A4 and so on but how to change colunm in below code instead of Row. I could make row constant by keeping counter constant.

I have used online tutorial code and changed a bit to match my requirement.

Sub AddOlEObject()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("SingleProfile").Activate
    Folderpath = "C:\Users\sandeep.hc\Pics"
    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 + 1
                  'Sheets("Object").Range("A" & counter).Value = fls.Name
                  'Sheets("Object").Range("B" & counter).ColumnWidth = 25
                'Sheets("Object").Range("B" & counter).RowHeight = 100
                Sheets("SingleProfile").Range("A" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("SingleProfile").Activate
            End If
        End If
    Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            '.Width = 50
            '.Height = 70
        End With
        .Left = ActiveSheet.Range("A" & counter).Left
        .Top = ActiveSheet.Range("A" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

Need help for Optimizing below code

As per the inputs from users i was able to get the solution which i desired.

I want to optimize the code now, as i am very novice in coding can some one help to optimize or help good coding techniques to improve below

Sub AddOlEObject()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("SingleProfile").Activate
    Folderpath = "C:\Users\sandeep.hc\Pics"
    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 = 29
                 counter1 = counter1 + 1

                Call insert(strCompFilePath, counter, counter1)
                'Sheets("SingleProfile").Activate
                counter1 = counter1 + 17
            End If
        End If
    Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter, counter1)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = 875
            .Height = 300
        End With
        .Left = ActiveSheet.Cells(counter, counter1).Left
        .Top = ActiveSheet.Cells(counter, counter1).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

Upvotes: 0

Views: 4952

Answers (2)

user3598756
user3598756

Reputation: 29421

For shifting through row 1 columns

   .Left = ActiveSheet.Cells(counter, 1).Left
   .Top = ActiveSheet.Cells(counter,1).Top

Upvotes: 1

arcadeprecinct
arcadeprecinct

Reputation: 3777

Instead of ActiveSheet.Range("C2") use ActiveSheet.Cells(2,3) and so on.

By the way, it would be safer to pass the sheet as another function parameter instead of activating it. That way you don't need to remember to activate it every time you call the function. I'd also recommend using Option Explicit at the start of your module, especially if you're new to VBA.

Upvotes: 1

Related Questions