Sub AddLogo()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strPath As String, strDocNm As String, wdDoc As Document
Dim Shp As Shape, SngTop As Single, SngLft As Single, SngWdth As Single, SngHght As Single
strPath = ActiveDocument.Path & "": strDocNm = ActiveDocument.FullName: SngWdth = 112.5: SngHght = SngWdth
strFolder = GetFolder: If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
Do While strFile <> ""
If strFolder & "" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Company Name"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.Execute
End With
If .Find.Found = True Then
SngLft = (.Characters.First.Information(wdHorizontalPositionRelativeToTextBoundary) + _
.Characters.Last.Next.Information(wdHorizontalPositionRelativeToTextBoundary) - SngWdth) / 2
SngTop = -(SngHght - .Characters.First.Font.Size) / 2
Set Shp =wdDoc.Shapes.AddPicture(FileName:=strPath & "bp.png", LinkToFile:=False, SaveWithDocument:=True, _
Left:=SngLft, Top:=SngTop, Width:=SngWdth, Height:=SngHght, Anchor:=.Characters.First)
With Shp
.LockAnchor = True
.LockAspectRatio = True
With .WrapFormat
.AllowOverlap = True
.Side = wdWrapBoth
.DistanceTop = 0
.DistanceBottom = 0
.DistanceLeft = 0
.DistanceRight = 0
.Type = wdWrapBehind
End With
End With
End If
End With
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Loop
Set wdDoc = Nothing
Application.ScreenUpdating = True
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
Bookmarks