Private Const mc_MsgTitle   As String = _
               "VB-fun-Demo - Dokumente bearbeiten"

Private Const mc_ErrLogFile As String = "Error.log"

Public Sub EditWordDocs(ByRef astrWDFiles() As String, Optional _
      strDocPWD As Variant, Optional strDocWritePWD As Variant)

  Dim objWDApp  As Word.Application
  Dim objWDDoc  As Word.Document
  Dim objWDRng  As Object

  Dim FN As Integer

  Dim nFilesCnt       As Long
  Dim nFile           As Long
  Dim strFileName     As String
  Dim nFilesChanged   As Long
  Dim blnSaveChanges  As Boolean
  
  Dim strErrTmp       As String
  Dim strErrLog       As String
  Dim strMsg          As String

  nFilesCnt = -1

  On Error Resume Next
  Set objWDApp = CreateObject("Word.Application")

  If Err.Number = 0 Then
    objWDApp.WordBasic.DisableAutoMacros 1

    If IsMissing(strDocPWD) Or Len(strDocPWD) = 0 Then
      strDocPWD = "PWD"
    End If
    If IsMissing(strDocWritePWD) Or Len(strDocWritePWD) = 0 Then
      strDocWritePWD = "PWD"
    End If

    nFilesCnt = UBound(astrWDFiles)
    For nFile = 0 To nFilesCnt
      blnSaveChanges = False
      strErrTmp = ""

      strFileName = astrWDFiles(nFile)

      ThisDocument.Application.StatusBar = "Bitte warten...   " & _
          "Dokument " & CStr(nFile + 1) & " von " & _
          CStr(nFilesCnt + 1) & " wird bearbeitet - " & strFileName
      DoEvents

      If Not IsFileReadyOnly(strFileName, strErrTmp) Then
        Set objWDDoc = objWDApp.Documents.Open( _
              FileName:=strFileName, ConfirmConversions:=False, _
              ReadOnly:=False, AddToRecentFiles:=False, _
              PasswordDocument:=strDocPWD, _
              WritePasswordDocument:=strDocWritePWD)

        If Err.Number = 0 Then
          If objWDDoc.ProtectionType = wdNoProtection Then
            Set objWDRng = objWDDoc.Content
            With objWDRng.Find
              .Text = "VB-fun"
              .Replacement.Text = "VB-fun-Demo"
              .Execute Replace:=wdReplaceAll
            End With
            Set objWDRng = Nothing

            If Err.Number = 0 Then
              nFilesChanged = nFilesChanged + 1
              blnSaveChanges = True
            Else
              strErrTmp = Err.Description
            End If

          Else
            strErrTmp = "Dokumentschutz ist aktiviert."
          End If

          objWDDoc.Close blnSaveChanges
          Set objWDDoc = Nothing

        Else
          strErrTmp = "Dokument konnte nicht geöffnet werden. " & _
                "Kennwortgeschützt!?"
        End If
      End If

      If Len(strErrTmp) > 0 Then
          strErrLog = strErrLog & vbCrLf & vbCrLf & _
                strFileName & vbCrLf & strErrTmp
      End If
    Next nFile

    objWDApp.WordBasic.DisableAutoMacros 0

    objWDApp.Quit
    Set objWDApp = Nothing

  Else
    MsgBox "Es konnte keine neue Word-Instanz erstellt werden!", _
         vbOKOnly + vbCritical, mc_MsgTitle
  End If

exit_Sub:
  On Error Resume Next

  If nFilesCnt > -1 Then
    nFilesCnt = nFilesCnt + 1
    If nFilesChanged < nFilesCnt Then
      If nFilesChanged = 0 Then
        strMsg = "Es ist bei allen Dokumenten ein Fehler" & _
              " aufgetreten!"
      Else
        strMsg = nFilesChanged & " Dokument(e) von " & _
              nFilesCnt & " konnte(n) bearbeitet werden!"
      End If
    Else
      strMsg = "Alle Dokumente wurde erfolgreich bearbeitet!"
    End If
  Else
    strMsg = "Es wurden keine Dokumente bearbeitet!"
  End If

  If Len(strErrLog) > 0 Then
    strErrLog = "*** " & mc_MsgTitle & vbCrLf & "*** " & _
        Format$(Now(), "yyyy-mm-dd hh:mm:ss") & vbCrLf & _
        vbCrLf & "In den folgenden Dokumenten sind " & _
        "Fehler aufgetreten:" & vbCrLf & strErrLog

    Dim strErrLogPath As String
    strErrLogPath = ThisDocument.Path

    If WriteErrLogFile(strErrLogPath, strErrLog) Then
      strMsg = strMsg & vbCrLf & vbCrLf & _
          "Die aufgetretenen Fehler können der Log-Datei '" & _
          mc_ErrLogFile & "' im Verzeichnis '" & strErrLogPath & _
          "' entnommen werden!"
    End If
  End If

  If Len(strMsg) > 0 Then
    MsgBox strMsg, vbOKOnly + vbInformation, mc_MsgTitle
  End If
  On Error GoTo 0
End Sub

Private Function WriteErrLogFile(ByVal strPath As String, _
      ByVal strErrMsg As String) As Boolean

  Dim strFileName As String
  Dim FN As Integer

  If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
  strFileName = strPath & mc_ErrLogFile

  FN = FreeFile()
  On Error Resume Next
  Open strFileName For Output As #FN
  If Err.Number = 0 Then
      Print #FN, strErrMsg
      Close #FN
      WriteErrLogFile = True
  End If
  On Error GoTo 0
End Function

Public Sub Start_EditWordDocs()
  Dim strPathDocs     As String
  Dim astrWDFiles()   As String

  Dim strDocPWD       As String
  Dim strDocWritePWD  As String

  Dim blnStatusBar    As Boolean

  strPathDocs = ThisDocument.Path & "\TestDateien\"

  strDocPWD = "lesen"
  strDocWritePWD = "schreiben"

  If Len(Dir$(strPathDocs, vbDirectory)) > 0 Then
    If GetWDFiles(astrWDFiles(), strPathDocs, False) Then
      With ThisDocument.Application
        blnStatusBar = .DisplayStatusBar
        .DisplayStatusBar = True
      End With

      Call EditWordDocs(astrWDFiles(), strDocPWD, strDocWritePWD)

      With ThisDocument.Application
        .StatusBar = mc_MsgTitle & " - Fertig !"
        .DisplayStatusBar = blnStatusBar
      End With
      Application.ScreenRefresh

      Erase astrWDFiles
    Else
      MsgBox "Keine Word-Dokumente im Verzeichnis " & vbCrLf & _
             strPathDocs & " gefunden!", vbInformation, _
             mc_MsgTitle
    End If
  Else
    MsgBox "Das Verzeichnis " & vbCrLf & strPathDocs & vbCrLf & _
          "existiert nicht!", vbInformation, mc_MsgTitle
  End If
End Sub