Option Explicit
 
'Re-used & shared variables
Dim FSO As Object, oFolder As Object, oSubFolder As Object
Dim oFiles As Object, oItem As Object
Dim i As Long, j As Long, k As Long, l As Long
Dim xlFList As String, xlRList As String, strFnd As String, strRep As String
Dim wdDoc As Document, Rng As Range, Sctn As Section, HdFt As HeaderFooter, FmFld As FormField
Dim bChng As Boolean, bProt As Boolean, Shp As Shape, StrLogo As String
Dim StrDtTm As String, StrPwd As String, Rng As Range
  
Sub Main()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
' Minimise screen flickering
Application.ScreenUpdating = False
' initialze the counters
i = 0: j = 0: k = 0
StrLogo = "C:\Users\" & Environ("Username") & "\Documents\NewLogo.png"
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Projects\IMS Structure Change\Find and Replace.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  'MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  'Exit Sub
End If
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then
  MsgBox "No document folder selected", vbExclamation
  Exit Sub
End If
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Excel.
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
  'Hide our Excel session
  If bStrt = True Then .Visible = False
  For Each xlWkBk In .Workbooks
    If xlWkBk.FullName = StrWkBkNm Then ' It's open
      Set xlWkBk = xlWkBk
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    Set xlWkBk = .Workbooks.Open(StrWkBkNm, , True, , , , , , , , , , False)
    If xlWkBk Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
      If bStrt = True Then .Quit
      Exit Sub
    End If
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' populate the F/R List.
    For k = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & k)) <> vbNullString Then
        xlFList = xlFList & "|" & Trim(.Range("A" & k))
        xlRList = xlRList & "|" & Trim(.Range("B" & k))
      End If
    Next
  End With
  If bFound = False Then xlWkBk.Close False
  If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
StrPwd = InputBox("What is the password for documents with forms protection?")
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " of " & j & " files updated.", vbOKOnly
End Sub
  
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
  
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then
  Set FSO = CreateObject("scripting.filesystemobject")
End If
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
  
Sub GetFolder(StrFolder As String)
Dim strFile As String
strFile = Dir(StrFolder & "*.docx")
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  Call UpdateFile(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
  
Sub UpdateFile(strDoc As String)
StrDtTm = FileDateTime(strDoc)
bProt = False
' Open the document
Set wdDoc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With wdDoc
  Select Case .ProtectionType
    Case wdNoProtection
    Case wdAllowOnlyFormFields
      bProt = True
      On Error Resume Next
      .Unprotect Password:=StrPwd
      On Error GoTo 0
      If .ProtectionType <> wdNoProtection Then GoTo NoGo
    Case Else
NoGo:
      ' Output a 'protected' file report in the document from which the macro is run.
      ThisDocument.Range.InsertAfter vbCr & strDoc & " protected. Not updated."
      .Close SaveChanges:=False
      GoTo ProtExit
  End Select
  'Process each word from the F/R List
  For k = 1 To UBound(Split(xlFList, "|"))
    strFnd = Split(xlFList, "|")(k)
    strRep = Split(xlRList, "|")(k)
    Call FndRep(.Range, strFnd, strRep)
    'Alternatively, to include footnotes, etc."
    'For Each Rng In .StoryRanges
      'Call Update(Rng, strFnd, strRep)
    'Next
    For Each Sctn In .Sections
      For Each HdFt In Sctn.Headers
        Call FndRep(HdFt.Range, strFnd, strRep)
      Next
      For Each HdFt In Sctn.Footers
        Call FndRep(HdFt.Range, strFnd, strRep)
      Next
    Next
  Next
  Call UpdateFmFlds(.Range)
  Call UpdateLogo(.Sections.First)
  If bProt = True Then .Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=StrPwd
  .Close SaveChanges:=True
  i = i + 1
End With
' Let Word do its housekeeping
DoEvents
' Reset the file's Date/Time stamp.
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set oItem = FSO.GetFile(strDoc)
On Error Resume Next
If IsDate(StrDtTm) Then If oItem.DateLastModified <> StrDtTm Then oItem.DateLastModified = StrDtTm
ProtExit:
' Update the main file counter
j = j + 1
Set wdDoc = Nothing
End Sub
  
Sub FndRep(Rng As Range, strFnd As String, strRep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = strFnd
  .Replacement.Text = strRep
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .Execute Replace:=wdReplaceAll
End With
End Sub
  
Sub UpdateFmFlds(Rng As Range)
With Rng
  For Each FmFld In .FormFields
    With FmFld
      If .Type = wdFieldFormDropDown Then
        bChng = False
        If .Name = "Dropdown1" Then
          bChng = True
        Else
          For i = 1 To .DropDown.ListEntries.Count
            If .DropDown.ListEntries(i).Name = "Select Vessel" Then
              bChng = True
              Exit For
            End If
          Next
        End If
      End If
      If bChng = True Then
        .Name = "drpVessel"
        'With .DropDown.ListEntries
        '  .Clear
        '  .Add "Item 1"
        '  .Add "Item 2"
        '  .Add "Item 3"
        '  .Add "Item 4"
        'End With
        Exit For
      End If
    End With
  Next
End With
End Sub
  
Sub UpdateLogo(Sctn1 As Section)
With Sctn1
  If .Headers(wdHeaderFooterFirstPage).Exists Then
    With .Headers(wdHeaderFooterFirstPage)
      If .Shapes.Count = 1 Then
        With Shapes(1)
          Set Rng = .Anchor
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
      ElseIf .Range.InlineShapes.Count = 1 Then
        With .Range.InlineShapes(1)
          Set Rng = .Range
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
        Shp.ConvertToInlineShape
      End If
    End With
  Else
    With .Headers(wdHeaderFooterPrimary)
      If .Shapes.Count = 1 Then
        With Shapes(1)
          Set Rng = .Anchor
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
      ElseIf .Range.InlineShapes.Count = 1 Then
        With .Range.InlineShapes(1)
          Set Rng = .Range
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
        Shp.ConvertToInlineShape
      End If
    End With
  End If
End With
End Sub