Question

我正在使用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`

Answer 1

经过多次尝试后，我只能通过创建一个运行宏的计划任务来启动此工作，该宏打开一个定时器间隔设置为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

任务计划程序不会运行宏

1 个答案: