Batch replace image(s) in multiple files and sheets

[Polanskiman]

Hello Everyone,

First, I haven't found my answer in other threads, so if it does exist, please redirect me.

Now, here is my problem. I have thousands of excel files each containing a varying quantity of sheets. There are two logos in each file first sheet (at the same position) and these logos, in some instances, are also located on other sheets of each file. Each logo in the other sheets are located each time at the same position but in different position than in the first Sheet. Each logo is the same in all files and sheets.

What I need is to replace these 2 logos in all files/sheets with new ones. Doing this manually would literally take weeks even months full time.

Could anyone help me with this?

Thanks in advance.

 

[Case_Germany]

Hi,

change the following code...

wksSheet.Shapes.AddPicture(strLogo1, _
    True, True, sngLeft, sngTop, _
    sngWidth, sngHeight).Name = "Logo1"

...instead of "sngWidth" and "sngHeight" use 142 or what size the logo has.

wksSheet.Shapes.AddPicture(strLogo1, _
    True, True, sngLeft, sngTop, _
    142, 142).Name = "Logo1"

 

[Polanskiman]

Hello,

Not sure that made the trick. Perhaps I didn't express my self properly. I need the new logos to be of similar size than the old logos but the new logos should keep their aspect ratio so they don't look deformed.

Also, I tried the macro on all of my files and in some instances the new logos started replacing some text boxes within the sheets. Not sure why...

Hi,

change the following code...

wksSheet.Shapes.AddPicture(strLogo1, _
    True, True, sngLeft, sngTop, _
    sngWidth, sngHeight).Name = "Logo1"

...instead of "sngWidth" and "sngHeight" use 142 or what size the logo has.

wksSheet.Shapes.AddPicture(strLogo1, _
    True, True, sngLeft, sngTop, _
    142, 142).Name = "Logo1"

 

[Case_Germany]

Hi,

aahhhh... yes "LockAspectRatio" - try:

Option Explicit
Public Sub Main()
    Dim stCalc As Integer
    Dim strPath As String
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' File is in the same directory as the file with the logos
    strPath = ThisWorkbook.Path & Application.PathSeparator
    ' File is in certain directory
    ' strPath = "C:\Temp\" ' adapt
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    ' SearchFiles strPath, "*.xls*", False ' without subfolder
    SearchFiles strPath, "*.xls*", True ' with subfolder
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim strLogo1 As String
    Dim strLogo2 As String
    Dim sngLeft As Single
    Dim shpShape As Shape
    Dim objFile As Object
    Dim sngTop As Single
    Dim objFSO As Object
    strLogo1 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_1.jpg"
    strLogo2 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_2.jpg"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName And objFile.Name <> _
            ThisWorkbook.Name And Left(objFile.Name, 1) <> "~" Then
            Workbooks.Open objFile.Path
            For Each wksSheet In Workbooks(objFile.Name).Worksheets
                For Each shpShape In wksSheet.Shapes
                    With shpShape
                        If .TopLeftCell.Row > 4 Then
                            If .TopLeftCell.Row > 37 Then
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                Set shpShape = wksSheet.Shapes.AddPicture(strLogo2, _
                                    True, True, sngLeft, sngTop, _
                                    -1, -1)
                                With shpShape
                                    .Name = "Logo2"
                                    .LockAspectRatio = msoTrue
                                    .Width = sngWidth
                                    .Height = sngHeight
                                End With
                            Else
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                Set shpShape = wksSheet.Shapes.AddPicture(strLogo1, _
                                    True, True, sngLeft, sngTop, _
                                    -1, -1)
                                With shpShape
                                    .Name = "Logo1"
                                    .LockAspectRatio = msoTrue
                                    .Width = sngWidth
                                    .Height = sngHeight
                                End With
                            End If
                        ElseIf .TopLeftCell.Row < 4 Then
                            If .TopLeftCell.Column < 4 Then
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                Set shpShape = wksSheet.Shapes.AddPicture(strLogo2, _
                                    True, True, sngLeft, sngTop, _
                                    -1, -1)
                                With shpShape
                                    .Name = "Logo2"
                                    .LockAspectRatio = msoTrue
                                    .Width = sngWidth
                                    .Height = sngHeight
                                End With
                            Else
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                Set shpShape = wksSheet.Shapes.AddPicture(strLogo1, _
                                    True, True, sngLeft, sngTop, _
                                    -1, -1)
                                With shpShape
                                    .Name = "Logo1"
                                    .LockAspectRatio = msoTrue
                                    .Width = sngWidth
                                    .Height = sngHeight
                                End With
                            End If
                        End If
                    End With
                    Set shpShape = Nothing
                Next shpShape
            Next wksSheet
            Workbooks(objFile.Name).Close True
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
            SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
        Next objFolder
    End If
End Sub

 

[Polanskiman]

Thank you very much, that seemed to do it

As I mentioned in my previous post, in some instances the new logos replace some text boxes within the sheets. Also sometimes the New Logo 2 replaces Old Logo 2 and also Old Logo 1. I therefore end up having New Logo 2 in all placements.

Any idea why is this happening?

Really thanks for what you have done.

 

[Case_Germany]

Hi,

yes, the problem is that in the test files no other "shapes" are. In my code I check the "TopLeftCell.Row" or "TopLeftCell.Column". Other "shapes" are deleted or replaced at this moment. Maybe you can upload some test files, in which the problem occurs?

 

