Visual Basic Help

[Mal Shot First]

Does anyone here have experience with Visual Basic, and specifically with its application in MS Word macros? I've been trying to figure out how to work with the CustomXMLParts object in word, but I'm having some trouble putting together what seems like it should be a simple Sub statement.

[Mal Shot First]

I might as well describe my exact problem. There are two main things I want to accomplish:
1. I want to use custom-made content controls to create boxes where you can enter content in one place in the document so that it will be repeated wherever the same content control box appears in the document.
2. I want to create a macro that summarizes which content controls are used in the document and what the current content of those boxes is.

I've already found a solution for Step 1, but I'm struggling with Step 2. Just to provide a full picture of the situation, I'll post the code that worked for me to achieve Step 1. It's actually something I found online, so I didn't come up with it myself.

Code: Select all

Sub AddContentControlAndMapToCustomXMLPart()
Dim oRng As Word.Range
______________________________________________________________________________
Dim oCC As Word.ContentControl
Dim xPath As String
Dim pTitle As String
Dim pNodeBaseName As String
Set oRng = Selection.Range
On Error GoTo Err_Handler
Set oCC = ActiveDocument.ContentControls.Add(wdContentControlText, oRng)
pTitle = InputBox("Type the title of this ContentControl (e.g., Client Name)", "Create Title")
pNodeBaseName = Replace(pTitle, " ", "_") 'Node BaseNames can not contain spaces
CreateDataNode pNodeBaseName
xPath = "/Data/" & pNodeBaseName
With oCC
  .Title = pTitle
  .XMLMapping.SetMapping xPath
End With
Set oRng = Nothing
Set oCC = Nothing
Exit Sub
Err_Handler:
If Err.Number = 4605 Then
  MsgBox "A content control already exists at the selected range.  Please " _
         & " select another location.", vbInformation + vbOKOnly, "Select Another Location"
End If
End Sub
______________________________________________________________________________
Sub CreateCustomPart()
'Establish the base CustomXMLPart.
Set oCustPart = ActiveDocument.CustomXMLParts.Add _
                ("<?xml version='1.0' encoding='utf-8'?><Data></Data>")
ActiveDocument.Variables("custPartID").Value = oCustPart.ID
Set oCustPart = Nothing
End Sub
______________________________________________________________________________
Sub CreateDataNode(ByRef pBaseName As String)
Dim oNode As CustomXMLNode
Set oCustPart = ActiveDocument.CustomXMLParts.SelectByID _
                (ActiveDocument.Variables("custPartID").Value)
'Create a child node for the content control bound data.
If Not oCustPart Is Nothing Then
  Set oNode = oCustPart.SelectSingleNode("/Data")
  oCustPart.AddNode Parent:=oNode, Name:=pBaseName, NodeValue:=""
  Set oCustPart = Nothing
  Set oNode = Nothing
  'Or use
  'oNode.AppendChildNode Name:=pBaseName, NodeValue:=""
Else 'The base CustomXMLPart does not yet exist.  Create it.
  CreateCustomPart
  CreateDataNode pBaseName
End If
End Sub
______________________________________________________________________________
Sub CleanUp()
'Can be used to delete the CustomXMLPart used for mapping.
On Error Resume Next
Set oCustPart = ActiveDocument.CustomXMLParts.SelectByID _
                (ActiveDocument.Variables("custPartID").Value)
oCustPart.Delete
On Error GoTo 0
End Sub

This macro does a couple of things when you run it: It pops up a window asking you to enter a title for the content control you're inserting (screenshot 01) and then it inserts the content control box wherever your cursor is placed in the document. You can then enter whatever text you want in the box and copy/paste it as many times as you want. So if I replaced "Hello there!" (screenshot 02) in the top box with some other text, that text would automatically be updated in the bottom box.

So that's the part that works great. I just don't know how to run a summary of all the content controls in the document.

I feel like I have found an approach to the solution, but I'm missing the know-how to get there. As you may know, MS Word has built-in content controls: namely, for placing info about the document properties into the text. For example, one of these document properties is the document title (accessible through Insert > Quick Parts > Document Property > Title). Let's say you enter "Citizen Kane" as the title, but you leave all other document properties blank; you can then run a macro to summarize the content you've entered:

Code: Select all

