Here's the whole thing. I want the document to open and stay open until the user closes it. However, it that's a problem, I'll close it, kill Word and give the user a message about where it is.
Thanks for your help!!
Private Sub cmdCompileBatches_Click()
'_______________________________________________________________________
'
'Allows user to merge all batches for a CC number into one Word document
'_________________________________________________________________________
On Error GoTo ErrorHandler
Dim rs As DBResults
Dim strSQL As String
Dim Batch As Long
Dim Request As String
Dim oapp As Word.Application
Dim SearchFolder As String
Dim FirstDocument As String
Dim psindex As Long
Dim doc As String
Dim DestinationFolder As String
Dim ActiveDocument As String
'Save the document
DestinationFolder = "//phlactgfp01/conflicts/"
SearchFolder = "//phlactgfp01/conflicts/"
'Get the Batch number entered by the user
Batch = Me.txtBatchID
Request = Me.txtSearchDesc.Text
'Check to see if the document is already open. If it is prompt user and stop
If IsDocOpen(Request & ".doc") = True Then
MsgBox "Word document " & Request & Chr(13) & Chr(10) & "is open. Please close.", vbCritical, "Document Exists and is Open"
Exit Sub
End If
'Open Word, set it to visible and minimize
Set oapp = CreateObject("Word.Application")
oapp.Visible = True
oapp.Application.WindowState = wdWindowStateMinimize
strSQL = "Select psindex, psdesc from psearch where psdesc = " & "'" & Request & "'" & _
" ORDER BY psindex asc"
Set rs = Application.DB.OpenResults(strSQL)
If Not rs.AtEnd Then
With rs
FirstDocument = SearchFolder & Batch & "001.doc"
If FirstDocument = "" Then
'File does not exist
MsgBox (FirstDocument & " does not exist!"), vbCritical + vbOKOnly, "EIS Forms"
Exit Sub
End If
If vbNo = MsgBox("Merge All Batch Files?", vbYesNo + vbQuestion) Then
Exit Sub
Else
oapp.Documents.Add DocumentType:=wdNewBlankDocument
Do While Not rs.AtEnd
Batch = rs.Value(psindex)
'Find the latest document number for each batch
Dim f As String
doc = LCase(Batch & "001.doc")
f = LCase(Dir(SearchFolder & Batch & "???.doc"))
While f <> ""
If f > doc Then doc = f
f = LCase(Dir)
Wend
oapp.Selection.InsertFile SearchFolder & doc
oapp.Selection.InsertBreak
rs.MoveNext
Loop
oapp.ActiveDocument.SaveAs (DestinationFolder & Request & ".doc")
End If
End With
MsgBox vbCr & _
"Conflict of Interest Report " & vbCr & _
"Compiled in Word as " & Request & ".doc", vbOKOnly, "Conflict Report"
End If
'Cleanup
DestinationFolder = ""
SearchFolder = ""
Batch = 0
Request = ""
strSQL = ""
Set rs = Nothing
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 5356
MsgBox "To save again, close document " & Request & "." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Then click Compile Word Document.", vbCritical, "Document Exists and is Open"
Case Else
MsgBox "Error " & Err.Number & vbCr & _
"Location: " & "VBA.frmBatch.txtBatchID" & vbCr & _
Err.Description, vbOKOnly + vbExclamation, _
"Custom Conflicts Search"
End Select
End Sub
Function IsDocOpen(docName As String) As Boolean
On Error Resume Next
IsDocOpen = Len(Documents(docName).Name)
If IsDocOpen = True Then
End If
End Function