Monday 5 August 2013

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

No comments:

Post a Comment