Sub cmdReadProps_Click()

    Dim sTitle As String
    Dim sCompany As String
    Dim sSubject As String
    Dim sCategory As String
    sTitle = ActiveDocument.BuiltInDocumentProperties(wdPropertyTitle)
    sCompany = ActiveDocument.BuiltInDocumentProperties(wdPropertyCompany)
    sSubject = ActiveDocument.BuiltInDocumentProperties(wdPropertySubject)
    sCategory = ActiveDocument.BuiltInDocumentProperties(wdPropertyCategory)
    MsgBox "The REPORT TITLE is currently " & sTitle & "." & vbNewLine & "The COMPANY NAME is currently " & sCompany & "." & vbNewLine & "The SUBJECT is currently " & sSubject & "." & vbNewLine & "The CATEGORY is currently " & sCategory & ".", vbOKOnly + vbInformation
     
End Sub

When you run this macro, it will pop up a window showing the following results:

The REPORT TITLE is currently Citizen Kane.
The COMPANY NAME is currently [Company Name].
The SUBJECT is currently [Subject].
The CATEGORY is currently [Category].

Since "Citizen Kane" is the only property that was entered, that one is the only result that will represent actual content; all the words within brackets are merely placeholders (that's how I set up my document - if you don't enter placeholders, I think it would just be a blank space before the period).

Anyway, I'd like to modify this second bit of code I presented in order to pull in the information from the custom content controls instead of pulling it from the built-in document properties. Problem is, I don't know what I need to do to accomplish that. Essentially, it seems like the solution would be to replace ActiveDocument.BuiltInDocumentProperties(wdPropertyTitle) with another object, but I've tried messing around with ActiveDocument.CustomXMLParts without any success.

Am I even on the right track here? What would I need to do if I wanted to pull in the "Custom Content" box from screenshot 02? That is, I would want the summary to include the following line: "The CUSTOM CONTENT is currently Hello there!." How would I go about doing that?

[Mal Shot First]

I've been looking around some more for possible solutions and discovered that there is also an ActiveDocument.ContentControls object that might be what I'm looking for, but I'm so confused at this point about how all this stuff works.

[The Swollen Goiter of God]

I taught myself the rudiments of Commodore BASIC when I was a kid, and I briefly took a BASIC course with my grandmother before she dropped out and I lost my ride. I keep meaning to relearn it, but I also keep doing other things. (Reading and writing, mostly. The same two things that have kept me too occupied to pick music and drawing back up and has also kept me from learning any Russian or Irish. Well, lack of talent and living with other people have both been stumbling blocks where music is concerned. My elbow has been a stumbling block where drawing is concerned.)

Anyway, I'm no help. Maybe Jubbers can help, but she may not see this until after the work day is done.

[Mal Shot First]

I looked around a bit more online to find some potential solutions, and I think I'm getting closer. I can now compile a summary containing precisely one of the content controls used in the document. The question now is how to add more to the list. Here's what I have so far.

I created a content control titled "Company Name" and entered [NAME] as a placeholder in the box (screenshot 01).

When I run the script below, it correctly identifies the content of the box (screenshot 02).

Code: Select all

Sub Summary_of_Content_Controls()

Dim oDoc As Document
Dim oCC As contentControl
Dim sText As String
Dim bFound As Boolean
    Set oDoc = activeDocument
    For Each oCC In oDoc.contentControls
        If oCC.Title = "Company Name" Then
            If Not oCC.range.Text = oCC.PlaceholderText Then
                'do something with the content control
                bFound = True
                MsgBox "The " & oCC.Title & " property is currently set to " & oCC.range.Text & "."
                Exit For    'stop looking
            End If
        End If
    Next oCC
    If Not bFound Then MsgBox "Control not found"
lbl_Exit:
    Set oDoc = Nothing
    Set oCC = Nothing
    Exit Sub
End Sub

