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?
Error.JPG
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