Seems like a lot to post when the problem is only in a small function but... I would like to figure this out even if I end up starting over. Here's the full code & I'm attaching a zipped folder with test document & images.
Sub NewCatalog()
'
'Create a new catalog document
'
'location of header templates, changes with different users & versions of Windows or Office
Dim BuildingBlocks As String
BuildingBlocks = "C:\Users\Calvin\AppData\Roaming\Microsoft\Document Building Blocks\1033\Building Blocks.dotx"
Dim Topic As String
Topic = "Animals"
'create new document from Normal template so it doesn't contain this macro
Dim TopicDoc As Document
Set TopicDoc = Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
With Selection.PageSetup
.TopMargin = InchesToPoints(0.5)
.BottomMargin = InchesToPoints(0.5)
.LeftMargin = InchesToPoints(1)
.RightMargin = InchesToPoints(0.5)
.HeaderDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
End With
'attach BuildingBlocks template
ActiveDocument.AttachedTemplate = BuildingBlocks
'add 1st header
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
FirstHeader (Topic)
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
CreateTable1
Dim ImageFile As String
Dim ImagePath As String
Dim ImageCount As Integer
Dim PageNum As Integer
Dim OldPage As Integer
Dim TestCount As Integer
Dim Result As Boolean
'need path to insert image but filename must be separate for info
ImagePath = "C:\Test\" & Topic & "\"
ImageFile = Dir(ImagePath & "*.*")
'error check in case Topic folder is empty
If ImageFile = "" Then
MsgBox (Topic & " contains no files")
Exit Sub
End If
ImageCount = 1
PageNum = 1
TestCount = 1
Do Until ImageFile = "Done"
'add images & file names from folder
'AddImage advances to next cell which, if at end of row, adds next row
'but need to add 2 rows so use ImageCount to find end of row (6 images/row)
Result = AddImage(ImagePath, ImageFile, TestCount)
If Result = False Then
ImageFile = "Done"
End If
If ImageCount = 6 Then
'easiest way to add another row is tab thru the current row
Selection.MoveRight Unit:=wdCell, Count:=6
ImageCount = 1
'ImageFile = "Done"
Else
ImageCount = ImageCount + 1
End If
TestCount = TestCount + 1
If ImageFile = "Done" Then
Exit Do
End If
ImageFile = Dir
If ImageFile = "" Then
ImageFile = "Done"
End If
Loop
'save/close new document when all images have been added
End Sub
Sub FirstHeader(ByVal Topic As String)
ActiveDocument.AttachedTemplate.BuildingBlockEntries( _
" Blank (Three Columns)").Insert Where:=Selection.Range, RichText:=True
Selection.HomeKey Unit:=wdLine
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Font.Name = "Broadway BT"
Selection.Font.Size = 14
Selection.TypeText Text:="Catalog Name"
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Font.Name = "AR JULIAN"
Selection.Font.Size = 14
Selection.TypeText Text:=Topic
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Font.Name = "AR JULIAN"
Selection.Font.Size = 14
Selection.TypeText Text:="Page "
ActiveDocument.AttachedTemplate.BuildingBlockEntries("Plain Number"). _
Insert Where:=Selection.Range, RichText:=True
Selection.TypeParagraph
Selection.Font.Name = "Calibri"
Selection.Font.Size = 11
Selection.TypeText Text:="Note"
End Sub
Private Sub CreateTable1()
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
6, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
'start w/ cursor in bottom row so AddImage will work
Selection.MoveDown Unit:=wdLine, Count:=1
End Sub
Function AddImage(ByVal ImagePath As String, ByVal ImageFile As String, ByVal TestCount As Integer) As Boolean
Dim OtherInfo As String
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.InlineShapes.AddPicture FileName:=ImagePath & ImageFile
'error checking code that sets AddImage = False & exits if there's a problem
'Stopping after inserting 1st image on new page (image 37), then continuing works
'Stopping after inserting image 38 (or simply running without stopping) messes up 2nd page
Debug.Assert TestCount < 38
OtherInfo = "This & That"
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.Font.Name = "Arial Narrow"
Selection.Font.Size = 10
Selection.TypeText Text:=ImageFile
Selection.TypeParagraph
Selection.TypeText Text:=OtherInfo
Selection.MoveRight Unit:=wdCell
AddImage = True
End Function