Hi there, I got the subject runtime error on and off when I run the following module in Access. This error only appears when there is already a Excel worksheet opened on my computer but this is not a regular incidence, meaning that I don't always get this error even with the existence of another worksheet.
It might be a simple conflict on the code but can't figure it out. I wonder if anyone can help.
It might be a simple conflict on the code but can't figure it out. I wonder if anyone can help.
Code:
Public Sub OutputPhoneDirectoryData(ByVal strBuilding As String, ByVal strFloor As String)
' Purpose: output the Phone data in tabular format
On Error GoTo Error_OutputPhoneDirectoryData
' Variables/Constants:
Dim dbs As Database
Dim strSQL As String
Dim rst As Recordset
Dim xlApp As Excel.Application
'Turn off screen updates - can reactivate them by Shift+{F2}
DoCmd.Hourglass True
Application.Echo False
Set dbs = CurrentDb
' Query database
strSQL = "SELECT tblEmployees.LastName, tblEmployees.FirstName, tblEmployees.Phone, tblEmployees.WSNum " _
& "FROM tblEmployees " _
& "WHERE (((tblEmployees.Status) = 'Active') AND ((tblEmployees.Building) = " & gcstrQuote & strBuilding & gcstrQuote & ") " _
& "AND ((tblEmployees.BldgFloor)= " & gcstrQuote & strFloor & gcstrQuote & ")) ORDER BY tblEmployees.LastName;"
Set rst = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
If rst.EOF Then
MsgBox "There is no records in the table.", vbExclamation
GoTo Exit_OutputPhoneDirectoryData
End If
rst.MoveLast: rst.MoveFirst
'SET UP THE OUTPUT WORKSHEET---------------------------------------
' Get Excel
Call StatusBarSetText("Establishing link with Excel...")
' Dim myXl As Excel.Worksheet
Dim iintLoop As Integer
Dim strHeader As String
Dim strBldgName As String
Dim intLastRow As Integer
Set xlApp = GetExcelObject()
With xlApp
.ScreenUpdating = False
.Workbooks.Add
.Worksheets("sheet1").Activate
.Range("a1").Select
Call SendDataToExcel(.ActiveSheet, rst, "A1")
.Sheets("Sheet1").Name = "Phone Directory"
End With
'Release references
rst.Close: Set rst = Nothing
dbs.Close: Set dbs = Nothing
'Display the file
Call StatusBarSetText("Displaying file...")
ActiveWindow.DisplayZeros = False
With xlApp
'Find the last data row
intLastRow = Range("A1").CurrentRegion.Rows.Count
'Format sheet
.Columns("A:D").Select
.Selection.Columns.AutoFit
.Rows("1:" & CStr(intLastRow)).Select
.Selection.Rows.AutoFit
.Rows("1:1").Select
.Selection.Font.Bold = True
'add borders to the sheet
.Range("a1").CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'set up building names
If strBuilding = "BLRE" Then
strBldgName = "120 Bloor"
ElseIf strBuilding = "CCP" Then
strBldgName = "777 Bay"
ElseIf strBuilding = "BMTT" Then
strBldgName = "55 Bloor"
ElseIf strBuilding = "BAY" Then
strBldgName = "302 Bay"
Else
strBldgName = strBuilding
End If
strHeader = "Phone Directory for " & strBldgName & ", Floor " & strFloor
'format worksheet for printing
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.CenterHeader = "&""-,Bold""&14" & strHeader
.CenterFooter = "&10P. &P of &N"
.LeftMargin = .Application.InchesToPoints(0.45)
.RightMargin = .Application.InchesToPoints(0.45)
.TopMargin = .Application.InchesToPoints(0.5)
.BottomMargin = .Application.InchesToPoints(0.25)
.HeaderMargin = .Application.InchesToPoints(0.2)
.FooterMargin = .Application.InchesToPoints(0.15)
.CenterHorizontally = True
.CenterVertically = False
End With
.Range("A1").Select
.Visible = True
.ScreenUpdating = True
.UserControl = True
End With
Set xlApp = Nothing
Exit_OutputPhoneDirectoryData:
Call StatusBarClearText
Application.Echo True
DoCmd.Hourglass False
Exit Sub
Error_OutputPhoneDirectoryData:
Set xlApp = Nothing
Application.Echo True
DoCmd.Hourglass False
MsgBox Err.Description & " Error # " & Err.Number, vbCritical, "Output Algorithm Error"
Resume Exit_OutputPhoneDirectoryData
End Sub
Public Sub SendDataToExcel(objXlSheet As Excel.Worksheet, _
ByRef rrst As Recordset, _
ByVal vstrRange As String, _
Optional ByVal ovblnIncludeFieldNames As Boolean = True)
'Purpose: Send data from a recordset to a new Excel spreadsheet
'Arguments: objXlSheet instance of Excel
' rrst recordset of data
' vstrRange top left cell of range where data will be placed
' ovblnIncludeFieldNames should field names be listed across top?
'Example: SendDataToExcel(myXl, rstEmployees, "C5", False)
'Errors are passed back up to the calling routine
Dim fld As Field
Dim iintLoop As Integer
With objXlSheet
.Range(vstrRange).Activate
If ovblnIncludeFieldNames Then
'Put the field names across the top of the sheet
For iintLoop = 0 To rrst.Fields.Count - 1
.Application.ActiveCell.Offset(0, iintLoop) = rrst.Fields(iintLoop).Name
Next iintLoop
.Application.ActiveCell.Offset(1, 0).Activate
End If
'Put data in cells
.Application.ActiveCell.CopyFromRecordset rrst
End With
End Sub
Public Function GetExcelObject() As Excel.Application
' Purpose: Get a reference to Excel (start a new instance, or use an existing one)
On Error GoTo Err_GetExcelObject
Const cstrProcName = "GetExcelObject"
Dim objExcel As Excel.Application 'new Excel Application for spreadsheet
Dim lngErrNum As Long 'Error raised
Dim blnRegistered As Boolean 'temp variable
'Get reference to instance of Excel (GetObject will return
'an error if Excel isn't running)
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
lngErrNum = Err.Number
Err.Clear
On Error GoTo Err_GetExcelObject
If lngErrNum <> 0 Then
'Excel wasn't running, so start a new instance of it
Set objExcel = CreateObject("Excel.Application")
End If
'Register the newly created Excel file
blnRegistered = RegisterRunningExcel
If blnRegistered Then
Set GetExcelObject = objExcel
Else
'Excel wasn't running, not registered
Set GetExcelObject = Nothing
End If
Exit_GetExcelObject:
Exit Function
Err_GetExcelObject:
MsgBox Err.Description, , "Error #" & Err.Number & " in procedure: " & cstrProcName
Set objExcel = Nothing
Resume Exit_GetExcelObject
End Function
Private Function RegisterRunningExcel() As Boolean
'Purpose: dectects a running Excel and registers it.
Const WM_USER = 1024
Dim hWnd As Long 'Excel's handle
'Get Excel's handle
hWnd = FindWindow("XLMAIN", 0)
If hWnd = 0 Then ' 0 means Excel not running.
RegisterRunningExcel = False
Else
'Excel is running. Use the SendMessage API
'function to enter it in the Running Object Table.
Call SendMessage(hWnd, WM_USER + 18, 0, 0)
RegisterRunningExcel = True
End If
End Function
Last edited:
