Loop of Insert Pictures into Excel Files

[kg2586]

I want to loop through a directory of excel files and insert pictures from another directory that goes down the line of excel files and inserts the pictures one after the other in the picture directory.

Below is the code to help show what I mean. I want the insert picture to be on the Signature tab pulling from the mwh-fs1\Users\xxxx\xxxx\xxxxx\xxxxx\SKM_C55818082107260_001.jpg where the 001 at the end is the scanned picture. I want this number to change from 002, 003, 004, etc. up through like 200. I would like it to go into a different directory, start at the top of that directory and go down and insert the pictures but increase by 1 every time as they're different scanned pictures for the individual file. These are reconciliations that we scan the official signed one in and have to insert the signed reconciliations into the excel files reconciliation. This macro would allow me to press a button and save me a lot of time. I will need to get the pictures in the correct order to match the order of the excel file reconciliations but that's minimal time compared to how I have been doing it. One by one, inserting picture, finding said picture in the directory, pressing insert and then saving and closing. I would like to have it automatically do this and save and close and just loop through the entire excel file directory.

OPEN_INSERT_PIC Macro'
' Keyboard Shortcut: Ctrl+Shift+Q
'
    Sheets("Signature").Select
    Range("A1").Select
    ActiveSheet.Pictures.Insert( _
        "\\mwh-fs1\Users\xxxx\xxxx\xxxxx\xxxxx\SKM_C55818082107260_001.jpg" _
        ).Select

 

[John_w]

Deleted - try again.

 

[John_w]

Manually create a copy of the folder containing the Excel files (workbooks), edit the code where shown to change the two folder paths (specifying the copy folder for the workbooksPath variable) and run the macro. The folder copy is just to test that the code works correctly, without affecting the files in the real folder.

The code assumes the workbooks folder doesn't contain any other type of file, otherwise it will generate an error.

Option Explicit

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function StrCmpLogicalW Lib "shlwapi.dll" (ByVal string1 As String, ByVal string2 As String) As Integer
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function StrCmpLogicalW Lib "shlwapi.dll" (ByVal string1 As String, ByVal string2 As String) As Integer
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


Public Sub Insert_Picture_In_Workbooks()

    Dim workbooksPath As String, filename As String
    Dim imagesPath As String, imageFileTemplate As String, imageNumber As Integer, imageFilename As String
    Dim n As Long, m As Long
    Dim files() As String, swap As String
    Dim wb As Workbook
    Dim pic As Picture
   
    workbooksPath = "C:\folder\path"                       'CHANGE THIS - PATH TO FOLDER CONTAINING THE EXCEL WORKBOOKS
    imagesPath = "\\mwh-fs1\Users\xxxx\xxxx\xxxxx\xxxxx"   'CHANGE THIS - PATH TO FOLDER CONTAINING THE IMAGES
    
    imageFileTemplate = "SKM_C55818082107260_|n|.jpg"
    
    If Right(workbooksPath, 1) <> "" Then workbooksPath = workbooksPath & ""
    If Right(imagesPath, 1) <> "" Then imagesPath = imagesPath & ""
    
    'Put workbook file names in files array
    
    n = 0
    filename = Dir(workbooksPath & "*.*")
    Do While filename <> vbNullString
        ReDim Preserve files(n)
        files(n) = filename
        filename = Dir
        n = n + 1
    Loop

    'Bubble sort files array in ascending numerical order.  Calls StrCmpLogicalW to compare strings numerically.
    
    For m = 0 To UBound(files) - 1
        For n = m + 1 To UBound(files)
            If StrCmpLogicalW(StrConv(files(m), vbUnicode), StrConv(files(n), vbUnicode)) = 1 Then
                'files(m) > files(n) so swap them
                swap = files(n)
                files(n) = files(m)
                files(m) = swap
            End If
        Next
    Next
    
    'Insert each sequential picture in workbooks in file name order
    
    Application.ScreenUpdating = False
    imageNumber = 0
    For n = 0 To UBound(files)
        imageNumber = imageNumber + 1
        imageFilename = Replace(imageFileTemplate, "|n|", Format(imageNumber, "000"))
        Set wb = Workbooks.Open(workbooksPath & files(n))
        With wb.Worksheets("Signature")
            Set pic = .Pictures.Insert(imagesPath & imageFilename)
            pic.ShapeRange.Left = .Range("A1").Left
            pic.ShapeRange.Top = .Range("A1").Top
        End With
        wb.Close SaveChanges:=True
    Next
    Application.ScreenUpdating = True
    
    MsgBox "Done!"
    
End Sub

 

[John_w]

Having trouble with trailing backslash characters - the lines should be:

    workbooksPath = "C:\folder\path\"                       'CHANGE THIS - PATH TO FOLDER CONTAINING THE EXCEL WORKBOOKS
    imagesPath = "\\mwh-fs1\Users\xxxx\xxxx\xxxxx\xxxxx\"   'CHANGE THIS - PATH TO FOLDER CONTAINING THE IMAGES
    
    imageFileTemplate = "SKM_C55818082107260_|n|.jpg"
    
    If Right(workbooksPath, 1) <> "\" Then workbooksPath = workbooksPath & "\"
    If Right(imagesPath, 1) <> "\" Then imagesPath = imagesPath & "\"

 

[kg2586]

Thank you for this. I am getting a debug at: For m = 0 To UBound(files) - 1

 

[John_w]

The error probably means the files array is empty, which means no files (matching *.*) were found in the workbooksPath folder.

Did you apply the corrections in my last post? Ensure both the workbooksPath and imagesPath end with a backslash.
<code><code></code></code>

 

[kg2586]

The error probably means the files array is empty, which means no files (matching *.*) were found in the workbooksPath folder.

Did you apply the corrections in my last post? Ensure both the workbooksPath and imagesPath end with a backslash.
<code><code></code></code>

Thank you. I made the change. I then get a prompt asking me if I want to update if I trust the links. I click Update and then receive "We can't update some of the links in your workbook right now. You can continue without updating their values, or edit the links you think are wrong." I select Continue and it then fails at this part of the code...

Set pic = .Pictures.Insert(imagesPath & imageFilename)

 

[John_w]

To suppress the update links warning, try adding

Application.DisplayAlerts = False

immediately after the Application.ScreenUpdating = False line, and

Application.DisplayAlerts = True

immediately before the Application.ScreenUpdating = True line.