Monday, June 30, 2008

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.

Tuesday, June 24, 2008

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

Thursday, June 19, 2008

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

    Wednesday, June 18, 2008

    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