IsFileOpen

If you ever need to determine if a file is already open before you attempt to do something with it in VBA, you will discover a blistering array of code segments on the interweb which all seem to share the characteristic that: they fail to work as advertised.

So time for me to add my version and I can state that it absolutely works except where the opening application fails to lock the file. AFAIK, that comment applies to text files opened in Notepad and any file opened with an Office application that has its read-only attribute set. However, since the main reason for testing if a file is already open is so that you can do stuff to it without it causing a "file is already in use" type of error, these two conditions don't matter since they don't stop you doing anything with the file. If you don't believe me, try this:

• Create an Excel file "test.xls"
• In Windows Explorer right click on the file and mark it as "read-only"
• Open the file in Excel
• Now go back to Windows Explorer and delete the file
• Voila! No problem since it was read-only, Excel opened a temporary copy of the file and so you do stuff to the original without it causing any problems.

Now, back to the problem: how do you tell if a given file is in use?
Answer: use the VBA "open" statement to exclusively open the file and trap any errors that may occur. We have to go one further though as the "open" statement will not see any hidden files and will act as though they don't exist. To overcome this we make some attribute changes and trap any errors that may occur in relation to them as well. See code below.

Public Function IsFileOpen(ByVal strFullPathFileName As String) As Boolean

   ' Attempting to open a file for ReadWrite that exists will fail
   ' if someone else has it open.  We also have to guard against the
   ' errors that occur if the file has uncommon file attributes such as
   ' 'hidden' which can upset the Open statement.
   ' NOTE: any open that doesn't lock the file such as opening a .txt file
   ' in NotePad or a read-only file open will return False from this call.

   Dim lngFile                    As Long
   Dim intAttrib                  As Integer

   On Error Resume Next
   intAttrib = GetAttr(strFullPathFileName)
   If Err <> 0 Then
       ' If we can't get these then it means the file name is
       ' invalid, or the file or path don't exist so no problem
       IsFileOpen = False
       Exit Function
   End If

   SetAttr strFullPathFileName, vbNormal
   If Err <> 0 Then
       ' An error here means that the file is open and the attributes
       ' therefore can't be changed so let them know that
       IsFileOpen = True
       Exit Function
   End If

   ' Ready to try and open the file exclusively and then any error means that
   ' the file is already open by some other process...
   lngFile = FreeFile
   Open strFullPathFileName For Random Access Read Write Lock Read Write As lngFile
   IsFileOpen = (Err <> 0)
   Close lngFile

   ' Restore the attributes and exit
   SetAttr strFullPathFileName, intAttrib

End Function

Set Follow Up Flag Icon For Unsent Mail

I am a big fan of the Follow Up Flag Icon (the coloured flags)in Outlook 2003 because it simplifies tracking all the important stuff that I have to do. By adding a coloured Flag Icon to email I can use the special For Follow Up search folder to just display the emails that I want to focus on. I also use Trog by Priacta which also uses these flags. But there is a problem (of course) and that is that Outlook won't allow me to set a Follow Up Flag Icon for an unsent email.

Well, I want to be able to do that so that I keep track of email that I have sent to people that I need to follow up on. I can send the email, then go to my Sent folder and then add the appropriate coloured flag but that is inefficient and just plain annoying. I don't send mail immediately anyway, so I have to use F9 and wait a bit or wait longer and remember to go and do it.

However after a bit of testing, I discovered that you can programmatically set the FlagIcon. But I didn't want to replace the inbuilt function completely, nor did I want to add another button to the commandbar. So I decided that I needed to be able to trap the button click and pop up my own form whenever I was looking at an unsent email. The trick is to sink the appropriate events using a class module.

Obviously, you can use these concepts to manage any number of tasks and in my example the form could be expanded to replace all of the functionality in Follow Up. I leave that to the reader as an exercise...

First, I designed a simple UserForm called frmSetFlagIcon. Here is an example, it doesn't take long to knock one up (email me if you want a copy sent to you).


Next, add the following code to the UserForm (make sure you use the same names for the controls or modify accordingly):

' frmSetFlagIcon

' Developed by Warren Bain on 30/06/2008
' Copyright (c) Thought Croft Pty Ltd
' All rights reserved.

' This module allows me to set the Follow Up Flag colour
' for unsaved new email which I want to do so I can track
' emails that I send and need to follow up using TROG by Priacta

Option Explicit

' -----------------
' Module variables
' -----------------

Dim moMail As MailItem
Dim mblnSent As Boolean
Dim moFlagStatus As OlFlagStatus
Dim moFlagIcon As OlFlagIcon

' -----------------
' Module procedures
' -----------------

Private Sub cboFlagIcon_Change()

' If we have unset the flag then the
' FlagStatus must be set appropriately

If IsNull(Me.cboFlagIcon) Then
  moFlagIcon = olNoFlagIcon
Else
  moFlagIcon = Me.cboFlagIcon
End If
If moFlagIcon = olNoFlagIcon Then
  moFlagStatus = olNoFlag
Else
  moFlagStatus = olFlagMarked
End If
Call DisplayControls

End Sub

Private Sub ckbCompleted_Change()

' If they mark it complete then alter
' FlagStatus accordingly

If Me.ckbCompleted Then
  moFlagStatus = olFlagComplete
Else
  moFlagStatus = olFlagMarked
End If
Call DisplayControls

End Sub

Private Sub cmdCancel_Click()

' Clear global object and close form

Set moMail = Nothing
Unload Me

End Sub

Private Sub cmdOK_Click()

If Not moMail Is Nothing Then
  With moMail
      If moFlagIcon <> .FlagIcon Or moFlagStatus <> .FlagStatus Then
          ' They altered something so update MailItem
          .FlagStatus = moFlagStatus
          .FlagIcon = moFlagIcon
          .Save
      End If
  End With
End If

Set moMail = Nothing
Unload Me

End Sub

Private Sub UserForm_Initialize()

' Set up the different colours available
' to us when the form is first opened
' The two arrays must be kept
' in step and in the order required

Dim astrColours As Variant
Dim avarFlagIcons As Variant
Dim i As Integer
Dim oInsp As Inspector
Dim oItem As Object


With Me.cboFlagIcon
  astrColours = Array("No flag set", "Red", "Blue", _
                      "Yellow", "Green", _
                      "Orange", "Purple")
  avarFlagIcons = Array(olNoFlagIcon, olRedFlagIcon, olBlueFlagIcon, olYellowFlagIcon, _
                        olGreenFlagIcon, olOrangeFlagIcon, olPurpleFlagIcon)
  For i = LBound(astrColours) To UBound(astrColours)
      .AddItem
      .List(i, 0) = avarFlagIcons(i)
      .List(i, 1) = astrColours(i)
  Next i
End With

' Now see which mail item is being referenced
' and prepare ourselves for working with it
Set oInsp = Application.ActiveInspector
If Not oInsp Is Nothing Then
  Set oItem = oInsp.CurrentItem
  If TypeOf oItem Is MailItem Then
      ' We have a mail item to work with so
      ' retrieve the current flag settings
      Set moMail = oItem
      With moMail
          mblnSent = .Sent
          moFlagStatus = .FlagStatus
          moFlagIcon = .FlagIcon
      End With
      Me.ckbCompleted = (moFlagStatus = olFlagComplete)
      Me.cboFlagIcon = moFlagIcon
  End If
End If

Set oItem = Nothing
Set oInsp = Nothing

End Sub

Private Sub DisplayControls()

' Ensure that the controls are enabled
' consistently with their settings

If Not moMail Is Nothing Then

  ' Only allow OK if they have actually altered the
  ' controls to be different from the MailItem
  With moMail
      Me.cmdOK.Enabled = moFlagIcon <> .FlagIcon _
                         Or moFlagStatus <> .FlagStatus
  End With

  ' Allow them to set Completed if the flag is set and SENT
  ' and allow Flag Icon change if incomplete
  Me.cboFlagIcon.Enabled = Not Me.ckbCompleted
  Me.ckbCompleted.Enabled = (Me.cboFlagIcon <> olNoFlagIcon) And mblnSent

End If

End Sub

Next, add a new class module to the Outlook Project to sink the events we are interested in. Essentially this will trap any click on the Add Reminder... menu item under Actions | Follow Up submenu, or click the Follow Up button on the Standard menubar, our form will be displayed instead of the inbuilt Outlook one. Name the class module clsInspectorHandler and paste this code into it.

Note that this will be instantiated for any Inspector that we are interested in and so we have to have a way of determining if a button click is for this instance of the Inspector object. We generate a unique key and set it in the button's Tag property. When the button is clicked on one Inspector, every CommandBarControl object referencing that button will have its Click event fired, so the instance ignores any for Controls that don't have its unique tag set in it.

' clsInspectorHandler

' Developed by Warren Bain on 30/06/2008
' Copyright (c) Thought Croft Pty Ltd
' All rights reserved.

Option Explicit

Dim WithEvents oInspector As Outlook.Inspector
Dim WithEvents oCBB1 As Office.CommandBarButton
Dim WithEvents oCBB2 As Office.CommandBarButton
Dim mstrUniqueTag As Integer

Private Sub Class_Initialize()
' Create a unique key for tag usage
Randomize
mstrUniqueTag = Int((9999 - 0 + 1) * Rnd + 0)
End Sub

Private Sub Class_Terminate()
Set oCBB1 = Nothing
Set oCBB2 = Nothing
Set oInspector = Nothing
End Sub

Private Sub oCBB1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
' We want to prevent this one from running and load our own
If Ctrl.Tag = mstrUniqueTag Then
    frmSetFlagIcon.Show
    CancelDefault = True
End If
End Sub

Private Sub oCBB2_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
' We want to prevent this one from running and load our own
If Ctrl.Tag = mstrUniqueTag Then
    frmSetFlagIcon.Show
    CancelDefault = True
End If
End Sub

Private Sub oInspector_Close()
Set oCBB1 = Nothing
Set oCBB2 = Nothing
End Sub

Public Sub SetInspector(Inspector As Outlook.Inspector)
If Not Inspector Is Nothing Then
    Set oInspector = Inspector
    With oInspector
        ' 1678 = Standard menu button "Follow &Up"
        ' 7478 = Action menu Follow Up submenu item "&Add Reminder..."
        Set oCBB1 = .CommandBars.FindControl(msoControlButton, 1678)
        oCBB1.Tag = mstrUniqueTag
        Set oCBB2 = .CommandBars.FindControl(msoControlButton, 7478)
        oCBB1.Tag = mstrUniqueTag
    End With
End If
End Sub

NOTE: the CommandBarControlButton ids that I have quoted are correct in my installation of Outlook 2003. You will need to check they are the same for your version. Sue Mosher has code that will allow you to enumerate all CommandBars in Outlook.

Then add the following code in the ThisOutlookSession module. When a new Inspector is opened (for example to compose an email), the NewInspector event will fire. If it is for an Unsent MailItem, we are interested in trapping the relevant button clicks so we create a new instance of the clsInspectorHandler, add it to a global collection object to keep it alive (as there may be multiple Inspectors open at any one time, we have to keep an instance for each one) and then call its SetInspector method to sink the required Click events.

Public WithEvents colInspectors As Outlook.Inspectors
Public gcolMyInspectors As Collection

Private Sub Application_Quit()
 Set gcolMyInspectors = Nothing
 Set colInspectors = Nothing
End Sub

Private Sub Application_Startup()
 Set gcolMyInspectors = New Collection
 Set colInspectors = Application.Inspectors
End Sub

Private Sub colInspectors_NewInspector(ByVal Inspector As Inspector)

 ' This will be called everytime we open
 ' a new Inspector, so check if this is
 ' one that we want to monitor

 Dim MyInspectorHandler As clsInspectorHandler

 If Inspector.CurrentItem.Class = olMail Then
     If Not Inspector.CurrentItem.Sent Then
         ' This is an unsent email so we want to
         ' trap the buttons that can be clicked
         Set MyInspectorHandler = New clsInspectorHandler
         Call MyInspectorHandler.SetInspector(Inspector)
         gcolMyInspectors.Add MyInspectorHandler
     End If
 End If
