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!
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!
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
Cheers
Paul Edstein
[Fmr MS MVP - Word]
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!
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
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
Last edited by macropod; 08-29-2017 at 01:45 AM.
Cheers
Paul Edstein
[Fmr MS MVP - Word]
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
Last edited by Aussiebear; 08-14-2023 at 07:19 PM. Reason: wrapped code with tags
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
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
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?
You might try:
oCC.LockContents = False