Thanks for the reply. Here is the function definition, it's really long, plus
it calls many other functions inside it. The macro definition is provided too.
--macro definition
macro name: daily
action: RunCode
Arguments: Automate()
---function definition
Public Function Automate()
'On Error GoTo Err_Automate
On Error Resume Next
Dim ErrorDirectory As String
Dim fs As Scripting.FileSystemObject
Dim fsFile As Scripting.File
Dim fsFolder As Scripting.Folder
Dim FileforWriting As TextStream
Dim i As Integer
Dim EmailError As Integer
Dim ErrorMessage As String
Dim ErrorModuleBeg As String
Dim ErrorModuleEnd As String
ErrorDirectory = "C:\SQLReportsError\"
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(ErrorDirectory) Then
Set fsFolder = fs.CreateFolder(ErrorDirectory)
fsFolder.CreateTextFile ("ErrorReport.txt")
Else
If Not fs.FileExists(ErrorDirectory & "ErrorReport.txt") Then
Set fsFolder = fs.GetFolder(ErrorDirectory)
fsFolder.CreateTextFile ("ErrorReport.txt")
End If
End If
Set FileforWriting = fs.OpenTextFile(ErrorDirectory & "ErrorReport.txt",
ForAppending)
FileforWriting.WriteLine (date)
FileforWriting.Close
DoCmd.SetWarnings False
Dim cnn As New ADODB.Connection
Dim cnnASD As New ADODB.Connection
Dim rsGrp As New ADODB.Recordset
Dim rsRpt As New ADODB.Recordset
Dim strSQL As String
Dim strChartDays As String
Dim intGrp, intRpt As Integer
Dim prtDefault As Printer
Dim outputTo, outputPrinter As String
'Dim iUserId As Integer
Dim iUserId As Long
Dim iBatchID As Integer
Dim strEmail As String
Dim strEmailPrefix As String
cnn.Open gstrCommonConnectionString ' was gstrConnectionString
outputTo = cns.outputToPrinter
cnnASD.Open gstrASDConnectionString
rsGrp.Open ("select 1 + IsNull(Max(BatchID), 0) as iBatch From LogPrint"),
cnnASD
iBatchID = rsGrp!iBatch
rsGrp.Close
strSQL = "SELECT intPageID,DRUserId, strChartDays, strPageTitle,
strOfficePrinter, strPrintDays, ysnPrint " & _
"FROM DailyReportGroups WHERE ysnActive = 1 " & _
"AND (strPrintDays = '0' OR CHARINDEX('" & CStr(Weekday(date)) &
"',strPrintDays) > 0) " & _
"ORDER BY intPrintOrder"
rsGrp.Open strSQL, cnn
If Not (rsGrp.BOF And rsGrp.EOF) Then
rsGrp.MoveFirst
Do While Not rsGrp.EOF
'charts
If Not IsNull(rsGrp!strChartDays) Then
strChartDays = rsGrp!strChartDays
'uncomment the following line temporary override to print the
charts EVERY DAY
'strChartDays = CStr(Weekday(Date))
If Len(strChartDays) > 0 Then
If InStr(strChartDays, CStr(Weekday(date))) > 0 Then
If Not IsNull(rsGrp!DRUserId) Then
iUserId = rsGrp!DRUserId
'If iUserId = 5 Then
modFunctions.SelectPrinter
(rsGrp!strOfficePrinter)
'modFunctions.SelectPrinter "Laser Near"
'MsgBox Application.Printer.DeviceName
'If Application.Printer = "Laser Near" Then
' Set Application.Printer =
Application.Printers("913")
' outputPrinter = "913"
'End If
cnnASD.Execute "insert into
aquastardata..logPrint (Ranat,BatchId,ProcessId,Descr,StepId) values
(GetDate()," & CStr(iBatchID) & ",1000,'User# Graphs: " & CStr(iUserId) &
"',0)"
gsheader1 = rsGrp!strpageTitle
'070109 JZ Comment out for testing
DoCmd.OpenReport "rptCover"
Form_frmInventoryAgeLot.PrintGraphs iUserId, False
'End If
End If
End If
End If
Else
strSQL = "SELECT RepDesID FROM DailyReports WHERE intPageID = "
& rsGrp!intPageId & _
" AND ysnActive = 1 AND (strPrintDays = '0' OR
CHARINDEX('" & CStr(Weekday(date)) & "',strPrintDays) > 0) " & _
"ORDER BY intPrintOrder"
'BugzID 5438: Correct Printing of report headers << Required
more work, via bugzID 6847
'moved the set printer line here
outputPrinter = rsGrp!strOfficePrinter
strEmailPrefix = ""
If Len(outputPrinter) > 5 Then
strEmail = Right(outputPrinter, Len(outputPrinter) - 6)
strEmailPrefix = Left(outputPrinter, 6)
End If
If strEmailPrefix = "email:" Then
outputTo = cns.outputToEmail
outputPrinter = strEmail
Else
outputTo = cns.outputToPrinter
End If
rsRpt.Open strSQL, cnn
If rsGrp!ysnPrint And Not rsRpt.EOF And strEmailPrefix <>
"email:" Then 'no point printing a cover sheet unless something to print
gsheader1 = rsGrp!strpageTitle
'BugzID 6847: Correct printing of report cover pages
SetPrinter (outputPrinter)
'070109 JZ Comment out for testing
'DoCmd.OpenReport "rptCover"
End If
If Not (rsRpt.BOF And rsRpt.EOF) Then
rsRpt.MoveFirst
i = 1
Do While Not rsRpt.EOF
cnnASD.Execute "insert into aquastardata..logPrint
(Ranat,BatchId,ProcessId,Descr,StepId) values (GetDate()," & CStr(iBatchID) &
",1001,'ODR#: " & rsRpt!RepDesID & "'," & CStr(i) & ")"
' '070109 JZ Comment out for testing
ODR rsRpt!RepDesID, outputTo, outputPrinter
iUserId = rsRpt!RepDesID
i = i + 1
rsRpt.MoveNext
Loop
End If
rsRpt.Close
End If
rsGrp.MoveNext
Loop
End If
cnnASD.Execute "insert into aquastardata..logPrint
(Ranat,BatchId,ProcessId,Descr,StepId) values (GetDate()," & CStr(iBatchID) &
",1002,'Printing Completed!',0)"
rsGrp.Close
cnn.Close
Set rsGrp = Nothing
Set rsRpt = Nothing
Set cnn = Nothing
cnnASD.Close
Set cnnASD = Nothing
'MUST COMMENT OUT THE FOLLOWING LINE BEFORE PROMOTING
''''''''Exit Function
gstrCurProductCat = ""
gstrCurOrigin = ""
gstrCurGLCode = ""
gstrCurSalesPerson = ""
gstrCurCustShipToTerritory = ""
gstrCurCustType = ""
gstrCurState = ""
gintInvGrp = 0
gintWareAllow = 1
gintSample = 1
glngCurOffice = 8
gstrCurChannel = "0"
gstrDailyReport = ""
'************** INTRANET SALES REPORTS *****************************
ErrorModuleBeg = "Intranet by Managers Reports"
'******* FOR Bob Hooey ********
i = IntranetbyManagers()
'i = -1 if function ran correctly or 0 if not
If i = 0 Then
MsgBox "The Intranet Sales Reports by Manager did not run correctly."
End If
ErrorModuleEnd = "Intranet by Managers End Reports"
ErrorModuleBeg = "Intranet by Sales Person Reports"
'******* BY SalesPerson ********
'Run Function to make reports for each SalesPerson
i = IntranetbySalesPerson()
'i = -1 if function ran correctly or 0 if not
If i = 0 Then
MsgBox "The Intranet Sales Reports by SalesPerson did not run
correctly."
End If
ErrorModuleEnd = "Intranet by Sales Person End Reports"
'******* BY Region ********
ErrorModuleBeg = "Intranet by Division Reports"
i = IntranetbyOffice()
'i = -1 if function ran correctly or 0 if not
If i = 0 Then
MsgBox "The Intranet Sales Reports by Division did not run correctly."
End If
ErrorModuleEnd = "Intranet by Division End Reports"
'******* ITEM LIST WEB PAGES ********
ErrorModuleBeg = "Intranet Numeric Item List"
'07-03-08 JZ Point to new location to decomission proxy
'DoCmd.outputTo acOutputReport, "rptIntranetNumericItemList",
acFormatHTML, "\\AsseaProxy\pages\Reports\" & "NumericItemList.HTML", 0
'070109 JZ Comment out for testing
'DoCmd.outputTo acOutputReport, "rptIntranetNumericItemList",
acFormatHTML, "\\Naseasps10\pages\Reports\" & "NumericItemList.HTML", 0
ErrorModuleEnd = "Intranet Numeric Item List End"
ErrorModuleBeg = "Excel Duty PO's"
' ******** Excel DUTY PO'S Dennis S. 8/25/04 *********
' China
sSQLSource = "EXEC prMarginDutyReports 'CN', '2004-04-29','2004-07-17'"
'070109 JZ Comment out for testing
'DoCmd.outputTo acOutputStoredProcedure, sSQLSource, acFormatXLS,
"\\Asseafs\Common\Dennis Spomer\DutyPO\DutyPOChina.xls", 0
' Thailand
sSQLSource = "EXEC prMarginDutyReports 'TH', '2004-04-29','2004-08-04'"
'070109 JZ Comment out for testing
'DoCmd.outputTo acOutputStoredProcedure, sSQLSource, acFormatXLS,
"\\Asseafs\Common\Dennis Spomer\DutyPO\DutyPOThailand.xls", 0
' India
sSQLSource = "EXEC prMarginDutyReports 'IN', '2004-04-29','2004-08-04'"
'070109 JZ Comment out for testing
'DoCmd.outputTo acOutputStoredProcedure, sSQLSource, acFormatXLS,
"\\Asseafs\Common\Dennis Spomer\DutyPO\DutyPOIndia.xls", 0
ErrorModuleEnd = "Excel Duty Po's End"
'************** Email SALES REPORTS NEW AS OF
7/21/04*****************************
ErrorModuleBeg = "Email Sales Reports"
EmailError = 1
' EmailError = EmailReports()
'0 = error, 1= OK
If EmailError = 0 Then
MsgBox "There was an error delivering the Email Reports."
End If
ErrorModuleBeg = "Intranet by Sales Person Reports"
' ********* Monthly Reports Offices and Salespersons - Mark Lawrence
****************
' ********* Run on the day after Closing Schedule
************************************
ErrorModuleBeg = "Monthly Reports Divisions and Salespersons Reports"
If Not (IsNull(DLookup("StartDate", "tblMonth", "StartDate = '" & date &
"'"))) Then
i = IntranetbyMonthlyOffice()
'i = -1 if function ran correctly or 0 if not
If i = 0 Then
MsgBox "The Intranet Sales Reports by Monthly Division did not
run correctly."
End If
i = IntranetbyMonthlySalesPerson()
'i = -1 if function ran correctly or 0 if not
If i = 0 Then
MsgBox "The Intranet Sales Reports by Monthly Salesperson did
not run correctly."
End If
End If
ErrorModuleEnd = "Monthly Reports Divisions and Salespersons Reports End"
Exit_Automate:
DoCmd.SetWarnings True
Set fsFolder = Nothing
Set FileforWriting = Nothing
Set fs = Nothing
Exit Function
Err_Automate:
Set FileforWriting = fs.OpenTextFile(ErrorDirectory & "ErrorReport.txt",
ForAppending)
FileforWriting.WriteLine ("")
FileforWriting.WriteLine ("NEW ERROR: on " & date & Chr(10))
FileforWriting.WriteLine ("")
FileforWriting.WriteLine ("Error Occured: " & Err.Number & " " &
Err.Description)
ErrorMessage = " Error Delivering Report on " & date & Chr(10)
ErrorMessage = ErrorMessage & "Last SQL Statement = " & sSQLSource &
Chr(10)
ErrorMessage = ErrorMessage & "Last Report Header = " & gsheader1 &
Chr(10)
ErrorMessage = ErrorMessage & "Beginning Function = " & sSQLSource &
Chr(10)
ErrorMessage = ErrorMessage & "Ending Function = " & gsheader1 & Chr(10)
FileforWriting.Write (ErrorMessage)
FileforWriting.WriteLine ("")
FileforWriting.Close
Resume Next
End Function
