我正在使用Access 2013并设置了一个通过任务调度程序调用的宏。我正在通过任务调度程序打开时收到错误2001。我的数据库已设置为受信任位置,但宏将无法完成。我正在登录下运行。所有其他宏都可以正常工作。如果我手动打开访问运行宏它运行正常没有任何错误。我正在更新这个宏中的两个电子表格,所以不确定这是否与它有任何关系。这是我的宏在下面调用的函数:
Function SendDailyInvoiceReport()
Dim myOutlook As outlook.Application
Dim filename As String
filename = "M:\Shared Documents\Invoices\Invoicing Reports\DAILY\Daily_Clients_Invoiced_" & Format(DateAdd("d", -1, Now()), "mm_dd_yyyy") & ".xlsx"
filename2 = "M:\Shared Documents\Invoices\Invoicing Reports\Daily\MonthToDate\Clients_Invoiced_Month_To_Date_" & Month(Now()) & "_" & Year(Now()) & ".xlsx"
DoCmd.OpenQuery "all invoices"
DoCmd.OutputTo acOutputQuery, "qryDAILYINVOICEREPORT", acFormatXLSX, filename, False
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ws As Worksheet
Set xlApp = New Excel.Application
With xlApp
.Visible = False
Set xlWB = .Workbooks.Open(filename, , False)
Set ws = .Worksheets("qryDAILYINVOICEREPORT")
End With
Dim LR As Long
Dim TotalBilled As Long
Dim TotalClients As Long
LR = ws.Range("C" & ws.Rows.count).End(xlUp).Row
ws.Range("C" & LR + 1).Value = "TOTAL # OF INVOICES:"
ws.Range("C" & LR + 1).Cells.Interior.ColorIndex = 6
LR = ws.Range("D" & ws.Rows.count).End(xlUp).Row
ws.Range("D" & LR + 1).Formula = "=COUNT(D2:D" & LR & ")"
TotalBilled = ws.Range("D" & ws.Rows.count).End(xlUp).Value
ws.Range("D" & LR + 1).Cells.Interior.ColorIndex = 6
LR = ws.Range("E" & ws.Rows.count).End(xlUp).Row
ws.Range("E" & LR + 1).Value = "TOTAL AMT INVOICED:"
ws.Range("E" & LR + 1).Cells.Interior.ColorIndex = 6
LR = ws.Range("F" & ws.Rows.count).End(xlUp).Row
ws.Range("F" & LR + 1).Formula = "=SUM(F2:F" & LR & ")"
TotalClients = ws.Range("F" & ws.Rows.count).End(xlUp).Value
ws.Range("F" & LR + 1).Cells.Interior.ColorIndex = 6
xlApp.DisplayAlerts = False
xlWB.SaveAs (filename)
xlWB.Close
xlApp.Quit
If Format(Now(), "MM/dd/yyyy") <> DateSerial(Year(Now()), Month(Now()), 1) Then
DoCmd.OutputTo acOutputQuery, "qryMONTHTODATEINVOICED", acFormatXLSX, filename2, False
Set xlApp = New Excel.Application
With xlApp
.Visible = False
Set xlWB = .Workbooks.Open(filename2, , False)
Set ws = .Worksheets("qryMONTHTODATEINVOICED")
End With
LR = ws.Range("C" & ws.Rows.count).End(xlUp).Row
ws.Range("C" & LR + 1).Value = "TOTAL # OF INVOICES:"
ws.Range("C" & LR + 1).Cells.Interior.ColorIndex = 6
LR = ws.Range("D" & ws.Rows.count).End(xlUp).Row
ws.Range("D" & LR + 1).Formula = "=COUNT(D2:D" & LR & ")"
TotalBilled = ws.Range("D" & ws.Rows.count).End(xlUp).Value
ws.Range("D" & LR + 1).Cells.Interior.ColorIndex = 6
LR = ws.Range("E" & ws.Rows.count).End(xlUp).Row
ws.Range("E" & LR + 1).Value = "TOTAL AMT INVOICED:"
ws.Range("E" & LR + 1).Cells.Interior.ColorIndex = 6
LR = ws.Range("F" & ws.Rows.count).End(xlUp).Row
ws.Range("F" & LR + 1).Formula = "=SUM(F2:F" & LR & ")"
TotalClients = ws.Range("F" & ws.Rows.count).End(xlUp).Value
ws.Range("F" & LR + 1).Cells.Interior.ColorIndex = 6
xlApp.DisplayAlerts = False
xlWB.SaveAs (filename2)
xlWB.Close
xlApp.Quit
End If
Set myOutlook = CreateObject("Outlook.Application")
Dim newEmail As outlook.MailItem
Set newEmail = myOutlook.CreateItem(olMailItem)
Dim myAttachments As outlook.Attachments
Set myAttachments = newEmail.Attachments
With newEmail
.Recipients.Add ("test@test.ORG")
.Subject = "--- SYSTEM FUNCTION --- Daily Clients Invoiced in System"
.Body = "Daily Clients Invoiced in System for " & Format(DateAdd("d", -1, Now()), "mm_dd_yyyy") & ""
End With
myAttachments.Add filename, olByValue
myAttachments.Add filename2, olByValue
newEmail.Send
Set newEmail = Nothing
Set myAttachments = Nothing
Set myOutlook = Nothing
Dim oServ As Object
Dim cProc As Variant
Dim oProc As Object
Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
For Each oProc In cProc
'Rename EXCEL.EXE in the line below with the process that you need to Terminate.
'NOTE: It is 'case sensitive
If oProc.Name = "EXCEL.EXE" Then
errReturnCode = oProc.Terminate()
End If
Next
End Function`
答案 0 :(得分:0)
经过多次尝试后,我只能通过创建一个运行宏的计划任务来启动此工作,该宏打开一个定时器间隔设置为10000的表单,该表单检查时间以及是否在特定时间运行这些函数。 / p>
Private Sub Form_Timer()
If TimeValue(Now()) > #7:00:00 AM# Then
Me.TimerInterval = 0
Call SendDailyInvoiceReport
Call SendDailyClientsMailReport
Call SendMonthlyClientsMailReport
Call SendYearlyClientsMailReport
DoCmd.Quit
End If
End Sub