I obviously cannot test the entire code here, as I don't have the
appropriate data and such all set up for a test. I've gone through the code
and can't find any obvious errors.
However, it's possible that the error is occurring because you're using the
default "activesheet" type references, and this may be caused by what the
code does in the other functions.
Why not try this and see if it helps. Let's replace these three lines of
code in the SendPatReptoExcel subroutine
.Sheets(patientreport).Activate
.ActiveSheet.Range("A9").CopyFromRecordset rstdata
.ActiveSheet.Range("N1
1").EntireColumn.Delete
to these lines:
.Sheets(patientreport).Range("A9").CopyFromRecordset rstdata
.Sheets(patientreport).Range("N1
1").EntireColumn.Delete
This uses specific references and there is less likelihood of the wrong
spreadsheet being accessed.
Post back and let us know.
--
Ken Snell
<MS ACCESS MVP>
Basil said:
Thanks for getting back to me Ken, it is really appreciated. Here is the detail that you asked.
Firstly, I don't think my previous messages went through. Secondly, I
thought it would be easier to show you the full code. I am running MS
Access 97. I have also tried to put the activate worksheet line outside of
the With Statement - it made no difference. One thing I have noticed is
that it seems to also error the first time round if the first sheet
referenced is not the default on workbook open. Stepping through the stages
it does seem to recognise (only on the first loop) what I am asking it to do
as in Excel it will activate the appropriate sheet and even successfully
complete any worksheet_onActivate procedures (when they exist) - but then
moving back to Access it will produce the error. Here is the full code (the
simplest version - I've tried loads of alternative methods), thanks for you
thoughts:
Option Compare Database
Option Explicit
'Declare API routines:
Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long
Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private dbs As Database
Private rstdata As Recordset
Public XLObject As Object 'Variable to hold MS Excel objects
Public XLRunning As Boolean 'Flag to hold initial state of MS Excel
Public reporttype As String
Public patientreport As String
Public ReferringTrust As String
Private patrepemail As String
Private rstdatacount As Long
Private nodata As Boolean
Function HasOutlook() As Boolean 'Returns 'True' if MS Outlook can be activated
On Error Resume Next
Dim OLObject As Object
Set OLObject = CreateObject("Outlook.Application") 'Attempts to open MS Outlook object
HasOutlook = (Err.Number = 0) 'Returns 'True' if
there is no error, Else 'False'
End Function
Function XLStatus() 'Enters the status
of Excel into XLRunning variable
'and registers it in Running Object Table
Const WM_USER = 1024
Dim hWnd As Long
hWnd = FindWindow("XLMAIN", 0) 'This API call returns Excel's handle
If hWnd = 0 Then '0 means Excel not running
XLRunning = False
Exit Function
Else
SendMessage hWnd, WM_USER + 18, 0, 0 'Excel is running so use the SendMessage API
XLRunning = True 'function to enter it in the Running Object Table
End If
End Function
Private Sub EmailPatXLRep()
Dim tabrecipient As TableDef
Dim rstrecipient As Recordset
Dim counter
Set dbs = CurrentDb
Set tabrecipient = dbs.TableDefs("Referring Trusts")
Set rstrecipient = tabrecipient.OpenRecordset
rstrecipient.MoveFirst
Do Until rstrecipient.EOF
ReferringTrust = rstrecipient("National Site/Trust Name")
patrepemail = rstrecipient("Patient Level Contact Email")
Forms![external reporting]!cborecipient = ReferringTrust
CreatePatXLRep
If nodata = True Then
XLObject.Close
Else
XLObject.SendMail patrepemail, "RPH Patient Report"
XLObject.Close
End If
rstrecipient.MoveNext
Loop
If XLRunning = False Then XLObject.Application.Quit
End Sub
Private Sub CreatePatXLRep()
Dim counter
counter = 0
rstdatacount = 0
nodata = True
Do
counter = counter + 1
Select Case counter
Case 1
patientreport = "Referral"
Case 2
patientreport = "Pre-Operative Clinic"
Case 3
patientreport = "Booked List"
Case 4
patientreport = "Inpatient"
Case 5
patientreport = "Post-Operative Clinic"
End Select
SendPatReptoExcel
Loop Until counter = 5
If rstdatacount > 0 Then nodata = False
End Sub
Private Sub SendPatReptoExcel()
Dim Master As String, TargetFile As String 'Variables for referencing external files
If patientreport = "Referral" Then
Master = "M:\RPH - Reporting\Reporting Components\Master External Patient Report.xls"
TargetFile = "M:\Patient Flow Team\External Reports\Patient
Reports\" & ReferringTrust & ".xls"
Microsoft Excel is already running
On Error GoTo err_mastertarget
If Dir(TargetFile) <> "" Then
Kill TargetFile
End If
FileCopy Master, TargetFile
Set XLObject = GetObject(TargetFile) 'Set the
object variable to reference the target file
End If
GetPatReprst
With XLObject
.Application.Visible = True
.Parent.Windows(1).Visible = True
.Sheets(patientreport).Activate
.ActiveSheet.Range("A9").CopyFromRecordset rstdata
.ActiveSheet.Range("N1
1").EntireColumn.Delete
End With
rstdata.Close
Exit Sub
err_mastertarget:
Select Case Err.Number
Case 53
MsgBox "The Master Excel file has been moved or it's directory has changed@Please contact the " _
& "administrator to report the problem@", vbOKOnly +
vbExclamation, "Error " & Err.Number
Case 70
MsgBox "The Master file is currently open@Please ensure it is
closed and re-run this procedure@", , _
"Error " & Err.Number
Case 75
MsgBox "The target file is currently open@Please close the file and re-run this procedure@", _
vbOKOnly + vbExclamation, "Error " & Err.Number
Case Else
MsgBox Err.Description, , Err.Number
End Select
Exit Sub
End Sub
Private Sub GetPatReprst()
Dim qry As QueryDef 'Variables for referencing the Access Objects
Set dbs = CurrentDb
Set qry = dbs.QueryDefs("qryExternal " & patientreport & " Report")
If patientreport = "Referral" Then
qry.Parameters(0) = Forms![external reporting]!cborecipient
qry.Parameters(1) = Forms![external reporting]!txtstdate
Else
qry.Parameters(0) = Forms![external reporting]!txtstdate
End If
Set rstdata = qry.OpenRecordset
rstdatacount = rstdatacount + rstdata.RecordCount
End Sub
