VBA Modules: Access: accUtils v2.00

Read this for full information on these modules

Kudos to a number of different people who've found similar solutions...

v1.00: acU_RelinkTables
Does a find & replace in linked tables.  Cross-posted.  Not sure why it took me so long to find the answer to this problem, but it did.... so after 5 years of manually updating linked tables I finally got the answer.
v1.01 improved messaging, case sensitivity bugfix

v2.00: acU_ChangeQueryPaths
Does a find & replace in SQL in all queries.

'accUtils
'v2.00 2014-01-16 13:46

'===========================================================================
' 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 / www.baldmosher.com
'   DGF Help Contact: see BPMHelpContact module
'=========================================================================

'===========================================================================
' accUtils
'===========================================================================
'   Various time-saving utilities for Access databases
'

'===========================================================================
' Additional modules required:
'===========================================================================
'   None
'

'=========================================================================
' VERSION HISTORY
'=========================================================================
'v2.00 2014-01-16 13:46 - added acU_ChangeQueryPaths (does a find & replace in all queries)
'v1.02 2013-12-05 14:18 - acU_RelinkTables, added Debug.Print for missing tables
'v1.01 2013-12-04 15:06 - acU_RelinkTables, bugfix for case sensitivity, added t count, improved msgboxes
'v1.00 2013-12-04 14:31 - added acU_RelinkTables (does a find & replace in linked tables)

Option Compare Database

Public Sub acU_RelinkTables(ByVal OldBasePath As String, ByVal NewBasePath As String _
    , Optional ByVal AlsoChangeQueries As Boolean = True)
'v1.02 2013-12-05 14:18 - added Debug.Print for missing tables
'v1.01 2013-12-04 15:06 - bugfix for case sensitivity, added t count, improved msgboxes
'v1.00 2013-12-04 14:31 - original version
'pass old & new path to update all linked tables
'and it will go through all the tables in your database and link them to the new location
'Original source: Written by John Hawkins 20/9/99 www.fabalou.com
'via http://database.ittoolbox.com/groups/technical-functional/access-l/how-to-programme-the-linked-table-manager-using-vba-in-ms-access-5185870
'Syntax:
'  acU_RelinkTables("\\OldShare\FolderName\", "\\NewShare\FolderName\)

Dim Dbs As Database
Dim Tdf As TableDef
Dim Tdfs As TableDefs
Dim TdfCurrentPath As String
Dim t As Integer, u As Integer  'NB: practical limit of 65536 linked tables
Dim pp As String, tt As String  'for msgboxes

Set Dbs = CurrentDb
Set Tdfs = Dbs.TableDefs

Screen.MousePointer = 11  'shows as "working"
'Loop through the tables collection
For Each Tdf In Tdfs
    If Tdf.SourceTableName <> "" Then 'If the table source is other than a base table
        TdfCurrentPath = Tdf.Connect
        If InStr(UCase(TdfCurrentPath), UCase(OldBasePath)) > 0 Then  'If the current path needs to be changed
            t = t + 1   'count tables processed
On Error Resume Next
            Tdf.RefreshLink 'Refresh the link
            If Err = 3011 Then GoTo OriginalTdfError    'bypasses change if current linked table isn't found
            Tdf.Connect = Replace(TdfCurrentPath, OldBasePath, NewBasePath)   'Set the new source
            Tdf.RefreshLink 'Refresh the link
            If Err = 3011 Then GoTo EscapeOnError    'likely means error in new path - could be critical
            u = u + 1   'count tables updated
On Error GoTo 0
        End If
    End If
OriginalTdfError:
If Err = 3011 Then Debug.Print "Error 3011:  " & Tdf.Name & vbLf & TdfCurrentPath
Next 'Goto next table

pp = u & " tables have been relinked from " & OldBasePath & " to " & NewBasePath
If t > u Then pp = pp & vbLf & vbLf & "(" & t - u & " were not updated successfully because the original table was missing)"
tt = "Tables Relinked"

Screen.MousePointer = 0
MsgBox pp, vbInformation, tt

Exit Sub
EscapeOnError:
pp = "Possible major error: please ensure OldBasePath and NewBasePath are correct - you will now be returned to Debug"
tt = "WARNING"
MsgBox pp, vbExclamation, tt
On Error GoTo 0
Tdf.Connect = TdfCurrentPath 'return to original
Tdf.RefreshLink 'Refresh the link - errors here means the table was missing before... this needs to be resolved
'NB: to continue from where you left off, drag arrow up to Next
End Sub

Public Sub acU_ChangeQueryPaths(ByVal OldBasePath As String, ByVal NewBasePath As String)
'v2.00 2014-01-16 13:46 - original version
'pass old & new path to update all queries
'Original source: acU_RelinkTables
'Syntax:
'  acU_ChangeQueryPaths("\\OldShare\FolderName\", "\\NewShare\FolderName\)

Dim Dbs As Database
Dim Qdf As QueryDef
Dim Qdfs As QueryDefs
Dim QdfOldSQL As String, QdfNewSQL As String
Dim q As Integer 'NB: practical limit of 65536 queries
Dim pp As String, tt As String  'for msgboxes

If Right(OldBasePath, 1) = "\" And Right(NewBasePath, 1) = "\" Then
    pp = "This will Find & Replace in all queries.  There is no validation for this.  Use with caution.  To Undo, simply re-run to correct the error." _
        & vbLf & vbLf & "find:          " & OldBasePath & vbLf & "replace:    " & NewBasePath
    tt = "WARNING"
    If MsgBox(pp, vbExclamation Or vbOKCancel, tt) = vbCancel Then Exit Sub
Else
    pp = "Your old and new paths must end with ""\"".  Otherwise, errors may occur.  Will now Exit." _
        & vbLf & vbLf & "find:          " & OldBasePath & vbLf & "replace:    " & NewBasePath
    tt = "CRITICAL WARNING"
    MsgBox pp, vbCritical, tt
    Exit Sub
End If

Set Dbs = CurrentDb
Set Qdfs = Dbs.QueryDefs

Screen.MousePointer = 11  'shows as "working"
For Each Qdf In Qdfs
    QdfOldSQL = Qdf.SQL
    QdfNewSQL = Replace(QdfOldSQL, OldBasePath, NewBasePath)
    If QdfOldSQL <> QdfNewSQL Then
        q = q + 1
        Qdf.SQL = QdfNewSQL
    End If
Next 'Goto next query

pp = q & " queries have been updated from " & OldBasePath & " to " & NewBasePath
tt = "Queries Updated"

Screen.MousePointer = 0
MsgBox pp, vbInformation, tt

End Sub

VBA Modules: Access: accPostCodes v1.03

Read this for full information on these modules


I wrote this module to help me out processing and extracting GB post codes, which can have a number of combinations:

A1 2BC
A12 3BC
AB1 2CD
AB12 3CD
AB1C 2DE

accPostCodeExtract is probably the most useful function here, as it will extract the post code from the end of a long address string.  There are options to work with most source string formats.  By default, the result will be padded with spaces to length = 8, e.g. "AB1  2CD"

accPostCodePrefix extracts the post code "town", e.g. "AB" from "AB1 2CD"
accPostCodePrefixWithNumber extracts the full post code prefix, e.g. "AB1" from "AB1 2CD"

'accPostCodes
'v1.03 2013-11-29 13:03

'===========================================================================
' 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/2013/11/vba-modules-access-accpostcodes.html
'   DGF Help Contact: see BPMHelpContact module
'=========================================================================

'   v1.03   accPostCodeExtract: bugfix where original post code already padded to len=8
'   v1.02   accPostCodeExtract: added bPadResult option, bugfix where string is just post code
'   v1.01   added accPostCodeExtract
'   v1.00   original version

Option Explicit
Option Compare Database

Function accPostCode(ByRef PCode, Optional ByVal FWSrcSys) As String
'v1.00 2013-11-29 11:53

Dim sPCode As String, sFWsys As String
On Error Resume Next
sPCode = PCode
sFWsys = FWSrcSys
On Error GoTo 0

If sFWsys = "LO" Then Exit Function

'extract "GB/" from start of NFE PCode
Dim b As Byte
b = InStr(sPCode, "/")
sPCode = Mid(sPCode, b + 1, Len(sPCode))

If sPCode = "" Or sPCode = "0" Or sPCode = "." Or sPCode = "#" Then Exit Function

accPostCode = sPCode

End Function

Function accPostCodePrefix(ByRef PCode, Optional ByVal FWSrcSys) As String
'v1.00 2013-11-29 11:53
'checks first 1-2 characters for alpha prefix

Dim sPCode As String, sFWsys As String
On Error Resume Next
sPCode = PCode
sFWsys = FWSrcSys
On Error GoTo 0

If sFWsys = "LO" Then Exit Function

Dim s As String
sPCode = accPostCode(sPCode)
If sPCode = "" Then Exit Function
s = Left(sPCode, 1)
If IsNumeric(s) Then Exit Function Else accPostCodePrefix = s
s = Mid(sPCode, 2, 1)
If IsNumeric(s) Then Exit Function Else accPostCodePrefix = accPostCodePrefix & s

End Function

Function accPostCodePrefixWithNumber(ByVal PCode, Optional ByVal FWSrcSys) As String
'v1.00 2013-11-29 11:53
'checks first 2 characters for alpha prefix then checks following 2-3 chars for numeric

Dim sPCode As String, sFWsys As String
On Error Resume Next
sPCode = PCode
sFWsys = FWSrcSys
On Error GoTo 0

If sFWsys = "LO" Then Exit Function

Dim b As Byte, APfx As String, ANPfx As String
APfx = accPostCodePrefix(sPCode)
If APfx = "" Then Exit Function
b = InStr(sPCode, " ")
If b > 0 Then
'just use characters before space
    ANPfx = Left(sPCode, b - 1)
Else
'no space, deduce logically
'e.g. for AB123CD need AB12, take APfx plus all except last following numeric character
    ANPfx = APfx & Mid(sPCode, Len(APfx) + 1, 3)
    'e.g. AB123 or AB12C or AB1C2
    If ANPfx = sPCode Then
    'e.g. AB12[] so only prefix anyway
    ElseIf IsNumeric(Mid(ANPfx, Len(ANPfx), 1)) Then
    'e.g. AB123[CD] so AB12 3CD
        ANPfx = Left(ANPfx, Len(ANPfx) - 1)
    ElseIf IsNumeric(Mid(ANPfx, Len(ANPfx) - 1, 1)) Then
    'e.g. AB12C[D] so AB1 2CD
        ANPfx = Left(ANPfx, Len(ANPfx) - 2)
    ElseIf IsNumeric(Mid(ANPfx, 3, 1)) And Not IsNumeric(Mid(ANPfx, 4, 1)) Then
    'e.g. AB1C2[DE] so AB1C 2DE
        ANPfx = Left(ANPfx, Len(ANPfx) - 1)
    Else
    'cannot identify
        ANPfx = ""
    End If
End If

accPostCodePrefixWithNumber = ANPfx

End Function

Function accPostCodeExtract(ByVal FullAddressString, Optional ByVal bPostCodeNoSpace As Boolean = False _
    , Optional ByVal bCommaSeparated As Boolean = False, Optional bPadResult As Boolean = True) As String
'v1.03 2013-11-29 13:03
'extracts the post code from the end of a long address string (after the last-but-one space [or comma])
'e.g. "CITY, County, AB12 3CD" becomes "AB12 3CD"
'NB: with "AB123CD" post code formats, use bPostCodeNoSpace = True
'NB: with "City,County,AB12 3CD" format strings, use bCommaSeparated = True
'NB: to pad result to fixed 8 characters, use bPadResult = True

On Error Resume Next

Dim FullString As String
FullString = FullAddressString
If FullString = "" Then Exit Function

Dim sSearchString As String, sCount As Byte
If bCommaSeparated Then
    sSearchString = ","
    sCount = 1
Else
    sSearchString = " "
    If bPostCodeNoSpace Then sCount = 1 Else sCount = 2
    While InStr(FullString, "  ") > 0
        FullString = Replace(FullString, "  ", " ")
    Wend
End If

Dim findspaces() As Integer, f As Integer, fCount As Byte
fCount = 1
While InStr(f + 1, FullString, sSearchString) > 0
ReDim Preserve findspaces(1 To fCount) As Integer
f = InStr(f + 1, FullString, sSearchString)
findspaces(fCount) = f
fCount = fCount + 1
Wend
accPostCodeExtract = Mid(FullString, findspaces(fCount - sCount) + 1, Len(FullString))
If accPostCodeExtract = "" Then accPostCodeExtract = FullString
If bPostCodeNoSpace Then accPostCodeExtract = Left(accPostCodeExtract, Len(accPostCodeExtract) - 3) & " " & Right(accPostCodeExtract, 3)
If bPadResult Then
    While Len(accPostCodeExtract) < 8
        accPostCodeExtract = Left(accPostCodeExtract, Len(accPostCodeExtract) - 3) & " " & Right(accPostCodeExtract, 3)
    Wend
End If

End Function

VBA Modules: Access: accCompactRepair v2.03

Read this for full information on these modules

This nifty little module performs a compact & repair on an Access database, or for all Access databases under a specified path. 

accSweepForDatabases runs acCompactRepair on all *.accdb and *.mdb files within [and beneath] the specified folder. (NB: you'll need to comment out the line for .accdb if you only have Access 2003 installed because it won't open those files.)

Syntax to auto-compact all databases under a path:

Access 2007/2010:

accSweepForDatabases "C:\Folder\", True, False, False

Access 2003:

accSweepForDatabases "C:\Folder\", True, False, True

acCompactRepair launches Access, opens the database, sets the "Compact on Close" option to "True", then quits.

Syntax to auto-compact:

acCompactRepair "C:\Folder\Database.accdb", True

I tend to use it after running a Delete query or removing a single table object from a database.

Syntax to return to default* afterwards:

acCompactRepair "C:\Folder\Database.accdb", False

*not necessary, but if your back end database is >1GB this can be rather annoying when you go into it directly and it then takes >2 minutes to quit.

'accCompactRepair
'v2.03 2013-11-28 17:43

'===========================================================================
' 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/2013/10/vba-modules-access-compact-repair.html
'   DGF Help Contact: see BPMHelpContact module
'=========================================================================

'includes code from
'http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for improved error handling

'   v2.03   added option for Access 2003 users
'           improved code annotation
'   v2.02   bugfix preventing Compact when bAutoCompact set to False
'           bugfix with "OLE waiting for another application" msgbox
'           added "MB" to start & end sizes of message box at end
'   v2.01   added size reduction to message box
'   v2.00   added recurse
'   v1.00   original version

Option Explicit

Function accSweepForDatabases(ByVal strFolder As String, Optional ByVal bIncludeSubfolders As Boolean = True _
    , Optional bAutoCompact As Boolean = False, Optional bOnlyAccess2003 As Boolean) As String
'v2.03 2013-11-28 17:43
'sweeps path for .accdb and .mdb files, compacts and repairs all that it finds
'NB: leaves AutoCompact on Close as False unless specified, then leaves as True

'syntax:
'   accSweepForDatabases "path", [False], [True]

'code for ActiveX CommandButton on sheet module named "admin" with two named ranges "vPath" and "vRecurse":
'   accSweepForDatabases admin.Range("vPath"), admin.Range("vRecurse") [, admin.Range("vLeaveAutoCompact")]

Application.DisplayAlerts = False

Dim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As Single
Dim SizeBefore As Long, SizeAfter As Long
t = Timer

'scan path for any .mdb and .accdb files
    If bOnlyAccess2003 = False Then RecursiveDir colFiles, strFolder, "*.accdb", True
    RecursiveDir colFiles, strFolder, "*.mdb", True

'now compact & repair the list of databases
    For Each vFile In colFiles
        'Debug.Print vFile
        SizeBefore = SizeBefore + (FileLen(vFile) / 1048576)
On Error GoTo CompactFailed
    If InStr(vFile, "Geographical Configuration.accdb") > 0 Then MsgBox "yes"
        acCompactRepair vFile, bAutoCompact
        i = i + 1  'counts successes
        GoTo NextCompact
CompactFailed:
On Error GoTo 0
        j = j + 1   'counts failures
        sFails = sFails & vFile & vbLf  'records failure
NextCompact:
On Error GoTo 0
        SizeAfter = SizeAfter + (FileLen(vFile) / 1048576)

    Next vFile

Application.DisplayAlerts = True

'display message box, mark end of process
    accSweepForDatabases = i & " databases compacted successfully, taking " & CInt(Timer - t) & " seconds, and reducing storage overheads by " & Int(SizeBefore - SizeAfter) & "MB" & vbLf & vbLf & "Size Before: " & Int(SizeBefore) & "MB" & vbLf & "Size After: " & Int(SizeAfter) & "MB"
    If j > 0 Then accSweepForDatabases = accSweepForDatabases & vbLf & j & " failures:" & vbLf & vbLf & sFails
    MsgBox accSweepForDatabases, vbInformation, "accSweepForDatabases"

End Function

Function acCompactRepair(ByVal pthfn As String, Optional doEnable As Boolean = True) As Boolean
'v2.02 2013-11-28 16:22
'if doEnable = True will compact and repair pthfn
'if doEnable = False will then disable auto compact on pthfn

On Error GoTo CompactFailed

Dim A As Object
Set A = CreateObject("Access.Application")
With A
    .OpenCurrentDatabase pthfn
    .SetOption "Auto compact", True
    .CloseCurrentDatabase
    If doEnable = False Then
        .OpenCurrentDatabase pthfn
        .SetOption "Auto compact", doEnable
    End If
    .Quit
End With
Set A = Nothing
acCompactRepair = True
Exit Function
CompactFailed:
End Function


'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for error handling

Private Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
On Error Resume Next
    strTemp = ""
    strTemp = Dir(strFolder & strFileSpec)
On Error GoTo 0
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
On Error Resume Next
        strTemp = ""
        strTemp = Dir(strFolder, vbDirectory)
On Error GoTo 0
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function

Private Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

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:

Excel:

mpTimestamp

mpURL

mpDownloadingFile

mpMoveToFile

mpPathFile

mpMacro

rResult

rTimestamp

Access:

mpTimestamp

mpURL

mpDownloadingFile

mpMoveToFile

mpPathFile

mpMacro

rResult

rTimestamp

Download:

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

VBA Modules: Outlook: OL_BPMProcess v6.22

Read this for full information on these modules

This module is getting into serious space-age coding territory here (well, for me anyway).  If you're a data analyst, and you are fed up with having to deal with a hundred emailed reports, if you can make full use of this, you'll shave at least a day off your workload.  If you can do it without anyone finding out, you can achieve the same amount of work with zero effort, and spend the rest of your time clearing your other workload and developing other automation solutions, so that eventually, everyone thinks you're incredibly busy, when actually, you're just sat back watching Outlook do everything for you and browsing Monster for new jobs.

To give you a rough idea of what I achieve with this, I use this module to process approximately 5GB of data downloads from a web server, update 32GB of local databases, and push out 4GB of Excel reports, and all before I get into the office on Monday morning.

Now, I could be very sneaky and change the schedule so it only runs during the day, and makes me look like some kind of high throughput automaton, but I'm not sneaky.  I prefer to make myself out to be some kind of code wizard, even though I work for a company that prefers to employ Indians, Mexicans and Filipinos in a data centre instead of talented analysts & coders in-country.  Now, we're not the only globocorp who does that, so I don't feel remotely ashamed by admitting that we're creating jobs in the third world, and coincidentally we outsource some of this to a "service" centre run by one of my previous blue chip globocorp employers, so I do feel that one day I might have to do this very thing for someone else.  Transferable skills are the only advantage we have left -- so learn as many as you can and move on to something else.

Anyway, mini-rant over, here's the code.


Note that I use Outlook Rules to launch the relevant script when keywords are found in the email subject.  There is another very elegant way of doing this using Event triggers, but as with many elegant solutions, I find they aren't always reliable once you start making things complicated.  This approach works like a sledgehammer.  Something gone wrong?  Kill Outlook and start again and it'll put the mangled wreckage of failure to one side, pick up the mallet, and start bashing again where it left off.

Downsides: it's annoying when it gets stuck, which for me is quite often, because I'm a messy coder.

Also note that the following uses modAppsFirefox to download a file from a URL.  As of v6, it uses modProcedures to store Excel/Access/Download procedures for running later.

'OL_BPMprocess
'v6.22 2013-12-02 17:31
'always export to \\GBMNCWSA050\BPMpublic\VBA Modules\Outlook\

'===========================================================================
' 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
'=========================================================================

'*************************************************************
' NOTE: all prior versions MUST be upgraded to v4.02 or later
'*************************************************************

'*****************************************************
'*****  WARNING: SETTINGS BELOW MUST BE AMENDED  *****
'*****************************************************

'===========================================================================
' OL_BPMprocess
'===========================================================================
' OL_ProcessANYREPORT
'   Routines for copying XLS/CSV (and extracting ZIP) attachments, and for
'   downloading reports from URL.
'
' OL_ProcessDATABASE
'   Routines for processing database updates automatically by trigger email.
'   Triggered by specific subject, e.g. "BPMAUTORUN DATABASE MONTHEND"
'
' OL_ProcessZIPIT
'   Routines for zipping attachments sent back by return (size limit applies).
'   Triggered by subject, e.g. "BPMAUTORUN ZIPIT free text"
'
' OLV_xxxxxxx
'   Simple functions for Outlook

'===========================================================================
' Additional modules required:
'===========================================================================
'   modAppsFirefox v3  (v2 if DL_WaitForCompletion = False)
'   modAppsOffice v4
'   modProcedures  (if DL_WaitForCompletion = True)
'   modZip v6
'   xlSharePoint  (for SP_fn_val)

'===========================================================================
' Additional References required:
'===========================================================================
'   BPMGB Outlook rule: BPMAUTORUN ANYREPORT
'   BPMGB Outlook rule: BPMAUTORUN DATABASE
'   BPMGB Outlook rule: BPMAUTORUN ZIPIT

'===========================================================================
' External applications required:
'===========================================================================
'   MS Access
'   MS Excel

'=========================================================================
' VERSION HISTORY
'=========================================================================
'   v6.22   OL_DATABASE: won't run if specified DBs are locked (see CRP/CRA)
'           olV_SubmitLog: renamed variables to make more sense
'   v6.21   OL_DATABASE: changed CRPCRA log file name
'   v6.20   OL_ANYREPORT: hides Excel window by default, allows automatic report updates
'   v6.19   OL_DATABASE: added GCCSDBREPORTS trigger
'   v6.18   OL_DATABASE: added pause to GCCS, prevent issues
'   v6.17   swapped email address for OL_DefaultEmail in module
'           OL_DATABASE: minor code tweaks, fixed Logis FTP code
'   v6.16   OL_DATABASE: added GCCS propagate routine
'   v6.15   OL_DATABASE: added Logis FTP routine (405)
'   v6.14   OL_DATABASE: better error handling for unrecognised routines
'   v6.13   OL_ANYREPORT: bugfix for false error report in simple download, added bNothingElseToDo
'   v6.12   OL_ANYREPORT: bugfix for false error report when saving attachments, added bAttSaved
'   v6.11   olXLapp: prevents bugs when using modAppsOffice.XLapp
'   v6.10   OL_Simple_Archive: bugfix for subject/folder name
'   v6.09   OL_v_URL: extracts URL from HTML tags <A HREF="url">
'           OL_v_URL: workaround to prefix incomplete URL in emails with Forwin DLL URL
'           OL_v_URL: bugfix for when forwarding trigger email to BPM.GB@dhl.com
'           OL_v_var: bugfix for when forwarding trigger email to BPM.GB@dhl.com
'           OL_Simple_Archive: bugfix for single-word subfolders
'   v6.08   OL_ProcessANYREPORT: major process fix for storing Downloads
'   v6.07   OL_ProcessANYREPORT: bugfix for stored Downloads
'   v6.06   OL_ProcessDATABASE: CRP/CRA conf email to triggerer, CC group mailboxes
'   v6.05   OL_ProcessANYREPORT: error handler for stored Download failure
'   v6.04   OL_ProcessDATABASE: updated CRP/CRA Control List v2 filename
'           olV_SubmitLog: added triggerer/recipient email address to log, bugfix
'   v6.03   OL_ProcessANYREPORT: bugfix
'           OL_SendEmail updated to v1.06
'   v6.02   OL_ProcessANYREPORT: modProcedures stores URL
'   v6.01   OL_ProcessANYREPORT: modProcedures error handling
'   v6.00   OL_ProcessANYREPORT: added modProcedures functionality
'   v5.00   merged code from modSpecialFolders
'   v4.05   OL_ProcessANYREPORT: handles dbn including pth
'   v4.04   OL_Simple_Archive: code rearrangement; marks read, flags complete
'   v4.03   OL_Simple_Archive: minor bugfix for failed email move (happens during debugging for some reason)
'           OL_ProcessANYREPORT: added cBsl and cFsl constants
'   v4.02   OL_SaveAttachment: stopped deleting ofn where pth & ofn = logpthfn
'           OL_ProcessANYREPORT: validity check for pth, includes \ or /
'   v4.01   external download routine now in modAppsFirefox
'   v4.00a  annotations only
'   v4.00   OL_v_vvar: rebuild
'           OL_ProcessZIPIT: rebuild
'           OL_ProcessANYREPORT: annotations
'           OL_ProcessDATABASE: merged modules, renamed macro
'           merged modules: OL_varPublic, OL_Attachments, OL_DBmacros
'           retired: OL_ProcessForwinReport, olV_get_From, olV_chk_Auto, olV_do_Auto
'***********************************************************************
' PRIOR VERSIONS MUST BE UPGRADED
'***********************************************************************
'=========================================================================
' OL_Attachments VERSION HISTORY
'=========================================================================
'   v3.06   OL_v_URL: works for any file format hyperlink
'   v3.05   OL_ProcessANYREPORT: changes to syntax in trigger failure reply
'   v3.04   OL_ProcessANYREPORT: bugfix in download errors
'   v3.03   OL_Simple_Archive: tgt folder dictated by UPPER CASE words
'           added OL_UpperCase
'           added OL_LowerCase (for posterity only, not used)
'   v3.02   OL_Simple_Archive: handles multiple attachments
'           OL_SaveAttachment: handles multiple attachments
'           OL_ProcessANYREPORT: handles multiple attachments
'           OL_ProcessANYREPORT: downloads files from Forwin CSV hyperlink
'           OL_v_URL: checks for specified pipe variable first
'   v3.01   merged olS and olZ modules into olA
'   v3.00   OL_ProcessForwinReport retired
'   v2.12   OL_ProcessAnyReport (replaces OL_ProcessForwinReport)
'=========================================================================
' OL_DBmacros VERSION HISTORY
'=========================================================================
'   v1.07   olD_ProcessDatabaseUpdates: runs OL_Simple_Archive
'   v1.06   olD_ProcessDatabaseUpdates: writes result to log, sends email
'   v1.05   olD_ProcessDatabaseUpdates: opens ReadOnly
'   v1.04   olD_ProcessDatabaseUpdates: XL quits afterwards
'   v1.03   olD_ProcessDatabaseUpdates: added CRP/CRA trigger and log
'=========================================================================
' OL_varPublic VERSION HISTORY
'=========================================================================
'   v2.15   removed xlShellAndWait and Excel references
'   v2.14   olV_submitlog: sends confirmation/failure email
'   v2.13   annotations only (no material effect)
'   v2.12   olV_submitlog: added logTimeTaken, logRecipientEmail, logpthfn
'   v2.11   bugfix for xlShellAndWait
'           updated log file path to GBMNCWSA050 share
'   v2.10   moved to GBMNCWSA050

Option Explicit

'*****************************************************
'*****  WARNING: SETTINGS BELOW MUST BE AMENDED  *****
'*****************************************************

'max email attachment size in BYTES (10000000 = 10MB)
Private Const maxAttSize As Double = 10000000

'log file location should be changed for end user, write access is required
Public Const LogFolder As String _
    = "\\GBMNCWSA050\BPMpublic\LogFiles\"  'v2.11

'CSV will be created/updated in above LogFolder
Public Const LogFileName As String _
    = "OutlookSaveAttachmentsLog.csv"

Private Const DL_WaitForCompletion As Boolean = False
'v6.00 True will always wait for completion of downloads, False requires modProcedures

'default email address for Trigger Failure and if recipient is specified as "" (mainly for testing)
Private Const OL_DefaultEmail As String = "bpm.gb@dhl.com"  'v5.00

'Specify name of default Mailbox - case sensitive
Private Const OL_MYmbx As String = "BPM.GB@dhl.com" 'v5.00

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



Private olXLapp As Excel.Application  'v6.11

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)

'==========================================================================
'==========================================================================
'==========================================================================
'==========================================================================

'
'   Code from modSpecialFolders module:
'

'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009
Private Declare Function SHGetSpecialFolderLocation _
                         Lib "shell32" (ByVal hwnd As Long, _
                                        ByVal nFolder As Long, ppidl As Long) As Long

Private Declare Function SHGetPathFromIDList _
                         Lib "shell32" Alias "SHGetPathFromIDListA" _
                             (ByVal Pidl As Long, ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

'Desktop
Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)
Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs
Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel
Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers
Private Const CSIDL_PERSONAL = &H5 'My Documents
Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites
Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup
Private Const CSIDL_RECENT = &H8 '<user name>\Recent
Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo
Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin
Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu
Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop
Private Const CSIDL_DRIVES = &H11 'My Computer
Private Const CSIDL_NETWORK = &H12 'Network Neighborhood
Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood
Private Const CSIDL_FONTS = &H14 'Windows\fonts
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu
Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs
Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop
Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data
Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood
Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)
Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup
Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup
Private Const CSIDL_COMMON_FAVORITES = &H1F
Private Const CSIDL_INTERNET_CACHE = &H20
Private Const CSIDL_COOKIES = &H21
Private Const CSIDL_HISTORY = &H22
Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data
Private Const CSIDL_WINDOWS = &H24 'Windows Directory
Private Const CSIDL_SYSTEM = &H25 'System Directory
Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files
Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures
Private Const CSIDL_PROFILE = &H28 'USERPROFILE
Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC
Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC
Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common
Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC
Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates
Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents
Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools
Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools
Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections
Private Const MAX_PATH = 260
Private Const NOERROR = 0

Private Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
    lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
    If lngFolderFound Then
        SpecFolder = Left$(strPath, _
                           InStr(1, strPath, vbNullChar) - 1)
    End If
End If
CoTaskMemFree lngPidl
End Function

'==========================================================================
'==========================================================================
'==========================================================================
'==========================================================================

Sub OL_ProcessANYREPORT(Item As Outlook.MailItem)
'v6.20 2013-11-26 15:09
'saves a copy of attachment (if one exists) and renames it (if ofn specified)
'!! ZIP extract & rename only possible if true extension is part of zip filename
'!! e.g. Report.csv.zip
'and/or downloads file from any URL (if url specified)
'and/or downloads file from any* hyperlink embedded in email
'!! *tested for Forwin CSV only - but can be adapted easily for other hyperlinks
'and/or run DB update (if dbn and dbm specified)
'and/or run XLS macros (if xls specified)
'and/or send confirmation email (if cfm specified)
'then move email into ANYREPORT folder

'SYNTAX to test:
'OL_ProcessANYREPORT OL_GetCurrentItem

' SUBJECT HEADER FOR EMAIL MUST BE ENTERED AS FOLLOWS:
'====================================================================
' BPMAUTORUN ANYREPORT [Report identification free text]
'====================================================================

' VARIABLES MUST BE ENTERED IN EMAIL BODY (PLAIN TEXT) AS FOLLOWS:
' BPMAUTORUN variables must be on separate lines, in "quote marks",
' and separated by pipes |
' NB: pattern match looks for e.g. "|pth=" at start and ""|" at end
' pth is mandatory, others are optional
'====================================================================
'|subj="BPMAUTORUN ANYREPORT [Report identification free text]"
        'NB: subj is not actually used, just helps with making copies of schedule template
'|pth="\\SERVER\Share Name\Folder\Subfolder\"
'       'NB: required
'|ofn="Filename.ext"
        'NB: if not specified, simply uses original filename
'|dbn="Database.mdb/.accdb"
'|dbm="reload ALL"
        'NB: this machine must have Access 2007+ installed for .accdb
'|xls="UPDATE MACRO.xls"
        'NB: can specify full path to override pth above, otherwise looks in pth for this file
'|cfm="recipient.email@domain.com"
        'NB: separate multiple recipients with semicolon and space "; "
'|url="http://domain.com/folder/file.ext"
'|      'NB: final pipe is required to prevent errors with last quotation mark
'
'CSV (hyperlink)
        'NB: may only extract URL from Forwin notification hyperlinks - to be tested
'====================================================================

Dim pth As String, ofn As String, dbn As String, dbm As String, xls As String, cfm As String, url As String
pth = OL_v_var(Item, "pth")  'REQUIRED - if none of the following are specified, will simply save attachment to pth
ofn = OL_v_var(Item, "ofn")  'optional (required if URL is used)
dbn = OL_v_var(Item, "dbn")  'optional (required if dbm is provided)
dbm = OL_v_var(Item, "dbm")  'optional (required if dbn is provided)
xls = OL_v_var(Item, "xls")  'optional (NB: if a UNC is specified here, note that if testing by forwarding, Outlook converts to HYPERLINK automatically)
cfm = OL_v_var(Item, "cfm")  'optional (specifies recipient for email confirmation when done)
url = OL_v_URL(Item)         'optional (required for download)

Dim cfmmsg As String, cfmsub As String, blnFailed As Boolean
Dim dl_PathFile As String  'v6.00
Dim bStoreProc As Boolean, bStoreURL As Boolean 'v6.02 'v6.03
Dim bAttSaved As Boolean  'v6.12
Dim bNothingElseToDo As Boolean  'v6.13

If cfm = "" Then cfm = Item.SenderEmailAddress

Const cBsl As String = "\"
Const cFsl As String = "/"

If pth <> vbNullString Then
    If InStr(pth, cBsl) > 0 Or InStr(pth, cFsl) > 0 Then
  
    'EITHER
    'optional: save attachment(s)
        If Item.Attachments.Count > 0 Then
            If Item.Attachments.Count > 1 And ofn <> "" Then
                'blnFailed = True  'not a total failure
                cfmmsg = "Error: ofn cannot be specified with multiple attachments." & vbLf & vbLf
                OL_SaveAttachment Item, pth
                bAttSaved = True  'v6.12
                cfmmsg = cfmmsg & "Attachments saved to: " & pth & vbLf & vbLf
            Else
                OL_SaveAttachment Item, pth, ofn
                bAttSaved = True  'v6.12
                cfmmsg = "Attachment saved to: " & pth & ofn & vbLf & vbLf
            End If
    'OR
    'optional: download from URL
        ElseIf url <> vbNullString Then
        'url and pth are BOTH required to download file
        '!! ofn is mandatory for URL downloads as the downloaded filename is always gibberish
            If ofn = "" Then
                blnFailed = True
                cfmmsg = "Error: ofn is required to download from URL to " & pth & vbLf & vbLf
            Else
            'download file
                dl_PathFile = modAppsFirefox.ff_GetDownload(url, "", pth & ofn, DL_WaitForCompletion)  'v6.00
                If dl_PathFile = "" Then
                    blnFailed = True
                    cfmmsg = "Error: file could not be downloaded from URL to:" & pth & ofn & vbLf & vbLf
                ElseIf dl_PathFile = pth & ofn Then
                    bNothingElseToDo = True
                    cfmmsg = url & vbLf & vbLf & "File downloaded to: " & pth & ofn & vbLf & vbLf
                ElseIf dl_PathFile = url Then  '6.02
                    bStoreURL = True
                    cfmmsg = "File not downloaded, URL will be stored and should be downloaded later" & vbLf & vbLf & dl_PathFile & vbLf & pth & ofn & vbLf & vbLf
                Else
                    bStoreProc = True
                    cfmmsg = "File still downloading, procedure will be stored and should be run later" & vbLf & vbLf & dl_PathFile & vbLf & pth & ofn & vbLf & vbLf
                End If
            End If
        End If
      
    'optional: DB macros are not always required
        If dbn <> vbNullString And dbm <> vbNullString And blnFailed = False Then
            If (dbn <> vbNullString And dbm = vbNullString) Or (dbn = vbNullString And dbm <> vbNullString) Then
                blnFailed = True
                cfmmsg = cfmmsg & "Error: Database could not be updated, dbn and dbm are both required" & vbLf & vbLf
            Else
                If InStr(dbn, cBsl) > 0 Or InStr(xls, cFsl) > 0 Then
                'path is included within dbn string
                    If bStoreURL = True Then
                    'download later
                        If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpAccess, dbn, dbm) = False Then  'v6.07
                            blnFailed = True
                            cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf
                        End If
                    ElseIf bStoreProc = True Then
                    'run procedure later
                        If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, 2, dbn, dbm) = False Then
                            blnFailed = True
                            cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf
                        End If
                    Else
                        run_Access vbNullString, dbn, dbm
                        If DBapp Is Nothing Then
                            cfmmsg = cfmmsg & "Database updated: " & dbn & vbLf & vbLf
                        Else
                            Set DBapp = Nothing
                            blnFailed = True
                            cfmmsg = cfmmsg & "Database not updated, something went wrong: " & dbn & vbLf & vbLf
                        End If
                    End If
                Else
                'path is same as saved report
                    If bStoreURL = True Then
                    'download later
                        If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpAccess, dbn, dbm) = False Then  'v6.07
                            blnFailed = True
                            cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf
                        End If
                    ElseIf bStoreProc = True Then
                        If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, 2, pth & dbn, dbm) = False Then
                            blnFailed = True
                            cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf
                        End If
                    Else
                        run_Access pth, dbn, dbm
                        If DBapp Is Nothing Then
                            cfmmsg = cfmmsg & "Database updated: " & dbn & vbLf & vbLf
                        Else
                            Set DBapp = Nothing
                            blnFailed = True
                            cfmmsg = cfmmsg & "Database not updated, something went wrong: " & dbn & vbLf & vbLf
                        End If
                    End If
                End If
            End If
        End If
  
    'optional: XL macros are not always required, but advisable, because you can
    'autorun Access macros, or long series of SQL queries, with Excel VBA
        If xls <> vbNullString And blnFailed = False Then
            If InStr(xls, cBsl) > 0 Or InStr(xls, cFsl) > 0 Then
            'path is included within xls string
                If bStoreURL = True Then
                'download later
                    If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpExcel, xls, "") = False Then  'v6.07
                        blnFailed = True
                        cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf
                    End If
                ElseIf bStoreProc = True Then
                'run procedure later
                    If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, mpApps.mpExcel, xls) = False Then
                        blnFailed = True
                        cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf
                    End If
                Else
                    run_Excel XLpth:=vbNullString, XLfn:=xls, bForceVisibility:=False  'v6.20 bForceVisibility fixes issue with automatic update of some reports, only updates when invisible
                    If olXLapp Is Nothing Then
                        cfmmsg = cfmmsg & "Excel macros run: " & pth & xls & vbLf & vbLf
                    Else
                        Set olXLapp = Nothing
                        blnFailed = True
                        cfmmsg = cfmmsg & "Excel macros not run, something went wrong: " & pth & xls & vbLf & vbLf
                    End If
                End If
            Else
            'path is same as saved report
                If bStoreURL = True Then
                'download later
                    If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpExcel, xls, "") = False Then  'v6.07
                        blnFailed = True
                        cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf
                    End If
                ElseIf bStoreProc = True Then
                    If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, mpApps.mpExcel, pth & xls) = False Then
                        blnFailed = True
                        cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf
                    End If
                Else
                    run_Excel XLpth:=pth, XLfn:=xls, bForceVisibility:=False  'v6.20 bForceVisibility fixes issue with automatic update of some reports, only updates when invisible
                    If olXLapp Is Nothing Then
                        cfmmsg = cfmmsg & "Excel macros run: " & pth & xls & vbLf & vbLf
                    Else
                        Set olXLapp = Nothing
                        blnFailed = True
                        cfmmsg = cfmmsg & "Excel macros not run, something went wrong: " & pth & xls & vbLf & vbLf
                    End If
                End If
            End If
        End If
  
    'optional: just move downloading file once completed if no XL macros or DB specified 'v6.08
        If bAttSaved = False And xls = vbNullString And dbn = vbNullString And blnFailed = False And bNothingElseToDo = False Then    'v6.13  'v6.12
        'eventual path can be different or same as current download location
            If bStoreURL = True Then
            'download later
                If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpExcel, "", "") = False Then  'v6.07
                    blnFailed = True
                    cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf
                End If
            ElseIf bStoreProc = True Then
            'run procedure later (actually doesn't run any procedure, because xls is "", could equally put it on Access sheet)
                If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, mpApps.mpExcel, "") = False Then
                    blnFailed = True
                    cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use?" & vbLf & vbLf & dl_PathFile & vbLf & vbLf
                End If
            Else
                blnFailed = True
                cfmmsg = cfmmsg & "Download process not stored, something went wrong: " & vbLf & vbLf & pth & ofn & vbLf & vbLf
            End If
        End If
  
    'send failure notification if nothing was done
        If cfmmsg = "" Then
            blnFailed = True
            cfmmsg = "Error: nothing to do." & vbLf & vbLf
        End If
  
    Else
    'pth doesn't contain any slashes, can't be valid, send failure notification
        blnFailed = True
        cfmmsg = "Error: pth invalid, no slashes."
    End If
Else
'pth not specified, send failure notification
    blnFailed = True
    cfmmsg = "Error: pth not specified, pth is mandatory."
End If


'send confirmation email
'NB: if cfm (optional) not specified, will send confirmation to modEmail.OL_DefaultEmail
If blnFailed = True Then
    Const cNotUsed = " (not used)"
    Const cMandatory = " (Mandatory)"
    Const cOptional = " (Optional)"
    Const cForwinURLOnly = " (NB: currently only tested with Forwin hyperlinks)"
    cfmsub = "Trigger Failed: " & Replace(Item.Subject, "BPMAUTORUN ANYREPORT ", "")
        cfmmsg = cfmmsg & vbLf _
        & vbLf _
        & "Original Message Body:" & vbLf _
        & Item.Body & vbLf _
        & vbLf _
        & "Correct Syntax for Email Body:" & vbLf & vbLf _
        & "|subj=" & Chr(34) & "BPMAUTORUN ANYREPORT FOLDER1 FOLDER2 [Report identification free text]" & Chr(34) & cNotUsed & vbLf _
        & "|pth=" & Chr(34) & "\\SERVER\Share Name\Folder\Subfolder\" & Chr(34) & cMandatory & vbLf _
        & "|ofn=" & Chr(34) & "Filename.ext" & Chr(34) & cOptional & "*" & vbLf _
        & "|dbn=" & Chr(34) & "Database.mdb/.accdb" & Chr(34) & cOptional & vbLf _
        & "|dbm=" & Chr(34) & "DB macro name" & Chr(34) & cOptional & vbLf _
        & "|xls=" & Chr(34) & "UPDATE MACRO.xls/m" & Chr(34) & cOptional & vbLf _
        & "|cfm=" & Chr(34) & "recipient.email@domain.com" & Chr(34) & cOptional & vbLf _
        & "|url=" & Chr(34) & "http://domain.com/folder/file.ext" & Chr(34) & cOptional & vbLf _
        & "|                  (Mandatory, this 'pipe' marks the end of the body text)" & vbLf _
        & vbLf _
        & "NB:" & vbLf _
        & " - UPPER CASE subject controls where completed trigger is filed (i.e. ANYREPORT > UPPER > CASE > Lower case text folder name)" & vbLf _
        & " - pipes | indicate the start of a variable" & vbLf _
        & " - anything on the line after " & Chr(34) & "variabletext" & Chr(34) & " is ignored" & vbLf _
        & " - attachment(s) will be saved to pth automatically" & vbLf _
        & " - ofn cannot be used with multiple attachments" & vbLf _
        & " - Hyperlinks within body text can also be downloaded, e.g.:" & vbLf _
        & "       CSV [hyperlink]" & cForwinURLOnly & vbLf _
        & " * ofn is Mandatory for hyperlink downloads" & vbLf

ElseIf bStoreProc = True Then
    cfmsub = "Procedure Stored: " & Replace(Item.Subject, "BPMAUTORUN ANYREPORT ", "")
    cfmmsg = cfmmsg & vbLf _
        & vbLf _
        & "Original Message Body:" & vbLf _
        & Item.Body

Else
    cfmsub = "Trigger Processed: " & Replace(Item.Subject, "BPMAUTORUN ANYREPORT ", "")
    cfmmsg = cfmmsg & vbLf _
        & vbLf _
        & "Original Message Body:" & vbLf _
        & Item.Body
End If

OL_Simple_Archive Item

OL_SendEmail _
    Email_Recipient:=cfm, _
    Email_RecipientBCC:=OL_DefaultEmail, _
    Email_Subject:=cfmsub, _
    Email_BodyText:=cfmmsg

End Sub

Sub OL_ProcessZIPIT(Item As Outlook.MailItem)
'v6.17 2013-10-31 11:20
'save a copy of attachment [to specified path]
'then zip and email back to sender [OR specified recipient]
'with default subject and body text [OR as specified]

'NB: this text is repeated below and used as body text syntax

' SUBJECT HEADER FOR EMAIL MUST BE ENTERED AS FOLLOWS:
'====================================================================
' BPMAUTORUN ZIPIT [Report identification free text]
'====================================================================

' VARIABLES MUST BE ENTERED IN EMAIL BODY (PLAIN TEXT) AS FOLLOWS:
' BPMAUTORUN variables must be on separate lines, in "quote marks",
' and separated by pipes |
' NB: pattern match looks for e.g. "|pth=" at start and ""|" at end
' all are optional
'====================================================================
'|subj="BPMAUTORUN ZIPIT [Report identification free text]"
'|fwd="email.address@domain.com"
'|pth="\\ServerName\ShareName\Folder\"
'|subj="Subject Header for Email"
'|sbod="Body text for email including signature, use VB character codes"
'|att="Attachment Name.zip"
'====================================================================

Const subjDef As String = "Zipped file attached"
Const sattDef As String = "Attachment.zip"
Dim sbodDef As String
sbodDef = "Please find your zipped attachment." & vbLf _
    & vbLf _
    & "Kind regards," & vbLf _
    & vbLf _
    & "BPM Autoresponder" & vbLf _
    & OL_DefaultEmail & vbLf _
    & vbLf _
    & "SUBJECT HEADER FOR EMAIL MUST BE ENTERED AS FOLLOWS:" & vbLf _
    & "====================================================================" & vbLf _
    & " BPMAUTORUN ZIPIT [Report identification free text]" & vbLf _
    & "====================================================================" & vbLf _
    & vbLf _
    & " VARIABLES MUST BE ENTERED IN EMAIL BODY (PLAIN TEXT) AS FOLLOWS:" & vbLf _
    & " BPMAUTORUN variables must be on separate lines, in " & Chr(34) & "quote marks" & Chr(34) & "," & vbLf _
    & " and separated by pipes |" & vbLf _
    & " NB: pattern match looks for e.g. " & Chr(34) & "|pth=" & Chr(34) & " at start and " & Chr(34) & " at end" & vbLf _
    & " all are optional" & vbLf _
    & "====================================================================" & vbLf _
    & "|subj=" & Chr(34) & "BPMAUTORUN ZIPIT [Report identification free text]" & Chr(34) & " (not used)" & vbLf _
    & "|fwd=" & Chr(34) & "email.address@domain.com" & Chr(34) & vbLf _
    & "|pth=" & Chr(34) & "\\ServerName\ShareName\Folder\" & Chr(34) & "  NB: this UNC share must be accessible to BPM.GB@dhl.com" & vbLf _
    & "|subj=" & Chr(34) & "Subject Header for Email" & Chr(34) & vbLf _
    & "|sbod=" & Chr(34) & "Body text for email including signature, use VB character codes" & Chr(34) & vbLf _
    & "|att=" & Chr(34) & "Attachment Name.zip" & Chr(34) & vbLf _
    & "===================================================================="

Dim pthdefault, pth As String, fwd As String, subj As String, sbod As String
Dim bPathFail As Boolean
Dim oMail As Outlook.MailItem
Set oMail = Application.Session.GetItemFromID(Item.EntryID)
Dim src As String, tgt As String
pth = OL_v_var(oMail, "pth")  'optional
fwd = OL_v_var(oMail, "fwd")  'optional
subj = OL_v_var(oMail, "subj")  'optional
'use defaults if not specified
If fwd = vbNullString Then fwd = oMail.SenderEmailAddress
If subj = vbNullString Then subj = subjDef
If sbod = vbNullString Then sbod = "Dear " & oMail.SenderName & "," & vbLf & vbLf & sbodDef

'check for multiple attachments
If oMail.Attachments.Count > 1 Then
    OL_SendEmail fwd, , OL_DefaultEmail, subj, "ZIPIT Error: cannot process multiple attachments", False
    Exit Sub
End If

'set default path
pthdefault = SpecFolder(CSIDL_PERSONAL) & "\BPM Tools\"
On Error Resume Next
MkDir pthdefault
pthdefault = pthdefault & "ZIPIT\"
MkDir pthdefault
On Error GoTo 0

'pth is optional to save original attachment
If pth <> vbNullString Then
'check the specified path exists and is accessible
    If Dir(pth, vbDirectory) <> "." Then bPathFail = True
Else
    bPathFail = True
End If

If bPathFail = True Then
'pth not specified or doesn't exist, save to default folder
    pth = pthdefault
End If

'save attachment to pth, delete from original email
src = OL_SaveAttachment(oMail, pth)

'set tgt zip in default folder
tgt = pthdefault & sattDef

'zip it
If Zip7Sub(src, tgt, True) <> 0 Then
    OL_SendEmail fwd, , OL_DefaultEmail, subj, "ZIPIT Error: please contact bpm.gb@dhl.com for advice", False
    Exit Sub
End If

'check zip file is below allowable size limit
Dim zAttSize As Long  'MB
zAttSize = FileLen(tgt) / 1048576  '(1024 * 1024)
If zAttSize > (maxAttSize / 1048576) Then
    OL_SendEmail fwd, , OL_DefaultEmail, subj, "ZIPIT Error: maximum attachment size of " & (maxAttSize / 1048576) & "MB exceeded, zip was " & zAttSize & "MB", False
    Exit Sub
End If

'send the email with zipped attachment
OL_SendEmail fwd, , , subj, sbod, False, tgt

'file email in ZIPIT folder
OL_Simple_Archive oMail

'log success at this point?

End Sub

Sub OL_ProcessDATABASE(Item As Outlook.MailItem)
'v6.22 2013-12-02 17:31

'triggers in scope, e.g. "BPMAUTORUN DATABASE MONTHEND"
'also need to replicate code below for new database process
Dim sProcess As String, bDoArchive As Boolean
Const cMONTHEND As String = "MONTHEND"
Const cCRPCRA As String = "CRP/CRA"
Const cGCCSprop As String = "GCCSPROPAGATE"     'v6.16
Const cGCCSreports As String = "GCCSDBREPORTS"  'v6.19
'NB: this doesn't use BPMAUTORUN DATABASE prefix:
Const cLogisFTP As String = "File transfer completed successfully."

Dim oMail As Outlook.MailItem
Set oMail = Application.Session.GetItemFromID(Item.EntryID)

Dim subj As String, rcpt As String, sbody As String, updname As String _
    , olAppObj As Object, WB As Object, logpthfn As String _
    , macroname As String, queryname As String, pthfn As String _
    , t As Single, s As Long

Dim DBIsLocked As Boolean, DBdependents() As String, d As Byte  'v6.22

'Dim logDateTime As String, logPathFile As String, logResult As String
'logResult = False

t = Now()

With oMail
'flag red, cleared later when completed
'NB: different code for Outlook 2007+
If val(Application.Version) < 12 Then
'2003 and before
    .FlagStatus = olFlagMarked
    .FlagIcon = olRedFlagIcon
    .Save
