Excel Automation fails second time round

feets · October 30th, 2007, 11:39 AM

I am having a few problems getting my head around Excel VBA.From an Access Form, I am running a command which runs several Sql Queries, exporting the recordsets to Excel. Each query creating a new worksheet. The first time I run it everything is ok, however the second time I get error 1004 method sheets of object _Global failed

Each Query is called from its own procedure, and as I say I get the error second run, when trying to add a worksheet.

Below is a sample of the code. I notice that the first time I run the command, it always leaves an instance of Excel running in my processes, which I don't understand since I tell the App to quit.

Any ideas much appreciated.

Quote:

quote:Private Sub cmdQryOfficer_Click()

Dim xl As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Set xl = CreateObject("excel.Application")

strXlsPath = Application.CurrentProject.Path

strXlsPath = strXlsPath & "\templates\OfficerRpt.xls"

Set xlBook = xl.Workbooks.Add(strXlsPath)

xl.Visible = True
xlBook.Windows(1).Visible = True

Set xlSheet = xlBook.Worksheets("Sheet1")
xl.Sheets(1).Name = "Report"

<---- This is where I get the error second time

xl.Worksheets.Add After:=xlBook.Sheets(Sheets.Count)
ViewCountRptsOnSchools

Set xlSheet = Nothing
Set xlBook = Nothing
Set rs = Nothing
Set cmd = Nothing
xl.Quit
Set xl = Nothing

End Sub

Private Sub ViewCountRptsOnSchools()

strSql = "select ChrSchoolName,Count(chrSchoolName) As CountVisits From View_AllSchoolVisits Where(intOfficerId=" _
& cboOfficer & ") Group By ChrSchoolName"

Set cmd = New ADODB.Command

cmd.ActiveConnection = CurrentProject.Connection
cmd.CommandType = adCmdText
cmd.CommandText = strSql

Set rs = cmd.Execute

intCount = rs.RecordCount
strRange = "A1:B" & intCount
Sheets(Sheets.Count).Cells(1, 1).CopyFromRecordset rs
Sheets(Sheets.Count).Name = "CountVisits"

Sheets("Report").Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.SetSourceData Source:=Sheets("CountVisits").Range(strRange), PlotBy _
:=xlColumns

End Sub

Shasur · October 30th, 2007, 08:54 PM

Excel Application might be in the memory if the workbooks opened in the Application are not closed - waiting for a user reply etc.

You can use the following to close the workbook

xlBook.Save (If Save is necessary)
xlBook.Close (False)

Cheers
Shasur

http://www.dotnetdud.blogspot.com

