I am using excel 2003 and accedd 2003. I my last go around I only gave a smippet of the code I am using. Today I will give all the code. I am getting an Error 9 subscript out of range. This seems to happen when I have two spreadsheets open at the same time. I don't know if this is causing the error. When I am getting the error 9 it is not letting me close the second workbook and save it. Any help is appreciated.
Code:
Private Sub cmdRunPrintSets_Click()
Dim strSQL As String
Dim rstPQ As Recordset
Dim rstRpts As Recordset
Dim iQ As Integer
Dim iRpt As Integer
Dim strPathName As String
Dim strSrcPath As String
Dim strSaveName As String
Dim strNewWkbk As String
Dim iPageCnt As Integer
Dim iRw As Integer
Dim strMenuItm As String
Dim iPgBrkCnt As Integer
'Dim tabnm()
DoCmd.SetWarnings False
' Create Excel Instance
Call XLCreate ' New Excel Instance - goXL
If gbXLPresent = True Then ' If Excel installed
' *** Get Print Queues to Process
Set rstPQ = CurrentDb.OpenRecordset("PROC_PrntQ_Detail", dbOpenTable)
If Not rstPQ.EOF Then
With rstPQ
.MoveLast
.MoveFirst
End With
For iQ = 1 To rstPQ.RecordCount
' Set Package Save Name
strSrcPath = "\\salmfilesvr1\Public\Client Services\AutoRpts\_Rpts\" & (GetCompany(rstPQ![clntid])) & "\" & (rstPQ![uci]) & "\"
strPathName = "\\salmfilesvr1\Public\Client Services\AutoRpts\_RptSets\" & (GetCompany(rstPQ![clntid])) & "\" & (rstPQ![uci]) & "\" & (GetMonthPath(rstPQ![prptpd]))
strSaveName = (rstPQ![deltypedsc]) & "_" & (rstPQ![uci]) & "_" & (rstPQ![mon_shnm]) & "_" & (rstPQ![yr]) & "_" & (FixDesc(rstPQ![deltoname])) & "_" & (rstPQ![prntqid]) & ".xls"
' Get reports for this queue
With DoCmd
.OpenQuery "000_ClearTableOfContents"
End With
strSQL = "INSERT INTO PROC_TableOfContents (ord,rpttitle,rptsubtitle,tabnm,fname ) " & _
"SELECT pr.ord,rq.rpttitle,rq.rptsubtitle,rq.tabnm,rq.rptname " & _
"FROM dbo_prntq_rpts pr " & _
"INNER JOIN dbo_Rpts_RptsQueued rq ON pr.rptqid = rq.qrptid " & _
"WHERE ((pr.prntqid=" & (rstPQ![prntqid]) & ") AND (rq.qrptpd = " & (rstPQ![prptpd]) & ")) " & _
"ORDER BY pr.ord;"
CurrentDb.Execute strSQL
' Build Report Package
' Open Cover Template
goXL.Workbooks.Open Filename:="\\salmfilesvr1\Public\Client Services\AutoRpts\Templates\Cover.xlt"
strNewWkbk = goXL.ActiveWorkbook.Name
With goXL.Sheets("Cover")
.Cells(8, 1).Value = GetClntName(rstPQ![clntid])
.Cells(10, 1).Value = (rstPQ![prnttitle])
.Cells(11, 1).Value = (rstPQ![prntsubtitle])
.Cells(13, 1).Value = "'" & (GetFullMonthName(rstPQ![prptpd]))
.Name = (rstPQ![uci])
End With
' Add Table of Contents
With goXL
.Workbooks.Open Filename:="\\salmfilesvr1\Public\Client Services\AutoRpts\Templates\TableOfContents.xlt"
.Sheets("Table of Contents").Copy After:=Workbooks(strNewWkbk).Worksheets(1)
.Workbooks(2).Close SaveChanges:=False
End With
' Get list of reports for this print set
strSQL = "SELECT ord,tabnm,fname FROM PROC_TableOfContents ORDER BY ord;"
Set rstRpts = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If Not rstRpts.EOF Then
With rstRpts
.MoveLast
.MoveFirst
End With
For iRpt = 1 To rstRpts.RecordCount ' Cycle through reports
goXL.Workbooks.Open Filename:=(strSrcPath) & (rstRpts![fname]) ' Open Report
' *** Get number of pages and update list
' Count Pages in Report
'orig code
'iPageCnt = ActiveSheet.HPageBreaks.Count + 1
iPageCnt = goXL.ActiveSheet.HPageBreaks.Count + 1 ' added 3/20/2013
' Update with Pages
strSQL = "UPDATE PROC_TableOfContents SET pgs = " & (iPageCnt) & " WHERE ord = " & (rstRpts![ord]) & ";"
CurrentDb.Execute strSQL
' Copy to print set and close
With goXL
'orig code
'.Sheets("" & (rstRpts![tabnm]) & "").Copy After:=Workbooks(strNewWkbk).Worksheets((iRpt + 2))
[Blue] .Sheets("" & (rstRpts![tabnm]) & "").Copy After:=.Workbooks(strNewWkbk).Worksheets((iRpt + 2)) 'added 3/20/2013 [/Blue]
'orig code
'.Workbooks(2).Close SaveChanges:=False
.ActiveWorkbook.Close SaveChanges:=False 'added 3/20/2013
End With
rstRpts.MoveNext
Next iRpt
End If
rstRpts.Close
Set rstRpts = Nothing
' Populate Table of Contents
goXL.Sheets("Table of Contents").Select
' Add First 3 Sheets (Cover, Table of Contents, Glossary)
With goXL.ActiveSheet
.Cells(4, 1).Value = "Cover Page"
.Cells(4, 15).Value = 1
.Cells(5, 1).Value = "Table of Contents"
.Cells(5, 15).Value = 2
.Cells(5, 27).Value = 1
.Cells(6, 1).Value = "Glossary"
.Cells(6, 27).Value = 1
End With
' Add Additionaly Sheets
iRw = 7
iPgBrkCnt = 1
strSQL = "SELECT rpttitle,rptsubtitle,tabnm,pgs FROM PROC_TableOfContents ORDER BY ord;"
Set rstRpts = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If Not rstRpts.EOF Then
With rstRpts
.MoveLast
.MoveFirst
End With
For iRpt = 1 To rstRpts.RecordCount ' Cycle through reports
' For Excel File Types include Tab Name
If ((rstPQ![deltypedsc] = "EMAIL") Or (rstPQ![deltypedsc] = "FTP") Or (rstPQ![deltypedsc] = "CDROM") Or (rstPQ![deltypedsc] = "INFOEDGE")) Then
strMenuItm = (rstRpts![rpttitle]) & " - " & (rstRpts![rptsubtitle]) & " (" & (rstRpts![tabnm]) & ")"
Else ' For Non File Types, no Tab Name
strMenuItm = (rstRpts![rpttitle]) & " - " & (rstRpts![rptsubtitle])
End If
With goXL.ActiveSheet
.Cells(iRw, 1).Value = strMenuItm
.Cells(iRw, 27).Value = (rstRpts![pgs])
End With
' Advance to next report
iRw = iRw + 1
iPgBrkCnt = iPgBrkCnt + 1
If (iPgBrkCnt > 33) Then ' Insert Page Break every 79 lines
With goXL
.Rows("" & (iRw) & ":" & (iRw) & "").Select
.ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End With
iPgBrkCnt = 1
End If
rstRpts.MoveNext
Next iRpt
' Delete Extra Rows in Table of Contents
With goXL
.Rows("" & (iRw) & ":250").Select
.Selection.Delete Shift:=xlUp
.Cells(4, 1).Select
End With
' Set Page Count for Table of Contents
iPageCnt = (ActiveSheet.HPageBreaks.Count) + 1
ActiveSheet.Cells(5, 27).Value = (iPageCnt)
End If
rstRpts.Close
Set rstRpts = Nothing
' Save and Close Print Set
With goXL
.Sheets("Table of Contents").Cells(4, 1).Select
.Sheets("" & (rstPQ![uci]) & "").Select
.DisplayAlerts = False
.ActiveWorkbook.SaveAs Filename:=(strPathName) & (strSaveName)
.Workbooks.Close
.DisplayAlerts = True
End With
' Flag Print Set as run and save file name
strSQL = "UPDATE dbo_Rpts_PrntSetQueue " & _
"SET runflag = 1" & _
",filenm = '" & (strSaveName) & "' " & _
"WHERE (prntqid = " & (rstPQ![prntqid]) & ");"
CurrentDb.Execute strSQL
' Advance to next queue item
rstPQ.MoveNext
Next iQ
End If
rstPQ.Close
Set rstPQ = Nothing
' Kill Excel
Call XLKill
' Clear Print Set List and refresh listbox
With DoCmd
.OpenQuery "000_ClearPrintQProc"
.OpenQuery "000_ClearPrntQDetail"
End With
With Me.lstPrintSets
.SetFocus
.Requery
End With
Else
MsgBox "ERROR: COULD NOT OPEN EXCEL.", , "BOO!!!"
End If
DoCmd.SetWarnings True
MsgBox "Print Sets Created!", , "All Done."
End Sub