Else
'2007 and later
    .FlagStatus = olFlagMarked
    .FlagIcon = olRedFlagIcon
    .Save
End If
    subj = .Subject
    rcpt = .SenderEmailAddress
    sbody = .Body
End With

'------------------------------------------------------------------------------------------------------------
' Month End database updates (doesn't work on GBMNCWSA050 yet?)
'------------------------------------------------------------------------------------------------------------
sProcess = cMONTHEND
    If InStr(subj, " " & sProcess) > 0 Then
        logpthfn = "C:\Documents and Settings\bpmgb\Documents\MONTHEND log.csv"
        macroname = ") RELOAD ALL"
    'this isn't set yet! need to migrate to shared drive first
        pthfn = "C:\Documents and Settings\All Users\"
        Set olAppObj = XLlaunch(True)
        'do anything else?
        Set WB = olAppObj.Workbooks.Open(pthfn)
        WB.Sheets(1).Range("SelectedQuery").Value = macroname
        WB.Macros.CBDoThisMacro_Click True
        WB.Close SaveChanges:=True
        olAppObj.Quit
        t = CSng(Now() - t)     'time in decimal
        s = t * 60 * 60 * 24    'converts decimal to seconds
        olV_SubmitLog Now(), sProcess, "Processed", s, OL_DefaultEmail, ""
        olAppObj.Quit
        Set olAppObj = Nothing
        bDoArchive = True
        GoTo CleanUp
    End If

'------------------------------------------------------------------------------------------------------------
' Customer Reporting Pack - Customer Revenue Analysis
'------------------------------------------------------------------------------------------------------------
sProcess = cCRPCRA
    If InStr(subj, " " & sProcess) > 0 Then
        d = 2  'v6.22
        ReDim DBdependents(d) As String
        DBdependents(1) = "\\GBMNCWSA050\Databases\Forwin\Shipment Level\Forwin Shipment Level.laccdb"
        DBdependents(2) = "\\GBMNCWSA050\Databases\ComboData\GBSTSWSA030\CoRA.laccdb"
        For d = 1 To d
            If Dir(DBdependents(d)) <> "" Then
                DBIsLocked = True
                Exit For
            Next d
        Next d
        logpthfn = "\\ishare.dhl.com\sites\DGFUK\CR\CRP\CRPCRA trigger log.csv"  'v6.21
        macroname = ""
        updname = "CRP / CRA database"
        If DBIsLocked Then  'v6.22
            olV_SubmitLog Now(), sProcess, "Failed - database(s) locked", 0, , logpthfn
            modEmail.SendEmail rcpt _
                , "DGFUK_CustomerReportingOS@DHL.com; DGFUK_CustomerReportingCT@DHL.com" _
                , OL_DefaultEmail _
                , "GBMNCWSA050 Automated Response: " & updname & " NOT updated" _
                , updname & " could not be updated, as per trigger sent by " & oMail.Sender & ", because a source database is locked (in use).  Please contact bpm.gb@dhl.com for more information before sending another trigger." & vbLf & vbLf _
                    & "Database locked:" & vbLf & DBdependents(d) 'v6.22 'v6.06
        Else
            pthfn = "\\ishare.dhl.com\sites\DGFUK\CR\CRP\CRP Control List v2.xlsm"  'v6.04
            Set olAppObj = XLlaunch(True)
            'do anything else?
            Set WB = olAppObj.Workbooks.Open(FileName:=pthfn, ReadOnly:=True)
            'the following is done automatically in WB
                'wb.Sheets(1).Range("SelectedQuery").Value = macroname
                'wb.Macros.CBDoThisMacro_Click True
                'wb.Close SaveChanges:=True
                'olAppObj.Quit
            t = CSng(Now() - t)     'time in decimal
            s = t * 60 * 60 * 24    'converts decimal to seconds
            olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn
            modEmail.SendEmail rcpt _
                , "DGFUK_CustomerReportingOS@DHL.com; DGFUK_CustomerReportingCT@DHL.com" _
                , OL_DefaultEmail _
                , "GBMNCWSA050 Automated Response: " & updname & " updated" _
                , updname & " updated and CSV updated on iShare, as per trigger sent by " & oMail.Sender  'v6.06
            olAppObj.Quit
            Set olAppObj = Nothing
        End If
        bDoArchive = True  'v6.22: NB: this is necessary otherwise infinite failure loop occurs (until DB is unlocked)
        GoTo CleanUp
    End If

'------------------------------------------------------------------------------------------------------------
' FTP file transfer - reports from Logis  - v6.15
'------------------------------------------------------------------------------------------------------------
sProcess = cLogisFTP
    If InStr(subj, " " & sProcess) > 0 And UCase(rcpt) = "NBC.COMPUTEROPS@DHL.COM" Then
        logpthfn = "\\GBMNCWSA050\Databases\Logis\LogisFTP log.csv"
        If InStr(UCase(sbody), "405 REPORT") > 0 Then
            updname = "Logis 405 database"
            pthfn = "\\GBMNCWSA050\Databases\Logis\405.accdb"
            macroname = "sweep_FTP_for_405()"  'runs VBA function
        End If
        Set olAppObj = run_Access("", pthfn, macroname)
        Set olAppObj = Nothing
        t = CSng(Now() - t)     'time in decimal
        s = t * 60 * 60 * 24    'converts decimal to seconds
        olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn
        modEmail.SendEmail OL_DefaultEmail _
            , _
            , _
            , "GBMNCWSA050 Automated Response: " & updname & " updated" _
            , updname & " updated, as per trigger sent by " & oMail.Sender
        bDoArchive = True
        GoTo CleanUp
    End If

'------------------------------------------------------------------------------------------------------------
' GCCS PROPAGATION  - v6.16
'------------------------------------------------------------------------------------------------------------
sProcess = cGCCSprop
    If InStr(subj, " " & sProcess) > 0 Then
        Sleep 20000  'this is necessary to ensure the upload to iShare is completed by triggerer before running process
        logpthfn = "\\GBMNCWSA050\Databases\GCCS\GCCS user propagation log.csv"
        updname = "GCCS user propagation"
        pthfn = "\\ishare.dhl.com\sites\DGFUK\Admin\GCCS\GCCS Users.xlsm"
        Set olAppObj = run_Excel(XLpth:="", XLfn:=pthfn, rxlOpenReadOnly:=True)
        Set olAppObj = Nothing
        t = CSng(Now() - t)     'time in decimal
        s = t * 60 * 60 * 24    'converts decimal to seconds
        olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn
        modEmail.SendEmail rcpt _
            , _
            , OL_DefaultEmail _
            , "GBMNCWSA050 Automated Response: " & updname & " completed" _
            , updname & " completed, as per trigger sent by " & oMail.Sender
        bDoArchive = True
        GoTo CleanUp
    End If

'------------------------------------------------------------------------------------------------------------
' GCCS DB AND REPORTS - v6.19
'------------------------------------------------------------------------------------------------------------
sProcess = cGCCSreports
    If InStr(subj, " " & sProcess) > 0 Then
        Sleep 20000  'this is necessary to ensure the upload to iShare is completed by triggerer before running process
        logpthfn = "\\GBMNCWSA050\Databases\GCCS\GCCS reports log.csv"
        updname = "GCCS reports update"
        pthfn = "\\GBMNCWSA050\Databases\GCCS\GCCS MASTER v4.xlsm"
        Set olAppObj = run_Excel(XLpth:="", XLfn:=pthfn, rxlOpenReadOnly:=True)
        Set olAppObj = Nothing
        t = CSng(Now() - t)     'time in decimal
        s = t * 60 * 60 * 24    'converts decimal to seconds
        olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn
        modEmail.SendEmail rcpt _
            , _
            , OL_DefaultEmail _
            , "GBMNCWSA050 Automated Response: " & updname & " completed" _
            , updname & " completed, as per trigger sent by " & oMail.Sender
        bDoArchive = True
        GoTo CleanUp
    End If


CleanUp:

If bDoArchive Then
'remove flag and Save
    With oMail
        .FlagStatus = False
        .FlagIcon = False
        .ReminderSet = False
        .UnRead = False
        .Save
    End With  'oMail
    OL_Simple_Archive Item
Else
'send failure notification
    modEmail.SendEmail Email_Recipient:=rcpt, Email_RecipientBCC:=OL_DefaultEmail, Email_Subject:=subj & " failed"
End If

End Sub

Private Function OL_SaveAttachment(Item As Outlook.MailItem _
    , pth As String, Optional ofn As String) As String
'v4.02 2013-08-06 14:49
'saves attachment(s) (requires pth to be set in parent macro)
'if AttCount > 1, renames if ofn specified (doesn't work for ZIP attachments)
'deletes attachment(s) from email ONLY if successful
'ZIP attachments MUST be named "Original Filename.csv.zip" and only contain that one file

Dim OLapp As Outlook.Application
Set OLapp = CreateObject("Outlook.Application")
'Set OLapp = Application

Dim myAttachments As Outlook.Attachments, AttName As String, AttCount As Byte, Att As Byte
Dim objItem As Outlook.MailItem

Dim logDateTime As String, logPathFile As String, logResult As String
logResult = False

Const zext As String = ".zip"

With Item
'flag red, cleared later when completed
'NB: different code for Outlook 2007+
If val(Application.Version) < 12 Then
'2003 and before
    .FlagStatus = olFlagMarked
    .FlagIcon = olRedFlagIcon
    .Save
Else
'2007 and later
    .FlagStatus = olFlagMarked
    .FlagIcon = olRedFlagIcon
    .Save
End If
End With

Set myAttachments = Item.Attachments
AttCount = myAttachments.Count
If AttCount = 0 Then GoTo ResultFalseNoAttachment
On Error GoTo ResultFalseNoAttachment
For Att = 1 To AttCount
    With myAttachments.Item(Att)
        On Error GoTo 0
        logDateTime = CStr(Now())
      
'save attachment as ZIP then unzip and process contents
        If Right(.DisplayName, 4) = zext Then
      
        'attachment name is "Trimmed Text - Report Name.csv.zip"
            logPathFile = pth & .DisplayName
    'On Error Resume Next
            If Dir(logPathFile) <> "" Then Kill logPathFile  'deletes old temporary zip file if still there
    'On Error GoTo 0
    On Error GoTo ResultFalseZipFail
            .SaveAsFile logPathFile
        'saved file is "Trimmed Text - Report Name.ext.zip"
        'extract original file from temporary ZIP
            Zip7Sub pth, logPathFile, False   '=0 is success
    On Error GoTo 0
            Kill logPathFile  'deletes temporary ZIP, no longer required
        'extracted file is now "Report Name.ext" so change logPathFile
            logPathFile = pth & Replace(logPathFile, ".zip", "")
        'logPathFile is now "Report Name.ext"
        'rename logPathFile if ofn specified
        'rename logPathFile if ofn specified
            If ofn <> "" Then
    On Error Resume Next  'only usually fails if file doesn't exist
                Kill pth & ofn
    On Error GoTo 0
    On Error GoTo ResultFalseRenameFail
                Name logPathFile As pth & ofn
    On Error GoTo 0
                OL_SaveAttachment = pth & ofn
            Else
                OL_SaveAttachment = logPathFile
            End If
      
      
