Monday 5 August 2013

VBA Modules: modAppsOffice v4.08

Read this for full information on these modules

modAppsOffice is a module I use all the time.  It has a few simple but endlessly useful functions for launching Access and Excel, and running SQL/Access macros/queries.  I probably haven't developed this one as much as I could have, but my needs are fairly simple!  I prefer to handle more complicated requirements within Excel using the Workbook_Open event to launch other custom macros.

This makes use of modKeyState by Chip Pearson - included within the module as of v4.

'modAppsOffice
'v4.08 2013-11-06 13:26

'===========================================================================
' 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 v3.14 or later
'*************************************************************

'********************************************
'****  two settings to be changed below  ****
'********************************************

'===========================================================================
' modAppsOffice
'===========================================================================
'   Routines for launching MS Office applications, opening files, running
'   macros, etc.  Requires application reference libraries to be enabled
'   via Tools > References ONLY if you are running from a different Office
'   application (e.g. launching Excel from Access).  Enabling unnecessary
'   libraries will cause no harm.

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

'===========================================================================
' Additional References required:
'===========================================================================
'   None

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

'=========================================================================
' VERSION HISTORY
'=========================================================================
'   v4.08   run_Excel: bugfix in error handler
'   v4.07   run_Excel: added bForceVisibility (defaults to maoVisibleByDefault)
'           run_Excel: added bForceVisibility
'           XL_launch: changed XLvisible to bForceVisibility
'   v4.06   mao_fix_path bugfix when pth includes fn
'   v4.05   run_Access: permits use of VB "function()" as DBmacro
'                       strQuery variable relabelled as SQLcommand
'   v4.04   run_Access/run_Excel: persistence bugfix
'   v4.03   run_Excel: RunNative bugfix
'   v4.02   run_Access/run_Excel error handlers (Not DBapp/XLapp Is Nothing)
'   v4.01   retired runOutlook_SendMail, use modEmail instead
'   v4.00   added optional SharePoint domain to check when opening XL_WB
'   v3.18   maoVisibleByDefault set Public for use with other modules
'           XLlaunch: visibility bugfix
'   v3.17   run_Excel: can specify Read-Only (rxlOpenReadOnly)
'   v3.16   run_Excel: determine Read-Only/Editable from iShare/not
'   v3.15   late bound references
'   v3.14   changed Access.Application to Object, fixes Debug issue for
'           users without MS Access installed - OL and XL still required
'*************************************************************
'   v3.13   minor bugfix in run_Excel (just saves a little time)
'   v3.12   MAJOR BUGFIX in XLlaunch
'*************************************************************
'!! v3.11   fixed persistent DBapp and XLapp issue (Objects set Public)
'           moved to GBMNCWSA050, annotations changed
'   v3.10a  MAJOR BUGFIX mao_fix_path
'*************************************************************
'!! v3.10   FAULTY mao_fix_path adds the last slash to paths
'*************************************************************
'   v3.09   annotations improved, no functional change
'   v3.08   run_AppName application objects changed to AppName.Application
'           runOutlook_SendMail tested in 2010
'           ** DOESN'T WORK IN OFFICE 2003 **
'   v3.07   run_Access changed to function (so XLapp, DBapp not required)
'   v3.03   runOutlook_SendMail sSubject, sRecipient, sBodyText, [DisplayFirst], [sAttach_pthfn1], [sAttach_pthfn2]
'   v2.xx   run_Excel XLpth, XLfn, [XLmacro], [RunNative], [LeaveOpenWhenDone](v2.09), [OpenOnly](v3.03)
'   v1.xx   run_Access DBpath, DBfn, [DBmacro], [DBquery], [strQuery], [LeaveOpenWhenDone](v2.09), [OpenOnly](v3.03)

Option Explicit
'References must be enabled via Tools > References
'Public prevents app always closing when macro ends
'--> must Set XXapp = Nothing to clean up
Public DBapp As Object 'Access.Application  'requires Access object library
Public OLapp As Object 'Outlook.Application 'requires Outlook object library
Public XLapp As Object 'Excel.Application   'requires Excel object library

'********************************************
'****  two settings to be changed below  ****
'********************************************

Public Const maoVisibleByDefault As Boolean = True  'v3.18 set public for use with other modules
    'set this to False for background-only operations

Private Const SP_domain As String = "ishare.dhl.com"
    'SharePoint domain, optional, "" if not required

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

Function run_Access(ByVal DBpath As String, ByVal DBfn As String _
    , Optional ByVal DBmacro As String _
    , Optional ByVal DBquery As String _
    , Optional ByVal SQLcommand As String _
    , Optional ByVal LeaveOpenWhenDone As Boolean _
    , Optional ByVal OpenOnly As Boolean _
    , Optional ByVal bForceVisibility As Boolean = maoVisibleByDefault) _
    As Object 'v3.14 was Access.Application  'v3.08 requires Microsoft Access object library via Tools > References
'v4.07 2013-11-04 14:04
'runs Access and opens DB [then runs Query OR Macro OR SQL command]

'DBpath   = "C:\JBA\"
DBpath = mao_fix_path(DBpath)  'v3.10
'DBfn   = "JBA G7 Detail.mdb"
'DBmacro  = "macro name 1"
'DBquery  = "query name 1"
'SQLcommand = "SELECT stuff FROM table WHERE this"

Set DBapp = Nothing  'v4.04

Dim strcount As Byte, pp As String, tt As String
Dim InXL As Boolean 'v3.07, v3.11
If InStr(Application.Name, "Excel") > 0 Then InXL = True
If InXL = True Then
    Set XLapp = Application  'v3.07
    XLapp.DisplayAlerts = False  'v3.07
End If

strcount = 0
tt = "FATAL ERROR"
pp = "Warning: can only process DBmacro OR DBquery OR SQLcommand." & vbLf
If DBmacro <> "" Then
    strcount = strcount + 1
    pp = pp & " - specified DBmacro " & DBmacro & vbLf
End If
If DBquery <> "" Then
    strcount = strcount + 1
    pp = pp & " - specified DBquery " & DBquery & vbLf
End If
If SQLcommand <> "" Then
    strcount = strcount + 1
    pp = pp & " - specified SQLcommand " & SQLcommand & vbLf
End If
If (strcount = 0 And OpenOnly = False) _
Or strcount > 1 Then
    MsgBox pp, , tt
    Exit Function
End If

Set run_Access = CreateObject("Access.Application")

On Error GoTo ErrorHandler  'leaves DBapp <> Nothing on error

With run_Access
    .Visible = bForceVisibility
'errors here means DBpath or DBfn is wrong
    .OpenCurrentDatabase DBpath & DBfn
'errors here could mean Excel Connection is not Read-Only
'solution here:   http://social.msdn.microsoft.com/Forums/en/sqlintegrationservices/thread/d03e4b1a-6be0-4b3c-8b31-42d6fc79bf39
    If OpenOnly = False Then
        If DBmacro <> "" Then
        'OL macro fails here doing Append macro - works when rerun - add a 2 second delay?
        'Application.Wait Val(Now() + TimeSerial(0, 0, 5))
            If Right(DBmacro, 2) = "()" Then  'v4.05 runs VB function or DB macro as required
            'DBmacro ends with "()", run VB function
                DBmacro = Left(DBmacro, Len(DBmacro) - 2)  'remove "()" from function name
                run_Access.Run DBmacro
            Else
            'run DB macro
                .DoCmd.RunMacro DBmacro
            End If
        ElseIf DBquery <> "" Then
            .DoCmd.OpenQuery DBquery
        ElseIf SQLcommand <> "" Then
            .DoCmd.RunSQL SQLcommand
        End If
    End If
    If maoVisibleByDefault = False Then
        .Visible = OpenOnly
    End If
    If OpenOnly = False And LeaveOpenWhenDone = False Then
        .CloseCurrentDatabase
        .Quit
        Set run_Access = Nothing
    Else
        If DBapp Is Nothing Then Set DBapp = run_Access 'Else MsgBox "Cannot persist >1 instance of Access"  'v3.11
        Set run_Access = Nothing
        .Visible = True
        Set XLapp = Nothing
        Exit Function  'v4.04 stops Access quitting
    End If
End With

ErrorHandler:   'leaves DBapp <> Nothing

Set DBapp = run_Access

If InXL = True Then
    XLapp.DisplayAlerts = True  'v3.07
End If

Set XLapp = Nothing

End Function

Function run_Excel(ByVal XLpth As String, ByVal XLfn As String _
    , Optional ByVal XLmacro As String _
    , Optional ByVal RunNative As Boolean _
    , Optional ByVal LeaveOpenWhenDone As Boolean _
    , Optional ByVal rxlOpenReadOnly As Boolean = False _
    , Optional ByVal bForceVisibility As Boolean = maoVisibleByDefault) _
    As Object
'v4.08 2013-11-06 13:26
'simply runs Excel and opens WB  [then runs macro] --> will run XLmacro when opened, if optional macro name specified
'WB should normally have macros that run on Workbook.Open
'v3.16 uses xlSharePoint, such files are ALWAYS opened Read-Only to allow automation and bypass message boxes
'otherwise use IsShiftKeyDown=True and Application.Wait to allow users to bypass any autoroutines

If RunNative = False Then Set XLapp = Nothing  'v4.04

On Error GoTo ErrorHandler  'leaves XLapp <> Nothing on error

If XLpth <> "" Then XLpth = mao_fix_path(XLpth)  'v3.13

Dim WB As Object  'Excel.Workbook  v3.15
Set run_Excel = XLlaunch(LeaveOpenWhenDone, RunNative) 'v4.03

