Consulting

Page 2 of 3 FirstFirst 1 2 3 LastLast
Results 21 to 40 of 53

Thread: Insert Multiple Pictures Into Table Word With Macro

  1. #21
    Would there happen to be a way to do this with two photos per page with a caption under each photo?

  2. #22
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    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
    [MS MVP - Word]

  3. #23
    VBAX Regular
    Joined
    Nov 2013
    Posts
    16
    Location
    ..
    Attached Images Attached Images
    Last edited by Frozsh; 12-12-2013 at 10:08 PM. Reason: wrong post

  4. #24
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    Without wanting to place too fine a point on it, you're trying to run a Word macro in Excel.
    Cheers
    Paul Edstein
    [MS MVP - Word]

  5. #25
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    Quote Originally Posted by palaceofrev View Post
    Would there happen to be a way to do this with two photos per page with a caption under each photo?
    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
    [MS MVP - Word]

  6. #26
    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.

  7. #27
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    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
    [MS MVP - Word]

  8. #28
    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

  9. #29
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    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
    [MS MVP - Word]

  10. #30
    Thanks Paul Edstein - You are Genius.

  11. #31
    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.

  12. #32
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    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
    [MS MVP - Word]

  13. #33
    VBAX Newbie
    Joined
    Jun 2014
    Posts
    5
    Location
    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.

  14. #34
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    Quote Originally Posted by bilareal View Post
    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)?
    Not with that macro. A completely different one would be required for that.
    Cheers
    Paul Edstein
    [MS MVP - Word]

  15. #35
    VBAX Newbie
    Joined
    Jun 2014
    Posts
    5
    Location
    Quote Originally Posted by macropod View Post
    Not with that macro. A completely different one would be required for that.

    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

  16. #36
    VBAX Newbie
    Joined
    Jun 2014
    Posts
    5
    Location
    Can help me?

  17. #37
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    Try:
    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
    PS: When posting code, please use the code tags. They're indicated by the # button on the posting screen.
    Cheers
    Paul Edstein
    [MS MVP - Word]

  18. #38
    VBAX Newbie
    Joined
    Jun 2014
    Posts
    5
    Location
    Run-time error '5834':

    .Cells(1).Range.Characters.Last.Style = "Caption"


    Any idea?

  19. #39
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,860
    Location
    Works for me - otherwise I wouldn't have posted it.
    Cheers
    Paul Edstein
    [MS MVP - Word]

  20. #40
    VBAX Newbie
    Joined
    Jun 2014
    Posts
    5
    Location
    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".

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •