MacroNoob
01-07-2016, 09:41 AM
I have been searching and found many macros to auto-organized pictures into tables and add captions, but none with multiple pictures to one caption. Also, I want to be able to auto format pictures already on the page. I'd like to thank MacroPod for his help in getting me started with ideas of selecting and using inline shapes pictures to a table. I described in the code what my intentions are. Hopefully, my mess of code is understandable and can be salvaged. I'm MacroNoob for a reason. Thanks for any help in advance.
Sub SelectorImagetoTable()
Application.ScreenUpdating = False
Dim iShp As InlineShape, Rng As Range, Tbl As Table
Dim i As Long, PicWdth As Single, VPos As Single
Dim HPos As Single, VRel As Long, HRel As Long
With ActiveDocument
'looks at each page and counts how many pictures
For i = 1 To .ComputeStatistics(wdStatisticPages)
Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
If i = .ComputeStatistics(wdStatisticPages) Then
Rng.End = .Range.End
End If
With Rng
Select Case .ShapeRange.Count
Case 1
'if only one picture on the page
With .ShapeRange(1)
'dimensions of the picture
.LockAspectRatio = msoTrue
.Width = InchesToPoints(5)
'location of picture
.Left = InchesToPoints(0.55)
.Top = InchesToPoints(3.13)
End With
Set Rng = .InlineShapes(i).Range
With Rng
If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
.InlineShapes(1).Range.Cut
End With
'insert picture in row 1 column 1 and caption in row 2 column 1
Set Tbl = .Tables.Add(Range:=Rng, NumRows:=2, NumColumns:=1)
With Tbl
.Cell(1, 1).Range.Paste
Set Rng = .Cell(2, 1).Range
With Rng
.Style = "Caption"
.End = .End - 1
.InsertAfter vbCr
.InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.Characters.First.Text = vbNullString
.Paragraphs.First.Range.Characters.Last.Text = vbNullString
'I had this working in a former macro for dimesion/
'location of caption...how would I implement?
'Set Box = ActiveDocument.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=0.44, Top:=9.3, Width:=5.18, Height:=0.44)
' Box.TextFrame.TextRange.Text = "Fig. "
'End With
End With
'no boarders on any boxes for clean look
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 0
.Columns.Width = InchesToPoints(5)
End With
Case 2
'if only one picture on the page
With .ShapeRange(2)
'dimensions/location of picture 1 and 2
With .ShapeRange(1)
'Problem ^ selecting the shape.
.LockAspectRatio = msoTrue
.Width = InchesToPoints(5)
.Left = InchesToPoints(0.55)
.Top = InchesToPoints(1.55)
End With
With .ShapeRange(2)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(5)
.Left = InchesToPoints(0.55)
.Top = InchesToPoints(5.55)
End With
End With
Set Rng = .InlineShapes(i).Range
With Rng
If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
.InlineShapes(1).Range.Cut
End With
'insert picture 1 in row 1 and picture 2 into row 2
'insert caption in row 3
Set Tbl = .Tables.Add(Range:=Rng, NumRows:=3, NumColumns:=1)
With Tbl
.Cell(1, 1).ShapeRange(1).Paste
.Cell(2, 1).ShapeRange(2).Paste
Set Rng = .Cell(3, 1).Range
With Rng
.Style = "Caption"
.End = .End - 1
.InsertAfter vbCr
.InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.Characters.First.Text = vbNullString
.Paragraphs.First.Range.Characters.Last.Text = vbNullString
'Set Box = ActiveDocument.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=0.44, Top:=9.3, Width:=5.18, Height:=0.44)
' Box.TextFrame.TextRange.Text = "Fig. "
'End With
End With
'no boarders on any boxes for clean look again
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 0
.Columns.Width = InchesToPoints(5)
End With
Case 3
'if there are 3 picture on the page
With .ShapeRange(3)
'dimensions/location of picture 1 and 2
With .ShapeRange(1)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(4.6)
.Left = InchesToPoints(0.27)
.Top = InchesToPoints(0.25)
End With
With .ShapeRange(2)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(4.6)
.Left = InchesToPoints(0.27)
.Top = InchesToPoints(3.75)
End With
With .ShapeRange(3)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(4.6)
.Left = InchesToPoints(0.27)
.Top = InchesToPoints(7.25)
End With
End With
Set Rng = .InlineShapes(i).Range
With Rng
If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
.InlineShapes(1).Range.Cut
End With
'insert pic 1 =row 1, pic 2 =row 2, and pic 3 =row 3
'insert caption in row 1 column 2
Set Tbl = .Tables.Add(Range:=Rng, NumRows:=3, NumColumns:=2)
With Tbl
.Cell(1, 1).ShapeRange(1).Paste
.Cell(2, 1).ShapeRange(2).Paste
.Cell(3, 1).ShapeRange(3).Paste
Set Rng = .Cell(1, 2).Range
With Rng
.Style = "Caption"
.End = .End - 1
.InsertAfter vbCr
.InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.Characters.First.Text = vbNullString
.Paragraphs.First.Range.Characters.Last.Text = vbNullString
'I had this working in a former macro for dimesion/
'location of caption...how would I implement?
'Set Box = ActiveDocument.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=4.5, Top:=0.7, Width:=2.5, Height:=1.5)
' Box.TextFrame.TextRange.Text = "Fig. "
'End With
'no boarders on any boxes for clean look again
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 0
.Columns.Width = InchesToPoints(5)
End With
End Sub
Sub SelectorImagetoTable()
Application.ScreenUpdating = False
Dim iShp As InlineShape, Rng As Range, Tbl As Table
Dim i As Long, PicWdth As Single, VPos As Single
Dim HPos As Single, VRel As Long, HRel As Long
With ActiveDocument
'looks at each page and counts how many pictures
For i = 1 To .ComputeStatistics(wdStatisticPages)
Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
If i = .ComputeStatistics(wdStatisticPages) Then
Rng.End = .Range.End
End If
With Rng
Select Case .ShapeRange.Count
Case 1
'if only one picture on the page
With .ShapeRange(1)
'dimensions of the picture
.LockAspectRatio = msoTrue
.Width = InchesToPoints(5)
'location of picture
.Left = InchesToPoints(0.55)
.Top = InchesToPoints(3.13)
End With
Set Rng = .InlineShapes(i).Range
With Rng
If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
.InlineShapes(1).Range.Cut
End With
'insert picture in row 1 column 1 and caption in row 2 column 1
Set Tbl = .Tables.Add(Range:=Rng, NumRows:=2, NumColumns:=1)
With Tbl
.Cell(1, 1).Range.Paste
Set Rng = .Cell(2, 1).Range
With Rng
.Style = "Caption"
.End = .End - 1
.InsertAfter vbCr
.InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.Characters.First.Text = vbNullString
.Paragraphs.First.Range.Characters.Last.Text = vbNullString
'I had this working in a former macro for dimesion/
'location of caption...how would I implement?
'Set Box = ActiveDocument.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=0.44, Top:=9.3, Width:=5.18, Height:=0.44)
' Box.TextFrame.TextRange.Text = "Fig. "
'End With
End With
'no boarders on any boxes for clean look
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 0
.Columns.Width = InchesToPoints(5)
End With
Case 2
'if only one picture on the page
With .ShapeRange(2)
'dimensions/location of picture 1 and 2
With .ShapeRange(1)
'Problem ^ selecting the shape.
.LockAspectRatio = msoTrue
.Width = InchesToPoints(5)
.Left = InchesToPoints(0.55)
.Top = InchesToPoints(1.55)
End With
With .ShapeRange(2)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(5)
.Left = InchesToPoints(0.55)
.Top = InchesToPoints(5.55)
End With
End With
Set Rng = .InlineShapes(i).Range
With Rng
If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
.InlineShapes(1).Range.Cut
End With
'insert picture 1 in row 1 and picture 2 into row 2
'insert caption in row 3
Set Tbl = .Tables.Add(Range:=Rng, NumRows:=3, NumColumns:=1)
With Tbl
.Cell(1, 1).ShapeRange(1).Paste
.Cell(2, 1).ShapeRange(2).Paste
Set Rng = .Cell(3, 1).Range
With Rng
.Style = "Caption"
.End = .End - 1
.InsertAfter vbCr
.InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.Characters.First.Text = vbNullString
.Paragraphs.First.Range.Characters.Last.Text = vbNullString
'Set Box = ActiveDocument.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=0.44, Top:=9.3, Width:=5.18, Height:=0.44)
' Box.TextFrame.TextRange.Text = "Fig. "
'End With
End With
'no boarders on any boxes for clean look again
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 0
.Columns.Width = InchesToPoints(5)
End With
Case 3
'if there are 3 picture on the page
With .ShapeRange(3)
'dimensions/location of picture 1 and 2
With .ShapeRange(1)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(4.6)
.Left = InchesToPoints(0.27)
.Top = InchesToPoints(0.25)
End With
With .ShapeRange(2)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(4.6)
.Left = InchesToPoints(0.27)
.Top = InchesToPoints(3.75)
End With
With .ShapeRange(3)
.LockAspectRatio = msoTrue
.Width = InchesToPoints(4.6)
.Left = InchesToPoints(0.27)
.Top = InchesToPoints(7.25)
End With
End With
Set Rng = .InlineShapes(i).Range
With Rng
If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
.InlineShapes(1).Range.Cut
End With
'insert pic 1 =row 1, pic 2 =row 2, and pic 3 =row 3
'insert caption in row 1 column 2
Set Tbl = .Tables.Add(Range:=Rng, NumRows:=3, NumColumns:=2)
With Tbl
.Cell(1, 1).ShapeRange(1).Paste
.Cell(2, 1).ShapeRange(2).Paste
.Cell(3, 1).ShapeRange(3).Paste
Set Rng = .Cell(1, 2).Range
With Rng
.Style = "Caption"
.End = .End - 1
.InsertAfter vbCr
.InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.Characters.First.Text = vbNullString
.Paragraphs.First.Range.Characters.Last.Text = vbNullString
'I had this working in a former macro for dimesion/
'location of caption...how would I implement?
'Set Box = ActiveDocument.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=4.5, Top:=0.7, Width:=2.5, Height:=1.5)
' Box.TextFrame.TextRange.Text = "Fig. "
'End With
'no boarders on any boxes for clean look again
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 0
.Columns.Width = InchesToPoints(5)
End With
End Sub