How to insert > 137 no. pictures in excel file?

[london7871]

The 150 pictures in F:\PIC have to be inserted in attached excel file.
But it only works if F:\PIC has 137 pictures;
If the F:\PIC has more than 137 pictures VBA is not function.
Please help to revise the VBA.
(System: Win 10+ Office 365)
Folder F:\PIC is too large to be uploaded.

[FDibbins]

Have you considered just having a hyperlink to those pics, instead of putting them in the file?

[london7871]

The pics cannot be hyperlinked as the F:\PIC will be removed later; hence I tried to copy and paste the pics to remove the link but failure.

[YasserKhalil]

Try this code

Sub InsertPictures()
    Dim sFile As Variant, r As Range
    Dim sh As Shape, I As Integer

    On Error Resume Next
        For I = 1 To 3
            Set r = Cells(I, 1)
            sFile = ThisWorkbook.Path & "\" & I & ".JPG"
            If sFile = False Or Not (Len(Dir(sFile)) > 0) Then GoTo Skipper
    
            Set sh = ActiveSheet.Shapes.AddPicture(Filename:=sFile, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=r.Left, Top:=r.Top, Width:=r.Width, Height:=r.Height)
    
            With sh
                .Top = r.Top
                .Left = r.Left
                .Height = r.RowHeight
                .Placement = xlMoveAndSize
            End With
Skipper:
            sFile = ""
        Next I
    On Error GoTo 0
End Sub

Rename your pictures 1 - 2 - 3 and so on

[london7871]

How to modify VBA if:
1. Pictures come from folder F:\PIC;
2. Picture names are SKM_C454e15101411100-001, SKM_C454e15101411100-002 ... SKM_C454e15101411100-150.

[YasserKhalil]

Try this code

Sub AddOlEObject()
    Dim folderPath As String, strCompFilePath As String
    Dim FSO, FLS, listFiles
    Dim noOfFiles As Long, Counter As Long
    Dim mainWorkBook As Workbook
    Dim Sh As Worksheet

    Set mainWorkBook = ActiveWorkbook
    Set Sh = mainWorkBook.Sheets("Sheet1")

    Sh.Activate
    folderPath = "F:\PIC"
    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
                Sh.Range("A" & Counter).Value = FLS.Name
                Sh.Range("B" & Counter).Activate
                Call Insert(strCompFilePath, Counter)
                Sh.Activate
            End If
        End If
    Next FLS
End Sub

Function Insert(PicPath, Counter)
    Dim R As Range, Sh As Shape
    
    Set R = ActiveSheet.Range("A" & Counter)
    Set Sh = ActiveSheet.Shapes.AddPicture(Filename:=PicPath, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=R.Left, Top:=R.Top, Width:=R.Width, Height:=R.Height)
    
    With Sh
        .Top = R.Top
        .Left = R.Left
        .Height = R.RowHeight
        .Placement = xlMoveAndSize
    End With
End Function

[london7871]

Thanks YasserKhalil.
Please revise VBA as follows:

1. No need to add filename at column A;
2. Size and location of pictures should match existing print range.
(Expected output please refer to attached excel)
3. The size of print range should match with no. of pictures.
(i.e. print range should be increased for more pictures)
4. The pictures should be transparent.

[YasserKhalil]

ِAs for first point
Just remove this line

Sh.Range("A" & Counter).Value = FLS.Name

As for other points, I can't deal with these points. Let's wait for experts

[london7871]

Thanks YasserKhalil.
I'll solve the remaining points myself.

[london7871]

Thanks YasserKhalil.
I'll solve the remaining points myself.

[YasserKhalil]

You're welcome and it is better to share your solution for other points .. as we need to learn new topics
Best Regards

[london7871]

How to revise your VBA if only picture SKM_C454e15101411100-### in F:\Pic are inserted to excel
and not insert other pictures with different filename in the same folder?

[london7871]

Hello YasserKhalil*,

Further to your reply to my thread "Re: How to insert > 137 no. pictures in excel file?" dated 4 Feb 16 as below,
the following VBA can apply to all jpeg in folder "F:\PIC".

Please advise how to revise the VBA so that it can apply to all jpeg to all sub-folder in "F:\PIC".
(as there are also jpegs in subfolders)





Sub AddOlEObject()
Dim folderPath As String, strCompFilePath As String
Dim FSO, FLS, listFiles
Dim noOfFiles As Long, Counter As Long
Dim mainWorkBook As Workbook
Dim Sh As Worksheet

Set mainWorkBook = ActiveWorkbook
Set Sh = mainWorkBook.Sheets("Sheet1")

Sh.Activate
folderPath = "F:\PIC"
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
Sh.Range("A" & Counter).Value = FLS.Name
Sh.Range("B" & Counter).Activate
Call Insert(strCompFilePath, Counter)
Sh.Activate
End If
End If
Next FLS
End Sub

Function Insert(PicPath, Counter)
Dim R As Range, Sh As Shape

Set R = ActiveSheet.Range("A" & Counter)
Set Sh = ActiveSheet.Shapes.AddPicture(Filename:=PicPath, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=R.Left, Top:=R.Top, Width:=R.Width, Height:=R.Height)

With Sh
.Top = R.Top
.Left = R.Left
.Height = R.RowHeight
.Placement = xlMoveAndSize
End With
End Function