Add header and footer macro - vb.net

I need to make a difficult makro.
When the makro has been activated (will happen via a button), it has to add a header and a footer to the document.
Also page1/frontpage needs a different header and footer than all the other potential pages.
So far, I have accomplished making page1/frontpage to work - somewhat.
I did this by recording a makro, where I'd enable headers and footers, write the needed data and then stop recording. Afterwards I edited the coding so it would fit a little better. Mostly it was junk-code cleanup.
It doesn't work though, if I use several pages.
How can I accomplish this setup?
I can provide you my current code, if anyone is interested:
Sub PDFtest2()
'
' PDFtest2 Macro
'
'
Dim FileName As String
Dim minPDFSti As String
Dim aryFolders
Dim i As Long
Dim version As String
Dim sFolder As String
'Skaf dokument titel
FileName = ActiveDocument.Name 'e.g document1.doc
aryFolders = Split(FileName, ".") 'split ved .doc da vi skal bruge pdf extension
FileName = aryFolders(LBound(aryFolders)) 'document1
'Lav en document-1 hvis document allerede eksistere. Putter også .pdf på som extension
If Dir(minPDFSti + FileName + ".pdf") <> "" Then
aryFolders = Split(FileName, "-")
version = aryFolders(UBound(aryFolders))
If version <> "" Then
FileName = FileName + "-" + version + "-1.pdf"
Else
FileName = FileName + "-1.pdf"
End If
Else
FileName = FileName + ".pdf"
End If
'Vores PDF sti
minPDFSti = "c:\PDF\"
If Dir(minPDFSti, vbDirectory) = "" Then
'If MsgBox("PDF Mappen eksistere ikke, lav en?", _
'vbYesNo, "PDF Mappe") = vbYes Then
aryFolders = Split(minPDFSti, "\")
sFolder = aryFolders(LBound(aryFolders))
For i = LBound(aryFolders) + 1 To UBound(aryFolders)
sFolder = sFolder & "\" & aryFolders(i)
If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder
Next i
'End If
End If
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeText Text:="Advokatfirmaet"
Selection.TypeParagraph
Selection.TypeText Text:="Beck & Partnere"
Selection.MoveLeft Unit:=wdCharacter, Count:=15, Extend:=wdExtend
Selection.Font.Size = 12
Selection.Font.Size = 13
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=16, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=15, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeText Text:="Advokataktieselskab"
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(4.5), _
Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.TypeText Text:=vbTab & "Damhaven 5"
Selection.ParagraphFormat.TabStops(CentimetersToPoints(7.96)).Position = _
CentimetersToPoints(7.96)
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(8.25) _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.ParagraphFormat.TabStops(CentimetersToPoints(7.96)).Position = _
CentimetersToPoints(8.25)
Selection.TypeText Text:=vbTab & "Giro 193 5100"
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(12.25 _
), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.TypeText Text:=vbTab & "Tel." & vbTab & "+45 75 72 41 00"
Selection.TypeParagraph
Selection.TypeText Text:="CVR 25 79 71 24" & vbTab & "DK-7100 Vejle" & _
vbTab
Selection.ParagraphFormat.TabStops(CentimetersToPoints(8.25)).Position = _
CentimetersToPoints(9)
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(8.25) _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.TypeText Text:="www.becklaw.dk" & vbTab & "Fax" & vbTab & _
"+45 75 72 41 00"
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=26
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(8.25) _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.ParagraphFormat.TabStops(CentimetersToPoints(8.25)).Position = _
CentimetersToPoints(9)
Selection.ParagraphFormat.TabStops(CentimetersToPoints(9)).Position = _
CentimetersToPoints(8.25)
ChangeFileOpenDirectory minPDFSti 'Sikre dig at stien eksistere
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
minPDFSti + FileName, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
Selection.WholeStory
Selection.TypeBackspace
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.WholeStory
Selection.TypeBackspace
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
The code also saves the dokument as a PDF. But that doesn't matter.
EDIT: Actually this accomplishes an odd result!
Let us say that I have a page1, 2 & 3 filled with text.
I press the button that activates the macro.
Page 1 recieves no header nor footer, but page 2 & 3 recieves the header and footer coded above.

Try this:
Sub HeaderFooterObject()
Dim MyText As String
MyHeaderText = "Header text"
MyFooterText = "Footer text"
MyHeaderTextFirstPage = "First Page"
MyFooterTextFirstPage = "Footer text First Page"
With ActiveDocument.Sections(1)
.PageSetup.DifferentFirstPageHeaderFooter = True
.Headers(wdHeaderFooterPrimary).Range.Text = MyHeaderText
.Footers(wdHeaderFooterPrimary).Range.Text = MyFooterText
.Headers(wdHeaderFooterFirstPage).Range.Text = MyHeaderTextFirstPage
.Footers(wdHeaderFooterFirstPage).Range.Text = MyFooterTextFirstPage
End With
End Sub
This came from here and here.

Related

How do I extract the line my selection.find found? It will only return to me the first character

In the following code I am trying to insert a picuture into my word document based on the text I found while searchiung. The problem is it will only return to me the firsat character od the text. How do I get all of the text? How do I get the actual line it was found in? The text I am looking for is directly after the text found. IE: "Insert screen shot here of Boxshot" So I am trying to load a file called Boxshot. NOT working. Help.
Sub NewPic()
'
' NewPic Macro
'
Dim screenshot, Dirname, selfound As String
Dim Dn As Long
'
With Selection.Find
.Text = "Insert screen shot here of "
'.Replacement.Text = ""
.Forward = True
End With
Selection.Find.Execute
'
'Insert picture and find next match
'
While Selection.Find.Found
Selection.TypeParagraph
Selection.TypeParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Select
selfound = Selection.Characters.First
MsgBox ("Text=" & selfound)
'
'Is picture there?
'
Dirname = ActiveDocument.Name
Dn = InStr(Dirname, "User")
Dirname = Left(Dirname, Dn)
screenshot = "C:\Users\User 1\Desktop\VB Upload files\CD's\" & Dirname & "\" &
Selection.Text & ".jpg"
MsgBox ("Screenshot= " & screenshot & ", Sellectedtext=" & Selection.Text)
'
If Dir(screenshot) <> "" Then
Else
screenshot = "C:\Users\User 1\Desktop\Mylogo.jpg"
End If
'
Selection.InlineShapes.AddPicture FileName:= _
screenshot, LinkToFile:=False, SaveWithDocument _
:=True
'"C:\Users\User 1\Desktop\Mylogo.jpg", LinkToFile:=False, SaveWithDocument _
':=True
Selection.TypeParagraph
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1
Selection.TypeParagraph
Selection.Find.Execute
Wend
'
End Sub
Your use of Selection makes your code unnecessarily complex and slow. The following macro will insert the relevant pictures wherever "Insert screen shot here of " is followed by the pic name (no error-checking for valid names & files). If you don't want to retain the pic names below the pics, simply un-comment the commented-out line.
Sub NewPics()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Insert screen shot here of "
.Replacement.Text = ""
.Forward = True
.Format = False
.Wrap = wdFindContinue
End With
Do While .Find.Execute
.Text = vbCr
.Collapse wdCollapseEnd
.End = .Paragraphs.Last.Range.End - 1
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.InlineShapes.AddPicture FileName:=ActiveDocument.Path & "\" & .Text & ".jpg", LinkToFile:=False, SaveWithDocument:=True
'.Start = .Start + 1: .Delete
Loop
End With
Application.ScreenUpdating = True
End Sub

Macro (VBA) crashing Microsoft word (Find and replace)

I using a VBA code to batch find and replace highlighted text. The macro finds and replaces the words in the document. It works well with a few number of highlighted text on a small document (1-2 pages). However, when I use this macro on a large documents which has over a 100 pages, Microsoft word crashed and becomes unresponsive so I have to forced to quit.
The code is to help make it easy to redact information. I am replacing the highlight text which occur also in tables with XXXXX and highlighted black.
Does anyone have any tips to make the code more efficient?
Here is the code
Sub FindandReplaceHighlight()
Dim strFindColor As String
Dim strReplaceColor As String
Dim strText As String
Dim objDoc As Document
Dim objRange As Range
Application.ScreenUpdating = False
Set objDoc = ActiveDocument
strFindColor = InputBox("Specify a color (enter the value):", "Specify Highlight Color")
strReplaceColor = InputBox("Specify a new color (enter the value):", "New Highlight Color")
strText = InputBox("Specify a new text (enter the value):", "New Text")
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Highlight = True
Do While .Execute
If Selection.Range.HighlightColorIndex = strFindColor Then
Set objRange = Selection.Range
objRange.HighlightColorIndex = strReplaceColor
objRange.Text = strText
objRange.Font.ColorIndex = wdBlack
Selection.Collapse wdCollapseEnd
End If
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
Try:
Sub FindandReplaceHighlight()
Application.ScreenUpdating = False
Dim ClrFnd As Long, ClrRep As Long, strTxt As String
Const StrColors As String = vbCr & _
" 1 Black" & vbCr & _
" 2 Blue" & vbCr & _
" 3 Turquoise" & vbCr & _
" 4 Bright Green" & vbCr & _
" 5 Pink" & vbCr & _
" 6 Red" & vbCr & _
" 7 Yellow" & vbCr & _
" 8 White" & vbCr & _
" 9 Dark Blue" & vbCr & _
"10 Teal" & vbCr & _
"11 Green" & vbCr & _
"12 Violet" & vbCr & _
"13 Dark Red" & vbCr & _
"14 Dark Yellow" & vbCr & _
"15 Gray 50" & vbCr & _
"16 Gray 25%"
ClrFnd = InputBox("Specify the old color (enter the value):" & StrColors, "Specify Highlight Color")
ClrRep = InputBox("Specify the new color (enter the value):" & StrColors, "New Highlight Color")
strTxt = InputBox("Specify the new text (enter the value):", "New Text")
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .HighlightColorIndex = ClrFnd Then
.HighlightColorIndex = ClrRep
.Text = strTxt
.Font.ColorIndex = wdBlack
.Collapse wdCollapseEnd
End If
Loop
End With
End With
Application.ScreenUpdating = True
End Sub

Remove illegal characters while saving workbook Excel VBA

this code basically reformats an xls file and saves it as an xlsx. however it uses G2 & H2 to grab the filename for the newly formatted file.
So that means certain characters can't be in the file name. I added a chunk of code to replace those characters (
' Remove/Replace Invalid File Name Characters
WkbName = Range("H2")
MyArray = Array("<", ">", "|", "/", "*", "\", ".", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
WkbName = Replace(WkbName, MyArray(X), "_", 1)
Next X
'MsgBox WkbName 'dispaly file name with illegal characters removed
ActiveWorkbook.SaveAs Filename:= _
WBPath & "\BOM_" & Range("G2") & "_" & WkbName & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
)
activeworkbook.saves as is where the debugger always takes me
I'm getting an error message saying there's always an illegal character even if its just normal text in h2, am I missing something?
full code below
Sub FormatBOMExport()
'
' FormatBOMExportPnV Macro
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' delete extra sheets
Sheets(Array("Sheet2", "Sheet3")).Select
ActiveWindow.SelectedSheets.Delete
WBPath = Application.ActiveWorkbook.Path
OrgFile = Application.ActiveWorkbook.FullName
Range("B1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:M").Select
Selection.Replace What:="" & Chr(10) & "", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Columns.AutoFit
Selection.Rows.AutoFit
Columns("J:J").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' Columns("J:J").Select
' Columns("J:J").ColumnWidth = 100
' Selection.Rows.AutoFit
Columns("G:G").EntireColumn.AutoFit
Range("G2").Select
' Remove/Replace Invalid File Name Characters
WkbName = Range("H2")
MyArray = Array("<", ">", "|", "/", "*", "\", ".", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
WkbName = Replace(WkbName, MyArray(X), "_", 1)
Next X
'MsgBox WkbName 'dispaly file name with illegal characters removed
ActiveWorkbook.SaveAs Filename:= _
WBPath & "\BOM_" & Range("G2") & "_" & WkbName & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If Len(Dir$(OrgFile)) > 0 Then
Kill OrgFile
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' MsgBox OrgFile & " has been deleted and saved as " & "BOM_" & Range("G2") & "_" & Range("H2") & ".xlsx"
End Sub
`
please excuse my notes and random crap in the code. I always clean it up before I give it to others
Because there could be more illegal characters in the filename. Your approach is right but it's not comprehensive list of illegal characters to remove or replace from the filename before saving it. For eg. these characters are missing from the array in your code -> : & . However it is advised to keep filename rid of other allowed special characters too.
Below, I am providing the function which returns a safe string that can be used to produce filename before saving.
Function ReplaceIllegalCharacters(strIn As String, strChar As String) As String
Dim strSpecialChars As String
Dim i As Long
strSpecialChars = "~""#%&*:<>?{|}/\[]" & Chr(10) & Chr(13)
For i = 1 To Len(strSpecialChars)
strIn = Replace(strIn , Mid$(strSpecialChars, i, 1), strChar)
Next
ReplaceIllegalCharacters = strIn
End Function
Specifically, in your code, replace the ActiveWorkbook.SaveAs line with this line:
ActiveWorkbook.SaveAs Filename:= _
WBPath & "\BOM_" & Range("G2").Value2 & "_" & ReplaceIllegalCharacters(Range("H2").Value2, "_") & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Hyperlinked text in Word footers to a selected bookmark

I wanted a custom footer in all my documents with a hyperlinked text to a bookmark in same document. i.e. 'Top Of Document' kind of link in all the footers. I had to collect information for all over the places to achieve this much. and wanted to share here so others do not have to fight for this thing all at once.
So far from all the question & suggestions from stackoverflow and other sites, I have achieved this much-
Created a macro to create a bookmark automatically, of a selected text in document.
Bookmark will be re-created (delete and create) if its already present
Macro will add a new footer with page number and a text with delimiter (i.e. / Hit Overview).
Now I want to create this text in footer a HyperLink to the bookmark. code is simple. but i guess i am doing something wrong, tried by creating a HyperLink object. but not working. please suggest something.
Here is the macro function-
Sub InsertFootnote()
Const wdAlignPageNumberCenter = 1
Dim varNumberPages As Variant
varNumberPages = ActiveDocument.Content.Information(wdActiveEndAdjustedPageNumber)
' Delete bookmark if any with this name
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
ActiveDocument.Bookmarks("HitOverviewMac").Delete
End If
' Create a Bookmark to the selected text
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="HitOverviewMac"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
Dim mHlink As Hyperlink
Dim i As Long
For i = 1 To ActiveDocument.Sections.Count
With ActiveDocument.Sections(i)
' Remove footer
'.Footers(wdHeaderFooterPrimary).Range.Text = ""
'.Footers(wdHeaderFooterPrimary).PageNumbers.Add (wdAlignPageNumberCenter)
'.Footers(wdHeaderFooterPrimary).Range.InsertBefore "Hit Overview / Page "
.Footers(wdHeaderFooterPrimary).Range.Select
With Selection
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
.Paragraphs(1).Alignment = wdAlignParagraphCenter
.TypeText Text:="Page "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"PAGE ", PreserveFormatting:=True
.TypeText Text:=" of "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"NUMPAGES ", PreserveFormatting:=True
.EndKey Unit:=wdLine
.TypeText Text:=" ~ "
ActiveDocument.Hyperlinks.Add Anchor:=.Range, Address:="", _
SubAddress:="HitOverview", ScreenTip:="", TextToDisplay:="Hit Overview"
Else
MsgBox "Bookmark does not exists"
End If
End With
End With
Next
End Sub
Ok, Its wasn't the problem with Macro(except below), its the problem with couple of Documents I was testing with.
few mistakes that I missed - SubAddress:="BOOKMARK_NAME" AND Anchor:=Selection.Range.
So the problem occurs if any Doc already has some text in footers. and so that now I am removing footer first.
Here is the Code for everyone's reference-
Sub InsertFootnote()
Const wdAlignPageNumberCenter = 1
Dim varNumberPages As Variant
varNumberPages = ActiveDocument.Content.Information(wdActiveEndAdjustedPageNumber)
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
ActiveDocument.Bookmarks("HitOverviewMac").Delete
End If
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="HitOverviewMac"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
Dim mHlink As Hyperlink
Dim i As Long
For i = 1 To ActiveDocument.Sections.Count
With ActiveDocument.Sections(i)
.Footers(wdHeaderFooterPrimary).Range.Text = ""
.Footers(wdHeaderFooterPrimary).PageNumbers.Add (wdAlignPageNumberCenter)
.Footers(wdHeaderFooterPrimary).Range.Select
With Selection
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
.Paragraphs.Alignment = wdAlignParagraphCenter
.TypeText Text:="Page "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"PAGE ", PreserveFormatting:=True
.TypeText Text:=" of "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"NUMPAGES ", PreserveFormatting:=True
.EndKey Unit:=wdLine
.TypeText Text:=" / "
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
SubAddress:="HitOverviewMac", ScreenTip:="", TextToDisplay:="Hit Overview"
Else
MsgBox "Bookmark does not exists"
End If
End With
End With
Next
End Sub

Is there an "elegant" way to enact Auto-Numbering in a Word 2007 Macro (VBA)?

Ok, so basically we have a couple of unique sections in a macro-enabled template for Word 2007 and for each section, we have 2 entries that are standard for the form, and then there are about 20 optional entries that are all handled by AutoText. The formatting is identical between the template and the AutoText entries and I'm wanting to auto-number the entries as they are added (either by the user typing the AutoText keyphrase or hitting a button on the ribbon to insert it).
Is there an easy way to do this?
Here is the block of code where one of these (numbered) entries is handled and what I've tried to implement as a numbering scheme from other suggestions on other forums (couldn't find anything useful here):
Case "cboFF"
SetMargins 0, 1, 1
Selection.ParagraphFormat.Space1
Selection.Text = "FINDINGS OF FACT" & vbLf
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.Bold = True
Selection.Font.Underline = wdUnderlineSingle
Selection.Collapse (wdCollapseEnd)
Selection.Text = vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
Selection.Font.Underline = wdUnderlineNone
Selection.Font.Bold = False
SetMargins 0, 1, 1
'With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
'.NumberFormat = "%1."
'.TrailingCharacter = wdTrailingTab
'.NumberStyle = wdListNumberStyleNone
'.NumberPosition = InchesToPoints(0.5)
'.Alignment = wdListLevelAlignLeft
'.TextPosition = InchesToPoints(0.5)
'.ResetOnHigher = 0
'.StartAt = 1
'AutoNumberOnFOF
Selection.Text = "On " & strDateFOF & ", an industrial appeals judge certified that the parties agreed to include the Jurisdictional History in the Board record solely for jurisdictional purposes." & vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
Select Case strCaseCategory
Case "IND", "IND SELF-I"
If frmIIOD.optII.Value = True Then
Selection.Text = "II-FF"
Selection.Range.InsertAutoText
Selection.Collapse (wdCollapseEnd)
Selection.Text = vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
GoToEnd
End If
If frmIIOD.optOD.Value = True Then
Selection.Text = "OD-FF"
Selection.Range.InsertAutoText
Selection.Collapse (wdCollapseEnd)
Selection.Text = vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
GoToEnd
End If
If frmIIOD.optNotNeeded.Value = True Then
Selection.Text = vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
End If
Case Else
'Do Nothing
End Select
Any constructive comments will be much appreciated to help solve this issue. I'm still very new to programming as a whole and most of my experience lies in C# and Java.
Edit: The structure of the document is essentially a set of itemized lists containing legal text that is updated by a user as the appeal process goes through various stages. In each of the last 2 sections the itemized lists need to follow a specific numbering scheme (num at .5", text at 1", right tab at 1") which is not native to Word 2007. There is a bolded heading for each of the sections that is the starting point of the numbering. The AutoText entries will be added as needed by the user. The rest of the document pulls information from our database and contains the legal wording necessary for the document.
If I could just figure out how to initiate the numbering for each section individually, then I could finish this up.
I've actually figured out my own solution to the issue. The problem was trying to insert an AutoText entry on the (2nd) line of numbering since it reads the whole line and thinks it is an AutoText entry. Rather than only reading ii-ff or od-ff, it was reading 1. ii-ff, which isn't a valid AutoText entry (by name).
Case "cboFF"
SetMargins 0, 1, 1
Selection.ParagraphFormat.Space1
Selection.Text = "FINDINGS OF FACT" & vbLf
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.Bold = True
Selection.Font.Underline = wdUnderlineSingle
Selection.Collapse (wdCollapseEnd)
Selection.Text = vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
Selection.Font.Underline = wdUnderlineNone
Selection.Font.Bold = False
SetMargins -0.5, 1, 1
'AutoNumberOn
Selection.Text = "1." & vbTab & "On " & strDateFOF & strEntry1 & vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
Select Case strCaseCategory
Case "IND", "IND SELF-I"
If frmIIOD.optII.Value = True Then
Selection.Text = "2." & vbTab & strIIEntry & vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
Selection.Text = "3." & vbTab & "" & vbLf
Selection.Collapse (wdCollapseEnd)
End If
If frmIIOD.optOD.Value = True Then
Selection.Text = "2." & vbTab & strODEntry & vbLf
Selection.Text = "3." & vbTab & "" & vbLf
Selection.Collapse (wdCollapseEnd)
End If
If frmIIOD.optNotNeeded.Value = True Then
Selection.Text = "2." & vbTab & "" & vbLf
Selection.ParagraphFormat.SpaceAfter = 6
Selection.Collapse (wdCollapseEnd)
End If
Case Else
'Do Nothing
End Select
This allows the to insert AutoText entries on the empty lines and continue the pre-formatted numbering system which isn't native to Word 2007. Now I just need to figure out the easiest way to higlight specific words within the inserted selection. Shouldn't be too bad:
'set array of text entries (6)
'begin loop
'find and highlight entry(i)
'end loop