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 : pray2:
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

13505

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! :beerchug:
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:
13510


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! :)