Microsoft Office Forums - View Single Post - VBA to F+R text + logo in header, body, footer in multiple folders

syl3786 · 04-22-2024, 11:15 PM

Quote:

Originally Posted by Jopo

Hello Syl

Thank you for taking the time out to respond. Attached is a classic document that has all the issues I mentioned in the OP. Alterations required to the 90 odd documents that are within about 60 folders.

Please follow these steps:

Execute the "ReplaceShapeInMultipleDocuments" function.
Choose the folder that houses the document on which you'd like to run the macro.
The macro will be applied to the selected folder's .docx files.

IMPORTANT: It's prudent to test on a few example documents before full execution.
Pending your response to my question, this macro is currently set to only identify and replace the rectangle located in the header with a specific image. You will need to determine the size of the image yourself. Moreover, don't forget to modify the image path as required.

Code:

Sub ReplaceShapeInMultipleDocuments()

    Dim folderPath As String
    Dim fileInFolder As String
    Dim doc As Document
    Dim dialogFolder As FileDialog
    
    ' Create a FileDialog object as a Folder Picker dialog box
    Set dialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' Allow the user to select multiple folders
    dialogFolder.AllowMultiSelect = True
    
    ' Show the dialog box
    If dialogFolder.Show = -1 Then
        ' Loop through each selected folder
        For i = 1 To dialogFolder.SelectedItems.Count
            ' Get the path of the folder
            folderPath = dialogFolder.SelectedItems(i)
            
            ' Get the first .docx file in the folder
            fileInFolder = Dir(folderPath & "\*.docx", vbNormal)
            
            ' Loop through each .docx file in the folder
            While fileInFolder <> ""
                ' Open the document
                Set doc = Documents.Open(folderPath & "\" & fileInFolder)
                
                ' Call the ReplaceShapeWithImage macro
                ReplaceShapeWithImage doc
                
                ' Close the document and save the changes
                doc.Close SaveChanges:=wdSaveChanges
                
                ' Get the next .docx file in the folder
                fileInFolder = Dir()
            Wend
        Next i
    End If
End Sub

Sub ReplaceShapeWithImage(doc As Document)
    Dim shp As Shape
    Dim imagePath As String
    Dim width As Single
    Dim height As Single
    
    ' Set the path to your image
    imagePath = "C:\Q.png"
    
    ' Prompt the user to input the size of the image
    width = 100
    height = 20
    
    ' Loop through each section in the document
    For Each sec In doc.Sections
        ' Loop through each header in each section
        For Each hdr In sec.Headers
            ' Loop through each shape in each header
            For Each shp In hdr.Shapes
                ' Check if the shape is the one we want to replace
                If shp.Name = "Rectangle 197" Then
                    ' Delete the old shape
                    shp.Delete
                    
                    ' Add the new image
                    Set shp = hdr.Shapes.AddPicture(imagePath, False, True, 0, 0, width, height)
                    
                    ' Set the name of the new shape to the old shape's name
                    shp.Name = "Rectangle 197"
                    
                    ' Center the image in the header
                    shp.Left = (hdr.Range.Sections(1).PageSetup.PageWidth - shp.width) / 2
                    
                    ' Exit the sub after replacing the shape
                    Exit Sub
                End If
            Next shp
        Next hdr
    Next sec
End Sub