Suggestion for Best Practice

[gmaxey]

Hello Excel Gurus!

I typically frequent the Word forum but posting here to describe a small project and ask advice on best practices. The project involves a Word document with several dropdown list Content Controls and I want to store (for ease of editing) the CC properties and dropdown list entries in Excel.

Each CC as a unique ID e.g., 234567969. So what I did was using three columns on the sheet, I used the first column for Name, Title and Placeholder text, column 2 for the list item Display text and Column 3 for the list item value text. I then selected that range and named it with a leading underscore e.g., _234567969. I then repeated that process using the next three columns in the sheet.

Using the following code, I loop through all of the document CCs and populate the combo/dropdown types using:


Option Explicit
Private Sub DefineCCs()
Dim oCC As ContentControl
Dim arrData As Variant
Dim strSQL As String
For Each oCC In ActiveDocument.ContentControls
If oCC.Type = 3 Or oCC.Type = 4 Then
strSQL = "SELECT * FROM [_" & oCC.ID & "];"
If fcnFillList(arrData, ThisDocument.Path & "\CCProps.xlsx", True, strSQL) Then
Populate_CC oCC, arrData
Else
MsgBox oCC.ID & " could not be defined using Excel Data.", vbOKOnly, "Data Error"
End If
End If
Next oCC
lbl_Exit:
Exit Sub
End Sub

Public Sub Populate_CC(oCC As ContentControl, varData)
Dim lngRow As Long, lngCol As Long

For lngRow = oCC.DropdownListEntries.Count To 2 Step -1
oCC.DropdownListEntries(lngRow).Delete
Next lngRow
oCC.Title = varData(0, 0)
oCC.Tag = varData(0, 1)
oCC.SetPlaceholderText , , varData(0, 2)
For lngRow = 0 To UBound(varData, 2)
On Error Resume Next
Select Case True
Case IsNull(varData(1, lngRow)) And IsNull(varData(2, lngRow))
'Do nothing. No data defined
Case IsNull(varData(1, lngRow))
'Use defined value for both value and display
oCC.DropdownListEntries.Add varData(2, lngRow), varData(2, lngRow)
Case IsNull(varData(2, lngRow))
'Use defined text for both display and value
oCC.DropdownListEntries.Add varData(1, lngRow), varData(1, lngRow)
Case Else
oCC.DropdownListEntries.Add varData(1, lngRow), varData(2, lngRow)
End Select
On Error GoTo 0
Next lngRow
lbl_Exit:
Exit Sub
End Sub

Public Function fcnFillList(arrPassed As Variant, strWorkbook As String, _
bSuppressHeader As Boolean, strSQL As String) As Boolean
Dim oConn As Object
Dim oRS As Object
Dim lngNumRecs As Long
Dim strConnection As String
fcnFillList = True
'Create connection:
Set oConn = CreateObject("ADODB.Connection")
If bSuppressHeader Then
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Else
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=NO;"";"
End If
oConn.Open ConnectionString:=strConnection
Set oRS = CreateObject("ADODB.Recordset")
'Read the data from the worksheet.
On Error GoTo Err_Retrieve
oRS.Open strSQL, oConn, 3, 1 '3: adOpenStatic, 1: adLockReadOnly
With oRS
'Find the last record.
.MoveLast
'Get count.
lngNumRecs = .RecordCount
'Return to the start.
.MoveFirst
End With
arrPassed = oRS.GetRows(lngNumRecs)
Err_ReEntry:
'Cleanup
If oRS.State = 1 Then oRS.Close
Set oRS = Nothing
If oConn.State = 1 Then oConn.Close
Set oConn = Nothing
lbl_Exit:
Exit Function
Err_Retrieve:
fcnFillList = False
Resume Err_ReEntry
End Function


Of course if I later add or remove items from a list I have to redefine the named range.

Questions:
Would it be better to use a separate sheet for Each CC?
Is there a better layout if I stay with a named range?
Any other suggestions for doing this more efficiently with Excel?

Thanks.

[Artik]

Greg, could you show a sample layout of data in the Excel attachment?

Artik

[gmaxey]

24743

Artik, the next CC would use column D, E and F the next G, H, and I etc.

Thanks

[Paul_Hossler]

Truthfully, it seems unnecessarily complicated to list the CC properties in Excel

I don't think there's any easy way to get Excel edits back to the CC other than manually (I might be wrong)

If you just want to list the CCs and associated properties, you could use a Word macro and put the information into a table in a new Word document

If you really want an Excel file, you could use the Word macro to write a CSV, and then a much simpler 'read and format' macro in Excel

Just a thought

[gmaxey]

Paul,

It isn't complicated at all as the code should illustrate. The question is does anyone see a better layout for the data (e.g., use individual sheets for each CC).

[Paul_Hossler]

Paul,

It isn't complicated at all as the code should illustrate. The question is does anyone see a better layout for the data (e.g., use individual sheets for each CC).




I want to store (for ease of editing) the CC properties and dropdown list entries in Excel.


Can you expand on how you plan to edit the CC based on the Excel sheet(s)?

[gmaxey]

Paul,

Ok. Using the CC in the example illustration which in the document is defined by CC.ID 12345798. Let's assume that I want to change its title from Test 2 to Alphabet Soup, and it's placeholder text to "Pick a letter" I also want to change the value for the display C from Cherry to "Chipmunk"

1. Make the changes in the Excel file close and save.
2. Open the Word document and run the code shown.

Now if I have another CC with the ID 987654321. I would then and another named range at columns D E and F. Name the range _987654321 and use column D for the Title, tag and PHT and columns E and F for the List Display and List Values.

[Paul_Hossler]

Well, if you were to add an "H" entry in row 9 in your screen shot in #3, the named range _123456789 would not include it automatically; you'd have to manually redefine the range

A possible layout change might be


24744



It doesn't require named ranges, and to find the starting column for the 3 columns, you just need to search row1 for the CC Id

Col 1, Col 4, Col 7, etc. are the starting columns for each 3-group of CC parameters

[gmaxey]

Paul,

The code never physically opens Excel to search. It uses an SQL string e.g.,:
strSQL = "SELECT * FROM [_" & oCC.ID & "];"

Where _" & oCC.ID defines the named range used.

You are right the observation you made is what makes me think that perhaps using as separate sheet for each CC might be better.

[Artik]

Well, if you were to add an "H" entry in row 9 in your screen shot in #3, the named range _123456789 would not include it automatically; you'd have to manually redefine the rangePaul, we can discuss whether you need to manually. Have you forgotten about the sheet events? ;)

Under the event, you could attach a procedure similar to Redefine.
Sub Redefine()
Dim Nm As Name
Dim rngRef As Range
Dim rngLast As Range

For Each Nm In ThisWorkbook.Names

If Nm.Name Like "_###*" Then

Set rngRef = Nm.RefersToRange.EntireColumn

With rngRef.Parent
Set rngLast = .Range(Last(3, rngRef.Cells))
Set rngRef = .Range(rngRef.Cells(1), rngLast)
End With


ThisWorkbook.Names.Add Name:=Nm.Name, RefersTo:="=" & rngRef.Address(External:=True)
End If

Next Nm

End Sub


Function Last(choice As Integer, rng As Range)
' By Ron de Bruin, 5 May 2008
' A choice of 1 = last row.
' A choice of 2 = last column.
' A choice of 3 = last cell.
Dim lrw As Long
Dim lcol As Integer

Select Case choice

Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

On Error Resume Next
Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0

End Select

If IsEmpty(Last) Then Last = 1
End Function

Greg, I was thinking a bit about your project and finally I came to the conclusion that "the better is the enemy of the good". :)
I like the project in such a shape as it is. You could download data from the worksheet to the array (data for all controls), but the efficiency increase for a few (or a dozen or so) controls will be small. And the transparency of your solution will suffer.

Artik

[gmaxey]

Artik,

Thanks! Adding Ron's function called by your code makes the process so much better!

[Bob Phillips]

Personally, I would avoid multiple columns, and multiple sheets. Instead, I would add a column A which provided a group ID, and use that group id within a WHERE clause in the SQL.

[gmaxey]

xld,

I can't visualize how that would work. If column A contains all the CC IDs, how you all of the rest of properties for each CC be arranged?

[snb]

To store the properties of each contentcontrol in an Excel sheet:


Sub M_snb()
ReDim sn(ActiveDocument.ContentControls.Count)

For Each it In ActiveDocument.ContentControls
If InStr("4_3_", it.Type & "_") Then
ReDim sp(it.DropdownListEntries.Count + 2, 2)
sp(0, 0) = it.Title
sp(1, 0) = it.ID
sp(2, 0) = it.PlaceholderText
For j = 2 To it.DropdownListEntries.Count
sp(j - 2, 1) = it.DropdownListEntries(j).Text
sp(j - 2, 2) = it.DropdownListEntries(j).Value
Next
sn(y) = sp
y = y + 1
End If
Next

With GetObject("G:\OF\example.xlsx")
For j = 0 To y - 1
.sheets(1).Cells(1, j * 4 + 1).Resize(UBound(sn(j)), 3) = sn(j)
Next
.Save
End With
End Sub

To retrieve the contentcontrol properties from the Excel sheet:

Sub snb_retrieve()
For Each it In GetObject("G:\OF\example.xlsx").sheets(1).usedrange.Rows(1).specialcells(2).areas
sn = it.currentregion.Resize(, 3)
With ActiveDocument.ContentControls(CStr(sn(2, 1))).DropdownListEntries
.Clear
For j = 1 To UBound(sn)
If sn(j, 2) <> "" And sn(j, 3) <> "" Then .Add sn(j, 2), sn(j, 3)
Next
End With
Next
End Sub

In Excel only 1 sheet suffices most of the time. The usedrange can easily be separated into currentregions of areas.

But I wouldn't use an Excel file to do this.
These properties can also be stored simply in Document variables in the Word document itself, or in an external txt file

[gmaxey]

Running your code results in an Excel file that when opened has no visible content or worksheet. It is pointless if the properties can't be edited in the resulting excel file.
Thanks for your dazzling display of Spartan coding style just the same ;-).

[Artik]

snb, but this is not only about data storage, but also about easy modification. In addition, the data layout should be clear to the user.




I can't visualize how that would work. If column A contains all the CC IDs, how you all of the rest of properties for each CC be arranged?In the attachments, I show the whole after changes, as suggested by xld.


strSQL = "SELECT * FROM [CC_Properties$A:D] WHERE ID='_" & oCC.ID & "';"
Here I will only explain that CC_Properties is the name of the sheet. In SQL, to indicate that it is a sheet, add the $ sign at the end.

Look Greg, already Harpies smash your project. :devil2:

Artik

[gmaxey]

Artik,

Yes, I was aware of the significance of the $. Thanks for example and your interest. The project is a learning experience so Harpie actions no problem.

[snb]

Running your code results in an Excel file that when opened has no visible content or worksheet. It is pointless if the properties can't be edited in the resulting excel file.

As an Excel user you should be familiar with Tab: View; Option: unhide (Why else did MS introduce this ?)

As a VBA-user you should be familiar with the property .Visible.


Sub M_snb()
ReDim sn(ActiveDocument.ContentControls.Count)

For Each it In ActiveDocument.ContentControls
If InStr("4_3_", it.Type & "_") Then
ReDim sp(it.DropdownListEntries.Count + 2, 2)
sp(0, 0) = it.Title
sp(1, 0) = it.ID
sp(2, 0) = it.PlaceholderText

For j = 2 To it.DropdownListEntries.Count
sp(j - 2, 1) = it.DropdownListEntries(j).Text
sp(j - 2, 2) = it.DropdownListEntries(j).Value
Next
sn(y) = sp
y = y + 1
End If
Next

With GetObject("G:\OF\example.xlsx")
For j = 0 To y - 1
.sheets(1).Cells(1, j * 4 + 1).Resize(UBound(sn(j)), 3) = sn(j)
Next
.Visible=true
.Close -1
End With
End Sub

@Artik

When storing data in Arrays you can use anything you like to adapt them; I'd prefer a userform to adapt the contents of a contentcontrol. I wouldn't use another Office program to adapt information in a Word document; and I would definitely abstain from using the ADODB library.

[Artik]

Because it is an educational project, I will take something out of it too. :)
I like this:
If InStr("4_3_", it.Type & "_") Then :thumb

Artik

[snb]

To illustrate what I mean:

Contentcontrol properties are being stored into Document variables.

The userform reads all document variables and shows each of them as a tabstrip Tab.

The tabstrip contains the texts & values of each contentcontrol.
If you adapt the text and values in the textboxes they will be stored into the documentvariables and the corresponding contentcontrol will be modified.

And Yes, you are right: this can be done without any storing in documentvariables. The userform can read and write directly into the contentcontrol.
Since Greg isn't very specific why he wants to store the properties of the contentcontrol I left the storing procedure intact.

The second attachment directly links the Userform to the contentcontrols.

[gmaxey]

snb,

True to your characteristic arrogance, you assume what a perfect stranger is and what he or she "should be familiar with." In truth, with the exception of this project and a few others, I rarely use Excel. But thanks of course for pointing out your superiority and my ignorance.

Additionally, your code first posted (now that I am so enlightened of course and can see the results before hidden), was not storing the first dropdown value and not retrieving the title, tag, or placeholder text. Your code slightly revised now does that.


Sub M_snb()
Dim sn, it, sp, y, j
Dim oXL
ReDim sn(ActiveDocument.ContentControls.Count)

For Each it In ActiveDocument.ContentControls
If InStr("4_3_", it.Type & "_") Then
ReDim sp(it.DropdownListEntries.Count + 2, 2)
sp(0, 0) = it.Title
sp(1, 0) = it.Tag
sp(2, 0) = it.ID
sp(3, 0) = it.PlaceholderText

For j = 1 To it.DropdownListEntries.Count 'Your code as was was not saving the first dropdown entry.
sp(j - 1, 1) = it.DropdownListEntries(j).Text
sp(j - 1, 2) = it.DropdownListEntries(j).Value
Next
sn(y) = sp
y = y + 1
End If
Next
Set oXL = GetObject(ThisDocument.Path & "\CCAttrs.xlsx")

With oXL
For j = 0 To y - 1
.sheets(1).Cells(1, j * 4 + 1).Resize(UBound(sn(j)), 3) = sn(j)
Next
.Visible = True
.Save
.Close = -1
.Application.Quit
End With
End Sub
Sub snb_retrieve()
Dim it, j, sn
For Each it In GetObject(ThisDocument.Path & "\CCAttrs.xlsx").sheets(1).usedrange.Rows(1).specialcells(2).areas
sn = it.currentregion.Resize(, 3)
With ActiveDocument.ContentControls(CStr(sn(3, 1)))
.Title = sn(1, 1)
.Tag = sn(2, 1)
.SetPlaceholderText , , sn(4, 1)
With .DropdownListEntries
.Item(1).Text = sn(1, 2)
For j = .Count To 2 Step -1 'Your code as clearing the default placeholder choice.
.Item(j).Delete
Next j
For j = 1 To UBound(sn)
If sn(j, 2) <> "" And sn(j, 3) <> "" Then .Add sn(j, 2), sn(j, 3)
Next
End With
End With
Next
End Sub

[snb]

But isn't the whole exercise a (redundant) replacement for :


Sub M_snb()
For Each it In ActiveDocument.ContentControls
it.Range.Select
Application.Dialogs(2394).Show
Next
End Sub

[gmaxey]

No it isn't. The purpose of the exercise is to facilitate efficient review and editing CC dropdown lists. So just for an example lets assume that one of your "it" has 300 entries and you want to eliminate the 3rd, the 5th and 101 through 300. It is the 49th it among 50 sibling its in the document.

No I wouldn't want to loop through the first 48 other its to get to it; and comparing the redundant dialog, your userform and tabs and one of the code solutions involving Excel, (yours included) which to you feel is most efficient for the task?

Thanks for posting you solution.

From this seat, and I am the one needing to review and edit, one of the code solutions involving Excel works best.

[snb]

In that case you select the contentcontrol in design mode, rightclick and choose the option 'properties'.

[gmaxey]

Yes, we both know how to do it the hard way. I could do that and click items 101 though 300 one at a time and click remove for each or I could have all that information in an Excel sheet that I can now see (thanks to your earlier enlightening post), open that file and delete the entries 101 through 300 in a second or two and redefine the CCs.

I can't do that with the dialog or with your userform method. In any case, I see no point in debating with you why I chose the Excel route. It works for me and works using your solution or one of the others so thanks for you input as arrogant as it typically is.

[snb]

Don't tell me you use contentcontrols containing more than 30 items ?

In that case a Listbox (property Multiline : 2) is probably more apt.

[gmaxey]

snb,

Okay, I won't. However, one of my clients does and he also wants to review and edit the properties in an Excel file. Not a userform like your first or second which is perfectly useless in his case! Now like you and others here I often suggest what I feel are better solutions to clients; but since they are the ones writing the checks, I never argue with them about it or engage in endless debate attempting to prove I know a better way.

With some changes your Excel solutions is as good as any of the others. Thanks.

[Artik]

Greg, do you remember to check if the source file (XL) is closed before using ADO? If it was open, you would cause a memory leak.

Artik

[gmaxey]

Artik,

I haven't but I will. thanks.

[gmaxey]

Thanks guys for all of you help with this project. Practically any of the methods suggested will work but just out of curiosity, I decided to see if I could make snb's first proposal make sense to me and expand it a bit to included storing properties for other CC types. Here is the code I used and the two associated files are attached should anyone be interested.

I'm a real kludge with Excel so I'm sure there is room for improvement. Both procedures are run from the active document in Word.


Option Explicit
Private m_oCC As ContentControl
Sub StoreCCPropertiesToExel()
Dim varCLProps, varCProps, varIndProps, varAttr
Dim lngListCCsCount As Long, lngOtherCCsCount As Long, lngIndex As Long
Dim oXL As Object
ReDim varCLProps(0)
ReDim varCProps(0)
For Each m_oCC In ActiveDocument.ContentControls
With m_oCC
Select Case .Type
Case 0, 1, 2, 6, 8
ReDim Preserve varCProps(lngOtherCCsCount)
ReDim varIndProps(8, 0)
varIndProps(0, 0) = .ID
varIndProps(1, 0) = .Title
varIndProps(2, 0) = .Tag
On Error Resume Next
varIndProps(3, 0) = .LockContents
varIndProps(4, 0) = .LockContentControl
varIndProps(5, 0) = .PlaceholderText
If .Type = 0 Or .Type = 1 Then varIndProps(6, 0) = .Temporary
If .Type = 1 Then varIndProps(7, 0) = .MultiLine
varCProps(lngOtherCCsCount) = varIndProps
lngOtherCCsCount = lngOtherCCsCount + 1
Case 3, 4
ReDim Preserve varCLProps(lngListCCsCount)
If .DropdownListEntries.Count > 6 Then
ReDim varIndProps(.DropdownListEntries.Count, 2)
Else
ReDim varIndProps(6, 2)
End If
For lngIndex = 1 To .DropdownListEntries.Count
varIndProps(lngIndex - 1, 1) = .DropdownListEntries(lngIndex).Text
varIndProps(lngIndex - 1, 2) = .DropdownListEntries(lngIndex).Value
Next
varIndProps(0, 0) = .ID
varIndProps(1, 0) = .Title
varIndProps(2, 0) = .Tag
On Error Resume Next
varIndProps(3, 0) = .LockContents
varIndProps(4, 0) = .LockContentControl
varIndProps(5, 0) = .PlaceholderText
On Error GoTo 0
varCLProps(lngListCCsCount) = varIndProps
lngListCCsCount = lngListCCsCount + 1
End Select
End With
Next
Set oXL = GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
With oXL
.Sheets("Sheet1").Cells.Clear
.Sheets("Sheet2").Cells.Clear
ReDim varAttr(5, 0)
varAttr(0, 0) = "ID"
varAttr(1, 0) = "Titel"
varAttr(2, 0) = "Tag"
varAttr(3, 0) = "Locked"
varAttr(4, 0) = "Lock Content"
varAttr(5, 0) = "Placeholder Text"
.Sheets("Sheet1").Cells(1, 1).Resize(8, 1) = varAttr
For lngIndex = 0 To lngListCCsCount - 1
If lngIndex = 0 Then
.Sheets("Sheet1").Cells(1, 3).Resize(UBound(varCLProps(lngIndex)), 3) = varCLProps(lngIndex)
Else
.Sheets("Sheet1").Cells(1, ((lngIndex + 1) * 4 + 1) - 2).Resize(UBound(varCLProps(lngIndex)), 3) = varCLProps(lngIndex)
End If
Next
ReDim varAttr(7, 0)
varAttr(0, 0) = "ID"
varAttr(1, 0) = "Titel"
varAttr(2, 0) = "Tag"
varAttr(3, 0) = "Locked"
varAttr(4, 0) = "Lock Content"
varAttr(5, 0) = "Placeholder Text"
varAttr(6, 0) = "Temporary"
varAttr(7, 0) = "Multiline"
.Sheets("Sheet2").Cells(1, 1).Resize(8, 1) = varAttr
For lngIndex = 0 To lngOtherCCsCount - 1
.Sheets("Sheet2").Cells(1, (lngIndex + 1) * 2 + 1).Resize(UBound(varCProps(lngIndex)), 1) = varCProps(lngIndex)
Next
.Application.Windows("CCAttrs.xlsx").Visible = True
.Save
.Close -1
.Application.Quit
End With
lbl_Exit:
Set oXL = Nothing
Exit Sub
End Sub
Sub RetrieveCCProperties()
Dim lngIndex As Long
Dim varIndProps
Dim oRng As Object
Dim oXL As Object
Dim oCC As ContentControl
Set oXL = GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
With oXL.Sheets("Sheet1")
For Each oRng In .UsedRange.Rows(1).SpecialCells(2).Areas
varIndProps = oRng.CurrentRegion.Resize(, 3)
On Error Resume Next
Set oCC = ActiveDocument.ContentControls(CStr(varIndProps(1, 1))) 'This is the CC's unique ID
On Error GoTo 0
If Not oCC Is Nothing Then
With oCC
.Title = varIndProps(2, 1)
.Tag = varIndProps(3, 1)
.LockContents = varIndProps(4, 1)
.LockContentControl = varIndProps(5, 1)
.SetPlaceholderText , , varIndProps(6, 1)
Select Case .Type
Case 3, 4
With .DropdownListEntries
On Error Resume Next
.Item(1).Text = varIndProps(1, 2)
On Error GoTo 0
For lngIndex = .Count To 2 Step -1 'Clear all but the first default reset placeholder text entry.
.Item(lngIndex).Delete
Next lngIndex
For lngIndex = 2 To UBound(varIndProps)
'If varIndProps(lngIndex, 2) <> "" And varIndProps(lngIndex, 3) <> "" Then .Add varIndProps(lngIndex, 2), varIndProps(lngIndex, 3)
'On Error Resume Next
Select Case True
Case IsEmpty(varIndProps(lngIndex, 2)) And IsEmpty(varIndProps(lngIndex, 3))
'Do nothing. No data defined
Case IsEmpty(varIndProps(lngIndex, 2))
'Use defined value for both value and display
.Add varIndProps(lngIndex, 3), varIndProps(lngIndex, 3)
Case IsEmpty(varIndProps(lngIndex, 3))
'Use defined text for both display and value
.Add varIndProps(lngIndex, 2), varIndProps(lngIndex, 2)
Case Else
.Add varIndProps(lngIndex, 2), varIndProps(lngIndex, 3)
End Select
Next
End With
End Select
End With
End If
Set oCC = Nothing
Next
End With
With oXL.Sheets("Sheet2")
For Each oRng In .UsedRange.Rows(1).SpecialCells(2).Areas
varIndProps = .Range(oRng, .Cells(.Rows.Count, oRng.Column).End(-4162))
On Error Resume Next
Set oCC = ActiveDocument.ContentControls(CStr(varIndProps(1, 1))) 'This is the CC's unique ID
On Error GoTo 0
If Not oCC Is Nothing Then
With oCC
On Error Resume Next
.Title = varIndProps(2, 1)
.Tag = varIndProps(3, 1)
.LockContents = varIndProps(4, 1)
.LockContentControl = varIndProps(5, 1)
.SetPlaceholderText , , varIndProps(6, 1)
.Temporary = varIndProps(7, 1)
.MultiLine = varIndProps(8, 1)
On Error GoTo 0
End With
End If
Set oCC = Nothing
Next
End With
With oXL
.Application.Windows("CCAttrs.xlsx").Visible = True
.Save
.Close -1
'.Application.Quit
End With
lbl_Exit:
Set oXL = Nothing
Exit Sub
End Sub


