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:
Excel:
| mpTimestamp | mpURL | mpDownloadingFile | mpMoveToFile | mpPathFile | mpMacro | rResult | rTimestamp |
| mpTimestamp | mpURL | mpDownloadingFile | mpMoveToFile | mpPathFile | mpMacro | rResult | rTimestamp |
| mpTimestamp | mpURL | mpApp | mpMoveToFile | mpPathFile | mpMacro | rResult | rTimestamp |
'modProcedures
'v2.14 2013-12-02 13:05
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP@tomparish.me.uk
' http://baldywrittencod.blogspot.com
' 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)
'=========================================================================
' VERSION HISTORY
'=========================================================================
' 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
'SYNTAX
' Store Excel procedure:
' mp_Procedure_Store "http://url.com", "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 "http://url.com", "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 "http://url.com", "", "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)
Else
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)
Else
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
CleanUp:
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
Else
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
Else
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
Else
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, ".")
Loop
If c > 0 Then mpFileExt = Mid(mpMoveToFile, c, 8)
b = InStr(mpMoveToFile, "\")
Do While b > 0
d = b
b = InStr(d + 1, mpMoveToFile, "\")
Loop
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://"
Else
'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
Loop
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)
Loop
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
Else
'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
ErrorHandler:
End Function