'save attachment as original file (not zipped)
        Else
      
        'attachment name is "Trimmed Text - Report Name.ext"
    On Error GoTo ResultFalseSaveFail
            logPathFile = pth & OL_fn_trim(.DisplayName)
            .SaveAsFile logPathFile
        'rename logPathFile if ofn specified
            If ofn <> "" And pth & ofn <> logPathFile Then  'v4.02 was deleting if ofn same filename
            'can only do this for one file
                If AttCount > 1 Then GoTo ResultFalseMultipleAttachmentsRenameFail
    On Error Resume Next
                Kill pth & ofn
    On Error GoTo 0
    On Error GoTo ResultFalseRenameFail
                Name logPathFile As pth & ofn
    On Error GoTo 0
                OL_SaveAttachment = pth & ofn
            Else
                OL_SaveAttachment = logPathFile
            End If
        'saved file is "Report Name.csv"
    On Error GoTo 0
      
        End If
  
    'completed with no errors
        logResult = "Success"
    End With  'Attachment
Next Att

'only gets this far if no errors (including writing to log)
With Item
'remove flag and save
    .FlagStatus = False
    .FlagIcon = False
    .ReminderSet = False
    .UnRead = False
    .Save  'is this required? probably not - saves during move step
'remove attachment and move to relevant folder
    OL_Simple_Archive Item
End With

GoTo ResultSubmit

ResultFalseNoAttachment:
logResult = "Failure: report not attached to email"
GoTo ResultSubmit

ResultFalseZipFail:
logResult = "Failure: ZIP attachment " & Att & " could not be saved/unzipped"
GoTo ResultSubmit

ResultFalseMultipleAttachmentsRenameFail:
logResult = "Failure: multiple (" & AttCount & ") attachments, cannot be renamed to " & ofn
GoTo ResultSubmit

ResultFalseRenameFail:
logResult = "Failure: saved attachment " & Att & " could not be renamed to " & ofn
GoTo ResultSubmit

ResultFalseSaveFail:
logResult = "Failure: CSV attachment " & Att & " could not be saved"
GoTo ResultSubmit

ResultFalseAttDelFail:
logResult = "Failure: attachment " & Att & " could not be removed"
GoTo ResultSubmit


ResultSubmit:
On Error GoTo 0
'report success/failure to log file
olV_SubmitLog logDateTime, logPathFile, logResult


'myOlApp.Quit
'Set myOlApp = Nothing

End Function

Private Function OL_fn_trim(ByVal DisplayName As String) As String
'v2.04 2012-11-08 09:19
'removes any of specified strings from attachment filename
'(could use Replace function instead)

'specify TOTAL strings to remove
Const smax As Byte = 2
Dim sr(1 To smax) As String, s As Byte, is_pos As Byte, sr_len As Byte
'specify each string to remove
sr(1) = "Lookups - "
sr(2) = " en"

OL_fn_trim = DisplayName
For s = 1 To smax
    sr_len = Len(sr(s))
    is_pos = InStr(OL_fn_trim, sr(s))
    If is_pos = 0 Then
    'sr(s) not found in OL_fn_trim
        Exit For
    Else
    'remove sr(s) from OL_fn_trim
        OL_fn_trim = Left(OL_fn_trim, is_pos - 1) & Mid(OL_fn_trim, is_pos + sr_len, Len(OL_fn_trim))
    End If
Next s

End Function

Private Function OL_v_URL(ByVal Item As Outlook.MailItem) As String
'v6.09 2013-09-20 13:00
'extracts "|url="http://specificurl.com/filename.ext"
' --> if not found, tries to extract "HYPERLINK " from plain text email
' --> if not found, extracts <a href="url"> from HTML (not tested)

'first check for user-specified URL variable, quit if found
OL_v_URL = OL_v_var(Item, "url")
If OL_v_URL <> "" Then Exit Function

Dim a As Long, b As Long, c As Integer, sbody As String
Const ptnHLNK As String = "HYPERLINK """
Const ptnHEnd As String = """" 'was """CSV", file type suffix is not relevant, just look for quot mark after URL
Const ptnATag As String = "<a href="""
Const ptnAEnd As String = """>"
Const ptnHTTP As String = "http"  'need this to validate HTML hyperlink extraction.  NB: may be http:// or https:// in valid URL
Const ptnFwin As String = "https://forwin.dhl.com/cognos8/cgi-bin/cognosisapi.dll"  'prefix added to "?b=" shortened URL

'extract URL from Body Text, quit if found
sbody = Item.Body
a = InStr(sbody, ptnHLNK)  'finds FIRST hyperlink, Forwin always adds this to end
If a > 0 Then
    c = a
    Do Until c = 0
        c = InStr(a + 1, sbody, ptnHLNK) 'finds NEXT hyperlink, Forwin always adds to END
        If c <> a And c <> 0 Then a = c
    Loop
    a = a + Len(ptnHLNK)
    b = InStr(a, sbody, ptnHEnd)
    c = b - a
    OL_v_URL = Mid(sbody, a, c)
End If
If OL_v_URL <> "" And Left(OL_v_URL, Len(ptnHTTP)) = ptnHTTP Then Exit Function  'second test helps when re-sending email to yourself, Outlook will convert UNC into hyperlinks

'extract URL from HTML links, quit if found - v6.09
sbody = Item.HTMLBody
a = InStr(sbody, ptnATag)
If a > 0 Then
'HTML A tag found
    c = a
    Do Until c = 0  'find LAST hyperlink, Forwin always adds to end
        c = InStr(a + 1, sbody, ptnATag) 'finds NEXT hyperlink
        If c <> a And c <> 0 Then a = c
    Loop
    a = a + Len(ptnATag)
    b = InStr(a, sbody, ptnAEnd)
    c = b - a
    OL_v_URL = Mid(sbody, a, c)
    'URL from Forwin sometimes excludes Forwin site DLL location for report downloads, so add that manually
    If Left(OL_v_URL, Len(ptnHTTP)) <> ptnHTTP Then
        OL_v_URL = ptnFwin & OL_v_URL
    End If
    'cleanup
    OL_v_URL = Replace(OL_v_URL, "&amp;", "&")
End If

End Function

Private Function OL_v_var(ByVal Item As Outlook.MailItem _
    , ByVal vvar As String) As String
'v6.09 2013-09-20 12:17
'retrieves specified variable from email body text
'vvar is "pth", will be amended to "|pth="
'variable must be surrounded by quote marks, i.e. |pth="http://somepath"
'returns no string if vvar not found

Dim iStartQuot As Integer, iEndQuot As Integer, iNextPipe As Integer
Dim btxt As String  'bodytext
Dim oMail As Outlook.MailItem
Set oMail = Application.Session.GetItemFromID(Item.EntryID)
btxt = oMail.Body
Const vpipe As String = "|"  'Chr(124)
Const vequa As String = "="  'Chr(61)
Const vquot As String = """" 'Chr(34)
Const ptnHLNK As String = "HYPERLINK """
Const ptnFILE As String = "file:///"
vvar = vpipe & vvar & vequa & vquot  'now searching for "|pth=" not "pth"

iStartQuot = InStr(btxt, vvar)  'position of vvar
If iStartQuot = 0 Then
'error, variable with pipe "|pth=" not found, exit
    OL_v_var = vbNullString
    Exit Function
End If

iStartQuot = iStartQuot + Len(vvar)  'position AFTER opening vquot (marks start of variable)
If Mid(btxt, iStartQuot, Len(ptnHLNK)) = ptnHLNK Then 'v6.09 workaround for forwarding triggers to retrigger, b/c Outlook converts UNC pth to hyperlink
    iStartQuot = iStartQuot + Len(ptnHLNK)
End If
iEndQuot = InStr(iStartQuot + 1, btxt, vquot)   'vEnd = position of NEXT vquot AFTER vvar (marks end of variable)
iNextPipe = InStr(iStartQuot + 1, btxt, vpipe)  'position of next pipe (for validity check)

If iEndQuot = 0 Or (iNextPipe > 0 And iEndQuot > iNextPipe) Then
'error, variable not surrounded by "", exit
    OL_v_var = vbNullString
    Exit Function
End If

OL_v_var = Replace(Mid(btxt, iStartQuot, iEndQuot - iStartQuot), ptnFILE, "")  'v6.09 workaround for forwarding triggers to retrigger, b/c Outlook converts UNC pth to hyperlink

End Function

Function OL_GetCurrentItem() As Object
'source: http://www.outlookcode.com/article.aspx?id=49
  
    Dim objApp As Outlook.Application
    Set objApp = Application
  
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set OL_GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set OL_GetCurrentItem = objApp.ActiveInspector.CurrentItem
        Case Else
            ' anything else will result in an error, which is
            ' why we have the error handler above
    End Select
  
    Set objApp = Nothing

End Function

Sub OL_Simple_Archive(Item As Outlook.MailItem)
'v6.10 2013-09-23 10:36
'puts email in folder according to email subject, deletes attachment(s), marks read & flags complete
'NB: Outlook rule should be set to prevent email replies on this subject from being processed this way

Dim OLapp As Outlook.Application
'Set OlApp = CreateObject("Outlook.Application")
Set OLapp = Application

Dim objNS As Outlook.NameSpace, objFolder As Outlook.MAPIFolder, ParentFolder As Outlook.MAPIFolder
Set objNS = OLapp.GetNamespace("MAPI")
Set objFolder = objNS.Folders(OL_MYmbx).Folders("Inbox")

Dim blnFolderCreated As Boolean

'identify subfolder from CAPITALISED SUBJECT PREFIX
'e.g. "BPMAUTORUN ANYREPORT FORWIN MAPPING Free Text" goes in BPMAUTORUN > ANYREPORT > FORWIN > MAPPING > Free Text
Dim subj As String, s As Integer, olFolderName As String, CapturePrefix As String

Dim oMail As Outlook.MailItem
Set oMail = Application.Session.GetItemFromID(Item.EntryID)
subj = SP_fn_val(oMail.Subject, "")  'v6.10 fixes issue with slash etc. in folder name

'capture "Report: " (generic scheduled reports)
    CapturePrefix = "Report: "
    If InStr(subj, CapturePrefix) Then
    'create/use FOLDERNAME
        olFolderName = "REPORTS"
        Set ParentFolder = objFolder
        blnFolderCreated = OL_Create_objFolder(olFolderName, ParentFolder)
        If blnFolderCreated = True Then Set ParentFolder = Nothing
        Set objFolder = ParentFolder.Folders(olFolderName)
        subj = Mid(subj, Len(CapturePrefix) + 1, Len(subj))
    End If

s = InStr(subj, " ")
Do While s > 0
    s = InStr(subj, " ")  'v6.09 bugfix for 1-word subfolders e.g. "ANYREPORT FORWIN TSP Routing"
    If s = 0 Then s = Len(subj) + 1
    olFolderName = Left(subj, s - 1)
    If OL_UpperCase(olFolderName) Then
    'create/use FOLDERNAME
        Set ParentFolder = objFolder
        blnFolderCreated = OL_Create_objFolder(olFolderName, ParentFolder)
        If blnFolderCreated = True Then Set ParentFolder = Nothing
        Set objFolder = objFolder.Folders(olFolderName)
        If olFolderName = "DATABASE" Then Exit Do  'v6.10 bugfix for v6.09 doing DATABASE triggers
        subj = Mid(subj, s + 1, Len(subj))
    Else
    'finished extracting CAPSFOLDERNAMES, use remaining free text as destination folder
        olFolderName = subj
        Set ParentFolder = objFolder
        blnFolderCreated = OL_Create_objFolder(olFolderName, ParentFolder)
        If blnFolderCreated = True Then Set ParentFolder = Nothing
        Set objFolder = objFolder.Folders(olFolderName)
        s = 0
    End If
Loop

Set oMail = Nothing

'delete any attachments from mail (saves on mailbox storage)
Dim AttCount As Byte, Att As Byte
On Error Resume Next
If Item.Attachments.Count > 0 Then
    For Att = 1 To Item.Attachments.Count
        Item.Attachments.Item(Att).Delete
    Next Att
End If
On Error GoTo 0


'mark unread, flag complete, move to specified subfolder
With Item
On Error Resume Next
    .UnRead = False
    .FlagStatus = olFlagComplete
    .Save
    .Move objFolder  'on error, check whether blnFolderCreated is True/False, usually False means it already exists!
On Error GoTo 0
End With

End Sub

Private Function OL_Create_objFolder(FolderName As String _
    , Optional ParentFolder As Outlook.MAPIFolder) As Boolean
'v2.11 2013-01-10 13:15

Dim olOutlook As Outlook.Application

On Error GoTo ErrorHandler
Set olOutlook = Application
'if using outside Outlook e.g. within Excel:
'Set olOutlook = CreateObject("Outlook.Application")
If ParentFolder Is Nothing Then
    Dim ns As Outlook.NameSpace
    Set ns = olOutlook.GetNamespace("MAPI")
    Set ParentFolder = ns.GetDefaultFolder(olFolderInbox)
End If
ParentFolder.Folders.Add FolderName
On Error GoTo 0

Set olOutlook = Nothing
Set ns = Nothing
Set ParentFolder = Nothing

OL_Create_objFolder = True
Exit Function

ErrorHandler:
On Error GoTo 0
OL_Create_objFolder = False

End Function

Private Function OL_UpperCase(stringToCheck As String) As Boolean
'v3.03 2013-07-19 18:21
'source: http://www.freevbcode.com/ShowCode.asp?ID=5198
    OL_UpperCase = StrComp(stringToCheck, UCase(stringToCheck), vbBinaryCompare) = 0
End Function

Private Function OL_LowerCase(stringToCheck As String) As Boolean
'v3.03 2013-07-19 18:21
'source: http://www.freevbcode.com/ShowCode.asp?ID=5198
    OL_LowerCase = StrComp(stringToCheck, LCase(stringToCheck), vbBinaryCompare) = 0
End Function

Function olV_SubmitLog(ByVal logDateTime As String, ByVal logPathFileProcessed As String _
    , ByVal logResult As String _
    , Optional ByVal logTimeTaken As Integer, Optional ByVal logRecipientEmail As String _
    , Optional ByVal logToPathFilename As String)
'v6.22 2013-12-02 17:14
'also sends email to administrator/triggerer on success/failure

If logToPathFilename = "" Then logToPathFilename = LogFolder & LogFileName  'default log file location, unless specified
'commented, v6.04 creates log
'If Dir(logToPathFilename) = vbNullString Then MsgBox "CSV not found at " & logToPathFilename

On Error Resume Next

Dim logmsg(1 To 5) As String
logmsg(1) = Chr(34) & logDateTime & Chr(34) & ","   'timestamp
logmsg(2) = Chr(34) & logPathFileProcessed & Chr(34) & ","   'file that succeeded/failed, required, but can be "" if not relevant
logmsg(3) = Chr(34) & logResult & Chr(34) & ","     'result
If logTimeTaken > 0 Then logmsg(4) = logTimeTaken & "," Else logmsg(4) = ","      'time taken in seconds
If logRecipientEmail <> "" Then logmsg(5) = Chr(34) & logRecipientEmail & Chr(34)      'trigger sender (if specified)

'append log file (CSV)
Dim echostring As String
If Dir(logToPathFilename) = "" Then
    echostring = "cmd /c echo " _
        & """Date"",""Routine"",""Result"",""Duration"",""Triggered By Email""" _
        & " >> " _
        & Chr(34) & logToPathFilename & Chr(34)
    Shell echostring, vbHide
    Dim p As Byte
    Do While Dir(logToPathFilename) = "" And p < 100
        Sleep 100   'v6.04 waits to create logToPathFilename
        p = p + 1   'v6.04 stops infinite loop
    Loop
End If

logToPathFilename = Chr(34) & logToPathFilename & Chr(34)  'adds speech marks for CSV and result notification

If p < 100 Then
    echostring = "cmd /c echo " _
        & logmsg(1) _
        & logmsg(2) _
        & logmsg(3) _
        & logmsg(4) _
        & logmsg(5) _
        & " >> " _
        & logToPathFilename
    Shell echostring, vbHide
Else  'v6.04, couldn't add to log
    logToPathFilename = logToPathFilename & vbLf & "NB: couldn't create log, check this path is correct"
End If

'send result email
If logRecipientEmail <> "" Then
    OL_SendEmail logRecipientEmail, "", OL_MYmbx, "GBMNCWSA050 Automated Response: " & logPathFileProcessed & " " & logResult, "The triggered update request is now completed.  Result: " & logResult & vbLf & vbLf & logToPathFilename, False
End If

'On Error GoTo 0  'only required if causing problems

End Function

Sub OL_test()

With OL_GetCurrentItem
'flag as Completed and Save
    .FlagStatus = False
    .FlagIcon = False
    .ReminderSet = False
    .UnRead = False
    .Save
End With

End Sub

Function OL_SendEmail(ByVal Email_Recipient As String, Optional ByVal Email_RecipientCC As String _
    , Optional ByVal Email_RecipientBCC As String, Optional ByVal Email_Subject As String _
    , Optional ByVal Email_BodyText As String, Optional ByVal DisplayMsg As Boolean = False _
    , Optional AttachmentPath) As Byte
'code matched to modEmail.SendEmail
'v1.06 2013-09-02 10:56
'results: 0=success, 1=fail
'original source: http://support.microsoft.com/kb/161088
'v1.05 bugfix: http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients

On Error GoTo SendEmailError

Dim objOutlook As Object        'Outlook.Application
'Dim objOutlookMsg 'As Object     'Outlook.MailItem
Dim objOutlookRecip As Object   'Outlook.Recipient
Dim objOutlookAttach As Object  'Outlook.Attachment
'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients
Dim EmailList As Variant, NumEmails As Long, AddEmailLoop As Long

' Create the Outlook session.
If InStr(Application.Name, "Outlook") = 0 Then
    Set objOutlook = CreateObject("Outlook.Application")
Else
    Set objOutlook = Application
End If

' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem
Set objOutlook = objOutlook.CreateItem(0) 'olMailItem

'With objOutlookMsg
With objOutlook
    ' Add the To recipient(s) to the message.
    If Email_Recipient = "" Then
        Set objOutlookRecip = .Recipients.Add(cDefaultEmail)  'for testing/blunt force only
    Else
    'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients
        Email_Recipient = Replace(Email_Recipient, ";", "; ")  'v1.06
        EmailList = Split(Email_Recipient, ";")
        NumEmails = UBound(EmailList)
        For AddEmailLoop = 0 To NumEmails
            Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))
            objOutlookRecip.Type = 1 'olTo
            objOutlookRecip.Resolve
        Next
    End If

    ' Add the CC recipient(s) to the message.
    If Email_RecipientCC <> "" Then
        Email_RecipientCC = Replace(Email_RecipientCC, ";", "; ")  'v1.06
        EmailList = Split(Email_RecipientCC, "; ")
        NumEmails = UBound(EmailList)
        For AddEmailLoop = 0 To NumEmails
            Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))
            objOutlookRecip.Type = 2 'olCC
            objOutlookRecip.Resolve
        Next
    End If
  
   ' Add the BCC recipient(s) to the message.
    If Email_RecipientBCC <> "" Then
        Email_RecipientBCC = Replace(Email_RecipientBCC, ";", "; ")  'v1.06
        EmailList = Split(Email_RecipientBCC, "; ")
        NumEmails = UBound(EmailList)
        For AddEmailLoop = 0 To NumEmails
            Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))
            objOutlookRecip.Type = 3 'olBCC
            objOutlookRecip.Resolve
        Next
    End If

   ' Set the Subject, Body, and Importance of the message.
   .Subject = Email_Subject
   .Body = Email_BodyText & vbCrLf & vbCrLf
   .Importance = 2  'olImportanceHigh  'High importance

   ' Add attachments to the message.
   If Not IsMissing(AttachmentPath) Then
       Set objOutlookAttach = .Attachments.Add(AttachmentPath)
   End If

   ' Resolve each Recipient's name.  'v1.06 now resolved separately on addition
'   For Each objOutlookRecip In .Recipients
'       objOutlookRecip.Resolve
'   Next

   ' Should we display the message before sending?
   If DisplayMsg Then
       .Display
   Else
       .Save
       .Send
   End If
End With

Set objOutlook = Nothing
OL_SendEmail = 0  'no error
Exit Function

SendEmailError:
OL_SendEmail = 1  'general failure
End Function