Would there happen to be a way to do this with two photos per page with a caption under each photo?
Would there happen to be a way to do this with two photos per page with a caption under each photo?
There are various ways. For example:
1. Make the cell size for the pictures large enough that only one row of pictures plus their captions would fit on a page;
2. Instead of adding new rows for each pair of pictures, insert a page break and add a new table.
The easiest is item 1.
Cheers
Paul Edstein
[Fmr MS MVP - Word]
..
Last edited by Frozsh; 12-12-2013 at 10:08 PM. Reason: wrong post
Without wanting to place too fine a point on it, you're trying to run a Word macro in Excel.
Cheers
Paul Edstein
[Fmr MS MVP - Word]
Cross-posted at: http://www.excelforum.com/word-progr...ith-macro.html
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184
Cheers
Paul Edstein
[Fmr MS MVP - Word]
Sorry for cross-posting, still really new to the help forum.
I've acquired a code that seems to do the trick for the most part but i need the caption to read "Picture #1:" ect...
Also, this code doesn't seem to place my pictures in order.
Sub InsertMultipleImagesFixed()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As Range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
'define resize constraints
max_height = 275
'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 1)
'+++++++++++++++++++++++++++++++++++++++++++++
'oTable.AutoFitBehavior (wdAutoFitFixed)
oTable.Rows.Height = CentimetersToPoints(4)
oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'++++++++++++++++++++++++++++++++++++++++++++++
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.wmf"
.FilterIndex = 2
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
iCol = 1
iRow = i
'get filename
picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\"))
'remove extension from filename ****
picName = Left(picName, InStrRev(picName, ".") - 1)
'select cell
Set oCell = oTable.Cell(iRow, iCol).Range
'insert image
oCell.InlineShapes.AddPicture FileName:= _
.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oCell
'resize image
If oCell.InlineShapes(1).Height > max_height Then
scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
oCell.InlineShapes(1).ScaleHeight = scale_factor
oCell.InlineShapes(1).ScaleWidth = scale_factor
End If
'center content
oCell.ParagraphFormat.Alignment = wdAlignParagraphCenter
'insert caption below image
oCell.InlineShapes(1).Range.InsertCaption Label:="Figure", TitleAutoText:="", _
Title:=": " & picName, Position:=wdCaptionPositionBelow, ExcludeLabel:=True
If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
oTable.Rows.Add
End If
Next i
End If
End With
Set fd = Nothing
End Sub
Please, anything you can offer would be really helpful.
I've already pretty much told you how to do this for yourself - read the code I posted, especially the 'FormatRows' sub. As it is, I don't even know what page size, margin sizes etc you're working with.
Cheers
Paul Edstein
[Fmr MS MVP - Word]
Hello every one,
I want to change in this code from 2 columns to 3 columns, I highlighted the problem area where the problem arise. Urgent need this solution. Please help me.
Sub InsertImages()
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, 3)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(6)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.count
'-------Problem Area
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).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(k).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(5.5)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub
Hello uhayatpk,
Please note that you should not leave issues until they're urgent. It may not be convenient for anyone who can answer your post to respond at that time. Secondly, when posting code, please use the code tags. They're on the 'Go Advanced' tab.
I've modified the code from the previous posts so you can now specify any number of columns and the picture row height. The column-width is calculated automatically, based on the page print width. Any inserted pictures will be constrained to fit the available cell space, at the correct aspect ratio.
As coded, the macro uses the "Normal" and "Caption" Styles. These both left-align the content, but you can change that and which Styles get used.
Sub AddPics() Application.ScreenUpdating = False Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single On Error GoTo ErrExit NumCols = CLng(InputBox("How Many Columns per Row?")) RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.5)?")) On Error GoTo 0 '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 NumCols-column table to take the images Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols) With ActiveDocument.PageSetup TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter End With With oTbl .AutoFitBehavior (wdAutoFitFixed) .Columns.Width = TblWdth / NumCols End With CaptionLabels.Add Name:="Picture" For i = 1 To .SelectedItems.Count Step NumCols r = ((i - 1) / NumCols + 1) * 2 - 1 'Format the rows Call FormatRows(oTbl, r, RwHght) For c = 1 To NumCols j = j + 1 'Insert the Picture ActiveDocument.InlineShapes.AddPicture _ FileName:=.SelectedItems(j), LinkToFile:=False, _ SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range 'Get the Image name for the Caption StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\"))) StrTxt = ": " & Split(StrTxt, ".")(0) 'Insert the Caption on the row below the picture With oTbl.Cell(r + 1, c).Range .InsertBefore vbCr .Characters.First.InsertCaption _ Label:="Picture", Title:=StrTxt, _ Position:=wdCaptionPositionBelow, ExcludeLabel:=False .Characters.First = vbNullString .Characters.Last.Previous = vbNullString End With 'Exit when we're done If j = .SelectedItems.Count Then Exit For Next 'Add extra rows as needed If j < .SelectedItems.Count Then oTbl.Rows.Add oTbl.Rows.Add End If Next Else End If End With ErrExit: Application.ScreenUpdating = True End Sub ' Sub FormatRows(oTbl As Table, x As Long, Hght As Single) With oTbl With .Rows(x) .Height = InchesToPoints(Hght) .HeightRule = wdRowHeightExactly .Range.Style = "Normal" End With With .Rows(x + 1) .Height = CentimetersToPoints(0.5) .HeightRule = wdRowHeightExactly .Range.Style = "Caption" End With End With End Sub
Cheers
Paul Edstein
[Fmr MS MVP - Word]
Thanks Paul Edstein - You are Genius.
I have another question regarding this topic. Are we use three parallel table. Table has one column & one Row. e.g. Insert one table and after specified position insert second table and after this insert third table.
Once again thanks for your co-operation.
Since the macro inserts the table wherever you have the insertion point, simply move that to wherever you want each table inserted. Pretty obvious, I would have thought.
Cheers
Paul Edstein
[Fmr MS MVP - Word]
Hello,
Isn't possible in a 2 columns model insert the photo only in the left cell of the line, and let free the right cell to make a description text?
And insert the caption and photo in the same cell (caption above the photo)?
Last edited by bilareal; 06-06-2014 at 10:12 AM.
I tried this, but i can't get fix the error in the caption!
Sub InsertMultipleImagesWithFilename()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As Range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
'define resize constraints
max_height = 275
If Documents.Count = 0 Then
sNoDoc = MsgBox(" " & _
"No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images")
If sNoDoc = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If
'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)
'+++++++++++++++++++++++++++++++++++++++++++++
'oTable.AutoFitBehavior (wdAutoFitFixed)
oTable.Rows.Height = CentimetersToPoints(4)
oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'++++++++++++++++++++++++++++++++++++++++++++++
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
'find col,row #s
If i Mod 2 = 0 Then 'even number right column
iRow = i / 2
iCol = 2
Else 'odd number left column new row
iRow = (i + 1) / 2
iCol = 1
End If
iRow = i
iCol = 1
'get filename
picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\"))
'remove extension from filename ****
picName = Left(picName, InStrRev(picName, ".") - 1)
'select cell
Set oCell = oTable.Cell(iRow, iCol).Range
'insert image
oCell.InlineShapes.AddPicture FileName:= _
.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oCell
'resize image
If oCell.InlineShapes(1).Height > max_height Then
scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
oCell.InlineShapes(1).ScaleHeight = scale_factor
oCell.InlineShapes(1).ScaleWidth = scale_factor
End If
'center content
oCell.ParagraphFormat.Alignment = wdAlignParagraphLeft
'insert caption above image
oCell.InlineShapes(1).Range.InsertCaption Label:="imagem", TitleAutoText:="", _
Title:=":" & picName, Position:=wdCaptionPositionAbove, ExcludeLabel:=True
If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
oTable.Rows.Add
End If
If i < .SelectedItems.Count Then 'add another row, more to go
oTable.Rows.Add
End If
Next i
End If
End With
Set fd = Nothing
End Sub
Can help me?
Try:
PS: When posting code, please use the code tags. They're indicated by the # button on the posting screen.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 'Picture' caption label CaptionLabels.Add Name:="Picture" 'Add a 2-row by 2-column table with 7cm columns to take the images Set oTbl = Selection.Tables.Add(Selection.Range, 1, 2) With oTbl .AutoFitBehavior (wdAutoFitFixed) .Columns.Width = CentimetersToPoints(7) End With For i = 1 To .SelectedItems.Count 'Add extra rows as needed With oTbl If i > .Rows.Count Then oTbl.Rows.Add With .Rows(i) .Height = CentimetersToPoints(7) .HeightRule = wdRowHeightExactly .Range.Style = "Normal" .Cells(1).Range.Text = vbCr .Cells(1).Range.Characters.Last.Style = "Caption" End With End With 'Insert the Picture ActiveDocument.InlineShapes.AddPicture FileName:=.SelectedItems(i), _ LinkToFile:=False, SaveWithDocument:=True, _ Range:=oTbl.Cell(i, 1).Range.Characters.First 'Get the Image name for the Caption StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\"))) StrTxt = ": " & Split(StrTxt, ".")(0) 'Insert the Caption on the line below the picture With oTbl.Cell(i, 1).Range .Characters.Last.Previous.InsertCaption Label:="Picture", Title:=StrTxt, _ Position:=wdCaptionPositionBelow, ExcludeLabel:=False .Characters.Last.Previous = vbNullString End With Next Else End If End With Application.ScreenUpdating = True End Sub
Cheers
Paul Edstein
[Fmr MS MVP - Word]
Run-time error '5834':
.Cells(1).Range.Characters.Last.Style = "Caption"
Any idea?
Works for me - otherwise I wouldn't have posted it.
Cheers
Paul Edstein
[Fmr MS MVP - Word]
Thank you very much! Works great! Solved my problem!
To work in my model i only changed in the line the reference "Caption" to "Normal".