[Polanskiman]

I've uploaded a sample file where this occurs. I simply deleted the confidential information, for the rest I left it untouched. Here is the link:

http://www.paullefevre.com/download/

Also, I forgot to mention earlier. On 2 files, I am requested by excel to "save as" which I don't understand as it doesn't do this for all other files. Perhaps there are some functions in those files that forces the file to be saved in XLSX. Anyways that's not a big deal because it's only 2 files. What I noticed though is that, in several files there are plenty of "Check boxes" and each check box is being replaced by the new logos. Overall when and if there is a "text boxes", a "Check boxes" or any type of Form control or ActiveX control it will replaced those controls with the new logos.

 

[Polanskiman]

I've also uploaded the New Logos with the dimensions corresponding to the real ones. Just in case it might be useful...

 

[Case_Germany]

Hi,

this should be done with an additional line of code - "If .Type = msoPicture Then".

Option Explicit
Public Sub Main()
    Dim stCalc As Integer
    Dim strPath As String
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' File is in the same directory as the file with the logos
    strPath = ThisWorkbook.Path & Application.PathSeparator
    ' File is in certain directory
    ' strPath = "C:\Temp\" ' adapt
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    ' SearchFiles strPath, "*.xls*", False ' without subfolder
    SearchFiles strPath, "*.xls*", True ' with subfolder
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim strLogo1 As String
    Dim strLogo2 As String
    Dim sngLeft As Single
    Dim shpShape As Shape
    Dim objFile As Object
    Dim sngTop As Single
    Dim objFSO As Object
    strLogo1 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_1.jpg"
    strLogo2 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_2.jpg"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName And objFile.Name <> _
            ThisWorkbook.Name And Left(objFile.Name, 1) <> "~" Then
            Workbooks.Open objFile.Path
            For Each wksSheet In Workbooks(objFile.Name).Worksheets
                For Each shpShape In wksSheet.Shapes
                    With shpShape
                        If .Type = msoPicture Then
                            If .TopLeftCell.Row > 4 Then
                                If .TopLeftCell.Row > 37 Then
                                    sngHeight = .Height
                                    sngWidth = .Width
                                    sngTop = .Top
                                    sngLeft = .Left
                                    .Delete
                                    Set shpShape = wksSheet.Shapes.AddPicture(strLogo2, _
                                        True, True, sngLeft, sngTop, _
                                        -1, -1)
                                    With shpShape
                                        .Name = "Logo2"
                                        .LockAspectRatio = msoTrue
                                        .Width = sngWidth
                                        .Height = sngHeight
                                    End With
                                Else
                                    sngHeight = .Height
                                    sngWidth = .Width
                                    sngTop = .Top
                                    sngLeft = .Left
                                    .Delete
                                    Set shpShape = wksSheet.Shapes.AddPicture(strLogo1, _
                                        True, True, sngLeft, sngTop, _
                                        -1, -1)
                                    With shpShape
                                        .Name = "Logo1"
                                        .LockAspectRatio = msoTrue
                                        .Width = sngWidth
                                        .Height = sngHeight
                                    End With
                                End If
                            ElseIf .TopLeftCell.Row < 4 Then
                                If .TopLeftCell.Column < 4 Then
                                    sngHeight = .Height
                                    sngWidth = .Width
                                    sngTop = .Top
                                    sngLeft = .Left
                                    .Delete
                                    Set shpShape = wksSheet.Shapes.AddPicture(strLogo2, _
                                        True, True, sngLeft, sngTop, _
                                        -1, -1)
                                    With shpShape
                                        .Name = "Logo2"
                                        .LockAspectRatio = msoTrue
                                        .Width = sngWidth
                                        .Height = sngHeight
                                    End With
                                Else
                                    sngHeight = .Height
                                    sngWidth = .Width
                                    sngTop = .Top
                                    sngLeft = .Left
                                    .Delete
                                    Set shpShape = wksSheet.Shapes.AddPicture(strLogo1, _
                                        True, True, sngLeft, sngTop, _
                                        -1, -1)
                                    With shpShape
                                        .Name = "Logo1"
                                        .LockAspectRatio = msoTrue
                                        .Width = sngWidth
                                        .Height = sngHeight
                                    End With
                                End If
                            End If
                        End If
                    End With
                    Set shpShape = Nothing
                Next shpShape
            Next wksSheet
            Workbooks(objFile.Name).Close True
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
            SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
        Next objFolder
    End If
End Sub

For the arrangement of the logos you need to find an algorithm that distinguishes the logos - in all files. Either the size or (just as it is currently in the code) the position.

Possibly, the logos are also distinguished by the name - if it is not "Picture 1", Picture 2" and so on...

 

[Polanskiman]

Thank you. I will try that code.

Distinguishing the logos by name might not be possible as I checked a few files and the name seems to change from one file to the other.

The file size could be an option. How do I check the size of a picture that is already in an excel sheet?

 

[Case_Germany]

Hi,

with size I was referring to the dimensions of the logo (Height and Width). If "LOGO_2" is always greater than "LOGO_1", it's not a problem. So either a commonality of all "LOGO_1" or "LOGO_2", or a distinction between "LOGO_1" and "LOGO_2".