Sub ConvertDocToDocx()
Application.ScreenUpdating = False
Dim SrcFldr As String, TgtFldr As String, DocSrc As Document, StrNm As String
' Zu einem Ordner navigieren
SrcFldr = GetFolder: If SrcFldr = "" Then Exit Sub
TgtFldr = SrcFldr & " neu\"
' Überprüfe, ob der Zielordner existiert, falls nicht, erstelle ihn
If Dir(TgtFldr, vbDirectory) = "" Then MkDir TgtFldr
' Schleife durch alle .doc-Dateien im Quellordner
StrNm = Dir(SrcFldr & "\*.doc", vbNormal)
While StrNm <> ""
' Öffne das Quelldokument
Set DocSrc = Documents.Open(FileName:=SrcFldr & "\" & StrNm, AddToRecentFiles:=False, Visible:=False)
With DocSrc
If .HasVBProject Then
' Konvertiere das Dokument in das .docm-Format
.SaveAs2 FileName:=TgtFldr & .Name & "m", Fileformat:=wdFormatXMLDocumentMacroEnabled, _
CompatibilityMode:=wdWord2003, AddToRecentFiles:=True
Else
' Konvertiere das Dokument in das .docx-Format
.SaveAs2 FileName:=TgtFldr & .Name & "x", Fileformat:=wdFormatXMLDocument, _
CompatibilityMode:=wdWord2003, AddToRecentFiles:=True
End If
' Schließe das Quelldokument
.Close False
End With
' Gehe zum nächsten Dokument
StrNm = Dir()
Wend
Application.ScreenUpdating = True
MsgBox "Die Konvertierung wurde abgeschlossen.", vbInformation
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Wählen Sie einen Ordner", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function