Load image in Content Control based on drop down list selection

[BradBerger]

Is there a way to load an image in a picture content control based on the selection of a drop down list? The image would just be in a basic location like My Pictures. The path isnt too important as I can always change that.

Thanks!

[macropod]

If you use a dropdown titled 'Dropdown1' for the selections and a Rich Text content control titled 'Picture' for the picture, it's as easy as:

Private Sub Document_ContentControlOnExit(ByVal CCtrl As ContentControl, Cancel As Boolean)
If CCtrl.Title <> "Dropdown1" Then Exit Sub
With ActiveDocument.SelectContentControlsByTitle("Picture")(1).Range
Do While .InlineShapes.Count > 0
.InlineShapes(1).Delete
Loop
Select Case CCtrl.Range.Text
Case 1: .InlineShapes.AddPicture FileName:="C:\Users\" & Environ("UserName") & "\Pictures\Pic1.gif"
Case 2: .InlineShapes.AddPicture FileName:="C:\Users\" & Environ("UserName") & "\Pictures\Pic2.gif"
Case 3: .InlineShapes.AddPicture FileName:="C:\Users\" & Environ("UserName") & "\Pictures\Pic3.gif"
Case Else
End Select
End With
End Sub

[BradBerger]

Thanks for the reply. I just tried this out and it isnt inserting the image in the rich text CC. I made sure the image path is correct as well. How does the code know which item has been selected in the drop down list? Should it be looking for the display name of each item or the value?

Edit: I jumped the gun. I didnt realize that I needed to put the name of each item as the case. It's working now!

[BradBerger]

I may not be out of the woods yet. There's alot going on in the ContentControlOnExit sub and I've added your code to it as well. Every time I click on the rich text CC that the picture is being inserted into, I'm getting a run time error 5991: Cannot access individual rows in this collection because the table has vertically merged cells. There are 11 tables in this document so I'm not sure which one this error is referring to. Here's the entire OnExit code. I apologize if it's sloppy, I havent being doing this sort of stuff for very long.



Private Sub Document_ContentControlOnExit(ByVal CC As ContentControl, Cancel As Boolean)
Dim oCC As ContentControl
Dim Index As Long
Dim oCell As Cell
Dim lngRow As Long
Dim sName1 As String, sName2 As String, sName3 As String

lngRow = CC.Range.Rows(1).Index
sName1 = "Qty" & lngRow
sName2 = "Amount" & lngRow
sName3 = "Total" & lngRow

On Error GoTo Err_Handler
Select Case CC.Tag
Case "Phone"
If IsNumeric(CC.Range.Text) Then
CC.Range.Text = Format(CC.Range.Text, "(000) 000-0000")
End If
Case sName1
If Not IsNumeric(CC.Range.Text) Then
Cancel = True
Beep
CC.Range.Select
Exit Sub
Else
CC.Range.Text = FormatValue(CC.Range.Text)
End If
Case sName2
If IsNumeric(CC.Range.Text) Then
CC.Range.Text = FormatCurrency(CC.Range.Text)
End If
Set oCC = ActiveDocument.SelectContentControlsByTag(sName3).Item(1)
With oCC
.LockContents = False
.Range.Text = FormatCurrency(ProductAB(ActiveDocument.SelectContentControlsByTag(sName1). Item(1).Range.Text, ActiveDocument.SelectContentControlsByTag(sName2).Item(1).Range.Text))
.LockContents = True
End With
Set oCC = ActiveDocument.SelectContentControlsByTag("PartsTotal").Item(1)
With oCC
.LockContents = False
.Range.Text = FormatCurrency(ActiveDocument.SelectContentControlsByTag("Total" & lngRow).Item(1).Range.Text)
.LockContents = True
End With
Set oCC = ActiveDocument.SelectContentControlsByTag("JETotal").Item(1)
With oCC
.LockContents = False
.Range.Text = FormatCurrency(MathAdd(ActiveDocument.SelectContentControlsByTag("HoursWorkedTotal").Item(1).Range.Text, ActiveDocument.SelectContentControlsByTag("MileageTotal").Item(1).Range.Text, ActiveDocument.SelectContentControlsByTag("PartsTotal").Item(1).Range.Text))
.LockContents = True
End With
Case "RateHoursWorked"
Set oCC = ActiveDocument.SelectContentControlsByTag("RateHoursWorked").Item(1)
With oCC
.LockContents = False
If IsNumeric(CC.Range.Text) Then
CC.Range.Text = FormatCurrency(CC.Range.Text)
End If
.LockContents = True
End With
Case "MileageRate"
Set oCC = ActiveDocument.SelectContentControlsByTag("MileageRate").Item(1)
With oCC
.LockContents = False
If IsNumeric(CC.Range.Text) Then
CC.Range.Text = FormatCurrency(CC.Range.Text)
End If
.LockContents = True
End With
End Select


