I recently came across a animated chart workbook that I created back in the summer of ’08 that tracked the Market Price and Moody’s Rating of corporate bonds in a SIV. I was tasked with creating an Excel-based rating agency compliance application, so I had all the daily price and ratings data for the bonds. The animated chart tracks a subset of the total data, from May 2007 to May 2008.

Each token in the chart represents a single asset. The shape and color identify the industry of the asset. See the Legend Key at the bottom of the chart.

I thought that anyone who was in the structured finance business during that period would appreciate the optics on this (while re-living that sinking feeling…)

Notice the following:

* The portfolio starts off with all assets clustered right around par (100), and rated in the Baa3 to B2 range (with a liberal sprinkling of Ba’s and Caa’s).

* In June ’07 we see a very slight downward drift in Moody’s ratings.

* In July ’07 the first price shock is seen, as clusters of assets drift down into the mid-to-high 90’s.

* Jan-Feb ’08 – The next major price shock. This was the first “big one”.

* Also notice that the ratings remained relatively unchanged, give or take a few outliers. This chart only displays prices down to 70, but there were quite a few assets that were priced well below that. And yet they retained their ratings. Interesting.

Click here for an AVI clip of the animated workbook, located on my Skydrive
(In order to keep the file size as small as possible, the clarity of the video clip suffers a bit, but hopefully you can still get the gist of what transpired)

Price & Moody's Rating - May 2007

Price & Moody's Rating - May 2007 (snapshot)

Price & Moody's Rating - May 2008

Price & Moody's Rating - May 2008 (snapshot)


Custom Data Access Class

Build a custom data access class that you can plug into any Excel application that requires Microsoft SQL Server or Microsoft Access connectivity. This will require two code modules: a class module and a standard module. The standard module is used simply to house the global database class instance, and to create/destroy it when the application workbook opens/closes.

Let’s get right into the code. First create a new workbook and switch to the VBA Editor. Add a reference to “Microsoft ActiveX Data Objects 2.8 Library”. Create a new Class module and name it “clsSQLConnection”. Add the following code to this class module.

clsSQLConnection Code

Option Explicit

'Module-level objects
Private mobjConn As ADODB.Connection
'Module-level variables
Private mblnIntegratedSecurity As Boolean
Private mstrModuleName As String
Private mstrConnectionString As String
Private mstrCurrentServer As String
Private mstrCurrentDatabase As String
Private mstrDatabaseType As String

Private Sub Class_Initialize()
mstrModuleName = "clsSQLConnection"
Set mobjConn = New ADODB.Connection
End Sub

Private Sub Class_Terminate()
On Error Resume Next
Set mobjConn = Nothing
On Error Goto 0
End Sub

Public Property Get ConnectionString() As String
ConnectionString = mstrConnectionString
End Property

Public Property Let ConnectionString(ByVal NewValue As String)
mstrConnectionString = NewValue
End Property

Public Property Get CommandTimeOut() As Integer
    CommandTimeOut = mobjConn.CommandTimeOut
End Property

Public Property Let CommandTimeOut(ByVal NewTimeOut As Integer)
mobjConn.CommandTimeOut = NewTimeOut
End Property

Public Property Get CurrentDatabase() As Integer
'Read-only property
CurrentDatabase = mstrCurrentDatabase
End Property

Public Property Get CurrentServer() As String
'Read-only property
CurrentServer = mstrCurrentServer
End Property

Public Property Get DatabaseType() As String
DatabaseType = mstrDatabaseType
End Property

Public Property Let DatabaseType(ByVal NewValue As String)
mstrDatabaseType = NewValue
End Property

Public Property Get IntegratedSecurity() As Boolean
IntegratedSecurity = mblnIntegratedSecurity
End Property

Public Property Let IntegratedSecurity(ByVal NewValue As Boolean)
mblnIntegratedSecurity = NewValue
End Property

Public Sub CloseDB()
'Close connection to database.

On Error Resume Next
If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is defined and still open; close it.
End If
End If
On Error GoTo 0

End Sub

Public Sub ShowErrorMessages(ByVal StandardErrorObject As VBA.ErrObject, _
ByVal SourceModule As String, ByVal SourceMethod As String)
'Construct a comprehensive error message based on the passed objects.
Dim strMsg As String

'Handle the standard error, if any.
If StandardErrorObject.Number < > 0 Then
strMsg = "Error: " & CStr(Err.Number) & vbCrLf & vbCrlf & "Description: " & _
Err.Description & vbCrLf & vbCrLf
End If

'Include the database-related errors, if any.
If Not (gobjDB Is Nothing) Then
strMsg = strMsg & gobjDB.ADOErrors()
End If

'Finally, tack on the module/method names.
strMsg = strMsg & SourceModule & "::" & SourceMethod & vbCrLf


MsgBox strMsg, vbCritical, "Contact Technical Support For Assistance"

End Sub

Public Function ADOErrors() As String
'Return a fully formatted string containing any current ADO errors in the collection.
Dim lngCount As Long
Dim objErr as ADODB.Error
Dim strReturn As String

strReturn = vbNullString

For Each objErr in mobjConn.Errors
strReturn = strReturn & CStr(objErr.Number) _
& vbCrLf & objErr.Description & vbCrLf & vbCrLf
Next objErr

ADOErrors = strReturn

End Function

Public Function OpenDB(Optional ByVal DatabaseType As String, _
Optional ByVal TargetServer As String = "", _
Optional ByVal TargetDatabase As String = "", _
Optional ByVal IntegratedSecurity As Boolean = False) As Boolean
'Open a connection to the specified server and database, if not already open.
'If the parameters are not specified, then just re-use the last connection
' string that was created.

Dim blnNewConnect As Boolean, blnReturn As Boolean
Dim strDataSource As String
Dim strDB As String
Dim strConn As String

blnReturn = True
blnNewConnect = True

On Error GoTo ODError

If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is alread defined and opened.
blnNewConnect = False
End If
End If

If blnNewConnect Then
'Must create a new connection
If TargetServer = "" Or TargetDatabase = "" Then
'Calling routine has not specified Server or Database values;
' default to last used.

If Len(mstrConnectionString) > 0 Then
strConn = mstrConnectionString
'If full connection string is blank, use the individual Server/Environment and
' Database variables to determine connection.

strConn = BuildConnectionString(mstrDatabaseType, mstrCurrentServer, _
mstrCurrentDatabase, mblnIntegratedSecurity)
End If
'Build connection string, based on passed arguments
strConn = BuildConnectionString(DatabaseType, TargetServer, TargetDatabase, _
End If
mobjConn.ConnectionString = strConn
End If

OpenDB = blnReturn
Exit Function

blnReturn = False
ShowErrorMessages Err, mstrModuleName, "OpenDB"
Resume ODResume

End Function

Public Function BuildConnectionString(ByVal DatabaseType As String, _
ByVal TargetServer As String, _
ByVal TargetDatabase As String, _
ByVal IntegratedSecurity As Boolean, _
Optional ByVal UserID As String, _
Optional ByVal Password As String) As String
'Construct a full connection string, set local properties, and
' return string to calling routine.

'Build connection string
Select Case DatabaseType
Case "SQLServer"
'Microsoft SQL Server; use proper network library.
mstrConnectionString = "Network Library=DBMSSOCN;" & _
";INITIAL CATALOG=" & TargetDatabase & _
If IntegratedSecurity Then
mstrConnectionString = "Provider=SQLNCLI10;" & _
"Server=" & TargetServer & ";" & _
"Database=" & TargetDatabase & ";" & _
End If
Case "Access2003"
'Access 2003 and prior
mstrConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & _
TargetDatabase & ".mdb;"
Case "Access2007"
'Access 2007 or 2010
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & _
TargetDatabase & ".accdb;Persist Security Info=Flase;"
Case Else
'Some other server; modify to accommodate.
mstrConnectionString = "Provider=SQLNCLI10;Server=" & TargetServer & _
";Database=" & TargetDatabase & ";Trusted_Connection=yes;"
End Select

'Update the module variables
mstrCurrentServer = TargetServer
mstrCurrentDatabase = TargetDatabase
mblnIntegratedSecurity = IntegratedSecurity

BuildConnectionString = mstrConnectionString

End Function

Public Function ExecuteSPWithADOCommand(StoredProcName As String, _
OutputParameter As String, OutputValue As Variant, _
ParamArray InputParameters() As Variant) As Boolean
'Execute a stored procedure, using an ADO command object. The InputParameters
' paramarray must contain pairs of data (i.e. element 0 should be Parameter name,
' with leading '@', and element 1 should be the associated parameter value; then
' element 2 is the next parameter name, element 3 is the next parameter value, etc.).
' Also allows for a single Output parameter and associated return value
' (OutputParmeter and OutputValue ByRef parameters). Remember
' to prefix the OutputParmeter name with '@', same as the input parameters.

Dim objCmd As ADODB.Command
Dim blnReturn As Boolean
Dim intParam As Integer
Dim strParamName As String
Dim vntParamValue As Variant

blnReturn = True

On Error GoTo ESPError

If OpenDB() Then
Set objCmd = New ADODB.Command
With objCmd
.ActiveConnection = mobjConn
.CommandText = StoredProcName
.CommandType = adCmdStoredProc
'Define the Input Parameters
For intParam = 0 To UBound(InputParameters) Step 2
.Parameters(InputParameters(intParam)).Value = _
InputParameters(intParam + 1)
Next intParam
'Define the single allowed output parameter, if any
If Len(Trim(OutputParameter)) > 0 Then
.Parameters(OutputParameter).Direction = adParamOutput
End If
'Execute the stored procedure
End With

'Retrieve the value of the output parameter (if any)
If Len(Trim(OutputParameter)) > 0 Then
OutputValue = objCmd.Parameters(OutputParameter).Value
OutputValue = vbNullString
End If
'No database connection could be established, but no error
' was raised (should never happen).

OutputValue = vbNullString
blnReturn = False
End If

ExecuteSPWithADOCommand = blnReturn
Set objCmd = Nothing
Exit Function

blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteSPWithADOCommand"
Resume ESPResume

End Function

Function GetRecordset(strSQL As String) As ADODB.Recordset
'Return a disconnected recordset from the database.
Dim rst As ADODB.Recordset

On Error GoTo GRError

If OpenDB() Then
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open strSQL, mobjConn, adOpenDynamic

Set GetRecordset = rst
rst.ActiveConnection = Nothing
End If

Exit Function

ShowErrorMessages Err, mstrModuleName, "GetRecordset"
Resume GRResume

End Function

Public Function GetRecordsetToArray(strSQL As String) As Variant
'Return recordset data into an array. If, for any reason, the recordset
' does not return any data, this function simply creates a single element
' array and populates it with "No matching records...".

Dim rst As ADODB.Recordset
Dim arrData As Variant
Dim lngX As Long

On Error GoTo GRAError

If OpenDB() Then
Set rst = New ADODB.Recordset
With rst
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.Open strSQL, mobjConn, adOpenStatic

If Not (rst.EOF) Then
'Disconnect the recordset
.ActiveConnection = Nothing
'Get the field count
lngX = .Fields.Count
arrData = .GetRows()
'Recordset is empty; create dummy array record
ReDim arrData(0, 0)
arrData(0, 0) = "No matching records found in the database"
End If
End With
'Connection failed for some reason; in order not to crash the
' calling routine, create dummy array record.

ReDim arrData(0, 0)
arrData(0, 0) = "Could not open database connection"
End If

GetRecordsetToArray = arrData
Exit Function

ShowErrorMessages Err, mstrModuleName, "GetRecordsetToArray"
Resume GRAResume

End Function

Public Function GetMultipleRecordsets(strSQL As String) As ADODB.Recordset
'Allows for multiple recordsets to be returned to the calling routine.
'IMPORTANT - Although this method is similar to the GetRecordSet function,
' there are significant differences.
' 1. Do not disconnect the Recordset (i.e. don't set ActiveConnection to Nothing).
' 2. You must not close the database connection! It must remain open so that
' the calling routine can retrieve all of the resultsets in the returned Recordset.

Dim rst As ADODB.Recordset

On Error GoTo GMRError

If OpenDB() Then
Set rst = New ADODB.Recordset
rst.Open strSQL, mobjConn

Set GetMultipleRecordsets = rst
End If

'REMEMBER! Do NOT close the connection here. Calling routine must close it.
Exit Function

ShowErrorMessages Err, mstrModuleName, "GetMultipleRecordsets"
Resume GMRResume

End Function

Public Function ExecuteActionQuery(SQLToExecute As String) As Boolean
'Execute an action query, or stored procedure, which is not expected
' to return a resultset.

Dim blnReturn As Boolean

blnReturn = True

On Error GoTo EAQError

If OpenDB() Then
mobjConn.Execute SQLToExecute
End If

ExecuteActionQuery = blnReturn
Exit Function

blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteActionQuery"
Resume EAQResume

End Function

Public Property Get SQLConnection() As ADODB.Connection
'Return the actual connection object, if requested by
' calling routine.

If Not mobjConn Is Nothing Then
On Error Resume Next
Set SQLConnection = mobjConn
On Error GoTo 0
End If

End Property

modGlobal Code

Next, insert a new standard module, name it modGlobal and copy the following code:

Option Explicit

'Global data access class object
Public gobjDB As clsSQLConnection

Public Sub InitializeDatabase()
Dim strDatabaseType As String
Dim strServerName As String
Dim strDatabaseName As String
Dim blnIntegratedSecurity As Boolean
Dim strUserID As String
Dim strPassword As String

'*** NOTE: The database properties and user ID, etc. can be read from an
' INI file or some other source. For this example, just hard-code
' the server and database values and assume that Windows integrated
' security is being used (so no UID or Pwd are required).
' This procedure assumes that you have a local SQL Server
' installation, with a database named "MyDatabase".
' Modify this as necessary to conform to your test environment.

strDatabaseType = "SQLServer"
strServerName = "(local)"
strDatabaseName = "MyDatabase"
blnIntegratedSecurity = True

Set gobjDB = New clsSQLConnection
gobjDB.BuildConnectionString strDatabaseType, strServerName, _
strDatabaseName, blnIntegratedSecurity

End Sub

Public Sub DestroyDatabase()

If Not (gobjDB Is Nothing) Then
On Error Resume Next
Set gobjDB = Nothing
End If

End Sub

Public Sub TestDataAccess()
'Test everything to make sure it works.
'NOTE: This procedure assumes there is a database
' table named "MyTestTable" that has at least two
' fields: "Field1" and "Field2". Modify to match
' your specifics.

Dim rsTest As ADODB.RecordSet
Dim lngRow As Long

Set rsTest = gobjDB.GetRecordSet("SELECT * FROM MyTestTable")
If Not (rsTest Is Nothing) Then
If Not rsTest.EOF Then
lngRow = 1
Do While Not rsTest.EOF
ActiveSheet.Range("A" & lngRow).Value = rsTest("Field1").Value
ActiveSheet.Range("B" & lngRow).Value = rsTest("Field2").Value
lngRow = lngRow + 1
End If
End If

End Sub

Workbook Code

Finally, in order to have the database connection initialized when the workbook opens, and destroyed when the workbook closes, add the following code to the “ThisWorkbook” object:

Option Explicit

Private Sub Workbook_Open()
InitializeDatabase 'Make call to global subroutine.
End Sub

Private Sub Workbook_BeforeClose()
End Sub

IMPORTANT: Remember that you must change the property values in the InitializeDatabase function to match your SQL Server values, and you must modify the table and field names for your test query in the TestDataAccess subroutine

That’s all you need to have a fully functional set of database access routines that can be plugged into any Excel workbook. Of course, there’s more functionality that can be added to the clsSQLConnection class module, such as application-specific stored procedure calls, database transaction management, etc. Use this as a starting point for your work, and modify as needed.


Although Excel UserForms do not inherently support minimize/maximize functionality, I got a request stating that the application users needed to be able to open multiple Userforms simultaneously, minimizing, maximizing and switching between. Or the world will end. Make it happen.

No need to sweat if you get marching orders like this. Armed with the information in this post you’ll have ’em minimizing and maximizing to their heart’s content.

As always, let’s start from the beginning:

* Create a new macro-enabled Excel workbook.

* Switch to the VBA editor and add a new code module. Name it modAPI. Enter the following code in the Declarations area. These are all the required Windows API function declarations and constants that will be required to allow standard window minimize/maximize behavior in our UserForms:

Public Const WS_MINIMIZEBOX = &H10000
Public Const WS_MAXIMIZEBOX = &H20000
Public Const GWL_STYLE = (-16)
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

* Next, add the following function to the modAPI module:

Public Sub AddMinMaxButtons(ByVal FormCaption As String, ByVal MinButton As Boolean, ByVal MaxButton As Boolean)
'Add either minimize button, maximize button, or both buttons to the UserForm with the specified caption.
'IMPORTANT: If a UserForm's caption is changed dynamically in your program, this subroutine must be run again (with the new Caption) or the min/max buttons will disappear.
Dim hWnd As Long
Dim lngStyle As Long
hWnd = FindWindow(vbNullString, FormCaption)
lngStyle = GetWindowLong(hWnd, GWL_STYLE)
If MaxButton Then
    lngStyle = lngStyle Or WS_MAXIMIZEBOX
End If
If MinButton Then
    lngStyle = lngStyle Or WS_MINIMIZEBOX
End If
SetWindowLong hWnd, GWL_STYLE, lngStyle
DrawMenuBar hWnd
End Sub

* Create a new UserForm. Change the Caption property to “My Test Form”

* In the UserForm_Activate event of the new form, enter the following code:

Private Sub UserForm_Activate()
'Set the min/max button setting for the form.
 AddMinMaxButtons Me.Caption, MinButton:=True, MaxButton:=True
End Sub

* Next, add the following code to the Workbook_Open() event of the ThisWorkbook module:

Private Sub Workbook_Open()
    UserForm1.Show vbModeless
End Sub

At this point you can save the workbook, close it, then open it again (or just run the project from the Workbook_Open() event in the ThisWorkbook object). You’ll see that the UserForm opens, it has proper Minimize and Maximize Buttons and the underlying worksheets are still accessible.

It’s that easy.

Finally, to demonstrate that Min/Max buttons will disappear if the UserForm’s caption changes, open the UserForm and add a Command Button. Set the Name property to cmdChange and the button’s Caption property to “Change Form Caption”. Open the code behind the button and enter the following code:

Private Sub cmdChange_Click()
'Change the form's caption and observe what happens to the Min/Max buttons.
    Me.Caption = "New Test Caption"
End Sub

UserForm for testing Min/Max Buttons

* Once again, save, close and re-open the workbook. When you see the UserForm, click on the “Change Form Caption” button. Immediately you will see the form’s caption change, and the Min/Max buttons disappear. So always insure that if your form name can change on the fly, make sure you add another call to the AddMinMaxButtons method after the caption changes.


Timed Updater Add-In

The Challenge…

I got a request to create an Excel 2007 Add-In, using standard VBA (i.e. not VSTO), that would update market prices of assets listed in an Excel workbook at timed intervals without requiring any structural modifications to the portfolio workbook, and without requiring any VBA code in the portfolio workbook.

A typical portfolio worksheet contains many, many columns of data, but the only column of interest to the new Add-In is column E, the “Market Price”.  First step is to create a workbook for testing that only contains a subset of the information (see below).

Reduced portfolio for testing purposes

Test Portfolio

Now that we have test data to refer to, let’s create the Add-In.

The Solution…

  • Create a new workbook and open the VBA Editor (Alt-F11).
  • Right-click on the project name (usually “VBAProject”) and select VBAProject Properties.  Use the dialog box to change the Project Name to “TimedUpdater” and change the Project Description to “Execute a function repeatedly at timed intervals”.  Click OK to store these changes.
  • In the interest of keeping this as simple as possible, we’re going to use Excel’s built-in Application.OnTime method as our timer.  We could create a more complex timer with granularity down to the millisecond, but that is not needed here, so let’s create a simple class module to expose Timer functionality.  Insert a new Class Module into the project, name it “CTimer”, and add the following constants and module-level variables:
Option Explicit
Private Const TIMER_INTERVAL = "00:00:03" 'Default Interval = 3 secs 
Private Const TIMED_FUNCTION = "TimedFunction" 'Function called at each Interval 
Private mstrTimerInterval As String 
Private mdatSchedTime As Date
  • Next, add the following public properties to the class module:
Public Property Let TimerInterval(ByVal NewInterval As String) 
 mstrTimerInterval = NewInterval 
End Property
Public Property Get TimerInterval() As String 
 TimerInterval = mstrTimerInterval 
End Property
Public Property Get DefaultTimerInterval() As String 
 DefaultTimerInterval = TIMER_INTERVAL 
End Property 
  • The last task for this module is to create the functions that will control the starting and stopping of the timer:
Sub StartTimer() 
 mdatSchedTime = Now + TimeValue(TIMER_INTERVAL) 
 Application.OnTime mdatSchedTime, TIMED_FUNCTION, , True 
End Sub
Sub StopTimer() 
 Application.OnTime mdatSchedTime, TIMED_FUNCTION, , False 
End Sub

We now have a timer class that can be started and stopped, and has the ability to periodically trigger the execution of the function specified in the global constant TIMED_FUNCTION.  It’s time to save the project, but before you save, click on the “ThisWorkbook” object in the project explorer and look at the properties that appear in the properties list.  Locate the property called “IsAddIn” and set it to True.  Now save the project in a separate testing folder, ensuring that it is saved as an “Excel Add-In (*.xlam)”, and name it “MDTimedUpdater.xlam”.  Next, let’s define that function and create some other global objects and functions required to make this Add-In work.

  • Insert a new standard module and name it “modGlobal”.
  • Add the following variable declarations to the module (we’ll be creating the “CDataAccess” class shortly; for now just add the variable declaration exactly as listed below):
Option Explicit
Public gclsTimer As CTimer 
Private mclsData As CDataAccess
  • Create a generic error reporting routine that we can use to report trapped errors throughout the project:
Public Sub ShowErrorMessages(ByVal StandardErrorObject As VBA.ErrObject, _   
 ByVal SourceModule As String, ByVal SourceMethod As String) 
 'Construct a comprehensive error message based on the passed objects. 
 Dim strMsg As String
 'Handle the standard error, if any 
 If StandardErrorObject.Number <> 0 Then 
 strMsg = "Error: " & CStr(Err.Number) & vbCrLf & "Description: " _ 
 & Err.Description & vbCrLf & vbCrLf 
 End If
 'Finally, tack on the module/method names 
 strMsg = strMsg & SourceModule & "::" & SourceMethod & vbCrLf 
 MsgBox strMsg, vbCritical, "Contact Technical Support for Assistance" 
End Sub
  • Add a new public subroutine to modGlobal, called “InitializeTimer”.  This subroutine will be called when the Add-In is first attached and can also be called by external routines:
Public Sub InitializeTimer() 
 Set gclsTimer = New CTimer 
 With gclsTimer 
 If Trim$(.TimerInterval) = "" Then   
 'If not yet set, use default interval value 
 .TimerInterval = .DefaultTimerInterval 
 End If
 End With 
End Sub
  • Next, another new public subroutine to modGlobal, called “CloseTimer”.  This subroutine will be used to stop the timer from executing and can also be called by external routines.
Public Sub CloseTimer() 
 If Not gclsTimer Is Nothing Then 
 Set gclsTimer = Nothing 
 End If 
End Sub
  • We will be returning to modGlobal later on, to create the function that will be triggered at each interval, but first let’s create some other necessary components.  A real portfolio price-updating application would have to reach out to some database, web service, external file, etc., in order to retrieve actual pricing data.  For purposes of this demonstration, we are simply going to create a dummy data access class.  So, insert a new Class Module into the project, name it CDataAccess and add one function, called “RefreshPortfolioPrices”:
Public Function RefreshPortfolioPrices(ByRef arrPrices As Variant) As Boolean 
Dim blnReturn As Boolean 
Dim intItem As Integer
blnReturn = True 
On Error GoTo RPPError 
'Just fill the array with dummy data for testing. 
'@@@ TO DO:  For the real application, the call to update the 
' data (from database, internet, or any other source) 
'  would be coded here. 
ReDim arrPrices(0 To 20)  
For intItem = 0 To UBound(arrPrices) 
 Randomize arrPrices(intItem) = Rnd(100) 'Add randomly generated price to array
Next intItem
 RefreshPortfolioPrices = blnReturn 
 Exit Function
 blnReturn = False 
 ShowErrorMessages Err, "CDataAccess", "RefreshPortfolioPrices" 
 Resume RPPResume 
End Function

This function simply populates the passed array with randomly generated prices between 1 and 100.  As the code comments say, this is where a real application would reach out to a data source to set actual prices.  This module does not need any other code, so save the project and close it.

  • Let’s return back to modGlobal to add the final function required there.  Create a new function called “TimedFunction”.  This function’s purpose is to create a new instance of the CDataAccess class, if necessary, and to retrieve the updated prices from it, and finally to actually update the portfolio worksheet with the updated prices.
Public Function TimedFunction() As Boolean 
'Function to be exectued at timed intervals. 
Dim ws As Worksheet 
Dim vntValue As Variant 
Dim arrData As Variant 
Dim intArraySize As Integer 
Const PRICES_COL = 5

If Application.Workbooks.Count > 0 Then 
 If ActiveWorkbook.Sheets.Count > 0 Then
 'Just make sure there's at least one worksheet showing
 vntValue = Empty
 On Error Resume Next
 Set vntValue = Application.Evaluate(Chr$(39) & 
 _ ActiveSheet.Name & Chr$(39) & "!A1") 
 On Error GoTo 0
 If Not IsEmpty(vntValue) Then
 Set ws = ActiveSheet
 If ws.Range("A1") = "UPDATEME" Then
 'This is a valid portfolio sheet; refresh risk data
 If mclsData Is Nothing Then
 Set mclsData = New CDataAccess
 End If
 If mclsData.RefreshPortfolioPrices(arrData) Then
 'Update the worksheet
 intArraySize = UBound(arrData) + 1
 ws.Cells(START_DATA_ROW, PRICES_COL).Resize(intArraySize, 1).Value 
 _ = Application.Transpose(arrData)
 End If
  'This is not a valid portfolio sheet; ' no need to refresh risk data.
 End If
  Set ws = Nothing
 End If
 End If
End If 
'Trigger timed function again, unless global 
' object has been destroyed by user action.
If Not (gclsTimer Is Nothing) Then
End If

End Function

This function requires a bit of explanation.  First, keep in mind that the Add-In needs to know what’s going on in the “ActiveWorkbook”.  This will not be the Add-In workbook itself, but some other workbook that the user has opened (hopefully, the portfolio workbook).  If no worksheets are present in the Activeworkbook, then any calls to the Add-In’s functions will generate an error, so we confirm that there is a worksheet open in the “ActiveWorkbook”.  Remember at the beginning of this post I mentioned the user requirements that no structural changes could be made to the portfolio workbooks?  Well all we need for our purposes is some consistent piece of information in the portfolio workbook to allow our Add-In to tell if the active workbook is an actual portfolio workbook that will require pricing updates.  In this example, I typed the words “UPDATEME” in unused cell A1 (using white text on white background so it’s invisible).  This will be the indicator that our Add-In will look for.  If there was already something consistent in all of the client’s portfolio worksheets, then maybe you wouldn’t have to enter anything bogus like this.  But, in this demonstration, we’ll use “UPDATEME” as our indicator.  The TimeFunction routine proceeds to look for “UPDATEME” and, when it finds it, it places the array directly into the target range, transposing it using the built-in Excel Transpose function.

If any of the conditions fail, i.e. if there’s no worksheet open, or if the worksheet does not contain the word “UPDATEME” in cell A1, the procedure just exits gracefully and the user is not even aware that anything is running in the background.

The final point that has to be made is that once the Application.OnTime function executes, it is done and will not execute again.  So, it must be initiated again at the end of the function.  Notice that the code checks for the existence of a gclsTimer object first.  This is because some external process (possibly even the user clicking on the Ribbon) may have stopped the timer and destroyed this object while this function was in the process of executing.  In such a case, we don’t want to try to refer to the object again.  If it’s “Nothing”, then we just leave it be and let the function complete.

  • Working backwards to the beginning, we now have to create the ThisWorkbook methods which manage the whole process.  When an Add-In is attached, either directly by the user or when Excel starts, the Workbook_Open event of ThisWorkbook automatically fires.  We will use this to start our timer process running immediately:
Private Sub Workbook_Open() 
End Sub
  • Conversely, when Excel closes, we want to stop the timer before exiting so we use the Workbook_BeforeClose event of ThisWorkbook to terminate the timer:
Private Sub Workbook_BeforeClose(Cancel As Boolean) 
End Sub

Recall that “InitializeTimer” and “CloseTimer” are both methods we created earlier in modGlobal so they are accessible to any module in the project.  Save the project.  Might also want to compile now (Debug… Compile TimedUpdater) just to flush out any syntax errors that may have seeped into the code.

  • Now, we’re in the home stretch.  As things are right now, the Add-In will function.  If you attach the Add-In normally, the timer will fire and the Add-In will keep looking for an open portfolio workbook to update.  If you have not yet created a portfolio workbook (see the graphic near the top of the article for required layout), do so now.  IMPORTANT: Remember to add “UPDATEME” to cell A1 before you save it.  With the Add-In attached and this new workbook open, you should see the prices in column E updating approximately every 3 seconds.
  • The finishing touch to this project will be to add some Ribbon buttons so that the user can control the starting and stopping of the timer as well as the interval.  Managing the Ribbon is beyond the scope of this post, but if you’d like to follow along, I’ll take you through the process very quickly.

The Ribbon…

  • First, save the Add-In and then close Excel completely.
  • The “Custom UI Editor for Microsoft Office” tool is required.  If you don’t have it installed, you can download it free from http://openxmldeveloper.org/archive/2006/05/25/CustomUIeditor.aspx.
  • Run the Custom UI Editor and use it to open the Add-In (MDTimedUpdate.xlam).  You’ll see the Add-In name listed in the Editor’s left pane (see below).
Custom UI Editor screen shot
Add-In loaded in Custom UI Editor
  • Right-click the Add-In name in the left pane and select “Office 2007 Custom UI Part” from the popup menu (unless, of course, you’re actually using Office 2010 for this exercise).  This will create a hidden XML file within the Add-In project.
  • Copy the following XML into the right pane (we’ll address all of this stuff in another post):
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui"> <ribbon> <tabs> <tab id="tabMD" label="MD Add-Ins" > <group id="grpAutoUpdater" label="Auto Updater" > <button id="btnStartTimer" label="Start Timer" imageMso="RecurrenceEdit" size="large" onAction="MDStartTimer" /> <separator id="sep1" /> <button id="btnStopTimer" label="Stop Timer" imageMso="PauseTimer" size="large" onAction="MDStopTimer" /> <separator id="sep2" /> <comboBox id="cboSetInterval" label="Set Interval (seconds):" onChange="cboSetInterval_Click" > <item id="itemSeconds1" label="1" /> <item id="itemSeconds2" label="2" /> <item id="itemSeconds3" label="3" /> <item id="itemSeconds5" label="5" /> <item id="itemSeconds10" label="10" /> <item id="itemSeconds15" label="15" /> <item id="itemSeconds20" label="20" /> <item id="itemSeconds25" label="25" /> <item id="itemSeconds30" label="30" /> </comboBox> </group> </tab> </tabs> </ribbon> </customUI>
  • Click the Save button to save your changes.
  • Click on the last toolbar button on the right (tooltip shows “Generate Callbacks”).  This will generate the Callbacks that you’ll need to plug into your Add-In project in order for the Ribbon to be able to communicate with it (see image, below).  Copy these Callback signatures and paste them into Notepad or any other convenient holding place.
Callbacks generated by Custom UI Editor
VBA Callbacks generated by Custom UI Editor
  • Exit the Custom UI Editor.
  • Return back to Excel and open up the Add-In once again (disabling macros so that the timer does not try to fire when you’re working).
  • Insert a new standard module and name it “modRibbon”.
  • Copy the new subroutine signatures into modRibbon (MDStartTimer, MDStopTimer and cboSetInterval_Click).  We’re now going to add code to these three subroutines.
Sub MDStartTimer(control As IRibbonControl) 'Callback for onAction of Ribbon button btnStartTimer InitializeTimer End Sub
Sub MDStopTimer(control As IRibbonControl) 'Callback for onAction of Ribbon button btnStopTimer CloseTimer End Sub
Sub cboSetInterval_Click(control As IRibbonControl, text As String) 'Callback for cboSetInterval onChange.  This will execute ' when the user clicks the comboBox on the Ribbon.  The "text" ' argument will contain the number of ' seconds to use for the timer interval. If Not gclsTimer Is Nothing Then gclsTimer.TimerInterval = "00:00:" & Right("0" & text, 2) End If End Sub
  • The MDStartTimer subroutine simply passes along control to the InitializeTimer function we defined earlier in modGlobal.  The MDStopTimer subroutine simply makes a call to the CloseTimer subroutine we defined earlier.  The cboSetInterval_Click subroutine contains the code that will be fired when the user chooses an item from the new ComboBox on the Ribbon (which we will see shortly).  The ComboBox will list various choices for the number of seconds to use for the Timer interval.  The value is formatted the way a “TimerInterval” is expected to be formatted (i.e. “00:00:03” for 3 seconds).
  • Save the Add-In and then exit completely.
  • Open Excel and attach our new Add-In.  If all has gone well, you should see a new Ribbon Tab called “MD Add-Ins”.  Click on this tab and you’ll see the “Start Timer” and “Stop Timer” buttons, as well as the “Set Interval (seconds)” ComboBox (see image, below).
New Add-In Ribbon controls
New Add-In Ribbon Controls

Give it a Whirl…

With the Add-In attached, open the test Portfolio workbook that you created earlier.  You should see the asset prices updating approximately every 3 seconds.  Test out the Add-In’s functionality.  Clicking the “Stop Timer” ribbon button should stop the timed pricing updates.  Click “Start Timer” to get them going again.  At any time you can change the interval by selecting a new value from the ComboBox.


With a very small amount of code we have created the framework for an auto-updating portfolio pricing tool.  It can be easily adapted to any project that requires timed updates or monitoring.  A useful additional feature you might want to add would be to retain the user’s Interval selection between sessions so they don’t have to re-set it every time they open Excel.  In future posts we’ll get more into the inner workings of the Ribbon, which can be kind of complex (at least, I think so) and quirky.


Snappy ListBox Population

The Challenge…

Retrieve 10,000 rows from a database table and populate a ListBox control on an Excel Userform; and make it snappy. While 10,000 rows is not a “large” dataset in our business, it is certainly large enough to drive your application users crazy as they wait for their worksheet or List controls to be populated with all this information.  Clearly, looping through a 10,000 row Recordset and populating the ListBox one row/column at a time is not going to meet the requirement.  This post will demonstrate how to create the Userform and ListBox control, retrieve the dataset from the database, and populate the ListBox in an efficient manner.

The Solution…

The ListBox control itself is quite optimized for handling large sets of data.  The key to the speed is in how we retrieve the data from the database and, equally important, how the data is inserted into the ListBox control.

  • Create a new workbook.
  • Open the VBA Editor (Alt-F11).
  • In the Project Explorer, right click on “VBAProject (Book1)” and select VBAProject Properties.
  • Change the Project Name to “SnappyListBox”.
  • Change the Project Description to “Populate ListBox with 10,000 rows from database”
  • Click OK, then click the Save button.  Create a new folder called “SnappyListBox” and name the workbook “SnappyListBox.xlsm” (being careful to save the workbook as a Excel “Macro-Enabled Workbook (*.xlsm)”).
  • Next, create a new Userform (Insert… Userform).  Change the Name property to “frmSnappy” and the Caption to “Snappy ListBox Form”.
  • Change the form’s Height to “400” and Width to “600”.
  • Add a ListBox control to frmSnappy.  Set Top=30, Left=30, Height=300, and Width=540.  Change the ListBox’s name to lstSnappy.
  • Open up the frmSnappy code window and enter the following code in the Userform_Initialize event procedure:

Private Sub UserForm_Initialize()

    'Set basic formatting for the ListView

    With lstSnappy

        .ListStyle = fmListStylePlain

        .BorderStyle = fmBorderStyleSingle

        .ColumnCount = 6

        .BoundColumn = 2

        .TextColumn = 3

        .ColumnHeads = False

        .ColumnWidths = "40pt;55pt;140pt;75pt;40pt;185pt"

        .MultiSelect = fmMultiSelectSingle

        .SpecialEffect = fmSpecialEffectEtched

    End With

End Sub
  • This just sets the basic attributes of the ListBox, such as the number of columns of data it will have, etc.
  • Save the Project.
  • Next, open up the code window for ThisWorkbook and locate the Workbook_Open event.  Add code to show the Userform when the workbook first opens:
Private Sub Workbook_Open()


End Sub
  • Add a Command Button to the form, in the lower right hand corner.  Name it “cmdLoadList” and change the caption to “Load List”.
  • Save the Project once again.  Then, with the Workbook_Open() function still open and selected, press F5 to run the project.  (You could also close the Workbook and open it again to trigger the execution of Workbook_Open(), but just running it from the development environment is much easier).
  • You should see your form appear with a blank list and Command Button, looking something like this:
Basic Userform with empty ListBox

Basic Userform with empty ListBox

  • If any errors are raised, review all the instructions above and try to determine where it went wrong.  Once you confirm that all is working correctly, close the Userform and let’s move on to the next step.

Now that the ListBox is prepared, we need to configure the environment and write the code to retrieve the data from the database.  We will be using a SQL Server database and will be connecting from VBA via ADO.  At this stage, you’ll need to have created a database called “TestDB” and you will need to know the server name on which the database resides and how to build a connection string to connect.  On my end, I have created a test table called “large_test_set” with the following columns defined:

CREATE TABLE [dbo].[large_test_set](
    [price_date] [smalldatetime] NULL,
    [item_id] [varchar](10) NULL,
    [issuer] [varchar](100) NULL,
    [avg_mkt_price] [float] NULL,
    [avg_rating] [varchar](5) NULL,
    [dominant_industry] [varchar](100) NULL

My test table is currently populate with about 14,000 rows.

NOTE:  If you’re unclear about any of the database stuff, you can still follow along with the post to see how the ListBox is managed (which is really the purpose of the post), although you won’t actually be able to run it.  However, it is still probably worthwhile to continue reading.

With everything on the database side now prepared, let’s return to the VBA code.

  • Return to the VBA Editor.  On the menu bar, click Tools… References.  Locate “Microsoft ActiveX Data Objects 2.8 Library” (or 2.7, or 2.6, whatever the latest version of ADO is on your computer; any of the version from the last few years will work for this example).  Check off the ADO selection and click OK to close the dialog.

Now the entire ADO object model is available for use in the project.  Normally, at this point I would plug in one of my data access class modules and go.  But since this is not really a post about ADO or data access, we’re going to keep it very basic and just include all the data access code directly in the form module.

  • Open up the code module for frmSnappy and add the following constant and variable (remember to substitute your values in the connection string constant):
Private Const CONN_STR = "Provider=SQLNCLI10;Server=MyServer;Database=TestDB;Trusted_Connection=yes;"
Private mobjConn As ADODB.Connection
  • Next, add the following module level function to frmSnappy:
Public Function GetRecordsetToArray(SQLToExecute As String) As Variant
    'Load recordset data into an array and return the array to the calling routine.
    'If the recordset does not return any data, this function simply creates a
    '  single element array and populates it with  "No matching records...".
    Dim rst As ADODB.Recordset
    Dim arrData As Variant
    Dim lngX As Long

    On Error GoTo GRAError
    If mobjConn Is Nothing Then
        Set mobjConn = New ADODB.Connection
    End If
    mobjConn.ConnectionString = CONN_STR
    Set rst = New ADODB.Recordset
    With rst
        .CursorLocation = adUseClient
        .LockType = adLockReadOnly
        .Open SQLToExecute, mobjConn, adOpenStatic
        If Not (rst.EOF) Then
            'Disconnect the recordset
            .ActiveConnection = Nothing
            'Get the field count
            lngX = .Fields.Count
            'Load the array
            arrData = .GetRows()
            'Recordset is empty; create dummy array record
            ReDim arrData(0, 0)
            arrData(0, 0) = "No matching records found in the database"
        End If
    End With

        GetRecordsetToArray = arrData
        Set rst = Nothing
        Set mobjConn = Nothing
        Exit Function
        MsgBox "Error: " & Err.Number & vbCrLf & "Description: " & _
            Err.Description & vbCrLf & "Source: frmSnappy::GetRecordSetToArray", _
            vbCritical, "Database Error"
        Resume GRAResume
End Function

Note that this function uses the .GetRows() method of the ADO Recordset object.  GetRows() will take the Recordset data and put it directly into an array.  It’s super-fast and reliable.  Great.  Except for one last problem:  GetRows() load the array such that the first dimension of the array are the Fields/Columns and the second dimension of the array are the Rows.  Which is exactly the opposite of what our ListBox’s .List property is expecting.  So, if I were to code “lstSnappy.List = arrData”, it would not give me the results I’m looking for since the data would be transposed.

Now it’s no real difficult thing to write a routine that will transpose an array, but wouldn’t it be better if the ListBox just had a way of handling this?  Well, it does.  The .Column property.  This poorly documented property will accept an array as its value, transposing it automatically.  (I haven’t seen this usage of .Column documented anywhere, but I’m sure it is; I just haven’t looked hard enough.  But I think it’s safe to say that it isn’t an easy thing to find).

  • Finally, write code for the Command Button to execute the database query and population of the Listbox:
Private Sub cmdLoadList_Click()
Dim strSQL As String
Dim arrData As Variant
'Clear the list first
'Retrieve the data into the array
strSQL = "select price_date, item_id, issuer, "
strSQL = strSQL & "avg_mkt_price, avg_rating, "
strSQL = strSQL & "dominant_industry" & vbCrLf
strSQL = strSQL & "from large_test_set" & vbCrlf
strSQL = strSQL & "order by price_date DESC"
arrDat = GetRecordsetToArray(strSQL)

'Populate the ListBox.
'Transpose and load the array in a single statement.
lstSnappy.Column = arrData

End Sub

Now run your project.  Click the “Load List” command button and see how quickly the thousands of rows are loaded into your ListBox.  Looping through a Recordset and using AddItem on the ListBox will take considerably longer, and will require more code.  Hopefully, this post has been clear enough that you’re seeing the same results I am.  Experiment with other techniques, such as dumping the Recordset onto a worksheet and setting the RowSource property of the ListBox to point to this range.  In my experimentation, the .GetRows/Column method is still considerably faster (and not a kludge like some other methods.

Populated ListBox control

ListBox control populated with 14,000+ Rows


The combination of the .GetRows() method of the ADO Recordset, combined with the mysterious .Column property of the ListBox, provides an optimal solution for quickly loading a ListBox with large data sets.  This technique works with Excel 2003 and 2007, but I have not yet tested it with Excel 2010.  Soon.


The Challenge…

Preferring to use ListView controls rather than standard Listboxes (because they look a lot slicker), the client tasked me with replacing all their Listboxes with ListViews with retention of all current functionality.  I soon discovered a problem with managing right-mouse-clicks on a ListView item. This post recounts the steps involved in taming this snarly beast.

(Note: If, for any reason, the ListView control is not available on your computer, see my post addressing installation and troubleshooting of the ListView, TreeView, ImageList, etc. controls)


This example was created using Excel 2007.

* Create a new macro-enabled workbook.

* Insert a new Userform and name it “frmHitTest” and change the Caption to “ListView HitTest Experiment” (or something like that).  Add a ListView control to the form, naming it “lvwTest”.  Finally, add a command button, name it btnExit, and set the Caption to “Exit”. Double-click the command button to open the btnExit_Click event and add the following code:

Private Sub btnExit_Click()
   Unload Me
End Sub

* Insert a new standard module and name it “modGlobal”.  Add a new subroutine called “InitializeApplication”, as follows:

Public Sub InitializeApplication()
End Sub

* Open the code window for ThisWorkbook and edit the Workbook_Open event as follows:

Private Sub Workbook_Open()
End Sub

* Right-click on the project name (usually “VBAProject”) and select VBAProject Properties.  Use the dialog box to change the Project Name to “ListView HitTest” and change the Project Description to “Proper Way to Perform HitTest on ListView Control”.  Click OK to store these changes.

* Next, let’s set the appearance of the ListView and populate it with some dummy data.  Open the code window for frmHitTest and add the following code in the Userform_Activate event:

Private Sub UserForm_Initialize()
Dim ListItem As MSComctlLib.ListItem
Dim lngRow As Long

'Define ListView appearance
With lvwTest
   .View = lvwReport
   .FullRowSelect = True
   .Gridlines = True
   .HideSelection = False
End With

'Create ListView columns
Dim ch As ColumnHeader
With lvwTest.ColumnHeaders
   Set ch = .Add(, , "ID", 40, lvwColumnLeft)
   Set ch = .Add(, , "First Field", 60, lvwColumnCenter)
   Set ch = .Add(, , "Second Field", 60, lvwColumnLeft)
   Set ch = .Add(, , "Last Field", 100, lvwColumnCenter)
End With

'Populate the ListView with dummy data
With lvwTest
   For lngRow = 0 To 40
     Set ListItem = .ListItems.Add(, , CStr(lngRow))
     ListItem.SubItems(1) = "FirstField" & CStr(lngRow)
     ListItem.SubItems(2) = "SecondField" & CStr(lngRow)
     ListItem.SubItems(3) = "LastField" & CStr(lngRow)
  Next lngRow
End With

End Sub

* Save the project as a macro-enabled workbook, naming it “ListViewHitTest.xlsm”.

* Run the project, either by closing then re-opening the workbook or by opening the Workbook_Open method of the “ThisWorkbook” code module and pressing F5.

Initial Appearance of ListView

Initial Appearance of ListView control

Now, let’s proceed to build the functionality that is required:

  • Capture click of right mouse button (i.e. right-click).
  • Capture the ID of the list item that was right-clicked.
  • Show a simple Msgbox that confirms the right list item has been right-clicked. (i.e. in a real application, this right click would most likely cause the display of a pop-up menu with user choices).

The Solution…

In an attempt not to overcomplicate things you might be tempted to use the MouseDown event of the ListView, accepting all arguments at face value, as follows:

Private Sub lvwTest_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
  ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
    Dim item As MSComctlLib.ListItem

    'Only capture the standard right-clicks; otherwise get out.
    If (Button <> xlSecondaryButton) Or (Shift <> 0) Then Exit Sub
    'Just pass along the event's x and y arguments.
    Set item = lvwTest.HitTest(x, y)

    MsgBox "Item: " & item.ListSubItems(1) & " has been right-clicked!", vbInformation, "Capture Right-Click"
End Sub

Sounds like a reasonable approach.  But this code gets erratic results.  No matter where you right-click, it seems to think you’ve clicked on the first visible item near the top of the list.  In the example below, I have right-clicked List item with ID# 17, but the Excel thinks I have right-clicked on ID #0 (at top of list).  Obviously not the results we wanted.

List View with incorrect list item selected

List View with incorrect list item selected by HitTest

After a bit of MSDN research I find that the ListView MouseDown event’s x and y arguments specify the number of pixels from the top and left of the ListView control.  But the HitTest method requires x and y parameters in Twips.  So, now we must use Windows API functions in order to perform this conversion.

* Add the following global Constants and API Function declarations to modGlobal:

'Windows API Constants
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90

'Windows API Function Declarations

'Get a handle to the Device Context (a drawing layer) for a window
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

'Get the capabilities of a device, from its Device Context
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
    ByVal nIndex As Long) As Long

'Release the handle to the Device Context, to tidy up
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
    ByVal hDC As Long) As Long

* Go back to frmTest and re-enter the code for lvwTest_MouseDown event as follows:

Private Sub lvwTest_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
 ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)

   Dim item As MSComctlLib.ListItem
   Dim lngXPixelsPerInch As Long, lngYPixelsPerInch As Long
   Dim lngDeviceHandle As Long

   'Only capture the standard right-clicks; otherwise get out.
   If (Button <> xlSecondaryButton) Or (Shift <> 0) Then Exit Sub

  'We must determine the Pixels per Inch for the display device.
   lngDeviceHandle = GetDC(0)
   lngXPixelsPerInch = GetDeviceCaps(lngDeviceHandle, LOGPIXELSX)
   lngYPixelsPerInch = GetDeviceCaps(lngDeviceHandle, LOGPIXELSY)
  ReleaseDC 0, lngDeviceHandle

  'Convert the event's x and y arguments from Pixels to Twips
  Set item = lvwTest.HitTest(x * 1440 / lngXPixelsPerInch, _
      y * 1440 / lngYPixelsPerInch)

   MsgBox "List ID #: " & item.Text & " has been right-clicked!", _
      vbInformation, "Capture Right-Click"

End Sub

* Run the project again and see what results you get.   Seems we’re on the right track now!  The HitTest is now able to correctly identify the ListView item that I right-clicked.

HitTest now correctly identifying Item #17 as right-clicked item.

HitTest now correctly identifying Item #17 as right-clicked item.

Great!  Only one problem remaining.  The ListView item that was right-clicked is not visibly selected (i.e. highlighted).  It looks like item #0 is selected even though the mouse cursor is clearly over item #17.  This problem is easily corrected, by forcing the selected item after the HitTest in the lvwTest_MouseDown event on frmTest.  Add the lines below, in blue text, after the existing HitTest line:

  Set item = lvwTest.HitTest(x * 1440 / lngXPixelsPerInch, y * 1440 / lngYPixelsPerInch)
 If Not item Is Nothing Then
     Set lvwTest.SelectedItem = item
 End If

Voila!  Now everything is working as intended.  You can see that item #17 is highlighted, and the MouseDown code is identifying that item #17 was the one that was right-clicked.

ListView with right-click and item highlighting working correctly.

ListView with right-click and item highlighting working correctly.


It’s not obvious that the x and y coordinates needed to be converted from one method to the next, but that was the case.  Even though it’s a bit of a pain to have to add all those API function declarations and constants just to perform the conversion, they can be wrapped in re-usable class modules and re-used from project to project.

Also, depending on the complexity of your Userforms, you may have to rearrange this code a bit.  For example if you have other code that is fired when a ListView item is clicked, you may have to prevent events from recursively firing.  In a recent project, I wanted to show a popup menu when the user right-clicked on a ListView item, and execute other code as well.  I ended up having to put the HitTest and the setting of the “SelectedItem” in the MouseDown event, while the call to the popup menu was placed in the MouseUp event.  If you’re able to implement the code in this post, and duplicate the results, but you find that quirky things are happening, don’t be afraid to experiment with using the different ListView event procedures to try and remedy the problem.

Snarly beast tamed.


HVLookup UDF

The following function can be used to perform a simultaneous Horizontal and Vertical Lookup on a matrix:

Public Function HVLookup(RowLabelValue As Variant, _
ColHeaderValue As Variant, _
objRange As Object, _
Optional vntShowErrBox As Variant) As Variant
'Pass in the values to be matched in matrix column
'header (ColHeaderValue), the matrix row label (RowLabelValue), the
'entire matrix range (objRange), and, optionally, whether or not you
'want to see an error message pop up if not match is found

Dim vntPosHoriz As Variant
Dim vntResult As Variant
Dim strSheet As String

With Application
'Set to volatile so that this function will auto update
'like a native function.

strSheet = objRange.Parent.Name
'Name of the worksheet on which the function is located (only
'needed for error message).

vntPosHoriz = .Match(ColHeaderValue, objRange.Rows(1), 0)
If IsError(vntPosHoriz) Then
If Not IsMissing(vntShowErrBox) Then
MsgBox CStr(ColHeaderValue) & " Does Not Exist in " _
& "Range [Sheet='" & strSheet & "']", _
32, "HVLookup Function Error"
End If
HVLookup = 0
Exit Function
vntResult = .VLookup(RowLabelValue, objRange, vntPosHoriz, False)
End If
End With

'Return result
If IsError(vntResult) Then
HVLookup = 0
HVLookup = vntResult
End If

End Function