Created
May 19, 2022 03:15
-
-
Save sfinktah/789cfb36b3b15025d5796433da68ffb4 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Sub RefStuff() | |
' https://docs.microsoft.com/en-us/office/vba/api/word.selection.insertcrossreference | |
myHeadings = _ | |
ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem) | |
For i = 1 To UBound(myHeadings) | |
MsgBox InStr(1, LTrim(myHeadings(i)), "(a)", 1) & ":" & myHeadings(i) | |
If InStr(LCase$(myHeadings(i)), "3.xxxx") Then | |
With Selection | |
.Collapse Direction:=wdCollapseStart | |
.InsertAfter "paragraph " | |
.Collapse Direction:=wdCollapseEnd | |
.InsertCrossReference _ | |
ReferenceType:=wdRefTypeNumberedItem, _ | |
ReferenceKind:=wdNumberFullContext, ReferenceItem:=i | |
.InsertAfter " " | |
.Collapse Direction:=wdCollapseEnd | |
.InsertCrossReference _ | |
ReferenceType:=wdRefTypeNumberedItem, _ | |
ReferenceKind:=wdPosition, ReferenceItem:=i | |
.InsertParagraphAfter | |
End With | |
End If | |
Next i | |
End Sub | |
Sub paragraphs_above_cursor() | |
'pos = ActiveDocument.Paragraphs(1).Range.Start | |
pos = 0 | |
pos2 = Selection.Range.End | |
Set myRange = ActiveDocument.Range(start:=pos, End:=pos2) | |
'myrange.Select | |
MsgBox "Current Paragraph Number is " & myRange.Paragraphs.count + 1 | |
End Sub | |
Sub WhereAmI() | |
MsgBox "Paragraph number: " & GetParNum(Selection.Range) & vbCrLf & _ | |
"Absolute line number: " & GetAbsoluteLineNum(Selection.Range) & vbCrLf & _ | |
"Relative line number: " & GetLineNum(Selection.Range) | |
End Sub | |
Function GetParNum(r As Range) As Integer | |
Dim rParagraphs As Range | |
Dim CurPos As Integer | |
r.Select | |
CurPos = ActiveDocument.Bookmarks("\startOfSel").start | |
Set rParagraphs = ActiveDocument.Range(start:=0, End:=CurPos) | |
GetParNum = rParagraphs.Paragraphs.count | |
End Function | |
Function GetLineNum(r As Range) As Integer | |
'relative to current page | |
GetLineNum = r.Information(wdFirstCharacterLineNumber) | |
End Function | |
Function GetAbsoluteLineNum(r As Range) As Integer | |
Dim i1 As Integer, i2 As Integer, count As Integer, rTemp As Range | |
r.Select | |
Do | |
i1 = Selection.Information(wdFirstCharacterLineNumber) | |
Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, count:=1, Name:="" | |
count = count + 1 | |
i2 = Selection.Information(wdFirstCharacterLineNumber) | |
Loop Until i1 = i2 | |
r.Select | |
GetAbsoluteLineNum = count | |
End Function | |
Sub Demo() | |
Application.ScreenUpdating = False | |
Dim StrOut As String | |
With ActiveDocument.Range | |
With .Find | |
.ClearFormatting | |
.Replacement.ClearFormatting | |
.Text = "^13[0-9.]{1,}" ' or: .Text = "^13[0-9]{1,} | |
.Replacement.Text = "" | |
.Forward = True | |
.Wrap = wdFindStop | |
.MatchWildcards = True | |
.Execute | |
End With | |
Do While .Find.found | |
StrOut = StrOut & .Text | |
' or: MsgBox Split(.Text, vbCr)(1) | |
.Collapse wdCollapseEnd | |
.Find.Execute | |
Loop | |
End With | |
Application.ScreenUpdating = True | |
MsgBox StrOut | |
End Sub | |
Sub ReplaceFromTableList() | |
Dim oChanges As Document, oDoc As Document | |
Dim oTable As Table | |
Dim oRng As Range | |
Dim rFindText As Range, rReplacement As Range | |
Dim i As Long | |
Dim sFname As String | |
Dim sAsk As String | |
sFname = "D:\My Documents\Test\Changes.docx" | |
Set oDoc = ActiveDocument | |
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False) | |
Set oTable = oChanges.Tables(1) | |
For i = 1 To oTable.Rows.count | |
Set oRng = oDoc.Range | |
Set rFindText = oTable.Cell(i, 1).Range | |
rFindText.End = rFindText.End - 1 | |
Set rReplacement = oTable.Cell(i, 2).Range | |
rReplacement.End = rReplacement.End - 1 | |
With oRng.Find | |
.ClearFormatting | |
.Replacement.ClearFormatting | |
Do While .Execute(FindText:=rFindText, _ | |
MatchWholeWord:=True, _ | |
MatchWildcards:=False, _ | |
Forward:=True, _ | |
Wrap:=wdFindStop) = True | |
oRng.Select | |
sAsk = MsgBox("Replace - " & vbCr & oRng & vbCr + vbCr & _ | |
"with - " & vbCr & rReplacement, vbYesNo, _ | |
"Replace from Table") | |
If sAsk = vbYes Then | |
oRng.Text = rReplacement | |
End If | |
oRng.Collapse wdCollapseEnd | |
Loop | |
End With | |
Next i | |
oChanges.Close wdDoNotSaveChanges | |
End Sub | |
Public Sub InsertParagraphReference(ByRef doc As word.Document, _ | |
ByRef sel As word.Selection, _ | |
match As String, _ | |
prefix As String, _ | |
aboveBelow As Boolean, _ | |
replaceText As String, _ | |
referenceSide As Integer) | |
myHeadings = _ | |
doc.GetCrossReferenceItems(wdRefTypeNumberedItem) | |
Dim count As Integer | |
count = 0 | |
For i = 1 To UBound(myHeadings) | |
If referenceSide = 1 And InStr(LTrim(myHeadings(i)), match) = 1 Then | |
count = count + 1 | |
With sel | |
.InsertAfter "-" ' Should really be an en-dash | |
.Collapse Direction:=wdCollapseEnd | |
.InsertCrossReference _ | |
ReferenceType:=wdRefTypeNumberedItem, _ | |
ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, _ | |
InsertAsHyperlink:=True, IncludePosition:=aboveBelow | |
.Collapse Direction:=wdCollapseEnd | |
End With | |
End If | |
If referenceSide = 0 And InStr(LTrim(myHeadings(i)), match) = 1 Then | |
count = count + 1 | |
With sel | |
' It would be preferable not to remove the extra junk (or at least whitespace) | |
' that will likely be selected, either side of the paragraph ref. TODO | |
' .Text = replace(.Text, replaceText, "") | |
.Text = "" | |
.Collapse Direction:=wdCollapseStart | |
If Len(prefix) > 0 Then | |
.InsertBefore prefix & " " | |
.Collapse Direction:=wdCollapseEnd | |
End If | |
.InsertCrossReference _ | |
ReferenceType:=wdRefTypeNumberedItem, _ | |
ReferenceKind:=wdNumberFullContext, ReferenceItem:=i, _ | |
InsertAsHyperlink:=True, IncludePosition:=aboveBelow | |
' .InsertAfter ", " | |
.Collapse Direction:=wdCollapseEnd | |
End With | |
End If | |
Next i | |
If count = 0 Then | |
With sel | |
.Collapse Direction:=wdCollapseStart | |
.InsertBefore "failed_match: '" & match & "'" | |
.Collapse Direction:=wdCollapseEnd | |
.InsertParagraphAfter | |
End With | |
End If | |
End Sub | |
Public Function JoinWords(ByRef words As Variant) As String | |
Dim joined As String | |
Dim count As Integer | |
count = 0 | |
For Each aWord In words | |
aWord = FilterWord(aWord) | |
' MsgBox "aWord: " & aWord | |
If Len(aWord) > 0 Then | |
joined = joined + aWord | |
count = count + 1 | |
End If | |
If count > 10 Then Exit For | |
Next aWord | |
JoinWords = joined | |
End Function | |
Public Function FilterWord(ByRef word As Variant) As String | |
Dim filtered As String | |
Dim ord As Integer | |
filtered = "" | |
Dim length As Integer | |
length = Len(word) | |
For i = 1 To length | |
ord = Asc(word.Characters(i)) | |
If ord > 31 Then filtered = filtered + word.Characters(i) | |
If ord = 11 Then filtered = filtered + " " | |
Next i | |
FilterWord = filtered | |
End Function | |
Public Function IterateNumberedParagraphsAndReferenceFunc(ByRef paragraphPath As String, depth As Integer, Optional ByRef paragraphPath2 As String, Optional depth2 As Integer, Optional prefix As String) | |
Dim para As Paragraph | |
Dim joined As String | |
ReDim current(10) As String | |
Dim length As Integer | |
Dim lastLength As Integer | |
Dim listLevel As String | |
Dim listLevelLen As Integer | |
Dim found As Integer | |
Dim found2 As Integer | |
Dim currentString As String | |
' .ListParagraphs iterates in reverse order, so use .Paragraph and filter | |
For Each para In ActiveDocument.Paragraphs | |
With para.Range | |
If .ListParagraphs.count > 0 Then | |
joined = JoinWords(.words) | |
listLevel = Trim(.ListFormat.ListString) | |
listLevelLen = Len(listLevel) | |
If Right(listLevel, 1) = "." Then listLevel = Left(listLevel, listLevelLen - 1) | |
current(.ListFormat.ListLevelNumber - 1) = listLevel | |
currentString = Implode("", current, .ListFormat.ListLevelNumber) | |
' MsgBox joined | |
If 0 Then | |
MsgBox "Searching for: " & paragraphPath & vbCrLf _ | |
& "Style: " & para.Style _ | |
& " ListLevel: " & .ListFormat.ListLevelNumber _ | |
& " Path: " & currentString _ | |
& " Text: '" & .ListFormat.ListString & " " _ | |
& RTrim(joined) & "'" | |
' & " OutlineLevel: " & para.OutlineLevel | |
End If | |
' MsgBox Join(current, ":") | |
' If .ListFormat.ListLevelNumber - 1 <= length Then | |
' | |
' End If | |
If Not found And depth And currentString = paragraphPath Then | |
found = 1 | |
Dim paraDepthName As String | |
paraDepthName = "paragraph" | |
If depth > 1 Then paraDepthName = "sub-paragraph" | |
If depth2 <> 0 Then paraDepthName = paraDepthName & "s" | |
MsgBox "Found start: " & currentString | |
InsertParagraphReference ActiveDocument, _ | |
Selection, _ | |
.ListFormat.ListString & " " & RTrim(joined), _ | |
prefix & paraDepthName, depth2 = 0, currentString, 0 | |
If depth2 = 0 Then Exit For | |
End If | |
If found = 1 And depth2 And Not found2 And currentString = paragraphPath2 Then | |
found2 = 1 | |
MsgBox "Found end: " & currentString | |
InsertParagraphReference ActiveDocument, _ | |
Selection, _ | |
.ListFormat.ListString & " " & RTrim(joined), _ | |
"", depth2 > 0, currentString, 1 | |
Exit For | |
End If | |
lastLength = length | |
length = .ListFormat.ListLevelNumber - 1 | |
' MsgBox length | |
' ReDim Preserve current(length) | |
' MsgBox Join(current, ":") | |
End If | |
End With | |
Next para | |
End Function | |
Function TestRegExp(myPattern As String, myString As String) | |
'Create objects. | |
Dim objRegExp As RegExp | |
Dim objMatch As match | |
Dim colMatches As MatchCollection | |
Dim RetStr As String | |
Dim d 'Create a variable | |
Set d = CreateObject("Scripting.Dictionary") | |
d.Add "a", "Athens" 'Add some keys and items | |
d.Add "b", "Belgrade" | |
d.Add "c", "Cairo" | |
' Create a regular expression object. | |
Set objRegExp = New RegExp | |
'Set the pattern by using the Pattern property. | |
objRegExp.pattern = myPattern | |
' Set Case Insensitivity. | |
objRegExp.IgnoreCase = True | |
'Set global applicability. | |
objRegExp.Global = True | |
'Test whether the String can be compared. | |
If (objRegExp.test(myString) = True) Then | |
'Get the matches. | |
Set colMatches = objRegExp.Execute(myString) ' Execute search. | |
For Each objMatch In colMatches ' Iterate Matches collection. | |
' RetStr = RetStr & "Match found at position " | |
' RetStr = RetStr & objMatch.FirstIndex & ". Match Value is '" | |
' RetStr = RetStr & objMatch.Value & "'." & vbCrLf | |
RetStr = RetStr & objMatch.Value | |
Next | |
Else | |
RetStr = "" | |
End If | |
TestRegExp = RetStr | |
' Set regexMatches = .Execute(strInput) | |
' If regexMatches.count = 1 Then | |
' With regexMatches(0) | |
' MsgBox "Predecessor Task ID: " & .SubMatches(0) & ", Type: " & .SubMatches(1) | |
' End With | |
' Else | |
' MsgBox "Invalid value" | |
' End If | |
End Function | |
Public Function SplitRe(Text As String, pattern As String, Optional IgnoreCase As Boolean) As String() | |
Static re As Object | |
If re Is Nothing Then | |
Set re = CreateObject("VBScript.RegExp") | |
re.Global = True | |
re.multiline = True | |
End If | |
re.IgnoreCase = IgnoreCase | |
re.pattern = pattern | |
SplitRe = strings.Split(re.Replace(Text, ChrW(-1)), ChrW(-1)) | |
End Function | |
' REFERENCE "Microsoft VBScript Regular Expressions 5.5" FOR ( RegExp ) | |
Function RegexReplace(pat As String, _ | |
repl As String, _ | |
str As String, _ | |
Optional is_global As Boolean = True, _ | |
Optional ignore_case As Boolean = False, _ | |
Optional multiline As Boolean = False) As String | |
' Replace all instances of pat in str with repl. | |
Dim regex As Object | |
Set regex = New RegExp | |
With regex: | |
.Global = is_global | |
.IgnoreCase = ignore_case | |
.pattern = pat | |
.multiline = multiline | |
End With | |
RegexReplace = regex.Replace(str, repl) | |
End Function | |
Function RegexContains(pat As String, _ | |
str As String, _ | |
Optional ignore_case As Boolean = False, _ | |
Optional multiline As Boolean = False) As Boolean | |
' Return True if regular expression pat matches the string else False | |
Dim regex: Set regex = New RegExp | |
With regex: | |
.IgnoreCase = ignore_case | |
.pattern = pat | |
.multiline = multiline | |
End With | |
RegexContains = regex.test(str) | |
End Function | |
Function RegexFullMatch(pat As String, _ | |
str As String, _ | |
Optional ignore_case As Boolean = False, _ | |
Optional multiline As Boolean = False) As Boolean | |
' Return True if regular expression pat matches the string EXACTLY else False | |
Dim regex: Set regex = New RegExp | |
With regex: | |
.IgnoreCase = ignore_case | |
.pattern = "^" + pat + "$" | |
.multiline = multiline | |
End With | |
RegexFullMatch = regex.test(str) | |
End Function | |
Function RegexMatch(pat As String, _ | |
str As String, _ | |
Optional ignore_case As Boolean = False, _ | |
Optional multiline As Boolean = False) As Boolean | |
' Return True if regular expression pat matches the string BEGINNING else False | |
Dim regex: Set regex = New RegExp | |
With regex: | |
.IgnoreCase = ignore_case | |
.pattern = "^" + pat | |
.multiline = multiline | |
End With | |
RegexMatch = regex.test(str) | |
End Function | |
Function RegexMatchEnd(pat As String, _ | |
str As String, _ | |
Optional ignore_case As Boolean = False, _ | |
Optional multiline As Boolean = False) As Boolean | |
' Return True if regular expression pat matches the string END else False | |
Dim regex: Set regex = New RegExp | |
With regex: | |
.IgnoreCase = ignore_case | |
.pattern = pat + "$" | |
.multiline = multiline | |
End With | |
RegexMatchEnd = regex.test(str) | |
End Function | |
Function RegexMatches(pat As String, _ | |
str As String, _ | |
Optional is_global As Boolean = True, _ | |
Optional ignore_case As Boolean = True, _ | |
Optional multiline As Boolean = False) As Object | |
' Get all the matches for a pattern in string str with those parameters | |
Dim regex: Set regex = CreateObject("VBScript.RegExp") | |
With regex: | |
.Global = is_global | |
.IgnoreCase = ignore_case | |
.pattern = pat | |
.multiline = multiline | |
End With | |
Set RegexMatches = regex.Execute(str) ' find all matches | |
End Function | |
Function RegexSplit(pat As String, _ | |
str As String, _ | |
Optional ignore_case As Boolean = False, _ | |
Optional multiline As Boolean = False, _ | |
Optional num_splits = -1) As Variant | |
' If there are no capturing groups in pat, get an array of all the substrings not matched | |
' by the regex. | |
' if there are capturing groups in the regex, each capturing group gets its | |
' own element in the string list at the location where it's found in the string | |
' in addition to all the substrings not matched by the regex | |
' If num_splits is -1, split out every instance of the regex that is found | |
' If num_splits is greater than 0, split at most num_splits times before stopping. | |
' num_splits cannot be 0 or a negative number other than 1. | |
Dim is_global As Boolean | |
Dim matches | |
is_global = IIf(num_splits = 1, False, True) | |
Set matches = RegexMatches(pat, str, is_global, ignore_case, multiline) | |
ReDim out(1) As Variant | |
If matches.count = 0 Then | |
out(0) = str | |
Else | |
Dim num_strings As Integer | |
Dim matches_so_far As Integer | |
Dim first_index As Long | |
Dim match_index As Long | |
Dim unmatched As String | |
Dim num_submatches As Integer | |
Dim submatch | |
num_submatches = matches.Item(0).SubMatches.count | |
ReDim out(matches.count * (num_submatches + 1)) | |
For Each match In matches | |
If (num_splits > 0) And (matches_so_far = num_splits) Then Exit For | |
match_index = match.FirstIndex | |
unmatched = Mid(str, first_index + 1, match_index - first_index) | |
' VBA's Mid function uses 1-based indexing | |
first_index = match_index + match.length | |
out(num_strings) = unmatched | |
num_strings = num_strings + 1 | |
For Each submatch In match.SubMatches | |
out(num_strings) = submatch | |
num_strings = num_strings + 1 | |
Next submatch | |
matches_so_far = matches_so_far + 1 | |
' MsgBox ("{" + Join(out, ", ") + "}") | |
Next match | |
out(num_strings) = Mid(str, first_index + 1, Len(str) - first_index) | |
ReDim Preserve out(num_strings) | |
End If | |
RegexSplit = out | |
End Function | |
Function RegexSplitToString(pat As String, _ | |
str As String, _ | |
Optional sep As String = ", ", _ | |
Optional ignore_case As Boolean = False, _ | |
Optional multiline As Boolean = False, _ | |
Optional num_splits = -1) As String | |
' Uses RegexSplit to split out all instances of the regex | |
' (or split and include capturing groups as described above) | |
' and then stringjoin the resulting array with sep. | |
' Unlike RegexSplit, this is suitable for use as a worksheet formula. | |
Dim strings As Variant | |
strings = RegexSplit(pat, str, ignore_case, multiline, num_splits) | |
RegexSplitToString = Join(strings, sep) | |
End Function | |
Function RegexEscape(str As String) As String | |
' Escape all the special characters in string str | |
Dim special_chars As String: special_chars = "([\[\]\(\)\{\}\?\+\*\.\^\$\|\\])" | |
RegexEscape = RegexReplace(special_chars, "\$1", str, True, False, True) | |
End Function | |
Public Function in_array(ByRef my_array, my_value) As Integer | |
'https://www.excel-pratique.com/en/vba_tricks/search-in-array-function | |
in_array = -1 | |
For i = LBound(my_array) To UBound(my_array) | |
If my_array(i) = my_value Then 'If value found | |
in_array = i | |
Exit For | |
End If | |
Next | |
End Function | |
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Variant | |
IsInArray = Join(Filter(arr, stringToBeFound), ",") | |
End Function | |
Public Function IsInArrayMulti(stringToBeFound As String, arr As Variant) As Boolean | |
' IsInArray = UBound(Filter(arr(), stringToBeFound)) > -1 | |
For Each Cell In arr | |
IsInArray = IsInArray Or UBound(Filter(Cell(), stringToBeFound)) | |
Next | |
End Function | |
Public Function Implode(separator, ByRef my_array, Optional limit As Integer) As String | |
Dim count As Integer | |
For i = LBound(my_array) To UBound(my_array) | |
If count Then Implode = Implode & separator | |
Implode = Implode & my_array(i) | |
count = count + 1 | |
If count = limit Then Exit For | |
Next i | |
End Function | |
Public Function ArraySlice(ByRef str As Variant, Optional start As Integer, Optional theend As Integer) As Variant | |
Dim base As Integer | |
base = LBound(str) | |
Dim length As Integer | |
length = UBound(str) - LBound(str) | |
' All offsets are calculated as if we have a 0-index array | |
' and translated at the end | |
If theend > length Then | |
theend = length | |
ElseIf theend < 0 Then | |
theend = theend + length | |
If theend < 0 Then theend = 0 | |
End If | |
If start < 0 Then | |
start = start + length | |
If start < 0 Then start = 0 | |
End If | |
' MsgBox start & " - " & theend | |
If start >= theend Then | |
ArraySlice = Array() | |
Exit Function | |
End If | |
ReDim result(1) As Variant | |
ReDim result(theend - start - 1) | |
Dim i As Integer | |
i = start | |
While i < theend | |
result(i - start) = str(base + i) | |
i = i + 1 | |
Wend | |
ArraySlice = result | |
End Function | |
Public Function ArrayLen(ByRef my_array As Variant) As Integer | |
' MsgBox "my_array " & my_array | |
MsgBox LBound(my_array) & "-" & UBound(my_array) | |
ArrayLen = UBound(my_array) - LBound(my_array) + 1 | |
End Function | |
Public Sub IsPinpointName() | |
Dim referenceTypes As Variant | |
referenceTypes = _ | |
Array("appendix", "app", "appendices", "apps", _ | |
"article", "art", "articles", "arts", _ | |
"chapter", "ch", "chapters", "chs", _ | |
"clause", "cl", "clauses", "cls", _ | |
"division", "div", "divisions", "divs", _ | |
"paragraph", "para", "paragraphs", "paras", _ | |
"part", "pt", "parts", "pts", _ | |
"schedule", "sch", "schedules", "schs", _ | |
"section", "s", "sections", "ss", _ | |
"sub-clause", "sub-cl", "sub-clauses", "sub-cls", _ | |
"subdivision", "sub-div", "subdivisions", "sub-divs", _ | |
"sub-paragraph", "sub-para", "sub-paragraphs", "sub-paras", _ | |
"subsection", "sub-s", "subsections", "sub-ss") | |
Dim ina As Integer | |
ina = in_array(referenceTypes, "cls") | |
If ina > -1 Then | |
Dim line As Integer | |
Dim col As Integer | |
Dim abbrev As Integer | |
line = ina \ 4 | |
col = ina Mod 4 | |
abbrev = ina Mod 2 | |
MsgBox Implode(", ", ArraySlice(referenceTypes, line * 4, line * 4 + 4), 2) | |
' MsgBox "Col: " & col & " Abbrev: " & abbrev & " Line: " & line | |
' MsgBox Join(Array(referenceTypes(line * 4), referenceTypes(line * 4 + 1), referenceTypes(line * 4 + 2), referenceTypes(line * 4 + 3)), ", ") | |
End If | |
End Sub | |
Sub CreateParagraphReferenceFromSelection() | |
' Sample input: ss 8(2), 5(a)-(b) | |
Dim joinWith As String | |
joinWithMultiple = ", " | |
If Selection.Type = wdSelectionIP Then | |
Dim distanceLeft As Integer | |
Dim distanceRight As Integer | |
Dim underCursor As String | |
underCursor = Selection.Text | |
' MsgBox Prompt:="You have not selected any text! Exiting procedure..." | |
distanceLeft = Selection.MoveStartUntil(Cset:=" ", count:=wdBackward) | |
distanceRight = Selection.MoveEndUntil(Cset:=" ", count:=wdForward) | |
' Selection.StartOf Unit:=wdWord, Extend:=wdMove | |
' Selection.EndOf Unit:=wdWord, Extend:=wdExtend | |
' Selection.StartOf Unit=:=wdLine, Extend:=wdMove | |
' Selection.EndOf Unit:=wdStory, Extend:=wdMove | |
' Selection.HomeKey Unit:=wdLine, Extend:=wdExtend | |
' Selection.EndKey Unit:=wdLine, Extend:=wdExtend | |
' Selection.MoveUp Unit:=wdLine, count:=2, Extend:=wdExtend | |
Exit Sub | |
End If | |
If Selection.Type <> wdSelectionNormal Then | |
MsgBox Prompt:="Not a valid selection! Exiting procedure..." | |
Exit Sub | |
End If | |
Dim pattern As String | |
pattern = "^(([1-9][0-9]*)|(\((?:[a-z]+|[1-9][0-9]*)\)))" | |
For Each pinpoint In RegexSplit(", ?", Selection) | |
' leftRight = 0 when processing left half a ranged pintpoint, or a pintpoint without a range | |
pinpoint = Trim(pinpoint) | |
MsgBox "Searching for pinpoint(s): " & pinpoint | |
If Len(pinpoint) Then | |
Dim result As String | |
Dim output As String | |
Dim out(5) As String | |
Dim outlen As Integer | |
Dim retval As Variant | |
Dim x As Variant | |
Dim i As Integer | |
Dim leftRight As Integer | |
Dim sides(1) As Variant | |
Dim pathLengths As Variant | |
leftRight = 0 | |
i = 0 | |
pathLengths = Array(0, 0) | |
For Each half In Split(pinpoint, "-", 2) | |
While Len(half) > 0 And Right(half, 1) < Chr(33) | |
half = Left(half, Len(half) - 1) | |
Wend | |
Dim token As String | |
Dim matches: Set matches = RegexMatches(pattern, Trim(half)) | |
' grab tokens, removing as we go | |
While matches.count > 0 | |
token = matches(0).Value | |
out(i) = token | |
i = i + 1 | |
half = Mid(half, 1 + Len(token)) | |
' MsgBox "section: '" & token & "'" & " Remaining: '" & half & "'" | |
Set matches = RegexMatches(pattern, Trim(half)) | |
Wend | |
If Len(half) Then | |
MsgBox "unprocessed: '" & half & "'" | |
Else | |
' What a terrible way to resize an array | |
' retval = Split(RTrim(Join(out, " "))) | |
' MsgBox RTrim(Join(out, " ")) & "<END>" | |
sides(leftRight) = ArraySlice(out, 0, i) | |
If leftRight = 1 Then MsgBox "sides: " & Join(sides(0), ":") & " " & Join(sides(1), ":") | |
pathLengths(leftRight) = i | |
i = 0 | |
End If | |
leftRight = leftRight + 1 | |
' Exit For | |
Next | |
' MsgBox "pathLengths: " & Join(pathLengths, ", ") | |
If pathLengths(1) > 0 Then | |
Dim rhs As Variant | |
ReDim rhs(pathLengths(0)) | |
rhs = sides(0) | |
Dim offset As Integer | |
Dim count As Integer | |
count = 0 | |
offset = pathLengths(0) - pathLengths(1) | |
' MsgBox "offset " & offset | |
While offset < pathLengths(0) | |
rhs(offset) = sides(1)(count) | |
offset = offset + 1 | |
count = count + 1 | |
Wend | |
sides(1) = rhs | |
' MsgBox "Left: " & Join(sides(0), "") & " Right: " & Join(sides(1), "") | |
x = IterateNumberedParagraphsAndReferenceFunc(Join(sides(0), ""), (pathLengths(0)), Join(sides(1), ""), (pathLengths(0)), prefix:=joinWith) | |
ElseIf pathLengths(0) > 0 Then | |
x = IterateNumberedParagraphsAndReferenceFunc(Join(sides(0), ""), (pathLengths(0)), prefix:=joinWith) | |
End If | |
End If | |
joinWith = joinWithMultiple | |
Next | |
' MsgBox output | |
End Sub | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment