gmaxey
04-15-2014, 01:03 PM
The other day I posted looking for a way to automatically detect and correct grammar subj-verb agreement errors. The reason was that I have been tinkering with XMLMapping and using content controls to display various personal pronouns.
For anyone interested, a compact version of my efforts is provided here (Note - all of the code goes in the ThisDocument Module):
Option Explicit
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Enum GotFocusHow
TabKey = 1
ShiftTabKeys = 4
LeftMouseBtn = 3
AltKey = 2
End Enum
Public p_oCCMonitored As ContentControl
Sub AddGenderXMLPartMapPicker()
Dim oXMLPart As CustomXMLPart
Dim oCC As ContentControl
Dim arrPronouns() As String
Dim oRng As Range
Dim oNode As CustomXMLNode
On Error Resume Next
Set oXMLPart = ActiveDocument.CustomXMLParts.SelectByNamespace("http://GenderXML/Basic.com").Item(1)
If Err.Number = 0 Then
oXMLPart.Delete
End If
Set oXMLPart = ActiveDocument.CustomXMLParts.Add("<?xml version='1.0'?><GenderXML xmlns='http://GenderXML/Basic.com'>" _
& "<genderNode xmlns='' " _
& "subjPronounFirstCap='' " _
& "subjPronoun='' " _
& "objPronoun='' " _
& "possessiveDeterminerPronounFirstCap='' " _
& "possessiveDeterminerPronoun='' " _
& "possessivePronoun='' " _
& "reflexivePronoun='' " _
& "PronounSetPerson='' >" _
& "</genderNode></GenderXML>")
With ActiveDocument
Set oRng = Selection.Range
oRng.Text = String(10, vbCr)
Set oCC = .ContentControls.Add(wdContentControlCheckBox, oRng.Paragraphs(1))
With oCC
.SetCheckedSymbol CharacterNumber:=&H2642, Font:="Times New Roman"
.SetUncheckedSymbol CharacterNumber:=&H2640, Font:="Times New Roman"
.Title = "Check Gender"
.XMLMapping.SetMapping oXMLPart.DocumentElement.ChildNodes(1).XPath
If .Checked Then
arrPronouns = fcnPronouns("Third Person Masculine")
Else
arrPronouns = fcnPronouns("Third Person Feminine")
End If
End With
oRng.Paragraphs(2).Range.Text = "Relocate, delete or copy/paste the following mapped CCs as required."
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronounFirstCap")
oNode.Text = arrPronouns(0)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(3).Range)
With oCC
.Title = "Subject (He/She)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronoun")
oNode.Text = arrPronouns(1)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(4).Range)
With oCC
.Title = "subject (he/she)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@objPronoun")
oNode.Text = arrPronouns(2)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(5).Range)
With oCC
.Title = "object (him/her)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronounFirstCap")
oNode.Text = arrPronouns(3)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(6).Range)
With oCC
.Title = "Determiner (His/Her)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronoun")
oNode.Text = arrPronouns(4)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(7).Range)
With oCC
.Title = "determiner (his/her)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessivePronoun")
oNode.Text = arrPronouns(5)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(8).Range)
With oCC
.Title = "possessive (his/hers)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@reflexivePronoun")
oNode.Text = arrPronouns(6)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(9).Range)
With oCC
.Title = "reflexive (himself/herself)"
.XMLMapping.SetMapping oNode.XPath
End With
End With
oRng.InsertBefore "Click to set/toggle gender: "
lbl_Exit:
Set oXMLPart = Nothing
Exit Sub
End Sub
Private Sub Document_ContentControlOnEnter(ByVal oCC_Entered As ContentControl)
Dim bTabEntry As Boolean
If oCC_Entered.Title = "Check Gender" And oCC_Entered.Type = 8 Then
'A click entry (via mouse) in a checkbox CC triggers an automatic state change a tab entry from another CC does not.
'How was CC entered?
bTabEntry = fcn_CCTabEntry
If Not bTabEntry Then
'The user clicked the control and it changed state on enter. Pass the CC to the custom change event.
CC_OnChange oCC_Entered
End If
'Set the public CC variable to the CC entered. This is the CC targeted for monitoring.
Set p_oCCMonitored = oCC_Entered
'Call the "new" ContentControlMonitor asynchrounously. This allows this procedure to run to termination.
Application.OnTime Now + TimeSerial(0, 0, 0.01), "ContentControlMonitor"
End If
End Sub
Private Sub Document_ContentControlOnExit(ByVal oCC As ContentControl, Cancel As Boolean)
'A built-in document event. Fires when a CC is exited.
Set p_oCCMonitored = Nothing
End Sub
Public Function CC_OnChange(oCC_InEvent As ContentControl)
Select Case oCC_InEvent.Title
Case "Check Gender"
#If VBA7 Then
If oCC_InEvent.Type = 8 Then
If oCC_InEvent.Checked = True Then
SetAttributes "Third Person Masculine"
Else
SetAttributes "Third Person Feminine"
End If
End If
#End If
Case Else
'Do nothing.
End Select
Application.ScreenRefresh
lbl_Exit:
Exit Function
End Function
Public Sub ContentControlMonitor()
'Intiated via CC OnEnter events, this procedure continously monitors the CC range for a content change.
'Triggers the "new" OnChange event when a change occurs.
Dim strCC_Text As String
Dim bCC_State As Boolean
'A successful OnExit event will terminate the reference to the monitored CC and raise an error.
On Error GoTo Err_Handler
'Set the intial text or state to compare.
strCC_Text = p_oCCMonitored.Range.Text
Do While strCC_Text = p_oCCMonitored.Range.Text
DoEvents
'Detect changes.
If strCC_Text <> p_oCCMonitored.Range.Text Then
'Pass the CC_Changed
CC_OnChange p_oCCMonitored
'Set new text to compare
strCC_Text = p_oCCMonitored.Range.Text
End If
Loop
Err_ReEntry:
Exit Sub
'Handle expected error 91
Err_Handler:
'Debug.Print Err.Number & " " & Err.Description & ". An exit event has terminated the reference to the monitored CC."
Resume Err_ReEntry
End Sub
Private Function fcn_CCTabEntry() As Boolean
'Determine how content control focus was achieved, and set the appropriate flag
Dim lngRet As GotFocusHow
If GetKeyState(vbKeyTab) < 0 Then
If (GetKeyState(vbKeyShift) < 0) Then
'Shift-Tab key is pressed
lngRet = ShiftTabKeys
Else
'Tab key is pressed
lngRet = TabKey
End If
ElseIf GetKeyState(vbKeyMenu) < 0 Then
'Alt key is pressed (hotkey activation)
lngRet = AltKey
ElseIf GetKeyState(vbKeyLButton) < 0 Then
'Mouse left button is pressed
lngRet = LeftMouseBtn
End If
'Set the flag here
Select Case lngRet
Case TabKey, ShiftTabKeys
fcn_CCTabEntry = True
Case Else
fcn_CCTabEntry = False
End Select
End Function
Sub SetAttributes(strType As String)
Dim oXMLPart As CustomXMLPart
Dim oNode As CustomXMLNode
Dim arrPronouns() As String
arrPronouns = fcnPronouns(strType)
Set oXMLPart = ActiveDocument.CustomXMLParts.SelectByNamespace("http://GenderXML/Basic.com").Item(1)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronounFirstCap")
oNode.Text = arrPronouns(0)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronoun")
oNode.Text = arrPronouns(1)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@objPronoun")
oNode.Text = arrPronouns(2)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronounFirstCap")
oNode.Text = arrPronouns(3)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronoun")
oNode.Text = arrPronouns(4)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessivePronoun")
oNode.Text = arrPronouns(5)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@reflexivePronoun")
oNode.Text = arrPronouns(6)
Set oXMLPart = Nothing
Set oNode = Nothing
lbl_Exit:
Exit Sub
End Sub
Function fcnPronouns(strPerson As String) As String()
Select Case strPerson
Case "Third Person Masculine"
fcnPronouns = Split("He|he|him|His|his|his|himself", "|")
Case "Third Person Feminine"
fcnPronouns = Split("She|she|her|Her|her|hers|herself", "|")
End Select
lbl_Exit:
Exit Function
End Function
For anyone interested, a compact version of my efforts is provided here (Note - all of the code goes in the ThisDocument Module):
Option Explicit
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Enum GotFocusHow
TabKey = 1
ShiftTabKeys = 4
LeftMouseBtn = 3
AltKey = 2
End Enum
Public p_oCCMonitored As ContentControl
Sub AddGenderXMLPartMapPicker()
Dim oXMLPart As CustomXMLPart
Dim oCC As ContentControl
Dim arrPronouns() As String
Dim oRng As Range
Dim oNode As CustomXMLNode
On Error Resume Next
Set oXMLPart = ActiveDocument.CustomXMLParts.SelectByNamespace("http://GenderXML/Basic.com").Item(1)
If Err.Number = 0 Then
oXMLPart.Delete
End If
Set oXMLPart = ActiveDocument.CustomXMLParts.Add("<?xml version='1.0'?><GenderXML xmlns='http://GenderXML/Basic.com'>" _
& "<genderNode xmlns='' " _
& "subjPronounFirstCap='' " _
& "subjPronoun='' " _
& "objPronoun='' " _
& "possessiveDeterminerPronounFirstCap='' " _
& "possessiveDeterminerPronoun='' " _
& "possessivePronoun='' " _
& "reflexivePronoun='' " _
& "PronounSetPerson='' >" _
& "</genderNode></GenderXML>")
With ActiveDocument
Set oRng = Selection.Range
oRng.Text = String(10, vbCr)
Set oCC = .ContentControls.Add(wdContentControlCheckBox, oRng.Paragraphs(1))
With oCC
.SetCheckedSymbol CharacterNumber:=&H2642, Font:="Times New Roman"
.SetUncheckedSymbol CharacterNumber:=&H2640, Font:="Times New Roman"
.Title = "Check Gender"
.XMLMapping.SetMapping oXMLPart.DocumentElement.ChildNodes(1).XPath
If .Checked Then
arrPronouns = fcnPronouns("Third Person Masculine")
Else
arrPronouns = fcnPronouns("Third Person Feminine")
End If
End With
oRng.Paragraphs(2).Range.Text = "Relocate, delete or copy/paste the following mapped CCs as required."
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronounFirstCap")
oNode.Text = arrPronouns(0)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(3).Range)
With oCC
.Title = "Subject (He/She)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronoun")
oNode.Text = arrPronouns(1)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(4).Range)
With oCC
.Title = "subject (he/she)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@objPronoun")
oNode.Text = arrPronouns(2)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(5).Range)
With oCC
.Title = "object (him/her)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronounFirstCap")
oNode.Text = arrPronouns(3)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(6).Range)
With oCC
.Title = "Determiner (His/Her)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronoun")
oNode.Text = arrPronouns(4)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(7).Range)
With oCC
.Title = "determiner (his/her)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessivePronoun")
oNode.Text = arrPronouns(5)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(8).Range)
With oCC
.Title = "possessive (his/hers)"
.XMLMapping.SetMapping oNode.XPath
End With
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@reflexivePronoun")
oNode.Text = arrPronouns(6)
Set oCC = .ContentControls.Add(wdContentControlText, oRng.Paragraphs(9).Range)
With oCC
.Title = "reflexive (himself/herself)"
.XMLMapping.SetMapping oNode.XPath
End With
End With
oRng.InsertBefore "Click to set/toggle gender: "
lbl_Exit:
Set oXMLPart = Nothing
Exit Sub
End Sub
Private Sub Document_ContentControlOnEnter(ByVal oCC_Entered As ContentControl)
Dim bTabEntry As Boolean
If oCC_Entered.Title = "Check Gender" And oCC_Entered.Type = 8 Then
'A click entry (via mouse) in a checkbox CC triggers an automatic state change a tab entry from another CC does not.
'How was CC entered?
bTabEntry = fcn_CCTabEntry
If Not bTabEntry Then
'The user clicked the control and it changed state on enter. Pass the CC to the custom change event.
CC_OnChange oCC_Entered
End If
'Set the public CC variable to the CC entered. This is the CC targeted for monitoring.
Set p_oCCMonitored = oCC_Entered
'Call the "new" ContentControlMonitor asynchrounously. This allows this procedure to run to termination.
Application.OnTime Now + TimeSerial(0, 0, 0.01), "ContentControlMonitor"
End If
End Sub
Private Sub Document_ContentControlOnExit(ByVal oCC As ContentControl, Cancel As Boolean)
'A built-in document event. Fires when a CC is exited.
Set p_oCCMonitored = Nothing
End Sub
Public Function CC_OnChange(oCC_InEvent As ContentControl)
Select Case oCC_InEvent.Title
Case "Check Gender"
#If VBA7 Then
If oCC_InEvent.Type = 8 Then
If oCC_InEvent.Checked = True Then
SetAttributes "Third Person Masculine"
Else
SetAttributes "Third Person Feminine"
End If
End If
#End If
Case Else
'Do nothing.
End Select
Application.ScreenRefresh
lbl_Exit:
Exit Function
End Function
Public Sub ContentControlMonitor()
'Intiated via CC OnEnter events, this procedure continously monitors the CC range for a content change.
'Triggers the "new" OnChange event when a change occurs.
Dim strCC_Text As String
Dim bCC_State As Boolean
'A successful OnExit event will terminate the reference to the monitored CC and raise an error.
On Error GoTo Err_Handler
'Set the intial text or state to compare.
strCC_Text = p_oCCMonitored.Range.Text
Do While strCC_Text = p_oCCMonitored.Range.Text
DoEvents
'Detect changes.
If strCC_Text <> p_oCCMonitored.Range.Text Then
'Pass the CC_Changed
CC_OnChange p_oCCMonitored
'Set new text to compare
strCC_Text = p_oCCMonitored.Range.Text
End If
Loop
Err_ReEntry:
Exit Sub
'Handle expected error 91
Err_Handler:
'Debug.Print Err.Number & " " & Err.Description & ". An exit event has terminated the reference to the monitored CC."
Resume Err_ReEntry
End Sub
Private Function fcn_CCTabEntry() As Boolean
'Determine how content control focus was achieved, and set the appropriate flag
Dim lngRet As GotFocusHow
If GetKeyState(vbKeyTab) < 0 Then
If (GetKeyState(vbKeyShift) < 0) Then
'Shift-Tab key is pressed
lngRet = ShiftTabKeys
Else
'Tab key is pressed
lngRet = TabKey
End If
ElseIf GetKeyState(vbKeyMenu) < 0 Then
'Alt key is pressed (hotkey activation)
lngRet = AltKey
ElseIf GetKeyState(vbKeyLButton) < 0 Then
'Mouse left button is pressed
lngRet = LeftMouseBtn
End If
'Set the flag here
Select Case lngRet
Case TabKey, ShiftTabKeys
fcn_CCTabEntry = True
Case Else
fcn_CCTabEntry = False
End Select
End Function
Sub SetAttributes(strType As String)
Dim oXMLPart As CustomXMLPart
Dim oNode As CustomXMLNode
Dim arrPronouns() As String
arrPronouns = fcnPronouns(strType)
Set oXMLPart = ActiveDocument.CustomXMLParts.SelectByNamespace("http://GenderXML/Basic.com").Item(1)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronounFirstCap")
oNode.Text = arrPronouns(0)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@subjPronoun")
oNode.Text = arrPronouns(1)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@objPronoun")
oNode.Text = arrPronouns(2)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronounFirstCap")
oNode.Text = arrPronouns(3)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessiveDeterminerPronoun")
oNode.Text = arrPronouns(4)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@possessivePronoun")
oNode.Text = arrPronouns(5)
Set oNode = oXMLPart.SelectSingleNode("/ns0:GenderXML[1]/genderNode[1]/@reflexivePronoun")
oNode.Text = arrPronouns(6)
Set oXMLPart = Nothing
Set oNode = Nothing
lbl_Exit:
Exit Sub
End Sub
Function fcnPronouns(strPerson As String) As String()
Select Case strPerson
Case "Third Person Masculine"
fcnPronouns = Split("He|he|him|His|his|his|himself", "|")
Case "Third Person Feminine"
fcnPronouns = Split("She|she|her|Her|her|hers|herself", "|")
End Select
lbl_Exit:
Exit Function
End Function