Option Compare Database
Option Explicit
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 Sub Command33_Click()
On Error GoTo Err_Command33_Click
Dim oExcel As Excel.Application
Dim oSht As Excel.Worksheet
Dim db As Database
Dim RS As DAO.Recordset
Dim bRunning As Boolean
Dim iAnswer As Integer
Dim iColumn As Integer
Dim sData As String
Dim fldLoop As Object
Dim fldCount As Integer
Dim ExcelWasNotRunning As Boolean ' Flag for final release
Dim strActiveCell As String
Screen.MousePointer = 11
Set db = CurrentDb
Set RS = db.OpenRecordset("my_tbl")
If RS.EOF Then
Screen.MousePointer = 0
Set db = Nothing
Beep
MsgBox "This resulted in 0 records found.", vbInformation, "No Records Found"
Exit Sub
End If
RS.MoveLast
RS.MoveFirst
iAnswer = 6
If RS.RecordCount > 1000 Then
Screen.MousePointer = 0
iAnswer = MsgBox("This resulted in " & RS.RecordCount & " records. Continue to Excel?", vbQuestion + vbYesNo, "High Record Count")
End If
If iAnswer = 6 Then
bRunning = True
Screen.MousePointer = 11
On Error Resume Next
' Getobject function called without the first argument returns a
' reference to an instance of the application. If the application isn't
' running, an error occurs.
Set oExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then ExcelWasNotRunning = True
Err.Clear ' Clear Err object in case error occurred.
' Check for Microsoft Excel. If Microsoft Excel is running,
' enter it into the Running Object table.
DetectExcel
' Set the object variable to reference the file you want to see.
Set oExcel = GetObject("c:\folder\my_excel.xlsx")
' Show Microsoft Excel through its Application property. Then
' show the actual window containing the file using the Windows
' collection of the MyXL object reference.
oExcel.Application.Visible = True
oExcel.Parent.Windows(1).Visible = True
Set oSht = oExcel.Worksheets("my_spreadsheet")
On Error GoTo Err_Command33_Click
oSht.Activate
DoEvents
strActiveCell = oSht.Range("a65536").End(xlUp).Offset(1, 0).Address
oSht.Range(strActiveCell).CopyFromRecordset RS
' Remove this next for loop if you do not want the first row to have the field names
' iColumn = 1
' For Each fldLoop In RS.Fields
' sData = fldLoop.Name
' oExcel.Cells(1, iColumn) = sData
' iColumn = iColumn + 1
' Next
End If
Exit_Command33_Click:
' If this copy of Microsoft Excel was not running when you
' started, close it using the Application property's Quit method.
' Note that when you try to quit Microsoft Excel, the
' title bar blinks and a message is displayed asking if you
' want to save any loaded files.
If ExcelWasNotRunning = True Then
oExcel.Application.Quit
End If
Set oExcel = Nothing ' Release reference to the application and spreadsheet.
Screen.MousePointer = 0
Set RS = Nothing
Set db = Nothing
Set oSht = Nothing
Set oExcel = Nothing
Exit Sub
Err_Command33_Click:
MsgBox Err.Description
Screen.MousePointer = 0
Set RS = Nothing
Set db = Nothing
Set oSht = Nothing
Set oExcel = Nothing
Resume Exit_Command33_Click
End Sub
Sub DetectExcel()
' Procedure dectects a running Excel and registers it.
Const WM_USER = 1024
Dim hWnd As Long
' If Excel is running this API call returns its handle.
hWnd = FindWindow("XLMAIN", 0)
If hWnd = 0 Then ' 0 means Excel not running.
Exit Sub
Else
' Excel is running so use the SendMessage API
' function to enter it in the Running Object Table.
SendMessage hWnd, WM_USER + 18, 0, 0
End If
End Sub
![[glasses]](/data/assets/smilies/glasses.gif "[glasses] [glasses]")
Just traded in my old subtlety...![[tongue]](/data/assets/smilies/tongue.gif "[tongue] [tongue]")
