Need Macro to create Figures, not sequences, so I can cross-references

[sharens1]

Can anyone direct me, or help me to modify this VBA to create sequential figures instead of codes, so I can cross-reference them? I would also be okay with adding bookmarks so I can cross-reference them. I cannot cross reference sequences.

I have tried and failed horribly.....


Option Explicit
Dim oTbl As Table
Sub AddPics()
Dim lngIndex As Long, lngRowIndex As Long, lngCellIndex As Long, strTxt As String
Dim oRng As Range
Dim oRow As Row
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
InsertFittedTable
For lngIndex = 1 To .SelectedItems.Count
lngRowIndex = Int((lngIndex + 1) / 2) * 3 - 1
lngCellIndex = (lngIndex - 1) Mod 2 + 1
'Add extra rows as needed
If lngRowIndex > oTbl.Rows.Count Then
Set oRng = oTbl.Rows.Last.Cells(1).Range
oRng.Collapse wdCollapseStart
oRng.Select
Selection.InsertRowsBelow 6
oTbl.Rows(oTbl.Rows.Count - 1).Height = oTbl.Rows(oTbl.Rows.Count - 7).Height
oTbl.Rows(oTbl.Rows.Count - 4).Height = oTbl.Rows(oTbl.Rows.Count - 10).Height
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(lngIndex), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(lngRowIndex).Cells(lngCellIndex).Range
'Get the Image name for the Caption
strTxt = Split(.SelectedItems(lngIndex), "\")(UBound(Split(.SelectedItems(lngIndex), "\")))
'Insert the Caption on the row above the picture
oTbl.Rows(lngRowIndex - 1).Cells(lngCellIndex).Range.Text = Split(strTxt, ".")(0)
Set oRng = oTbl.Rows(lngRowIndex + 1).Cells(lngCellIndex).Range
oRng.Text = "Figure - "
oRng.Collapse wdCollapseEnd
oRng.End = oRng.End - 1
ActiveDocument.Fields.Add oRng, wdFieldSequence, "Number"
Next
End If
End With
ActiveDocument.Fields.Update
Do While Len(oTbl.Rows.Last.Range) = 6
oTbl.Rows.Last.Delete
Loop
Application.ScreenUpdating = True
lbl_Exit:
Exit Sub
End Sub
Sub InsertFittedTable()
Dim oRow As Row
Set oTbl = Selection.Tables.Add(Selection.Range, 6, 2)
oTbl.AutoFitBehavior (wdAutoFitFixed)
For Each oRow In oTbl.Rows
With oRow
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Next oRow
Do
oTbl.Rows(2).Height = oTbl.Rows(2).Height + 5
oTbl.Rows(5).Height = oTbl.Rows(2).Height
Loop Until oTbl.Rows(6).Range.Information(wdActiveEndPageNumber) > oTbl.Rows(1).Range.Information(wdActiveEndPageNumber)
ActiveDocument.Undo 2
End Sub

[Paul_Hossler]

I added CODE tags for you - you can use the [#] icon next time

#1 in my sig

[macropod]

See: http://www.vbaexpress.com/forum/showthread.php?44473-Insert-Multiple-Pictures-Into-Table-Word-With-Macro&p=306321&viewfull=1#post306321
Note that the macro there creates a new caption Label, named 'Picture', which you can then cross-reference.

[sharens1]

Many Many thanks Macropod/