Office: noch keine Antwort - Makro Bilddoku - bitte um Hilfe!

Hallo,

ich hatte vor einiger Zeit schon mal gepostet bzgl. eines Word-Makros für Bilddokumentationen.

Ich habe mittlerweile ein Makro für einige Teile, aber das klappt nicht so gut
(Bei mehr als ca. 90 Bildern kommen Laufzeitfehler und das Makro bricht ab.

BITTE bitte helft mir!!!!

Code:

Sub Fotodokumentation()
'
' Fotodokumentation Makro
' Makro aufgezeichnet am 14.05.2009 von cm
'
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(2.5)
.BottomMargin = CentimetersToPoints(1)
.LeftMargin = CentimetersToPoints(1)
.RightMargin = CentimetersToPoints(1)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.25)
.FooterDistance = CentimetersToPoints(1.25)
.PageWidth = CentimetersToPoints(29.7)
.PageHeight = CentimetersToPoints(21)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
With ActiveDocument.PageSetup.TextColumns
.SetCount NumColumns:=1
.EvenlySpaced = False
.LineBetween = False
End With
ActiveDocument.PageSetup.TextColumns.Add Width:=CentimetersToPoints(12.47) _
, Spacing:=CentimetersToPoints(1.25), EvenlySpaced:=False
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Style = ActiveDocument.Styles("Standard")
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(2.22) _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"FILLIN ", PreserveFormatting:=True
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.Name = "Arial"
Selection.Font.Size = 8
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldPage
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

Dim strVerz As String
Dim strDName As String
strVerz = InputBox(("Pfad angeben ..."), "Alle Bilder aus Verzeichnis einfügen", _
"D:\Eigene Dateien\Eigene Bilder\")
If Right(strVerz, 1) <> "\" Then strVerz = strVerz & "\"
strDName = Dir(strVerz & "*.*") 'Typ anpassen (*.* für alle Typen)
If strDName <> "" Then
prgBilderEinfuegen strVerz, strDName
End If
Do While (strDName <> "")
strDName = Dir()
If strDName <> "" Then
prgBilderEinfuegen strVerz, strDName
End If
Loop
End Sub
Sub prgBilderEinfuegen(strVerz As String, strDName As String)
Selection.InlineShapes.AddPicture (strVerz & strDName), LinkToFile:=False, _
SaveWithDocument:=True
Selection.TypeParagraph
Selection.TypeParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

Dim myIS As Word.InlineShape
Dim Prozent As Single

Prozent = 30 'Hier den Prozentwert eingeben!

For Each myIS In ActiveDocument.InlineShapes
myIS.ScaleHeight = Prozent
myIS.ScaleWidth = Prozent
Next myIS

End Sub