VBA Tips & Tricks (http://www.vbadud.blogspot.com)

feets · October 31st, 2007, 07:48 AM

After advise from other Pro's, I have prequalified all my objects, but still am unable to run the command second time round. The excel Process remains present after the first run.

After prequalifying my objects I am still unable to run my Query the second time. Any more Ideas

Quote:

quote:

Quote:

Option Explicit

Dim xlBook As excel.workbook

Private Sub cmdQryOfficer_Click()

' --- Open xl report showing Stats for Chosen Officer ---

On Error GoTo Err_Error

Dim strXlsPath As String
Dim strName As String
Dim strSheetName As String
Dim strSql As String

Dim xl As Excel.Application

Dim intCount As Integer
Dim i As Integer

Dim cboField As ComboBox

' --- Check and Create Necessary Folders ---

Set cboField = Me.cboOfficer
strXlsPath = SpecFolder(CSIDL_Personal) & "\Reports\"
strName = cboField.Column(1)

CreateFolder (strXlsPath)

Set xl = CreateObject("excel.Application")

strXlsPath = Application.CurrentProject.Path

strXlsPath = strXlsPath & "\templates\OfficerRpt.xls"
Set xlBook = xl.Workbooks.Add(strXlsPath)

xl.Visible = True
xlBook.Windows(1).Visible = True

xl.Sheets(1).Name = "Report"

' ViewCountRptsOnSchools

strSql = "select ChrSchoolName,Count(chrSchoolName) As CountVisits From View_AllSchoolVisits Where(intOfficerId=" _
  & cboOfficer & ") Group By ChrSchoolName"

strSheetName = "CountVisits"
XlsExport strSql, strSheetName

' ViewTotalTimeSpentWithSchools

strSql = "select ChrSchoolName,sum(intTimeSpent) As TotalTimeSpent from View_allSchoolVisits Where(intOfficerID=" _
  & cboOfficer & ") group by ChrSchoolName"

strSheetName = "TimeSpent"
XlsExport strSql, strSheetName

' ViewActivityAtSchool

strSql = "Select chrActivity, Count(visits.intActivityId) from view_AllSchoolVisits As Visits inner join"
strSql = strSql & " tblActivity on visits.intActivityId=tblActivity.intActivityId "
strSql = strSql & "Where (intOfficerId=" & cboOfficer & ") Group By tblActivity.chrActivity"

strSheetName = "Activity"
XlsExport strSql, strSheetName

' viewMethodOfVisit

strSql = "Select chrMethod, Count(visits.intMethodId) from view_AllSchoolVisits As Visits inner join"
strSql = strSql & " tblMethod on visits.intMethodId=tblMethod.intMethodId "
strSql = strSql & "Where (intOfficerId=" & cboOfficer & ") Group By tblMethod.chrMethod"

strSheetName = "Method"
XlsExport strSql, strSheetName

' viewFunding

strSql = "Select chrFunding, Count(visits.intFundingId) from view_AllSchoolVisits As Visits inner join"
strSql = strSql & " tblFunding on visits.intFundingId=tblFunding.intFundingId "
strSql = strSql & "Where (intOfficerId=" & cboOfficer & ") Group By tblFunding.chrFunding"

strSheetName = "Funding"
XlsExport strSql, strSheetName

' viewRoleOfVisit

strSql = "Select chrRole, Count(visits.intRoleId) from view_AllSchoolVisits As Visits inner join"
strSql = strSql & " tblRole on visits.intRoleId=tblRole.intRoleId "
strSql = strSql & "Where (intOfficerId=" & cboOfficer & ") Group By tblRole.chrRole"

strSheetName = "Role"
XlsExport strSql, strSheetName

intCount = xlBook.Sheets.Count

For i = 1 To intCount

    If xlBook.Sheets(i).Name <> "Report" Then

    xlBook.Sheets(i).Visible = False

        Else

    End If

Next i

' Front Cover Details

' Save Xls File

xlBook.Sheets("Report").Select
Range("C21:I24").Select
ActiveCell.FormulaR1C1 = "Based on Data Recorded By " & strName

strXlsPath = SpecFolder(CSIDL_Personal) & "\Reports\"
strXlsPath = strXlsPath & strName & "_" & Date & ".xls"
strXlsPath = Replace(strXlsPath, "/", "-")

  If CheckExists(strXlsPath) = -1 Then

    Kill (strXlsPath)

    xlBook.SaveAs FileName:=strXlsPath, WriteResPassword:="ch414fd"
    xl.ActiveWorkbook.Close

    Else

    xlBook.SaveAs FileName:=strXlsPath, WriteResPassword:="ch414fd"
    xl.ActiveWorkbook.Close

  End If

Set xlBook = Nothing
xl.Quit
Set xl = Nothing

' i = MsgBox("Do You Wish to Email the report", vbYesNo, "Email Report")

' If i = vbYes Then

' Else

' End If

Err_Exit:

Exit Sub

Err_Error:

MsgBox Err.Number & ", " & Err.Description, vbCritical, "Error"

Resume Err_Exit

End Sub

Private Sub XlsExport(sqlQuery As String, SheetName As String)

Dim strRange As String
Dim strChart As String
Dim intCount As Integer
Dim intRs As Integer
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset

On Error GoTo Err_Error

Set cmd = New ADODB.Command
cmd.ActiveConnection = CurrentProject.Connection
cmd.CommandType = adCmdText
cmd.CommandText = sqlQuery

Set rs = cmd.Execute

xlBook.Sheets.Add After:=xlBook.Sheets(xlBook.Sheets.Count)
intRs = rs.RecordCount
intCount = xlBook.Sheets.Count

strRange = "A1:B" & intRs
strChart = "Chart " & (intCount - 1)

xlBook.Sheets(xlBook.Sheets.Count).Cells(1, 1).CopyFromRecordset rs
xlBook.Sheets(xlBook.Sheets.Count).Name = SheetName

xlBook.Sheets("Report").Select
xlBook.ActiveSheet.ChartObjects(strChart).Activate
xlBook.ActiveChart.ChartArea.Select
    xlBook.ActiveChart.SetSourceData Source:=xlBook.Sheets(SheetName).Range(strRange), PlotBy _
        :=xlColumns

Set rs = Nothing
Set cmd = Nothing

Err_Exit:

Exit Sub

Err_Error:

MsgBox Err.Number & ", " & Err.Description, vbCritical, "Error"

Resume Err_Exit

End Sub