Option Explicit
Public TParas As Integer, MyTop1$, Mytop2$, Sfile As String, Tfile As String
Public Function Searchwords(TotParas As Integer, MyTopic2$, Mytopic1$, _
Sourcefile As String, Transferfile As String) As Boolean
'Extract and transfer range between Word docs. Standard module code
'searches sourcefile for 1 or 2 words in a range defined by...
'mytopic1(para 1/line 1) add totparas - 1 ie. both mytopic1 & mytopic2...
'must be within number of paras/lines defined by TotParas to be found
'(use 1 for mytopic2 if only 1 word search in range)
'copies found range to transferfile
'uses file copies to prevent/correct errors
'** paragraphs are 1 line only
Dim Wapp As Object, Wapp2 As Object, Bigstring As String
Dim myData$, TemP As String, PagFlag As Boolean
Dim Myrange As Variant, Myrange2 As Variant, Adjust As Integer
Dim ThisParaLoc As Integer, LastParaLoc As Integer, FirstParaloc As Integer
Searchwords = True
'copy scource file to temp file & error check
If NoFileError(Sourcefile) Then
Exit Function
End If
On Error GoTo RetErr
'Open source temp file and search
Set Wapp = CreateObject("Word.Application")
TemP = Left(Sourcefile, Len(Sourcefile) - 4) & "T.doc"
Wapp.documents.Open Filename:=TemP, ReadOnly:=True
ThisParaLoc = 0 'found paragraph line#
Bigstring = vbNullString 'combines paragraphs
'turn on pagination
PagFlag = False
If Wapp.Options.Pagination = False Then
Wapp.Options.Pagination = True
PagFlag = True
End If
'find last paragraph
Wapp.ActiveDocument.Select
LastParaLoc = Wapp.Selection.Paragraphs.Count 'last paragraph(line#)
'Find keyword(myTopic) in the source WORD document
'loop to find all keywords in doc.
On Error GoTo RetErr2
Do While ThisParaLoc < LastParaLoc
Set Myrange2 = Wapp.ActiveDocument.Paragraphs(ThisParaLoc + 1).Range
Myrange2.SetRange Start:=Myrange2.Start, _
End:=Wapp.ActiveDocument.Paragraphs(LastParaLoc).Range.End
Myrange2.Select
With Wapp.Selection.Find
.Text = Mytopic1
.Forward = True
.Execute
If .Found = True Then
On Error GoTo RetErr3
'if > 1 page
If Wapp.Selection.Information(3) > 1 Then
Adjust = Wapp.Selection.Information(3) * 46 - 46
End If
'expand keyword selection to whole paragraph(line) selection
.Parent.Expand Unit:=4
'expange range to include total # of paragraphs/lines
FirstParaloc = Wapp.Selection.Information(10) + Adjust
Set Myrange = Wapp.ActiveDocument.Paragraphs(FirstParaloc).Range
Myrange.SetRange Start:=Myrange.Start, _
End:=Wapp.ActiveDocument.Paragraphs(FirstParaloc + (TotParas - 1)).Range.End
ThisParaLoc = FirstParaloc + (TotParas - 1)
Myrange.Select
'find 2nd keyword
If MyTopic2 <> 1 Then
Myrange.Select
With Wapp.Selection.Find
.Text = MyTopic2
.Forward = True
.Execute
End With
If .Found = True Then
Myrange.Select
myData = Wapp.Selection.Text
Else
GoTo Below
End If
End If
myData = Wapp.Selection.Text
Else
Exit Do
End If
End With
'store in bigstring
Bigstring = Bigstring + myData
MsgBox Bigstring 'this line optional ie. comment out
Below:
Loop
On Error GoTo RetErr4
'transfer file to temp file & error check
NoFileError (Transferfile)
'temp transfer file to real tranfer file (errorcheck/correct)
BackToReal Transferfile, False
'transfer from bigstring to transfer file
Set Wapp2 = CreateObject("Word.Application")
Wapp2.documents.Open Filename:=Transferfile, ReadOnly:=False
Wapp2.ActiveDocument.Select
With Wapp2.ActiveDocument
.Range(0, .Characters.Count).Delete
.content.insertafter Bigstring
End With
Wapp2.ActiveDocument.Close savechanges:=True
Wapp2.Quit
Set Wapp2 = Nothing
Wapp.Quit
Set Wapp = Nothing
'temp source file to real file
BackToReal Sourcefile, True
Exit Function
'handle errors
Searchwords = False
RetErr: On Error GoTo 0: MsgBox "Source Doc Error": Wapp.Quit: _
Set Wapp = Nothing: Kill TemP: GoTo Erbelow
RetErr2: On Error GoTo 0: MsgBox "Search Error": Wapp.Quit: _
Set Wapp = Nothing: Kill TemP: GoTo Erbelow
RetErr3: On Error GoTo 0: MsgBox "Range Creation Error": Wapp.Quit: _
Set Wapp = Nothing: Kill TemP: GoTo Erbelow
RetErr4: On Error GoTo 0: MsgBox "Transfer Doc Error": Wapp2.Quit: _
Set Wapp2 = Nothing: Kill TemP: Kill Left(Transferfile, Len(Transferfile) - 4) _
& "T.doc"
Erbelow: If PagFlag Then
Wapp.Options.Pagination = False
End If
End Function
Function NoFileError(Flpath As String) As Boolean
'check if file exists. Copy to temp file from real file
Dim fs As Object, TemP3 As String
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.fileexists(Flpath) Then
TemP3 = Left(Flpath, Len(Flpath) - 4) & "T.doc"
fs.copyfile Flpath, TemP3
NoFileError = False
Else
On Error GoTo 0
MsgBox "Error: This file does not exist: " & Flpath
NoFileError = True
End If
Set fs = Nothing
End Function
Function BackToReal(Retpath As String, FlScource As Boolean)
'if real source file open continue (leave source file open)
'if real transfer file open, close it and continue
'copy temp file back to real file & kill temp file
Dim fs As Object, Objwordapp As Object, d As Variant, TemP2 As String
TemP2 = Left(Retpath, Len(Retpath) - 4) & "T.doc"
Set fs = CreateObject("Scripting.FileSystemObject")
On Error GoTo Errcode
fs.copyfile TemP2, Retpath
Set fs = Nothing
Kill TemP2
Exit Function
Errcode:
On Error GoTo 0
If FlScource Then
MsgBox "Transfer proceeding. This source file remains open: " & Retpath
Else
MsgBox "Close all Word Docs. Transfer proceeding. This transfer file was open: " & Retpath
Set Objwordapp = GetObject(, "word.application")
With Objwordapp
.Application.Quit
End With
Set Objwordapp = Nothing
fs.copyfile TemP2, Retpath
End If
Set fs = Nothing
Kill TemP2
End Function
