Content Controls - Add with Rows with Sequential Numbering

[bigal.nz]

Hi Folks,

As a part of a project I want to acheive the following:

Page 1 of a document captures a bunch of data in a series of tables. (Data Capture Page)

Pages 2,3,4,5 are several different forms - where peices of information from Page 1 is copied to various parts of the forms made up of pages 2-5.

This information is copied by way of mapped content controls (Thanks Greg Maxey for his pages on this).

An example of one of the tables on page 1 would be this:

Row1: Customer1 Cust.Number1
Row2: Customer2 Cust.Number2

I have added some code (again from Greg Maxeys page) that at the end of each row asks you if you want to add another row, but this code doesnt increment the number so in the above example every row I add would be customer2 instead of customer3,customer4,customer5 etc.

The code I used is:

Private Sub Document_ContentControlOnEnter(ByVal ContentControl As ContentControl)
With Selection.Range
  If .Information(wdWithInTable) Then
    If .Cells(1).RowIndex = .Tables(1).Range.Cells _
                            (.Tables(1).Range.Cells.Count).RowIndex Then
      If .Cells(1).ColumnIndex = .Tables(1).Range.Cells _
                                 (.Tables(1).Range.Cells.Count).ColumnIndex Then
        If MsgBox("This is the last row/last cell." _
                & " Do  you want to add a new new row?", _
                  vbQuestion + vbYesNo, "New Row") = vbYes Then
          InsertRowWithContent
        End If
        Set p_oTargetRow = Selection.Rows(1)
      End If
    End If
  End If
End With
End Sub

Option Explicit
Public p_oTargetRow As Word.Row

Sub InsertRowWithContent()
Dim vProtectionType As Variant, strPassword As String
Dim oRows As Word.Row
Dim iRow As Long
Dim oRng As Word.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
    Application.ScreenUpdating = False
      If vProtectionType <> wdNoProtection Then
        strPassword = "" 'Insert password here
        ActiveDocument.Unprotect Password:=strPassword
      End If
      With Selection
        iRow = oRows.Index
        With .Tables(1)
          If .Rows.Count > iRow Then
            'Copy and paste content in new "inserted" row.
            iRow = iRow + 1
            'Copy content.
            oRows.Range.Copy
            'Bug in Word - CCs in following row must be unlocked
            For Each oCC_Master In .Rows(iRow).Range.ContentControls
              strLocked = oCC_Master.LockContentControl & ","
              oCC_Master.LockContentControl = False
            Next oCC_Master
            strLocked = Left(strLocked, Len(strLocked) - 1)
            .Rows.Add .Rows(iRow)
            Set oRng = .Rows(iRow).Range
            oRng.MoveEnd wdCharacter, -1
            oRng.Paste
            arrLocked = Split(strLocked, ",")
            For lngIndex = 1 To UBound(arrLocked)
              .Rows(iRow).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.
            .Rows.Add
            Set oRng = .Rows.Last.Range
            'Clip end of row mark.
            oRng.MoveEnd wdCharacter, -1
            'Paste content.
            oRng.Paste
            iRow = iRow + 1
          End If
          'Work with new row content.
          With .Rows(iRow)
            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 = False
      Set p_oTargetRow = Nothing
  Else
      MsgBox "The cursor must be locate in a table row containing content controls.", _
              vbInformation + vbOKOnly, "INVALID SELECTION"
  End If
End Sub

Any help appreciated!

Thanks

-Al

[gmaxey]

Al,

For the numbering part. Change your CC titles to include a "_" delimiter e.g., Charge_1, Charge_2, etc. Then modify the code:

'Work with new row content.
With .Rows(iRow)
For lngIndex = 1 To .Previous.Range.ContentControls.Count
Set oCC_Master = .Previous.Range.ContentControls(lngIndex)
Set oCC_Clone = .Range.ContentControls(lngIndex)
Dim arrTitle() As String
arrTitle = Split(oCC_Master.Title, "_")
oCC_Clone.Title = arrTitle(0) & "_" & Val(arrTitle(1) + 1)

[bigal.nz]

Will give that a go tonight. As always - Thanks Greg

[bigal.nz]

So it looks like I should edit this code:

           oRng.Paste
            iRow = iRow + 1
          End If
          'Work with new row content.
          With .Rows(iRow)
            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

to read:

           oRng.Paste
            iRow = iRow + 1
          End If

'Work with new row content.
          With .Rows(iRow)
            For lngIndex = 1 To .Previous.Range.ContentControls.Count
              Set oCC_Master = .Previous.Range.ContentControls(lngIndex)
              Set oCC_Clone = .Range.ContentControls(lngIndex)
              Dim arrTitle() As String
              arrTitle = Split(oCC_Master.Title, "_")
              oCC_Clone.Title = arrTitle(0) & "_" & Val(arrTitle(1) + 1)

              With oCC_Clone
                #If VBA7 Then
                  If Int(Application.Version) >= 14 Then
                    If .Type = wdContentControlCheckBox Then
                      .Checked = False
                    End If
                  End If
                #End If
etc....

Cheers

-Al

[bigal.nz]

Works beautifully. THANKS.

I need to update the placeholder text too else it gets hard to follow whats mapped to what, but that should not be too hard.