End Sub

Save the project, restart Outlook and you will be in business. Anytime you want to flag an unsent email, your form will popup in place of the Outlook inbuilt one.

Generate Password

This is a simple digit only password generator that I use for a number of purposes. My recent post about managing automation objects uses this function and I forgot to include it there - I have updated that post but though I would also post it separately. I adapted this from some code I got somewhere, my apologies for not acknowledging the source.

Public Function GeneratePassword( _
       ByVal intLength As Integer) As String

    ' Generates a random string of digits of the requested length

    ' In:
    '   intLength - number of digits to be returned (max 9)
    ' Out:
    '   Return Value - a random string of digits
    ' Example:
    '   GetPassword(3) = "927"

    Dim lngHighNumber              As Long
    Dim lngLowNumber               As Long
    Dim lngRndNumber               As Long

    ' Check we don't exceed our maximum range
    If intLength > 9 Or intLength < 1 Then
        Err.Raise 5, "GetPassword", _
                  "Invalid string length - must be between 1 and 9"
    Else
        ' Work out the numbers
        lngLowNumber = 10 ^ (intLength - 1)
        lngHighNumber = (10 ^ intLength) - 1
        ' Generate a new seed and a new random number
        Randomize
        lngRndNumber = Int((lngHighNumber - lngLowNumber + 1) * Rnd) + lngLowNumber
        ' Format the result as string
        GeneratePassword = Format$(lngRndNumber, String$(intLength, "0"))
    End If
End Function

Automation Manager Class

I needed a way to manage calls to different office automation servers in a consistent fashion. These were mostly from Access to extract data from a large number of Excel workbooks. Specifically what I wanted was a way of managing:

* reuse of any existing instance of Excel or start an instance if there wasn't one

* save the state of the application - things like the calculation mode etc and restore them when finished

* work out whether to close the instance when finished (if we started it) or leave it (if we didn't)

* handle the strange automation errors that can occur and ensure that the instance is properly terminated in the case where an unrecoverable error has occurred

Further, I wanted to be able to use this for multiple automation clients. The following class modules have served me well for this purpose and I offer them here for those that may have a similar requirement. Some of this is not for the faint hearted, so send me an email if you need further explanation.

Typical calling method is as follows:

' Give this global scope
Public asm As AppStateMgr
Public app as Object

Set asm = New AppStateMgr
'
' Do something and decide we need to open Excel, say
'
Call asm.OpenApplication("Excel",app)
'
' Now open a workbook say and check for errors
'
If asm.CheckApplicationError(app,Err.Number) Then
   ' Something bad happened so deal with it
   ' If the error was catastrophic to Excel
   ' a new instance will be started anyway
Else
   ' Everything is fine, so something else
End If
'
' Finishing up now
'
Call asm.CloseApplication(app)
Set asm = Nothing

Create a new Class Module called AppState and copy the following code into it. This describes all the properties associated with an instance of an application that has been started to provide automation services.

' Class for defining an application state which can be
' saved and restored using the AppStateMgr class

' Developed by Warren Bain on 16/11/2006
' Copyright (c) Thought Croft Pty Ltd
' http:\\www.thoughtcroft.com
' All rights reserved.

Option Explicit

' Pointer calculated from the object used to index the state collection
' and the name of the application object this relates to
Private mstrIndex As String
Private mstrAppName As String

' Was the application instance created by us and how many are using it
Private mblnSelfStarted As Boolean
Private mlngObjectCount As Long

' Common application properties
Private mblnDisplayAlerts As Boolean
Private mblnScreenUpdating As Boolean
Private mblnVisible As Boolean
Private mlnghWnd As Long

' This one is only with Excel
Private meCalculation As Variant

Friend Property Get ObjectCount() As Long
    ObjectCount = mlngObjectCount
End Property

Friend Property Get DisplayAlerts() As Boolean
    DisplayAlerts = mblnDisplayAlerts
End Property

Friend Property Let DisplayAlerts(ByVal blnDisplayAlerts As Boolean)
    mblnDisplayAlerts = blnDisplayAlerts
End Property

Friend Property Get SelfStarted() As Boolean
    SelfStarted = mblnSelfStarted
End Property

Friend Property Let SelfStarted(ByVal blnSelfStarted As Boolean)
    mblnSelfStarted = blnSelfStarted
End Property

Friend Property Get ScreenUpdating() As Boolean
    ScreenUpdating = mblnScreenUpdating
End Property

Friend Property Let ScreenUpdating(ByVal blnScreenUpdating As Boolean)
    mblnScreenUpdating = blnScreenUpdating
End Property

Friend Property Get Visible() As Boolean
    Visible = mblnVisible
End Property

Friend Property Let Visible(ByVal blnVisible As Boolean)
    mblnVisible = blnVisible
End Property

Friend Property Get Index() As String
    Index = mstrIndex
End Property

Friend Property Let Index(ByVal strIndex As String)
    ' Can only assign this if the value is empty
    ' i.e. after it has been set, it is read only!
    If Len(mstrIndex) = 0 Then
        mstrIndex = strIndex
    Else
        Err.Raise vbObjectError + 5, "AppState", _
                  "Can't alter the Index after created!"
    End If
End Property

Friend Function IncrementCount() As Long
    ' Increase the count of objects using this application    
    mlngObjectCount = mlngObjectCount + 1
    IncrementCount = mlngObjectCount
End Function

Friend Function DecrementCount() As Long
    ' Decrease the count of objects using this application
    mlngObjectCount = mlngObjectCount - 1
    DecrementCount = mlngObjectCount
End Function

Friend Property Get AppName() As String
    AppName = mstrAppName
End Property

Friend Property Let AppName(ByVal strAppName As String)
    ' Can only assign this if the value is empty
    ' i.e. after it has been set, it is read only!
    If Len(mstrAppName) = 0 Then
        mstrAppName = strAppName
    Else
        Err.Raise vbObjectError + 5, "AppState", _
                  "Can't alter the AppName after created!"
    End If
End Property

Friend Property Get Calculation() As Variant
    Calculation = meCalculation
End Property

Friend Property Let Calculation(ByVal eCalculation As Variant)
    meCalculation = eCalculation
End Property

Friend Property Get WindowsHandle() As Long
    WindowsHandle = mlnghWnd
End Property

Friend Property Let WindowsHandle(ByVal lngWindowsHandle As Long)
    mlnghWnd = lngWindowsHandle
End Property

Create a Class Module called AppStateMgr and copy the following code into it. This provides the functions for managing instances of automation clients.

' Manage the state of automation application objects and associated
' functions for saving, restoring the application state as well as
' handling typical automation errors, etc

' Developed by Warren Bain on 16/11/2006
' Copyright (c) Thought Croft Pty Ltd
' http:\\www.thoughtcroft.com
' All rights reserved.

Option Explicit

Private Const PROCESS_TERMINATE As Long = (&H1)
Private Const SW_SHOWNORMAL = 1

Private Declare Function apiFindWindow Lib "user32" Alias "FindWindowA" ( _
                                       ByVal strClass As String, _
                                       ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias "SendMessageA" ( _
                                        ByVal hwnd As Long, _
                                        ByVal Msg As Long, _
                                        ByVal wParam As Long, _
                                        ByVal lParam As Long) As Long

Private Declare Function apiSetForegroundWindow Lib "user32" Alias "SetForegroundWindow" ( _
                                                ByVal hwnd As Long) As Long

Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" ( _
                                       ByVal hwnd As Long, _
                                       ByVal nCmdShow As Long) As Long

Private Declare Function apiIsIconic Lib "user32" Alias "IsIconic" ( _
                                     ByVal hwnd As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
                               ByRef Destination As Any, _
                               ByRef Source As Any, _
                               ByVal Length As Long)

Private Declare Function CloseHandle Lib "kernel32.dll" ( _
                                     ByVal hObject As Long) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32.dll" ( _
                                                  ByVal hwnd As Long, _
                                                  ByRef lpdwProcessId As Long) As Long

Private Declare Function OpenProcess Lib "kernel32.dll" ( _
                                     ByVal dwDesiredAccess As Long, _
                                     ByVal bInheritHandle As Long, _
                                     ByVal dwProcessId As Long) As Long

Private Declare Function TerminateProcess Lib "kernel32.dll" ( _
                                          ByVal hProcess As Long, _
                                          ByVal uExitCode As Long) As Long


' Collection for holding the application states
Private mcolAppStateCol       As Collection

Friend Property Get AppStateCol() As Collection
    ' Return collection object, create if necessary
    If mcolAppStateCol Is Nothing Then
        Set mcolAppStateCol = New Collection
    End If
    Set AppStateCol = mcolAppStateCol
End Property

Public Function CheckApplicationError( _
       ByRef objApp As Object, _
       ByVal lngErrNumber As Long) As Boolean

    ' Check for a range of automation errors that can occur
    ' and try and recover from them, typically by restarting
    ' the application server. Returns True if the App
    ' had to be recovered due to Automation errors

    ' Normally, lngErrNumber will contain the value from
    ' Err.Number after a call to an automation client related
    ' object but can be passed a negative number to force a restart

    Const conSpecificAutomationErrorEndRange = 0
    Const conObjectRequiredError = 424
    Const conGeneralAutomationError = 440
    Const conAutomationNotSupportedError = 458
    Const conRemoteServerLostError = 462
    Const conApplicationDefinedError = 1004

    Dim objState              As AppState

    If objApp Is Nothing Then
        ' Must have application to work with here
        Err.Raise vbObjectError + 5, "AppStateMgr::CheckApplication", _
                  "Must supply a valid App object"
    Else
        Select Case lngErrNumber
        Case Is < conSpecificAutomationErrorEndRange, _
             conObjectRequiredError, _
             conGeneralAutomationError, _
             conAutomationNotSupportedError, _
             conRemoteServerLostError, _
             conApplicationDefinedError
            ' Definitely an unrecoverable automation error
            ' so force a close, getting the state so we can
            ' determine the app type and force a new instance
            Set objState = CloseApplication(objApp, True)
            Call OpenApplication(objState.AppName, objApp, True)
            Set objState = Nothing
            CheckApplicationError = True
        End Select
    End If
End Function

Private Function CheckAppRunning( _
        ByVal strAppName As String, _
        Optional ByVal blnActivate As Boolean) As Boolean

    ' This code was originally written by Dev Ashish
    ' but has been enhanced to cope with other classes
    ' of application by Warren Bain

    Const WM_USER = 1024

    Dim lngH                  As Long
    Dim strClassName          As String
    Dim lngX                  As Long
    Dim lngTmp                As Long

    On Local Error GoTo HandleErrors

    CheckAppRunning = False
    strClassName = GetClassName(strAppName)
    If Len(strClassName) = 0 Then
        lngH = apiFindWindow(vbNullString, strAppName)
    Else
        lngH = apiFindWindow(strClassName, vbNullString)
    End If
    If lngH <> 0 Then
        apiSendMessage lngH, WM_USER + 18, 0, 0
        lngX = apiIsIconic(lngH)
        If lngX <> 0 Then
            lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
        End If
        If blnActivate Then
            lngTmp = apiSetForegroundWindow(lngH)
        End If
        CheckAppRunning = True
    End If

ExitHere:
    Exit Function
HandleErrors:
    CheckAppRunning = False
    Resume ExitHere
End Function

Private Sub Class_Terminate()

    ' Destroy the collection object if there are
    ' still members that we haven't terminated before hand

    If Not mcolAppStateCol Is Nothing Then
        Set mcolAppStateCol = Nothing
    End If

End Sub

Public Sub CloseAllApplications( _
       Optional ByVal blnForceKill As Boolean = False)

    ' Walk the collection and call CloseApplication for
    ' each instance we have available to us.

    ' ***************** WARNING ************************
    ' Use extreme care calling as this will terminate the
    ' application without cleaning up any objects still
    ' pointing at it.  May cause host app to crash on exit
    ' **************************************************

    Dim objState              As AppState
    Dim i                     As Integer

    If Not Me.AppStateCol Is Nothing Then
        For i = Me.AppStateCol.Count To 1 Step -1
            ' Create an object for each
            ' member that was created
            ' using GetObjectFromPtr
            Set objState = Me.AppStateCol(i)
            Call CloseApplication(GetObjectFromPtr(objState.Index), _
                                  blnForceKill, _
                                  objState)
        Next i
    End If

End Sub

Public Function CloseApplication( _
       ByRef objApp As Object, _
       Optional ByVal blnForceKill As Boolean = False, _
       Optional ByRef objState As AppState) As AppState

    ' Restore application state and leave it running if it
    ' was not started by us (unless they want us to kill it)
    ' or if there are others using it

    Dim blnShutDown           As Boolean
    Dim blnLastState          As Boolean

    If Not objApp Is Nothing Then
        ' Find the saved status of the application
        ' and work out if we started it - if no
        ' saved state, then assume we didn't start it
        If objState Is Nothing Then
            ' They didn't supply it so, find it
            ' Don't worry about trapping errors
            On Error Resume Next
            Set objState = FindAppState(objApp)
            On Error GoTo 0
        End If
        If objState Is Nothing Then
            ' No state saved so action depends on ForceKill value
            blnShutDown = blnForceKill
        Else
            ' Decrement count of objects to decide if we should
            ' really shut this one down as well
            With objState
                blnLastState = (.DecrementCount <= 0)
                blnShutDown = blnForceKill Or _
                              (.SelfStarted And blnLastState)
            End With
        End If

        ' Did we start it and no-one else using it
        ' or do they want to kill it anyway?
        If blnShutDown Then
            ' Don't bother restoring, just terminate the application
            Call TerminateApplication(objApp, objState)
        ElseIf blnLastState Then
            ' Attempt to restore the application state
            ' as we have finished with it in this process
            ' and remove it from the list
            Call RestoreAppState(objApp, objState)
        End If
        Call RemoveAppState(objState)
        Set CloseApplication = objState
        ' Force release of application object to ensure
        ' application will shutdown normally
        Set objApp = Nothing
    End If
End Function

Private Function FindAppState( _
        ByRef objApp As Object, _
        Optional ByVal strName As String = vbNullString, _
        Optional ByVal blnCreateNew As Boolean = False) As AppState

    ' Retrieve an existing AppSave object or
    ' if not available then add a new one if
    ' caller requests us to CreateNew

    Dim objState              As AppState

    If objApp Is Nothing Then
        ' Can't do this if there isn't any object
             Err.Raise vbObjectError + 5, "AppStateMgr::FindAppState", _
                      "Must supply an instantiated object (not Nothing)!"
    Else
        ' Check compatible parameters
        If Len(strName) = 0 And blnCreateNew Then
            ' Can't create if we don't know the AppName
            Err.Raise vbObjectError + 13, "AppStateMgr::FindAppState", _
                      "Can't specify 'CreateNew' without supplying 'Name'!"
        Else
            On Error Resume Next
            Set objState = Me.AppStateCol(GetObjPtr(objApp))
            On Error GoTo 0
            If objState Is Nothing Then
                If blnCreateNew Then
                    Set objState = SaveAppState(objApp, strName)
                Else
                    Err.Raise vbObjectError + 63, "AppStateMgr::FindAppState", _
                              "Can't find required 'AppState' for this object!"
                End If
            ElseIf objState.AppName <> strName And Len(strName) > 0 Then
                ' Found existing one but it doesn't match
                ' the AppName we are expecting - whoops!
                Err.Raise vbObjectError + 13, "AppStateMgr::FindAppState", _
                          "Conflict with 'AppName' supplied [" & strName & _
                          "] and retrieved [" & objState.AppName & "]!"
            End If
            Set FindAppState = objState
        End If
    End If
End Function

Private Function GeneratePassword( _
       ByVal intLength As Integer) As String

    ' Generates a random string of digits of the requested length

    Dim lngHighNumber         As Long
    Dim lngLowNumber          As Long
    Dim lngRndNumber          As Long

    ' Check we don't exceed our maximum range
    If intLength > 9 Or intLength < 1 Then
        Err.Raise 5, "GetPassword", _
                  "Invalid string length - must be between 1 and 9"
    Else
        ' Work out the numbers
        lngLowNumber = 10 ^ (intLength - 1)
        lngHighNumber = (10 ^ intLength) - 1
        ' Generate a new seed and a new random number
        Randomize
        lngRndNumber = Int((lngHighNumber - lngLowNumber + 1) * Rnd) + lngLowNumber
        ' Format the result as string
        GeneratePassword = Format$(lngRndNumber, String$(intLength, "0"))
    End If
End Function

Private Function GetApplicationHandle(ByRef objApp As Object) As Long

    ' Locate the windows handle for the application
    ' represented by this object

    Dim hwnd                  As Long
    Dim varCaption            As Variant

    On Error Resume Next

    ' Determine the type of object - can make it easy
    ' as the object may store it itself
    If TypeOf objApp Is Access.Application Then
        hwnd = objApp.hWndAccessApp
    ElseIf TypeOf objApp Is Excel.Application Then
        ' This only works for Excel 2002 onwards
        hwnd = objApp.hwnd
    End If
    On Error GoTo 0

    If hwnd = 0 Then
        ' Need to discover it from the Window so we make sure
        ' that the caption is unique for this application
        varCaption = objApp.Caption
        objApp.Caption = GeneratePassword(8)
        hwnd = apiFindWindow(GetClassName(objApp.Name), objApp.Caption)
        objApp.Caption = varCaption
    End If
    GetApplicationHandle = hwnd
End Function

Private Function GetClassName(ByVal strAppName As String) As String

    ' Returns the Class Name for the main window of various
    ' Microsoft software applications

    Select Case LCase$(strAppName)
    Case "excel", "microsoft excel": GetClassName = "XLMain"
    Case "word", "microsoft word": GetClassName = "OpusApp"
    Case "access", "microsoft access": GetClassName = "OMain"
    Case "powerpoint95": GetClassName = "PP7FrameClass"
    Case "powerpoint97": GetClassName = "PP97FrameClass"
    Case "powerpoint2000": GetClassName = "PP9FrameClass"
    Case "powerpoint2002": GetClassName = "PP10FrameClass"
    Case "powerpoint2003": GetClassName = "PP11FrameClass"
    Case "powerpoint2007": GetClassName = "JWinproj-WhimperMainClass"
    Case "project", "microsoft project": GetClassName = "PP9FrameClass"
    Case "notepad": GetClassName = "NOTEPAD"
    Case "paintbrush": GetClassName = "pbParent"
    Case "wordpad": GetClassName = "WordPadClass"
    Case Else: GetClassName = vbNullString
    End Select
End Function

Private Function GetObjectFromPtr(ByVal lPtr As Long) As Object

    ' Based on Bruce McKinney's code for getting an Object from the
    ' object pointer - the reverse of ObjPtr(object).

    Dim objT                  As Object

    On Error GoTo HandleError

    CopyMemory objT, lPtr, 4
    Set GetObjectFromPtr = objT
    Exit Function

HandleError:
    With Err
        .Raise .Number, "AppStateMgr::GetObjectFromPtr" & .Source, _
               .Description, .HelpFile, .HelpContext
    End With
End Function

Private Function GetObjPtr(ByRef obj As Object) As String

    ' This relies on undocumented function to return
    ' the address of the object pointer in memory
    ' which is useful for fast indexing into a collection
    ' of objects or object related data. Returns null string
    ' if object hasn't been assigned yet

    If obj Is Nothing Then
        GetObjPtr = vbNullString
    Else
        GetObjPtr = CStr(ObjPtr(obj))
    End If
End Function

Public Sub OpenApplication( _
       ByVal strAppName As String, _
       ByRef objApp As Object, _
       Optional ByVal blnForceNewInstance As Boolean = False, _
       Optional ByVal blnDisplayAlerts As Boolean = False)

    ' Check if object is already referencing an application and
    ' if not then first try and use existing automation client if
    ' running else start a new one and save its state. The caller
    ' can force us to create a new instance if they wish although
    ' this also depends on the application which may only single instance

    Dim objState              As AppState
    Dim blnSelfStarted        As Boolean

    On Error GoTo HandleErrors

    If objApp Is Nothing Then
        ' Try and locate an existing instance first before starting new one
        If CheckAppRunning(strAppName) And Not blnForceNewInstance Then
            ' Server already running so return reference to it
            Set objApp = GetObject(, strAppName & ".Application")
            blnSelfStarted = False
        Else
            ' Need to start a new instance of required server application
            Set objApp = CreateObject(strAppName & ".Application")
            blnSelfStarted = True
        End If

        ' Now find the state - if it doesn't exist then it will create a
        ' new one and save app state.
        Set objState = FindAppState(objApp, strAppName, True)

        ' Increment the counter and set the DisplayAlert property
        objState.IncrementCount
        objApp.DisplayAlerts = blnDisplayAlerts
        
        ' Save whether we started it but don't update it
        ' if we didn't because may have been done by previous
        ' call using a different object variable
        If blnSelfStarted Then
            objState.SelfStarted = blnSelfStarted
        End If
    End If

ExitHere:
    Exit Sub

HandleErrors:
    With Err
        Select Case .Number
        Case Else
            .Raise .Number, "AppStateMgr::OpenApplication", .Description, .HelpFile, .HelpContext
        End Select
    End With
    Resume ExitHere
End Sub

Private Function RemoveAppState(ByRef objState As AppState)

    ' To remove the supplied AppState object from the
    ' collection - no longer required

    If Not objState Is Nothing Then
        Me.AppStateCol.Remove objState.Index
    End If
End Function

Private Function RestoreAppState( _
        ByRef objApp As Object, _
        Optional ByRef objState As AppState = Nothing) As AppState

    ' To find existing AppState and restore the state
    ' of the supplied application object

    ' If application is already nothing then exit
    If Not objApp Is Nothing Then
        If objState Is Nothing Then
            ' No AppState supplied so go find it -
            ' note that this call will raise an error
            ' if the AppState can't be found
            Set objState = FindAppState(objApp)
        End If

        ' We will have a valid AppState now
        With objApp

            ' *************************************
            ' These properties apply to all objects
            .DisplayAlerts = objState.DisplayAlerts
            .ScreenUpdating = objState.ScreenUpdating

            ' Can only reset this if we started it
            If Not .UserControl Then
                .Visible = objState.Visible
            End If

            ' -------------------------------------
            ' Properties specific to Excel
            If TypeOf objApp Is Excel.Application Then
                ' Can only reset this if we started it
                If Not .UserControl Then
                    .Calculation = objState.Calculation
                End If
            End If

        End With
        Set RestoreAppState = objState
    End If
End Function

Private Function SaveAppState( _
        ByRef objApp As Object, _
        ByVal strName As String) As AppState

    ' To create a new AppState and save the state
    ' of the supplied application object

    Dim objState              As AppState

    If Not objApp Is Nothing Then
        ' Create a new instance and save key state info
        Set objState = New AppState
        With objState

            ' *************************************
            ' These properties apply to all objects
            .Index = GetObjPtr(objApp)
            .AppName = strName
            .WindowsHandle = GetApplicationHandle(objApp)
            .DisplayAlerts = objApp.DisplayAlerts
            .Visible = objApp.Visible
            .ScreenUpdating = objApp.ScreenUpdating

            ' -------------------------------------
            ' Properties specific to Excel
            If TypeOf objApp Is Excel.Application Then
                .Calculation = objApp.Calculation
            End If

            ' Now add to the collection
            Me.AppStateCol.Add objState, .Index
        End With
        Set SaveAppState = objState
    End If
End Function

Private Sub TerminateApplication( _
        ByRef objApp As Object, _
        ByRef objState As AppState)

    ' This will try and exit the application and
    ' also terminate the process where the
    ' automation server is not responding

    Dim hWndApp               As Long
    Dim hProcessID            As Long
    Dim hThreadID As Long
    Dim hTerminateID          As Long


    On Error Resume Next
    If Not objApp Is Nothing Then
        If objState Is Nothing Then
            hWndApp = GetApplicationHandle(objApp)
        Else
            hWndApp = objState.WindowsHandle
        End If

        ' Now close the application normally - the Quit just
        ' allows the application to close its objects but it
        ' doesn't actually terminate until we close the object
        objApp.Quit
        Set objApp = Nothing
        DoEvents

        If hWndApp <> 0 Then
            ' Find the processid of the selected window in case it didn't
            ' close normally in  which case we will get an id back
            hThreadID = GetWindowThreadProcessId(hWndApp, hProcessID)
            If hProcessID <> 0 Then
                ' Acquire a handle with terminate ability and try and kill it
                ' don't worry about failing as there is nothing we can do anyway
                hTerminateID = OpenProcess(PROCESS_TERMINATE, 0, hProcessID)
                Call TerminateProcess(hTerminateID, 0)
                Call CloseHandle(hTerminateID)
            End If
        End If
    End If
End Sub

Strip Different Types of Characters from a String

I realised that one of my earlier posts Generic Function to Copy Excel Data references a function called 'tcStripChars' in order to remove control characters from a cell value. This was required to prevent Excel 97 crashing when copying the .Value2 property of a cell into another cell whenever there were control characters in the value e.g. LFCR.

The function is useful for other situations as well so here it is. Please note the use of the Vba6 conditional compilation constant to generate appropriate code for your version of VBA using Enumerated Types (VBA6) or Public Constants (pre VBA6)

' Note: Vba6 is a conditional compiler constant that indicates
' the version of VBA and in this module we use enumerated types if
' supported otherwise we use plain old public constants

#If CBool(VBA6) Then
' Enumerate methods for selecting mode of character removal
Public Enum StripCharsMode
    scmcRemoveAlphas = 2 ^ 0
    scmcRemoveControl = 2 ^ 1
    scmcRemoveNumerics = 2 ^ 2
    scmcRemoveSpaces = 2 ^ 3
    scmcRemoveOthers = 2 ^ 4
    scmcRemoveAll = 2 ^ 5 - 1
    scmcKeepAlphas = scmcRemoveAll - scmcRemoveAlphas
    scmcKeepLetters = scmcRemoveAll - scmcRemoveAlphas - scmcRemoveSpaces
    scmcKeepNumerics = scmcRemoveAll - scmcRemoveNumerics
    scmcKeepOthers = scmcRemoveAll - scmcRemoveOthers
    scmcKeepControl = scmcRemoveAll - scmcRemoveControl
End Enum

Public Function tcStripChars( _
       ByVal strInputText As String, _
       ByVal scmRemoveType As StripCharsMode) _
       As String
    
    Dim scmCharMode As StripCharsMode
#Else
' Constants for selecting mode of character removal
Public Const scmcRemoveAlphas As Integer = 2 ^ 0
Public Const scmcRemoveControl As Integer = 2 ^ 1
Public Const scmcRemoveNumerics As Integer = 2 ^ 2
Public Const scmcRemoveSpaces As Integer = 2 ^ 3
Public Const scmcRemoveOthers As Integer = 2 ^ 4
Public Const scmcRemoveAll As Integer = 2 ^ 5 - 1
Public Const scmcKeepAlphas As Integer = scmcRemoveAll - scmcRemoveAlphas
Public Const scmcKeepLetters As Integer = scmcRemoveAll - scmcRemoveAlphas _
                                          - scmcRemoveSpaces
Public Const scmcKeepNumerics As Integer = scmcRemoveAll - scmcRemoveNumerics
Public Const scmcKeepOthers As Integer = scmcRemoveAll - scmcRemoveOthers
Public Const scmcKeepControl As Integer = scmcRemoveAll - scmcRemoveControl

Public Function tcStripChars( _
       ByVal strInputText As String, _
       ByVal scmRemoveType As Integer) _
       As String

    Dim scmCharMode As Integer
#End If

    Dim intPos As Integer
    Dim strChar As String

    ' Remove specified types of characters from input string

    ' Developed by Warren Bain
    ' Copyright 2004, Thought Croft Pty Ltd
    ' All rights reserved.

    ' In:
    '   strInputText:
    '       text to extract characters from
    '   scmRemoveType:
    '       type of removal (or retention) required
    '       can be combined to remove multiple types of chars
    ' Out:
    '   Return Value:
    '       text with all required chars removed


    ' Start with an empty output string
    tcStripChars = vbNullString

    ' Determine for each character in the input string
    ' whether it should be retained or discarded based
    ' on bitwise comparison with scmRemoveType parameter
    For intPos = 1 To Len(strInputText)
        strChar = Mid$(strInputText, intPos, 1)
        Select Case Asc(strChar)
        Case 65 To 90, 97 To 122: scmCharMode = scmcRemoveAlphas
        Case 48 To 57: scmCharMode = scmcRemoveNumerics
        Case 32: scmCharMode = scmcRemoveSpaces
        Case 0 To 31: scmCharMode = scmcRemoveControl
        Case Else: scmCharMode = scmcRemoveOthers
        End Select

        ' If the character's type bit is set in the remove type
        ' we will discard it - otherwise retain it
        If scmRemoveType And scmCharMode Then
            'Ignore this one
        Else
            tcStripChars = tcStripChars & strChar
        End If
    Next intPos
    
End Function

Automatic Email Account Assignment in Outlook

NOTE: THIS HAS BEEN UPDATED TO WORK WITH OUTLOOK 2007

I use Google Apps to host my family's and my private company's email but I manage my email through Outlook 2003 (because I prefer to operate off-line and I need to synchronise with my Nokia N95 phone).

Google Mail is fantastic but the issue I had to grapple with relates to how email is pulled into Outlook. Email sent to warren@[personal] and warren@[business] ends up arriving in the one inbox and is automatically assigned to the default email account in Outlook ([business] in this case).