With run_Excel
    .Visible = bForceVisibility  'v4.07
    .DisplayAlerts = False
    If XLmacro <> vbNullString Then
    'open WB, run macro
        Set WB = .Workbooks.Open(XLpth & XLfn)
        .Run XLmacro
    On Error Resume Next  'prevents errors where ThisWorbook closes automatically
        If LeaveOpenWhenDone = False Then .Close SaveChanges:=True
    On Error GoTo 0
    Else
    'macro(s) will autorun on Workbook.Open
        If SP_domain <> "" And (InStr(XLpth, SP_domain) > 0 Or InStr(XLfn, SP_domain) > 0) Then
        'always open RO from SharePoint (prevents issues with CheckIn and can dictate automation when opened Read-Only)
            .Workbooks.Open FileName:=XLpth & XLfn, ReadOnly:=True
        Else
        'always open writeable from shared drive (unless rxlOpenReadOnly is specified)
            .Workbooks.Open FileName:=XLpth & XLfn, ReadOnly:=rxlOpenReadOnly
        End If
    On Error Resume Next  'prevents errors where ThisWorbook closes automatically
        If LeaveOpenWhenDone = True Then .ActiveWorkbook.Close SaveChanges:=True
    On Error GoTo 0
    End If
    .DisplayAlerts = False
    On Error Resume Next  'prevents errors where Excel closes automatically
        If LeaveOpenWhenDone = False Then
            .Quit
            Set run_Excel = Nothing
        Else
            .Visible = True
        End If
    On Error GoTo 0
End With
Exit Function 'v4.08

ErrorHandler:
On Error Resume Next  'v4.08
run_Excel.Visible = True  'v4.07
Set XLapp = run_Excel

End Function

Function XLlaunch(Optional ByVal bForceVisibility As Boolean = maoVisibleByDefault _
    , Optional RunNative As Boolean = False) _
    As Object
'v4.07 2013-11-04 14:04

Dim InXL As Boolean
If InStr(Application.Name, "Excel") > 0 Then InXL = True 'v3.12

If RunNative = True And InXL = True Then
    Set XLlaunch = Application
Else
    Set XLlaunch = CreateObject("Excel.Application")
    XLlaunch.Visible = bForceVisibility
End If

End Function

Function mao_fix_path(ByVal pth As String) As String
'v4.06 2013-10-31 11:32
'adds the relevant last slash to the path, if missing, and if not including .accdb/.mdb/.xl

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

If InStr(pth, ".xl") > 0 Or InStr(pth, ".accdb") > 0 Or InStr(pth, ".mdb") > 0 Then
    mao_fix_path = pth
ElseIf InStr(pth, cBsl) > 0 And Right(pth, 1) <> cBsl Then
    mao_fix_path = pth & cBsl
ElseIf InStr(pth, cFsl) > 0 And Right(pth, 1) <> cFsl Then
    mao_fix_path = pth & cFsl
Else
    mao_fix_path = pth
End If

End Function



'Sub runOutlook_SendMail(sSubject As String, sRecipient As String _
'    , sBodyText As String, DisplayFirst As Boolean _
'    , Optional sAttach_pthfn1 As String _
'    , Optional sAttach_pthfn2 As String)
'retired v4.01 2013-08-21 16:27
'
'legacy code:
'modEmail.SendEmail sRecipient, "", "", sSubject, sBodyText, DisplayFirst, sAttach_pthfn1
'
''v3.15 2013-07-10 12:25
''*** DOESN'T WORK IN OFFICE 2003? *** tested OK in 2010
'' - haven't bypassed Outlook virus protection so will ask for permission?
'' - can only attach max 2 files, need to change this to allow more
'
''Syntax:
''  SendMail "My email with attachment", "name@host.com", "Here is an email", False, "c:\test.txt"
''source: http://www.vbaexpress.com/kb/getarticle.php?kb_id=758
'
'    Dim olMail As Object  'Outlook.MailItem
'    Dim blRunning As Boolean
'
'     'get application
'    blRunning = True
'    On Error Resume Next
'    Set OLapp = GetObject(, "Outlook.Application")
'    If OLapp Is Nothing Then
'        Set OLapp = CreateObject("Outlook.Application")
'        blRunning = False
'    End If
'    On Error GoTo 0
'
'    Set olMail = OLapp.CreateItem(0)  '0=olMailItem, see http://www.ozgrid.com/forum/showthread.php?t=148735
'    With olMail
'         'Specify the email subject
'        .Subject = sSubject
'         'Specify who it should be sent to
'         'Repeat this line to add further recipients
'        .Recipients.Add sRecipient
'         'specify the file to attach
'         'repeat this line to add further attachments
'        If sAttach_pthfn1 <> vbNullString Then
'            .Attachments.Add sAttach_pthfn1
'            If sAttach_pthfn2 <> vbNullString Then
'                .Attachments.Add sAttach_pthfn2
'            End If
'        End If
'         'specify the text to appear in the email
'        .Body = sBodyText
'         'Choose which of the following 2 lines to have commented out
'        If DisplayFirst = True Then
'            .Display 'This will display the message for you to check and send yourself
'        Else
'            .Send ' This will send the message straight away
'        End If
'    End With
'
'    If Not blRunning Then OLapp.Quit
'
'    Set OLapp = Nothing
'    Set olMail = Nothing
'
'End Sub

No comments:

Post a Comment