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.

 

[Polanskiman]

Hello,

Well, in that case then Old Logo 1 always has a more rectangular shape than Old logo 2 which is more square shaped. I am pretty certain that this is valid in all excel files. More precisely below are the original sizes of the Old Logos (the resized sizes are variable from file to file and sheet to sheet as it was done manually) but ultimately if I reset the size it will always be the Original Size in all files. Hope that makes sense.

Old Logo 1 Original Size in all files
Height: 1.56"
Width: 3.28" (more than twice the height)

Old Logo 2 Original Size in all files
Height: 2.71"
Width: 3.69"

Can something be done knowing the above?

Thanks again.

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".

 

[Case_Germany]

Hi,

OK - the following code you need to customize two lines of code "If .Height < 50 Then 'OLD_LOGO_1"
and "If .Height < 140 Then ' OLD_LOGO_2". Here you have to specify the height of the old two logos in pixels. In my test files (see below) you can test it without adjustment.

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
                            sngHeight = .Height
                            sngWidth = .Width
                            sngTop = .Top
                            sngLeft = .Left
                            .ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
                            .ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
                            If .Height < 50 Then ' OLD_LOGO_1
                                .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
                            ElseIf .Height < 140 Then ' OLD_LOGO_2
                                .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
                            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

And here is an example: Try...

By the way - hereby You can read the sizes of the images in pixels:

Option Explicit
Sub Test()
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim shpShape As Shape
    For Each shpShape In Sheet1.Shapes
        With shpShape
            sngHeight = .Height
            sngWidth = .Width
            Debug.Print "OLD Height / Width: = " & sngHeight & " / " & sngWidth
            .ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
            .ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
            Debug.Print "NEW Height / Width: = " & .Height & " / " & .Width
        End With
    Next shpShape
End Sub

 

[Polanskiman]

Hi,

Thank you very much. I have tried the code to read the sizes of the images in pixel but it only makes them bigger when I run the macro. Am I missing something?

 

[Case_Germany]

Hi,

In my example files?

 

[Polanskiman]

Yes. I created the macro in one of the sample file and it simply makes the 2 logos full size. That's all.

 

[Case_Germany]

Hi,

Created? Extract the zip file and open the file "Change_Logo.xls". Then start the macro with the button on Sheet1. Does it work?

 

[Polanskiman]

I am referring to the Sub Test() macro code you send. The first code works just fine.

 

[Case_Germany]

Hi,

with this code, the size of the images in "Immediate Window (Ctrl+G in VBE)" is displayed in pixels. So you see the size of the images in one of your files, if you copy the code in one of your files and run.

Or:

Set a breakpoint (F9 = Toggle Breakpoint) and run the code, or go with F8 step by step through the code to the following line of code:

If .Height < 50 Then ' OLD_LOGO_1

In the "Locals Window" you can see the exact content of the variables in this moment. Adjust this to your circumstances.

 

[Polanskiman]

Hello,

Got it!! I didn't know about the immediate and local windows and that running the macros within VBE could provide so much information about what is going on during the macro...

Anyways, thank you so much. I will make some real test runs on a complete batch of files see how it goes. ray: