tag:blogger.com,1999:blog-192875832024-03-19T22:25:33.446+11:00VBA AdventuresI'm an IT consultant with over 25 years in the game who has returned to his programming roots. It's VBA and Office products rather than IBM 360 assembler code this time around. I've been inspired by other folks on the web and this is my way of sharing what I have learned. If you find it useful, feel free to use it. Don't underestimate the power of VBA!Anonymoushttp://www.blogger.com/profile/15980463719782533046noreply@blogger.comBlogger17125tag:blogger.com,1999:blog-19287583.post-87113698768406369062010-04-01T14:42:00.000+11:002010-04-01T14:42:56.350+11:00How to tell if a file is a Word documentI am building a tool that needs to do something to all the Word documents in a set of folders. There are other sorts of files in these folders so I need to filter the list. I didn't want to hard code the file extensions that constitute Word documents because these change according to the version and will do so in future. So I decided to develop a function that is cross-version compatible.<br />
<br />
To determine the documents that Microsoft Word can open and update natively, I am using the Filters collection from the Application.FileDialog object which is available in Word version 2002 onwards. This is the list of extensions that can be selected in the File Open dialog to filter the files that can be opened in Word. Seems to work like a charm. For earlier versions, you'll need to hardcode the extensions.<br />
<pre><code><span style="color:purple;">
Public Function IsWordDocument(ByVal strExtension As String) As Boolean
' Developed by Warren Bain on 01/04/2010
' Copyright (c) Thought Croft Pty Ltd
' All rights reserved.
' Verifies if the supplied file extension e.g. "doc"
' is recognised as one of the documents that this version
' of Word can natively handle. List is constructed from the
' types of documents that can be filtered in the Open File dialog
' therefore this only works from Microsoft Word 2002 onwards.
Const strcNoiseChars As String = "*?."
Const strcSeparators As String = ";,"
Const strcDelimiter As String = "|"
Static colExtensions As Collection
Dim fdf As FileDialogFilter
Dim astrExts As Variant
Dim strExts As String
Dim i As Integer
' Check if we have loaded the collection yet - only done once
If colExtensions Is Nothing Then
Set colExtensions = New Collection
For Each fdf In Application.FileDialog(msoFileDialogOpen).Filters
strExts = fdf.Extensions
' Remove any 'noise' characters from the string
For i = 1 To Len(strcNoiseChars)
strExts = Replace(strExts, Mid$(strcNoiseChars, i, 1), vbNullString)
Next i
' Ensure we standardise on separators used
For i = 1 To Len(strcSeparators)
strExts = Replace(strExts, Mid$(strcSeparators, i, 1), strcDelimiter)
Next i
' Turn the current set of extensions into an array
astrExts = Split(strExts, strcDelimiter)
' Add all the ones we haven't already got
For i = LBound(astrExts) To UBound(astrExts)
' If already there, this will fail so ignore
On Error Resume Next
colExtensions.Add Trim(astrExts(i)), Trim(astrExts(i))
On Error GoTo 0
Next i
Next fdf
End If
' We just try and look up the file type and if it fails
' then it is not an intrinsically supported document
On Error Resume Next
strExts = colExtensions.Item(strExtension)
IsWordDocument = (Err = 0)
End Function
</span></code></pre>Unknownnoreply@blogger.com3tag:blogger.com,1999:blog-19287583.post-35370493587112797932010-02-26T16:57:00.004+11:002010-02-26T17:10:17.119+11:00Handling strings containing quotes properly in SQLEveryone is aware that quotes in strings used in SQL cause all sorts of problems. As a developer, it is our duty to ensure that an end user never sees an SQL error because we didn't handle his input appropriately! But how the heck do you ensure that quotes are handled correctly? The following function will take a string and return it enclosed with quotes and all instances of quotes in the string will be doubled up. This will work in SQL.<br /><br />For example if I call QuotedString("This is a "string" example") then it will return:<br /><br />"This is ""a string"" example"<br /><br /><pre><code><span style="color:purple;"><br />Public Function QuotedString( _<br /> strText As String) As String<br /><br /> Const conQuoteChar = """"<br /><br /> QuotedString = conQuoteChar _<br /> & Replace$(strText, conQuoteChar, conQuoteChar & conQuoteChar) _<br /> & conQuoteChar<br />End Function<br /></span></code></pre>Unknownnoreply@blogger.com0tag:blogger.com,1999:blog-19287583.post-39711935005332055572009-04-30T10:48:00.005+10:002010-01-07T09:03:28.313+11:00INDIRECT() function in ExcelThis is not a VBA issue but a recent discussion on LinkedIn brought up the question of how to use INDIRECT to construct a reference to a named range in an external sheet. I have been using this very useful function for years to programmatically construct references based on different parameters which resolve to a specific workbook, sheet, name etc. Here is some information on how to properly construct a text based reference.<br /><br />INDIRECT returns a reference specified by a text string and the syntax is INDIRECT(ref_text [, a1]) where ref_text is a reference to a cell containing an A1-style reference, an R1C1-style reference, a name defined as a reference or a reference to a cell as a text string. An error in the reference returns #REF!. a1 specifies the type of reference and for TRUE or omitted means A1-style and FALSE means R1C1 style.<br /><br />The INDIRECT function will return #REF! if the target workbook is not open at the time you open the source workbook (closing the target after it has been open doesn't cause this error as Excel remembers the value until you force a recalc).<br /><br />The proper construction of a text string based reference is as follows:<br /><span style="font-weight: bold;"></span><blockquote><span style="font-weight: bold;">'</span><span style="font-style: italic;">path</span><span style="font-weight: bold;">[</span><span style="font-style: italic;">file</span><span style="font-weight: bold;">]</span><span style="font-style: italic;">sheet</span><span style="font-weight: bold;">'!</span><span style="font-style: italic;">range</span></blockquote>where the literal characters apostrophe <span style="font-weight: bold;">'</span>, square brackets <span style="font-weight: bold;">[]</span> and exclamation mark <span style="font-weight: bold;">!</span> delimit the following<br /><span style="font-style: italic;"></span><span style="font-style: italic;"><blockquote></blockquote></span><ul><li><span style="font-style: italic;">path</span> = drive and folder where the file exists. If you leave this out then it will use the workbook named <span style="font-style: italic;">file</span> you have open no matter its location on disk. If the path has a folder with spaces in it then you must use the apostrophes.<br /></li><li><span style="font-style: italic;">file</span> = the name of the file with extension. Use of the apostrophes means that this name can have spaces in it. If you leave out the apostrophes then no spaces are allowed!<br /></li><li><span style="font-style: italic;">sheet</span> = the name of the worksheet. Only use the "[]" delimiters if a sheet name is provided. No sheet name, no brackets around <file><span style="font-style: italic;">file</span>!<br /></file></li></ul>If you don't provide a sheet name then the reference will default to the first sheet in the workbook. For a named range, no <span style="font-style: italic;">sheet</span> will work if the named range has a scope of workbook or a scope of the first sheet. Obviously, if you provide a <span style="font-style: italic;">sheet</span> for a named range then it must have a scope of that sheet or the reference doesn't exist and returns #REF!<br /><br />I hope this is helpful to folks that are confused about this very useful function.Unknownnoreply@blogger.com0tag:blogger.com,1999:blog-19287583.post-9047768328034056712009-04-15T11:22:00.002+10:002009-04-15T11:32:12.009+10:00Project Holiday Import Wizard<p>Check out this VBA enabled Microsoft Project Plan document that I recently developed. It neatly solves a need of every project manager who uses Microsoft Project to track their project: marking public holidays as non-working time in the project schedule.</p><p>My approach is to use the Outlook Holiday File that is installed on your computer when you install Microsoft Office Outlook. It contains hundreds of religious and national holidays from countries around the world. If you don't have Outlook installed, the wizard will take you to a page where you can learn about this file and download a copy to use as a source of holiday dates.</p><p>Best of all: its free!</p><a class="snap_shots" href="http://www.thoughtcroft.com/downloads/project-holiday-import-wizard">Click here to visit my company website and check it out.</a>Unknownnoreply@blogger.com0tag:blogger.com,1999:blog-19287583.post-91667121013836721772009-01-28T15:06:00.004+11:002009-02-02T10:25:46.398+11:00Possible Error in Excel 2007 Workbooks.Open methodI have discovered a disturbing "feature" in Excel 2007 <span class="blsp-spelling-error" id="SPELLING_ERROR_0">VBA</span> in the way that the Workbooks.Open method handles <span class="blsp-spelling-error" id="SPELLING_ERROR_1">xlsx</span> format files versus the legacy <span class="blsp-spelling-error" id="SPELLING_ERROR_2">xls</span> format file.<br /><br />If a file has a "workbook protection" password set, then the following statement will succeed for an <span class="blsp-spelling-error" id="SPELLING_ERROR_3">xls</span> file but will fail for an <span class="blsp-spelling-error" id="SPELLING_ERROR_4">xlsx</span> file with <span class="blsp-spelling-corrected" id="SPELLING_ERROR_5">run time</span> error "1004: The password you supplied is not correct."<br /><br /> set <span class="blsp-spelling-error" id="SPELLING_ERROR_6">wkb</span> = Application.Workbooks.Open("<span class="blsp-spelling-error" id="SPELLING_ERROR_7">file</span>.???", , , , "password")<br /><br />Why supply a password in this call? I am running Excel as an unattended automation server to load data captured in workbooks submitted from a website into an Access database. Sometimes the users apply a "file open" password which will cause Excel to display a dialog box and wait for someone to supply the password if no password is supplied as an argument to the Open method - very bad! On the other hand, if the password argument is present and is incorrect then the above 1004 error is generated and I can then deal with it in code. If there isn't a "file open" password on the file, the Open method ignores the password argument.<br /><br />However, all my files have a "workbook protection" password set and some users submit the files in the new <span class="blsp-spelling-error" id="SPELLING_ERROR_8">xlsx</span> format. This causes me to discard the file when it should be able to be opened. By the way, even if the "workbook protection" password is "password" it generates this error. And if there is a "workbook protection" password on an <span class="blsp-spelling-error" id="SPELLING_ERROR_9">xlsx</span> file and no password argument is provided to the Open method, it opens the file without any trouble.<br /><br />So looks like Microsoft have messed up the Workbooks Open method in the case where:<br /><ol><li>The file has a "workbook protection" password</li><li>The file is in the new <span class="blsp-spelling-error" id="SPELLING_ERROR_10">xlsx</span> format</li><li>A password argument is supplied in the call to the Workbooks.Open method</li></ol>If you know someone who can alert Microsoft to this, please let them or me know!<br /><br /><span style="font-weight: bold; color: rgb(255, 0, 0);">*** UPDATE ***</span><br /><br /><span style="font-weight: bold;">Prominent Excel MVP </span><a style="font-weight: bold;" href="http://www.rondebruin.nl/tips.htm">Ron de Bruin</a><span style="font-weight: bold;"> has confirmed this is an error and has notified the Microsoft Excel team. Stay tuned for additional developments.</span><br /><br /><span style="font-weight: bold; color: rgb(255, 0, 0);">*** UPDATE ***</span>Unknownnoreply@blogger.com7tag:blogger.com,1999:blog-19287583.post-29113977452350182652008-08-27T16:25:00.003+10:002008-08-27T16:46:25.663+10:00IsFileOpenIf 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.<br /><br />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:<br /><ul><li>Create an Excel file "test.xls"</li><li>In Windows Explorer right click on the file and mark it as "read-only"</li><li>Open the file in Excel</li><li>Now go back to Windows Explorer and delete the file</li><li>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.</li></ul>Now, back to the problem: how do you tell if a given file is in use?<br />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.<br /><pre><code><span style="color:purple;"><br />Public Function IsFileOpen(ByVal strFullPathFileName As String) As Boolean<br /><br /> ' Attempting to open a file for ReadWrite that exists will fail<br /> ' if someone else has it open. We also have to guard against the<br /> ' errors that occur if the file has uncommon file attributes such as<br /> ' 'hidden' which can upset the Open statement.<br /> ' NOTE: any open that doesn't lock the file such as opening a .txt file<br /> ' in NotePad or a read-only file open will return False from this call.<br /><br /> Dim lngFile As Long<br /> Dim intAttrib As Integer<br /><br /> On Error Resume Next<br /> intAttrib = GetAttr(strFullPathFileName)<br /> If Err <> 0 Then<br /> ' If we can't get these then it means the file name is<br /> ' invalid, or the file or path don't exist so no problem<br /> IsFileOpen = False<br /> Exit Function<br /> End If<br /><br /> SetAttr strFullPathFileName, vbNormal<br /> If Err <> 0 Then<br /> ' An error here means that the file is open and the attributes<br /> ' therefore can't be changed so let them know that<br /> IsFileOpen = True<br /> Exit Function<br /> End If<br /><br /> ' Ready to try and open the file exclusively and then any error means that<br /> ' the file is already open by some other process...<br /> lngFile = FreeFile<br /> Open strFullPathFileName For Random Access Read Write Lock Read Write As lngFile<br /> IsFileOpen = (Err <> 0)<br /> Close lngFile<br /><br /> ' Restore the attributes and exit<br /> SetAttr strFullPathFileName, intAttrib<br /><br />End Function<br /></code></pre>Unknownnoreply@blogger.com3tag:blogger.com,1999:blog-19287583.post-5020325716303005572008-06-30T17:25:00.008+10:002008-12-10T02:35:09.972+11:00Set Follow Up Flag Icon For Unsent MailI 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.<br /><br />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.<br /><br />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.<br /><br />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...<br /><br />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).<br /><br /><a onblur="try {parent.deselectBloggerImageGracefully();} catch(e) {}" href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEh6Otj3s09QS7Hf5AvqnXz0ozFXyCDMtduJ4l4doXUq0uuFRSMm_la-AUTaWPl2QBI2X-j7OkLxVO-N5S2zpbNqzo1unxStOuAlheowtolDDTW7TBsq9OCIe1n53P1hG0Gawcu9/s1600-h/SetFlagIcon.jpg"><img style="margin: 0px auto 10px; display: block; text-align: center; cursor: pointer;" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEh6Otj3s09QS7Hf5AvqnXz0ozFXyCDMtduJ4l4doXUq0uuFRSMm_la-AUTaWPl2QBI2X-j7OkLxVO-N5S2zpbNqzo1unxStOuAlheowtolDDTW7TBsq9OCIe1n53P1hG0Gawcu9/s320/SetFlagIcon.jpg" alt="" id="BLOGGER_PHOTO_ID_5217577728942614530" border="0" /></a><br />Next, add the following code to the UserForm (make sure you use the same names for the controls or modify accordingly):<br /><pre><code><span style="color:purple;"><br />' frmSetFlagIcon<br /><br />' Developed by Warren Bain on 30/06/2008<br />' Copyright (c) Thought Croft Pty Ltd<br />' All rights reserved.<br /><br />' This module allows me to set the Follow Up Flag colour<br />' for unsaved new email which I want to do so I can track<br />' emails that I send and need to follow up using TROG by Priacta<br /><br />Option Explicit<br /><br />' -----------------<br />' Module variables<br />' -----------------<br /><br />Dim moMail As MailItem<br />Dim mblnSent As Boolean<br />Dim moFlagStatus As OlFlagStatus<br />Dim moFlagIcon As OlFlagIcon<br /><br />' -----------------<br />' Module procedures<br />' -----------------<br /><br />Private Sub cboFlagIcon_Change()<br /><br />' If we have unset the flag then the<br />' FlagStatus must be set appropriately<br /><br />If IsNull(Me.cboFlagIcon) Then<br /> moFlagIcon = olNoFlagIcon<br />Else<br /> moFlagIcon = Me.cboFlagIcon<br />End If<br />If moFlagIcon = olNoFlagIcon Then<br /> moFlagStatus = olNoFlag<br />Else<br /> moFlagStatus = olFlagMarked<br />End If<br />Call DisplayControls<br /><br />End Sub<br /><br />Private Sub ckbCompleted_Change()<br /><br />' If they mark it complete then alter<br />' FlagStatus accordingly<br /><br />If Me.ckbCompleted Then<br /> moFlagStatus = olFlagComplete<br />Else<br /> moFlagStatus = olFlagMarked<br />End If<br />Call DisplayControls<br /><br />End Sub<br /><br />Private Sub cmdCancel_Click()<br /><br />' Clear global object and close form<br /><br />Set moMail = Nothing<br />Unload Me<br /><br />End Sub<br /><br />Private Sub cmdOK_Click()<br /><br />If Not moMail Is Nothing Then<br /> With moMail<br /> If moFlagIcon <> .FlagIcon Or moFlagStatus <> .FlagStatus Then<br /> ' They altered something so update MailItem<br /> .FlagStatus = moFlagStatus<br /> .FlagIcon = moFlagIcon<br /> .Save<br /> End If<br /> End With<br />End If<br /><br />Set moMail = Nothing<br />Unload Me<br /><br />End Sub<br /><br />Private Sub UserForm_Initialize()<br /><br />' Set up the different colours available<br />' to us when the form is first opened<br />' The two arrays must be kept<br />' in step and in the order required<br /><br />Dim astrColours As Variant<br />Dim avarFlagIcons As Variant<br />Dim i As Integer<br />Dim oInsp As Inspector<br />Dim oItem As Object<br /><br /><br />With Me.cboFlagIcon<br /> astrColours = Array("No flag set", "Red", "Blue", _<br /> "Yellow", "Green", _<br /> "Orange", "Purple")<br /> avarFlagIcons = Array(olNoFlagIcon, olRedFlagIcon, olBlueFlagIcon, olYellowFlagIcon, _<br /> olGreenFlagIcon, olOrangeFlagIcon, olPurpleFlagIcon)<br /> For i = LBound(astrColours) To UBound(astrColours)<br /> .AddItem<br /> .List(i, 0) = avarFlagIcons(i)<br /> .List(i, 1) = astrColours(i)<br /> Next i<br />End With<br /><br />' Now see which mail item is being referenced<br />' and prepare ourselves for working with it<br />Set oInsp = Application.ActiveInspector<br />If Not oInsp Is Nothing Then<br /> Set oItem = oInsp.CurrentItem<br /> If TypeOf oItem Is MailItem Then<br /> ' We have a mail item to work with so<br /> ' retrieve the current flag settings<br /> Set moMail = oItem<br /> With moMail<br /> mblnSent = .Sent<br /> moFlagStatus = .FlagStatus<br /> moFlagIcon = .FlagIcon<br /> End With<br /> Me.ckbCompleted = (moFlagStatus = olFlagComplete)<br /> Me.cboFlagIcon = moFlagIcon<br /> End If<br />End If<br /><br />Set oItem = Nothing<br />Set oInsp = Nothing<br /><br />End Sub<br /><br />Private Sub DisplayControls()<br /><br />' Ensure that the controls are enabled<br />' consistently with their settings<br /><br />If Not moMail Is Nothing Then<br /><br /> ' Only allow OK if they have actually altered the<br /> ' controls to be different from the MailItem<br /> With moMail<br /> Me.cmdOK.Enabled = moFlagIcon <> .FlagIcon _<br /> Or moFlagStatus <> .FlagStatus<br /> End With<br /><br /> ' Allow them to set Completed if the flag is set and SENT<br /> ' and allow Flag Icon change if incomplete<br /> Me.cboFlagIcon.Enabled = Not Me.ckbCompleted<br /> Me.ckbCompleted.Enabled = (Me.cboFlagIcon <> olNoFlagIcon) And mblnSent<br /><br />End If<br /><br />End Sub<br /></span></code></pre><br />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 <span style="font-style: italic; font-weight: bold;">Add Reminder...</span> menu item under <span style="font-weight: bold; font-style: italic;">Actions | Follow Up</span> submenu, or click the <span style="font-weight: bold; font-style: italic;">Follow Up</span> button on the <span style="font-weight: bold; font-style: italic;">Standard </span>menubar, our form will be displayed instead of the inbuilt Outlook one. Name the class module clsInspectorHandler and paste this code into it.<br /><br />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.<br /><pre><code><span style="color:purple;"><br />' clsInspectorHandler<br /><br />' Developed by Warren Bain on 30/06/2008<br />' Copyright (c) Thought Croft Pty Ltd<br />' All rights reserved.<br /><br />Option Explicit<br /><br />Dim WithEvents oInspector As Outlook.Inspector<br />Dim WithEvents oCBB1 As Office.CommandBarButton<br />Dim WithEvents oCBB2 As Office.CommandBarButton<br />Dim mstrUniqueTag As Integer<br /><br />Private Sub Class_Initialize()<br />' Create a unique key for tag usage<br />Randomize<br />mstrUniqueTag = Int((9999 - 0 + 1) * Rnd + 0)<br />End Sub<br /><br />Private Sub Class_Terminate()<br />Set oCBB1 = Nothing<br />Set oCBB2 = Nothing<br />Set oInspector = Nothing<br />End Sub<br /><br />Private Sub oCBB1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)<br />' We want to prevent this one from running and load our own<br />If Ctrl.Tag = mstrUniqueTag Then<br /> frmSetFlagIcon.Show<br /> CancelDefault = True<br />End If<br />End Sub<br /><br />Private Sub oCBB2_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)<br />' We want to prevent this one from running and load our own<br />If Ctrl.Tag = mstrUniqueTag Then<br /> frmSetFlagIcon.Show<br /> CancelDefault = True<br />End If<br />End Sub<br /><br />Private Sub oInspector_Close()<br />Set oCBB1 = Nothing<br />Set oCBB2 = Nothing<br />End Sub<br /><br />Public Sub SetInspector(Inspector As Outlook.Inspector)<br />If Not Inspector Is Nothing Then<br /> Set oInspector = Inspector<br /> With oInspector<br /> ' 1678 = Standard menu button "Follow &Up"<br /> ' 7478 = Action menu Follow Up submenu item "&Add Reminder..."<br /> Set oCBB1 = .CommandBars.FindControl(msoControlButton, 1678)<br /> oCBB1.Tag = mstrUniqueTag<br /> Set oCBB2 = .CommandBars.FindControl(msoControlButton, 7478)<br /> oCBB1.Tag = mstrUniqueTag<br /> End With<br />End If<br />End Sub<br /></span></code></pre><br />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 <a href="http://www.outlookcode.com/codedetail.aspx?id=1507">enumerate all CommandBars in Outlook</a>.<br /><br />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.<br /><pre><code><span style="color:purple;"><br />Public WithEvents colInspectors As Outlook.Inspectors<br />Public gcolMyInspectors As Collection<br /><br />Private Sub Application_Quit()<br /> Set gcolMyInspectors = Nothing<br /> Set colInspectors = Nothing<br />End Sub<br /><br />Private Sub Application_Startup()<br /> Set gcolMyInspectors = New Collection<br /> Set colInspectors = Application.Inspectors<br />End Sub<br /><br />Private Sub colInspectors_NewInspector(ByVal Inspector As Inspector)<br /><br /> ' This will be called everytime we open<br /> ' a new Inspector, so check if this is<br /> ' one that we want to monitor<br /><br /> Dim MyInspectorHandler As clsInspectorHandler<br /><br /> If Inspector.CurrentItem.Class = olMail Then<br /> If Not Inspector.CurrentItem.Sent Then<br /> ' This is an unsent email so we want to<br /> ' trap the buttons that can be clicked<br /> Set MyInspectorHandler = New clsInspectorHandler<br /> Call MyInspectorHandler.SetInspector(Inspector)<br /> gcolMyInspectors.Add MyInspectorHandler<br /> End If<br /> End If<br />End Sub<br /></span></code></pre><br />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.Unknownnoreply@blogger.com1tag:blogger.com,1999:blog-19287583.post-11096976563160668582008-06-24T17:40:00.006+10:002010-02-26T17:12:43.723+11:00Generate PasswordThis 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.<br /><br /><pre><code><span style="color:purple;"><br />Public Function GeneratePassword( _<br /> ByVal intLength As Integer) As String<br /><br /> ' Generates a random string of digits of the requested length<br /><br /> ' In:<br /> ' intLength - number of digits to be returned (max 9)<br /> ' Out:<br /> ' Return Value - a random string of digits<br /> ' Example:<br /> ' GetPassword(3) = "927"<br /><br /> Dim lngHighNumber As Long<br /> Dim lngLowNumber As Long<br /> Dim lngRndNumber As Long<br /><br /> ' Check we don't exceed our maximum range<br /> If intLength > 9 Or intLength < 1 Then<br /> Err.Raise 5, "GetPassword", _<br /> "Invalid string length - must be between 1 and 9"<br /> Else<br /> ' Work out the numbers<br /> lngLowNumber = 10 ^ (intLength - 1)<br /> lngHighNumber = (10 ^ intLength) - 1<br /> ' Generate a new seed and a new random number<br /> Randomize<br /> lngRndNumber = Int((lngHighNumber - lngLowNumber + 1) * Rnd) + lngLowNumber<br /> ' Format the result as string<br /> GeneratePassword = Format$(lngRndNumber, String$(intLength, "0"))<br /> End If<br />End Function<br /></span></code></pre>Unknownnoreply@blogger.com1tag:blogger.com,1999:blog-19287583.post-30870670191461643252008-06-19T17:53:00.006+10:002008-06-25T15:42:57.185+10:00Automation Manager ClassI 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:<br /><br /><li>* reuse of any existing instance of Excel or start an instance if there wasn't one</li><br /><li>* save the state of the application - things like the calculation mode etc and restore them when finished</li><br /><li>* work out whether to close the instance when finished (if we started it) or leave it (if we didn't)</li><br /><li>* 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</li><br />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.<br /><br />Typical calling method is as follows:<br /><PRE><CODE><FONT color="purple"><br />' Give this global scope<br />Public asm As AppStateMgr<br />Public app as Object<br /><br />Set asm = New AppStateMgr<br />'<br />' Do something and decide we need to open Excel, say<br />'<br />Call asm.OpenApplication("Excel",app)<br />'<br />' Now open a workbook say and check for errors<br />'<br />If asm.CheckApplicationError(app,Err.Number) Then<br /> ' Something bad happened so deal with it<br /> ' If the error was catastrophic to Excel<br /> ' a new instance will be started anyway<br />Else<br /> ' Everything is fine, so something else<br />End If<br />'<br />' Finishing up now<br />'<br />Call asm.CloseApplication(app)<br />Set asm = Nothing<br /></FONT></CODE></PRE><br /><br />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.<br /><PRE><CODE><FONT color="purple"><br />' Class for defining an application state which can be<br />' saved and restored using the AppStateMgr class<br /><br />' Developed by Warren Bain on 16/11/2006<br />' Copyright (c) Thought Croft Pty Ltd<br />' http:\\www.thoughtcroft.com<br />' All rights reserved.<br /><br />Option Explicit<br /><br />' Pointer calculated from the object used to index the state collection<br />' and the name of the application object this relates to<br />Private mstrIndex As String<br />Private mstrAppName As String<br /><br />' Was the application instance created by us and how many are using it<br />Private mblnSelfStarted As Boolean<br />Private mlngObjectCount As Long<br /><br />' Common application properties<br />Private mblnDisplayAlerts As Boolean<br />Private mblnScreenUpdating As Boolean<br />Private mblnVisible As Boolean<br />Private mlnghWnd As Long<br /><br />' This one is only with Excel<br />Private meCalculation As Variant<br /><br />Friend Property Get ObjectCount() As Long<br /> ObjectCount = mlngObjectCount<br />End Property<br /><br />Friend Property Get DisplayAlerts() As Boolean<br /> DisplayAlerts = mblnDisplayAlerts<br />End Property<br /><br />Friend Property Let DisplayAlerts(ByVal blnDisplayAlerts As Boolean)<br /> mblnDisplayAlerts = blnDisplayAlerts<br />End Property<br /><br />Friend Property Get SelfStarted() As Boolean<br /> SelfStarted = mblnSelfStarted<br />End Property<br /><br />Friend Property Let SelfStarted(ByVal blnSelfStarted As Boolean)<br /> mblnSelfStarted = blnSelfStarted<br />End Property<br /><br />Friend Property Get ScreenUpdating() As Boolean<br /> ScreenUpdating = mblnScreenUpdating<br />End Property<br /><br />Friend Property Let ScreenUpdating(ByVal blnScreenUpdating As Boolean)<br /> mblnScreenUpdating = blnScreenUpdating<br />End Property<br /><br />Friend Property Get Visible() As Boolean<br /> Visible = mblnVisible<br />End Property<br /><br />Friend Property Let Visible(ByVal blnVisible As Boolean)<br /> mblnVisible = blnVisible<br />End Property<br /><br />Friend Property Get Index() As String<br /> Index = mstrIndex<br />End Property<br /><br />Friend Property Let Index(ByVal strIndex As String)<br /> ' Can only assign this if the value is empty<br /> ' i.e. after it has been set, it is read only!<br /> If Len(mstrIndex) = 0 Then<br /> mstrIndex = strIndex<br /> Else<br /> Err.Raise vbObjectError + 5, "AppState", _<br /> "Can't alter the Index after created!"<br /> End If<br />End Property<br /><br />Friend Function IncrementCount() As Long<br /> ' Increase the count of objects using this application <br /> mlngObjectCount = mlngObjectCount + 1<br /> IncrementCount = mlngObjectCount<br />End Function<br /><br />Friend Function DecrementCount() As Long<br /> ' Decrease the count of objects using this application<br /> mlngObjectCount = mlngObjectCount - 1<br /> DecrementCount = mlngObjectCount<br />End Function<br /><br />Friend Property Get AppName() As String<br /> AppName = mstrAppName<br />End Property<br /><br />Friend Property Let AppName(ByVal strAppName As String)<br /> ' Can only assign this if the value is empty<br /> ' i.e. after it has been set, it is read only!<br /> If Len(mstrAppName) = 0 Then<br /> mstrAppName = strAppName<br /> Else<br /> Err.Raise vbObjectError + 5, "AppState", _<br /> "Can't alter the AppName after created!"<br /> End If<br />End Property<br /><br />Friend Property Get Calculation() As Variant<br /> Calculation = meCalculation<br />End Property<br /><br />Friend Property Let Calculation(ByVal eCalculation As Variant)<br /> meCalculation = eCalculation<br />End Property<br /><br />Friend Property Get WindowsHandle() As Long<br /> WindowsHandle = mlnghWnd<br />End Property<br /><br />Friend Property Let WindowsHandle(ByVal lngWindowsHandle As Long)<br /> mlnghWnd = lngWindowsHandle<br />End Property<br /></FONT></CODE></PRE><br /><br />Create a Class Module called AppStateMgr and copy the following code into it. This provides the functions for managing instances of automation clients.<br /><PRE><CODE><FONT color="purple"><br />' Manage the state of automation application objects and associated<br />' functions for saving, restoring the application state as well as<br />' handling typical automation errors, etc<br /><br />' Developed by Warren Bain on 16/11/2006<br />' Copyright (c) Thought Croft Pty Ltd<br />' http:\\www.thoughtcroft.com<br />' All rights reserved.<br /><br />Option Explicit<br /><br />Private Const PROCESS_TERMINATE As Long = (&H1)<br />Private Const SW_SHOWNORMAL = 1<br /><br />Private Declare Function apiFindWindow Lib "user32" Alias "FindWindowA" ( _<br /> ByVal strClass As String, _<br /> ByVal lpWindow As String) As Long<br /><br />Private Declare Function apiSendMessage Lib "user32" Alias "SendMessageA" ( _<br /> ByVal hwnd As Long, _<br /> ByVal Msg As Long, _<br /> ByVal wParam As Long, _<br /> ByVal lParam As Long) As Long<br /><br />Private Declare Function apiSetForegroundWindow Lib "user32" Alias "SetForegroundWindow" ( _<br /> ByVal hwnd As Long) As Long<br /><br />Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" ( _<br /> ByVal hwnd As Long, _<br /> ByVal nCmdShow As Long) As Long<br /><br />Private Declare Function apiIsIconic Lib "user32" Alias "IsIconic" ( _<br /> ByVal hwnd As Long) As Long<br /><br />Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _<br /> ByRef Destination As Any, _<br /> ByRef Source As Any, _<br /> ByVal Length As Long)<br /><br />Private Declare Function CloseHandle Lib "kernel32.dll" ( _<br /> ByVal hObject As Long) As Long<br /><br />Private Declare Function GetWindowThreadProcessId Lib "user32.dll" ( _<br /> ByVal hwnd As Long, _<br /> ByRef lpdwProcessId As Long) As Long<br /><br />Private Declare Function OpenProcess Lib "kernel32.dll" ( _<br /> ByVal dwDesiredAccess As Long, _<br /> ByVal bInheritHandle As Long, _<br /> ByVal dwProcessId As Long) As Long<br /><br />Private Declare Function TerminateProcess Lib "kernel32.dll" ( _<br /> ByVal hProcess As Long, _<br /> ByVal uExitCode As Long) As Long<br /><br /><br />' Collection for holding the application states<br />Private mcolAppStateCol As Collection<br /><br />Friend Property Get AppStateCol() As Collection<br /> ' Return collection object, create if necessary<br /> If mcolAppStateCol Is Nothing Then<br /> Set mcolAppStateCol = New Collection<br /> End If<br /> Set AppStateCol = mcolAppStateCol<br />End Property<br /><br />Public Function CheckApplicationError( _<br /> ByRef objApp As Object, _<br /> ByVal lngErrNumber As Long) As Boolean<br /><br /> ' Check for a range of automation errors that can occur<br /> ' and try and recover from them, typically by restarting<br /> ' the application server. Returns True if the App<br /> ' had to be recovered due to Automation errors<br /><br /> ' Normally, lngErrNumber will contain the value from<br /> ' Err.Number after a call to an automation client related<br /> ' object but can be passed a negative number to force a restart<br /><br /> Const conSpecificAutomationErrorEndRange = 0<br /> Const conObjectRequiredError = 424<br /> Const conGeneralAutomationError = 440<br /> Const conAutomationNotSupportedError = 458<br /> Const conRemoteServerLostError = 462<br /> Const conApplicationDefinedError = 1004<br /><br /> Dim objState As AppState<br /><br /> If objApp Is Nothing Then<br /> ' Must have application to work with here<br /> Err.Raise vbObjectError + 5, "AppStateMgr::CheckApplication", _<br /> "Must supply a valid App object"<br /> Else<br /> Select Case lngErrNumber<br /> Case Is < conSpecificAutomationErrorEndRange, _<br /> conObjectRequiredError, _<br /> conGeneralAutomationError, _<br /> conAutomationNotSupportedError, _<br /> conRemoteServerLostError, _<br /> conApplicationDefinedError<br /> ' Definitely an unrecoverable automation error<br /> ' so force a close, getting the state so we can<br /> ' determine the app type and force a new instance<br /> Set objState = CloseApplication(objApp, True)<br /> Call OpenApplication(objState.AppName, objApp, True)<br /> Set objState = Nothing<br /> CheckApplicationError = True<br /> End Select<br /> End If<br />End Function<br /><br />Private Function CheckAppRunning( _<br /> ByVal strAppName As String, _<br /> Optional ByVal blnActivate As Boolean) As Boolean<br /><br /> ' This code was originally written by Dev Ashish<br /> ' but has been enhanced to cope with other classes<br /> ' of application by Warren Bain<br /><br /> Const WM_USER = 1024<br /><br /> Dim lngH As Long<br /> Dim strClassName As String<br /> Dim lngX As Long<br /> Dim lngTmp As Long<br /><br /> On Local Error GoTo HandleErrors<br /><br /> CheckAppRunning = False<br /> strClassName = GetClassName(strAppName)<br /> If Len(strClassName) = 0 Then<br /> lngH = apiFindWindow(vbNullString, strAppName)<br /> Else<br /> lngH = apiFindWindow(strClassName, vbNullString)<br /> End If<br /> If lngH <> 0 Then<br /> apiSendMessage lngH, WM_USER + 18, 0, 0<br /> lngX = apiIsIconic(lngH)<br /> If lngX <> 0 Then<br /> lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)<br /> End If<br /> If blnActivate Then<br /> lngTmp = apiSetForegroundWindow(lngH)<br /> End If<br /> CheckAppRunning = True<br /> End If<br /><br />ExitHere:<br /> Exit Function<br />HandleErrors:<br /> CheckAppRunning = False<br /> Resume ExitHere<br />End Function<br /><br />Private Sub Class_Terminate()<br /><br /> ' Destroy the collection object if there are<br /> ' still members that we haven't terminated before hand<br /><br /> If Not mcolAppStateCol Is Nothing Then<br /> Set mcolAppStateCol = Nothing<br /> End If<br /><br />End Sub<br /><br />Public Sub CloseAllApplications( _<br /> Optional ByVal blnForceKill As Boolean = False)<br /><br /> ' Walk the collection and call CloseApplication for<br /> ' each instance we have available to us.<br /><br /> ' ***************** WARNING ************************<br /> ' Use extreme care calling as this will terminate the<br /> ' application without cleaning up any objects still<br /> ' pointing at it. May cause host app to crash on exit<br /> ' **************************************************<br /><br /> Dim objState As AppState<br /> Dim i As Integer<br /><br /> If Not Me.AppStateCol Is Nothing Then<br /> For i = Me.AppStateCol.Count To 1 Step -1<br /> ' Create an object for each<br /> ' member that was created<br /> ' using GetObjectFromPtr<br /> Set objState = Me.AppStateCol(i)<br /> Call CloseApplication(GetObjectFromPtr(objState.Index), _<br /> blnForceKill, _<br /> objState)<br /> Next i<br /> End If<br /><br />End Sub<br /><br />Public Function CloseApplication( _<br /> ByRef objApp As Object, _<br /> Optional ByVal blnForceKill As Boolean = False, _<br /> Optional ByRef objState As AppState) As AppState<br /><br /> ' Restore application state and leave it running if it<br /> ' was not started by us (unless they want us to kill it)<br /> ' or if there are others using it<br /><br /> Dim blnShutDown As Boolean<br /> Dim blnLastState As Boolean<br /><br /> If Not objApp Is Nothing Then<br /> ' Find the saved status of the application<br /> ' and work out if we started it - if no<br /> ' saved state, then assume we didn't start it<br /> If objState Is Nothing Then<br /> ' They didn't supply it so, find it<br /> ' Don't worry about trapping errors<br /> On Error Resume Next<br /> Set objState = FindAppState(objApp)<br /> On Error GoTo 0<br /> End If<br /> If objState Is Nothing Then<br /> ' No state saved so action depends on ForceKill value<br /> blnShutDown = blnForceKill<br /> Else<br /> ' Decrement count of objects to decide if we should<br /> ' really shut this one down as well<br /> With objState<br /> blnLastState = (.DecrementCount <= 0)<br /> blnShutDown = blnForceKill Or _<br /> (.SelfStarted And blnLastState)<br /> End With<br /> End If<br /><br /> ' Did we start it and no-one else using it<br /> ' or do they want to kill it anyway?<br /> If blnShutDown Then<br /> ' Don't bother restoring, just terminate the application<br /> Call TerminateApplication(objApp, objState)<br /> ElseIf blnLastState Then<br /> ' Attempt to restore the application state<br /> ' as we have finished with it in this process<br /> ' and remove it from the list<br /> Call RestoreAppState(objApp, objState)<br /> End If<br /> Call RemoveAppState(objState)<br /> Set CloseApplication = objState<br /> ' Force release of application object to ensure<br /> ' application will shutdown normally<br /> Set objApp = Nothing<br /> End If<br />End Function<br /><br />Private Function FindAppState( _<br /> ByRef objApp As Object, _<br /> Optional ByVal strName As String = vbNullString, _<br /> Optional ByVal blnCreateNew As Boolean = False) As AppState<br /><br /> ' Retrieve an existing AppSave object or<br /> ' if not available then add a new one if<br /> ' caller requests us to CreateNew<br /><br /> Dim objState As AppState<br /><br /> If objApp Is Nothing Then<br /> ' Can't do this if there isn't any object<br /> Err.Raise vbObjectError + 5, "AppStateMgr::FindAppState", _<br /> "Must supply an instantiated object (not Nothing)!"<br /> Else<br /> ' Check compatible parameters<br /> If Len(strName) = 0 And blnCreateNew Then<br /> ' Can't create if we don't know the AppName<br /> Err.Raise vbObjectError + 13, "AppStateMgr::FindAppState", _<br /> "Can't specify 'CreateNew' without supplying 'Name'!"<br /> Else<br /> On Error Resume Next<br /> Set objState = Me.AppStateCol(GetObjPtr(objApp))<br /> On Error GoTo 0<br /> If objState Is Nothing Then<br /> If blnCreateNew Then<br /> Set objState = SaveAppState(objApp, strName)<br /> Else<br /> Err.Raise vbObjectError + 63, "AppStateMgr::FindAppState", _<br /> "Can't find required 'AppState' for this object!"<br /> End If<br /> ElseIf objState.AppName <> strName And Len(strName) > 0 Then<br /> ' Found existing one but it doesn't match<br /> ' the AppName we are expecting - whoops!<br /> Err.Raise vbObjectError + 13, "AppStateMgr::FindAppState", _<br /> "Conflict with 'AppName' supplied [" & strName & _<br /> "] and retrieved [" & objState.AppName & "]!"<br /> End If<br /> Set FindAppState = objState<br /> End If<br /> End If<br />End Function<br /><br />Private Function GeneratePassword( _<br /> ByVal intLength As Integer) As String<br /><br /> ' Generates a random string of digits of the requested length<br /><br /> Dim lngHighNumber As Long<br /> Dim lngLowNumber As Long<br /> Dim lngRndNumber As Long<br /><br /> ' Check we don't exceed our maximum range<br /> If intLength > 9 Or intLength < 1 Then<br /> Err.Raise 5, "GetPassword", _<br /> "Invalid string length - must be between 1 and 9"<br /> Else<br /> ' Work out the numbers<br /> lngLowNumber = 10 ^ (intLength - 1)<br /> lngHighNumber = (10 ^ intLength) - 1<br /> ' Generate a new seed and a new random number<br /> Randomize<br /> lngRndNumber = Int((lngHighNumber - lngLowNumber + 1) * Rnd) + lngLowNumber<br /> ' Format the result as string<br /> GeneratePassword = Format$(lngRndNumber, String$(intLength, "0"))<br /> End If<br />End Function<br /><br />Private Function GetApplicationHandle(ByRef objApp As Object) As Long<br /><br /> ' Locate the windows handle for the application<br /> ' represented by this object<br /><br /> Dim hwnd As Long<br /> Dim varCaption As Variant<br /><br /> On Error Resume Next<br /><br /> ' Determine the type of object - can make it easy<br /> ' as the object may store it itself<br /> If TypeOf objApp Is Access.Application Then<br /> hwnd = objApp.hWndAccessApp<br /> ElseIf TypeOf objApp Is Excel.Application Then<br /> ' This only works for Excel 2002 onwards<br /> hwnd = objApp.hwnd<br /> End If<br /> On Error GoTo 0<br /><br /> If hwnd = 0 Then<br /> ' Need to discover it from the Window so we make sure<br /> ' that the caption is unique for this application<br /> varCaption = objApp.Caption<br /> objApp.Caption = GeneratePassword(8)<br /> hwnd = apiFindWindow(GetClassName(objApp.Name), objApp.Caption)<br /> objApp.Caption = varCaption<br /> End If<br /> GetApplicationHandle = hwnd<br />End Function<br /><br />Private Function GetClassName(ByVal strAppName As String) As String<br /><br /> ' Returns the Class Name for the main window of various<br /> ' Microsoft software applications<br /><br /> Select Case LCase$(strAppName)<br /> Case "excel", "microsoft excel": GetClassName = "XLMain"<br /> Case "word", "microsoft word": GetClassName = "OpusApp"<br /> Case "access", "microsoft access": GetClassName = "OMain"<br /> Case "powerpoint95": GetClassName = "PP7FrameClass"<br /> Case "powerpoint97": GetClassName = "PP97FrameClass"<br /> Case "powerpoint2000": GetClassName = "PP9FrameClass"<br /> Case "powerpoint2002": GetClassName = "PP10FrameClass"<br /> Case "powerpoint2003": GetClassName = "PP11FrameClass"<br /> Case "powerpoint2007": GetClassName = "JWinproj-WhimperMainClass"<br /> Case "project", "microsoft project": GetClassName = "PP9FrameClass"<br /> Case "notepad": GetClassName = "NOTEPAD"<br /> Case "paintbrush": GetClassName = "pbParent"<br /> Case "wordpad": GetClassName = "WordPadClass"<br /> Case Else: GetClassName = vbNullString<br /> End Select<br />End Function<br /><br />Private Function GetObjectFromPtr(ByVal lPtr As Long) As Object<br /><br /> ' Based on Bruce McKinney's code for getting an Object from the<br /> ' object pointer - the reverse of ObjPtr(object).<br /><br /> Dim objT As Object<br /><br /> On Error GoTo HandleError<br /><br /> CopyMemory objT, lPtr, 4<br /> Set GetObjectFromPtr = objT<br /> Exit Function<br /><br />HandleError:<br /> With Err<br /> .Raise .Number, "AppStateMgr::GetObjectFromPtr" & .Source, _<br /> .Description, .HelpFile, .HelpContext<br /> End With<br />End Function<br /><br />Private Function GetObjPtr(ByRef obj As Object) As String<br /><br /> ' This relies on undocumented function to return<br /> ' the address of the object pointer in memory<br /> ' which is useful for fast indexing into a collection<br /> ' of objects or object related data. Returns null string<br /> ' if object hasn't been assigned yet<br /><br /> If obj Is Nothing Then<br /> GetObjPtr = vbNullString<br /> Else<br /> GetObjPtr = CStr(ObjPtr(obj))<br /> End If<br />End Function<br /><br />Public Sub OpenApplication( _<br /> ByVal strAppName As String, _<br /> ByRef objApp As Object, _<br /> Optional ByVal blnForceNewInstance As Boolean = False, _<br /> Optional ByVal blnDisplayAlerts As Boolean = False)<br /><br /> ' Check if object is already referencing an application and<br /> ' if not then first try and use existing automation client if<br /> ' running else start a new one and save its state. The caller<br /> ' can force us to create a new instance if they wish although<br /> ' this also depends on the application which may only single instance<br /><br /> Dim objState As AppState<br /> Dim blnSelfStarted As Boolean<br /><br /> On Error GoTo HandleErrors<br /><br /> If objApp Is Nothing Then<br /> ' Try and locate an existing instance first before starting new one<br /> If CheckAppRunning(strAppName) And Not blnForceNewInstance Then<br /> ' Server already running so return reference to it<br /> Set objApp = GetObject(, strAppName & ".Application")<br /> blnSelfStarted = False<br /> Else<br /> ' Need to start a new instance of required server application<br /> Set objApp = CreateObject(strAppName & ".Application")<br /> blnSelfStarted = True<br /> End If<br /><br /> ' Now find the state - if it doesn't exist then it will create a<br /> ' new one and save app state.<br /> Set objState = FindAppState(objApp, strAppName, True)<br /><br /> ' Increment the counter and set the DisplayAlert property<br /> objState.IncrementCount<br /> objApp.DisplayAlerts = blnDisplayAlerts<br /> <br /> ' Save whether we started it but don't update it<br /> ' if we didn't because may have been done by previous<br /> ' call using a different object variable<br /> If blnSelfStarted Then<br /> objState.SelfStarted = blnSelfStarted<br /> End If<br /> End If<br /><br />ExitHere:<br /> Exit Sub<br /><br />HandleErrors:<br /> With Err<br /> Select Case .Number<br /> Case Else<br /> .Raise .Number, "AppStateMgr::OpenApplication", .Description, .HelpFile, .HelpContext<br /> End Select<br /> End With<br /> Resume ExitHere<br />End Sub<br /><br />Private Function RemoveAppState(ByRef objState As AppState)<br /><br /> ' To remove the supplied AppState object from the<br /> ' collection - no longer required<br /><br /> If Not objState Is Nothing Then<br /> Me.AppStateCol.Remove objState.Index<br /> End If<br />End Function<br /><br />Private Function RestoreAppState( _<br /> ByRef objApp As Object, _<br /> Optional ByRef objState As AppState = Nothing) As AppState<br /><br /> ' To find existing AppState and restore the state<br /> ' of the supplied application object<br /><br /> ' If application is already nothing then exit<br /> If Not objApp Is Nothing Then<br /> If objState Is Nothing Then<br /> ' No AppState supplied so go find it -<br /> ' note that this call will raise an error<br /> ' if the AppState can't be found<br /> Set objState = FindAppState(objApp)<br /> End If<br /><br /> ' We will have a valid AppState now<br /> With objApp<br /><br /> ' *************************************<br /> ' These properties apply to all objects<br /> .DisplayAlerts = objState.DisplayAlerts<br /> .ScreenUpdating = objState.ScreenUpdating<br /><br /> ' Can only reset this if we started it<br /> If Not .UserControl Then<br /> .Visible = objState.Visible<br /> End If<br /><br /> ' -------------------------------------<br /> ' Properties specific to Excel<br /> If TypeOf objApp Is Excel.Application Then<br /> ' Can only reset this if we started it<br /> If Not .UserControl Then<br /> .Calculation = objState.Calculation<br /> End If<br /> End If<br /><br /> End With<br /> Set RestoreAppState = objState<br /> End If<br />End Function<br /><br />Private Function SaveAppState( _<br /> ByRef objApp As Object, _<br /> ByVal strName As String) As AppState<br /><br /> ' To create a new AppState and save the state<br /> ' of the supplied application object<br /><br /> Dim objState As AppState<br /><br /> If Not objApp Is Nothing Then<br /> ' Create a new instance and save key state info<br /> Set objState = New AppState<br /> With objState<br /><br /> ' *************************************<br /> ' These properties apply to all objects<br /> .Index = GetObjPtr(objApp)<br /> .AppName = strName<br /> .WindowsHandle = GetApplicationHandle(objApp)<br /> .DisplayAlerts = objApp.DisplayAlerts<br /> .Visible = objApp.Visible<br /> .ScreenUpdating = objApp.ScreenUpdating<br /><br /> ' -------------------------------------<br /> ' Properties specific to Excel<br /> If TypeOf objApp Is Excel.Application Then<br /> .Calculation = objApp.Calculation<br /> End If<br /><br /> ' Now add to the collection<br /> Me.AppStateCol.Add objState, .Index<br /> End With<br /> Set SaveAppState = objState<br /> End If<br />End Function<br /><br />Private Sub TerminateApplication( _<br /> ByRef objApp As Object, _<br /> ByRef objState As AppState)<br /><br /> ' This will try and exit the application and<br /> ' also terminate the process where the<br /> ' automation server is not responding<br /><br /> Dim hWndApp As Long<br /> Dim hProcessID As Long<br /> Dim hThreadID As Long<br /> Dim hTerminateID As Long<br /><br /><br /> On Error Resume Next<br /> If Not objApp Is Nothing Then<br /> If objState Is Nothing Then<br /> hWndApp = GetApplicationHandle(objApp)<br /> Else<br /> hWndApp = objState.WindowsHandle<br /> End If<br /><br /> ' Now close the application normally - the Quit just<br /> ' allows the application to close its objects but it<br /> ' doesn't actually terminate until we close the object<br /> objApp.Quit<br /> Set objApp = Nothing<br /> DoEvents<br /><br /> If hWndApp <> 0 Then<br /> ' Find the processid of the selected window in case it didn't<br /> ' close normally in which case we will get an id back<br /> hThreadID = GetWindowThreadProcessId(hWndApp, hProcessID)<br /> If hProcessID <> 0 Then<br /> ' Acquire a handle with terminate ability and try and kill it<br /> ' don't worry about failing as there is nothing we can do anyway<br /> hTerminateID = OpenProcess(PROCESS_TERMINATE, 0, hProcessID)<br /> Call TerminateProcess(hTerminateID, 0)<br /> Call CloseHandle(hTerminateID)<br /> End If<br /> End If<br /> End If<br />End Sub<br /></FONT></CODE></PRE>Unknownnoreply@blogger.com3tag:blogger.com,1999:blog-19287583.post-65881812827382255942008-06-18T10:53:00.005+10:002008-06-18T12:15:15.926+10:00Strip Different Types of Characters from a StringI realised that one of my earlier posts <a href="http://vbaadventures.blogspot.com/2007/10/generic-function-to-copy-excel-data.html">Generic Function to Copy Excel Data</a> 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.<br /><br />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)<br /><br /><PRE><CODE><FONT color="purple"><br />' Note: Vba6 is a conditional compiler constant that indicates<br />' the version of VBA and in this module we use enumerated types if<br />' supported otherwise we use plain old public constants<br /><br />#If CBool(VBA6) Then<br />' Enumerate methods for selecting mode of character removal<br />Public Enum StripCharsMode<br /> scmcRemoveAlphas = 2 ^ 0<br /> scmcRemoveControl = 2 ^ 1<br /> scmcRemoveNumerics = 2 ^ 2<br /> scmcRemoveSpaces = 2 ^ 3<br /> scmcRemoveOthers = 2 ^ 4<br /> scmcRemoveAll = 2 ^ 5 - 1<br /> scmcKeepAlphas = scmcRemoveAll - scmcRemoveAlphas<br /> scmcKeepLetters = scmcRemoveAll - scmcRemoveAlphas - scmcRemoveSpaces<br /> scmcKeepNumerics = scmcRemoveAll - scmcRemoveNumerics<br /> scmcKeepOthers = scmcRemoveAll - scmcRemoveOthers<br /> scmcKeepControl = scmcRemoveAll - scmcRemoveControl<br />End Enum<br /><br />Public Function tcStripChars( _<br /> ByVal strInputText As String, _<br /> ByVal scmRemoveType As StripCharsMode) _<br /> As String<br /> <br /> Dim scmCharMode As StripCharsMode<br />#Else<br />' Constants for selecting mode of character removal<br />Public Const scmcRemoveAlphas As Integer = 2 ^ 0<br />Public Const scmcRemoveControl As Integer = 2 ^ 1<br />Public Const scmcRemoveNumerics As Integer = 2 ^ 2<br />Public Const scmcRemoveSpaces As Integer = 2 ^ 3<br />Public Const scmcRemoveOthers As Integer = 2 ^ 4<br />Public Const scmcRemoveAll As Integer = 2 ^ 5 - 1<br />Public Const scmcKeepAlphas As Integer = scmcRemoveAll - scmcRemoveAlphas<br />Public Const scmcKeepLetters As Integer = scmcRemoveAll - scmcRemoveAlphas _<br /> - scmcRemoveSpaces<br />Public Const scmcKeepNumerics As Integer = scmcRemoveAll - scmcRemoveNumerics<br />Public Const scmcKeepOthers As Integer = scmcRemoveAll - scmcRemoveOthers<br />Public Const scmcKeepControl As Integer = scmcRemoveAll - scmcRemoveControl<br /><br />Public Function tcStripChars( _<br /> ByVal strInputText As String, _<br /> ByVal scmRemoveType As Integer) _<br /> As String<br /><br /> Dim scmCharMode As Integer<br />#End If<br /><br /> Dim intPos As Integer<br /> Dim strChar As String<br /><br /> ' Remove specified types of characters from input string<br /><br /> ' Developed by Warren Bain<br /> ' Copyright 2004, Thought Croft Pty Ltd<br /> ' All rights reserved.<br /><br /> ' In:<br /> ' strInputText:<br /> ' text to extract characters from<br /> ' scmRemoveType:<br /> ' type of removal (or retention) required<br /> ' can be combined to remove multiple types of chars<br /> ' Out:<br /> ' Return Value:<br /> ' text with all required chars removed<br /><br /><br /> ' Start with an empty output string<br /> tcStripChars = vbNullString<br /><br /> ' Determine for each character in the input string<br /> ' whether it should be retained or discarded based<br /> ' on bitwise comparison with scmRemoveType parameter<br /> For intPos = 1 To Len(strInputText)<br /> strChar = Mid$(strInputText, intPos, 1)<br /> Select Case Asc(strChar)<br /> Case 65 To 90, 97 To 122: scmCharMode = scmcRemoveAlphas<br /> Case 48 To 57: scmCharMode = scmcRemoveNumerics<br /> Case 32: scmCharMode = scmcRemoveSpaces<br /> Case 0 To 31: scmCharMode = scmcRemoveControl<br /> Case Else: scmCharMode = scmcRemoveOthers<br /> End Select<br /><br /> ' If the character's type bit is set in the remove type<br /> ' we will discard it - otherwise retain it<br /> If scmRemoveType And scmCharMode Then<br /> 'Ignore this one<br /> Else<br /> tcStripChars = tcStripChars & strChar<br /> End If<br /> Next intPos<br /> <br />End Function</FONT></CODE></PRE>Unknownnoreply@blogger.com4tag:blogger.com,1999:blog-19287583.post-15967263925695963222008-03-19T15:12:00.015+11:002010-03-12T07:06:07.800+11:00Automatic Email Account Assignment in Outlook<span style="font-weight: bold; color: rgb(255, 0, 0);">NOTE: THIS HAS BEEN UPDATED TO WORK WITH OUTLOOK 2007</span><br /><br />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).<br /><br />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).<br /><br />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.<br /><br />First download and install the excellent <a href="http://www.dimastr.com/redemption/home.htm">Redemption</a> 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.<br /><br />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.<br /><br />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.<br /><br />First, create a new Class module in your Outlook VBA project called clsNewMailHandler<br /><pre><code><span style="color:purple;"><br />Option Explicit<br /><br />Public WithEvents oApp As Outlook.Application<br />Const TC_BAINSWORLD_ACCOUNT = "bainsworld"<br /><br /><br />Private Sub Class_Terminate()<br /> Set oApp = Nothing<br />End Sub<br /><br /><br />Private Sub oApp_NewMailEx(ByVal EntryIDCollection As String)<br /><br />' This will be called whenever we receive new mail so<br />' process each item to determine if we should alter<br />' the account - do we need to worry about conflicts with Rules?<br /><br /> Dim astrEntryIDs() As String<br /> Dim objItem As Object<br /> Dim varEntryID As Variant<br /><br /> astrEntryIDs = Split(EntryIDCollection, ",")<br /> For Each varEntryID In astrEntryIDs<br /> Set objItem = oApp.Session.GetItemFromID(varEntryID)<br /> If objItem.Class = olMail Then<br /> ' Only call this for MailItems - can be ReadReceipts<br /> ' too which are class olReport<br /> Call SetEmailAccount(objItem)<br /> End If<br /> Next varEntryID<br /> Set objItem = Nothing<br />End Sub<br /><br /><br />Private Sub SetEmailAccount(ByRef oItem As MailItem)<br /><br />' This code will check if the item is of interest to<br />' us and if so will update the account property accordingly<br /><br />' Check if this was sent to a 'bainsworld' address<br /> If CheckMessageRecipient(oItem, TC_BAINSWORLD_ACCOUNT, False) Then<br /> ' Yes it was - change the account<br /> Call SetMessageAccount(oItem, TC_BAINSWORLD_ACCOUNT, True)<br /> End If<br />End Sub<br /><br /><br />Private Sub Class_Initialize()<br /> Set oApp = Application<br />End Sub<br /></span></code></pre><br />Next create a new standard Module called basMailRoutines and import this code:<br /><pre><code><span style="color:purple;"><br />Option Explicit<br /><br />Private Const PR_HEADERS = &H7D001E<br />Private Const PR_ACCOUNT = &H80F8001E<br /><br /><br />Public Function CheckMessageRecipient( _<br /> ByRef oItem As MailItem, _<br /> ByVal strMatch As String, _<br /> Optional ByVal blnExact As Boolean = False) As Boolean<br /><br />' Check if the supplied string matches the recipient<br />' of the email. We use the internet headers and check<br />' the first part of the string if we can. The match<br />' can be made exact or not<br /><br /> Const TC_HEADER_START As String = "Delivered-To:"<br /> Const TC_HEADER_END As String = "Received:"<br /><br /> Dim strHeader As String<br /> Dim intStart As Integer<br /> Dim intEnd As Integer<br /> Dim strRecipient As String<br /><br /> ' First get the header and see if it makes sense<br /> strHeader = GetInternetHeaders(oItem)<br /> intStart = InStr(1, strHeader, TC_HEADER_START, vbTextCompare)<br /> If intStart = 0 Then intStart = 1<br /> intEnd = InStr(intStart, strHeader, vbCrLf & TC_HEADER_END, vbTextCompare)<br /><br /> If intEnd = 0 Then<br /> ' The headers are unreliable so just check the whole string<br /> strRecipient = strHeader<br /> Else<br /> ' Found headers so grab the recipient data<br /> strRecipient = Trim$(Mid$(strHeader, intStart + Len(TC_HEADER_START), _<br /> intEnd - (intStart + Len(TC_HEADER_START))))<br /> End If<br /><br /> ' Now undertake the check<br /> If blnExact Then<br /> CheckMessageRecipient = (strRecipient = strMatch)<br /> Else<br /> CheckMessageRecipient = (InStr(1, strRecipient, strMatch, vbTextCompare) > 0)<br /> End If<br />End Function<br /><br /><br />Public Sub SetMessageAccount(ByRef oItem As MailItem, _<br /> ByVal strAccount As String, _<br /> Optional blnSave As Boolean = True)<br /><br /> Dim rMailItem As Redemption.RDOMail<br /> Dim rSession As Redemption.RDOSession<br /> Dim rAccount As Redemption.RDOAccount<br /> <br /> ' Use a RDO Session object to locate the account<br /> ' that we are interested in<br /><br /> Set rSession = New Redemption.RDOSession<br /> rSession.MAPIOBJECT = Application.Session.MAPIOBJECT<br /> Set rAccount = rSession.Accounts(strAccount)<br /> <br /> ' Now use the RDO Mail object to change the account<br /> ' to the one we require<br /><br /> Set rMailItem = rSession.GetMessageFromID(oItem.EntryID)<br /> rMailItem.Account = rAccount<br /> If blnSave Then<br /> ' They want us to force a save to the mail object<br /> rMailItem.Subject = rMailItem.Subject<br /> rMailItem.Save<br /> End If<br /> Set rMailItem = Nothing<br /> Set rAccount = Nothing<br /> Set rSession = Nothing<br />End Sub<br /><br /><br />Public Function GetInternetHeaders(ByRef oItem As MailItem) As String<br /><br /> Dim rUtils As Redemption.MAPIUtils<br /><br /> ' Return the internet header of a message<br /> Set rUtils = New Redemption.MAPIUtils<br /> GetInternetHeaders = rUtils.HrGetOneProp(oItem.MAPIOBJECT, PR_HEADERS)<br /> Set rUtils = Nothing<br />End Function<br /></span></code></pre><br />Finally, add the following code to the ThisOutlookSession object:<br /><pre><code><span style="color:purple;"><br />Dim MyNewMailHandler As clsNewMailHandler<br /><br /><br />Private Sub Application_Quit()<br /> Set MyNewMailHandler = Nothing<br />End Sub<br /><br /><br />Private Sub Application_Startup()<br /> Set MyNewMailHandler = New clsNewMailHandler<br />End Sub<br /></span></code></pre><br />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.Unknownnoreply@blogger.com17tag:blogger.com,1999:blog-19287583.post-39970933531781890382007-10-12T15:33:00.005+10:002008-04-03T11:03:51.140+11:00Generic function to copy Excel data between WorkbooksI needed way to ensure that some Excel workbooks that were being completed by customers and uploaded to a server for analysis and subsequent loading into a database, were not being tampered with. Certainly in Excel version up to and including 2003 it is not possible to prevent a determined user from "cracking" the Worksheet and Workbook protection passwords and hence to modifying any formulae in the Workbook.<br /><br />My solution was to create a new, clean copy of the workbook from a master template and to then copy the customer entered data from the submitted book to the new clean book. The following <span style="font-weight: bold;">CopyExcelData </span>sub does the bulk of the work - the comments explain what is going on.<br /><br />It does take some time to do this as it operates cell-by-cell (around 1 minute to copy 500 cells spread across 15 worksheets) but its not a bad trade-off to be safe in the knowledge that the final result is tamper-proof.<br /><br />As a side benefit, any corrections needed to the customer workbook after it has been issued can be made to the template version and files received after that point will be automatically "upgraded".<br /><pre><code><font color="purple"><br />Public Sub CopyExcelData( _<br /> ByRef wkbSource As Object, _<br /> ByRef wkbTarget As Object, _<br /> Optional ByVal blnCopyEmptyCells As Boolean = True)<br /><br /> '*** Change to remove control chars as it crashes Excel 97 ***'<br /><br /> ' Copy all data entry cells from one workbook<br /> ' to the other assuming that a data entry cell<br /> ' is:<br /> ' 1) On Visible sheets only<br /> ' 2) In the UsedRange of cells<br /> ' 3) If Sheet is Protected then Unlocked Cells<br /> ' 4) If Sheet is UnProtected then Non-formula cells<br /> '<br /> ' Since the target is expected to be the 'good' copy,<br /> ' that is the one we use to test the above conditions<br /> ' and we then extract the corresponding data from the<br /> ' source cell and place it in the target cell<br /><br /> ' Note: late binding has been used to limit any issues<br /> ' related to different versions of Excel, parameters<br /> ' are actually:<br /> ' ByRef wkbSource As Excel.Workbook<br /> ' ByRef wkbTarget As Excel.Workbook<br /><br /><br /> Dim appExcel As Object 'Excel.Application<br /> Dim blnProtectTarget As Boolean<br /> Dim rngAllTarget As Object 'Excel.Range<br /> Dim rngCellSource As Object 'Excel.Range<br /> Dim rngCellTarget As Object 'Excel.Range<br /> Dim wksSource As Object 'Excel.Worksheet<br /> Dim wksTarget As Object 'Excel.Worksheet<br /> Dim xlCalcMode As Variant<br /><br /><br /> ' Before we start, ensure calculation mode is manual<br /> Set appExcel = wkbSource.Application<br /> xlCalcMode = appExcel.Calculation<br /> appExcel.Calculation = xlCalculationManual<br /><br /> For Each wksTarget In wkbTarget.Worksheets<br /> If wksTarget.Visible = xlSheetVisible Then<br /> ' We only want data on sheets the user can see<br /> ' so we ignore any that are Hidden or VeryHidden<br /> Set rngAllTarget = wksTarget.UsedRange<br /> If Not rngAllTarget Is Nothing Then<br /> ' We have some non-empty cells on this sheet<br /> Set wksSource = wkbSource.Worksheets(wksTarget.Name)<br /> blnProtectTarget = wksTarget.ProtectContents<br /> For Each rngCellTarget In rngAllTarget.Cells<br /> ' Stepping through each cell in the range...<br /> With rngCellTarget<br /> If (blnProtectTarget And Not .Locked) Or _<br /> (Not blnProtectTarget And Not .HasFormula) Then<br /> ' This is a cell that can be completed in<br /> ' the original target sheet so examine further<br /> If .Address = .MergeArea(1, 1).Address Then<br /> ' This is the main cell for a merged set of cells<br /> ' or not merged at all so we are interested...<br /> Set rngCellSource = wksSource.Range(.Address)<br /> If Not IsError(rngCellSource.Value2) Then<br /> ' Only copy valid cell entries<br /> If rngCellSource.HasFormula And _<br /> Not (rngCellSource.FormulaHidden Or .FormulaHidden) Then<br /> ' They are using a formula and we can access the formula<br /> ' in both source and target so transfer it (can't access this<br /> ' property if FormulaHidden is TRUE for either)<br /> .Formula = rngCellSource.Formula<br /> ElseIf Len(rngCellSource.Value2) > 0 Or blnCopyEmptyCells Then<br /> ' Not a formula so just get the value using Value2<br /> ' to avoid problems introduced by incorrect date formats<br /> ' NOTE: remove control characters to avoid Excel 97 crash<br /> .Value2 = tcStripChars(rngCellSource.Value2, scmcRemoveControl)<br /> End If<br /> End If<br /> End If<br /> End If<br /> End With<br /> Next rngCellTarget<br /> End If<br /> End If<br /> Next wksTarget<br /><br /> ' Return calculation mode to whatever it was before<br /> appExcel.Calculation = xlCalcMode<br /><br /> Set rngCellTarget = Nothing<br /> Set rngCellSource = Nothing<br /> Set wksSource = Nothing<br /> Set wksTarget = Nothing<br /> Set appExcel = Nothing<br />End Sub<br /><br /><br />Public Function GetNamedRangeValue(ByRef nm As Object) As Variant<br /><br /> ' To get the value held by a range name. This<br /> ' function handles Named constants and formulae<br /> ' which can't be evaluated by the object itself<br /><br /> ' Note: to avoid problems with different Excel<br /> ' versions, we use late binding of the range<br /> ' and the input parameter:<br /> ' ByRef nm As Excel.Name<br /> ' Dim rng As Excel.Range<br /><br /><br /> Dim rng As Object ' Excel.Range<br /><br /> With nm<br /> ' Check to see if this is a named constant or formula<br /> ' in which case it won't have a range object<br /> On Error Resume Next<br /> Set rng = .RefersToRange<br /> On Error GoTo 0<br /> If rng Is Nothing Then<br /> ' This a named constant or named formula<br /> ' so we need to use Excel to evaluate<br /> On Error Resume Next<br /> GetNamedRangeValue = .Application.ExecuteExcel4Macro(Mid(.RefersToR1C1, 2))<br /> On Error GoTo 0<br /> Else<br /> ' This is a cell so we can recover the value<br /> ' using the RefersToRange value2 which allows<br /> ' us better control over formatting glitches<br /> GetNamedRangeValue = .RefersToRange.Value2<br /> End If<br /> End With<br /> Set rng = Nothing<br />End Function<br /></font></code></pre>Unknownnoreply@blogger.com4tag:blogger.com,1999:blog-19287583.post-47738147981426810012007-03-01T16:54:00.003+11:002008-04-03T11:01:24.171+11:00How to tell if an Access Report was PrintedI needed to be able to determine if an Access Report had been actually sent to the printer (as opposed to just previewed on screen) so that I could update a log recording the fact. This is useful for tracking whether or not a letter has been sent to a customer without requiring the user to click on a separate "log" button.<br /><br />After some research on the 'net I discovered that a lot of the published solutions only half-solved the problem. Microsoft themselves got it completely wrong in <a href="http://support.microsoft.com/kb/q154894/">this knowledgebase article</a>!<br /><br />The trick is understanding the different events that are fired when an Access report is opened. Supposing the ReportHeader section is visible, its Print event will be fired when the report is generated in Preview mode and again every time the report is sent to the printer. To guard against the situation where the report is sent direct to the printer without first being opened in preview, we also need to look at the Activate event which will be fired when the report is opened in preview mode. Because the Activate event also fires whenever we switch back the preview from another window, we also need to track the Deactivate event to know that we have switched away from the preview.<br /><br />And so that I don't have to add code to every report that I want to track for all these events, I will define a class that sinks the events in the report's open events as follows:<br /><pre><code><font color="purple"><br />ReportPrintStatus class definition<br /><br /> ' Use the hidden object type for a section so we can sink the events<br /> ' (thanks to Stephen Lebans for this tip - see www.lebans.com)<br /><br />Private WithEvents mrpt As Access.Report<br />Private WithEvents msecReportHeader As Access.[_SectionInReport]<br />Private mintCounter As Integer<br /><br />'--------------------------------<br />' Public Properties and Methods<br />'--------------------------------<br /><br />Public Property Set Report(rpt As Access.Report)<br /> ' Sink the event handling for this report<br /> Const strEventKey As String = "[Event Procedure]"<br /> Set mrpt = rpt<br /> With mrpt<br /> ' If we don't populate these properties, the events will<br /> ' never fire in the report and we will be sunk!<br /> .OnActivate = strEventKey<br /> .OnClose = strEventKey<br /> .OnDeactivate = strEventKey<br /> ' Note, we assume this section exists - if not, it won't work<br /> Set msecReportHeader = .Section(acHeader)<br /> msecReportHeader.OnPrint = strEventKey<br /> End With<br />End Property<br /><br />Public Property Get Printed() As Boolean<br /> ' Did they print this report?<br /> Printed = (mintCounter >= 1)<br />End Property<br /><br />Public Sub Term()<br /> ' If we don't destroy these objects here, we risk an Access GPF!<br /> On Error Resume Next<br /> Set msecReportHeader = Nothing<br /> Set mrpt = Nothing<br />End Sub<br /><br />'--------------------------------<br />' Event Procedures<br />'--------------------------------<br /><br />Private Sub mrpt_Activate()<br /> ' This occurs if we open the report in print preview and also when<br /> ' we switch back to the previewed report in which case incremented<br /> ' by deactivate event<br /> mintCounter = mintCounter - 1<br />End Sub<br /><br />Private Sub mrpt_Close()<br /> ' This occurs when the report closes so ensure we destroy objects<br /> ' to prevent an Access GPF<br /> Me.Term<br />End Sub<br /><br />Private Sub mrpt_Deactivate()<br /> ' Called when we close report from preview or if we switch out of<br /> ' preview mode to another window in which case decremented by<br /> ' associated activate event<br /> mintCounter = mintCounter + 1<br />End Sub<br /><br />Private Sub msecReportHeader_Print(Cancel As Integer, PrintCount As Integer)<br /> ' Increment our counter occurs once for every time we print and also<br /> ' the first time we open in preview mode<br /> mintCounter = mintCounter + 1<br />End Sub<br /></font></code></pre><br />Now it becomes a simple matter to have a report work out if it was printed or just previewed by inserting the following lines in the report's code module. Note that this was in Access 97 - in later versions I could raise a ReportPrinted event.<br /><pre><code><font color="purple"><br />Private rps As ReportPrintStatus<br /><br />Private Sub Report_Close()<br /> If rps.Printed Then<br /> ' Do something<br /> End If<br />End Sub<br /><br />Private Sub Report_Open(Cancel As Integer)<br /> ' Sink the reports events so we can determine if it was printed or not<br /> Set rps = New ReportPrintStatus<br /> Set rps.Report = Me<br />End Sub<br /></font></code></pre>Unknownnoreply@blogger.com2tag:blogger.com,1999:blog-19287583.post-1153443804085505022006-07-21T10:15:00.003+10:002008-04-03T10:57:02.071+11:00Error Referring To Excel Sheets Collection by Sheet NameI've just had a frustrating couple of hours dealing with what appears to be a bug in the Excel Sheets collection when accessed from an Access VBA module. The application is an Access 2000 database reading data from an Excel workbook. The method employed is to loop through the table definition and retrieve the value of any Named Ranges from the work book which match the name of each field in the table. This works fine.<br /><br />But a new version of the workbook was issued to users with some of the named range definitions missing. So to compensate for this, I added a correction table to the database with three text fields - FieldName, Sheet (e.g. "xyz") and Cell (e.g. "A5"). When the load routine fails to find the required field in the workbook, the following code segment was intended to retrieve the value from the workbook:<br /><pre><code><font color="purple">varData = wb.Sheets(rst!Sheet).Range(rst!Cell).Value</font></code></pre><br />This failed with "Run-time error '13': Type mismatch". Subsequent testing in the immediate window showed the culprit to be accessing the Sheets collection with <strong>wb.Sheets(18).Name</strong> returning "xyz" but <strong>wb.Sheets("xyz").Name</strong> failing with Error 13.<br /><br />I don't get this error from VBA running in the Excel client, only when Excel is an automation client and the code is running within the Access client. It also applies to the Worksheets collection as well (as you would expect).<br /><br />The workaround was to change the correction table to be two fields - FieldName & RefersTo (which is Sheet and Cell combined e.g. "xyz!A5") and to use the following which works without any problems:<br /><pre><code><font color="purple">varData = appExcel.Range(rst!RefersTo).Value</font></code></pre>Unknownnoreply@blogger.com0tag:blogger.com,1999:blog-19287583.post-1133306907744268262005-11-30T10:28:00.003+11:002008-04-03T11:00:45.239+11:00CAGRMicrosoft Excel comes with a lot of inbuilt functions that can be used in cell formulae and there are also a number of add-ins that provide specialised sets of functions to support statistical, numerical and financial analysis e.g. The Analysis ToolPak.<br /><br />As an amateur investor, I am often interested in the Compound Annual Growth Rate (CAGR) calculation for comparing the smoothed rate of return of different investments. Surprisingly enough, Excel doesn't have this in its kitbag, so I wrote my own. Below is my version of a user-defined function (UDF) that can be used in Excel (or any other VBA friendly product).<br /><pre><code><font color="purple"><br />Public Function CAGR( _<br /> ByVal StartValue As Double, _<br /> ByVal EndValue As Double, _<br /> ByVal StartDate As Date, _<br /> ByVal EndDate As Date) _<br /> As Double<br /><br /> ' Compute Compound Annual Growth Rate according to formula<br /> ' CAGR = (FV / PV ) ^ 1/n - 1 where n is number of years<br /> ' Developed by Warren Bain of Thought Croft Pty Ltd<br /><br /> CAGR = (EndValue / StartValue) _<br /> ^ (1 / ((EndDate - StartDate) / 365.25)) - 1<br />End Function<br /></font></code></pre>Unknownnoreply@blogger.com0tag:blogger.com,1999:blog-19287583.post-1132894569313200582005-11-25T15:34:00.003+11:002008-04-03T11:00:06.726+11:00SetTextEditModeI like to use the Locked and Enabled properties of text-based controls - combo boxes, check boxes, list boxes and text boxes - to control whether they can be changed or entered. But for the life of me, I can never remember which combination of true and false values gives me the look I am after. For example, Enabled=Yes and Locked=Yes means the text field can be entered but can't be changed. Change this to Enabled=No and Locked=Yes and you won't be able to enter or edit the field. Make it Enabled=Yes, Locked=No and you can enter and edit and so on.<br /><br />To make it easier on myself, I wrote this function to do the remembering for me. As you can see, a lot of the work is done by the enumerated constants definition - that's why I like to use them apart from the fact that the VBA compiler (or whatever) also reminds me what values I can use when I am coding. I also like to use these constants as bitwise comparison flags by making them different powers of 2 - easier to look at the example than try and explain! The net effect is that some sensible constant design simplifies coding to two statements rather than a string of nested IFs.<br /><pre><code><font color="purple"><br />Public Enum TextEditMode<br /> temcInvalid = 0<br /> temcLockedTrue = 2 ^ 1<br /> temcLockedFalse = 2 ^ 2<br /> temcEnabledTrue = 2 ^ 3<br /> temcEnabledFalse = 2 ^ 4<br /> temcEnterWithEdit = temcLockedFalse + temcEnabledTrue<br /> temcEnterNoEdit = temcLockedTrue + temcEnabledTrue<br /> temcNoEnterNormal = temcLockedTrue + temcEnabledFalse<br /> temcNoEnterDimmed = temcLockedFalse + temcEnabledFalse<br />End Enum<br /><br />Public Function SetTextEditMode( _<br /> ByRef ctl As Control, _<br /> Optional ByVal temMode As TextEditMode) As TextEditMode<br /><br /> ' Set or return the value of Enabled and Locked properties<br /> ' in a text based control to manage how it looks as follows:<br /> ' Enabled? Locked? Result?<br /> ' Yes Yes Can enter, can't edit, normal<br /> ' Yes No Can enter, can edit, normal<br /> ' No Yes Can't enter, can't edit, normal<br /> ' No No Can't enter, can't edit, dimmed<br /> ' If no mode requested then returns the current settings<br /><br /> ' Developed by Warren Bain on 21/10/2005<br /> ' Copyright (c) Thought Croft Pty Ltd<br /> ' All rights reserved.<br /><br /> ' Check we can do this for this type of control<br /> Select Case ctl.ControlType<br /> Case acComboBox, acCheckBox, acListBox, acTextBox<br /> If IsMissing(temMode) Then<br /> ' Let them know what is set<br /> SetTextEditMode = IIf(ctl.Enabled, temcEnabledTrue, temcEnabledFalse) + _<br /> IIf(ctl.Locked, temcLockedTrue, temcLockedFalse)<br /> Else<br /> ' Set the controls parameters<br /> ctl.Enabled = temMode And temcEnabledTrue<br /> ctl.Locked = temMode And temcLockedTrue<br /> SetTextEditMode = temMode<br /> End If<br /> Case Else<br /> SetTextEditMode = temcInvalid<br /> End Select<br />End Function</font></code></pre>Unknownnoreply@blogger.com0tag:blogger.com,1999:blog-19287583.post-1132881386170779302005-11-25T12:06:00.002+11:002008-04-03T10:59:16.988+11:00GetSubFormControlNameI'm currently developing a Microsoft Access based system and found myself continually needing to work out how to access a property of the control that contains a subform from code running in the subform (for example to get at the Tag property).<br /><br />This function will do that by walking the controls collection of the subform's parent form looking for any subforms and then compares the hWnd (basically Windows internal "handle" for that window) of that control with the hWnd of our subform.<br /><br />Once found, we construct the name of the control using the appropriate name format. If we want to use the name in code then the short format is fine but if it is to be used in a query then we need the long version which may necessitate walking up the hierarchy if in fact the parent form is itself a subform (forms can be nested to three levels). This is achieved by calling the function recursively on the parent.<br /><pre><code><font color="purple"><br />Public Enum ControlNameFormat<br /> cnfcShortPropertyName<br /> cnfcLongHierarchicalName<br />End Enum<br /><br />Public Function GetSubFormControlName( _<br /> ByRef frm As Form, _<br /> Optional ByVal NameFormat As ControlNameFormat = _<br /> cnfcShortPropertyName) As String<br /><br />' Tells a subform the name of the control that<br />' it has been opened in on the main form. Used<br />' to modify the base subform's source or to<br />' retrieve special values from its Tag property.<br />' The NameFormat tells us whether to just provide<br />' the ctl.Name property or the fully qualified<br />' form controls collection item name.<br /><br />' Example:<br />' Form "MainForm" holding "1stSubForm" in control "fsub1"<br />' holding "2ndSubForm" in control "fsub2"...<br />' GSFCN(1stSubForm,Long) = "[Forms]![MainForm]![fsub1]"<br />' GSFCN(2ndSubForm,Long) = "[Forms]![MainForm]![fsub1].Form![fsub2]"<br />' GSFCN(2ndSubForm,Short) = "fsub2"<br /><br />' Developed by Warren Bain on 26/09/2005<br />' Copyright (c) Thought Croft Pty Ltd.<br /><br /> Dim ctl As Control<br /> Dim strResult As String<br /><br /> On Error Resume Next<br /><br /> ' Loop through all controls on the parent and test for the<br /> ' handle of the window of the subsidiary form. If it<br /> ' matches ours, then we have found the control it opened in<br /> If Not IsSubForm(frm) Then<br /> ' We are at the top of the tree, so return name<br /> If NameFormat = cnfcShortPropertyName Then<br /> strResult = frm.Name<br /> ElseIf NameFormat = cnfcLongHierarchicalName Then<br /> strResult = "[Forms]![" & frm.Name & "]"<br /> End If<br /> Else<br /> For Each ctl In frm.Parent.Controls<br /> If ctl.ControlType = acSubform Then<br /> If ctl.Form.hWnd = frm.hWnd Then<br /> ' Found the right one<br /> If NameFormat = cnfcShortPropertyName Then<br /> ' Just return the name of the control<br /> strResult = ctl.Name<br /> ElseIf NameFormat = cnfcLongHierarchicalName Then<br /> ' Add parent plus fully qualified control<br /> strResult = GetSubFormControlName(frm.Parent, NameFormat) & ".Form![" & ctl.Name & "]"<br /> End If<br /> Exit For<br /> End If<br /> End If<br /> Next ctl<br /> End If<br /> GetSubFormControlName = strResult<br />End Function<br /><br />Private Function IsSubForm(frm As Form) As Boolean<br /> ' Is the form currently loaded as a subform?<br /> Dim strFormName As String<br /> On Error Resume Next<br /> strFormName = frm.Parent.Name<br /> IsSubForm = (Err.Number = 0)<br /> Err.Clear<br />End Function</font></code></pre>Unknownnoreply@blogger.com0