Microsoft Office Forums - View Single Post - [Solved] Add Rows to table that will include content controls of previous rows

gmaxey · 01-25-2020, 10:44 AM

Paul,

I've taken some liberties with your project and wanted to share them with you. I am not getting the double firing of the Exit event.

First, I've split the code between the ThisDocument module and a standard module call mode main. I've added a button to the QAT to insert a new row after the selected row.

Standard module code:

Code:

Option Explicit
Sub SandwichNewRow()
  InsertRowWithContent Selection.Information(wdEndOfRangeRowNumber)
End Sub

Sub InsertRowWithContent(lngRowIndex As Long)
Dim lngLastRowIndex As Long
Dim oTbl As Table
Dim oRng As Range
  Set oTbl = Selection.Tables(1)
  Application.ScreenUpdating = False
  With oTbl.Range
    lngLastRowIndex = .Cells(.Cells.Count).RowIndex
    With .Rows(lngRowIndex).Range
      If lngRowIndex = lngLastRowIndex Then
        'Append row at end of table
        .Characters.Last.Next.InsertBefore vbCr
      Else
        'Insert row after current row
        On Error GoTo Err_Adjust
        Set oRng = .Characters.Last.Next
        'Note: Error occurs if a content control is the first character in the following row.
        oRng.InsertBreak wdColumnBreak
        On Error GoTo 0
      End If
Adjust_RE:
      .Characters.Last.Next.FormattedText = .FormattedText
    End With
  End With
  InitializeNewRow Selection.Tables(1), lngRowIndex + 1
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
Err_Adjust:
  oRng.InsertBefore " "
  oRng.End = oRng.End - 1
  oRng.InsertBreak wdColumnBreak
  oRng.Characters.Last.Next.Delete
  Resume Adjust_RE
End Sub

Sub InitializeNewRow(oTbl As Table, lngIndex As Long)
Dim oCC As ContentControl
Dim bLocked As Boolean, bLockContent As Boolean
  'Reset all content controls in the designated row
  With oTbl.Rows(lngIndex).Range
    For Each oCC In .ContentControls
      With oCC
        bLocked = .LockContentControl: bLockContent = .LockContents
        .LockContentControl = False: .LockContents = False
        Select Case .Type
          Case 8: .Checked = False
          Case wdContentControlPicture
            If Not .ShowingPlaceholderText Then
              If .Range.InlineShapes.Count > 0 Then .Range.InlineShapes(1).Delete
            End If
          Case wdContentControlRichText, wdContentControlText, wdContentControlDate: .Range.Text = ""
          Case wdContentControlDropdownList
            .Type = wdContentControlText
            .Range.Text = ""
            .Type = wdContentControlDropdownList
          Case wdContentControlComboBox
            .Type = wdContentControlText
            .Range.Text = ""
            .Type = wdContentControlComboBox
        End Select
        .LockContentControl = bLocked: .LockContents = bLockContent
      End With
    Next
  End With
lbl_Exit:
  Exit Sub
End Sub

ThisDocument Module:

Code:

Option Explicit
Private Sub Document_ContentControlOnExit(ByVal oCC As ContentControl, Cancel As Boolean)
Dim oDoc As Document
Dim oTbl As Table
Dim lngPType As Long, lngDDLE As Long
Const constPW = "" 'Insert password (if any) here
  Set oDoc = ActiveDocument
  On Error Resume Next
  Set oTbl = oDoc.Tables(1)
  If Not oTbl Is Nothing Then
    lngPType = oDoc.ProtectionType
    If lngPType <> wdNoProtection Then oDoc.Unprotect constPW
    Application.ScreenUpdating = False
    With oCC
      Select Case .Title
        Case "Description"
          For lngDDLE = 1 To .DropdownListEntries.Count
            If .DropdownListEntries(lngDDLE).Text = .Range.Text Then
              With .Range.Rows(1).Cells(3).Range.ContentControls(1)
                .LockContents = False
                .Range.Text = oCC.Range.Text
                .LockContents = True
              End With
              Exit For
            End If
          Next lngDDLE
        Case Else
          If oCC.Range.InRange(oTbl.Rows.Last.Cells(oTbl.Rows.Last.Cells.Count).Range) Then
            If MsgBox("Do you want to add a new row?", vbQuestion + vbYesNo, "ADD ROW") = vbYes Then
              modMain.InsertRowWithContent oCC.Range.Rows(1).Index
            End If
          End If
      End Select
    End With
    'Re-protect the document, if applicable
    oDoc.Protect lngPType, constPW
    Application.ScreenUpdating = True
  End If
lbl_Exit:
  Set oDoc = Nothing: Set oTbl = Nothing
  Exit Sub
End Sub