If CC.Tag <> "Engineer" Then Exit Sub
With ActiveDocument.SelectContentControlsByTag("EngineerSig")(1).Range
Do While .InlineShapes.Count > 0
.InlineShapes(1).Delete
Loop
Select Case CC.Range.Text
Case "Brad Berger": .InlineShapes.AddPicture FileName:="C:\Users\" & Environ("UserName") & "\Pictures\sig.png"
Case Else
End Select
End With


Err_ReEntry:
Set oCC = Nothing
Exit Sub
Err_Handler:
With oCC
.LockContents = False
Beep
.Range.Text = "ERROR"
.LockContents = True
End With
Resume Err_ReEntry
End Sub

[macropod]

You can't use .Rows(1).Index in a table with vertically-merged cells. Accordingly, you might try:

Private Sub Document_ContentControlOnExit(ByVal CC As ContentControl, Cancel As Boolean)
Dim CCtrlQty As ContentControl, CCtrlAmt As ContentControl, CCtrlTot As ContentControl
Dim CCtrlHrs As ContentControl, CCtrlMlg As ContentControl, CCtrlPts As ContentControl
Dim lngRow As Long, sName1 As String, sName2 As String, sName3 As String, sTmp As String
With CC
If .Range.Information(wdWithInTable) = True Then
lngRow = .Range.Cells(1).RowIndex
With ActiveDocument
sName1 = "Qty" & lngRow: Set CCtrlQty = .SelectContentControlsByTag(sName1)(1)
sName2 = "Amount" & lngRow: Set CCtrlAmt = .SelectContentControlsByTag(sName2)(1)
sName3 = "Total" & lngRow: Set CCtrlTot = .SelectContentControlsByTag(sName3)(1)
Set CCtrlHrs = .SelectContentControlsByTag("HoursWorkedTotal")(1)
Set CCtrlMlg = .SelectContentControlsByTag("MileageTotal")(1)
Set CCtrlPts = .SelectContentControlsByTag("PartsTotal")(1)
End With
End If
Select Case .Tag
Case "Phone"
With .Range
sTmp = Replace(Replace(Replace(Replace(.Text, "(", ""), ")", ""), "-", ""), " ", "")
If IsNumeric(sTmp) Then
If .Text <> Format(sTmp) Then .Text = Format(sTmp, "(000) 000-0000")
End If
End With
Case sName1
With .Range
If Not IsNumeric(.Text) Then Cancel = True: Beep: .Select: Exit Sub
.Text = Format(.Text, ",0")
End With
Case sName2
With .Range
If IsNumeric(.Text) Then
With CCtrlTot
.LockContents = False
.Range.Text = Format(CCtrlQty.Range.Text * CCtrlAmt.Range.Text, "$,0.00")
.LockContents = True
End With
With ActiveDocument.SelectContentControlsByTag("PartsTotal").Item(1)
.LockContents = False
.Range.Text = Format(CCtrlTot.Range.Text, "$,0.00")
.LockContents = True
End With
With ActiveDocument.SelectContentControlsByTag("JETotal").Item(1)
.LockContents = False
.Range.Text = Format(CSng(CCtrlHrs.Range.Text) + _
CSng(CCtrlMlg.Range.Text) + CSng(CCtrlPts.Range.Text), "$,0.00")
.LockContents = True
End With
.Text = Format(.Text, "$,0.00")
Else
Beep
.Select
End If
End With
Case "RateHoursWorked"
.LockContents = False
If IsNumeric(.Range.Text) Then
.Range.Text = Format(.Range.Text, "$,0.00")
.LockContents = True
Else
Beep
.Range.Select
End If
Case "MileageRate"
.LockContents = False
If IsNumeric(.Range.Text) Then
.Range.Text = Format(.Range.Text, "$,0.00")
.LockContents = True
Else
Beep
.Range.Select
End If
Case "Engineer"
With ActiveDocument.SelectContentControlsByTag("EngineerSig")(1).Range
Do While .InlineShapes.Count > 0
.InlineShapes(1).Delete
Loop
If CC.Range.Text = "Brad Berger" Then .InlineShapes.AddPicture _
FileName:="C:\Users\" & Environ("UserName") & "\Pictures\sig.png"
End With
Case Else
End Select
End With
Set CCtrlQty = Nothing: Set CCtrlAmt = Nothing: Set CCtrlTot = Nothing
Set CCtrlHrs = Nothing: Set CCtrlMlg = Nothing: Set CCtrlPts = Nothing
End Sub

