Macro to add row with placeholder text and content controls works in one table but not another.

kevinbradley57 · #1 04-18-2024, 04:30 PM

I have a macro that will add either a clean row or a clean table, depending on whether the cursor is in Table 1 or Table 2 of the attached document. By "clean" I mean any user-entered text is removed and original placeholder text and content controls are restored to their defaults. I had to add an entirely new kind of table and I would like the macro to work the same as it does for Table 1. I can do very rudimentary VBA but the current macro was written by someone else and is way beyond my expertise. Any help is greatly appreciated.

Code:

Sub InsertRowWithContent()
'This is the main procedure called from the QAT icon.
Dim oRows As Word.Row, oNewRow As Row
Dim lngRow As Long
Dim oRng As Word.Range, oCellRng As Range
Dim lngIndex As Long
Dim strLocked As String
Dim arrLocked() As String
Dim oCC_Master As ContentControl, oCC_Clone As ContentControl
  
  vProtectionType = ActiveDocument.ProtectionType
  On Error Resume Next
  Set oRows = p_oTargetRow
  If Error <> 0 Then
    If Selection.Information(wdWithInTable) Then
        Set oRows = Selection.Rows(1)
    End If
  End If
  If Not oRows Is Nothing Then
    'If the selection is in a Prior Audit Issue, Regulator Issue or New Audit Issue block then pass execution to InsertNewTable
    Select Case Selection.Tables(1).Title
      Case "NAI", "RI", "PAI", "MSII", "PAR", "Issue Detail"
        InsertNewTable Selection.Tables(1).Title
        Exit Sub
    End Select
    Application.ScreenUpdating = False
      If vProtectionType <> wdNoProtection Then
        strPassword = "" 'Insert password here
        ActiveDocument.Unprotect Password:=strPassword
      End If
      With Selection
        lngRow = oRows.Index
        With .Tables(1)
          If .Rows.Count > lngRow Then
            'Copy and paste content in new "inserted" row.
            lngRow = lngRow + 1
            'Copy content.
            oRows.Range.Copy
            'Bug in Word - CCs in following row must be unlocked
            For Each oCC_Master In .Rows(lngRow).Range.ContentControls
              strLocked = oCC_Master.LockContentControl & ","
              oCC_Master.LockContentControl = False
            Next oCC_Master
            strLocked = Left(strLocked, Len(strLocked) - 1)
            Set oNewRow = .Rows.Add(.Rows(lngRow))
            Set oRng = .Rows(lngRow).Range
            oRng.MoveEnd wdCharacter, -1
            oRng.Paste
            If InStr(.Cell(1, 1).Range.Text, "New Audit Issues") = 1 Then
              oNewRow.Cells(1).Range.Text = ""
              oNewRow.Cells(3).Range.Text = ""
              oNewRow.Cells(4).Range.Text = ""
              oNewRow.Range.ContentControls(1).DropdownListEntries(1).Select
              oNewRow.Cells(2).Shading.BackgroundPatternColorIndex = wdNoHighlight
              oNewRow.Range.ContentControls(2).Range.Text = ""
            End If
            If InStr(.Cell(1, 1).Range.Text, "Business Line") = 1 Then
              oNewRow.Cells(1).Range.Text = ""
              oNewRow.Cells(2).Range.Text = ""
              oNewRow.Cells(3).Range.Text = ""
              oNewRow.Range.Shading.BackgroundPatternColorIndex = wdNoHighlight
              For lngIndex = 1 To 6
                oNewRow.Range.ContentControls(lngIndex).DropdownListEntries(1).Select
              Next
            End If
            arrLocked = Split(strLocked, ",")
            For lngIndex = 1 To UBound(arrLocked)
              .Rows(lngRow).Range.ContentControls(lngIndex + 1).LockContentControl = arrLocked(lngIndex)
            Next lngIndex
          Else
            'Copy and paste row content in new appended row.
            .Rows.Last.Range.Copy
            'Append new row.
            Set oNewRow = .Rows.Add
            Set oRng = .Rows.Last.Range
            'Clip end of row mark.
            oRng.MoveEnd wdCharacter, -1
            'Paste content.
            oRng.Paste
            If InStr(.Cell(1, 1).Range.Text, "New Audit Issues") = 1 Then
              oNewRow.Cells(1).Range.Text = ""
              oNewRow.Cells(3).Range.Text = ""
              oNewRow.Cells(4).Range.Text = ""
              oNewRow.Range.ContentControls(1).DropdownListEntries(1).Select
              oNewRow.Cells(2).Shading.BackgroundPatternColorIndex = wdNoHighlight
              oNewRow.Range.ContentControls(2).Range.Text = ""
            End If
            If InStr(.Cell(1, 1).Range.Text, "Business Line") = 1 Then
              oNewRow.Cells(1).Range.Text = ""
              oNewRow.Cells(2).Range.Text = ""
              oNewRow.Cells(3).Range.Text = ""
              oNewRow.Range.Shading.BackgroundPatternColorIndex = wdNoHighlight
              For lngIndex = 1 To 6
                oNewRow.Range.ContentControls(lngIndex).DropdownListEntries(1).Select
              Next
            End If
            lngRow = lngRow + 1
          End If
          'Work with new row content.
          With .Rows(lngRow)
            For lngIndex = 1 To .Previous.Range.ContentControls.Count
              Set oCC_Master = .Previous.Range.ContentControls(lngIndex)
              Set oCC_Clone = .Range.ContentControls(lngIndex)
              With oCC_Clone
                #If VBA7 Then
                  If Int(Application.Version) >= 14 Then
                    If .Type = wdContentControlCheckBox Then
                      .Checked = False
                    End If
                  End If
                #End If
                If .Type = wdContentControlRichText Or _
                   .Type = wdContentControlText Or _
                   .Type = wdContentControlDate Then
                     If Not .ShowingPlaceholderText Then
                       .Range.Text = ""
                     End If
                End If
                If .Type = wdContentControlDropdownList Or .Type = wdContentControlComboBox Then
                  .DropdownListEntries(1).Select
                End If
                If .Type = wdContentControlPicture Then
                  If Not .ShowingPlaceholderText Then
                    If .Range.InlineShapes.Count > 0 Then
                      .Range.InlineShapes(1).Delete
                      .Range.InlineShapes(1).Width = oCC_Master.Range.InlineShapes(1).Width
                    End If
                  End If
                End If
                If .Type = wdContentControlDate Then .Range.Text = ""
                .LockContentControl = oCC_Master.LockContentControl
              End With
            Next lngIndex
          End With
        End With
      End With
      If vProtectionType > -1 Then
         ActiveDocument.Protect Type:=vProtectionType, Password:=strPassword
      End If
      Application.ScreenUpdating = True
      Set p_oTargetRow = Nothing
  Else
      MsgBox "The cursor must be in a table row containing content controls.", _
              vbInformation + vbOKOnly, "INVALID SELECTION"
  End If
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to help turn text in square brackets into dropdown content controls	jmf_techs	Word VBA	2	10-16-2022 06:24 AM
Macro to save docx to doc that checks compatibility and converts content controls to static content.	staicumihai	Word VBA	4	10-12-2016 08:23 PM
Don't Print Content Control Placeholder Text	vera	Word VBA	3	07-01-2016 01:57 PM
How to set the Content Control placeholder default text	dsimon14	Word VBA	3	03-27-2015 07:15 AM
Need help with placeholder text in ActiveX controls in Word	mhellerstein	Office	0	11-02-2011 12:31 PM