Content Controls - Add with Rows with Sequential Numbering
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:
Code:
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
Code:
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
