Consulting

Results 1 to 2 of 2

Thread: Replace Header Info - Relative Path Issue

  1. #1
    VBAX Newbie
    Joined
    Apr 2020
    Posts
    1
    Location

    Replace Header Info - Relative Path Issue

    Hi there!

    I am using the following VBA script to replace information in the header of all documents at a specific path. I need help adjusting the script to replace all header info in all documents at the same path as the word file with the VBA script (relative). Basically i have a Word docx with the VBA script and want to be able to copy it to multiple directories and have it edit the files in the directory where it is saved. The script currently works with specific paths only.

    I am using the latest MS Word version.


    Sub ReplaceEntireHdr()
        Dim wrd As Word.Application
        Set wrd = CreateObject("word.application")
        wrd.Visible = True
        AppActivate wrd.Name
         'Change the directory to YOUR folder's path
        FName = Dir("C:\temp\*.doc")
        Do While (FName <> "")
            With wrd
                 'Change the directory to YOUR folder's path
                .Documents.Open ("C:\Temp" & FName)
                If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
                    .ActiveWindow.ActivePane.View.Type = wdPrintView
                Else
                    .ActiveWindow.View.Type = wdPrintView
                End If
                .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
                .Selection.WholeStory
                .Selection.Paste
                .ActiveDocument.Save
                .ActiveDocument.Close
            End With
            FName = Dir
        Loop
        Set wrd = Nothing
    End Sub

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,121
    Location
    If these document are past correspondence, there could be adverse legal implications resulting from changing the content this way, as the documents will no longer be an accurate reflection of the documents actually used; doing so will also invalidate all your backups. This is especially important in the corporate environment. That said, try:
    Option Explicit
    Dim FSO As Object, oFolder As Object, StrFolds As String
    Dim wdDocTgt As Document, wdDocSrc As Document
     
    Sub Main()
    Application.ScreenUpdating = False
    Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
    TopLevelFolder = GetFolder: StrFolds = vbCr & TopLevelFolder
    If TopLevelFolder = "" Then Exit Sub
    Set wdDocSrc = ActiveDocument
    If FSO Is Nothing Then
      Set FSO = CreateObject("Scripting.FileSystemObject")
    End If
    'Get the sub-folder structure
    Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
    For Each aFolder In TheFolders
      RecurseWriteFolderName (aFolder)
    Next
    'Process the documents in each folder
    For i = 1 To UBound(Split(StrFolds, vbCr))
      Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
    Next
    Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
    Application.ScreenUpdating = True
    End Sub
     
    Sub UpdateDocuments(oFolder As String)
    Dim strFolder As String, strFile As String
    strFolder = oFolder
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strFolder & "\" & strFile <> wdDocSrc.FullName Then
        Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
        AddToRecentFiles:=False, Visible:=False)
        With wdDocTgt
          .Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText = _
            wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
          .Close SaveChanges:=True
        End With
      End If
      strFile = Dir()
    Wend
    End Sub
    
    Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
    End Function
    
    Sub RecurseWriteFolderName(aFolder)
    Dim SubFolders As Variant, SubFolder As Variant
    Set SubFolders = FSO.GetFolder(aFolder).SubFolders
    StrFolds = StrFolds & vbCr & CStr(aFolder)
    On Error Resume Next
    For Each SubFolder In SubFolders
      RecurseWriteFolderName (SubFolder)
    Next
    End Sub
    Last edited by macropod; 04-15-2020 at 06:26 AM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •