Monday, 2 September 2013

VBA Modules: Outlook/Access/Excel: modProcedures v2.14

Read this for full information on these modules

One major down side of the OL_BPMProcess and modAppsFirefox routines was that they locked up the Outlook session while they're running.  This module came about because I was fed up of losing Outlook for an entire Monday while it was busy waiting to download huge CSV files, particularly as the routines would invariably get stuck somewhere random and unexpected and I'd have to set them going again on Monday morning.  Storing the URL and other variables from the email triggers allows me to move on, and pick up those routines where they left off, much later on, when it's more convenient for me.

A few tweaks to the other modules have allowed me to force all downloads to complete during weekends and evenings (my routines usually run on Sundays), but to never wait for too long during business hours (in case something got stuck and I have to fix an issue on Monday).  Manually running the procedures doesn't invoke the same protections, so I can still consciously forego Outlook during the day if I want to run these saved procedures, or I can just wait until I leave the office at night or go on lunch.

Firefox (for me) will only download a maximum of 6 simultaneous streams so there are protections built into modFirefox for that too.  Rather than start downloading the file, store the Excel or Access procedure and pick those up later when the file has downloaded, it just stores the Download procedure for triggering later on.

When the procedure is running it updates the worksheet to "In Progress" then to "OK" when completed.  (You can choose to rerun Failed procedures, but it's not really recommended, owing to the way the routines are stored and will run -- if it fails once it'll usually fail again.  I usually delete all the procedures from the file once a week just for good housekeeping.)

This module should be added to an Excel workbook with sheets named Excel, Access, and Download with the appropriate column headings in place:

mpTimestamp mpURL mpDownloadingFile mpMoveToFile mpPathFile mpMacro rResult rTimestamp
mpTimestamp mpURL mpDownloadingFile mpMoveToFile mpPathFile mpMacro rResult rTimestamp
mpTimestamp mpURL mpApp mpMoveToFile mpPathFile mpMacro rResult rTimestamp

'v2.14 2013-12-02 13:05

' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   DGF Help Contact: see BPMHelpContact module

' modProcedures
'   mp_Procedure_Store: stores list of procedures to be run later, prevents
'   indefinite hangs when downloading large files from Outlook.
'   mp_Run_Procedures: runs stored list of procedures sequentially (or just one)

' Additional modules required:
'   modAppsOffice
'  [automation requires modAppsFireFox v3.00 and OL_BPMprocess v6.00, but not used here]

' Additional References required:
'   Microsoft Excel Object Library

' External applications required:
'   Microsoft Outlook   (for automation)
'   Microsoft Access    (for Access functions)
'   Microsoft Excel     (for Excel functions)

'   v2.14   mpDefaultStoreWorkbook changed to C:\SHARES\ as more robust than UNC
'   v2.13   mp_Run_Procedures: recalcs after each item is run
'   v2.12   mp_Run_Procedures: bugfix, resets mpApp on Downloads sheet
'   v2.11   mp_Run_Procedures: bugfix, doesn't run Excel/Access if nothing to do
'   v2.10   mpXLapp, prevents conflict with modAppsOffice
'   v2.09   mp_Run_Procedures: bugfix prevents WB.Open Read-Only
'   v2.08   mp_Procedure_Store: bugfix prevents WB.Open Read-Only
'   v2.07   mp_Procedure_Store: bugfix prevents looping for Download proc
'   v2.06   mp_Procedure: bugfixes
'   v2.05   mp_Procedure_Store: bugfix for Downloads store
'   v2.04   mp_Run_Procedures: will Download then run relevant App procedure
'   v2.03   mp_Procedure: bugfix if mpDownloadedFile not found
'   v2.02   mp_Procedure_Store: bugfix
'   v2.01   mp_Procedure_Store: bugfix
'   v2.00   mp_Procedure_Store now stores URL and allows queued Downloads
'   v1.01   errorhandlers, bugfix in mp_run_Procedures
'   v1.00   mp_Procedure_Store, mp_Run_Procedures, mp_Procedure

Option Explicit

Private mpXLapp As Excel.Application  '2.10 bugfix prevents issues with modAppsOffice XLapp

Private Const mpDefaultStoreWorkbook As String = "C:\SHARES\VS\ProcStore.xlsb"  'v2.13
'can specify a different WB when storing procedures

Public Enum mpApps
'v2.00 2013-08-27 13:05
'sheet number matched to each application type
    mpExcel = 1
    mpAccess = 2
    mpDownload = 3  'v2.00
End Enum

Function mp_Procedure_Store(ByVal mpURL As String, ByVal mpDownloadingFile As String, ByVal mpMoveToFile As String _
    , ByVal mpApp As mpApps, ByRef mpPathFile As String, Optional ByVal mpMacro As String _
    , Optional ByVal mpProceduresWorkbook As String = mpDefaultStoreWorkbook) As Boolean
'v2.08 2013-09-16 13:05
'runs Excel, opens mpProceduresWorkbook, records downloading filename and procedure details for later

' Store Excel procedure:
'   mp_Procedure_Store "", "C:\Users\bpmgb\Downloads\downloadingfile.xls", "C:\Users\bpmgb\Downloads\Downloaded File.xls", mpExcel, "C:\Users\bpmgb\Downloads\", "runtest.xlsm", ""
' Store Access procedure:
'   mp_Procedure_Store "", "C:\Users\bpmgb\Downloads\downloadingfile.xls", "C:\Users\bpmgb\Downloads\Downloaded File.csv", mpAccess, "C:\Users\bpmgb\Downloads\", "runtest.accdb", "runtest"
' Store Download procedure:  mpDownloadingFile = "" qualifies
'   mp_Procedure_Store "", "", "C:\Users\bpmgb\Downloads\Downloaded File.xls", mpExcel, "C:\Users\bpmgb\Downloads\", "runtest.xlsm", ""

mp_Procedure_Store = True

Dim WB As Excel.Workbook, pwSheet As Excel.Worksheet, pwRow As Excel.Range
Dim rTimestamp As Excel.Range, rDownloadingFile As Excel.Range, rMoveToFile As Excel.Range _
    , rPathFile As Excel.Range, rMacro As Excel.Range, rDLfiles As Excel.Range _
    , rURL As Excel.Range, rApp As Excel.Range, a As Byte

'run Excel (or use this Excel session for testing)
Dim mpNative As Boolean
On Error Resume Next
If UCase(ThisWorkbook.FullName) <> UCase(mpProceduresWorkbook) Then  'v2.08 stops looping
    Set mpXLapp = XLlaunch(True, False)
    Set mpXLapp = Application
End If
On Error GoTo 0

With mpXLapp
    .DisplayAlerts = False

'open WB (if not open), store details for processing later
    If mpXLapp <> Application Then
        Set WB = .Workbooks.Open(mpProceduresWorkbook)
    If UCase(ThisWorkbook.FullName) = UCase(mpProceduresWorkbook) _
    Then Set WB = ThisWorkbook _
    Else: Set WB = .Workbooks.Open(mpProceduresWorkbook)
    End If
    With WB
        If mpApp <> mpDownload And mpDownloadingFile <> "" Then  'v2.07 bugfix, doesn't loop
        'check this file is not already being downloaded on Excel and Access sheets
            For a = mpApps.mpExcel To mpApps.mpAccess
                Set pwSheet = .Sheets(a)
                With pwSheet
                    Set rDLfiles = .Columns(mpXLapp.Match("mpDownloadingFile", .Rows(1), 0))  'v2.01
                    If mpXLapp.CountIf(rDLfiles, mpDownloadingFile) > 0 Then
                    'error: this mpDownloadingFile file is already being used for another procedure?
                    'store this procedure to try downloading it again later from source URL
                        mp_Procedure_Store mpURL, "", mpMoveToFile, mpApp, mpPathFile, mpMacro, mpProceduresWorkbook
                        GoTo CleanUp
                    End If
                End With
            Next a
        End If
        'this is a new file being downloaded / to be downloaded
        If mpDownloadingFile = "" Then Set pwSheet = .Sheets(3) Else Set pwSheet = .Sheets(mpApp)  'v2.05
        With pwSheet
            Set pwRow = .Rows(mpXLapp.CountA(.Columns(1)) + 1)
            Set rTimestamp = pwRow.Columns(mpXLapp.Match("mpTimestamp", .Rows(1), 0))
                rTimestamp.Value = Now()
            Set rURL = pwRow.Columns(mpXLapp.Match("mpURL", .Rows(1), 0))
                rURL.Value = mpURL
        If mpDownloadingFile = "" Then   'v2.05 'store app, only for Download sheet
            Set rApp = pwRow.Columns(mpXLapp.Match("mpApp", .Rows(1), 0))
                rApp.Value = mpApp
        Else  'store downloading file name, not for Download sheet
            Set rDownloadingFile = pwRow.Columns(mpXLapp.Match("mpDownloadingFile", .Rows(1), 0))
                rDownloadingFile.Value = mpDownloadingFile
        End If
            Set rMoveToFile = pwRow.Columns(mpXLapp.Match("mpMoveToFile", .Rows(1), 0))
                rMoveToFile.Value = mpMoveToFile
            Set rPathFile = pwRow.Columns(mpXLapp.Match("mpPathFile", .Rows(1), 0))
                rPathFile.Value = mpPathFile
            Set rMacro = pwRow.Columns(mpXLapp.Match("mpMacro", .Rows(1), 0))
                rMacro.Value = mpMacro
        End With
On Error Resume Next
        If mpNative = False Then .Close SaveChanges:=True Else .Save
        Set pwSheet = Nothing
        Set WB = Nothing
    End With
    If mpNative = False Then .Quit
    Set mpXLapp = Nothing
End With

End Function

Sub mp_Run_Procedures(ByRef mpApp As mpApps, ByVal bRerun As Boolean _
    , Optional ByVal mpProceduresWorkbook As String = mpDefaultStoreWorkbook)
'v2.13 2013-11-26 16:00
'runs all Procedures that have not yet been completed OK
'[and reruns all failed Procedures if bRerun = True]
'SYNTAX:  mp_Run_Procedures mpExcel, False

Dim WB As Excel.Workbook, pwSheet As Excel.Worksheet, pwRow As Excel.Range, pwRows() As Long
Dim rURL As Range, rApp As Range, rDownloadingFile As Excel.Range, rMoveToFile As Excel.Range _
    , rPathFile As Excel.Range, rMacro As Excel.Range _
    , rResult As Excel.Range, rTimestamp As Excel.Range, rTimestamps As Excel.Range
Dim mpDownloadingFile As String, mpMoveToFile As String _
    , mpPathFile As String, mpMacro As String, mpFileExt As String, mpFileName As String, r As Long
Dim b As Integer, c As Integer, d As Integer

Const rOK As String = "OK"
Const rFail As String = "Fail"
Const rIP As String = "In Progress"

'run Excel (use this WB preferably)  'v2.09
Dim mpNative As Boolean
If UCase(ThisWorkbook.FullName) = UCase(mpProceduresWorkbook) Then
'NB: differences in path e.g. UNC vs Local will cause to open again Read-Only
    Set mpXLapp = Application
    mpNative = True
    Set mpXLapp = XLlaunch(True, False)
End If

With mpXLapp
    .DisplayAlerts = False

'open WB, store details for processing later
    If mpNative = True Then 'v2.09
        Set WB = ThisWorkbook
        Set WB = .Workbooks.Open(mpProceduresWorkbook)
    End If
    With WB
        Set pwSheet = .Sheets(mpApp)
        With pwSheet
            Set rTimestamps = .Cells(1, 1)
            Set rTimestamps = .Range(rTimestamps, rTimestamps.End(xlDown))
            r = rTimestamps.Cells.Count  'total rows (timestamps) in table incl. header
            Set rTimestamps = .Columns(mpXLapp.Match("rTimestamp", .Rows(1), 0))  'in/complete rows
            Set rResult = .Columns(mpXLapp.Match("rResult", .Rows(1), 0))   'result (allows rerun)
            Set rURL = .Columns(mpXLapp.Match("mpURL", .Rows(1), 0))  'v2.04 URL for download or in case need to download again
            If mpApp = mpApps.mpDownload Then 'v2.04
                Set rApp = .Columns(mpXLapp.Match("mpApp", .Rows(1), 0))
                Set rDownloadingFile = .Columns(mpXLapp.Match("mpMoveToFile", .Rows(1), 0))  'v2.12 bugfix in Downloads process
                Set rDownloadingFile = .Columns(mpXLapp.Match("mpDownloadingFile", .Rows(1), 0))
            End If
            Set rMoveToFile = .Columns(mpXLapp.Match("mpMoveToFile", .Rows(1), 0))
            Set rPathFile = .Columns(mpXLapp.Match("mpPathFile", .Rows(1), 0))
            Set rMacro = .Columns(mpXLapp.Match("mpMacro", .Rows(1), 0))
            For r = 2 To r  'all reports, ignore header row
                If rTimestamps.Cells(r) = "" Then
                    If (bRerun = True And rResult.Cells(r) <> "OK") Or rResult.Cells(r) <> "Fail" Then 'v2.04
                    'run this procedure
                        mpMoveToFile = rMoveToFile.Cells(r).Value
                        b = InStr(mpMoveToFile, ".")
                        Do While b > 0
                            c = b
                            b = InStr(c + 1, mpMoveToFile, ".")
                        If c > 0 Then mpFileExt = Mid(mpMoveToFile, c, 8)
                        b = InStr(mpMoveToFile, "\")
                        Do While b > 0
                            d = b
                            b = InStr(d + 1, mpMoveToFile, "\")
                        If d > 0 Then mpFileName = Mid(mpMoveToFile, d + 1, Len(mpMoveToFile) - d)
                        mpPathFile = rPathFile.Cells(r).Value
                        mpMacro = rMacro.Cells(r).Value
                        rResult.Cells(r).Value = "In Progress"
                        If mpApp = mpApps.mpDownload Then
                        'Downloads: mp_Procedure will use URL to download file, then run procedure in relevant App
                            mpApp = rApp.Cells(r).Value
                            mpDownloadingFile = rURL.Cells(r).Value  'starts with "http://" or "https://"
                        'Apps: mp_Procedure will check if downloading file is finished yet, then run procedure in relevant App
                            mpDownloadingFile = rDownloadingFile.Cells(r).Value
                        End If
                        If mp_Procedure(mpApp, mpDownloadingFile, mpMoveToFile, mpPathFile, mpMacro) = True _
                        Then rResult.Cells(r).Value = "OK" _
                        Else: rResult.Cells(r).Value = "Fail"
                        rTimestamps.Cells(r).Value = Now()
                        mpApp = .Index  'v2.12 bugfix, resets mpApp
                    End If
                End If
                Application.Calculate  'v2.13, updates admin sheet counts
            Next r
        End With
        If mpNative = False Then .Close SaveChanges:=True Else .Save
        Set pwSheet = Nothing
        Set WB = Nothing
    End With
    If mpNative = False Then .Quit
    Set mpXLapp = Nothing
End With

End Sub

Private Function mp_Procedure(ByRef mpApp As mpApps, ByRef mpDownloadingFile As String, ByRef mpMoveToFile As String _
    , ByVal mpPathFile As String, ByVal mpMacro As String) As Boolean
'v2.11 2013-09-23 11:18
'only run from mp_Run_Procedures

On Error GoTo ErrorHandler  'mp_Procedure = False

Dim mp_DownloadedFile As String, mp_FileExt As String, b As Byte, c As Byte

'v2.04 if URL is specified, download file then change variables and run relevant procedure
'       NB: mpApp is never 3 at this point
If Left(mpDownloadingFile, 7) = "http://" Or Left(mpDownloadingFile, 8) = "https://" Then  'v2.05 handles https
    b = InStr(mpMoveToFile, ".")  'check end of string for file ext
    Do Until b = 0
        mp_FileExt = Mid(mpMoveToFile, b, 1 + Len(mpMoveToFile) - b)  '".csv"
        c = b
        b = InStr(b + 1, mpMoveToFile, ".") 'check end of string for file ext
    mpDownloadingFile = modAppsFirefox.ff_GetDownload(mpDownloadingFile, mp_FileExt, mpMoveToFile, True)  'True always waits for completion
End If

'original code from modFireFox, second part is changed for this procedure
'whilst downloading, file.ext placeholder will exist with 0 bytes, file.ext.part is temporary downloading file
'on completion, file.ext wil be deleted, then file.ext.part will be renamed, so file.ext will be >0 bytes
    Dim f1 As Double
On Error Resume Next
    If Dir(mpDownloadingFile) = "" Then GoTo ErrorHandler
    f1 = FileLen(mpDownloadingFile)
    Do While f1 = 0
    'when download completes, mpDownloadingFile is deleted (i.e. error) then reappears with f1 > 0
        f1 = FileLen(mpDownloadingFile)
On Error GoTo 0

On Error GoTo ErrorHandler  'mp_Procedure = False

'rename downloaded file if specified
'NB: renaming .csv to .xls will cause you problems!
    If mpMoveToFile <> "" Then
    'use specified filename
        mp_DownloadedFile = mpMoveToFile
    'use default download filename
        Const cDefaultFilename As String = "Downloaded Web Server Report."  ' & mp_FileExt
        Const cPrd As String = "."
        mp_FileExt = Replace(LCase(mp_FileExt), cPrd, "")
        mp_DownloadedFile = cDefaultFilename & mp_FileExt
    End If
'before moving/renaming download file, kill target file
    If mpDownloadingFile <> mp_DownloadedFile Then 'v2.06 not necessary where filenames the same
        If Dir(mpDownloadingFile) <> "" And Dir(mp_DownloadedFile) <> "" Then Kill mp_DownloadedFile  'v2.06 stops deletion where files not found
    'rename/move downloaded file
        Name mpDownloadingFile As mp_DownloadedFile
    End If
'validity check to confirm download completed
    If Dir(mp_DownloadedFile) = "" Then
    'downloaded file doesn't exist, something went wrong
        MsgBox "Downloaded file not found", vbCritical, "Error in mp_DownloadedFile"
        GoTo ErrorHandler
    End If

'run relevant application (only if required)  'v2.11
    If mpPathFile <> "" Then
        If mpApp = 1 Then run_Excel "", mpPathFile, mpMacro, False
        If mpApp = 2 Then run_Access "", mpPathFile, mpMacro
    End If
mp_Procedure = True
Exit Function
End Function

No comments:

Post a Comment