Insert Multiple Pictures Into Table Word With Macro + Adding DropDownList, no caption

[snowseals]

Hi there,

Hope u guys can help me.
I got the feeling i'm really close to what i want to achieve.

The goal is to add a DropDownList Menu under the pictures I imported using Macropod's solution.
The insertion of Caption I have deleted succesfully. I am a noob in VBA, but I did managed to add a DropDownList.

Problem is the position.
It adds this DropDownList on the first row, instead of placing them under each imported picture.

Can someone help me out?

Here's my code:

Sub AddPics_v2()
    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("Hoeveel kolommen per rij?"))
    RwHght = CSng(InputBox("Welke rij-hoogte voor de afbeeldingen, in inches (bijv. 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
            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
                    'Insert the Caption on the row below the picture
                     'Insert the Caption on the row below the picture
                    With oTbl.Cell(r + 1, c).Range
                        .InsertBefore vbCr
                        .Characters.First = vbNullString
                                                
                        Dim objCC As ContentControl
Dim objLE As ContentControlListEntry
Dim objMap As XMLMapping
 
Set objCC = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
 
'List items
objCC.DropdownListEntries.Add "Cat"
objCC.DropdownListEntries.Add "Dog"
objCC.DropdownListEntries.Add "Equine"
objCC.DropdownListEntries.Add "Monkey"
objCC.DropdownListEntries.Add "Snake"
objCC.DropdownListEntries.Add "Other"
                       
                    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

[gmayor]

You haven't include the FormatRows macro, so I'll assume that works. As for the rest:

Sub AddPics_v3()
    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
    Dim oCell As Range
    On Error GoTo ErrExit
    NumCols = CLng(InputBox("Hoeveel kolommen per rij?"))
    RwHght = CSng(InputBox("Welke rij-hoogte voor de afbeeldingen, in inches (bijv. 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
            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
                     'Insert the Caption on the row below the picture
                    Set oCell = oTbl.Cell(r + 1, c).Range
                    oCell.End = oCell.End - 1
                    Call AddDropdown(oCell)
                     '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 AddDropdown(oRng As Range)
Dim objCC As ContentControl
    oRng.InsertBefore vbCr
    Set objCC = oRng.ContentControls.Add(wdContentControlDropdownList)
    'List items
    objCC.DropdownListEntries.Add "Cat"
    objCC.DropdownListEntries.Add "Dog"
    objCC.DropdownListEntries.Add "Equine"
    objCC.DropdownListEntries.Add "Monkey"
    objCC.DropdownListEntries.Add "Snake"
    objCC.DropdownListEntries.Add "Other"
lbl_Exit:
    Set objCC = Nothing
    Exit Sub
End Sub

[snowseals]

W00t! Works
Thank you very much!

I indeed forgot to place the FormatRows part and had to add to your code above to make it work, but it does now.

To finish it off, I'd like to have a question, just like with the height and amount of rows, which Dropdown-menu I want under the pics.
I'll have 3 Dropdown-menu's in the end (with each different content).

To illustrate my goal:
I'll import pictures in 3 different sections of the document.
1) pictures of the car/overall impression
2) pictures of the car/options/accessoires
3) pictures of the car/damage

vba-dropdownmenu-question.png

So for example I import the damage-pictures, I choose height, rows + dropdown-menu 'Damage'.
Now the pictures are there with the damage dropdown-menu, and manually select the damage-description from the dropdown-list under each pic.

If u want to help me again, I'll donate some Euro's to you.

[snowseals]

Hereby the code of the FormatRows:

 'FormatRows Macro
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x)
            .Height = InchesToPoints(Hght)
            .HeightRule = wdRowHeightExactly
            
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            
        End With
    End With
End Sub

[gmayor]

I think the following modification will do what you require. You will have to do your own translations for the input box and message boxes; and configure the lists with the values you want.
Donations? By all means visit my web site - linked from my signature.

Option Explicit

Sub AddPics_v4()
    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
    Dim strList As String
    Dim oCell As Range
    Dim oRng As Range
    On Error GoTo ErrExit
Start:
    strList = InputBox("Enter the number of the required dropdownlist for this section" & vbCr & vbCr & _
                       "1) pictures of the car/overall impression" & vbCr & _
                       "2) pictures of the car/options/accessoires" & vbCr & _
                       "3) pictures of the car/damage" & vbCr & _
                       "4) Quit." & vbCr)
    If Not IsNumeric(strList) Then
        MsgBox "You must enter a number between 1 and 4!"
        strList = ""
        GoTo Start
    End If
    If Val(strList) > 4 Or Val(strList) < 1 Then
        MsgBox "You must enter a number between 1 and 4!"
        strList = ""
        GoTo Start
    End If
    If Val(strList) = 4 Then GoTo ErrExit

    NumCols = CLng(InputBox("Hoeveel kolommen per rij?"))
    RwHght = CSng(InputBox("Welke rij-hoogte voor de afbeeldingen, in inches (bijv. 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 oRng = Selection.Range
            If oRng.Start > ActiveDocument.Range.Start Then
            oRng.Text = vbCr
            oRng.Collapse 0
            End If
            Set oTbl = oRng.Tables.Add(Range:=oRng, NumRows:=2, NumColumns:=NumCols)
            With ActiveDocument.PageSetup
                TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
            End With
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = TblWdth / NumCols
            End With
            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
                    'Insert the Caption on the row below the picture
                    Set oCell = oTbl.Cell(r + 1, c).Range
                    oCell.End = oCell.End - 1
                    Call AddDropdown(oCell, Val(strList))
                    '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 AddDropdown(oRng As Range, iList As Long)
Dim objCC As ContentControl
    oRng.InsertBefore vbCr
    Set objCC = oRng.ContentControls.Add(wdContentControlDropdownList)
    'List items
    Select Case iList
        Case 1
            objCC.DropdownListEntries.Add "Cat"
            objCC.DropdownListEntries.Add "Dog"
            objCC.DropdownListEntries.Add "Equine"
            objCC.DropdownListEntries.Add "Monkey"
            objCC.DropdownListEntries.Add "Snake"
            objCC.DropdownListEntries.Add "Other"
        Case 2
            objCC.DropdownListEntries.Add "Banana"
            objCC.DropdownListEntries.Add "Pear"
            objCC.DropdownListEntries.Add "Orange"
        Case 3
            objCC.DropdownListEntries.Add "Apricot"
            objCC.DropdownListEntries.Add "Peach"
            objCC.DropdownListEntries.Add "Melon"
    End Select
lbl_Exit:
    Set objCC = Nothing
    Exit Sub
End Sub

 'FormatRows Macro
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x)
            .Height = InchesToPoints(Hght)
            .HeightRule = wdRowHeightExactly
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
        End With
    End With
End Sub

[snowseals]

Works like a charm - Thank you so much!
I've donated €50 thru your website.

Only thing is, that I can't fill in my own text nomore.

It's the difference between these 2 buttons, whereas I originally used the 1st:
vba-2-dropdown-menus_v2.png


So I bet I have to change

objCC.DropdownListEntries.Add

to a different name to get the function, where u have AND dropdown-menu AND the ability to input your own text.
U prolly know how its called VBA-script wise...?

[gmayor]

I followed the original code and used a ListBox. To use a Combo box, change

Set objCC = oRng.ContentControls.Add(wdContentControlDropdownList)

to

Set objCC = oRng.ContentControls.Add(wdContentControlComboBox)

[snowseals]

Thanks!