24772 24773

[snb]

To store the contentcontrol properties:

Sub M_snb()
ReDim sn(ActiveDocument.ContentControls.Count - 1)

For Each it In ActiveDocument.ContentControls
With it
st = Array("'" & .ID, .Title, .Type, .Tag, .LockContents, .LockContentControl, .PlaceholderText, .Temporary, " ", " ")
If InStr("34", .Type) Then
st(8) = .MultiLine
For j = 1 To .DropdownListEntries.Count
With .DropdownListEntries(j)
st(9) = st(9) & vbLf & .Text & vbTab & .Value
End With
Next
st = Split(Join(st, vbLf), vbLf)
End If
End With
sn(y) = st
y = y + 1
Next

With GetObject(Application.Options.DefaultFilePath(0) & "\overzicht.xlsx")
.sheets(1).Cells.ClearContents
.sheets(1).Cells(1).Resize(, 3 * UBound(sn)) = " "
For j = 0 To UBound(sn)
.sheets(1).Cells(1, 1 + 3 * j).Resize(UBound(sn(j)) + 1) = .Application.transpose(sn(j))
Next
.sheets(1).Columns.AutoFit
.Close -1
End With
End Sub

To adapt the stored properties manually

Sub M_snb_adapt()
GetObject(Application.Options.DefaultFilePath(0) & "\overzicht.xlsx").Windows(1).Visible = True
End Sub

To retrieve the stored/adapted properties:

Sub M_snb_retrieve()
With GetObject(Application.Options.DefaultFilePath(0) & "\overzicht.xlsx")
.sheets(1).Cells.specialcells(4).Delete -4162
.Save
sn = .sheets(1).Cells(1).currentregion
.Close 0
End With

For jj = 1 To UBound(sn, 2)
If sn(1, jj) <> " " Then
With ActiveDocument.ContentControls(sn(1, jj))
.Title = sn(2, jj)
.Type = sn(3, jj)
.Tag = sn(4, jj)
.LockContents = sn(5, jj)
.LockContentControl = sn(6, jj)
.SetPlaceholderText , , sn(7, jj)
.Temporary = sn(8, jj)
If InStr("34", sn(3, jj)) Then
.MultiLine = sn(9, jj)
.DropdownListEntries.Clear
For j = 11 To UBound(sn)
If sn(j, jj) <> "" Then .DropdownListEntries.Add Split(sn(j, jj), vbTab)(0), Split(sn(j, jj), vbTab)(1)
Next
End If
End With
End If
Next
End Sub

NB. Since the thread title is 'best practices' I'd suggest to check in Wikipedia the meaning in mathematics of

- Ockham's razor
- the principle of parsimony
- the qualification 'elegance' for formulae, solutions, coding

[gmaxey]

One ponders your motives snb. Do you really want to help or is your overriding motivation to prove your superiority?

I'm sure that if I read your suggestions and given time I might approach the lofty levels you inhabit. That just isn't my objective. Sorry.

Your last posting is interesting and again in a bow to you, I have adapted it somewhat for my purpose so tomorrow, or next week, next month, I can understand it. I don't concern myself with your aversion to declare variables so please return the favor and don't be concerned that I do.

First I added a legend to the left side of the sheet and removed the two columns separating the data.

The list entries appeared butted up together in the sheet so I replaced your tab delimiter with a "~*~". I will still need to add a error handler in case someone should edit the sheet with duplicate list entry values. That is easy enough or I can try to figure out how to format those cells in Excel with a duplicate check.

For some reason your suggested .Visible=true is changed to .Visible = True but does not run (errors)

Type 3 and 4 CCs don't have mulitline that is type 1 only.

It would be nice the data was single column for types 0 - 2, 6 and 8 and two columns for type 3 and 4 which would make editing the list display and list values easier. I may try to figure that out.


Sub StoreCCsPropertiesToExcel()
Dim varCCs As Variant, varAttrs As Variant
Dim lngIndex As Long, lngLE As Long
Dim oCC As ContentControl

ReDim varCCs(ActiveDocument.ContentControls.Count)
varAttrs = Array("ID", "Title", "Type", "Tag", "LockContents", "LockContentControl", "Placeholder Text", "Temporary", "Multiline", "", "", "List Entries")
varCCs(lngIndex) = varAttrs
For Each oCC In ActiveDocument.ContentControls
lngIndex = lngIndex + 1
With oCC
varAttrs = Array("'" & .ID, .Title, .Type, .Tag, .LockContents, .LockContentControl, .PlaceholderText, .Temporary, " ", " ")
If .Type = 1 Then varAttrs(8) = .MultiLine
If InStr("34", .Type) Then
For lngLE = 1 To .DropdownListEntries.Count
With .DropdownListEntries(lngLE)
varAttrs(9) = varAttrs(9) & vbLf & .Text & "~*~" & .Value
End With
Next
varAttrs = Split(Join(varAttrs, vbLf), vbLf)
End If
End With
varCCs(lngIndex) = varAttrs
Next oCC
With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.sheets(1).Cells.ClearContents
.sheets(1).Cells(1).Resize(, 1 * UBound(varCCs)) = " "
For lngIndex = 0 To UBound(varCCs)
.sheets(1).Cells(1, 1 + 1 * lngIndex).Resize(UBound(varCCs(lngIndex)) + 1) = .Application.transpose(varCCs(lngIndex))
Next
.sheets(1).Columns.AutoFit
.Application.Windows("CCAttrs.xlsx").Visible = True 'Just your .Visible=true didn't work here.
.Save
.Close -1
End With
End Sub

Sub M_snb_adapt()
'This doesn't do anything but open an instance of Excel in the background. It isn't visible.
GetObject(ThisDocument.Path & "\CCAttrs.xlsx").Windows(1).Visible = True
End Sub

Sub RetrieveCCPropertiesFromExcel()
Dim varAttrs As Variant, varLEs As Variant
Dim lngAttr As Long, lngLE As Long
With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.sheets(1).Cells.specialcells(4).Delete -4162
.Application.Windows("CCAttrs.xlsx").Visible = True
.Save
varAttrs = .sheets(1).Cells(1).currentregion
.Close 0
End With
For lngAttr = 2 To UBound(varAttrs, 2)
If varAttrs(1, lngAttr) <> " " Then
With ActiveDocument.ContentControls(varAttrs(1, lngAttr))
.Title = varAttrs(2, lngAttr)
.Type = varAttrs(3, lngAttr)
.Tag = varAttrs(4, lngAttr)
.LockContents = varAttrs(5, lngAttr)
.LockContentControl = varAttrs(6, lngAttr)
.SetPlaceholderText , , varAttrs(7, lngAttr)
If InStr("01", varAttrs(3, lngAttr)) Then .Temporary = varAttrs(8, lngAttr)
If .Type = 1 Then .MultiLine = varAttrs(9, lngAttr)
If InStr("34", varAttrs(3, lngAttr)) Then
.DropdownListEntries.Clear
For lngLE = 11 To UBound(varAttrs)
If varAttrs(lngLE, lngAttr) <> "" Then
varLEs = Split(varAttrs(lngLE, lngAttr), "~*~")
Select Case True
Case IsEmpty(varLEs(0))
'Use defined value for both value and display
.DropdownListEntries.Add varLEs(1), varLEs(1)
Case IsEmpty(varLEs(1))
'Use defined text for both display and value
.DropdownListEntries.Add varLEs(0), varLEs(0)
Case Else
.DropdownListEntries.Add varLEs(0), varLEs(1)
End Select
End If
Next
End If
End With
End If
Next
End Sub

[snb]

With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.sheets(1).Cells.ClearContents
1 .sheets(1).Cells(1).Resize(, 1 * UBound(varCCs)) = " "
For lngIndex = 0 To UBound(varCCs)
2 .sheets(1).Cells(1, 1 + 1 * lngIndex).Resize(UBound(varCCs(lngIndex)) + 1) = .Application.transpose(varCCs(lngIndex))
Next
.sheets(1).Columns.AutoFit
3 .Application.Windows("CCAttrs.xlsx").Visible = True 'Just your .Visible=true didn't work here.
4 .Save
.Close -1
End With

1. 1*Ubound(sn)= Ubound(sn)

.sheets(1).Cells(1).Resize(, UBound(varCCs)) = " "

2. .sheets(1).Cells(1, 1 + 1 * lngIndex).Resize(UBound(varCCs(lngIndex)) + 1)
I would use
.sheets(1).Cells(1, 1 + lngIndex).Resize(UBound(varCCs(lngIndex))+1)

3. Why making the file visible ? If you use the macro M_adapt the file will always be visible when needed for any manual adaptation.
Now it is only slowing down the macro and creating an unstable screen.

you could have noticed in M_adapt that instead of

.Application.Windows("CCAttrs.xlsx").Visible = True

.windows(1).visible=true

suffices

4. .Close -1 saves any changes before closing the file, so .Save is redundant.

5. Instead of
varAttrs = Array("ID", "Title", "Type", "Tag", "LockContents", "LockContentControl", "Placeholder Text", "Temporary", "Multiline", "", "", "List Entries")
varCCs(lngIndex) = varAttrs


varCCs(lngIndex) = split("ID Title Type Tag LockContents LockContentControl PlaceholderText Temporary Multiline ListEntries")

[gmaxey]

snb,

Most of that was helpful. Thanks.

I suppose I want the file to be visible because I would simply like to open it like I open most Excel files i.e., using File Open and not have to use your macro which doesn't acually opne the file (at least not here).

As mentioned, before I thought it would be nice to have the List Entry display and List Entry value in two separate columns so I've tried my hand at it. What I've done may look like a dog's breakfast but it seems to work.

As CCs may appear in headers, footers, shapes, textboxes etc. I've added a function to get the entire collection.


Option Explicit
Sub StoreCCsPropertiesToExcel()
Dim varCCs As Variant, varAttrs As Variant
Dim lngCC As Long, lngIndex As Long, lngLE As Long
Dim oCC As ContentControl
Dim oCC_Col As Collection

Set oCC_Col = fcnGetCCCollection(ActiveDocument)
ReDim varCCs(0)
varCCs(lngIndex) = Split("ID|Title|Type|Tag|Lock Contents|Lock ContentControl|Placeholder Text|Temporary|Multiline||List Entries", "|")
For lngCC = 1 To oCC_Col.Count
Set oCC = oCC_Col.Item(lngCC)
lngIndex = lngIndex + 1
ReDim Preserve varCCs(lngIndex)
With oCC
varAttrs = Array("'" & .ID, .Title, .Type, .Tag, .LockContents, .LockContentControl, .PlaceholderText, .Temporary, " ", " ")
If .Type = 1 Then varAttrs(8) = .MultiLine
If InStr("34", .Type) Then
For lngLE = 1 To .DropdownListEntries.Count
With .DropdownListEntries(lngLE)
varAttrs(9) = varAttrs(9) & vbLf & .Text
End With
Next
varAttrs = Split(Join(varAttrs, vbLf), vbLf)
End If
varCCs(lngIndex) = varAttrs
If InStr("34", .Type) Then
lngIndex = lngIndex + 1
ReDim Preserve varCCs(lngIndex)
varAttrs = Array(" ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ")
For lngLE = 1 To .DropdownListEntries.Count
With .DropdownListEntries(lngLE)
varAttrs(9) = varAttrs(9) & vbLf & .Value
End With
Next lngLE
varAttrs = Split(Join(varAttrs, vbLf), vbLf)
varCCs(lngIndex) = varAttrs
End If
End With
Next lngCC
With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.sheets(1).Cells.ClearContents
.sheets(1).Cells(1).Resize(, UBound(varCCs)) = " "
For lngIndex = 0 To UBound(varCCs)
.sheets(1).Cells(1, 1 + lngIndex).Resize(UBound(varCCs(lngIndex)) + 1) = .Application.transpose(varCCs(lngIndex))
Next
.sheets(1).Columns.AutoFit
.Close -1
End With
lbl_Exit:
Exit Sub
End Sub

Sub M_snb_adapt()
With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.Windows(1).Visible = True
.Close -1
End With
End Sub

Sub RetrieveCCPropertiesFromExcel()
Dim varAttrs As Variant, varLEs As Variant
Dim lngAttr As Long, lngLE As Long, lngNextCol
Dim oCC As ContentControl
Dim bDup As Boolean

With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.sheets(1).Cells.specialcells(4).Delete -4162
varAttrs = .sheets(1).Cells(1).currentregion
.Close 0
End With
For lngAttr = 2 To UBound(varAttrs, 2)
On Error Resume Next
Set oCC = ActiveDocument.ContentControls(varAttrs(1, lngAttr))
On Error GoTo 0
If Not oCC Is Nothing Then
With oCC
.Title = varAttrs(2, lngAttr)
.Type = varAttrs(3, lngAttr)
.Tag = varAttrs(4, lngAttr)
.LockContents = varAttrs(5, lngAttr)
.LockContentControl = varAttrs(6, lngAttr)
.SetPlaceholderText , , varAttrs(7, lngAttr)
If InStr("01", varAttrs(3, lngAttr)) Then .Temporary = varAttrs(8, lngAttr)
If .Type = 1 Then .MultiLine = varAttrs(9, lngAttr)
If InStr("34", varAttrs(3, lngAttr)) Then
.DropdownListEntries.Clear
lngNextCol = lngAttr + 1
On Error GoTo Err_Duplicate
For lngLE = 11 To UBound(varAttrs)
Select Case True
Case IsEmpty(varAttrs(lngLE, lngAttr)) And IsEmpty(varAttrs(lngLE, lngNextCol))
'Do nothing, not LE defined
Case IsEmpty(varAttrs(lngLE, lngAttr))
'Use defined value for both value and display
.DropdownListEntries.Add varAttrs(lngLE, lngNextCol), varAttrs(lngLE, lngNextCol)
Case IsEmpty(varAttrs(lngLE, lngNextCol))
'Use defined text for both display and value
.DropdownListEntries.Add varAttrs(lngLE, lngAttr), varAttrs(lngLE, lngAttr)
Case Else
.DropdownListEntries.Add varAttrs(lngLE, lngAttr), varAttrs(lngLE, lngNextCol)
End Select
Dup_ReEntry:
Next lngLE
On Error GoTo 0
lngAttr = lngNextCol
End If
End With
End If
Set oCC = Nothing
Next lngAttr
If bDup Then MsgBox "One or more duplicate list entries were defined in the Excel source and could not be added to the list entries."
lbl_Exit:
Exit Sub
Err_Duplicate:
bDup = True
Resume Dup_ReEntry
End Sub

Function fcnGetCCCollection(oDoc As Document) As Collection
'Used in the Title and Taggin utility.
Dim lngValidator As Long
Dim oStoryRng As Word.Range
Dim oCC As ContentControl
Dim oShp As Shape
Dim strSelectedID As String
Dim lngItems As Long
Dim oColCCs As Collection

Set oColCCs = New Collection
lngValidator = oDoc.Sections(1).Headers(1).Range.StoryType
For Each oStoryRng In oDoc.StoryRanges
'Iterate through all linked stories
Select Case oStoryRng.StoryType
Case 1 To 11
Do
On Error Resume Next
For Each oCC In oStoryRng.ContentControls
oColCCs.Add oCC
Next oCC
Select Case oStoryRng.StoryType
Case 6, 7, 8, 9, 10, 11
If oStoryRng.ShapeRange.Count > 0 Then
For Each oShp In oStoryRng.ShapeRange
On Error GoTo Err_HasText
If oShp.TextFrame.HasText Then
For Each oCC In oShp.TextFrame.TextRange.ContentControls
oColCCs.Add oCC
Next oCC
End If
Err_HasText_ReEntry:
Next oShp
End If
Case Else
'Do Nothing
End Select
'Get next linked story (if any)
Set oStoryRng = oStoryRng.NextStoryRange
Loop Until oStoryRng Is Nothing
Case Else
End Select
Next oStoryRng
Set fcnGetCCCollection = oColCCs
Set oColCCs = Nothing
lbl_Exit:
Exit Function
Err_HasText:
Resume Err_HasText_ReEntry
End Function


One piece of ugliness is the


For lngLE = 11 To UBound(varAttrs) ....

If the document contained 300 type 3 or 4 CCs and most had <5 or less LEs and 1 had 300 LEs (not saying one would but just as an example), then there would be a lot of looping through that For ... Next loop.

Maybe some sort of escape in the event a couple successive empty values were returned. Still thinking on that.

I'm going to try to figure our how to apply a duplicate flag from rows 10 down in the sheet so if someone tries to define a duplicate entry in the list it will show an alert. However, what I have will certainly meet my requirements as is. Thanks snb, Artik, xld and ... others who replied.

[snb]

That's why I chose .text & vbtab & .Value

Then it is possible to use texttocolumns in Excel, splitting by vbtab.


columns(3).texttocolumns,,,,1,0,0,0,0

[gmaxey]

snb,

I don't know what you mean. So, maybe you could do that after the fact, but you didn't explain that. How would your code to retrieve work if you after the fact split your columns? Wouldn't you need to revise your retrieve code?

Don't you see that when you are so much smarter than everyone else and you think a) five miles ahead of them and b) ten feet over their heads; instead of being helpful, you frustrate.

Try a little humility. Try to accept that most people can't make sense out of your Spartan style regardless if it fits on the edge of Ockham's razor or "elegant" to a math geek.

Despite it being pointed out to you twice combobox CCs and DropdownList CCs (type 3 and 4) don't have a mulitline property.


BREAK

Sorry, the code I posted earlier had a serious flaw as the "Value" data was not matching up with the display data. I've fixed that here:


Option Explicit
Sub StoreCCsPropertiesToExcel()
Dim varCCs As Variant, varAttrs As Variant
Dim lngCC As Long, lngIndex As Long, lngLE As Long
Dim oCC As ContentControl
Dim oCC_Col As Collection

Set oCC_Col = fcnGetCCCollection(ActiveDocument)
ReDim varCCs(0)
varCCs(lngIndex) = Split("ID|Title|Type|Tag|Lock Contents|Lock ContentControl|Placeholder Text|Temporary|Multiline||List Entries", "|")
For lngCC = 1 To oCC_Col.Count
Set oCC = oCC_Col.Item(lngCC)
lngIndex = lngIndex + 1
ReDim Preserve varCCs(lngIndex)
With oCC
varAttrs = Array(.ID, .Title, .Type, .Tag, .LockContents, .LockContentControl, .PlaceholderText, .Temporary, " ", " ")
If .Type = 1 Then varAttrs(8) = .MultiLine
If InStr("34", .Type) Then
For lngLE = 1 To .DropdownListEntries.Count
With .DropdownListEntries(lngLE)
varAttrs(9) = varAttrs(9) & vbLf & .Text
End With
Next
varAttrs = Split(Join(varAttrs, vbLf), vbLf)
End If
varCCs(lngIndex) = varAttrs
If InStr("34", .Type) Then
lngIndex = lngIndex + 1
ReDim Preserve varCCs(lngIndex)
varAttrs = Array(" ", " ", " ", " ", " ", " ", " ", " ", " ", " ")
For lngLE = 1 To .DropdownListEntries.Count
With .DropdownListEntries(lngLE)
If .Value = vbNullString Then
varAttrs(9) = varAttrs(9) & vbLf & "~*~"
Else
varAttrs(9) = varAttrs(9) & vbLf & .Value
End If
End With
Next lngLE
varAttrs = Split(Join(varAttrs, vbLf), vbLf)
varCCs(lngIndex) = varAttrs
End If
End With
Next lngCC
With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.sheets(1).Cells.ClearContents
.sheets(1).Cells(1).Resize(, UBound(varCCs)) = " "
For lngIndex = 0 To UBound(varCCs)
.sheets(1).Cells(1, 1 + lngIndex).Resize(UBound(varCCs(lngIndex)) + 1) = .Application.transpose(varCCs(lngIndex))
Next
.sheets(1).Columns.AutoFit
.Close -1
End With
lbl_Exit:
Exit Sub
End Sub

Sub M_snb_adapt()
With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.Windows(1).Visible = True
.Close -1
End With
End Sub

Sub RetrieveCCPropertiesFromExcel()
Dim varRowData As Variant, varLEs As Variant
Dim lngAttr As Long, lngLE As Long, lngNextCol
Dim oCC As ContentControl
Dim bDup As Boolean

With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
.sheets(1).Cells.specialcells(4).Delete -4162
varRowData = .sheets(1).Cells(1).currentregion
.Close 0
End With
For lngAttr = 2 To UBound(varRowData, 2)
On Error Resume Next
Set oCC = ActiveDocument.ContentControls(CStr(varRowData(1, lngAttr)))
On Error GoTo 0
If Not oCC Is Nothing Then
With oCC
.Title = varRowData(2, lngAttr)
.Type = varRowData(3, lngAttr)
.Tag = varRowData(4, lngAttr)
.LockContents = varRowData(5, lngAttr)
.LockContentControl = varRowData(6, lngAttr)
.SetPlaceholderText , , varRowData(7, lngAttr)
If InStr("01", varRowData(3, lngAttr)) Then .Temporary = varRowData(8, lngAttr)
If .Type = 1 Then .MultiLine = varRowData(9, lngAttr)
If InStr("34", varRowData(3, lngAttr)) Then
.DropdownListEntries.Clear
On Error GoTo Err_Duplicate
For lngLE = 11 To UBound(varRowData)
Select Case True
Case IsEmpty(varRowData(lngLE, lngAttr)) And IsEmpty(varRowData(lngLE, lngAttr + 1))
'Do nothing, not LE defined
Case IsEmpty(varRowData(lngLE, lngAttr + 1))
'Use defined display for both display and value
.DropdownListEntries.Add varRowData(lngLE, lngAttr), varRowData(lngLE, lngAttr)
Case IsEmpty(varRowData(lngLE, lngAttr + 1))
'Use defined value for both display and value
.DropdownListEntries.Add varRowData(lngLE, lngAttr + 1), varRowData(lngLE, lngAttr + 1)
Case Else
If lngLE = 11 And varRowData(lngLE, lngAttr + 1) = "~*~" Then
.DropdownListEntries.Add varRowData(lngLE, lngAttr), ""
Else
.DropdownListEntries.Add varRowData(lngLE, lngAttr), varRowData(lngLE, lngAttr + 1)
End If
End Select
Dup_ReEntry:
Next lngLE
On Error GoTo 0
lngAttr = lngAttr + 1
End If
End With
End If
Set oCC = Nothing
Next lngAttr
If bDup Then MsgBox "One or more duplicate list entries were defined in the Excel source and could not be added to the list entries."
lbl_Exit:
Exit Sub
Err_Duplicate:
bDup = True
Resume Dup_ReEntry
End Sub

Function fcnGetCCCollection(oDoc As Document) As Collection
'Used in the Title and Taggin utility.
Dim lngValidator As Long
Dim oStoryRng As Word.Range
Dim oCC As ContentControl
Dim oShp As Shape
Dim strSelectedID As String
Dim lngItems As Long
Dim oColCCs As Collection

Set oColCCs = New Collection
lngValidator = oDoc.Sections(1).Headers(1).Range.StoryType
For Each oStoryRng In oDoc.StoryRanges
'Iterate through all linked stories
Select Case oStoryRng.StoryType
Case 1 To 11
Do
On Error Resume Next
For Each oCC In oStoryRng.ContentControls
oColCCs.Add oCC
Next oCC
Select Case oStoryRng.StoryType
Case 6, 7, 8, 9, 10, 11
If oStoryRng.ShapeRange.Count > 0 Then
For Each oShp In oStoryRng.ShapeRange
On Error GoTo Err_HasText
If oShp.TextFrame.HasText Then
For Each oCC In oShp.TextFrame.TextRange.ContentControls
oColCCs.Add oCC
Next oCC
End If
Err_HasText_ReEntry:
Next oShp
End If
Case Else
'Do Nothing
End Select
'Get next linked story (if any)
Set oStoryRng = oStoryRng.NextStoryRange
Loop Until oStoryRng Is Nothing
Case Else
End Select
Next oStoryRng
Set fcnGetCCCollection = oColCCs
Set oColCCs = Nothing
lbl_Exit:
Exit Function
Err_HasText:
Resume Err_HasText_ReEntry
End Function

[snb]

In international exchanges I prefer the ISO standards for measurements. Imperial (since when is the US an imperium?) are so 18th century-ish.

I see no need to enter the property labels in column A again and again. Once done manually we'd better leave it alone.
The CC-properties are being written into the sheet starting in cell C1

To illustrate .texttocolumn:


Sub M_snb()
ReDim sn(ActiveDocument.ContentControls.Count - 1)

For Each it In ActiveDocument.ContentControls
With it
st = Array("'" & .ID, .Title, .Type, .Tag, .LockContents, .LockContentControl, .PlaceholderText, .Temporary, " ", "")
If st(2) = 1 Then st(8) = .MultiLine
If InStr("34", .Type) Then
For j = 1 To .DropdownListEntries.Count
With .DropdownListEntries(j)
st(9) = st(9) & .Text & vbTab & .Value & vbLf
End With
Next
st = Split(Join(st, vbLf), vbLf)
End If
End With
sn(y) = st
y = y + 1
Next

With GetObject(Application.Options.DefaultFilePath(0) & "\overzicht.xlsx")
.sheets(1).usedrange.Offset(, 2).ClearContents
For j = 0 To UBound(sn)
With .sheets(1).Cells(1, 3 + 3 * j).Resize(UBound(sn(j)) + 1)
.Value = .Application.transpose(sn(j))
If InStr("34", sn(j)(2)) Then .Offset(1).texttocolumns , , , , 1, 0, 0, 0, 0
End With
Next
.sheets(1).Columns.AutoFit
.Close -1
End With
End Sub


Sub M_snb_retrieve()
With GetObject(Application.Options.DefaultFilePath(0) & "\overzicht.xlsx")
sn = .sheets(1).usedrange
.Close 0
End With

For jj = 3 To UBound(sn, 2)
If sn(1, jj) <> "" Then
With ActiveDocument.ContentControls(sn(1, jj))
.Title = sn(2, jj)
.Type = sn(3, jj)
.Tag = sn(4, jj)
.LockContents = sn(5, jj)
.LockContentControl = sn(6, jj)
.SetPlaceholderText , , sn(7, jj)
.Temporary = sn(8, jj)
If sn(3, jj) = 1 Then .MultiLine = sn(9, jj)

If InStr("34", sn(3, jj)) Then
.DropdownListEntries.Clear
For j = 10 To UBound(sn)
If sn(j, jj) <> "" Then .DropdownListEntries.Add sn(j, jj), sn(j, jj + 1)
Next
End If
End With
End If
Next
End Sub

To prevent double dropdownlistentries you only need to add
' On Error Resume Next"
in the retrieving macro.

NB.
Instead of varAttrs = Array(" ", " ", " ", " ", " ", " ", " ", " ", " ", " ")

you could use sn = Split(Replace(Space(10), " ", " _") & " ", "_")

[gmaxey]

snb,

Ok. 3 meters and 8K meters. Yes, the US is such a backwards state. Can't understand why so many people want to come here.

Again, I've attempted to adapt your examples to suit my particular style and requriements.

I didn't want all the empty columns remaining in the resulting worksheet so I've cobbled together a process to remove them. Overall, it seems to work well. Thanks for your interest even though it is always given with your characteristic arrogance and stuborness.





Sub StoreCCsPropertiesToExcel()
Dim oCC_Col As Collection
Dim oCC As ContentControl
Dim lngCC As Long, lngIndex As Long
Dim varCCs, varAttrs, varTitles
Dim oCol

'Get the entire document CC collection.
Set oCC_Col = fcnGetCCCollection(ActiveDocument)
ReDim varCCs(oCC_Col.Count - 1)
For lngCC = 1 To oCC_Col.Count
Set oCC = oCC_Col.Item(lngCC)
With oCC
'Store the common CC attributes and convert numerical type to proper name.
varAttrs = Array("'" & .ID, fncTypeToText(.Type), .Title, .Tag, .LockContents, .LockContentControl, .PlaceholderText, " ", " ", "")
'??? snb, what is the significance of " " vice "" in the line above?
If InStr("01", .Type) Then varAttrs(7) = .Temporary 'Save "Delete content control if contents edited property for Rich Text and Plain Text CCs.
If .Type = 1 Then varAttrs(8) = .MultiLine 'Save mulit-line property for Plain Text CCs.
If .Type = 2 Then varAttrs(6) = " " 'Clear FALSE Placeholder Text property for Picture CCs.
If .Type = 5 Then varAttrs(7) = .BuildingBlockType: varAttrs(8) = .BuildingBlockCategory 'Save Type and Gallery for Building Block CCs.
If .Type = 6 Then varAttrs(7) = .DateDisplayFormat 'Save date display format for Date CCs.
If .Type = 8 Then varAttrs(6) = " " 'Clear FALSE Placeholder Text property for Checkbox CCs.
If InStr("34", .Type) Then
For lngIndex = 1 To .DropdownListEntries.Count
With .DropdownListEntries(lngIndex)
varAttrs(9) = varAttrs(9) & .Text & vbTab & .Value & vbLf
End With
Next lngIndex
varAttrs = Split(Join(varAttrs, vbLf), vbLf)
End If
End With
varCCs(lngCC - 1) = varAttrs
Next lngCC

With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
If Not .sheets(1).Range("A1").Value = "Content control ID" Then
'Clear the sheet and add legend.
.sheets(1).Cells.ClearContents
varTitles = Split("Content control ID|Type|Title|Tag|Contents cannot be edited|Content control cannot be deleted|Placeholder Text" _
& "|Temporay/BB Gal/Date Format|Multi-Line/BB Cat|List Entries", "|")
.sheets(1).Cells(1, 1).Resize(UBound(varTitles) + 1).Value = .Application.transpose(varTitles)
Else
'Clear sheet except for legend.
.sheets(1).usedrange.Offset(, 2).ClearContents
End If
'Write the CC data to the sheet.
For lngCC = 0 To UBound(varCCs)
'Data is writen to single columns separated by an empty column
With .sheets(1).Cells(1, 2 + 2 * lngCC).Resize(UBound(varCCs(lngCC)) + 1)
.Value = .Application.transpose(varCCs(lngCC))
'Split the list entries into two columns.
If InStr("34", fncTypeToText(, CStr(varCCs(lngCC)(1)))) Then .Offset(1).texttocolumns , , , , 1, 0, 0, 0, 0
End With
Next
.sheets(1).Columns.AutoFit
'Remove remaining empty columns.
For lngIndex = .sheets(1).usedrange.Columns.Count To 1 Step -1
Set oCol = .sheets(1).usedrange.Cells(1, lngIndex).EntireColumn
If .Application.WorksheetFunction.CountA(oCol) = 0 Then
oCol.Delete
End If
Next lngIndex
.Windows(1).Visible = True 'Temp
.Close -1
End With
End Sub

Sub RetrieveCCPropertiesFromExcel()
Dim varRowData As Variant, varLEs As Variant
Dim lngAttr As Long, lngLE As Long, lngNextCol
Dim oCC As ContentControl
Dim bDup As Boolean

With GetObject(ThisDocument.Path & "\CCAttrs.xlsx")
varRowData = .sheets(1).usedrange
.Close 0
End With

For lngAttr = 2 To UBound(varRowData, 2)
On Error Resume Next
Set oCC = ActiveDocument.ContentControls(varRowData(1, lngAttr))
On Error GoTo 0
If Not oCC Is Nothing Then
With oCC
.Type = varRowData(2, lngAttr)
.Title = varRowData(3, lngAttr)
.Tag = varRowData(4, lngAttr)
.LockContents = varRowData(5, lngAttr)
.LockContentControl = varRowData(6, lngAttr)
Select Case .Type
Case 0, 1, 3, 4
.SetPlaceholderText , , varRowData(7, lngAttr)
If InStr("01", .Type) Then .Temporary = varRowData(8, lngAttr)
If .Type = 1 Then .MultiLine = varRowData(9, lngAttr)
Case 5
.SetPlaceholderText , , varRowData(7, lngAttr)
.BuildingBlockType = CLng(varRowData(8, lngAttr))
.BuildingBlockCategory = varRowData(9, lngAttr)
Case 6
.SetPlaceholderText , , varRowData(7, lngAttr)
.DateDisplayFormat = varRowData(8, lngAttr)
End Select
If InStr("34", varRowData(3, lngAttr)) Then
.DropdownListEntries.Clear
On Error GoTo Err_Duplicate
For lngLE = 10 To UBound(varRowData)
If varRowData(lngLE, lngAttr) <> "" Then .DropdownListEntries.Add varRowData(lngLE, lngAttr), varRowData(lngLE, lngAttr + 1)
Dup_ReEntry:
Next lngLE
End If
End With
End If
Set oCC = Nothing
Next lngAttr
If bDup Then MsgBox "One or more duplicate list entries were defined in the Excel source and could not be added to the list entries."
lbl_Exit:
Exit Sub
Err_Duplicate:
bDup = True
Resume Dup_ReEntry
End Sub

Function fcnGetCCCollection(oDoc As Document) As Collection
'Used in the Title and Taggin utility.
Dim lngValidator As Long
Dim oStoryRng As Word.Range
Dim oCC As ContentControl
Dim oShp As Shape
Dim strSelectedID As String
Dim lngItems As Long
Dim oColCCs As Collection

Set oColCCs = New Collection
lngValidator = oDoc.Sections(1).Headers(1).Range.StoryType
For Each oStoryRng In oDoc.StoryRanges
'Iterate through all linked stories
Select Case oStoryRng.StoryType
Case 1 To 11
Do
On Error Resume Next
For Each oCC In oStoryRng.ContentControls
oColCCs.Add oCC
Next oCC
Select Case oStoryRng.StoryType
Case 6, 7, 8, 9, 10, 11
If oStoryRng.ShapeRange.Count > 0 Then
For Each oShp In oStoryRng.ShapeRange
On Error GoTo Err_HasText
If oShp.TextFrame.HasText Then
For Each oCC In oShp.TextFrame.TextRange.ContentControls
oColCCs.Add oCC
Next oCC
End If
Err_HasText_ReEntry:
Next oShp
End If
Case Else
'Do Nothing
End Select
'Get next linked story (if any)
Set oStoryRng = oStoryRng.NextStoryRange
Loop Until oStoryRng Is Nothing
Case Else
End Select
Next oStoryRng
Set fcnGetCCCollection = oColCCs
Set oColCCs = Nothing
lbl_Exit:
Exit Function
Err_HasText:
Resume Err_HasText_ReEntry
End Function

Function fncTypeToText(Optional lngType As Long = 10, Optional strName As String = vbNullString)
Select Case lngType
Case 0: fncTypeToText = "Rich Text"
Case 1: fncTypeToText = "Plain Text"
Case 2: fncTypeToText = "Picture"
Case 3: fncTypeToText = "Combo Box"
Case 4: fncTypeToText = "Dropdown List"
Case 5: fncTypeToText = "Building Block Gallery"
Case 6: fncTypeToText = "Date"
Case 8: fncTypeToText = "Checkbox"
Case 9: fncTypeToText = "Repeating Section"
End Select
Select Case strName
Case "Rich Text": fncTypeToText = 0
Case "Plain Text": fncTypeToText = 1
Case "Picture": fncTypeToText = 2
Case "Combo Box": fncTypeToText = 3
Case "Dropdown List": fncTypeToText = 4
Case "Building Block Gallery": fncTypeToText = 5
Case "Date": fncTypeToText = 6
Case "Checkbox: fncTypeToText = 8"
Case "Repeating Section": fncTypeToText = 9
End Select
lbl_Exit:
Exit Function
End Function

[snb]

What is the benefit of putting all elements of the collection contentcontrols in a collection ?
It surely isn't 'best practice'.

[gmaxey]

Because ActiveDocument.ContentControls only returns the content controls in the main text storyrange of the document not the CCs in headers, footers, shapes etc.

So if it isn't 'best practice,' it is better than leaving them out.

varAttrs = Array("'" & .ID, fncTypeToText(.Type), .Title, .Tag, .LockContents, .LockContentControl, .PlaceholderText, " ", " ", "")
'??? snb, what is the significance of "'" and " " vice "" in the line above?

[SamT]

Greg,
From your post # 9 "The code never physically opens Excel to search."

Just dropped in from boredom, and your name caught my eye.

It seems to me that not opening Excel in the background memory is really making this more difficult. I would layout the data like Paul did in #8, but with an added empty column between each record. I would open objExcel in Word. Then I would use a Worksheet function to return the Record's Range Address to the SQLQuery in Word.

Word Code:

strMyVar = objExcel.Worksheet_Object_Name.GetRecordAddress occID

Sheet Code:

Public Function GetRecordAddress(occID As Variant) As String
'Returns an address or null

Dim tmp as Range
Set tmp = Row(n).Find(Cstr(occID))
If Not tmp is Nothing Then GetRecordAddress = tmp.CurrentRegion.Address
End Function
Of course if you don't use an empty column separator, then you will have to Set tmp using Offsets and Ends.

Personally, I would make the Worksheet a custom Object with Properties and Methods which Properties would return values as needed
Word Code:

Set myDB = 'Open the Custom Excel WorksheetObject
With myDB
.Record = occID
myocc.Name = .Name
myocc.Label = .label
etc
End With
Etc

Putting a For Each Item in MyDoc around the With Structure lets you loop thru all Controls, AND, ignores any orphan records in the worksheet.

[Paul_Hossler]

@SamT --

Welcome back -- been awhile :joy: :2jump:

I'm SO glad we're a relief for boredom :devil2:




I've been following this thread, but only made the one post since I don't know anything about ADODB, etc.
I also thought about a blank column to use .CurrentRegion, but since data is always stored in a 3 column block, I figured .Resize would work

Since there was nothing I could add to the solution, I've been just following out of interest and the interpersonal dynamics

[gmaxey]

Hey guys and particularly snb.

The method (an adaptation of snb) that I thought was working very well has just hit a major snag!! The issue seems related to this part of the code:

If InStr("34", fncTypeToText(, CStr(varCCs(lngCC)(1)))) Then .Offset(1).texttocolumns , , , , 1, 0, 0, 0, 0

... and it is seemingly madness.

When testing with some sample documents I had, I started getting errors that "Data is already found here, do you want to replace." Well as it turned out, for some reason if the CC.TAG is three or more words long e.g., "My Tag is A" then that line of code is splitting the column into three or more columns based on the "spaces" found in the text and the List Entries delimited with vbLf are not being split.

I've tried to refine that statement to "ONLY" split columns if the text is delimited with vbLF but nothing seems to work.

I also can't understand why the same thing doesn't happen if the Title or Placeholder text is more than two words. Very strange.

If this should go to a new thread, please advise.


24791
24790