Option Explicit
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(1st paragraph of range)to Totparas(total # of paras/lines in range)
'(use 1 for Mytopic2 if only one word search required within range)
'copies found range(s) to Transferfile
'uses file copies to prevent/correct open file errors
'** paragraphs are 1 line only
'TotParas= # of paragraphs/lines in range to be transferred
'MyTopic2$= 2nd word to be found located anywhere within range.
'Mytopic1$= 1st word to be found. **Must be in 1st paragraph of range
'Sourcefile= Doc file being searched
'Transferfile= Doc file that range is being transferred to
'Boolean result indicates success/failure of transfer
Dim Wapp 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(MyTopic1) 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 'Mytopic2 not found
End If
End If
'found paragraph range converted to string
Mydata = Wapp.Selection.Text
Else
Exit Do 'Mytopic1 not found
End If
End With
'store found paragraph range with other found ranges
Bigstring = Bigstring + Mydata
Below:
Loop
On Error Goto RetErr4
'transfer file to temp file & error check
NoFileError (Transferfile)
'temp transfer file to real transfer file (errorcheck/correct)
BackToReal Transferfile, False
'transfer from bigstring to transfer file
Wapp.documents.Open Filename:=Transferfile, ReadOnly:=False
Wapp.activedocument.Select
With Wapp.activedocument
.Range(0, .Characters.Count).Delete
.content.insertafter Bigstring
End With
Wapp.activedocument.Close savechanges:=True
'reset pagination to start setting
If PagFlag Then
Wapp.Options.Pagination = False
End If
Wapp.Quit
Set Wapp = Nothing
'temp source file to real file
BackToReal Sourcefile, True
Exit Function
'handle errors
RetErr: On Error Goto 0: MsgBox "Source Doc Error": Kill Temp: Goto Erbelow
RetErr2: On Error Goto 0: MsgBox "Search Error": Kill Temp: Goto Erbelow
RetErr3: On Error Goto 0: MsgBox "Range Creation Error": Kill Temp: Goto Erbelow
RetErr4: On Error Goto 0: MsgBox "Transfer Doc Error": Kill Temp: Kill _
Left(Transferfile, Len(Transferfile) - 4) & "T.doc"
Erbelow:
Searchwords = False
'reset pagination to start setting
If PagFlag Then
Wapp.Options.Pagination = False
End If
Wapp.Quit
Set Wapp = Nothing
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
Sub Callfunction()
Dim TParas As Integer, MyTop1 As String, Mytop2 As String
Dim Sfile As String, Tfile As String
Sfile = "c:\vbaxtest.doc" 'search document path
Tfile = "c:\test.doc" 'search results document path
'other search words as Mytop1 eg's: Assert,spraysup,CustAPL,RndUp
MyTop1 = "seed" ' 1st search word ie. start of transfer range
'other search eg. trial "bart" as Mytop2 with "seed" as mytop1
Mytop2 = "1" ' 2nd search word. Set to "1" if only 1 word search
TParas = 5 '# of paras to extract (includes blank para following range)
If Searchwords(TParas, Mytop2, MyTop1, Sfile, Tfile) Then
MsgBox "Transfer complete"
Else
MsgBox "Transfer not successful"
End If
End Sub
|