axiomcrs
07-11-2013, 11:39 AM
I am having trouble saving the Word doc in the macro below and can't figure out why. The macro seems to run successfully, but when I close Word, it asks if I want to save the doc. Any suggestions?
Sub SearchDocByLine()
Dim RegExp As Object
Set RegExp = CreateObject("vbscript.regexp")
Dim re As RegExp
Set re = New RegExp
re.Pattern = "^[\t\+][0-9]+\."
re.IgnoreCase = True
re.Global = True
Application.ScreenUpdating = False
Dim i As Integer, Rng As Range
Dim intVal As Integer
Dim mymatches As MatchCollection
Dim mymatch As match
Dim names() As String
Dim namesindented() As String
Dim j As Integer
Dim pagenumber As Integer
Dim msgString As String
Dim temp As String
Dim strTemp As String
Dim x As Integer
Dim y As Integer
Dim lngMin As Long
Dim lngMax As Long
Dim temp1 As String
Dim temp2 As String
Dim namestotal As Integer
Dim printdebug As Integer
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim z As Integer
'Dim f As Integer
'Const WODDOC As String = "C:\Project2\output\master.doc"
'f = FreeFile
'Open WODDOC For Output As #f 'opens the file in I/O stream
'Close #f 'closes and saves new, blank file
'Shell "winword " & WODDOC, vbMaximizedFocus
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
'Set wrdDoc = wrdApp.Documents.Open("C:\Project2\output\master.doc")
Set wrdDoc = wrdApp.Documents.Add
ChDir "C:\KenGraves\Project2\input"
myName = Dir("*.DOC")
j = 0
printdebug = 0
namestotal = 0
With wrdDoc
'Concatenate files
While myName <> ""
With Selection
.InsertFile FileName:=myName, ConfirmConversions:=False
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
myName = Dir()
Wend
With Selection
.TypeText Text:="INDEX"
.InsertParagraphAfter
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.found
i = i + 1
Set Rng = .Duplicate
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\line")
re.Pattern = "^[\t\+][0-9]+\."
'Test if line contains a descendant
If (re.test(Rng.Text)) Then
If printdebug = 1 Then
MsgBox "Rng.Text=" & Rng.Text
MsgBox "Page num=" & Rng.Information(wdActiveEndPageNumber)
End If
'Get first descendant
re.Pattern = "^([\t\+][0-9]+\.\t)([.a-zA-Z ]+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If mymatches(0).SubMatches(1) <> "infant" And mymatches(0).SubMatches(1) <> "daughter" Then
If printdebug = 1 Then
MsgBox "Desc=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
'Get married name that follows m.
re.Pattern = "(, m\. )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If mymatches(0).SubMatches(1) <> "------" Then
If printdebug = 1 Then
MsgBox "m.=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
'Get married name that follows m(1)
re.Pattern = "(m\(1\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If printdebug = 1 Then
MsgBox "m1=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
'Get married name that follows m(2)
re.Pattern = "(m\(2\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If printdebug = 1 Then
MsgBox "m2=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
'Get married name that follows m(3)
re.Pattern = "(m\(3\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If printdebug = 1 Then
MsgBox "m3=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
If Rng.Text = "INDEX" Then Exit Do
.start = Rng.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With 'ActiveDocument.Range
Set Rng = Nothing
Application.ScreenUpdating = True
printdebug = 1
namestotal = j
If printdebug = 1 Then
MsgBox "namestotal=" & namestotal
End If
printdebug = 0
'Rearrange names to be last name first
For j = 1 To namestotal
temp = names(j)
re.Pattern = "([a-zA-Z \.\(\)\? ]+) ([a-zA-z]+)( [0-9]+)$"
Set mymatches = re.Execute(temp)
If mymatches.Count > 0 Then
If printdebug = 1 Then
MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
End If
names(j) = mymatches(0).SubMatches(1) & ", " & mymatches(0).SubMatches(0) & mymatches(0).SubMatches(2)
Else
If printdebug = 1 Then
MsgBox "No match"
End If
End If
Next j
printdebug = 0
If printdebug = 1 Then
For j = 1 To UBound(names)
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 0
'Sort array
lngMin = 1
lngMax = namestotal
For x = lngMin To lngMax - 1
For y = x + 1 To lngMax
If names(x) > names(y) Then
strTemp = names(x)
names(x) = names(y)
names(y) = strTemp
End If
Next y
Next x
printdebug = 0
If printdebug = 1 Then
For j = 1 To namestotal
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 1
'Indent array to give illusion of an index
ReDim Preserve namesindented(namestotal)
namesindented(1) = names(1)
'For j = 2 To namestotal
' re.Pattern = "^([a-zA-Z]+, )"
' Set mymatches = re.Execute(names(j - 1))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp1 = mymatches(0).SubMatches(0)
' End If
' Set mymatches = re.Execute(names(j))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp2 = mymatches(0).SubMatches(0)
' End If
' If printdebug = 1 Then
' MsgBox "temp1=" & temp1 & " temp2=" & temp2
' End If
' If temp1 = temp2 Then
' namesindented(j) = Right(names(j), Len(names(j)) - Len(temp1))
' namesindented(j) = Space(Len(temp1)) & namesindented(j)
' If printdebug = 1 Then
' MsgBox "names=" & names(j) & " namesindented=" & namesindented(j)
' End If
' End If
'Next j
'Write array to doc
For z = 1 To namestotal
ActiveDocument.Content.InsertAfter (names(z)) & vbCrLf
MsgBox "Written string=" & names(z)
Next z
If Dir("C:\Project2\output\master.doc") <> "" Then
Kill "C:\Project2\output\master.doc"
End If
.SaveAs ("C:\Project2\output\master.doc")
.Close ' close the document
End With 'wrddoc
wrdApp.quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
Sub SearchDocByLine()
Dim RegExp As Object
Set RegExp = CreateObject("vbscript.regexp")
Dim re As RegExp
Set re = New RegExp
re.Pattern = "^[\t\+][0-9]+\."
re.IgnoreCase = True
re.Global = True
Application.ScreenUpdating = False
Dim i As Integer, Rng As Range
Dim intVal As Integer
Dim mymatches As MatchCollection
Dim mymatch As match
Dim names() As String
Dim namesindented() As String
Dim j As Integer
Dim pagenumber As Integer
Dim msgString As String
Dim temp As String
Dim strTemp As String
Dim x As Integer
Dim y As Integer
Dim lngMin As Long
Dim lngMax As Long
Dim temp1 As String
Dim temp2 As String
Dim namestotal As Integer
Dim printdebug As Integer
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim z As Integer
'Dim f As Integer
'Const WODDOC As String = "C:\Project2\output\master.doc"
'f = FreeFile
'Open WODDOC For Output As #f 'opens the file in I/O stream
'Close #f 'closes and saves new, blank file
'Shell "winword " & WODDOC, vbMaximizedFocus
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
'Set wrdDoc = wrdApp.Documents.Open("C:\Project2\output\master.doc")
Set wrdDoc = wrdApp.Documents.Add
ChDir "C:\KenGraves\Project2\input"
myName = Dir("*.DOC")
j = 0
printdebug = 0
namestotal = 0
With wrdDoc
'Concatenate files
While myName <> ""
With Selection
.InsertFile FileName:=myName, ConfirmConversions:=False
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
myName = Dir()
Wend
With Selection
.TypeText Text:="INDEX"
.InsertParagraphAfter
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.found
i = i + 1
Set Rng = .Duplicate
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\line")
re.Pattern = "^[\t\+][0-9]+\."
'Test if line contains a descendant
If (re.test(Rng.Text)) Then
If printdebug = 1 Then
MsgBox "Rng.Text=" & Rng.Text
MsgBox "Page num=" & Rng.Information(wdActiveEndPageNumber)
End If
'Get first descendant
re.Pattern = "^([\t\+][0-9]+\.\t)([.a-zA-Z ]+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If mymatches(0).SubMatches(1) <> "infant" And mymatches(0).SubMatches(1) <> "daughter" Then
If printdebug = 1 Then
MsgBox "Desc=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
'Get married name that follows m.
re.Pattern = "(, m\. )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If mymatches(0).SubMatches(1) <> "------" Then
If printdebug = 1 Then
MsgBox "m.=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
'Get married name that follows m(1)
re.Pattern = "(m\(1\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If printdebug = 1 Then
MsgBox "m1=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
'Get married name that follows m(2)
re.Pattern = "(m\(2\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If printdebug = 1 Then
MsgBox "m2=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
'Get married name that follows m(3)
re.Pattern = "(m\(3\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If printdebug = 1 Then
MsgBox "m3=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
If Rng.Text = "INDEX" Then Exit Do
.start = Rng.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With 'ActiveDocument.Range
Set Rng = Nothing
Application.ScreenUpdating = True
printdebug = 1
namestotal = j
If printdebug = 1 Then
MsgBox "namestotal=" & namestotal
End If
printdebug = 0
'Rearrange names to be last name first
For j = 1 To namestotal
temp = names(j)
re.Pattern = "([a-zA-Z \.\(\)\? ]+) ([a-zA-z]+)( [0-9]+)$"
Set mymatches = re.Execute(temp)
If mymatches.Count > 0 Then
If printdebug = 1 Then
MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
End If
names(j) = mymatches(0).SubMatches(1) & ", " & mymatches(0).SubMatches(0) & mymatches(0).SubMatches(2)
Else
If printdebug = 1 Then
MsgBox "No match"
End If
End If
Next j
printdebug = 0
If printdebug = 1 Then
For j = 1 To UBound(names)
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 0
'Sort array
lngMin = 1
lngMax = namestotal
For x = lngMin To lngMax - 1
For y = x + 1 To lngMax
If names(x) > names(y) Then
strTemp = names(x)
names(x) = names(y)
names(y) = strTemp
End If
Next y
Next x
printdebug = 0
If printdebug = 1 Then
For j = 1 To namestotal
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 1
'Indent array to give illusion of an index
ReDim Preserve namesindented(namestotal)
namesindented(1) = names(1)
'For j = 2 To namestotal
' re.Pattern = "^([a-zA-Z]+, )"
' Set mymatches = re.Execute(names(j - 1))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp1 = mymatches(0).SubMatches(0)
' End If
' Set mymatches = re.Execute(names(j))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp2 = mymatches(0).SubMatches(0)
' End If
' If printdebug = 1 Then
' MsgBox "temp1=" & temp1 & " temp2=" & temp2
' End If
' If temp1 = temp2 Then
' namesindented(j) = Right(names(j), Len(names(j)) - Len(temp1))
' namesindented(j) = Space(Len(temp1)) & namesindented(j)
' If printdebug = 1 Then
' MsgBox "names=" & names(j) & " namesindented=" & namesindented(j)
' End If
' End If
'Next j
'Write array to doc
For z = 1 To namestotal
ActiveDocument.Content.InsertAfter (names(z)) & vbCrLf
MsgBox "Written string=" & names(z)
Next z
If Dir("C:\Project2\output\master.doc") <> "" Then
Kill "C:\Project2\output\master.doc"
End If
.SaveAs ("C:\Project2\output\master.doc")
.Close ' close the document
End With 'wrddoc
wrdApp.quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub