Chapter 22

Advanced Techniques

CONTENTS

You've probably noticed that I like to start each chapter with a welcoming paragraph to introduce you to what you are about to read and why it is important. I started doing so with this chapter, but 1,500 words later I realized that what I was writing was the chapter itself.

So instead of the usual introduction, I would like to offer a few words of caution. This chapter discusses some of the most advanced functionality supported by Windows. Many of the techniques I demonstrate are difficult to understand and debug, and when they fail, they are likely to cause your application or your system to hang or raise a memory exception. While I will try to briefly introduce the fundamental ideas behind the techniques shown, you probably won't really understand them without a good understanding of Windows and the Win32 API. So, if you get lost, all I can do is encourage you to read my other book, Dan Appleman's Visual Basic 5.0 Programmer's Guide to the Win32 API, which is referenced throughout this book. Its sole reason for existence is to give Visual Basic programmers a good understanding of Windows and the Win32 API. Since it consists of more than 1500 pages, I'm sure you can appreciate why I don't try to include the information in this chapter.

Visual Basic versus Visual C++

Now that we have discussed the creation of ActiveX controls with Visual Basic at some length, allow me to ask two simple questions. Does Visual Basic 5 make it easy to create ActiveX controls? Does Visual Basic 5 make it possible to create serious, robust, professional-quality ActiveX controls? The answer to both questions is clearly yes-and no. To explain what I mean by this, I first need to discuss a completely different language: Visual C++.

If you have used both Visual Basic and Visual C++, you know they are completely different, and not only because the underlying language is different. You see, Visual C++ is not really "Visual" in the same sense as Visual Basic.

Visual Basic is a highly interactive development environment, where you can interact easily with user interface elements and other objects and attach code directly to their events. The Visual Basic environment encapsulates the underlying Windows and OLE technology so you don't have to deal with it. This encapsulation makes Visual Basic relatively easy to learn and use but does result in some loss of functionality. You can only use those capabilities that are either exposed by Visual Basic or can be accessed by bypassing Visual Basic via API calls or third-party tools.

Visual C++ is a combination of a compiler, class library (called the Microsoft Foundation Classes, or MFC), and set of sophisticated wizards. The class library provides a framework for working with Windows and OLE that can be programmed using the wizards. The wizards know how to create code to accomplish a wide variety of tasks using this framework. The framework itself provides pretty much full access to all of the underlying capability of Windows and OLE. The catch to this approach is: As long as you are trying to implement functionality that is known by one of the wizards, Visual C++ is easy to learn and use. However, the instant you go beyond this built-in functionality, Visual C++ requires a substantial knowledge of Windows and its extension libraries in order to accomplish anything. And while the wizards and class libraries do implement most of the "grunge work" involved in common Windows tasks, they do little or nothing when it comes to implementing features unique to your applications. With Visual Basic, all you need to learn to write simple controls is Visual Basic itself. With Visual C++, you need to know C++, Windows API functions, MFC classes, and OLE. Ultimately, Visual C++ is much harder to learn and use than Visual Basic (and this is from the perspective of someone who routinely uses both).

Here is another thing to keep in mind about Visual C++: If you use the MFC classes and their associated wizards, you will need to distribute the MFC run-time libraries with your control. So despite the fact that you are using C++, you are still stuck with distributing a run-time library-exactly the same situation you face with Visual Basic. It is possible to use Visual C++ to create controls without MFC, but in doing so you lose the benefits of the wizards and the functionality provided by the classes. Learning to create these "lightweight" controls is a significant undertaking, since they require an excellent understanding of both Windows and OLE technology.

Visual Basic's "Limitations"

I've heard a number of people complain about perceived limitations in Visual Basic's ability to create ActiveX controls. These limitations derive from two distinct facts:

First, there are some definite limitations in Visual Basic's implementation of ActiveX controls. These result from the very encapsulation that makes it easy to create controls in VB in the first place. Most of these can be worked around with the aid of API and OLE techniques or third-party tools such as SpyWorks.

Second, there is the problem of expectations. When Visual Basic first appeared, some people considered it a toy language because it didn't do everything they wanted. Features were missing from the core language that could not be implemented without direct access to the Windows API or use of third-party tools. Now we understand that the very nature of the encapsulation VB provides requires that some functionality be left out of the core language. If Visual Basic did everything, it would just be another Visual C++ and be just as hard to learn and use. VB programmers became accustomed to taking advantage of those features built into the language directly, while using API calls or third-party tools to selectively extend Visual Basic where necessary for their own applications. That is perhaps Visual Basic's greatest strength, that it gives you the power to choose for yourself which tasks to perform at a high (VB) level and which to perform at a low (API) level. I believe that many of those programmers who are complaining about Visual Basic's implementation of ActiveX controls are forgetting this trade-off. They've decided that just because Visual Basic does not make it easy to do everything possible in a Visual C++ ActiveX control, it is somehow not suitable for serious control development. This is as silly now as it was then.

You should also keep in mind that Visual Basic's ActiveX control implementation has some unique advantages over the approach taken in Visual C++. It is extraordinarily difficult to build controls out of constituent controls using VC++. The vast majority of VC++ controls are either pure user-drawn controls or are subclassed from a standard control-a technique similar to one you will see shortly in this chapter.

So now let us revisit the opening questions in this chapter. Does Visual Basic 5.0 make it easy to create ActiveX controls? The key word here is easy. The answer is yes, so long as the controls fit closely into the functionality encapsulated by Visual Basic itself. The answer is no, as soon as you need to implement functionality that goes beyond what Visual Basic is designed to handle easily.

Does Visual Basic 5 make it possible to create serious, robust, professional-quality ActiveX controls? The key word here is possible. The answer again is yes, as long as you are willing to put in the effort to take full advantage of all of the resources available to you. If you know the functionality provided by Visual Basic, understand Win32 API programming techniques, understand how to take advantage of advanced API techniques such as subclassing and hooks, understand the nature of COM interfaces, and are willing to use third-party tools that can manipulate those interfaces, then almost anything you can imagine will be possible. But if you are unwilling to learn or use these additional resources, the answer will be no. You will be stuck with using Visual C++, where you may ultimately be forced to use all of those techniques anyway, whether you like it or not!

One of the consequences of this situation is that a sophisticated control can be as complex and difficult to write in Visual Basic as it is in Visual C++. I believe that even in these situations Visual Basic will often have the advantage, if only because it provides a much more interactive development environment with regard to testing and debugging.

Overview of Windows Messaging

Creating advanced controls demands a good understanding of the fundamentals of Windows messaging. If you are already acquainted with Windows messaging, you can skip this section. For everyone else, it should provide enough of a background to allow you to follow the techniques described later in this chapter.

What Is a message?

Consider what happens when you click your mouse on a window. The mouse driver for the Windows operating system detects the mouse click and notifies the operating system that a click has occurred. The operating system detects which window appears under the mouse pointer location and determines which application needs to receive the information.

The operating system maintains a queue for each application that contains a list of events, such as mouse clicks and keystrokes, that need to be sent to the application. Each of these events is called a message, and the queue is thus called the message queue. Each message has associated information, as shown in Table 22.1.

Table 22.1: Message Parameters

Message Parameter Description Mouse Click Example
hWndThe 32-bit window handle that is the destination for the message. The window handle of the window that was clicked.
MessageA 32-bit number assigned to a particular message. &H201, also called WM_LBUTTONDOWN.
wParamA 32-bit parameter whose meaning depends on the message. Flags indicating whether the control and/or shift key is pressed and whether any of the other mouse buttons are currently pressed.
lParamA 32-bit parameter whose meaning depends on the message. The low 16 bits contain the horizontal location within the window of the mouse click position. The high 16 bits contain the vertical location.

How does the operating system actually send a message to a window? Within each Windows application, there is a loop in which the program continuously polls the operating system to see if any messages are available. This loop, called the application message loop, does not exit until the application is closed. This loop is also completely hidden from Visual Basic programmers. When the loop sees that a message is available, it dispatches it to the window that is supposed to receive the message.

How does it do this? Every window in the system has a function defined called a window function. The window function for the window has four parameters. A window function written in Visual Basic would take the form: 

Public Function MyWindowFunction(ByVal hWnd As Long, ByVal message As _
Long, ByVal wParam As Long, ByVal lParam As Long) As Long

In other words, the message loop for the application calls an API function that looks up the window function for a window and calls the function with the message parameters.

It is also possible to call the window function for any window directly, in effect sending a message to the window. There are two API functions you will typically use to do this, each of which takes the standard message parameters (hWnd, message, wParam, and lParam):

When working with Windows, the term posting a message always refers to the use of the PostMessage or related API functions to post a message into an application's message queue. The term sending a message always refers to the use of SendMessage or related API functions to call the window function for a window immediately.

What Happens When a Window Is Created?

When a window is created, whether it is a form, a control, or a custom window, it is always given a window function by the application that creates it. This is another one of those tasks that Visual Basic handles for you. When an application receives messages, it can handle them as it chooses or send them on to a class window function that is provided by Windows. For example: Windows defines a class of windows called LISTBOX. When a window belongs to this class, it can call a class window function provided by Windows which implements the default behavior of a list box. This is what makes it possible for applications to create list boxes without implementing all the complexity of a list box itself.

Figure 22.1 illustrates the control flow when a message is sent to a window. The application (or operating system) calls the window function. The window function can either call the class window function to implement a standard behavior provided by the class or handle the message itself. The arrows with broken lines indicate an optional path for the program's flow.

Figure 22.1 : Execution flow for a window.

What is Subclassing?

Visual Basic provides window functions for forms and controls it creates. Not only does this window function implement the behavior of forms and controls, it also raises Visual Basic events for selected incoming messages.

But it does not raise events for every incoming message. And there are cases where you may wish to override the standard behavior of the form or control provided by the window function that VB furnishes. In cases like this, it is possible to subclass the window. The SetWindowLong API function can be used to set the window function for a window to a function that you specify. Then you have the option of calling the previous window function if you wish. This situation is illustrated in Figure 22.2.

Figure 22.2 : Execution flow for a subclassed window.

What Is a Windows Hook?

A Windows hook is a technique for intercepting messages at various points along the normal message processing sequence. Hooks are installed by providing an address of a hook function to the SetWindowsHookEx function call. Some of the more common hook types are as follows:

Hooks must be handled very carefully, since it is possible to confuse Windows as to what is happening in the system.

It is also possible to establish hooks that work on a system-wide basis or that hook processes other than your own. However, I have serious doubts as to whether this can be done safely (if at all) with Visual Basic. The cross-process hook controls provided with SpyWorks are all written in C++.

Custom Windows, Subclassing, and Visual Basic

One of the intriguing new features of Visual Basic 5.0 is the fact that it is possible to obtain the address of a function using the AddressOf operator. You can pass this address to the CreateWindow API function and create and manage your own private windows. Or, you can pass this address to the SetWindowLong API function to subclass an existing window. This approach is illustrated in the Visual Basic documentation. This means that Visual Basic is now able to create private windows and subclass existing windows, a task that previously required third-party tools.

There are, however, a number of crucial issues relating to these techniques that the Visual Basic documentation does not address:

These issues posed a significant dilemma for me in terms of how I would demonstrate these techniques in this book. You see, my staff just invested a significant effort in adding a Visual Basic-authored component that handles subclassing, private windows, hooks, and more to version 5 of our SpyWorks product. This product is intended to provide VB programmers with the safest and most efficient possible solution to handle this type of low-level windows functionality. It also includes some high-level solutions that are based on this technology and designed specifically to help with ActiveX control development. It is also intended to be educational, in that it includes complete source code. As such, a number of possibilities faced me.

I could have included a subset of the component with some source code. But the schedule for this book did not permit an adequate explanation of the code. I could have included the whole component, but frankly, I couldn't afford to. Our customers understand that what they pay for our software goes directly towards providing them with support and with new features and new products as time goes on. I could have avoided using the component and instead used the techniques shown in the VB documentation. But then I would have been guilty of misleading you by demonstrating code that I would never consider using in my own projects. I could have included a demo version of the component that is fully functional, as long as the component is being run from within Visual Basic itself.

I finally decided on the latter approach. The first customer that every SpyWorks component is designed for is our own technical staff. I personally implemented most of the features in this particular component during the course of my own ActiveX control development (and the writing of this book). I believe that no programmer should ever ship software they are not willing to use in their own applications. These are the components I personally use. So, I do hope you will find this component (and the others in SpyWorks) useful and cost effective. Along the way here I'll try to explain what each call to the component does so you can reproduce the component's functionality yourself if you choose. For those who are interested, SpyWorks includes the full source code for the components used in this chapter.

Messaging Examples

It is simply not possible to discuss the enormous array of advanced techniques that are made possible through the use of API and messaging techniques. All I can hope to do is offer a few representative examples. In this section you will see two of the most common examples for use with ActiveX controls. In the next section you will see how a number of these techniques can be combined to create advanced controls.

Advanced Keystroke Handling

The dwCounter control illustrates a common problem relating to user-drawn controls. You have already seen that the ability to tab between constituent controls within a control is provided by Visual Basic. And you know that you can tab to a user-drawn control. But what if you want to be able to tab between elements in a user-drawn control?

This is the case with the dwCounter control shown in Figure 22.3. This control can be thought of as a digit counter, where each digit can be clicked or changed individually. The version of this control shown here is a simplified version of the dwCounter control from Desaware's ActiveX Gallimaufry.

Figure 22.3 : Counter control.

The control treats each digit individually, meaning that it must be possible not only to set the focus to the control, but also to switch easily between the digits. This is representative of a more complex type of problem, where you have a control that contains a complex form and you want to be able to switch between the elements on the form and edit them individually, without using multiple constituent text boxes.

Listing 22.1 begins our exploration of how this control is implemented by showing the code that implements the control's properties. The listing also includes event and API declarations that will be described later.

Listing 22.1: Counter Control Code Relating to Properties 
' dwCounter control
' Part of Desaware's ActiveX Gallimaufry
' Copyright © 1997 by Desaware Inc.  All Rights Reserved.

Option Explicit
'Default Property Values:
Const m_def_Digits = 2
Const m_def_Value = 0
Const m_def_FocusColor = &HFF&   ' Red
'Property Variables:
Dim m_Digits As Integer
Dim m_Value As Long
Dim m_FocusColor As OLE_COLOR

'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl, _
UserControl,-1,KeyDown
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl _
,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp

' API stuff
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
' Not redeclaration of InvalidateRect from standard
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, _
ByVal lpRect As Long, ByVal bErase As Long) As Long

' Other values
Dim m_DigitWidth As Long
Dim m_FocusIsAt As Integer
Dim WithEvents PretranslateHook As dwPretranslate
Dim m_ClickedDigit As Integer

Private Sub UserControl_Initialize()
   m_ClickedDigit = 1
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
   BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
   UserControl.BackColor() = New_BackColor
   PropertyChanged "BackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BorderStyle
Public Property Get BorderStyle() As Integer
   BorderStyle = UserControl.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
   UserControl.BorderStyle() = New_BorderStyle
   PropertyChanged "BorderStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
   Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
   UserControl.Enabled() = New_Enabled
   PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
   Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
   Set UserControl.Font = New_Font
   PropertyChanged "Font"
   UserControl.Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
   ForeColor = UserControl.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
   UserControl.ForeColor() = New_ForeColor
   PropertyChanged "ForeColor"
End Property

Public Property Get FocusColor() As OLE_COLOR
   FocusColor = m_FocusColor
End Property

Public Property Let FocusColor(ByVal New_FocusColor As OLE_COLOR)
   m_FocusColor = New_FocusColor
   PropertyChanged "FocusColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,hWnd
Public Property Get hwnd() As Long
   hwnd = UserControl.hwnd
End Property

Public Property Get Digits() As Integer
   Digits = m_Digits
End Property

Public Property Let Digits(ByVal New_Digits As Integer)
   If New_Digits < 0 Or New_Digits > 10 Then
      Err.Raise 380
   End If
   If Ambient.UserMode Then
      ' In this preliminary edition, digits is design time only
      Err.Raise 382
   End If
   m_Digits = New_Digits
   PropertyChanged "Digits"
   SetSize
   UserControl.Refresh
End Property

Public Property Get Value() As Long
   Value = m_Value
End Property

Public Property Let Value(ByVal New_Value As Long)
   Dim MaxValue&
   ' Trick to get maximum value -
   ' example: 4 digits is 999
   MaxValue = Val(String$(m_Digits, "9"))
   If New_Value > MaxValue Then
      ' In this preliminary version, no auto digit setting
      Err.Raise 380
   End If
   m_Value = New_Value
   PropertyChanged "Value"
   UserControl.Refresh
End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
   Set Font = Ambient.Font
   m_Digits = m_def_Digits
   m_Value = m_def_Value
   m_FocusColor = m_def_FocusColor
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
   UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
   UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
   Set Font = PropBag.ReadProperty("Font", Ambient.Font)
   UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
   m_FocusColor = PropBag.ReadProperty("FocusColor", m_def_FocusColor)
   m_Digits = PropBag.ReadProperty("Digits", m_def_Digits)
   m_Value = PropBag.ReadProperty("Value", m_def_Value)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
   Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
   Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
   Call PropBag.WriteProperty("Font", Font, Ambient.Font)
   Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
   Call PropBag.WriteProperty("FocusColor", m_FocusColor, m_def_FocusColor)
   Call PropBag.WriteProperty("Digits", m_Digits, m_def_Digits)
   Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
End Sub

Most of the properties are implemented using standard techniques and were, in fact, generated using the ActiveX Interface Wizard. There are three custom properties in this version of the control:

Both the Digits and Value property have simple range checking to make sure that the properties are valid. They raise error 380 (Invalid Property Value) if they are not. The Digits property procedure and the control's Resize event also call the Following function to make sure the control is large enough to display the digits for the currently selected font: 

' Sets the minimum control size
Private Sub SetSize()
   Dim minwidth&
   Dim useheight&
   ' Calculate the width of each digit
   m_DigitWidth = ScaleWidth / Digits
   minwidth = Digits * TextWidth("W")
   useheight = TextHeight("1")
   If ScaleWidth < minwidth Or ScaleHeight < useheight Then
      ' Control is too small
      If ScaleHeight > useheight Then useheight = ScaleHeight
      UserControl.Size ScaleWidth, useheight
      Exit Sub
   End If
End Sub

Private Sub UserControl_Resize()
   SetSize
End Sub

The control has an internal variable named m_FocusIsAt that indicates the focus status of the control. If the control does not have the focus, the variable is set to 0. If the control does have the focus, the variable is set to the digit in the control (starting from 1) that has the focus. The control's EnterFocus and ExitFocus events control the initial setting of the variable when the control receives the focus. They set it to 0 when the control loses the focus as follows: 

Private Sub UserControl_EnterFocus()
   m_FocusIsAt = m_ClickedDigit
   UserControl.Refresh
End Sub

Private Sub UserControl_ExitFocus()
   m_FocusIsAt = 0
   m_ClickedDigit = 1   ' Reset to first digit
   UserControl.Refresh
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   m_ClickedDigit = Int(X / m_DigitWidth) + 1
   If m_FocusIsAt > 0 Then ' Change now if already have focus
      m_FocusIsAt = m_ClickedDigit
      UserControl.Refresh
   End If
End Sub

The m_ClickedDigit variable is used to keep track of which digit was clicked in cases where the focus is set to the control due to a mouse click. This digit is given the focus immediately if the control already has the focus, or during the EnterFocus event if the control is about to gain the focus due to the click.

The control's appearance is defined by the Paint event, which is shown here: 

' This preliminary version has no sophisticated
' border setting
Private Sub UserControl_Paint()
   Dim ypos&
   Dim txt$, fmt$
   Dim charpos%
   Dim thischar$
   If Not Ambient.UserMode Then
      ' Design time shows control name
      txt$ = Ambient.DisplayName
      CurrentY = (ScaleHeight - TextHeight(txt)) / 2
      CurrentX = (ScaleWidth - TextWidth(txt)) / 2
      If CurrentX < 0 Then CurrentX = 0
      Print txt
      Exit Sub
   End If
   ypos = (ScaleHeight - TextHeight("1")) / 2
   fmt$ = String$(m_Digits, "0")
   txt$ = Format$(m_Value, fmt$)
   For charpos = 1 To m_Digits
      If charpos = m_FocusIsAt Then
         UserControl.Line ((charpos - 1) * m_DigitWidth, 0)-(charpos _
         * m_DigitWidth, ScaleHeight), m_FocusColor, BF
      End If
      thischar$ = Mid$(txt$, charpos, 1)
      CurrentX = m_DigitWidth * (charpos - 1) + (m_DigitWidth _
      - TextWidth(thischar)) / 2
      CurrentY = ypos
      UserControl.Print thischar
   Next charpos
   For charpos = 1 To m_Digits - 1
      UserControl.Line (m_DigitWidth * charpos, 0)-(m_DigitWidth * _
      charpos, ScaleHeight)
   Next charpos
End Sub

The appearance of the control at design time differs radically from that at runtime. At design time, the control simply displays the Ambient DisplayName property in the center of the control using the currently selected font. The DisplayName is the name the developer assigned to the control.

At runtime, the routine first obtains a string where each character represents a digit in the control. A format string is defined with the correct length. This string is used with the VB Format function to load a string with the correct number of leading zeros.

The position of each digit is calculated separately so it will appear in the center of the area allocated for that digit. If the digit currently has the focus, the background color for that digit is first filled with the color defined by the FocusColor property. Finally, a line is drawn between the digits. A later version of this control will have a more sophisticated look but, for now, this approach is adequate.

The last problem we face with this control is to provide a way for the user to switch focus between the digits within the control. A first cut at this is to use the arrow keys for this purpose. The right and down arrow keys are defined as switching to the next digit. The left and up keys switch to the previous digit. This is accomplished using the following code: 

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
   RaiseEvent KeyDown(KeyCode, Shift)
   If KeyCode = vbKeyRight Or KeyCode = vbKeyDown Then
      If m_FocusIsAt < m_Digits Then
         m_FocusIsAt = m_FocusIsAt + 1
         UserControl.Refresh
         Exit Sub
      End If
   End If
   If KeyCode = vbKeyLeft Or KeyCode = vbKeyUp Then
      If m_FocusIsAt > 1 Then
         m_FocusIsAt = m_FocusIsAt - 1
         UserControl.Refresh
         Exit Sub
      End If
   End If
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
   RaiseEvent KeyUp(KeyCode, Shift)
End Sub

The first thing the UserControl_KeyDown event does is raise the control's KeyDown event. This allows the developer to override the keystroke. Next, the routine looks for the arrow keys. If it finds one, it changes the m_FocusIsAt variable and redraws the control. The control currently does not allow you to use the arrow keys to change the focus to another control.

The KeyPress event shown below demonstrates how typing a number when a digit has the focus can change the value of that digit. A developer could easily disable this behavior by setting the KeyAscii parameter to 0 during the control's KeyPress event. This is possible because the control's KeyPress event is raised before the KeyAscii value is processed by this routine. 

Private Sub UserControl_KeyPress(KeyAscii As Integer)
   Dim fmt$, txt$
   RaiseEvent KeyPress(KeyAscii)
   If KeyAscii >= vbKey0 And KeyAscii <= vbKey9 Then
      fmt$ = String$(m_Digits, "0")
      txt$ = Format$(m_Value, fmt$)
      Mid$(txt$, m_FocusIsAt, 1) = Chr$(KeyAscii)
      Value = txt$
   End If

End Sub

The one problem with the implementation so far is that you cannot use the tab key to switch focus between the digits of the control. This is because the tab key is intercepted by the container so it can tab between controls. Your control's KeyDown and KeyUp events never see it (even if the KeyPreview property for the control is set to True).

The solution for this problem is to intercept the tab key before it gets to the container. This is accomplished using a WH_GETMESSAGE hook. The dwspyvb.dll component contains an object called dwPretranslate, which uses this hook internally to implement a function similar to the PreTranslateMessage method of the Visual C++ MFC control class. This allows you to see every message before the application processes it. The dwPretranslate object uses internal filtering to retrieve messages destined only for the window that you specify, in this case, the control's window. This reduces the control's overhead considerably. Since Pre-translate functionality is typically used for keyboard messages, an additional filter in this control lets you restrict it to intercepting the WM_KEYDOWN and WM_KEYUP messages.

The PretranslateHook variable is initialized in the following code: 

Private Sub UserControl_Show()
   If Ambient.UserMode And PretranslateHook Is Nothing Then
      ' Not yet initialized
      Set PretranslateHook = New dwPretranslate
      PretranslateHook.KeyMessagesOnly = True
      PretranslateHook.hwnd = UserControl.hwnd
   End If
End Sub

Since there is no need for pre-translation at design time, the PretranslateHook object is only set at runtime. The object raises a single event called PreTranslateMessage which is shown below: 

Private Sub PretranslateHook_PreTranslateMessage(ByVal hwnd As Long, _
Msg As Long, wParam As Long, lParam As Long, nodef As Boolean)
   Static UpPending As Boolean
   Dim IsShiftPressed As Boolean

   IsShiftPressed = GetKeyState(vbKeyShift) < 0
   ' Watch for tab key
   If Msg = WM_KEYDOWN And wParam = vbKeyTab Then
      If m_FocusIsAt < m_Digits And Not IsShiftPressed Then
         m_FocusIsAt = m_FocusIsAt + 1
         Call InvalidateRect(UserControl.hwnd, 0, True)
         UpPending = True
         Msg = 0
         nodef = True
      End If
      If m_FocusIsAt > 1 And IsShiftPressed Then
         m_FocusIsAt = m_FocusIsAt - 1
         Call InvalidateRect(UserControl.hwnd, 0, True)
         UpPending = True
         Msg = 0
         nodef = True
      End If
      Exit Sub
   End If
   If Msg = WM_KEYUP And wParam = vbKeyTab And UpPending Then
      ' Kill the pending keyup tab
      Msg = 0
      nodef = True
      UpPending = False
   End If
End Sub

This event includes the standard message parameters. The Msg, wParam, lParam, and nodef parameters are passed by reference, meaning that the functions can change their values before they are processed by the application. If you set the nodef parameter to True, you prevent subsequent controls that have placed windows hooks from intercepting the message.

The routine first checks the current state of the shift key, which allows it to determine in which direction the focus is changing. The current implementation always sets the focus to the first digit when the control receives the focus, so performing a shift tab into the control will go to the first digit instead of the last. It is possible to change this behavior, but it is a great deal of trouble since you must figure out which control previously had the focus. However, this is a minor limitation, since few people use the shift-tab combination to tab backward.

When a tab key arrives, the control determines whether a focus change is necessary. If so, it changes the value of the m_FocusIsAt variable.

It then sets the UpPending static variable to True. This is a static variable that belongs to the event procedure. It is used when the WM_KEYUP message arrives indicating that the tab key has been released. You see, the event procedure throws away the WM_KEYDOWN message, and Windows might become confused if it sees the tab key being released without its first being pressed. So this variable is set to True before the tab key press message is discarded as a signal to throw away the release message as well.

The message is thrown away by setting the Msg value to 0. The null message is ignored by all windows. The nodef parameter is also set to True to prevent other hooks from seeing the message as well.

The InvalidateRect API function is used to update the control display. Why not use the UserControl Refresh method? Because this event is occurring during a Windows message hook, which is a dangerous time for many operations. It is always a good idea to keep hook functions as simple as possible and avoid performing complex operations that might confuse the system if they occur in the middle of a message dispatch operation. A refresh operation, with all of the code associated in the Paint event, is a vast unknown. It may work safely, but it's a risk. The InvalidateRect API is a fast call that simply notifies Windows that the entire area of the control window is now invalid and needs to be redrawn. Windows will itself post a WM_PAINT message for the window into the application's message queue, which in turn will trigger the control's Paint event.

One thing this control does not do is properly set the focus for a digit when you click on the control. This is left as an exercise for the reader. (Hint: use the UserControl's MouseDown event.)

Managing Update Areas

One of the limitations of the Visual Basic model of ActiveX control development with regard to user-drawn controls relates to the Paint event. The problem is that when this event occurs, you must redraw the entire control. This can be a very time-consuming operation for a complex control, and much of that time may be wasted in cases where the Paint event is triggered and only a small portion of the control needs to be redrawn. This often happens when dragging windows over each other or when a dialog box or message box is hidden.

If your control's drawing routine can be designed to only update those parts of the window that have changed, you might be able to gain a substantial performance benefit. You can determine the update area of a window using subclassing by calling the GetUpdateRect API function during the WM_PAINT message for the window. Listing 22.2 shows a control that does not use this technique to update itself. Instead, it subclasses its container so the container can determine its update area.

Listing 22.2: The PaintUpdate Control Code
 
' Guide to the Perplexed
' Paint update example
' Copyright © 1997 by Desaware Inc. All Rights Reserved

Option Explicit

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Declare Function GetUpdateRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT, ByVal bErase As Long) As Long

Private Const WM_PAINT = &HF

Dim m_UpdateRect As RECT

Dim WithEvents UpdateHook As dwSubClass

Private Sub UpdateHook_WndMessage(ByVal hwnd As Long, Msg As Long, wp As _
Long, lp As Long, retval As Long, nodef As Boolean)
   Call GetUpdateRect(Extender.Parent.hwnd, m_UpdateRect, False)
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   If Ambient.UserMode Then
      Set UpdateHook = New dwSubClass
      UpdateHook.AddMessage WM_PAINT
      UpdateHook.HwndParam = Extender.Parent.hwnd
   End If
End Sub

Private Sub UserControl_Resize()
   UserControl.Size UserControl.Picture.Width, UserControl.Picture.Height
End Sub

Private Sub UserControl_Terminate()
   Set UpdateHook = Nothing
End Sub

Public Property Get UpdateLeft() As Long
   UpdateLeft = m_UpdateRect.Left * Screen.TwipsPerPixelX
End Property

Public Property Get UpdateTop() As Long
   UpdateTop = m_UpdateRect.Top * Screen.TwipsPerPixelY
End Property

Public Property Get UpdateRight() As Long
   UpdateRight = m_UpdateRect.Right * Screen.TwipsPerPixelX
End Property

Public Property Get UpdateBottom() As Long
   UpdateBottom = m_UpdateRect.Bottom * Screen.TwipsPerPixelY
End Property

The dwSubClass object is part of the dwspyvb.dll component. The UpdateHook variable is initialized during the ReadProperties event, by which time the Extender property is valid. The HwndParam property of the UpdateHook object sets the window to be subclassed, in this case using the window handle of the container. The control could detect its own update area by using the hWnd property of the UserControl object instead.

The AddMessage method sets the WM_PAINT message as the only message to be detected. The object performs message filtering at a low level to provide the best possible performance. This also eliminates the need to check for messages during the object's WndMessage event. The WM_PAINT message is the only one that will arrive.

During the WndMessage event, the update rectangle is retrieved using the GetUpdateRect function and stored in the m_UpdateRect variable. The fields of this variable can be read using the UpdateLeft, UpdateTop, UpdateRight, and UpdateBottom properties.

The UpdateTest program demonstrates this by displaying the update coordinates in a Label control on the frmUpdate form. Try dragging a window over part of the form to see how this works.

A Tale of Four Listboxes

We will conclude both our discussion of advanced controls, and our discussion of controls in general, with a look at four different approaches towards implementing a custom Listbox control. These will include:

Before beginning, I should stress that none of these controls are intended as examples of complete or robust controls. In most cases only a few properties and events are implemented-just enough to illustrate the techniques associated with the particular approach. They have undergone minimal testing and have little or no error checking.

The ListCtls.vbg project group contains two projects. ListCtls.vbp contains the four controls that demonstrate the approaches listed above. ListTest.vbp contains four forms that demonstrate some of the characteristics of the four controls.

A Constituent-Based Control

Listing 22.3 contains the code for the constituent control-based example. This control illustrates the main limitation of this approach-that it is impossible for a developer using your control to set the design-time properties of a constituent control. This is because your control is in run mode even during the container's design time. The MultiSelect property is an example of a property that cannot be changed at runtime. The ListCtlA supports the MultiSelect property by including two separate list controls, one that is set to multi-select mode, the other to single-select.

Listing 22.3: Listing for Control ListCtlA.ctl
 
' Constituent control based list example
' Copyright (c) 1997, by Desaware Inc. All Rights Reserved

Option Explicit
'Event Declarations:
Event Click()
Event DblClick()
Event KEYDOWN(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KEYUP(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)

Dim CurrentListBox As ListBox
Dim m_MultiSelect As Boolean

Public Property Get MultiSelect() As Boolean
   MultiSelect = m_MultiSelect
End Property


Public Property Get BackColor() As OLE_COLOR
   BackColor = CurrentListBox.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
   List1.BackColor = New_BackColor
   List2.BackColor = New_BackColor
   PropertyChanged "BackColor"
End Property

Public Property Get ForeColor() As OLE_COLOR
   ForeColor = CurrentListBox.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
   List1.ForeColor = New_ForeColor
   List2.ForeColor = New_ForeColor
   PropertyChanged "ForeColor"
End Property

Public Property Get Enabled() As Boolean
   Enabled = CurrentListBox.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
   List1.Enabled = New_Enabled
   List2.Enabled = New_Enabled
   PropertyChanged "Enabled"
End Property

Public Property Get Font() As Font
   Set Font = CurrentListBox.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
   Set List1.Font = New_Font
   Set List2.Font = New_Font
   PropertyChanged "Font"
End Property

Public Sub Refresh()
   CurrentListBox.Refresh
End Sub

Private Sub List1_Click()
   RaiseEvent Click
End Sub

Private Sub List2_Click()
   RaiseEvent Click
End Sub


Private Sub List1_DblClick()
   RaiseEvent DblClick
End Sub

Private Sub List2_DblClick()
   RaiseEvent DblClick
End Sub

Private Sub List1_KeyDown(KeyCode As Integer, Shift As Integer)
   RaiseEvent KEYDOWN(KeyCode, Shift)
End Sub

Private Sub List2_KeyDown(KeyCode As Integer, Shift As Integer)
   RaiseEvent KEYDOWN(KeyCode, Shift)
End Sub

Private Sub List1_KeyPress(KeyAscii As Integer)
   RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub List2_KeyPress(KeyAscii As Integer)
   RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub List1_KeyUp(KeyCode As Integer, Shift As Integer)
   RaiseEvent KEYUP(KeyCode, Shift)
End Sub

Private Sub List2_KeyUp(KeyCode As Integer, Shift As Integer)
   RaiseEvent KEYUP(KeyCode, Shift)
End Sub

Private Sub List1_MouseDown(Button As Integer, Shift As Integer, x As Single, _
                            Y As Single)
   RaiseEvent MouseDown(Button, Shift, x, Y)
End Sub

Private Sub List2_MouseDown(Button As Integer, Shift As Integer, x As Single, _
                            Y As Single)
   RaiseEvent MouseDown(Button, Shift, x, Y)
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, x As Single, _
                            Y As Single)
   RaiseEvent MouseMove(Button, Shift, x, Y)
End Sub

Private Sub List2_MouseMove(Button As Integer, Shift As Integer, x As Single, _
                            Y As Single)
   RaiseEvent MouseMove(Button, Shift, x, Y)
End Sub

Private Sub List1_MouseUp(Button As Integer, Shift As Integer, x As Single, _
                          Y As Single)
   RaiseEvent MouseUp(Button, Shift, x, Y)
End Sub

Private Sub List2_MouseUp(Button As Integer, Shift As Integer, x As Single, _
                          Y As Single)
   RaiseEvent MouseUp(Button, Shift, x, Y)
End Sub

Public Sub AddItem(item As String, Optional Index As Variant)
   CurrentListBox.AddItem item, Index
End Sub

Public Sub Clear()
   CurrentListBox.Clear
End Sub


Public Property Get hwnd() As Long
   hwnd = CurrentListBox.hwnd
End Property

Public Property Get ItemData(ByVal ItemIndex As Long) As Long
   ItemData = CurrentListBox.ItemData(ItemIndex)
End Property

Public Property Let ItemData(ByVal ItemIndex As Long, ByVal New_ItemData _
                             As Long)
   CurrentListBox.ItemData(ItemIndex) = New_ItemData
   PropertyChanged "ItemData"
End Property

Public Property Get List(ByVal ItemIndex As Long) As String
   List = CurrentListBox.List(ItemIndex)
End Property

Public Property Let List(ByVal ItemIndex As Long, ByVal New_List As String)
   CurrentListBox.List(ItemIndex) = New_List
   PropertyChanged "List"
End Property

Public Property Get ListCount() As Integer
   ListCount = CurrentListBox.ListCount
End Property

Public Property Get ListIndex() As Integer
   ListIndex = CurrentListBox.ListIndex
End Property

Public Property Let ListIndex(ByVal New_ListIndex As Integer)
   CurrentListBox.ListIndex = New_ListIndex
   PropertyChanged "ListIndex"
End Property

Public Property Get MouseIcon() As Picture
   Set MouseIcon = CurrentListBox.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
   Set List1.MouseIcon = New_MouseIcon
   Set List2.MouseIcon = New_MouseIcon
   PropertyChanged "MouseIcon"
End Property

Public Property Get NewIndex() As Integer
   NewIndex = CurrentListBox.NewIndex
End Property

Public Sub RemoveItem(Index As Integer)
   CurrentListBox.RemoveItem Index
End Sub

Public Property Get Selected(ByVal ItemIndex As Long) As Boolean
   If CurrentListBox Is List2 Then
      Selected = CurrentListBox.Selected(ItemIndex)
   Else
      ListError 1000
   End If
End Property

Public Property Let Selected(ByVal ItemIndex As Long, ByVal New_Selected _
As Boolean)
   If CurrentListBox Is List2 Then
      CurrentListBox.Selected(ItemIndex) = New_Selected
      PropertyChanged "Selected"
   Else
      ListError 1000
   End If
End Property


Private Sub UserControl_InitProperties()
   Set CurrentListBox = List1
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   m_MultiSelect = PropBag.ReadProperty("MultiSelect", False)
   If m_MultiSelect Then
      Set CurrentListBox = List2
      List1.Visible = False
      List2.Visible = True
   Else
      Set CurrentListBox = List1
      List2.Visible = False
      List1.Visible = True
   End If
   BackColor = PropBag.ReadProperty("BackColor", &H80000005)
   ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
   Enabled = PropBag.ReadProperty("Enabled", True)
   Set CurrentListBox.Font = PropBag.ReadProperty("Font")
   Set CurrentListBox.MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
End Sub


'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   Call PropBag.WriteProperty("MultiSelect", m_MultiSelect, False)
   Call PropBag.WriteProperty("BackColor", CurrentListBox.BackColor, &H80000005)
   Call PropBag.WriteProperty("ForeColor", CurrentListBox.ForeColor, &H80000008)
   Call PropBag.WriteProperty("Enabled", CurrentListBox.Enabled, True)
   Call PropBag.WriteProperty("Font", CurrentListBox.Font)
   Call PropBag.WriteProperty("MouseIcon", CurrentListBox.MouseIcon, Nothing)
End Sub

As you can see, most of the standard properties and events are implemented in the same manner that we have seen throughout this book.

In this implementation, the properties are mapped to both controls. It might be more efficient to use variables to hold the property values and only set the constituent properties for the control that is currently visible. However, this would also require additional code to load all of the constituent control's properties when you switch from one control to the other.

A variable called CurrentListBox serves as a handy reference to the constituent control that is in use. It is set during both the ReadProperties event and the Property Let procedure for the MultiSelect property as shown below. 

Public Property Let MultiSelect(ByVal vNewValue As Boolean)
   If UserControl.Ambient.UserMode Then
      ' Can't change list type at runtime
      SetNotSupportedAtRuntime
   End If
   m_MultiSelect = vNewValue
   If m_MultiSelect Then
      Set CurrentListBox = List2
      List1.Visible = False
      List2.Visible = True
   Else
      Set CurrentListBox = List1
      List1.Visible = True
      List2.Visible = False
   End If

   PropertyChanged "MultiSelect"
End Property

Note that it is possible using this approach to allow the user to switch between multiple-select and single-select mode at the container's runtime as well, though that functionality is not implemented here. If you decide to allow that feature, you would also have to decide whether the current contents of the listbox should be copied from one constituent control to the other during the switch. This example raises an error in this case to remain compatible with the standard listbox.

The Resize event positions both listboxes so they fill the client area of your control as shown here in the UserControl_Resize event: 

Private Sub UserControl_Resize()
   List1.Move 0, 0, ScaleWidth - Screen.TwipsPerPixelX, _
   ScaleHeight - Screen.TwipsPerPixelY
   List2.Move 0, 0, ScaleWidth - Screen.TwipsPerPixelX, _
   ScaleHeight - Screen.TwipsPerPixelY
End Sub

What if you wanted to handle the constituent control's Appearance property as well? This is another design-time-only property, so you would need four separate constituent list controls in order to support it. The Integral property would bring you to eight controls. Add the Sorted property, and you would be up to 16 constituent controls…

As you see, this approach can verge on the ridiculous very quickly. The overhead of supporting 17 windows for each control (the 16 listboxes plus the UserControl object) is horrendous. Any programmer who chooses this approach should (hopefully) quit the profession in embarrassment.

This is not to say that you should never use the constituent approach. Just that it is impractical if you require that your developer be able to change more than one design-time property (two at the most).

A User-Drawn Control

Consider, for a moment, the standard listbox window class implemented by Windows. This is the class used by Visual Basic to implement its standard listbox control. How is the class itself implemented?

When a listbox window is created, the system first creates a window (which is just like any other window in the system). It assigns the class window function for the listbox class to the window. This window function receives incoming messages sent or posted to the window. When a paint message arrives, the code draws the listbox using API functions. Mouse or keyboard messages perform various selection and scrolling operations. Control messages can be sent to the window in order to perform tasks such as adding and deleting strings. The listbox is able to send messages to its parent window to notify it when certain events occur, such as a selection change. The characteristics of the listbox, such as whether it is sorted, or if it is a single- or multiple-selection listbox, are determined by the style characteristics of the window. Every window has two 32-bit style variables. Some of the bits in these variables are standardized, such as whether the window has a border. Others depend on the type of window.

We'll revisit this subject in slightly more detail later. For now, consider this: A Visual Basic-authored ActiveX control receives events. It can define internal variables. It can expose methods and properties to the outside world. It can paint whatever it chooses into its control window. The mechanism might not be the same as a window class defined by the system, but the effect is the same.

A listbox window is a window with code that processes incoming messages. An ActiveX control is a window with code that processes incoming messages. Obviously, you could implement your own list control from scratch, duplicating all or part of the functionality of a standard listbox window. If the thought of doing this seems a bit intimidating, it's probably because the task is quite intimidating. But it can be done, and with Visual Basic's new support for native code compilation, you can obtain excellent performance from this approach.

And keep in mind one important fact: If you do choose this approach, you are not limited to the features or characteristics of either the standard Visual Basic Listbox control or the Listbox window class. Your List control could include bitmaps, or even audio or video clips.

The ListCtlB example demonstrates this approach. In this case the control is designed to mimic the appearance and much of the behavior of the standard listbox, just to show it can be done. Once again, let me stress that what you see here is an experimental control designed purely for educational purposes. It is based on code I have been using in conference and training sessions over the past few years to demonstrate some of the possibilities that Visual Basic offers. It has gradually evolved over that time, and this is its first incarnation as an ActiveX control. Note that the multiple-selection capability, as it is implemented here, is a hack that was added to demonstrate the possibility of supporting both single and multiple selection in such a control. The multiple-selection behavior does not duplicate that of a standard listbox, nor is it a demonstration of good design. A proper redesign and implementation is a task for some future version.

The declarations and variables for the ListCtlB control are shown below. As you can see, this control takes advantages of a number of Win32 API functions. 

' User drawn list example
' Copyright (c) 1997, by Desaware Inc. All Rights Reserved
Option Explicit

Private Type RECT   '16 Bytes
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type

Private Type POINTAPI  '8 Bytes - Synonymous with LONG
    x As Long
    Y As Long
End Type

Private Declare Function DrawFocusRect& Lib "user32" (ByVal hdc As Long, _
lpRect As RECT)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal hdc _
As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal _
wFormat As Long)
Private Declare Function GetSysColor& Lib "user32" (ByVal nIndex As Long)
Private Declare Function InflateRect& Lib "user32" (lpRect As RECT, ByVal x _
As Long, ByVal Y As Long)
Private Declare Function ScrollWindowByNum& Lib "user32" Alias "ScrollWindow" _
(ByVal hwnd As Long, ByVal XAmount As Long, ByVal YAmount As Long, lpRect As _
RECT, ByVal lpClipRect As Long)
Private Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI)
Private Declare Function SetCursorPos& Lib "user32" (ByVal x As Long, ByVal Y _
As Long)
Private Declare Function SetCapture& Lib "user32" (ByVal hwnd As Long)
Private Declare Function ReleaseCapture& Lib "user32" ()
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function SetTextColor& Lib "gdi32" (ByVal hdc As Long, _
ByVal crColor As Long)
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal _
hObject As Long) As Long

Private CurrentTop As Long
Private TotalLines As Long
Private PixelsPerLine As Integer
Private Selected() As Long    ' The number of the selected line
Private HasFocus As Long
Private highlight As Long
Private HighlightText As Long
' Note, -1,-1 on these means to draw it all
Private LowDrawRange As Long    ' Lowest that needs drawing
Private HighDrawRange As Long   ' Highest that needs drawing
Private ClickLine As Long       ' Line on which click is detected
Private InContext As Integer    ' Prevent reentrant mousemove events
Private Light3D As Long       ' 3D highlight
Private Dark3D As Long        ' 3D shadow
Private DarkShadow As Long    ' 3D dark shadow
Private FixNextScroll As Long

Private Const KEYDOWN = 40
Private Const KEYUP = 38
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_3DDKSHADOW = 21
Private m_BorderStyle As Integer  ' 1 = Single, 2 = 3D, 0 = None
Private m_MultiSelect As Boolean  ' Multiple selection dialog


Private Const DT_LEFT = &H0
Private Const DT_SINGLELINE = &H20
Private Const DT_NOPREFIX = &H800

The control has a number of internal variables that hold precalculated values such as the number of pixels per line. The control has a single constituent scroll bar to allow the listbox to scroll.

This List control does not actually hold string data. Instead, it requests the string data for each item from the container using the GetText event. This approach does require additional work from the container, but it can be extremely efficient in that it does not require that you preload the listbox with data ahead of time. This can be ideal for database applications, where you would only need to retrieve those few items visible when the control is first displayed. It also makes it easy to handle very large numbers of entries efficiently.

The code for the properties and methods for the control is shown below. As you can see, it is possible to set both the BorderStyle and MultiSelect properties at the container's design time and runtime. This is because these characteristics impact the control's behavior and appearance, and these are implemented entirely in the control's code. 

'------------------------------------------------------
'
'  Control Public Methods and Events
'
Event GetText(ByVal location As Long, ListBoxString As String)
Event Click()
Event DblClick()

Public Property Get BorderStyle() As dwBorderStyle
   BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(vNewBorder As dwBorderStyle)
   If vNewBorder < 0 Or vNewBorder > 2 Then
      ListError 380
   End If
   m_BorderStyle = vNewBorder
   PropertyChanged "BorderStyle"
   CalculateValues
   PositionScrollBar
   lbInvalidateRange
   Refresh
End Property

Public Property Get MultiSelect() As Boolean
   MultiSelect = m_MultiSelect
End Property

Public Property Let MultiSelect(ByVal vNewValue As Boolean)
   m_MultiSelect = vNewValue
   ReDim Preserve Selected(0)
   lbInvalidateRange
   Refresh
   PropertyChanged "MultiSelect"
End Property

Public Property Get BackColor() As OLE_COLOR
   BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(vNewColor As OLE_COLOR)
   UserControl.BackColor = vNewColor
   PropertyChanged "BackColor"
End Property

Public Property Get Font() As Font
   Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal vNewValue As Font)
   Set UserControl.Font = vNewValue
   PropertyChanged "Font"
   CalculateValues
   lbInvalidateRange
   Refresh
End Property

The UserControl_Initialize event initializes the internal listbox variables to their default values. The listbox colors are retrieved at this time based on the standard system colors. You can add new properties to override their values if you wish.

Those user events that control the operation of the listbox call a set of private functions with the LB prefix. This arrangement is intended to improve the readability and modularity of the code. Some events, such as the Resize event, require that some of the listbox variables be recalculated. One of the important tasks you must perform with any user-drawn control is to check the impact each variable has on the appearance of the control and handle it correctly. This control does demonstrate a good approach for handling this, where the calculations are isolated into a few routines that can be called as necessary. 

'------------------------------------------------------
'
'  UserControl Methods and Events
'


Private Sub UserControl_Initialize()
   CurrentTop = 0
   LowDrawRange = -1
   HighDrawRange = -1
   m_BorderStyle = dw3d
   UserControl.BackColor = &HFFFFFF
   ReDim Selected(0)
   Selected(0) = -1
   FixNextScroll = -1
   PixelsPerLine = TextHeight("W") + 1
   highlight = GetSysColor(COLOR_HIGHLIGHT)
   HighlightText = GetSysColor(COLOR_HIGHLIGHTTEXT)
   Light3D = GetSysColor(COLOR_BTNHIGHLIGHT)
   Dark3D = GetSysColor(COLOR_BTNSHADOW)
   DarkShadow = GetSysColor(COLOR_3DDKSHADOW)
End Sub

Private Sub UserControl_Click()
   RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
   RaiseEvent DblClick
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x _
As Single, Y As Single)
    LBMouseDown x, Y
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x _
As Single, Y As Single)
    LBMouseMove Button, x, Y
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x _
As Single, Y As Single)
    LBMouseUp
End Sub

Private Sub UserControl_Paint()
    LBDraw
End Sub

Private Sub UserControl_Resize()
   CalculateValues
   PositionScrollBar
   lbInvalidateRange
End Sub

Private Sub UserControl_EnterFocus()
   LBGotFocus
End Sub

Private Sub UserControl_ExitFocus()
   LBLostFocus
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   m_BorderStyle = PropBag.ReadProperty("BorderStyle", dw3d)
   m_MultiSelect = PropBag.ReadProperty("MultiSelect", False)
   UserControl.BackColor = PropBag.ReadProperty("BackColor", &HFFFFFF)
   Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
   CalculateValues
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, dw3d)
   Call PropBag.WriteProperty("MultiSelect", m_MultiSelect, 0)
   Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &HFFFFFF)
   Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
End Sub

Private Sub UserControl_InitProperties()
   m_BorderStyle = dw3d
End Sub

The ListCtlB control uses a constituent scrollbar to provide scrolling capability for the listbox. The prospect of creating an owner-drawn scrollbar on the control window was too depressing to contemplate. This approach does have one major disadvantage. As you may recall, when you use a visible constituent control in a Visual Basic-authored control, the control itself cannot receive the focus. Focus will always go to the constituent control. This means all keystroke events will come in by way of the scrollbar control instead of the UserControl object. It also means that the scrollbar will appear to have the focus when your control has the focus, which will not produce the appearance of a standard list control. This is unavoidable using this particular implementation, but you'll see an easy solution in the next example. 

'------------------------------------------------------
'
'  VScroll1 Methods and Events
'

Private Sub VScroll1_Change()
   If FixNextScroll >= 0 Then
      If VScroll1.Value <> FixNextScroll Then
         VScroll1.Value = FixNextScroll
         Exit Sub
      End If
      FixNextScroll = -1
      Exit Sub
   End If
   Debug.Print "Change"
   LBScrollChange
End Sub

Private Sub VScroll1_KeyDown(KeyCode As Integer, Shift As Integer)
   FixNextScroll = VScroll1.Value
   LBArrow KeyCode
End Sub

Private Sub VScroll1_Scroll()
   Debug.Print "Scroll"
   LBScroll
End Sub

Private Sub VScroll1_KeyPress(KeyAscii As Integer)
   If KeyAscii = vbKeySpace And m_MultiSelect Then
      LBSelect ClickLine
      lbInvalidateRange ClickLine, ClickLine
      Refresh
   End If
End Sub

The user-drawn List control is actually implemented using the functions that follow. Now, I'll admit that this code looks somewhat complex. The truth is, I could probably spend the better part of an entire chapter describing it, but time and space do not permit that. My best suggestion is that you tackle it the way you would any other complex piece of code. Try to follow the logic, and trace through the code at runtime. 

'------------------------------------------------------
'
'  Functions that implement the user drawn list control
'
'
' Call this from the keydown event in the control
'
Private Sub LBArrow(keyid%)
   Dim newClickLine&
   Dim NewScrollValue&
   Select Case keyid%
      Case KEYDOWN
         newClickLine = ClickLine + 1
      Case KEYUP
         newClickLine = ClickLine - 1
      Case Else
         Exit Sub
   End Select
   If newClickLine < 0 Or newClickLine > VScroll1.Max Then
      ' No change, so block the redraw caused by the container
      Exit Sub
   End If
   ClickLine = newClickLine
   HasFocus = ClickLine
   If Not m_MultiSelect Then LBSelect ClickLine

   If ClickLine < CurrentTop Then
      FixNextScroll = -1
      NewScrollValue = VScroll1.Value - 1
      VScroll1.Value = NewScrollValue
      FixNextScroll = NewScrollValue
      Exit Sub
   End If

   If ClickLine > CurrentTop + TotalLines - 1 Then
      FixNextScroll = -1
      NewScrollValue = VScroll1.Value + 1
      VScroll1.Value = NewScrollValue
      FixNextScroll = NewScrollValue
      Exit Sub
   End If
   LBDraw
End Sub

Each line obtains the text to draw using the GetText event. It calculates the exact area in the window that will be covered by the line, taking the current border and scrollbar position into account. If the line is not visible, it doesn't bother drawing the line at all. 

' Draw the specified line number in the list box
'
Private Sub LBDrawLine(tloc&)
   Dim rc As RECT
   Dim rc2 As RECT
   Dim di&
   Dim oldcolor&
   Dim txt$
   Dim usefont As IFont
   Dim oldfont As Long
   If tloc < CurrentTop Or tloc > CurrentTop + TotalLines Then
      ' It's not visible
      Exit Sub
   End If
   If Ambient.UserMode Then
      RaiseEvent GetText(tloc, txt$)
   Else
      If tloc = 0 Then txt = Extender.Name
   End If

   rc.left = m_BorderStyle + 1
   rc.right = ScaleWidth - VScroll1.Width - m_BorderStyle * 2
   rc.top = (tloc - CurrentTop) * PixelsPerLine + m_BorderStyle
   rc.bottom = rc.top + PixelsPerLine - 1
   Line (m_BorderStyle, rc.top + m_BorderStyle)-(ScaleWidth - _
   VScroll1.Width, rc.bottom + m_BorderStyle), BackColor, BF
   If IsSelected(tloc) Then
      If VScroll1.hwnd = GetFocus() And HasFocus = tloc Then   _
      ' This line has the focus
         LSet rc2 = rc
         rc2.left = m_BorderStyle
         rc2.right = ScaleWidth - VScroll1.Width - m_BorderStyle
         di = DrawFocusRect(hdc, rc2)
         di = InflateRect(rc2, -1, -1)
         Line (rc2.left, rc2.top)-(rc2.right - 1, rc2.bottom - 1), highlight, BF
      Else
         Line (m_BorderStyle, rc.top)-(ScaleWidth - VScroll1.Width - _
         m_BorderStyle, rc.bottom), highlight, BF
      End If
      oldcolor = SetTextColor(hdc, HighlightText)

   Else
      If VScroll1.hwnd = GetFocus() And HasFocus = tloc Then
         ' This line has the focus
         LSet rc2 = rc
         rc2.left = m_BorderStyle
         rc2.right = ScaleWidth - m_BorderStyle
         di = DrawFocusRect(hdc, rc2)
         di = InflateRect(rc2, -1, -1)
         Line (rc2.left, rc2.top)-(rc2.right - 1, rc2.bottom - 1), BackColor, BF
      Else
         Line (m_BorderStyle, rc.top)-(ScaleWidth - m_BorderStyle, rc.bottom), _
               BackColor, BF
      End If
   End If

   'Set usefont = UserControl.Font
   'oldfont = SelectObject(hdc, usefont.hFont)
   di = DrawText(hdc, txt, Len(txt), rc, DT_LEFT Or DT_SINGLELINE Or _
                 DT_NOPREFIX)
   'Call SelectObject(hdc, oldfont)
   If IsSelected(tloc) Then
      oldcolor = SetTextColor(hdc, oldcolor)
   End If

End Sub

It would be very inefficient for the control to display every entry in the listbox any time a change occurs. For example: when the list is scrolled one item up or down, it should be possible to just scroll the window contents and draw the one line that has just appeared. This feature is supported by this implementation. The lbInvalidateRange function is used to mark which entries in the listbox actually need to be drawn. 

'
' Invalidate a range of entries
'
Private Sub lbInvalidateRange(Optional ByVal lowval& = 0, Optional _
ByVal highval& = &H7FFFFFFF)
   Dim tval&
   Dim highest&
   If LowDrawRange = -1 And HighDrawRange = -1 Then
      LowDrawRange = &H7FFFFFFF
   End If
   If highval < lowval Then
      ' Swap if necessary to keep range in order
      tval = lowval
      lowval = highval
      highval = tval
   End If
   If lowval < LowDrawRange Then LowDrawRange = lowval
   If highval > HighDrawRange Then HighDrawRange = highval
   If LowDrawRange < CurrentTop Then LowDrawRange = CurrentTop
   highest = CurrentTop + TotalLines
   If HighDrawRange > highest Then HighDrawRange = highest

End Sub

When an entry is clicked, it may need to be redrawn if the selection state changed. This is handled by the LBMouseDown function as shown here. Note how it shifts the entry that has the focus as well. The function also captures mouse input. This will be described further in the LBMouseMove function. 

'
' Called this by the mouse down event for the control
'
Private Sub LBMouseDown(ByVal x&, ByVal Y&)
   Dim newClickLine&
   Dim li&
   li = SetCapture(hwnd)
   newClickLine = (Y - m_BorderStyle) \ PixelsPerLine + CurrentTop
   ' Listbox line did not change
   If HasFocus <> newClickLine Then
      HasFocus = newClickLine
      lbInvalidateRange HasFocus, HasFocus
   End If
   If IsSelected(newClickLine) And Not m_MultiSelect Then
       Exit Sub
   End If
   ClickLine = newClickLine
   LBSelect ClickLine
   LBDraw
End Sub

The LBScroll function handles the scrolling operation that was described earlier. It calculates how far the list needs to scroll and calls the ScrollWindow API function to scroll the contents of the window the correct amount. It then uses the lbInvalidateRange function to mark the lines that need to be drawn from scratch. This approach provides for very fast and smooth scrolling. 

'
' Call from the scroll event of the vertical scroll bar
'
Private Sub LBScroll()
   Dim howmuch&
   Dim newtop&
   Dim dl&
   Dim rc As RECT
   rc.left = m_BorderStyle
   rc.right = ScaleWidth - VScroll1.Width - m_BorderStyle
   rc.top = m_BorderStyle
   rc.bottom = ScaleHeight - m_BorderStyle
   newtop& = VScroll1.Value
   howmuch& = CurrentTop - newtop&
   If howmuch& = 0 Then
      Exit Sub
   End If
   If Abs(howmuch) >= TotalLines Then
      ' Set to redraw it all
      LowDrawRange = -1
      HighDrawRange = -1
      CurrentTop = newtop
      LBDraw
      Exit Sub
   End If
   CurrentTop = newtop
   dl& = ScrollWindowByNum(hwnd, 0, howmuch& * PixelsPerLine, rc, 0)
   ' Now invalidate
   If howmuch < 0 Then ' We scrolled up
       lbInvalidateRange newtop + TotalLines + howmuch, newtop + TotalLines
   Else
       lbInvalidateRange newtop, newtop + howmuch
   End If
   LBDraw

End Sub

The selection operation is quite straightforward. In single-selection mode, the first entry in the selected array specifies the entry currently selected. In multiple-selection mode, the Selected array is dynamically sized using the SetSelection function to contain a list of lines that are currently selected. 

'
' Select the specified entry
'
Private Sub LBSelect(ByVal tloc&)
   If m_MultiSelect Then
      SetSelection tloc, Not IsSelected(tloc)
      lbInvalidateRange
   Else
      lbInvalidateRange Selected(0), tloc
      Selected(0) = tloc
   End If
End Sub

The LBDraw function draws those lines that are currently marked as invalid. Its most interesting characteristic, however, is the border implementation. As you can see, it is quite easy to implement 3D effects using simple VB code. Remember this the next time you consider using an ActiveX control solely to provide a 3D appearance. The code approach is much more efficient in terms of memory and resources, and its performance is excellent. 

Private Sub LBDraw()
   Dim startline&, lastline&
   Dim x&
   Dim sw As Long
   Dim sh As Long
   sw = ScaleWidth
   sh = ScaleHeight

   If LowDrawRange = -1 And HighDrawRange = -1 Then
        startline& = CurrentTop
        lastline& = TotalLines + CurrentTop
   Else
        startline& = LowDrawRange
        lastline& = HighDrawRange
   End If
   For x& = startline& - 1 To lastline& + 1
      LBDrawLine x
   Next x&
   LowDrawRange = -1
   HighDrawRange = -1

   Select Case m_BorderStyle
      Case dw3d
         UserControl.Line (0, 0)-(sw, 0), Dark3D
         UserControl.Line (1, 1)-(sw, 1), DarkShadow
         UserControl.Line (0, 0)-(0, sh), Dark3D
         UserControl.Line (1, 1)-(1, sh), DarkShadow
         UserControl.Line (sw - 1, 0)-(sw - 1, sh), Light3D
         UserControl.Line (sw - 1, sh - 1)-(1, sh - 1), Light3D
         UserControl.Line (sw - 2, sh - 2)-(2, sh - 2), Dark3D
      Case dwSingle
         UserControl.Line (0, 0)-(sw, 0), 0
         UserControl.Line (0, 0)-(0, sh), 0
         UserControl.Line (sw - 1, 0)-(sw - 1, sh), 0
         UserControl.Line (sw - 1, sh - 1)-(1, sh - 1), 0
   End Select
End Sub

What happens when you click on an entry in a listbox and drag the mouse outside of the top or bottom border of the listbox. The listbox continues to scroll. The LBMouseMove uses an API trick to accomplish this. If a MouseMove event appears from a coordinate outside of the listbox, it checks to see if the location is above or below the control. If it is, the code first scrolls the listbox. Then it performs a DoEvents operation to allow the update to occur. A module level context variable named incontext is used to prevent reentrancy at this time. Thus, any other MouseMove events are ignored at this time. Next, the function uses the GetCursorPos and SetCursorPos to set the mouse pointer position to its current location. This does not move the mouse, but it does generate another MouseMove event, causing the scroll operation to repeat.

How can a MouseMove event appear for a point outside of the control? During the LBMouseDown function, the SetCapture API function was called to capture the mouse input. Under Win32, mouse capture is only guaranteed to remain in effect while the mouse button is held down, which is perfect for this application. The LBMouseUp function releases the capture using the ReleaseCapture API function. 

'
' Call this from the MouseMove event of the control
'
Private Sub LBMouseMove(ByVal Button%, ByVal x&, ByVal Y&)
    Dim pt As POINTAPI
    Dim dl&
    If InContext% Then Exit Sub
    If (Button And 1) = 0 Then Exit Sub
    If Y < 0 Or Y > ScaleHeight Then ' We be scrolling
        InContext% = True
        If Y < 0 Then
            If VScroll1.Value > 0 Then VScroll1.Value = VScroll1.Value - 1
        Else
            If VScroll1.Value < VScroll1.Max Then VScroll1.Value = _
            VScroll1.Value + 1
        End If
        DoEvents
        ' Force another mouse event so it will scroll again
        InContext% = False
        dl& = GetCursorPos(pt)
        dl& = SetCursorPos(pt.x, pt.Y)
        Exit Sub
    End If
    If Not m_MultiSelect Then LBMouseDown x, Y
End Sub

Private Sub LBMouseUp()
    Dim dl&
    dl& = ReleaseCapture()
End Sub

Private Property Get LBClickLine()
    LBClickLine = ClickLine
End Property


'
' Call this from the GotFocus event
'
Private Sub LBGotFocus()
   If m_MultiSelect Then
      lbInvalidateRange
   Else
      lbInvalidateRange Selected(0), Selected(0)
   End If
   LBDraw
End Sub

'
' Call this from the Change event of the scrollbar
'
Private Sub LBScrollChange()
    LBScroll
End Sub

'
' Call this from the control LostFocus event
'
Private Sub LBLostFocus()
   If m_MultiSelect Then
      lbInvalidateRange
   Else
      lbInvalidateRange Selected(0), Selected(0)
   End If
   LBDraw
End Sub


Private Sub PositionScrollBar()
   Dim slidescroll%
   If m_BorderStyle = dw3d Then slidescroll = 1
   VScroll1.Move ScaleWidth - (VScroll1.Width + slidescroll), _
   slidescroll, VScroll1.Width, ScaleHeight - m_BorderStyle
End Sub

Private Function IsSelected(ByVal location&) As Boolean
   Dim x&
   For x = 0 To UBound(Selected)
      If Selected(x) = location Then
         IsSelected = True
         Exit Function
      End If
   Next x
End Function

The SetSelection subroutine manages the selection array. This is one of the hacks that were described earlier and does not represent the most efficient way of handling this task. But it does the trick. 

Private Sub SetSelection(ByVal location&, ByVal newstate As Boolean)
   Dim x&
   Dim firstfree&
   firstfree = -1
   For x = 0 To UBound(Selected)
      If Selected(x) = location Then
         If Not newstate Then Selected(x) = -1
         Exit Sub
      End If
      If firstfree < 0 And Selected(x) = -1 Then firstfree = x
   Next x
   If newstate Then
      If firstfree >= 0 Then
         Selected(firstfree) = location
         Exit Sub
      End If
      ReDim Preserve Selected(UBound(Selected) + 1)
      Selected(UBound(Selected)) = location
   End If

End Sub


Private Sub CalculateValues()
   PixelsPerLine = UserControl.TextHeight("W") + 1
   TotalLines = (ScaleHeight - m_BorderStyle * 2) \ PixelsPerLine
End Sub

As you can see, the user-drawn approach does require substantially more work, but you gain a great deal of flexibility in the process. Before leaving this approach behind, there is one more example to look at that fixes the focus problem that exists with this implementation.

A Better User-Drawn Control

The ListCtlC.ctl example eliminates the problems relating to focus that result from having a visible constituent control. It turns out that Windows has built-in scrollbar support that is available to virtually every type of window. This scrollbar support can be turned on using API functions but requires subclassing to obtain the necessary messages. You can turn on these built-in scrollbars for the UserControl window as well. Doing so does not count as a visible constituent control. Thus the control itself will receive the focus.

Turning on scrollbars and managing the incoming messages turns out to be quite a bit of work, but the dwspyvb.dll component includes an object that does the work for you: the dwScrollBars object. It works with many types of windows including ActiveX control windows, forms, and picture controls. The object is declared and initialized as follows:

Private WithEvents VScroll As dwScrollBars

The object is initialized in the UserControl_Initialize event as follows:

Set VScroll = New dwScrollBars

The vertical scrollbar is turned on during the UserControl_Show event as follows: 

Private Sub UserControl_Show()
   If Ambient.UserMode Then
      VScroll.hwnd = UserControl.hwnd
      VScroll.ScrollBars = sbeVerticalScrollbar
   End If
End Sub

There is no need to display the scrollbar at design time.

The control itself now receives keyboard input, which is handled as follows: 

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
   FixNextScroll = VScroll.VValue
   LBArrow KeyCode
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
   If KeyAscii = vbKeySpace And m_MultiSelect Then
      LBSelect ClickLine
      lbInvalidateRange ClickLine, ClickLine
      Refresh
   End If
End Sub

The VScroll object properties and events are similar to those of the standard scrollbar control. The only difference is that each event or property name is prefixed with an H or V character indicating whether it belongs to the vertical or horizontal scrollbar. This control only uses the vertical scrollbar, but the object supports both, either individually or simultaneously. 

'------------------------------------------------------
'
'  VScroll1 Methods and Events
'
Private Sub VScroll_VChange()
   If FixNextScroll >= 0 Then
      If VScroll.VValue <> FixNextScroll Then
         VScroll.VValue = FixNextScroll
         Exit Sub
      End If
      FixNextScroll = -1
      Exit Sub
   End If
   Debug.Print "Change"
   LBScrollChange
End Sub

Private Sub VScroll_VScroll()
   LBScroll
End Sub

The remaining control functions are virtually identical except for the change from the VScroll1 control to VScroll object and the change in name to the scrolling property and event names.

This concludes our discussion of user-drawn controls and leaves us with one more approach to discuss: the fourth model of control creation, which is the window-based control.

A Custom Window-Based Control

The major limitation of constituent-based controls is that you cannot change the design properties of the constituent controls. This is because those properties are based on window styles that must be defined when the window is created. Visual Basic 5.0 does not provide a mechanism to destroy and recreate a control. But if you were to create your own window from scratch, you could destroy and re-create the window any time you wanted, including the container's design time and runtime. Of course, in doing so your control would take on a number of responsibilities:

But that really isn't as bad as it might sound, as you will soon see.

The ListCtlD sample control creates a standard listbox window and places it over the UserControl window for your control. The sample begins with a number of standard API declarations.

The WS and LBS prefixed constants describe the styles of the window. You can guess the meanings of most of them by their names. Detailed explanations can be found in any good API reference. Only a few of the styles shown here are actually used in this control. 

' CreateWindow list example
' Copyright (c) 1997, by Desaware Inc. All Rights Reserved

Option Explicit

Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_BORDER = &H800000
Private Const WS_GROUP = &H20000
Private Const WS_TABSTOP = &H10000
Private Const WS_VSCROLL = &H200000
Private Const WS_EX_APPWINDOW = &H40000
Private Const WS_EX_CLIENTEDGE = &H200&
Private Const WS_EX_CONTEXTHELP = &H400&
Private Const WS_EX_CONTROLPARENT = &H10000
Private Const WS_EX_LEFT = &H0&
Private Const WS_EX_LEFTSCROLLBAR = &H4000&
Private Const WS_EX_LTRREADING = &H0&
Private Const WS_EX_MDICHILD = &H40&
Private Const WS_EX_RIGHT = &H1000&
Private Const WS_EX_RIGHTSCROLLBAR = &H0&
Private Const WS_EX_RTLREADING = &H2000&
Private Const WS_EX_STATICEDGE = &H20000
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_EX_WINDOWEDGE = &H100&

' Listbox Styles
Private Const LBS_NOTIFY = &H1&
Private Const LBS_SORT = &H2&
Private Const LBS_NOREDRAW = &H4&
Private Const LBS_MULTIPLESEL = &H8&
Private Const LBS_OWNERDRAWFIXED = &H10&
Private Const LBS_OWNERDRAWVARIABLE = &H20&
Private Const LBS_HASSTRINGS = &H40&
Private Const LBS_USETABSTOPS = &H80&
Private Const LBS_NOINTEGRALHEIGHT = &H100&
Private Const LBS_MULTICOLUMN = &H200&
Private Const LBS_WANTKEYBOARDINPUT = &H400&
Private Const LBS_EXTENDEDSEL = &H800&
Private Const LBS_DISABLENOSCROLL = &H1000&
Private Const LBS_NODATA = &H2000&
Private Const LBS_NOSEL = &H4000&
Private Const LBS_STANDARD = (LBS_NOTIFY Or LBS_SORT Or WS_VSCROLL Or WS_BORDER)

Notification codes are types of WM_COMMAND messages that are sent from the window to the parent, in this case, the UserControl window. 

' Listbox Notification Codes
Private Const LBN_ERRSPACE = (-2)
Private Const LBN_SELCHANGE = 1
Private Const LBN_DBLCLK = 2
Private Const LBN_SELCANCEL = 3
Private Const LBN_SETFOCUS = 4
Private Const LBN_KILLFOCUS = 5

The LB_ prefixed messages are used to control the operation of the listbox window. Only a few of the commands shown here are actually implemented in this example. 

' Listbox messages
Private Const LB_ADDSTRING = &H180
Private Const LB_INSERTSTRING = &H181
Private Const LB_DELETESTRING = &H182
Private Const LB_SELITEMRANGEEX = &H183
Private Const LB_RESETCONTENT = &H184
Private Const LB_SETSEL = &H185
Private Const LB_SETCURSEL = &H186
Private Const LB_GETSEL = &H187
Private Const LB_GETCURSEL = &H188
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_GETCOUNT = &H18B
Private Const LB_SELECTSTRING = &H18C
Private Const LB_DIR = &H18D
Private Const LB_GETTOPINDEX = &H18E
Private Const LB_FINDSTRING = &H18F
Private Const LB_GETSELCOUNT = &H190
Private Const LB_GETSELITEMS = &H191
Private Const LB_SETTABSTOPS = &H192
Private Const LB_GETHORIZONTALEXTENT = &H193
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const LB_SETCOLUMNWIDTH = &H195
Private Const LB_ADDFILE = &H196
Private Const LB_SETTOPINDEX = &H197
Private Const LB_GETITEMRECT = &H198
Private Const LB_GETITEMDATA = &H199
Private Const LB_SETITEMDATA = &H19A
Private Const LB_SELITEMRANGE = &H19B
Private Const LB_SETANCHORINDEX = &H19C
Private Const LB_GETANCHORINDEX = &H19D
Private Const LB_SETCARETINDEX = &H19E
Private Const LB_GETCARETINDEX = &H19F
Private Const LB_SETITEMHEIGHT = &H1A0
Private Const LB_GETITEMHEIGHT = &H1A1
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_SETLOCALE = &H1A5
Private Const LB_GETLOCALE = &H1A6
Private Const LB_SETCOUNT = &H1A7
Private Const LB_MSGMAX = &H1A8
Private Const WM_CTLCOLORLISTBOX = &H134


Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_SETFONT = &H30

Private Const WHITE_BRUSH = 0
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long

Event Click()
Event DblClick()

This sample uses two objects from the dwSpyvb.dll component. The dwPrivateWindow class is used to manage the creation and use of private windows. The dwSubClass object you saw earlier is used to intercept the listbox window notifications. 

Dim WithEvents listwnd As dwPrivateWindow
Dim WithEvents cmdhook As dwSubClass

Private Const defClassName = "LISTBOX"

Private m_MultiSelect As Boolean
Private m_BorderStyle As Integer

Changing the MultiSelect and BorderStyle properties both require that the listbox window be destroyed and re-created, as you can see in their property procedures. 

Public Property Get MultiSelect() As Boolean
   MultiSelect = m_MultiSelect
End Property

Public Property Let MultiSelect(ByVal vNewValue As Boolean)
   m_MultiSelect = vNewValue
   PropertyChanged "MultiSelect"
   InitTheWindow  ' Change the appearance now!
End Property

Public Property Get BorderStyle() As dwBorderStyle
   BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal vNewValue As dwBorderStyle)
   If vNewValue > 2 or vNewValue < 0 Then
      Err.Raise 380
   End If
   m_BorderStyle = vNewValue
   PropertyChanged "BorderStyle"
   InitTheWindow
End Property


Public Property Get Font() As Font
   Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal vNewValue As Font)
   Set UserControl.Font = vNewValue
   PropertyChanged "Font"
   UpdateTheFont
End Property

When your control receives the focus, you must set the focus to the contained listbox window. This is necessary because a private window is not really a constituent control, so Visual Basic doesn't know that it should receive the focus when the control does. The SetFocus method you see here is a method of the dwPrivateWindow object that calls the API SetFocus command. 

'---------------------------------------------
'
'     UserControl events and properties
'
Private Sub UserControl_EnterFocus()
   listwnd.SetFocus
End Sub


Private Sub UserControl_Initialize()
   Set listwnd = New dwPrivateWindow
   Set cmdhook = New dwSubClass
End Sub

The InitWindow function is called when the control is initialized or loaded. 

Private Sub UserControl_InitProperties()
   ' Create the child window after properties are read
   InitTheWindow
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   ' Create the child window after properties are read
   m_MultiSelect = PropBag.ReadProperty("MultiSelect", False)
   m_BorderStyle = PropBag.ReadProperty("BorderStyle", False)
   Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
   InitTheWindow
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   Call PropBag.WriteProperty("MultiSelect", m_MultiSelect, False)
   Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, False)
   Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
End Sub

The following cleanup on termination is mostly a matter of good style. Both the dwPrivateWindow and dwSubClass objects know how to clean up after themselves when they are destroyed. 

Private Sub UserControl_Terminate()
   listwnd.DestroyWindow
   cmdhook.HwndParam = 0
   Set listwnd = Nothing
   Set cmdhook = Nothing
End Sub

You cannot obtain a font handle from the Font object directly, but the Font object implements an interface called IFont that allows you to retrieve the handle to the font. This can be sent to the listbox window using the WM_SETFONT message. 

'-------------------------------------
'
'     Functions used internally
'

Private Sub UpdateTheFont()
   Dim usefont As IFont
   Set usefont = UserControl.Font
   Call listwnd.SendMessageNumber(WM_SETFONT, usefont.hFont, 1)
End Sub

The GetListboxStyle function is a utility function that retrieves the correct window style to use for the given multiple-select and border settings. 

Private Function GetListboxStyle() As Long
   Dim LS As Long
   LS = WS_CHILD Or WS_TABSTOP Or WS_CLIPSIBLINGS Or WS_VISIBLE Or WS_VSCROLL
   LS = LS Or LBS_NOTIFY Or LBS_HASSTRINGS
   If m_MultiSelect Then LS = LS Or LBS_MULTIPLESEL Or LBS_EXTENDEDSEL
   If m_BorderStyle Then LS = LS Or WS_BORDER
   GetListboxStyle = LS
End Function

The InitTheWindow function creates the contained listbox window. The cmdhook object is set to subclass the user control window. It is set to detect command messages using the CommandMessage event, which breaks the WM_COMMAND message parameters into their individual components. It is also set to detect the WM_CTLCOLORLISTBOX message, which allows you to set the background color of the listbox. The listwnd CreateWindowEx method creates the new window. There is no need to destroy the previous window-that operation is handled automatically when you create the new one. 

Private Sub InitTheWindow()
   cmdhook.EnableCommandEvent = True
   cmdhook.HwndParam = UserControl.hwnd
   cmdhook.AddMessage WM_CTLCOLORLISTBOX
   Call listwnd.CreateWindowEx(0, defClassName, "", GetListboxStyle, _
         0, 0, ScaleWidth, ScaleHeight, hwnd, 0)
   If Not Ambient.UserMode Then AddItem Ambient.DisplayName
   UpdateTheFont
End Sub

WM_COMMAND messages from the listbox window are intercepted on their way to the UserControl window. The UserControl window receives WM_COMMAND messages from many sources, including other controls and menus. In this example, no other window exists, so the only source of WM_COMMAND messages is the listbox window. However, it is still good practice to double check. The messages are mapped directly into Control events. 

' Here is where command notifications come in
Private Sub cmdhook_CommandMessage(ByVal hwnd As Long, ByVal wID As Long, _
ByVal wNotifyCode As Long, ByVal hwndCtl As Long, retval As Long, nodef _
As Boolean)
   If hwndCtl <> listwnd.hwnd Then Exit Sub  ' It's not for the list box
   Select Case wNotifyCode
      Case LBN_SELCHANGE
         RaiseEvent Click
      Case LBN_DBLCLK
         RaiseEvent DblClick
   End Select
   ' Default result for notification messages
   nodef = True
   retval = 0
End Sub

Private Sub cmdhook_WndMessage(ByVal hwnd As Long, Msg As Long, wp As Long, lp As_
Long, retval As Long, nodef As Boolean)
   If lp <> listwnd.hwnd Then Exit Sub  ' It's not for the list box
   Select Case Msg
      Case WM_CTLCOLORLISTBOX
         retval = GetStockObject(WHITE_BRUSH)   ' Return white brush
         nodef = True   ' Block default processing
   End Select
End Sub

The cmdhook_WndMessage function intercepts the WM_CTLCOLORLISTBOX message and returns a handle to a white brush to force the background color of the list box to white. You could, of course, set this value based on a BackColor property should you choose to implement one. The nodef event parameter must be set to True to prevent default processing for the message, which would set the color to the default background color for listboxes.

Adding and removing a string is a simple matter of sending the appropriate message. 

' Add a string to the list box
Public Sub AddItem(item As String, Optional Index As Long = -1)
   Dim res&
   If Index = -1 Then
      res = listwnd.SendMessageString(LB_ADDSTRING, 0, item)
      ' TODO - on fail raise error
   Else
      res = listwnd.SendMessageString(LB_INSERTSTRING, Index, item)
      ' TODO - on fail raise error
   End If
End Sub

' Remove a string from the list box
Public Sub RemoveItem(ByVal Index As Long)
   If Index < 0 Or Index > ListCount Then
      Err.Raise 380
   Else
      Call listwnd.SendMessageNumber(LB_DELETESTRING, Index, 0)
   End If
End Sub

Public Property Get ListCount() As Long
   ListCount = listwnd.SendMessageNumber(LB_GETCOUNT, 0, 0)
End Property

What about the messages that are being sent to the private listbox window? Unless you specify otherwise, they are automatically sent by the listwnd object to the default window function-the class window function that implements the listbox functionality. You can override the handling of these messages if you wish, but in this case there is no need to do so. The nice thing about this approach is that if you break or pause your application, window messages will continue to receive their default processing, thus allowing Windows message processing to continue in a normal manner. This is because default message processing is built into the dwPrivateWindow object. You can override it if you choose, but if your code is stopped, the default message processing will always take place. 

Private Sub listwnd_WndMessage(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long, retval As Long, nodef As Boolean)
   Select Case Msg
      ' We can handle window messages here
   End Select
End Sub

The approach shown here can become much more useful when using a technique called owner drawn listboxes. In this case the standard listbox window does not actually draw the list box. Instead, it sends a message to the parent window telling it which line to draw and whether it is selected or has the focus. It also provides a device context that is ready for drawing.

You may feel you need to be a bit of a Windows expert to take full advantage of the private window approach. There is some truth to this. But it just serves to stress the point I made at the beginning of this chapter: that you can take advantage of virtually all of the control development techniques that are possible using other languages when writing controls using Visual Basic. However, to do so you must learn those techniques and handle them at the same level-the API and windows messaging level. Visual Basic may be the easiest way to create advanced controls, but this is empathetically not the same as saying that it is easy.

This concludes our coverage of developing ActiveX controls using Visual Basic. We'll return to the subject again in Part 4, where we cover the related topics of versioning and licensing. Meanwhile, let's turn our attention to a closely related component type: the ActiveX document.