[EimearC]

Hi, I apologise for opening an old thread but I am using the above VBA code to change a picture based on a drop down list content control selection but I keep getting an error, please see picture below. There is no restrictions on this document so I am not sure what the error means, would anyone be able to assist me please?
30984
Edit: I have added the coding used here in case I have done something wrong:


Private Sub Document_ContentControlOnExit(ByVal CCtrl As ContentControl, Cancel As Boolean)
If CCtrl.Title <> "Companies" Then Exit Sub
With ActiveDocument.SelectContentControlsByTitle("Picture")(1).Range
Do While .InlineShapes.Count > 0
.InlineShapes(1).Delete
Loop
Select Case CCtrl.Range.Text
Case "company1": .InlineShapes.AddPicture FileName:="C:\Users" & Environ("UserName") & "\Pictures\pic1.JPG"
Case "company2": .InlineShapes.AddPicture FileName:="C:\Users" & Environ("UserName") & "\Pictures\pic2.JPG"
Case "company3": .InlineShapes.AddPicture FileName:="C:\Users" & Environ("UserName") & "\Pictures\pic3.png"
Case Else
End Select
End With
End Sub

[gmayor]

Your path is wrong, and the macro gets confused about which range is being processed. Try the following

Private Sub Document_ContentControlOnExit(ByVal CCtrl As ContentControl, Cancel As Boolean)
Dim oCC As ContentControl
Set oCC = ActiveDocument.SelectContentControlsByTitle("Picture")(1)
If CCtrl.Title <> "Companies" Then Exit Sub
With oCC.Range
Do While .InlineShapes.Count > 0
.InlineShapes(1).Delete
Loop
End With
Select Case CCtrl.Range.Text
Case "company1": oCC.Range.InlineShapes.AddPicture FileName:="C:\Users\" & Environ("UserName") & "\Pictures\pic1.JPG"
Case "company2": oCC.Range.InlineShapes.AddPicture FileName:="C:\Users\" & Environ("UserName") & "\Pictures\pic2.JPG"
Case "company3": oCC.Range.InlineShapes.AddPicture FileName:="C:\Users\" & Environ("UserName") & "\Pictures\pic3.png"
Case Else
End Select
End Sub

[EimearC]

Hi Graham,

Thanks so much for getting back to me, I have updated the macro with your code but unfortunately I am still getting the same error, that 'the current selection is locked for editing'. Any ideas?

[gmaxey]

You might try:

oCC.LockContents = False