Sub Logo()
Dim Verz As String
Dim aDok As String
Titel = "Bitte Verzeichnis wählen"
Basis = Dialogs(wdDialogToolsOptionsFileLocations).Setting
If Not Right(Basis, 1) = "\" Then Basis = Basis & "\"
retcode = OrdnerAuswaehlen(Titel, Basis, Verz)
If retcode = 4 Then MsgBox "Vorgang abgebrochen", vbExclamation
If retcode = 0 Then
ChDir Verz
aDok = Dir(Verz & "\*.docx")
If aDok <> "" Then
Logo_einfuegen Verz, aDok
End If
Do While (aDok <> "")
aDok = Dir()
If aDok <> "" Then
WordBasic.DisableAutoMacros 1
Logo_einfuegen Verz, aDok
End If
Loop
End If
WordBasic.DisableAutoMacros 0
End Sub
Private Function OrdnerAuswaehlen(ByVal Titel As String, ByVal Basis As String, _
Verz As String) As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Titel
.InitialFileName = Basis
If .Show = -1 Then
Verz = .SelectedItems(1)
If Right(Verz, 1) = "\" Then Verz = Left(Verz, Len(Verz) - 1)
Else
OrdnerAuswaehlen = 4
End If
End With
End Function
Private Sub Logo_einfuegen(Verz As String, aDok As String)
Documents.Open FileName:=aDok
LogoBO = ThisDocument.Path & "\Logo_BochumMVZ_18.jpg"
With Selection.Find
.ClearFormatting
.Text = "MVZ Labor Bochum MLB GmbH"
.Replacement.ClearFormatting
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll, Forward:=True, _
Wrap:=wdFindContinue
End With
Selection.Find.ClearFormatting
With Selection.Find
.Text = "MVZ Labor Bochum MLB GmbH"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
ActiveDocument.InlineShapes.AddPicture FileName:=LogoBO, LinkToFile:=False, SaveWithDocument:=True
With ActiveDocument.InlineShapes(1)
.ScaleHeight = 50
.ScaleWidth = 50
End With
ActiveDocument.Save
ActiveWindow.Close
End Sub