任务计划程序将无法运行宏 [英] Task Scheduler will not run macro

问题描述

我正在使用Access 2013，并且已设置要通过任务计划程序调用的宏.通过任务计划程序打开时，我目前收到错误2001.我的数据库已设置为受信任的位置，但是宏将无法完成.我正在以我的登录名运行.所有其他宏都可以正常工作.如果我手动打开访问权限以运行宏，它将运行正常且没有任何错误.我正在一个宏中更新两个电子表格，所以不确定是否与此有关.这是我的宏在下面调用的函数:

I am using access 2013 and have setup a macro to be called via the task scheduler. I am currently getting the the error 2001 when opened via the task scheduler. My database has been set as a trusted location but the macro will not complete. I am running under my login. All other macros work perfectly. If I manually open access to run the macro It runs just fine without any errors. I am updating two spreadsheets in this one macro so not sure if this has anything to do with it. Here is the function my macro calls below:

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 ("[e-mail]")

        .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`

推荐答案

多次尝试后，我只能通过创建一个计划任务来运行此任务，该任务运行一个宏，该宏打开一个计时器间隔设置为10000的表单，以检查时间，如果需要的话，请运行功能.

After multiple attempts I was only able to get this working by creating a scheduled task that runs a macro that opens a form with the timer interval set to 10000 that checks the time and if it is a certain time run the functions.

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

这篇关于任务计划程序将无法运行宏的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！