When I reply to an email I want it to be sent through the correct account so that the sender and reply addresses match the right context. I can do that manually using the Accounts button followed by the Send button but there is another (better) way using VBA.

First download and install the excellent Redemption COM Library written by Dmitry Streblechenko. This will expose the required properties of the Outlook object model without triggering the user confirmation dialog introduced by the Outlook Security Patch. It also provides access to many useful MAPI properties not available through the standard Outlook object model.

The following code is triggered whenever new mail arrives in Outlook. In essence, I look for certain phrases that indicate that the mail has been sent to my [personal] address and then change the mail account for that message to match. Subsequently, when I reply to that message, I don't need to choose which address to send it from as that has already been selected.

It works 95% of the time with misses probably due to timing issues and possible conflicts with Outlook rules. The NewMailEx event is perhaps not guaranteed to fire (despite what the documentation says) and so sometimes the account is left set to the incorrect one but I am happy enough with the result. The techniques employed here could be used for other new mail triggered actions.

First, create a new Class module in your Outlook VBA project called clsNewMailHandler

Option Explicit

Public WithEvents oApp As Outlook.Application
Const TC_BAINSWORLD_ACCOUNT = "bainsworld"


Private Sub Class_Terminate()
   Set oApp = Nothing
End Sub


Private Sub oApp_NewMailEx(ByVal EntryIDCollection As String)

' This will be called whenever we receive new mail so
' process each item to determine if we should alter
' the account - do we need to worry about conflicts with Rules?

   Dim astrEntryIDs() As String
   Dim objItem As Object
   Dim varEntryID As Variant

   astrEntryIDs = Split(EntryIDCollection, ",")
   For Each varEntryID In astrEntryIDs
       Set objItem = oApp.Session.GetItemFromID(varEntryID)
       If objItem.Class = olMail Then
           ' Only call this for MailItems - can be ReadReceipts
           ' too which are class olReport
           Call SetEmailAccount(objItem)
       End If
   Next varEntryID
   Set objItem = Nothing
End Sub


Private Sub SetEmailAccount(ByRef oItem As MailItem)

' This code will check if the item is of interest to
' us and if so will update the account property accordingly

' Check if this was sent to a 'bainsworld' address
   If CheckMessageRecipient(oItem, TC_BAINSWORLD_ACCOUNT, False) Then
       ' Yes it was - change the account
       Call SetMessageAccount(oItem, TC_BAINSWORLD_ACCOUNT, True)
   End If
End Sub


Private Sub Class_Initialize()
   Set oApp = Application
End Sub

Next create a new standard Module called basMailRoutines and import this code:

Option Explicit

Private Const PR_HEADERS = &H7D001E
Private Const PR_ACCOUNT = &H80F8001E


Public Function CheckMessageRecipient( _
      ByRef oItem As MailItem, _
      ByVal strMatch As String, _
      Optional ByVal blnExact As Boolean = False) As Boolean

' Check if the supplied string matches the recipient
' of the email.  We use the internet headers and check
' the first part of the string if we can.  The match
' can be made exact or not

   Const TC_HEADER_START As String = "Delivered-To:"
   Const TC_HEADER_END As String = "Received:"

   Dim strHeader As String
   Dim intStart As Integer
   Dim intEnd As Integer
   Dim strRecipient As String

   ' First get the header and see if it makes sense
   strHeader = GetInternetHeaders(oItem)
   intStart = InStr(1, strHeader, TC_HEADER_START, vbTextCompare)
   If intStart = 0 Then intStart = 1
   intEnd = InStr(intStart, strHeader, vbCrLf & TC_HEADER_END, vbTextCompare)

   If intEnd = 0 Then
       ' The headers are unreliable so just check the whole string
       strRecipient = strHeader
   Else
       ' Found headers so grab the recipient data
       strRecipient = Trim$(Mid$(strHeader, intStart + Len(TC_HEADER_START), _
                                 intEnd - (intStart + Len(TC_HEADER_START))))
   End If

   ' Now undertake the check
   If blnExact Then
       CheckMessageRecipient = (strRecipient = strMatch)
   Else
       CheckMessageRecipient = (InStr(1, strRecipient, strMatch, vbTextCompare) > 0)
   End If
End Function


Public Sub SetMessageAccount(ByRef oItem As MailItem, _
                            ByVal strAccount As String, _
                            Optional blnSave As Boolean = True)

    Dim rMailItem                  As Redemption.RDOMail
    Dim rSession                   As Redemption.RDOSession
    Dim rAccount                   As Redemption.RDOAccount
    
    ' Use a RDO Session object to locate the account
    ' that we are interested in

    Set rSession = New Redemption.RDOSession
    rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set rAccount = rSession.Accounts(strAccount)
    
    ' Now use the RDO Mail object to change the account
    ' to the one we require

    Set rMailItem = rSession.GetMessageFromID(oItem.EntryID)
    rMailItem.Account = rAccount
    If blnSave Then
        ' They want us to force a save to the mail object
        rMailItem.Subject = rMailItem.Subject
        rMailItem.Save
    End If
    Set rMailItem = Nothing
    Set rAccount = Nothing
    Set rSession = Nothing
End Sub


Public Function GetInternetHeaders(ByRef oItem As MailItem) As String

   Dim rUtils As Redemption.MAPIUtils

   ' Return the internet header of a message
   Set rUtils = New Redemption.MAPIUtils
   GetInternetHeaders = rUtils.HrGetOneProp(oItem.MAPIOBJECT, PR_HEADERS)
   Set rUtils = Nothing
End Function

Finally, add the following code to the ThisOutlookSession object:

Dim MyNewMailHandler As clsNewMailHandler


Private Sub Application_Quit()
   Set MyNewMailHandler = Nothing
End Sub


Private Sub Application_Startup()
   Set MyNewMailHandler = New clsNewMailHandler
End Sub

Restart Outlook and you are in business! Obviously you could rearrange this code to suit your own purpose and condense some of the code into the one class module but I find this modularisation makes the code much easier to understand and manage.