Macro to insert 4 pictures per page, picture name, picture references

[sharens1]

Hello, I am a noobie, and am looking for some sympathy from a VBA coder. I am trying to create a Macro, which will insert 4 large images per page in two columns and two rows. I would like the picture file name at the top, and a figure field (numbered) at bottom. I would like all pictures centered in the page. Any help is greatly appreciated. This is what I have liberated thus far (I cant take any credit for this). The code does not do this yet:

centers pictures in table
Inserts figure reference (Figure 1, etc. numerically)
Would like a maximum of four images, which would take a majority of the page. The images would be likely 40%-50% current size.

Any help is greatly appreciated.

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String

'Select and insert the Pics
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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With

For i = 1 To .SelectedItems.Count
j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1
'Add extra rows as needed

If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If

'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j + 1).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
'Insert the Caption on the row above the picture
oTbl.Rows(j).Cells(k).Range.Text = Split(StrTxt, ".")(0)
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub


Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x + 1)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
End With
End Sub

[gmaxey]

The add-in is macro based. When someone hands you something on a silver platter you should at least show the courtesy of taking a look at it before dismissing it out of hand!

Something like this would likely work (best if the pictures have a portrait orientation). If your pictures are a mixed bag of portrait/landscape/different aspects then nothing it likely going to work perfectly.

Break

SamT, please unstick that thread ;-)


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

[sharens1]

Gmaxey thank you for your reply. I did look at your website and you add-in previously. Very impressive, however, this did not look macro based. The add-in appeared to be a program. This is something I have been trying to do for a long time to driver personal efficiency in report development. As I indicated - I am a Noobie to this stuff. What I find frustrating about this, is that I have created two separate threads on the same topic. One is closed and the second is the same response. Again, the "add-on" program you provided appears to be a program, rather than a Raw Macro. I am looking for a Macro and cross-functionality/compatibility across all current and future programs. If someone could help me with editing that Macro, I would be eternally grateful. I think I could get either portrait or landscaping onto one page with suitable size using a raw macro.


In closing, thank you for your service.


and information.

[gmaxey]

There is a raw macro provided in my previous response. It does (or appears to do) what you have indicated you want done.

[sharens1]

Oh- wow; I just thought that was copy of my original thread... I did not see that.. Thank you so much. Really appreciate it.

[Kilroy]

Hey guys great macro, very useful. I've been using this macro and trying to figure a way to insert a column break after the third row for about 4 hours now. Is it even possible?

Happy 4th of July!

[Kilroy]

I found this. it works great.



Sub SplitTable()
Application.ScreenUpdating = False
Dim Tbl As Table, RngFnd As Range, StrFindTxt As String
StrFindTxt = "figure"
If Trim(StrFindTxt) = "" Then Exit Sub
For Each Tbl In ActiveDocument.Tables
Set RngFnd = Tbl.Range
With RngFnd.Find
.ClearFormatting
.Text = StrFindTxt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
With RngFnd.Duplicate
If .Cells(1).RowIndex < .Tables(1).Rows.Count Then
.Tables(1).Split .Cells(1).RowIndex + 1
End If
.Collapse (wdCollapseEnd)
End With
Loop
End With
Next
Set RngFnd = Nothing
Application.ScreenUpdating = True
End Sub