Gasman
Enthusiastic Amateur
- Local time
- Today, 16:34
- Joined
- Sep 21, 2011
- Messages
- 16,449
Hi all,
I am trying to export the results of a query to an excel workbook.
The excel object is created, but when I try an open an excel file (I have tried several) it fails with Automation Error, The Server threw an exception - Error 2147417851
All of the code is below and is in development.
I can run macroes in other workbooks no problem and I have trust vba in security setting for excel and able to run macroes in Access.
Where do I start to find the problem please?
I am trying to export the results of a query to an excel workbook.
The excel object is created, but when I try an open an excel file (I have tried several) it fails with Automation Error, The Server threw an exception - Error 2147417851
All of the code is below and is in development.
I can run macroes in other workbooks no problem and I have trust vba in security setting for excel and able to run macroes in Access.
Where do I start to find the problem please?
Code:
Private Sub Command4_Click()
On Error GoTo Err_Handler
Dim db As Database
Dim xlApp As New Excel.Application
Dim xlWrkBk As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim rstTrades As Recordset, rstIntro As Recordset
Dim strSQL As String, strSQLdate As String, strDBpath As String, strFolder As String, strPaymentsPath As String
Dim lSubmitterID As Long, lxlRow As Long
Const strcJetDate = "\#mm\/dd\/yyyy\#" 'Needed for dates in queries as Access expects USA format.
Set db = CurrentDb()
strDBpath = GetDBPath
'Create new folder if it does not exist
strFolder = Format(Now(), "yyyy-mm-dd")
strPaymentsPath = strDBpath & "Invoice\" & strFolder & "\"
' Test for path to save files, created each week.
If Dir(strPaymentsPath, vbDirectory) = "" Then
MkDir strPaymentsPath
End If
'Open and reference an instance of the Excel app
Set xlApp = CreateObject("Excel.Application")
' First get all the Submitters that can have an Invoice Run
strSQL = "SELECT tblSubmitter.InvoiceRun, tblSubmitter.SubmitterName, tblSubmitter.SubmitterID FROM tblSubmitter"
strSQL = strSQL & " WHERE (((tblSubmitter.InvoiceRun)=True))"
strSQL = strSQL & " ORDER BY tblSubmitter.SubmitterName;"
Set rstIntro = db.OpenRecordset(strSQL, dbOpenDynaset)
' Any submitter to process?
If rstIntro.EOF Then
MsgBox "No Submitters found for Invoice Run"
GoTo ExitSub
End If
' Set date in correct format for query
strSQLdate = Format(Me.txtInvoiceDate, strcJetDate)
' Set submitterID for query
lSubmitterID = rstIntro.Fields("SubmitterID").Value
lSubmitterID = 1
strSQL = "SELECT tblSVSTrades.TradeDate, tblSVSTrades.Forename, tblSVSTrades.Surname, tblSVSTrades.TradeType, tblSVSTrades.NetCost, tblSVSTrades.BuySell, tblSubmitter.SubmitterName, tblIntroCommission.IntroCommission FROM tblSubmitter"
strSQL = strSQL & " INNER JOIN (tblSubmitterClient INNER JOIN ((tblCommission INNER JOIN tblIntroCommission ON tblCommission.CommissionID = tblIntroCommission.CommissionID) INNER JOIN tblSVSTrades ON tblCommission.TradeID = tblSVSTrades.SVSTradesID) ON tblSubmitterClient.SubmitterClientID = tblIntroCommission.SubmitterClientID) ON tblSubmitter.SubmitterID = tblSubmitterClient.SubmitterID"
strSQL = strSQL & " WHERE (((tblIntroCommission.InvoicedDate) = " & strSQLdate & ") AND ((tblSubmitterClient.SubmitterID)= " & lSubmitterID & "))"
strSQL = strSQL & " ORDER BY tblSVSTrades.SVSTradesID;"
Set rstTrades = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rstTrades.BOF And rstTrades.EOF) Then
' Open the Excel Template file
[COLOR="Red"]Set xlWrkBk = xlApp.Workbooks.Open("C:\Temp\SVS Weekly Update.xlsx")[/COLOR]
'reference the first sheet in the file
Set xlSht = xlWrkBk.Sheets(1)
rstTrades.MoveFirst
lxlRow = 3
Do While Not rstTrades.EOF
' Now enter values in sheet
xlSht.Cells(xlRow, 1) = rstTrades.Fields("Trade date")
xlSht.Cells(xlRow, 2) = rstTrades.Fields("Forename")
xlSht.Cells(xlRow, 3) = rstTrades.Fields("Surname")
xlSht.Cells(xlRow, 4) = rstTrades.Fields("Trade Type")
xlSht.Cells(xlRow, 5) = rstTrades.Fields("NetCost")
xlSht.Cells(xlRow, 6) = rstTrades.Fields("Buy/Sell")
xlSht.Cells(xlRow, 7) = rstTrades.Fields("SubmitterName")
xlSht.Cells(xlRow, 8) = rstTrades.Fields("IntroCommission")
lxlRow = lxlRow + 1
rstTrades.MoveNext
Loop
lxlRow = lxlRow + 2
xlSht.Cells(xlRow, 7) = "Total"
xlSht.Cells(xlRow, 8) = "=SUM(H3:H" & lxlRow - 2 & ")"
' Now save the workbook
xlWrkBk.saveas strPaymentsPath & rstTrades.Fields("SubmitterName") & " Invoice.xlsx"
xlWrkBk.Close
Else
MsgBox "No trades for " & rstTrades.Fields("SubmitterName")
End If
ExitSub:
Set db = Nothing
Set rstIntro = Nothing
Set rstTrades = Nothing
Set xlWrkBk = Nothing
Set xlApp = Nothing
Err_Exit:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " " & Err.Description
Resume ExitSub
End Sub