Hi all,
I am trying to write a macro that allows me to use VBA to draw a line immediately following text. It is to delineate sections of a document that will automatically be outputted based on responses given by the end user. I am not terribly familiar with VBA and am entirely self taught, so I know my programming is quite poor.
Basically, I would like the line to draw after the next paragraph, and as you can see by the coordinates, it runs the whole width of the page. Assuming:
'add line
Shapes.AddLine 0, 2, 700, 2
I know this macro is a mess, but I am inculding the rest of the macro, just in case someone wants to replicate the whole macro in order to test. As you can tell, I have it running off of a check box for now, though that I have a box that that indicates the number it times that the Macro runs as well as a bookmark that is "end" in order to find its location. I have certainly copied and pasted several things into this in order to get it to do this much but am stumped for now. Thanks in advance. Whole macro following:
Private Sub CheckBox1_Click()
Dim sNum As Long
Dim oRng As Range
Dim bProtected As Boolean
Dim fCount As Long
Dim i As Long
Dim j As Long
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
bProtected = True
ActiveDocument.Unprotect Password:=""
End If
sNum = ActiveDocument.FormFields("numberofproblems").Result
Selection.GoTo what:=wdGoToBookmark, Name:="end"
'Define the range object. This is where the cursor is at (start point)
Set oRng = Selection.Range
For i = 1 To sNum
With Selection
'Insert one blank lines
'Set the underline option
.Font.Underline = wdUnderlineSingle
'Set the bold option
.Font.Bold = False
'Ensure that the paragraphs stay together on the same page
.ParagraphFormat.KeepWithNext = True
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Problem #: "
'Add a dropdown list
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "1"
objcc.DropdownListEntries.Add "2"
objcc.DropdownListEntries.Add "3"
objcc.DropdownListEntries.Add "4"
objcc.DropdownListEntries.Add "5"
objcc.DropdownListEntries.Add "6"
objcc.DropdownListEntries.Add "7"
objcc.DropdownListEntries.Add "8"
objcc.DropdownListEntries.Add "9"
objcc.DropdownListEntries.Add "10"
objcc.DropdownListEntries.Add "11"
objcc.DropdownListEntries.Add "12"
objcc.DropdownListEntries.Add "13"
objcc.DropdownListEntries.Add "14"
objcc.DropdownListEntries.Add "15"
objcc.DropdownListEntries.Add "16"
objcc.DropdownListEntries.Add "17"
objcc.DropdownListEntries.Add "18"
objcc.DropdownListEntries.Add "19"
objcc.DropdownListEntries.Add "20"
Selection.MoveRight Unit:=wdCharacter, Count:=2
' Text for problem
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Date: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'date dropdown box
Selection.Range.ContentControls.Add (wdContentControlDate)
Selection.MoveRight Unit:=wdCharacter, Count:=2
' Text for Fars/Cars domain
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "FARS/CFARS Domain: "
'Turn off the underline
'.Font.Underline = wdUnderlineNone
'Turn off the bold option
'.Font.Bold = False
'.TypeParagraph
'.TypeParagraph
' Domain Dropdown
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "Depression"
objcc.DropdownListEntries.Add "Anxiety"
objcc.DropdownListEntries.Add "Hyper Affect"
objcc.DropdownListEntries.Add "Thought Process"
objcc.DropdownListEntries.Add "Cognitive Performance"
objcc.DropdownListEntries.Add "Medical/Physical"
objcc.DropdownListEntries.Add "Traumatic Stress"
objcc.DropdownListEntries.Add "Substance Use"
objcc.DropdownListEntries.Add "Interpersonal Relationships"
objcc.DropdownListEntries.Add "Family Relationships"
objcc.DropdownListEntries.Add "Family Environment"
objcc.DropdownListEntries.Add "Socio-Legal"
objcc.DropdownListEntries.Add "Select: Work/School"
objcc.DropdownListEntries.Add "ADL Functioning"
objcc.DropdownListEntries.Add "Ability to Care for Self"
objcc.DropdownListEntries.Add "Danger to Self"
objcc.DropdownListEntries.Add "Danger to Others"
objcc.DropdownListEntries.Add "Security/Mangement Needs"
Selection.MoveRight Unit:=wdCharacter, Count:=2
'FARS/CFARS Score text
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Bold = False
.Font.Color = wdColorDarkBlue
.TypeText "FARS/CFARS Score: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'dropdown box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "1 No Problem"
objcc.DropdownListEntries.Add "2 Less than Slight"
objcc.DropdownListEntries.Add "3 Slight Problem"
objcc.DropdownListEntries.Add "4 Slight to Moderate"
objcc.DropdownListEntries.Add "5 Moderate Problem"
objcc.DropdownListEntries.Add "6 Moderate to Severe"
objcc.DropdownListEntries.Add "7 Severe Problem"
objcc.DropdownListEntries.Add "8 Severe to Extreme"
objcc.DropdownListEntries.Add "9 Extreme Problem"
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Target FARS/CFARS Score
Selection.TypeText Text:=vbTab
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Target FARS/CFARS Score: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'dropdown list
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "1 No Problem"
objcc.DropdownListEntries.Add "2 Less than Slight"
objcc.DropdownListEntries.Add "3 Slight Problem"
objcc.DropdownListEntries.Add "4 Slight to Moderate"
objcc.DropdownListEntries.Add "5 Moderate Problem"
objcc.DropdownListEntries.Add "6 Moderate to Severe"
objcc.DropdownListEntries.Add "7 Severe Problem"
objcc.DropdownListEntries.Add "8 Severe to Extreme"
objcc.DropdownListEntries.Add "9 Extreme Problem"
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Specific
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Specific Problems and Symptoms (include FARS/CFARS adjectives and other concerns the client has identified): "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'add content control text box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlText)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Goals and objectives
.TypeParagraph
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Short Term Service Goals/Objectives: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'add content control text box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlText)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Add Date
.Font.Color = wdColorDarkBlue
.TypeText ". These goals/objectives will be completed or reviewed by: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'date dropdown box
Selection.Range.ContentControls.Add (wdContentControlDate)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Goals and objectives
.TypeParagraph
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Clinical Interventions Used to Meet Objectives: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'add content control text box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlText)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'add line
Shapes.AddLine 0, 2, 700, 2
End With
Next
End Sub
I am trying to write a macro that allows me to use VBA to draw a line immediately following text. It is to delineate sections of a document that will automatically be outputted based on responses given by the end user. I am not terribly familiar with VBA and am entirely self taught, so I know my programming is quite poor.
Basically, I would like the line to draw after the next paragraph, and as you can see by the coordinates, it runs the whole width of the page. Assuming:
'add line
Shapes.AddLine 0, 2, 700, 2
I know this macro is a mess, but I am inculding the rest of the macro, just in case someone wants to replicate the whole macro in order to test. As you can tell, I have it running off of a check box for now, though that I have a box that that indicates the number it times that the Macro runs as well as a bookmark that is "end" in order to find its location. I have certainly copied and pasted several things into this in order to get it to do this much but am stumped for now. Thanks in advance. Whole macro following:
Private Sub CheckBox1_Click()
Dim sNum As Long
Dim oRng As Range
Dim bProtected As Boolean
Dim fCount As Long
Dim i As Long
Dim j As Long
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
bProtected = True
ActiveDocument.Unprotect Password:=""
End If
sNum = ActiveDocument.FormFields("numberofproblems").Result
Selection.GoTo what:=wdGoToBookmark, Name:="end"
'Define the range object. This is where the cursor is at (start point)
Set oRng = Selection.Range
For i = 1 To sNum
With Selection
'Insert one blank lines
'Set the underline option
.Font.Underline = wdUnderlineSingle
'Set the bold option
.Font.Bold = False
'Ensure that the paragraphs stay together on the same page
.ParagraphFormat.KeepWithNext = True
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Problem #: "
'Add a dropdown list
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "1"
objcc.DropdownListEntries.Add "2"
objcc.DropdownListEntries.Add "3"
objcc.DropdownListEntries.Add "4"
objcc.DropdownListEntries.Add "5"
objcc.DropdownListEntries.Add "6"
objcc.DropdownListEntries.Add "7"
objcc.DropdownListEntries.Add "8"
objcc.DropdownListEntries.Add "9"
objcc.DropdownListEntries.Add "10"
objcc.DropdownListEntries.Add "11"
objcc.DropdownListEntries.Add "12"
objcc.DropdownListEntries.Add "13"
objcc.DropdownListEntries.Add "14"
objcc.DropdownListEntries.Add "15"
objcc.DropdownListEntries.Add "16"
objcc.DropdownListEntries.Add "17"
objcc.DropdownListEntries.Add "18"
objcc.DropdownListEntries.Add "19"
objcc.DropdownListEntries.Add "20"
Selection.MoveRight Unit:=wdCharacter, Count:=2
' Text for problem
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Date: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'date dropdown box
Selection.Range.ContentControls.Add (wdContentControlDate)
Selection.MoveRight Unit:=wdCharacter, Count:=2
' Text for Fars/Cars domain
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "FARS/CFARS Domain: "
'Turn off the underline
'.Font.Underline = wdUnderlineNone
'Turn off the bold option
'.Font.Bold = False
'.TypeParagraph
'.TypeParagraph
' Domain Dropdown
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "Depression"
objcc.DropdownListEntries.Add "Anxiety"
objcc.DropdownListEntries.Add "Hyper Affect"
objcc.DropdownListEntries.Add "Thought Process"
objcc.DropdownListEntries.Add "Cognitive Performance"
objcc.DropdownListEntries.Add "Medical/Physical"
objcc.DropdownListEntries.Add "Traumatic Stress"
objcc.DropdownListEntries.Add "Substance Use"
objcc.DropdownListEntries.Add "Interpersonal Relationships"
objcc.DropdownListEntries.Add "Family Relationships"
objcc.DropdownListEntries.Add "Family Environment"
objcc.DropdownListEntries.Add "Socio-Legal"
objcc.DropdownListEntries.Add "Select: Work/School"
objcc.DropdownListEntries.Add "ADL Functioning"
objcc.DropdownListEntries.Add "Ability to Care for Self"
objcc.DropdownListEntries.Add "Danger to Self"
objcc.DropdownListEntries.Add "Danger to Others"
objcc.DropdownListEntries.Add "Security/Mangement Needs"
Selection.MoveRight Unit:=wdCharacter, Count:=2
'FARS/CFARS Score text
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Bold = False
.Font.Color = wdColorDarkBlue
.TypeText "FARS/CFARS Score: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'dropdown box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "1 No Problem"
objcc.DropdownListEntries.Add "2 Less than Slight"
objcc.DropdownListEntries.Add "3 Slight Problem"
objcc.DropdownListEntries.Add "4 Slight to Moderate"
objcc.DropdownListEntries.Add "5 Moderate Problem"
objcc.DropdownListEntries.Add "6 Moderate to Severe"
objcc.DropdownListEntries.Add "7 Severe Problem"
objcc.DropdownListEntries.Add "8 Severe to Extreme"
objcc.DropdownListEntries.Add "9 Extreme Problem"
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Target FARS/CFARS Score
Selection.TypeText Text:=vbTab
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Target FARS/CFARS Score: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'dropdown list
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlDropdownList)
objcc.DropdownListEntries.Add "1 No Problem"
objcc.DropdownListEntries.Add "2 Less than Slight"
objcc.DropdownListEntries.Add "3 Slight Problem"
objcc.DropdownListEntries.Add "4 Slight to Moderate"
objcc.DropdownListEntries.Add "5 Moderate Problem"
objcc.DropdownListEntries.Add "6 Moderate to Severe"
objcc.DropdownListEntries.Add "7 Severe Problem"
objcc.DropdownListEntries.Add "8 Severe to Extreme"
objcc.DropdownListEntries.Add "9 Extreme Problem"
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Specific
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Specific Problems and Symptoms (include FARS/CFARS adjectives and other concerns the client has identified): "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'add content control text box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlText)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Goals and objectives
.TypeParagraph
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Short Term Service Goals/Objectives: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'add content control text box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlText)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Add Date
.Font.Color = wdColorDarkBlue
.TypeText ". These goals/objectives will be completed or reviewed by: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'date dropdown box
Selection.Range.ContentControls.Add (wdContentControlDate)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'Goals and objectives
.TypeParagraph
.TypeParagraph
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorDarkBlue
.TypeText "Clinical Interventions Used to Meet Objectives: "
.Font.Underline = wdUnderlineNone
.Font.Color = wdColorBlack
'add content control text box
Set objcc = ActiveDocument.ContentControls.Add(wdContentControlText)
Selection.MoveRight Unit:=wdCharacter, Count:=2
'add line
Shapes.AddLine 0, 2, 700, 2
End With
Next
End Sub