Ask Me Help Desk

Ask Me Help Desk (https://www.askmehelpdesk.com/forum.php)
-   Access (https://www.askmehelpdesk.com/forumdisplay.php?f=441)
-   -   Ms access automation email reports (https://www.askmehelpdesk.com/showthread.php?t=560574)

  • Mar 8, 2011, 08:39 AM
    SoyJet
    Ms access automation email reports
    Scott, You've helped me before through All Experts. Please help me now, I'm at wits end

    Need help with automating the sending of access reports at night.

    I have several BAT files that run DISCOVERER exports to excel
    I have a VBS that loops through all those exports to re-save in a compliant version
    I have a VBS that runs several access subs to update the tables with the downloaded data
    Finally, and here's where it goes awry
    I have a VBS that runs a sub to OUTPUT a report, looping filter by slsman...
    All these are bundled in a BAT so they run one after the other
    This is inside a WS to make it run in the background, under Task Scheduler, at night..

    In the VBS MIDNIGHT REPORTING, I include the Resume and Suspend for Express Click Yes.

    It works fine, except that once the first report is open and ready to send, it bombs there.. it won't pass to Outlook, maybe because it has been idle?? \

    In the VBS that calls this report sub, trying to overcome this, I included some code to open and display the inbox, but it didn't work, either..

    Here's the vbs code, followed by the access function code:

    Code:


    option explicit

    On Error resume Next

    dim objFSO
    dim objFile
    Dim Log

    dim accObj
    DIM MyDb
    dim MyArray
    dim MyModule
    Dim item


    'added this outlook section to check if this would wake it up.  if it doesn't delete this outlook section thru
    ' where it sais error logging

    Dim oOutlook
    Dim oItems
    Dim oFirst


    '  Wake Outlook up from Idle

     Set oOutlook = GetObject("Outlook.Application")
     Set oItems = oOutlook.GetNameSpace("MAPI").GetDefaultFolder(6).Items.GetFirst()
     Set oFirst = oItems.GetFirst()
     oFirst.Display
     oFirst.Close

    Set oFirst = Nothing
    Set oItems = Nothing
    Set oOutlook = Nothing



    '  Error logging

    Const ForAppending = 8
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Log = "C:\home\Network Development\Regional Assistants\BackEnds\DiscvrRepSched\reporting.log"


    '  Open Access database
    Const ERR_APP_NOTRUNNING = 429

    MyDb = "C:\home\Network Development\Regional Assistants\Daily Task Management.mdb"

      Set accObj = GetObject(MyDb, "Access.Application")
    '  If Access isn't running, create a new instance.
      If Err = ERR_APP_NOTRUNNING Then
        Set accObj= New Access.Application
            accObj.OpenCurrentDataBase MyDb
      End If



    ' ******** CHANGE TO CREATE DOUBLE ARRAYS FOR PATHS AS WELL AS DB NAMES OR SOMETHING. 
    ' ******** mAYBE A TABLE FIRST, AND FROM THERE THE ARRAY?


    MyArray = Array("ReportingDailyStats")

    'MyArray = Array("ReportingDailyStats", _
    '                "...", _
    '                )

    For each item in MyArray
    accObj.run item

    'accObj.run "ReportingDailyStats"


    Set objFile = objFSO.OpenTextFile(Log, ForAppending, True)
    If Err.Number <> 0 Then
        objFile.Writeline "Access Reporting of " & item & " failed somewhere ! " & Now _
            & " " & Err.Number & " Error Description: " & Err.Description
        Err.Clear
    Else
        objFile.Writeline "Access Reporting of " & item & " was completed " & Now
        Err.Clear
    End If

    objFile.Close

    Next


    accObj.CloseCurrentDatabase


    'objFile.Close

    ' Clear memory

    Set accObj = Nothing
    Set objFSO = Nothing
    Set objFile = Nothing

    ' ****************

    'HERE'S THE ACCESS FUNCTION:

    Option Compare Database

    Public Sub ReportingDailyStats()


    'this is the actual send access report loop
    Dim strEmail As String
    Dim rs As ADODB.Recordset
    Dim strAssignee As String
    Dim blnOK As Boolean
    Dim msg As String
    Dim strName As String
    Dim strToList As String
    blnOK = True

    ' *******CHECK HERE THE EMAILS....  IF NEED TO CHANGE... CREATE DISTRIB TABLE
    strToList = "[email protected];[email protected]"

    Set rs = New ADODB.Recordset
    rs.Open "Select DISTINCT Assignee, EmailAddress from TblAssociates where State not like 'Sears' and [Reporting State] = 'Yes'", _
        CurrentProject.Connection, adOpenKeyset, adLockOptimistic

    If rs.RecordCount > 0 Then

    ResumeClickYes
    rs.MoveFirst
    While Not rs.EOF
    strEmail = rs!emailaddress
    strAssignee = rs!Assignee
    msg = "Daily Performance Update for " & [strAssignee]

    DoCmd.OpenReport "Daily Performance Update - Use", acViewPreview, , "[Assignee] = '" & strAssignee & "'"
    DoCmd.SendObject acSendReport, , acFormatPDF, strEmail, , , msg, , False
    DoCmd.Close acReport, "Daily Performance Update - Use"

    rs.MoveNext

    Wend
    SuspendClickYes
    rs.Close
    Set rs = Nothing

    End If

    'this sends the full report to managers named in strToArray dimmed above
    ResumeClickYes
    DoCmd.SendObject acSendReport, "Daily Performance Update - Use", acFormatPDF, strToList, , , "Daily Performance Update", _
        "Please let me know if you see any inconsistencies, or the update dates do not fall within the last 12 hours.", 0
    DoCmd.Close acReport, "Daily Performance Update - Use"
    SuspendClickYes

    'this is for saving the report, if preferred
    'DoCmd.OutputTo acOutputReport, "Daily Performance Update - TESTJET", acFormatPDF, _
        "C:\home\Network Development\Regional Assistants\BackEnds\DiscvrRepSched\EMAIL\" _
            & "Daily Performance Update" & Format(Date, ShortDate) & ".pdf"

    Exit_ReportingDailyStats:
        Exit Sub

    Err_ReportingDailyStats:
        MsgBox Error$ & ": " & Err.Description
        SuspendClickYes
        Resume Exit_ReportingDailyStats

    End Sub


    ANY HELP IS GREATLY APPRECIATED!! I've got other reports that I'd like to automate once this one is working...

    Thanks! Be my savior!

    Jet

  • All times are GMT -7. The time now is 10:00 AM.