Unfortunately, now I'm stuck again. I'd like to add another If-Then statement to capture a second content control title. Each content control has properties where you can define a title (in the code above, this is the oCC.Title object, which is "Company Name" for the content control that's currently in the document). If I now add a second content control to the document (e.g., Company Phone), how would I need to modify the script so that it returns the message from screenshot 02 for each content control?

I don't care if the summary comes in the form of one list

The Company Name property is currently set to [NAME].
The Company Phone property is currently set to [PHONE].

or in the form of separate consecutive popup windows that you click away by pressing OK.

The Company Name property is currently set to [NAME].

The Company Phone property is currently set to [PHONE].

I assume there would need to be several If-Then statements in the script, and each would need to be executed (rather than the script ending once the first condition it encounters is satisfied).

[Jubbers]

I'll take a look when I get off work. 75% of my job is VBA, though mostly with Excel and occasionally PowerPoint.

[Mal Shot First]

Thanks, Jubbers! I appreciate it.

[Mal Shot First]

I should mention that there's no big rush on this. If you don't get to it tonight, it's no big deal.

[Jubbers]

I deleted most of the code in part #1, removing all of the XML stuff. That helped.

New part 1:

Code: Select all

Sub AddContentControl()
    Dim oRng As Word.Range
    Dim oCC As Word.ContentControl
    Dim pTitle As String
    Set oRng = Selection.Range
    On Error GoTo Err_Handler
    Set oCC = ActiveDocument.ContentControls.Add(wdContentControlText, oRng)
    pTitle = InputBox("Type the title of this ContentControl (e.g., Client Name)", "Create Title")
    oCC.Title = Replace(pTitle, " ", "_") 'Node BaseNames can not contain spaces
    Set oRng = Nothing
    Set oCC = Nothing
    Exit Sub
Err_Handler:
If Err.Number = 4605 Then
MsgBox "A content control already exists at the selected range.  Please " _
& " select another location.", vbInformation + vbOKOnly, "Select Another Location"
End If

End Sub

I ran the macro three times:

VBCodeScreenshot1.png (4.23 KiB) Viewed 28161 times

I then hit enter a bunch of times to get further down in the document, and ran this to summarize the content controls:

Code: Select all

Sub SumUpEverything()

    Dim j As Integer
    For j = 1 To ActiveDocument.ContentControls.Count
        ActiveDocument.Content.InsertAfter ("The " & ActiveDocument.ContentControls(j).Title & " is currently " & ActiveDocument.ContentControls(j).Range.Text & "." & vbCr)
    Next
End Sub

Which looked like this:

VBCodeScreenshot2.png (3.88 KiB) Viewed 28161 times

Hope that's close to what you were after.

[Mal Shot First]

Jubbers, you are amazing! I mean that in all seriousness: What an elegant solution compared to my clumsy attempts!

[Peter Falk]I just have one more question[/Peter Falk]:
Is there a way to limit the summary to include only unique values? Here's why I ask: If I repeat the same content control multiple times in the text, the summary will list every instance of that content control.

screenshot-01.png (6.7 KiB) Viewed 28155 times

When there are only a few content controls in the document, it's not a big inconvenience to have duplicates in the summary, but I'm constructing a document where each content control is repeated 10 or more times, so the summary list would get quite inflated if it lists all the duplicates. Is there a relatively simple way to get the summary to return only unique values?

[Jubbers]

Can I have the output of the summary be in Excel?

[Mal Shot First]

Works for me.

[Jubbers]

Cool

Code: Select all

Sub SumUpEverything()
    Dim objExcel As Excel.Application, newWorkbook As Excel.Workbook, j As Integer, rowCount As Integer
    Dim k As Integer, controlExists As Integer

    'Is Excel Open?
    On Error Resume Next
    Set objExcel = GetObject(, "Excel.Application")
    If Err Then
        Set objExcel = New Excel.Application
    End If
    On Error GoTo 0
    
    'Next line important else you have Excel running in background and you can't see anything :P
    objExcel.Visible = True
        
    Set newWorkbook = objExcel.Workbooks.Add
        
    'Header Row if you want, else delete next two lines and set rowCount = 1
    newWorkbook.Sheets(1).Cells(1, 1).Value = "Title"
    newWorkbook.Sheets(1).Cells(1, 2).Value = "Value"
    rowCount = 2
    
    For j = 1 To ActiveDocument.ContentControls.Count
        controlExists = 0
        For k = 1 To rowCount
            If newWorkbook.Sheets(1).Cells(k, 1).Value = ActiveDocument.ContentControls(j).Title And newWorkbook.Sheets(1).Cells(k, 2).Value = ActiveDocument.ContentControls(j).Range.Text Then
                controlExists = 1
            End If
        Next
        
        If controlExists = 0 Then
            newWorkbook.Sheets(1).Cells(rowCount, 1).Value = ActiveDocument.ContentControls(j).Title
            newWorkbook.Sheets(1).Cells(rowCount, 2).Value = ActiveDocument.ContentControls(j).Range.Text
            rowCount = rowCount + 1
        End If
        
    Next
End Sub

[Mal Shot First]

Hm, I get the following error message when I try to run that macro:

screenshot-01.png (31.84 KiB) Viewed 28148 times

Not sure if it's related to my version of MS Office. I'm using Office 2016.

[The Swollen Goiter of God]

I meant to ask last night which version of Office you were using. I am a poor man with a poor man's older version of Office.

[Jubbers]

I left out a step - in order to enable Excel manipulation from Word, you have to add a "reference" to enable the Excel code from inside Word.

In the VB Editor window, you go to Tools -> References

screenshot1.png (11.51 KiB) Viewed 28145 times

Then you scroll through the giant list of things until you find "Microsoft Excel [some number] Object Library":

screenshot2.png (22.51 KiB) Viewed 28145 times

That should enable it to work.

[Mal Shot First]

Thanks, Jubbers - worked like a charm!

I modified your code a little bit to format the Excel output:

Code: Select all

Set newWorkbook = objExcel.Workbooks.Add
        
    'Header Row if you want, else delete next two lines and set rowCount = 1
    newWorkbook.Sheets(1).Cells(1, 1).Value = "Content Control Title"
    newWorkbook.Sheets(1).Cells(1, 2).Value = "Content Control Value"
    rowCount = 2
    
    With newWorkbook.Sheets(1).Cells(1, 1).Font
    .FontStyle = "Bold"
    End With
    
    With newWorkbook.Sheets(1).Columns("A")
    .ColumnWidth = 25
    End With
    
    With newWorkbook.Sheets(1).Cells(1, 2).Font
    .FontStyle = "Bold"
    End With
    
    With newWorkbook.Sheets(1).Columns("B")
    .ColumnWidth = 33
    End With

This is awesome. Thanks again for your help!

[Jubbers]

I meant to ask last night which version of Office you were using. I am a poor man with a poor man's older version of Office.

Our version at work is a middle child between you and Mal.

[Mal Shot First]

The 2016 version I use is the one they provided to me at work. I didn't even know there was a 2015 version. The one I have on my personal computer is 2007.

[Mal Shot First]

In case you're curious what I was trying to accomplish, I am putting together a report template for work. There are elements in the report that get repeated throughout (e.g., the product name) and in the current template there are placeholders that you'd have to replace manually. I guess you could do a "find/replace all" and replace each placeholder that way, but I wanted to find a different solution.

The reason I was using the VBA code with the XML parts in it was to create content controls where you would type the text you want in one place in the document and the text would be updated in all other content controls of the same name throughout the document.

For example:

[Product Name] is a great product that everyone should use. I use [Product Name] every day to help me take the edge off. Ask your doctor if [Product Name] is right for you.

If the brackets in the example above represent the Product Name content control, I could then type the actual name of the product into any one of them, and it would automatically appear in all three locations. Atrejub's cleaned-up code (without the XML) didn't allow for this - I think it's because the XML parts basically create a storage space where the text that's linked to a particular content control title is saved. However, it wasn't a big deal because I found a different way of going about getting the result that I wanted.

In the end, I created exactly one content control box for each element I needed. There were 11 of those. Then, for each content control name, I would create a corresponding Document Variable that would be defined by running a macro:

Code: Select all

Sub GetSetDocVars()

   activeDocument.Variables("Variable01").Value = activeDocument.contentControls(1).range.Text
   activeDocument.Variables("Variable02").Value = activeDocument.contentControls(2).range.Text
   activeDocument.Variables("Variable03").Value = activeDocument.contentControls(3).range.Text
   activeDocument.Variables("Variable04").Value = activeDocument.contentControls(4).range.Text
   activeDocument.Variables("Variable05").Value = activeDocument.contentControls(5).range.Text
   activeDocument.Variables("Variable06").Value = activeDocument.contentControls(6).range.Text
   activeDocument.Variables("Variable07").Value = activeDocument.contentControls(7).range.Text
   activeDocument.Variables("Variable08").Value = activeDocument.contentControls(8).range.Text
   activeDocument.Variables("Variable09").Value = activeDocument.contentControls(9).range.Text
   activeDocument.Variables("Variable10").Value = activeDocument.contentControls(10).range.Text
   activeDocument.Variables("Variable11").Value = activeDocument.contentControls(11).range.Text

MsgBox "Variable01 is now " & activeDocument.contentControls(1).range.Text & "." & vbNewLine & "Variable02 is now " & activeDocument.contentControls(2).range.Text & "." & vbNewLine & "Variable03 is now " & activeDocument.contentControls(3).range.Text & "." & vbNewLine & "Variable04 is now " & activeDocument.contentControls(4).range.Text & "." & vbNewLine & "Variable05 is now " & activeDocument.contentControls(5).range.Text & "." & vbNewLine & "Variable06 is now " & activeDocument.contentControls(6).range.Text & "." & vbNewLine & "Variable07 is now " & activeDocument.contentControls(7).range.Text & "." & vbNewLine & "Variable08 is now " & activeDocument.contentControls(8).range.Text & "." & vbNewLine & "Variable09 is now " & activeDocument.contentControls(9).range.Text & "." & vbNewLine & "Variable10 is now " & activeDocument.contentControls(10).range.Text & "." & vbNewLine & "Variable11 is now " & activeDocument.contentControls(11).range.Text & "."

End Sub

Function DocVarExists(sVarName As String, doc As word.Document) As Boolean
    Dim var As word.Variable, bExists As Boolean
    bExists = False
    For Each var In doc.Variables
        If var.Name = sVarName Then
            bExists = True
            Exit For
        End If
    Next
    DocVarExists = bExists
End Function

The Sub statement defines a variable name for each of the 11 content controls and the function just ensures that I can run the macro each time new terms are entered into the content control boxes (because if I define Variable01 to display the text from the Product Name content control [e.g., Coke] but then change that text [e.g., to Pepsi] and then run the macro again, I would get a message saying that Variable01 already exists; the function is there to overwrite the previous entry).

So then, I can remake my example using one content control box and two fields that use a DocVariable field code.

Example:

[Product Name] is a great product that everyone should use. I use {DOCVARIABLE Variable01 \* MERGEFORMAT} every day to help me take the edge off. Ask your doctor if {DOCVARIABLE Variable01 \* MERGEFORMAT} is right for you.

Then, every time you replace the text in the Product Name content control, you run the macro to update the corresponding variable and then you refresh all fields to make that text appear in the rest of the document. When you run the macro, it reports the value for each variable in the document:

message.PNG (14.2 KiB) Viewed 28110 times

Thanks again, Jubbers, for helping me out with the code here!

[Mal Shot First]

Hey, Jubbers! I've got another VBA question for you.

So, I've got this macro that is set up to use a web query to scrape data from a particular URL. It gets the URL from a cell within the spreadsheet. The column containing that URL has something like 300 rows, and each row has a URL in it. Right now, I have it set up so that it retrieves data based on the URL in cell D2, but I want it to keep going through the other rows of that column and do the same thing for every other URL. The question is: How would I set up that loop? (Loops always throw me for a loop.)

Here's the code I have:

Code: Select all

Sub WebQuery()
'
' WebQuery Macro
'

'
    Application.CutCopyMode = False
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & Range("D2").Value, Destination _
        :=Range("$G$2"))
        .Name = "Player Info"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("I13").Select
End Sub

Here is a screenshot of what the result of the query looks like:
https://dl.dropboxusercontent.com/s/xhm ... reen05.png

The data retrieved from the first URL gets dumped into cell G2 and the content spans 12 rows, so the content of the next URL would need to get dumped into cell G14, and the one after that into cell G26, etc. Is there a way to adjust the above code to accomplish all of what I'm looking for?

[Mal Shot First]

I think I got it.

Code: Select all

Sub WebQuery()
'
' WebQuery Macro
'
Dim i As Integer
For i = 2 To 400
'
    Application.CutCopyMode = False
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & Range("D" & i).Value, Destination _
        :=Range("$G$" & ((-13) + ((i - 1) * 15))))
        .Name = "Player Info"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Next i
End Sub

[Jubbers]

Man, I never log on. Sorry for not seeing this.

[Mal Shot First]

No worries! It was a hobby project, so it wasn't that important - and I ended up figuring it out fairly quickly with some trial and error.

One thing I haven't bothered looking up (but probably should) is how to end the script properly. Right now, when it reaches the end of the column of data, I get an error message, probably because it keeps looking for data and can't find any. What would I need to do to stop it from returning an error when there is no more data?

[Jubbers]

You could change the For 2 to 400 to be For 2 to However Many Rows There are.

I have to do this in a lot of macros for work. I typically have a variable I call endRow.
endRow = ThisWorkbook.Sheets("WhatEverMySheetsNameIs").Range("G10000").End(xlUp).Row

The 10000 is just some number greater than whatever you think the max number of rows will likely be.

Then For 2 to endRow