# ftsItem_content

c0Title: Close All MDI Children Simply
c1Code:
This code allows you to close all the MDI child forms in an MDI form at once. First, create a menu item in the MDI form, then paste in this code:

 
Private Sub mnuCloseAll_Click()
     Screen.MousePointer = vbHourglass
     Do While Not (Me.ActiveForm Is Nothing)
          Unload Me.ActiveForm
     Loop
     Screen.MousePointer = vbDefault
End Sub


Once the user clicks on that menu item, the MDI child forms will close.

�Tai Choo Tack, Port Klang, Selangor, Malaysia


c0Title: Create Captionless MDI Forms
c1Code:
Sometimes you might want an MDI form without any captions or buttons, such as in a game or acting as a background parent object.
You can create a captionless MDI form easily with a few API calls.

The system menu keys, such as Alt-F4 and Alt-Space, still work, even though the system menu icon is invisible. If you don�t want the system menu to pop up, then uncomment the Xor WS_SYSMENU line below. Note that Alt-F4 still works, however:

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 

Private Const GWL_STYLE = (-16) 
Private Const WS_CAPTION = &HC00000 
Private Const WS_SYSMENU = &H80000 

Private Sub MDIForm_Load() 
    Dim lStyle As Long 
    lStyle = GetWindowLong(Me.hWnd, GWL_STYLE) 
    lStyle = lStyle Xor WS_CAPTION ' Uncomment to remove system menu access:
    ' lStyle = lStyle Xor WS_SYSMENU
    Call SetWindowLong (Me.hWnd, GWL_STYLE, lStyle)
    ' *** Required by VB4 32, not VB5 or later:
    ' Form1.Show
    ' Unload Form1
End Sub


If you�re still using VB4, you must load a child form before the caption bar will disappear. If you don�t want to show a child loaded initially, then load and immediately unload a small MDI child form in the MDI�s Form_Load( ) event.

�Matt Hart, Tulsa, Oklahoma


c0Title: Create Close-All Add-In
c1Code:
I often open up many windows in a VB project when I�m doing a search and/or replace in code. On large projects, it becomes cumbersome to close all those windows one by one. Here�s a quick add-in you can create to close those windows for you. Start a new project and select the Add-In type. Paste this code into the frmAddIn that�s created for you:

Private Sub Form_Load()
   Dim w As Window

   For Each w In VBInstance.Windows
       ' close either code or form design windows 
       ' that are visible
       If (w.Type = vbext_wt_CodeWindow Or w.Type = vbext_wt_Designer) And w.Visible Then
           w.Close
           End If
       Next

       Unload Me
End Sub


Highlight the Connect class in the Object Browser, right-click on it, and edit the Description property to change the name and description of the add-in. Also, search the template code and replace �My Add-In� with whatever you decided to call it. After building the DLL, you can add it from the Add-In Manager and close all those pesky windows in no time.

�Rick Lalliss, received by e-mail


c0Title: Create Non-Rectangular Forms In VB
c1Code:
Ever want to create a non-rectanguar Form in Visual Basic? Well you might be surprised to know that it's actually very easy. It can actually be any shape that may be constructed using Win32 region functions. Using the SetWindowRgn Win32 function from within VB is so simple, but the results are unbelievable.

Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long


The following example code in the Form Load sub, creates a round Form as seen above.

Dim lReturn As Long
Me.Show
lReturn = SetWindowRgn(hWnd, CreateEllipticRgn(50, 50, 200, 200), True)


Code Found On The Microsoft Newsgroup.
Written By: AlMoataz B. Ahmed


c0Title: Custom Form Shapes
c1Code:
The clock applet that comes with Microsoft Plus! has an interesting feature: Its window is round instead of rectangular. Surprisingly, giving your form an odd shape is easy. Add this code to a new form to give your window the shape of the Microsoft Windows logo:

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

Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

Private Const RGN_AND = 1

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private Function GetTextRgn() As Long
    Dim hRgn1 As Long, hRgn2 As Long
    Dim rct As RECT
    'Create a path for the window's shape
    BeginPath hdc
    TextOut hdc, 10, 10, Chr$(255), 1
    EndPath hdc
    '... Convert the path to a region...
    hRgn1 = PathToRegion(hdc)
    GetRgnBox hRgn1, rct
    hRgn2 = CreateRectRgnIndirect(rct)
    CombineRgn hRgn2, hRgn2, hRgn1, RGN_AND
    'Return the region handle
    DeleteObject hRgn1
    GetTextRgn = hRgn2
End Function

Private Sub Form_DblClick()
    'Need to be able to close the form
    Unload Me
End Sub

Private Sub Form_Load()
    Dim hRgn As Long
    Me.Font.Name = "Wingdings"
    Me.Font.Size = 200
    hRgn = GetTextRgn()
    SetWindowRgn hwnd, hRgn, 1
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Give us some way to move the form
    ReleaseCapture
    SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
End Sub


While this is a sort of novelty shape for a form, you can give a form any shape you want, provided you have a way to create the shape of the region. Look at the various region-related API calls to find methods of creating regions other than using font characters.

�Ben Baird, Twin Falls, Idaho


c0Title: Default Button Prevents Firing of Validate Event
c1Code:
VB6 introduced the Validate event as a way to handle field-level validation without using LostFocus, which doesn�t always fire in the order you would expect. The Validate event is a great idea, but doesn�t work correctly on forms with a Default button. If the user presses Enter instead of clicking on the default button, neither the Validate event nor the LostFocus event fire. If the user clicks on the button with the mouse, however, both events fire correctly. You can get around the LostFocus problem by entering this code in the first part of the button�s Click event:

Private Sub cmdOK_Click()
    If Not Me.ActiveControl Is cmdOK Then
        cmdOK.SetFocus
        DoEvents
    End If
    ' [remainder of click processing]
End Sub


With this code, if the user presses Enter to pick the default, the focus changes to the default button before any other Click event code executes, causing whichever control currently has focus to fire its LostFocus event. You would expect the Validate event would also fire that in this situation, but it doesn�t. So, for forms with default buttons, LostFocus is the better way to handle field-level validation.

�Gordon Lawson, Billings, Montana


c0Title: Disabling All Controls on a Form
c1Code:
If you ever need to disable all the controls on a form you can loop through the control array and set each Enabled property to False with this code:

Sub cmdArray_Click ()
    Dim iLoop As Integer
    For iLoop = 0 To Me.Controls.Count - 1
        Me.Controls(iLoop).Enabled = False
    Next iLoop
End Sub


An alternatively is to set the Enabled property of the form to False, which effectively disables the entire form:

Me.Enabled = False


There is a side effect to the second method, however: because you can�t use the control menu from the form, there is no way to close the form. You�ll need to have another form unload this disabled form.

�Paul D. Sherriff/Visual Basic Power Guides


c0Title: Preventing a User from Switching to Another Application
c1Code:
When developing an application in Visual Basic�, you may need to perform a task that should not be interrupted. This article explains how to use the Windows� application programming interface (API) SetSysModalWindow and LockInput functions to disable task-switching.

Preventing a User from Switching to Another Application

The Windows� application programming interface (API) SetSysModalWindow function can be used to prevent a user from switching to a different Windows-based application while your program is executing. The ALT+TAB, CTRL+ESC, ALT+F4, and ALT+ESC keystroke combinations will not bring up the Task Manager or any other application�these keystrokes will simply be ignored. For a discussion of the SetSysModalWindow function, see "Additional References" below.

In addition, the LockInput function can be used to force all input to your Visual Basic� application only. No other application will receive any mouse or keyboard data. The Declare statement for the LockInput function is as follows (note that it must be typed as a single line of code):

Declare Function LockInput Lib "User" (ByVal hReserved As Integer, ByVal 
   hwndInput As Integer, ByVal fLock As Integer) As Integer


The LockInput function requires three arguments:
hReserved	An integer value that must be set to a value of zero.
hwndInput	An integer value containing the window's handle. This is the window that will receive all input.
fLock	An integer value set to TRUE (nonzero) to lock input or FALSE (zero) to unlock input.

When your program is terminated, you must use the LockInput function to restore input to other Windows-based programs. In addition, you must destroy the system modal window; otherwise the user will not be able to switch to any other Windows-based applications and will have to reboot the computer system.

Example Program
The program below shows how you can prevent a user from switching to another Windows-based application while your program is executing.

Create a new project in Visual Basic. Form1 is created by default.
Set the following properties for Form1:

ClipControls = False
ControlBox = false
MaxButton = False
MinButton = False


Add the following Dim and Declare statements to the General Declarations section of Form1 (note that each Declare statement must be typed as a single line of code):

Declare Function GetActiveWindow Lib "User" () As Integer
Declare Function SetFocusAPI Lib "User" Alias "SetFocus" (ByVal Hwnd As Integer) As Integer
Declare Function SetSysModalWindow Lib "User" (ByVal Hwnd As Integer) As Integer
Declare Function LockInput Lib "User" (ByVal hReserved As Integer, ByVal hwndInput As Integer, ByVal fLock As Integer) As Integer
Dim TopHwnd As Integer


Add the following code to the Form_Load event for Form1:

Sub Form_Load()
 
  Dim X As Integer
   
  Show
  DoEvents
  TopHwnd = GetActiveWindow()
   
  X = SetFocusAPI(TopHwnd)
  X = SetSysModalWindow(TopHwnd)
  X = LockInput(0, TopHwnd, 1)
End Sub


Add the following code to the Form_Unload event for Form1:

Sub Form_Unload(Cancel As Integer)
  X = LockInput(0, TopHwnd, 0)
End Sub


Add a Command Button control to Form1. Command1 is created by default. Set its Caption property to "Quit".
Add the following code to the Click event for Command1:

Sub Command1_Click()
   X = LockInput(0, TopHwnd, 0)
   End
End Sub


Additional References: Knowledge Base Q72674. "How to Create a System-Modal Program/Window in Visual Basic." (Development Library, Knowledge Base and Bug Lists)


c0Title: Display Forms Within A Form
c1Code:
Did you ever want to display Forms, sub Forms within a Form without having to have a MDI Parent and Child Forms? Well it's actually very easy. You could use this technique to show information from other forms or even create a Wizard type form.

Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long


Just place the following code in the Form_Load event of any "child" form.

SetParent(Me.hWnd, Form1.hWnd)


Just one thing to remember... make sure you unload the child Forms before unloading the Form that they are on.

Tip Submitted By: David McCarter


c0Title: Display Taskbar Icons for Borderless Forms
c1Code:
When you create a borderless form in VB (BorderStyle = 0) and make it visible to the taskbar (ShowInTaskbar = True), only the form�s caption shows and the form�s icon is invisible. To display the icon, you must add a system menu to the form by modifying the style. This also gives you the ability to right-click on the taskbar button and see a standard system menu, but the items in it won�t work unless you subclass the form and handle the system menu Click events yourself.

 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000


Add this code to the Form_Load event:

Dim lStyle As Long
lStyle = GetWindowLong(hWnd, GWL_STYLE) Or WS_SYSMENU
SetWindowLong hWnd, GWL_STYLE, lStyle


�Matt Hart, Tulsa, Oklahoma


c0Title: Find Form Size
c1Code:
It�s often useful to know the space occupied by a form�s caption or menu bars�for example, for positioning or resizing a form. VB doesn�t give direct access to this information, but a quick call to one of the Windows API functions does the job. Add these declarations to the General section of a form. Or add them to a separate module, in which case you make the declarations Public:

 
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CYCAPTION = 4
Private Const SM_CYMENU = 15
 
' menubar height in pixels
MenuHeight = GetSystemMetrics(SM_CYMENU)
' caption bar height in pixels
CaptionHeight = GetSystemMetrics(SM_CYCAPTION)


Note that these height values are in pixels, so you multiply them by Screen.TwipsPerPixelY to convert the value to twips. Search MSDN online or your own SDK docs for GetSystemMetrics to see the hundred or so other useful values this single API function can return.

�John Cullen, Pedroucos, Portugal


c0Title: Convert Color to Grayscale
c1Code:
Whether you�re printing on a grayscale printer, changing a color picture to grayscale, or just trying to decide whether white or black is a better contrast over an arbitrary background color, you need to know how �bright� some color is. This function returns a number between 0 (black) and 255 (white) for any Long color value you send it. It uses the standard algorithm found in everything from color TVs to black-and-white laser printers:

Public Function GrayScale (ByVal Colr As Long) As Long
	' Takes a long integer color value,
	' returns an equivalent grayscale value
	' between 0 and 255
	Dim R As Long, G As Long, B As Long
	' Break up long color into r, g, b
	R = Colr Mod 256
	Colr = Colr \ 256
	G = Colr Mod 256
	Colr = Colr \ 256
	B = Colr Mod 256
	' Find equivalent grayscale value
	GrayScale = (77 * R + 150 * G + 28 * B) / 255 End Function


�Jim Deutch, Syracuse, New York


c0Title: Adding Bitmaps to Menus
c1Code:
This tip explains how to add bitmap pictures to menu items.

Declarations

Add the following code to the declarations section of a module:

Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, _ ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, _ ByVal hBitmapChecked As Long) As Long

Public Const MF_BITMAP = &H4&

Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Declare Function GetMenuItemCount Lib "user32" _ (ByVal hMenu As Long) As Long
Declare Function GetMenuItemInfo Lib "user32" _ Alias "GetMenuItemInfoA" (ByVal hMenu As Long, _ ByVal un As Long, ByVal b As Boolean, _ lpMenuItemInfo As MENUITEMINFO) As Boolean

Public Const MIIM_ID = &H2
Public Const MIIM_TYPE = &H10
Public Const MFT_STRING = &H0&


Code

a.. Add one form to the project.
b.. Add a picturebox (Autosize = True) with a bitmap (not an icon!!!), max. 13X13
c.. Add a commandbutton with following code:

Private Sub Command1_Click()

'Get the menuhandle of your app
hMenu& = GetMenu(Form1.hwnd)

'Get the handle of the first submenu (Hello) 
hSubMenu& = GetSubMenu(hMenu&, 0)

'Get the menuId of the first entry (Bitmap) 
hID& = GetMenuItemID(hSubMenu&, 0)

'Add the bitmap

SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, _ Picture1.Picture, _ Picture1.Picture 'You can add two bitmaps to a menuentry 'One for the checked and one for the unchecked 'state.

End Sub


a.. Run the Project and click the button.
Tip by John Percival


c0Title: Calculate The Angle Between Two Lines
c1Code:
In graphical applications, you often need to know the angle be-tween two lines. You can move their intersection point to the origin easily, so all you need to do is choose a point on each line and find the angle between a line from the origin to that point and the x-axis. The angle between the lines is the difference. The arctangent of y/x is the mathematical function you need to find these angles, but VB's Atn( ) function only returns angles between -PI/2 and PI/2 (-90 to +90 degrees). You lose half the circle! And it fails completely if x = 0 (divide by zero error!). Many languages provide an Atn2( ) function that extends Atn( ) to the entire circle, taking the x and y arguments separately to avoid the divide error. Here�s a straightforward VB function that treats all possible cases separately:

Function Atn2(ByVal x As Double, ByVal y _ As Double) As Double 
    Dim theta As Double 
    Const pi As Double = 3.14159265359 

    If x <> 0 Then 
        theta = Atn(y / x) 
        If x < 0 Then 
            theta = theta + pi 
        End If 
    Else 
        If y < 0 Then 
            theta = 3 * pi / 2 ' 90 deg 
        Else 
            theta = pi / 2 ' 270 deg 
        End If 
    End If
    Atn2 = theta
End Function


�Jim Deutch, Syracuse, New York


c0Title: Anti-Aliasing Bitmap Resize
c2File: ShrinkBitmap.zip
c1Code:
VB allows you to shrink an image using PaintPicture. This, however doesn't anti-alias the image, like a paint program would, producing jagged results. This is a small DLL that can be easily called from VB, based off a sample available online, that anti-alaises the image.

The library itself, and a small sample VB project are included in the archive. 


c0Title: Creating Disabled or Etched Icons
c1Code:
Here�s how to create an etched or disabled icon using an icon editor:

   1. Change all filler color to light gray.
   2. Change the outline to dark gray (usually from black).
   3. Change every dark gray pixel to white if the pixel to its south east is light gray.

�Craig Goren


c0Title: Draw Arrowheads on Lines
c1Code:
If you�ve ever wanted to draw a flowchart, diagram, or clock face, you�ve probably wanted to put arrowheads on some of your lines.
This is easy enough if the lines are all vertical or horizontal, but it�s tough to do in the general case without the insight that line directions are easily expressed in polar coordinates. This code transforms x,y-space into r,theta-space and back to determine the endpoints of the arrowhead lines:

Public Type PointAPI
    X As Long
    Y As Long
End Type

Public Sub DrawArrow(startpt As PointAPI, endpt As PointAPI, canvas As Object, colr As Long, Size As Long) 
    Dim x3 As Long, x4 As Long 
    Dim y3 As Long, y4 As Long 
    Dim xs As Long, ys As Long 
    Dim theta As Double 'arrow direction 
    Const pi = 3.14159 

    ' Polar coords centered on EndPt:
    xs = endpt.X - startpt.X
    ys = endpt.Y - startpt.Y

    ' This is an embedded atan2() function:
    If xs <> 0 Then
        theta = Atn(ys / xs)
        If xs < 0 Then
            theta = theta + pi
        End If
    Else
        If ys < 0 Then
            theta = 3 * pi / 2 '90
        Else
            theta = pi / 2 '270
        End If
    End If

    ' Rotate direction
    theta = theta - 0.8 * pi

    'Find end of one side of arrow:
    x3 = Size * Cos(theta) + endpt.X
    y3 = Size * Sin(theta) + endpt.Y

    ' Rotate other way for other arrow line
    theta = theta + 1.6 * pi
    x4 = Size * Cos(theta) + endpt.X
    y4 = Size * Sin(theta) + endpt.Y

    ' Draw the lines
    canvas.Line (startpt.X, startpt.Y) - (endpt.X, endpt.Y), colr
    canvas.Line (endpt.X, endpt.Y)-(x3, y3), colr canvas.Line (endpt.X, endpt.Y)-(x4, y4), colr 
End Sub


All units are those used by the drawing canvas�a form, picture box, or user control.

�Jim Deutch, Syracuse, New York


c0Title: Cool Commands for Your Help Menu
c1Code:
Most Windows applications include the following commands in the help menu:

Contents
Search For Help On...
How To Use Help

Although VB doesn�t provide direct support for these commands, they can easily be added to your VB applications by accessing the Windows API directly. The required declarations are listed here and should appear in one of your application�s BAS files:

'Function declaration
Declare Function WinHelp Lib "User" (ByVal hWnd As Integer, ByVal lpHelpFile As String, ByVal wCommand As Integer, ByVal dwData As Any) As Integer
'Global constants 
Global Const HELP_QUIT = 2 
Global Const HELP_INDEX = 3 
Global Const HELP_HELPONHELP = 4 
Global Const HELP_PARTIALKEY = &H105 


Add the new menu items and name them mnuHelpContents, mnuHelpSearch and mnuHelpHowToUse, respectively. The handlers for each of these commands should look like this (Change the first argument to WinHelp (Form1.hWnd) to reference the main form in your application and set App.HelpFile to your application�s help file when your application starts):

'Contents command
Sub mnuHelpContents_Click ()
    Dim i As Integer
    i = WinHelp(Form1.hWnd, App.HelpFile, HELP_INDEX, 0&) 
End Sub

'Search For Help On... command
Sub mnuHelpSearch_Click ()
    Dim i As Integer
    i = WinHelp(Form1.hWnd, App.HelpFile, HELP_PARTIALKEY, "") 
End Sub

'How To Use Help command
Sub mnuHelpHowToUse_Click ()
    Dim i As Integer
    i = WinHelp(Form1.hWnd, App.HelpFile, HELP_HELPONHELP, 0&) 
End Sub 


To make sure Windows Help unloads when your application terminates, place this code in your main form�s Unload event:

'Unload WINHELP.EXE
Sub Form_Unload (Cancel As Integer)
    Dim i As Integer
    i = WinHelp(frmMain.hWnd, App.HelpFile, HELP_QUIT, 0&) 
End Sub 


�Jonathan Wood


c0Title: Enhance Development With Registry Edits
c1Code:
Here are a couple useful Registry edits to enhance your day-to-day Visual Basic development. Save these Registry lines to a text file with a REG extension, then double-click on the file to merge it with your Registry.

Right-click on DLL register/unregister (make sure RegSvr32.exe is on your path):

REGEDIT4
[HKEY_CLASSES_ROOT\dllfile\Shell\Register\command]
@="RegSvr32 \"%1\""
[HKEY_CLASSES_ROOT\dllfile\Shell\Unregister\command]
@="RegSvr32 /u \"%1\""


Right-click on OCX register/unregister:

REGEDIT4
[HKEY_CLASSES_ROOT\.ocx]
@="ocxfile"
[HKEY_CLASSES_ROOT\ocxfile]
@=�OCX�
[HKEY_CLASSES_ROOT\ocxfile\shell\Register\command]
@="RegSvr32 \"%1\""
[HKEY_CLASSES_ROOT\ocxfile\shell\Unregister\command]
@="RegSvr32 /u \"%1\""


Right-click on OLEView to open a DLL or OCX in the OLE Viewer utility (edit paths appropriately):

REGEDIT4
[HKEY_CLASSES_ROOT\dllfile\Shell\OleView\command]
@="c:\\Visual Studio\\Common\\Tools\\oleview.exe \"%1\"" 
[HKEY_CLASSES_ROOT\ocxfile\Shell\OleView\command]
@="c:\\Visual Studio\\Common\\Tools\\oleview.exe \"%1\"" 


These shell extensions work for previous versions of VB as well; simply change the commands and/or paths appropriately. Editor�s Note: As with all Registry edits, be sure you either have a current backup or can live with the consequences.

�Richard Hundhausen, Boise, Idaho


c0Title: Enforce Case With Enums
c1Code:
Enumerated constants are great, but they have a quirk that�s a bit obnoxious: They don�t retain their capitalization in the Integrated Development Environment (IDE), which a lot of folks use to provide visual feedback that they haven�t misspelled the constant name.

You can fool the IDE into retaining the capitalization by also declaring the Enums as public variables and surrounding the declarations with #If False...#End If compiler directives so they won�t be compiled:

Public Enum MyEnum
	EnumOne=1
	EnumTwo
	EnumThree
End Enum

#If False Then
	Public EnumOne
	Public EnumTwo
	Public EnumThree
#End If


�Barry Garvin, Georgetown, Massachusetts


c0Title: Auto-Indent Existing Code
c1Code:
This function re-indents code passed to it, based on where blocks of code should be. I find this very useful when I'm trying to follow someone else's code that doesn't use tabs (or uses them oddly). Note: This code uses the clsStringCollection class, it's available under the Strings->Split on my sample code page (attached).

Option Explicit

Private Const TAB_SIZE = 4

Public Function IndentCode(sCode As String) As String

    Dim sc As clsStringCollection
    Set sc = New clsStringCollection
    sc.SplitInto sCode, vbNewLine
    
    Dim nCurLine As Long
    Dim nCurTab As Long
    Dim sLine As String
    Dim vItem As Variant
    Dim bEscapeEOL As Boolean
    Dim nCount As Long
    Dim nEOLTab As Long
    Dim vLine As Variant
    Dim sOut As String
    
    Dim colIncrease As Collection
    Dim colDecrease As Collection
    Dim colInAll As Collection
    Dim colDeAll As Collection
    Set colIncrease = New Collection
    Set colDecrease = New Collection
    Set colInAll = New Collection
    Set colDeAll = New Collection
    
    colIncrease.Add "If "
    colIncrease.Add "With "
    colIncrease.Add "Select Case "
    colIncrease.Add "Select Case "
    colIncrease.Add "While"
    colIncrease.Add "Do"
    colIncrease.Add "Private Sub "
    colIncrease.Add "Private Function "
    colIncrease.Add "Private Property "
    colIncrease.Add "Public Sub "
    colIncrease.Add "Public Function "
    colIncrease.Add "Public Property "
    colIncrease.Add "Sub "
    colIncrease.Add "Function "
    colIncrease.Add "Property "
    colIncrease.Add "For "
    colIncrease.Add "Type "
    colIncrease.Add "Public Type "
    colIncrease.Add "Private Type "
    
    colDecrease.Add "End If"
    colDecrease.Add "End Select"
    colDecrease.Add "End Select"
    colDecrease.Add "End With"
    colDecrease.Add "Wend"
    colDecrease.Add "Loop"
    colDecrease.Add "End Sub"
    colDecrease.Add "End Function"
    colDecrease.Add "End Property"
    colDecrease.Add "Next"
    colDecrease.Add "End Type"
    
    colDecrease.Add "Else"
    colDecrease.Add "Case"
    colIncrease.Add "Else"
    colIncrease.Add "Case"
    
    nCurTab = 0
    bEscapeEOL = False
    nCount = sc.Count
    
    For Each vLine In sc
        sLine = Trim(vLine)
        
        For Each vItem In colDecrease
            If LCase(Mid(sLine, 1, Len(vItem))) = LCase(vItem) Then
                nCurTab = nCurTab - TAB_SIZE
            End If
        Next
        
        If nCurTab < 0 Then
            nCurTab = 0
            sLine = sLine & " ' TAB COUNT ERROR"
        End If
        
        
        sOut = sOut & Space(nCurTab) & sLine & vbNewLine
        
        If Right(sLine, 2) = " _" Then
            If Not bEscapeEOL Then
                nEOLTab = InStr(1, Trim(sLine), " ")
                If nEOLTab < 3 Then
                    nEOLTab = 3
                End If
                nCurTab = nCurTab + nEOLTab
                bEscapeEOL = True
            End If
        Else
            If bEscapeEOL Then
                nCurTab = nCurTab - nEOLTab
                bEscapeEOL = False
            End If
        End If
        
        For Each vItem In colIncrease
            If LCase(Mid(sLine, 1, Len(vItem))) = LCase(vItem) Then
                nCurTab = nCurTab + TAB_SIZE
            End If
        Next
        
    Next
    
    IndentCode = sOut
    
End Function


Sample Usage:

        
Dim sTemp As String
sTemp = IndentCode(Clipboard.GetText)
    
Clipboard.Clear
Clipboard.SetText sTemp


c0Title: Drag Files Into Project Window
c1Code:
Creating a new project in VB6 (and earlier versions) has always been a pain when you have a large library of modules to add in. You can do it a module at a time�the Add File dialog doesn�t support multiple select�or you can edit the VBP file manually. Either way is difficult.
But try this: Open VB, then open an Explorer window. Find and highlight several BAS, FRM, or CLS modules, and simply drag them into the Project window in VB. Voil�! No more single-select night-mares. All the files are added to the project instantly.

�Darin Higgins, Fort Worth, Texas


c0Title: Dump Resource Strings to Text File
c1Code:
The Resource Editor add-in is useful to add resource file text entries, but it doesn�t provide any facility to print the current contents. You can add this routine to a project module to generate the desired documentation:

Public Sub DumpResStrings(Start As Long, Finish As Long, FileSpec As String) 
    Dim hFile As Long 
    Dim sText As String 
    Dim i As Long 

    On Error Resume Next 

    hFile = FreeFile 
    Open FileSpec For Output As #hFile 

    For i = Start To Finish 
        sText = LoadResString(i) 
        If Err.Number = 0 Then 
            Print #hFile, i & vbTab & sText 
        Else 
            Err.Clear 
        End If 
    Next i 

    Close #hFile 
End Sub 


To extract the desired range of resource file numbers into a text file, open the Immediate window and call DumpResStrings, passing appropriate parameters:

call dumpresstrings(1,2999,"resdat.txt")


When resource file documentation is complete, set the function to Private for standard application development.

�Trevor Marr, Chessington, Surrey, England


c0Title: Detect Change of Windows Locale
c1Code:
While designing multilingual applications, I had to make them respond when a user changes the Windows locale setting�for example, by loading a different language�s captions or text. Al-though it�s possible to intercept a Windows message generated and broadcast when the Windows locale changes, this requires subclassing, which is not always desirable.

Another solution is to create an ActiveX control responsible for detecting the change and raising an event. The UserControl object raises a private AmbientChanged event when any of the AmbientProperties change, and it passes the changed property�s name to the event. The Ambient object provides a LocaleID property, which you can pass to the client with a public custom LocaleChanged event. Your ActiveX control might have no visual interface, pretty much like a Timer control, and you can place it on any form required to react to a change of Windows locale. You can load the new language�s elements subsequently from a database or a resource file:

Public Event LocaleChanged(ByVal LocaleID As Long)

Private Sub UserControl_AmbientChanged(PropertyName As String)
	If PropertyName = "LocaleID" Then RaiseEvent LocaleChanged(Ambient.LocaleID) 
End Sub


�Brian Hunter, Brooklyn, New York


c0Title: Create World Wide Web Hyperlinks In Your Program
c1Code:
Many programs now (including Visual Basic) has buttons or menu items that opens up a browser program and goes to the specified page. This is really easy to do.

Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Dim X
X = ShellExecute(hwnd, "Open", "http://www.microsoft.com/vbasic", &O0, &O0, SW_NORMAL)


Tip Submitted By: Ryan Martinsen


c0Title: Populate List Items from a Database
c1Code:
With a normal listbox control you have to loop through each item in the database and add it using the .AddItem method. Data binding only is used to highlight the field value for the current database record (if it's already in the list).

The DBList control adds the RowSource, ListField, and BoundColumn properties to populate the list from a DAO database recordset. Just add the component: Microsoft Data Bound List Controls. For ADO, use the Microsoft DataList Controls component.


c0Title: Create MailTo: URL
c1Code:
The MailToURL function creates a mailto: url that can be used to create a mail message, complete with a subject and body already intact. Take a look at the sample code for sample usage.

        
Public Function MailToURL(sAddy As String, sSubject As String, sBody As String)
    MailToURL = "mailto:" & URLEncode(sAddy) & "?subject=" & URLEncode(sSubject) & "&body=" & URLEncode(sBody)
End Function

Public Function URLEncode(sPlain As String) As String
    Dim i As Long

    For i = 1 To Len(sPlain)
        Select Case Asc(UCase(Mid(sPlain, i, 1)))
            Case Asc("A") To Asc("Z")
                URLEncode = URLEncode & Mid(sPlain, i, 1)
            Case Else
                URLEncode = URLEncode & "%" & Right("00" & Hex(Asc(Mid(sPlain, i, 1))), 2)
        End Select
    Next
End Function


Sample Usage:

        
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
   
Private Const SW_NORMAL = 1

Private Sub Form_Load()

    Dim sAddy As String
    Dim sSubject As String
    Dim sBody As String
    
    sAddy = "scott@scottandmichelle.net"
    sSubject = "Example Message"
    sBody = "This is just an example message" & vbNewLine & "Please disregard"

    ShellExecute 0, "open", MailToURL(sAddy, sSubject, sBody), "", "", SW_NORMAL
End Sub


c0Title: Clear a Masked Edit Box
c1Code:
To blank out the text in a masked edit box, make sure the string you assign uses underscores matching the mask. It�s difficult to maintain code when you have to change a mask; you have to find all the locations where you cleared the masked edit control in your code. To fix this problem, simply get rid of the mask, clear the contents, then restore the mask. Use this subroutine to clear the text of any masked edit box; just pass in the control:

Public Sub ClearMaskEdBox(oMaskEdBox As MaskEdBox)
     Dim sTemp As String
     With oMaskEdBox
          sTemp = .Mask
          .Mask = ""
          .Text = ""
          .Mask = sTemp
     End With
End Sub
 
'Sample Call:
Private Sub cmdClear_Click()
     ClearMaskEdBox MaskEdBox1
     MaskEdBox1.SetFocus
End Sub


�E.J. Osis, Sterling Heights, Michigan


c0Title: Converting Numbers To Strings
c1Code:
When numbers are converted to strings, a leading space is always reserved for the sign of number. If number is positive, the returned string contains a leading space and the plus sign is implied.

Use the Format function to convert numeric values you want formatted as dates, times, or currency or in other user-defined formats. Unlike Str, the Format function doesn't include a leading space for the sign of number.

Note: The Str function recognizes only the period (.) as a valid decimal separator. When different decimal separators may be used (for example, in international applications), use CStr to convert a number to a string.


c0Title: Compare Floating Point Values Using the Round Function
c1Code:
When you have to compare the results of floating point expressions, you can�t rely on the "=" operator due to the finite precision of Single or Double variables. To see this concept demonstrated, use this code:

Dim i As Integer, d As Double

For i = 1 To 10
    d = d + CDbl(0.1)
Next

MsgBox (d = 1)               ' displays "False"


To more easily compare two floating numbers, use the new VB6 Round function, which rounds a number to the desired number of decimal digits. For example, you can rewrite the previous test like this:

' the difference is less than 1E-12
MsgBox (Round(d, 12) = 1)  ' displays "True"


You can also use this method to check whether A and B variables contain values that match up to their 12th decimal digit:

If Round(A � B, 12) = 0 Then Print "Equal"


�Francesco Balena, Bari, Italy


c0Title: Calculate Finishing Time
c1Code:
If you ever wondered how some DOS applications, such as Norton Utilities, can calculate the estimated finishing time for a long process, here�s the formula:

Estimated = DateAdd("s", (DateDiff("s", StartTime, Time()) / PercentDone) * 100, StartTime)


To see how it works, add a form with three label controls and one command button. Add this code in the Command button Click event:

Private Sub Command1_Click()
	Dim Start As Double
	Dim i As Long
	Dim lMax As Long
	lMax = 300000
	Const fmt As String = "hh:mm:ss ampm"
	Start = InitEstTime()
	Label1.Caption = Format$(Start,fmt)
	For i = 1 To lMax
		Label2.Caption = Format$(UpdateEstTime(Start, (i / lMax) * 100), fmt)
		DoEvents
	Next i
	Label3.Caption = Format$(Time, fmt)
End Sub


Include these two functions:

Public Function UpdateEstTime(ByVal StartTime As Double, ByVal PercentDone As Single)
	' Avoid dividing by zero error
	If PercentDone <= 0 Then PercentDone = 0.000000001
	UpdateEstTime = DateAdd("s", (DateDiff("s", StartTime, Time()) / PercentDone) * 100, StartTime) 
End Function

Public Function InitEstTime() As Double
	InitEstTime = Time()
End Function


�Jacques Levy, Clearwater, Florida


c0Title: Compare two variables of a user-defined type (UDT) to see if they hold the same values
c1Code:
You can compare the structures one field at a time but that requires a bunch of If statements.
This program includes a function that uses the CopyMemory API function to copy the two structures into byte arrays. It then compares the bytes.

Robert Heinig points out that this will not work if the UDTs contain strings or object references. In that case, this method would compare only the addresses of the objects not the objects themselves. Other cases such as variants (where some bytes are irrelevant so it's conceivable that VB would not initialize them in the same way every time) may also cause trouble. For these reasons, you should use this technique with some care. Robert also rounds the size of the UDTs up to the next multiple of 4 bytes so he can make the comparison using 4-byte integers instead of bytes. That will make things faster for large UDTs.

Option Explicit

' This doesn't work if the Type contains variable
' length strings.
Private Type MyType
    StringValue As String * 20
    IntegerValue As Integer
    IntegerArray(1 To 10) As Integer
End Type

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

' Return True if these structures contain the same data.
Private Function MyTypesTheSame(a As MyType, b As MyType) As Boolean
Dim i As Integer
Dim a_bytes() As Byte
Dim b_bytes() As Byte
Dim different As Boolean

    ' Copy the data into arrays of bytes.
    ReDim a_bytes(1 To Len(a))
    ReDim b_bytes(1 To Len(b))

    CopyMemory a_bytes(1), a, Len(a)
    CopyMemory b_bytes(1), b, Len(b)

    ' Compare the bytes.
    For i = 1 To Len(a)
        If a_bytes(i) <> b_bytes(i) Then
            MyTypesTheSame = False
            Exit Function
        End If
    Next i

    MyTypesTheSame = True
End Function

Private Sub Command1_Click()
Dim a As MyType
Dim b As MyType
Dim i As Integer

    With b
        .IntegerValue = 123
        .StringValue = "Here's a string"
        For i = 1 To 10
            .IntegerArray(i) = i * i
        Next i
    End With

    With a
        .IntegerValue = 123
        .StringValue = "Here's a string"
        For i = 1 To 10
            .IntegerArray(i) = i * i
        Next i
    End With

    If MyTypesTheSame(a, b) Then
        MsgBox "The same", , "Match"
    Else
        MsgBox "Different", , "Match"
    End If

    b.StringValue = "Oops"
    If MyTypesTheSame(a, b) Then
        MsgBox "The same", , "Different String"
    Else
        MsgBox "Different", , "Different String"
    End If

    b.StringValue = "Here's a string"
    If MyTypesTheSame(a, b) Then
        MsgBox "The same", , "Match"
    Else
        MsgBox "Different", , "Match"
    End If

    b.IntegerValue = 321
    If MyTypesTheSame(a, b) Then
        MsgBox "The same", , "Different Integer"
    Else
        MsgBox "Different", , "Different Integer"
    End If

    b.IntegerValue = 123
    b.IntegerArray(1) = 2
    If MyTypesTheSame(a, b) Then
        MsgBox "The same", , "Different Integer Array"
    Else
        MsgBox "Different", , "Different Integer Array"
    End If
End Sub


c0Title: Convert a Decimal Number to Base N
c1Code:
Here�s a function that converts a decimal number (base 10) to another base number system. Each digit position corresponds to a power of N, where N is a number between 2 and 36. In other words, if a number system�s base is N, then N digits are used to write numbers in that system. For example, the base 2 number system (binary) uses the digits 0 and 1, while the base 20 system uses digits 0 through K.

The ConvertDecToBaseN function accepts a double-value decimal number and a byte-value representing the base number between 2 and 36. By default, the base value used is 16 (hexadecimal). The decimal number is converted to a positive number if it�s negative. This function is useful for representing large numbers as strings, using fewer digit positions. I developed it to help reduce the footprint of several large numbers used in constructing a 16-character unique string ID. (Creating a complementary function to convert a base N number back into a decimal would be a great exercise.)

Public Function ConvertDecToBaseN(ByVal dValue As Double, Optional ByVal byBase As Byte = 16) As String

    Const BASENUMBERS As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

    Dim sResult As String
    Dim dRemainder As Double

    On Error GoTo ErrorHandler

    sResult = ""

    If (byBase < 2) Or (byBase > 36) Then GoTo Done

    dValue = Abs(dValue)

    Do
        dRemainder = dValue - (byBase * Int((dValue / byBase)))
        sResult = Mid$(BASENUMBERS, dRemainder + 1, 1) & sResult
        dValue = Int(dValue / byBase)
    Loop While (dValue > 0)

Done:

    ConvertDecToBaseN = sResult
    Exit Function

ErrorHandler:

    Err.Raise Err.Number, "ConvertDecToBaseN", Err.Description

End Function


Sample usage:

ConvertDecToBaseN(999999999999#, 36)

'Returns 'CRE66I9R


�Peter Rodriguez, received by e-mail


c0Title: Crc - Returns a 16-bit CRC value for a data block
c1Code:
Private Function CRC(Buffer() As Byte, Optional InputCrc As Long) As Long 
'===========================================================================
'   Crc - Returns a 16-bit CRC value for a data block.
'
'   Refer to CRC-CCITT compute-on-the-fly implementatations for more info.
'===========================================================================

  Dim Bit       As Long
  Dim i         As Long
  Dim j         As Long

  On Error GoTo ErrHandler

  ' Derive from a prior CRC value if supplied.
  CRC = InputCrc
  
  ' Loop thru entire buffer computing the CRC
  For i = LBound(Buffer) To UBound(Buffer)

    ' Loop thru each of the 8 bits
    For j = 0 To 7
    
      Bit = ((CRC And &H8000&) = &H8000&) _
        Xor ((Buffer(i) And (2 ^ j)) = 2 ^ j)

      CRC = ((CRC And &H7FFF&) * 2)
      
      If Bit <> 0 Then
        CRC = CRC Xor &H1021&
      End If
  
    Next j

  Next i

  Exit Function
  Resume
ErrHandler:
  Debug.Assert 0

End Function


c0Title: Automatic Selection Of Text
c1Code:
Applies To TextBox, ComboBox

When using edit boxes, it is often useful to generate automatic selection of text for your users when the control gets focus. This makes it easy to overwrite the text. You can do this easily by adding a couple of lines to the GotFocus event procedure:
Sub Text1_GotFocus ()
     Text1.SelStart = 0
     Text1.SelLength = 65535
End Sub

Notice that the length value for SelLength is 65535, the maximum length allowed in a Text Box. This forces Visual Basic to use the actual length of the text as the SelLength.


c0Title: Automatically Display the Contents of a Combo Box
c1Code:

If you�ve ever wanted to make a combo box automatically display its contents, you know it is next to impossible with VB�s SendKey command. The correct way to do this is with a SendMessage API call:
Global Const WM_USER = 1024
Global Const CB_SHOWDROPDOWN = (WM_USER + 15) 
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long 

Dim nRet as Long 
nRet = SendMessage(combo1.hWnd, CB_SHOWDROPDOWN, 1, ByVal 0&) 

Sending this message will cause the target combo box to display its list of entries just as if you had clicked the down-arrow button on the combo box control.

�Deepak Agrawal


c0Title: Find a string in a ListBox or ComboBox control
c1Code:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const CB_FINDSTRING = &H14C
Private Const LB_FINDSTRING = &H18F
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const CB_FINDSTRINGEXACT = &H158

' Find a string in a ListBox or ComboBox control
' Returns the index of the match, or -1 if not found.
'
' The third argument is the index *after* which to start the sFind (first item
' if omitted).
' If the fourth argument is True it searches for an exact match (default)
'
Function ListFindString(oControl As Control, _
                        ByVal sFind As String, _
                        Optional nStartIndex As Long = -1, _
                        Optional bExactMatch As Boolean = True) As Long
    Dim nMsg As Long
    
    If TypeOf oControl Is ListBox Then
        nMsg = IIf(bExactMatch, LB_FINDSTRINGEXACT, LB_FINDSTRING)
    ElseIf TypeOf oControl Is ComboBox Then
        nMsg = IIf(bExactMatch, CB_FINDSTRINGEXACT, CB_FINDSTRING)
    Else
        Exit Function
    End If
    
    ListFindString = SendMessage(oControl.hWnd, nMsg, nStartIndex, ByVal sFind)
End Function


c0Title: Check if you're running in the IDE or a compiled EXE
c1Code:
'IsCompiled - Identifies if code is executing under the development
'environment or from a precompiled project.
Public Function IsCompiled() As Boolean
    On Error GoTo ExitLabel
    ' Produce a divide by zero error if running from code.
    Debug.Print 1 / 0
    IsCompiled = True
ExitLabel:
End Function


c0Title: Compact a path string to fit in a text object
c1Code:
Private Declare Function PathCompactPath Lib "shlwapi.dll" Alias "PathCompactPathA" (ByVal hDC As Long, ByVal lpszPath As String, ByVal dx As Long) As Long

'Shorten a path\filename to fit in a text display and return it '
'Arguments:  Width  The text object's width in twips (e.g. Text1.Width)
'            hDC    The parent form's device context handle (e.g. Me.hDC)
'
Function CompactPath(ByVal Path As String, ByVal Width As Long, ByVal hDC As Long) As String
    Const Margin = 100
    Dim NullPos As Long
    
    PathCompactPath hDC, Path, (Width - Margin) / Screen.TwipsPerPixelX
    NullPos = InStr(Path, Chr$(0))
    If NullPos > 0 Then
        Path = Left$(Path, NullPos - 1)
    End If
    CompactPath = Path
End Function


c0Title: Add paths together (e.g. Path & Filename), inserting a backslash if necessary
c1Code:
'Concatenates a string onto a path, inserting a backslash if necessary
Function PathAdd(sPath1, sPath2) As String
    
    If Right$(sPath1, 1) <> "\" Then sPath1 = sPath1 & "\"
    PathAdd = sPath1 & sPath2

End Function


c0Title: ShellExecute - Open a file in the associated application
c1Code:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpszOp As String, ByVal lpszFile As String, ByVal lpszParams As String, ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Const SW_SHOWNORMAL = 1

'Open the specified file with the associated application
Public Function ShellExec(sFile As String, Optional nMode As Long = SW_SHOWNORMAL) As Long
    Dim hDC As Long

    hDC = GetDesktopWindow()
    ShellExec = ShellExecute(hDC, "Open", sFile, "", "C:\", SW_SHOWNORMAL)
End Function



c0Title: Get the Min or Max value from a list of values
c1Code:
'Returns the minimum value from the list of arguments
Public Function Min(ParamArray vList() As Variant) As Variant
    Dim nItem As Long
    Dim vMin As Variant
    
    vMin = vList(LBound(vList))
    
    For nItem = LBound(vList) + 1 To UBound(vList)
        If vList(nItem) < vMin Then vMin = vList(nItem)
    Next
    
    Min = vMin
End Function


'Returns the maximum value from the list of arguments
Public Function Max(ParamArray vList() As Variant) As Variant
    Dim nItem As Long
    Dim vMax As Variant
    
    vMax = vList(LBound(vList))
    
    For nItem = LBound(vList) + 1 To UBound(vList)
        If vList(nItem) > vMax Then vMax = vList(nItem)
    Next
    
    Max = vMax
End Function



c0Title: Trim Null chars from the end of a string
c1Code:
'Trim null characters from the end of a string
'Used with API functions that return fixed length strings full of nulls
Public Function TrimNull(sValue As String) As String
    Dim nNullPos As Long
    nNullPos = InStr(sValue, vbNullChar)
    If nNullPos > 0 Then
        TrimNull = Left$(sValue, nNullPos - 1)
    Else
        TrimNull = sValue
    End If
End Function


c0Title: Convert null or empty string to 0 or another value
c1Code:
'Converts null and empty strings to the specified value
Public Function Nz(vValue As Variant, Optional vNullValue As Variant = 0) As Variant
    If IsNull(vValue) = True Then
        Nz = vNullValue
    Else
        If (TypeName(vValue) = "String") And (vValue = vbNullString) Then
            Nz = vNullValue
        Else
            Nz = vValue
        End If
    End If
End Function


c0Title: SQLite Database Class using SQLite3VB.dll
c2File: SQLite3VB.dll
c1Code:
Option Explicit
Option Compare Text

'Uses SqLite3VB.DLL from http://tannertech.net/sqlite3vb/

Private Declare Sub sqlite3_open Lib "SQLite3VB.dll" (ByVal Filename As String, ByRef handle As Long)
Private Declare Sub sqlite3_close Lib "SQLite3VB.dll" (ByVal DB_Handle As Long)
Private Declare Function sqlite3_last_insert_rowid Lib "SQLite3VB.dll" (ByVal DB_Handle As Long) As Long
Private Declare Function sqlite3_changes Lib "SQLite3VB.dll" (ByVal DB_Handle As Long) As Long
Private Declare Function sqlite_get_table Lib "SQLite3VB.dll" (ByVal DB_Handle As Long, ByVal SQLString As String, ByRef ErrStr As String) As Variant()
Private Declare Function sqlite_libversion Lib "SQLite3VB.dll" () As String
Private Declare Function number_of_rows_from_last_call Lib "SQLite3VB.dll" () As Long

Private mhDB As Long
Private msErr As String
Private msFileName As String

Public Event PercentDone(ByVal rPercent As Single, ByRef bCancel As Boolean)


'Get the SQLite library version
Public Function Version() As String
    Version = sqlite_libversion()
End Function

'Open an existing database or create a new one if it doesn't exist
'Returns TRUE if successful
Public Function OpenFile(ByVal sFile As String) As Boolean
    If mhDB > 0 Then CloseFile
    If InStr(sFile, "\") = 0 Then sFile = sFile & "\" & App.Path
    sqlite3_open sFile, mhDB
    msFileName = sFile
    OpenFile = (mhDB <> 0)
End Function

'Close the database that's currently open
Public Function CloseFile()
    If mhDB > 0 Then
        sqlite3_close mhDB
        mhDB = 0
        msErr = vbNullString
        msFileName = vbNullString
    End If
End Function

'Execute an SQL query. Any result table is written to vData as a variant array. Row 0 contains
'the field names. Any error message is written to sError. Returns the number of rows affected
Public Function Exec(ByRef sSQL As String, Optional ByRef vData As Variant, Optional ByRef sError As String) As Long
    If mhDB <> 0 Then
        vData = sqlite_get_table(mhDB, sSQL, sError)
        Exec = number_of_rows_from_last_call
'        Debug.Assert Len(sError) = 0   'Watch for query errors
    End If
End Function

'Database filename currently open
'Returns "" if no file is open
Public Property Get Filename() As String
    Filename = msFileName
End Property

'Returns TRUE if a database is currently open
Public Property Get IsOpen() As Boolean
    IsOpen = (mhDB <> 0)
End Property

'Error string from the last SQL query
Public Property Get LastError() As String
    LastError = msErr
End Property

'The rowid of the most recent successful INSERT into the database. If no successful INSERTs have ever
'occurred on that database connection, zero is returned.
Public Property Get LastInsertRowID() As Long
    If mhDB <> 0 Then
        LastInsertRowID = sqlite3_last_insert_rowid(mhDB)
    End If
End Property

'The number of database rows that were changed or inserted or deleted by the most recently completed SQL
'statement. Only changes that are directly specified by the INSERT, UPDATE, or DELETE statement are counted.
'Auxiliary changes caused by triggers are not counted.
Public Property Get Changes() As Long
    If mhDB <> 0 Then
        Changes = sqlite3_changes(mhDB)
    End If
End Property

'Return the value of a field that may be over 16,000 characters long. sField may contain an expression
'The value is retrieved in chunks because returning over 16,000 chars at once crashes SQLiteVB.dll
Public Function GetLargeField(sTable As String, sField As String, ParamArray vFieldValueList() As Variant) As String
    Const cChunkSize = 16000    'vbsqlite.dll will crash if a query returns more bytes than this
    Dim nStartByte As Long
    Dim vData As Variant
    Dim sWhere As String
    Dim oValue As CString
    Dim sValue As String
    Dim nField As Long
    Dim nBytes As Long
    Dim nChunkBytes As Long
    Dim bCancel As Boolean
    
    Set oValue = New CString
    
    For nField = 0 To UBound(vFieldValueList) - 1 Step 2
    
        If VarType(vFieldValueList(nField + 1)) = vbString Then
            'Replace single quotes with 2 single quotes and put the entire value in single quotes
            sValue = "'" & Replace(vFieldValueList(nField + 1), "'", "''") & "'"
        Else    'Numeric value
            sValue = vFieldValueList(nField + 1)
        End If
        
        sWhere = sWhere & vFieldValueList(nField) & " = " & sValue & " AND "
    Next
        
    'Remove last ' AND '
    sWhere = Left(sWhere, Len(sWhere) - 5)

    
    Exec "SELECT Length(" & sField & ") FROM " & sTable & " WHERE " & sWhere, vData
    If IsValidArray(vData) = False Then Exit Function
    
    nBytes = vData(1, 0)
    oValue.SetBufferSize nBytes
    
    For nStartByte = 1 To nBytes Step cChunkSize
        
        RaiseEvent PercentDone(nStartByte / nBytes * 100, bCancel)
        If bCancel = True Then GoTo Finish
        
        If nStartByte + cChunkSize > nBytes Then
            nChunkBytes = nBytes - nStartByte + 1
        Else
            nChunkBytes = cChunkSize
        End If
        
        Exec "SELECT Substr(" & sField & ", " & nStartByte & ", " & nChunkBytes & ") " & _
             "FROM " & sTable & " WHERE " & sWhere & ";", vData
             
        oValue.Append vData(1, 0)
    Next
    
    GetLargeField = oValue.Value
    
Finish:
    Set oValue = Nothing
End Function

'Returns the value of the specified field where the list of fields and values exist
'Update 1/25/09 Added brackets around return Field name
Public Function LookupField(sTable As String, sField As String, ParamArray vFieldValueList() As Variant) As String
            
    Dim sQuery As String
    Dim vValues As Variant
    Dim nField As Long
    Dim sValue As String
    Dim sWhere As String
    Dim vList As Variant
    Dim nRows As Long
    
    For nField = 0 To UBound(vFieldValueList) - 1 Step 2
    
        If VarType(vFieldValueList(nField + 1)) = vbString Then
            'Replace single quotes with 2 single quotes and put the entire value in single quotes
            sValue = "'" & Replace(vFieldValueList(nField + 1), "'", "''") & "'"
        Else    'Numeric value
            sValue = vFieldValueList(nField + 1)
        End If
        
        sWhere = sWhere & "[" & vFieldValueList(nField) & "]=" & sValue & " AND "
        
    Next
        
    'Remove last ' AND '
    sWhere = Left(sWhere, Len(sWhere) - 5)
    
    sQuery = "SELECT [" & sField & "] FROM [" & sTable & "] WHERE " & sWhere
    nRows = Exec(sQuery, vValues)
            
    If IsValidArray(vValues) Then
        LookupField = Nz(vValues(1, GetFieldNo(vValues, sField)))
    Else
        LookupField = vbNullString
    End If
End Function


'Returns the value of the specified field where the list of fields and values exist
'If the record doesn't exist, it's created
'Update 1/25/09 Added brackets around return Field name
Public Function LookupCreate(sTable As String, sField As String, ParamArray vFieldValueList() As Variant) As String
    Dim sQuery As String
    Dim vValues As Variant
    Dim nField As Long
    Dim sValue As String
    Dim sWhere As String
    Dim vList() As Variant
    Dim nRows As Long
    
    For nField = 0 To UBound(vFieldValueList) - 1 Step 2
    
        If VarType(vFieldValueList(nField + 1)) = vbString Then
            'Replace single quotes with 2 single quotes and put the entire value in single quotes
            sValue = "'" & Replace(vFieldValueList(nField + 1), "'", "''") & "'"
        Else    'Numeric value
            sValue = vFieldValueList(nField + 1)
        End If
        
        sWhere = sWhere & "[" & vFieldValueList(nField) & "]=" & sValue & " AND "
        
    Next
        
    'Remove last ' AND '
    sWhere = Left(sWhere, Len(sWhere) - 5)
    
    sQuery = "SELECT [" & sField & "] FROM [" & sTable & "] WHERE " & sWhere
    nRows = Exec(sQuery, vValues)
            
    If nRows = 0 Then
        vList = vFieldValueList
        AddRecord sTable, vList
        Exec sQuery, vValues
    End If
            
    If IsValidArray(vValues) Then
        LookupCreate = Nz(vValues(1, GetFieldNo(vValues, sField)))
    Else
        LookupCreate = vbNullString
    End If

End Function


Public Function GetFieldNo(vData As Variant, sField As String) As Long
    Const cFieldRow = 0
    Dim nField As Long
    
    If IsValidArray(vData) = True Then
        For nField = LBound(vData, 2) To UBound(vData, 2)
            If vData(cFieldRow, nField) = sField Then
                GetFieldNo = nField
                Exit Function
            End If
        Next
    End If
    GetFieldNo = -1
End Function


'Insert a new record into the specified table
'vFieldValueList should be fieldname1, value1, fieldname2, value2, etc.
'Modified 1/25/09 Added brackets around table name
'         2/15/09 Added return of error
Public Function AddRecord(sTable As String, ParamArray vFieldValueList() As Variant) As String

    Dim sQuery As String
    Dim nField As Long
    Dim sFields As String
    Dim sValues As String
    Dim sValue As String
    Dim sError As String
    Dim vArray As Variant
    
    'If an array variable was passed instead of a parameter list, copy it from the first
    'element of vFieldValueList
    vArray = vFieldValueList
    
    If IsValidArray(vArray(0)) Then
        vArray = vFieldValueList(0)
    End If
    
    For nField = 0 To UBound(vArray) Step 2
        sFields = sFields & "[" & vArray(nField) & "],"
        
        Select Case VarType(vArray(nField + 1))
        Case vbString
            sValues = sValues & "'" & Replace(vArray(nField + 1), "'", "''") & "',"
        Case vbDate
            sValues = sValues & "#" & vArray(nField + 1) & "#,"
        Case Else
            sValues = sValues & vArray(nField + 1) & ","
        End Select
    Next
        
    'Remove last comma
    sFields = Left(sFields, Len(sFields) - 1)
    sValues = Left(sValues, Len(sValues) - 1)
    
    sQuery = "INSERT INTO [" & sTable & "] (" & sFields & ") " & _
             "VALUES (" & sValues & ");"
             
    Exec sQuery, , sError
    AddRecord = sError
End Function


'Set multiple fields in the record with ID field matching the specified ID
'vFieldValueList should be fieldname1, value1, fieldname2, value2, etc.
Public Function SetFields(sTable As String, nRowID As Long, ParamArray vFieldValueList() As Variant)

    Dim sQuery As String
    Dim nField As Long
    Dim sFieldValueList As String
    
    For nField = 0 To UBound(vFieldValueList) Step 2
        sFieldValueList = sFieldValueList & "[" & vFieldValueList(nField) & "] = "
        
        If VarType(vFieldValueList(nField + 1)) = vbString Then
            sFieldValueList = sFieldValueList & "'" & Replace(vFieldValueList(nField + 1), "'", "''") & "', "
        Else
            sFieldValueList = sFieldValueList & vFieldValueList(nField + 1) & ", "
        End If
    Next
        
    'Remove last comma and space
    sFieldValueList = Left(sFieldValueList, Len(sFieldValueList) - 2)
    
    sQuery = "UPDATE " & sTable & " SET " & sFieldValueList & " WHERE ROWID = " & nRowID
             
    Exec sQuery

End Function


Private Sub Class_Terminate()
    If mhDB <> 0 Then CloseFile
End Sub



c0Title: High Performance String Builder Class
c1Code:
Note: Set Value() as the default item of the class

Option Explicit

'-----------------------------------------------------------
' CSTRING Class
' by Francesco Balena
'
' This class implements the string data type as an
' object type, and also supports most string functions
' It offers a few advantages on native VB strings:
'
' 1) chars are stored in ANSI format, use less memory
' 2) you decide how much memory is allocated to each
'    string, hence memory is not re-allocated with each
'    new assignment
' 3) since data is stored as ANSI, no internal conversion
'    is necessary when printing to file or passing to APIs
'    (in this case, pass the StrPtr Value as a pointer to chars)
'-----------------------------------------------------------
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal Bytes As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (dest As Any, ByVal numBytes As Long, ByVal fillByte As Integer)
 
' number of chars initially allocated to the string
Const DEFAULT_MAXLENGTH = 256
 
' this array holds the character
Private chars() As Byte
' the current lenght of the string
Private m_Len As Long
' the current UBound() of the array (accounts for ending null char)
Private m_MaxLength As Long
 
 
Private Sub Class_Initialize()
    ' create the chars() array
    SetBufferSize DEFAULT_MAXLENGTH
End Sub
 
' set the size of the internal buffer
' Use "mystr.SetBufferSize mystr.Length" to release unused memory
 
Sub SetBufferSize(ByVal newSize As Long, Optional clearIt As Boolean)
    m_MaxLength = newSize
    If m_Len Or clearIt = 0 Then
        ReDim Preserve chars(0 To m_MaxLength) As Byte
    Else
        ReDim chars(0 To m_MaxLength) As Byte
    End If
End Sub
 
' the current Value as a Unicode string
' this is the default item of the class, so you can use
' the object variable as if it were a string variable
 
Property Get Value() As String
    If m_Len > 0 Then
        Value = Space$(m_Len)
        CopyMemory ByVal Value, chars(0), m_Len
    End If
End Property
 
Property Let Value(NewValue As String)
    ' check that the private array is large enough
    m_Len = Len(NewValue)
    If m_Len > m_MaxLength Then
        SetBufferSize m_Len, True
    End If
    ' copy the characters into the private array
    If m_Len > 0 Then
        CopyMemory chars(0), ByVal NewValue, m_Len
    End If
End Property


Property Get ByteArray() As Byte()
    Dim nData() As Byte
    
    If m_Len > 0 Then
        ReDim nData(0 To m_Len - 1)
        CopyMemory nData(0), chars(0), m_Len
        ByteArray = nData
    End If
End Property
 
' the address of the first character (read-only)
 
Function StrPtr() As Long
    StrPtr = VarPtr(chars(0))
    ' append a null character to the internal string
    ' in case this will be passed to an external DLL
    chars(m_Len) = 0
End Function
 
' copy data from a memory address (Friend sub)
 
Friend Sub CopyData(ByVal SourceAddr As Long, ByVal NumChars As Long)
    ' raise error if new Length is invalid
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' check that the private array is large enough
    m_Len = NumChars
    If m_Len > m_MaxLength Then
        SetBufferSize m_Len, True
    End If
    ' copy the characters into the private array
    If m_Len > 0 Then
        CopyMemory chars(0), ByVal SourceAddr, m_Len
    End If
End Sub
 
' the current Length (can also be written to)
' ("Len" can't be used because it is a reserved word)
 
Property Get Length() As Long
    Length = m_Len
End Property
 
Property Let Length(ByVal NewValue As Long)
    ' raise error if new Length is invalid
    If NewValue < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' check that the private array is large enough
    If NewValue > m_MaxLength Then
        SetBufferSize NewValue, False
    End If
    ' fill with blanks if necessary
    If NewValue > m_Len Then
        FillMemory chars(m_Len), NewValue - m_Len, 32
    End If
    ' truncate or expand the string
    m_Len = NewValue
End Property
 
' clear the string
 
Sub Clear()
    m_Len = 0
End Sub
 
' create a copy of this CString object
 
Function Copy() As CString
    Set Copy = New CString
    Copy.CopyData StrPtr(), m_Len
End Function

Function FromHex(sHex As String)
    Dim nChar As Long
    Dim sHexByte As String
    Dim nHexChar As Long
    Dim nChars As Long
    
    nChars = Len(sHex) / 2
    Me.SetBufferSize nChars, clearIt:=True
    
    For nChar = 0 To nChars - 1
        nHexChar = (nChar * 2) + 1
        sHexByte = "&h" & VBA.Mid$(sHex, nHexChar, 2)
        chars(nChar) = CByte(sHexByte)
    Next
    
    m_Len = nChars
End Function

Function ToHex() As CString
    Dim oHex As CString
    Dim nChar As Long
    
    Set oHex = New CString
    
    oHex.SetBufferSize Me.Length * 2, clearIt:=True
    
    For nChar = 0 To m_Len - 1
        oHex.Append VBA.Right$("00" & Hex(chars(nChar)), 2)
    Next
       
    Set ToHex = oHex
End Function

' create a new CString object with leftmost characters

Property Get Left(ByVal NumChars As Long) As CString
    ' raise error if new Length is invalid
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' adjust length if necessary
    If NumChars > m_Len Then NumChars = m_Len
    ' create a new CString object
    Set Left = New CString
    Left.CopyData StrPtr(), NumChars
End Property
 
' replace leftmost characters using a given string
 
Property Let Left(ByVal NumChars As Long, NewValue As Variant)
    ' raise error if new parameter is invalid
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' can't copy more character than existing
    If NumChars > m_Len Then NumChars = m_Len
    ' can't copy more characters then the string's length
    If NumChars > Len(NewValue) Then NumChars = Len(NewValue)
    ' copy chars from the string into the local array
    If NumChars > 0 Then
        CopyMemory chars(0), ByVal CStr(NewValue), NumChars
    End If
End Property
 
' replace leftmost characters using a CString object
 
Property Set Left(ByVal NumChars As Long, NewValue As CString)
    ' raise error if new parameter is invalid
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' can't copy more character than existing
    If NumChars > m_Len Then NumChars = m_Len
    ' can't copy more characters then the string's length
    If NumChars > NewValue.Length Then NumChars = NewValue.Length
    ' copy chars from the string into the local array
    If NumChars > 0 Then
        CopyMemory chars(0), ByVal NewValue.StrPtr, NumChars
    End If
End Property
 
' create a new CString object with rightmost characters
 
Property Get Right(ByVal NumChars As Long) As CString
    ' raise error if new Length is invalid
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' adjust length if necessary
    If NumChars > m_Len Then NumChars = m_Len
    ' create a new CString object
    Set Right = New CString
    Right.CopyData VarPtr(chars(m_Len - NumChars)), NumChars
End Property
 
' replace rightmost characters using a given string
 
Property Let Right(ByVal NumChars As Long, NewValue As Variant)
    ' raise error if new parameter is invalid
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' can't copy more character than existing
    If NumChars > m_Len Then NumChars = m_Len
    ' can't copy more characters then the string's length
    If NumChars > Len(NewValue) Then NumChars = Len(NewValue)
    ' copy chars from the string into the local array
    If NumChars > 0 Then
        CopyMemory chars(m_Len - NumChars), ByVal CStr(NewValue), NumChars
    End If
End Property
 
' replace leftmost characters using a CString object
 
Property Set Right(ByVal NumChars As Long, NewValue As CString)
    ' raise error if new parameter is invalid
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length"
    ' can't copy more character than existing
    If NumChars > m_Len Then NumChars = m_Len
    ' can't copy more characters then the string's length
    If NumChars > NewValue.Length Then NumChars = NewValue.Length
    ' copy chars from the string into the local array
    If NumChars > 0 Then
        CopyMemory chars(m_Len - NumChars), ByVal NewValue.StrPtr, NumChars
    End If
End Property
 
' the Mid function
' one- and two-params syntaxes are supported
 
Property Get Mid(ByVal StartPos As Long, Optional NumChars As Variant) As CString
    Dim Bytes As Long
    ' raise error if the first parameter is invalid
    If StartPos < 0 Then Err.Raise 5, TypeName(Me), "Invalid starting position"
     
    If IsMissing(NumChars) Then
        ' if missing, use the remainder of the string
        Bytes = m_Len - StartPos + 1
    Else
        Bytes = NumChars
        If Bytes < 0 Then
            ' raise error if new parameter is invalid
            Err.Raise 5, TypeName(Me), "Invalid length"
        ElseIf StartPos + Bytes > m_Len Then
            ' truncate it if too long
            Bytes = m_Len - StartPos + 1
        End If
    End If
     
    ' create a new CString object
    Set Mid = New CString
    If StartPos <= m_Len Then
        Mid.CopyData VarPtr(chars(StartPos - 1)), Bytes
    End If
End Property
 
' replace a portion of the string with another string
' if the second parameter is omitted, the string is replaced up to its end
 
Property Let Mid(ByVal StartPos As Long, Optional NumChars As Variant, NewValue As Variant)
    Dim Bytes As Long
    ' raise error if the first parameter is invalid
    If StartPos < 0 Then Err.Raise 5, TypeName(Me), "Invalid starting position"
     
    If IsMissing(NumChars) Then
        ' if missing, use the remainder of the string
        Bytes = m_Len - StartPos + 1
    Else
        Bytes = NumChars
        If Bytes < 0 Then
            ' raise error if new parameter is invalid
            Err.Raise 5, TypeName(Me), "Invalid length"
        ElseIf StartPos + Bytes > m_Len Then
            ' truncate it if too long
            Bytes = m_Len - StartPos + 1
        End If
    End If
     
    If Bytes > Len(NewValue) Then Bytes = Len(NewValue)
    If Bytes > 0 Then
        CopyMemory chars(StartPos - 1), ByVal CStr(NewValue), Bytes
    End If
End Property
 
' replace a portion of the string with another CString object
' if the second parameter is omitted, the string is replaced up to its end
 
Property Set Mid(ByVal StartPos As Long, Optional NumChars As Variant, NewValue As CString)
    Dim Bytes As Long
    ' raise error if the first parameter is invalid
    If StartPos < 0 Then Err.Raise 5, TypeName(Me), "Invalid starting position"
     
    If IsMissing(NumChars) Then
        ' if missing, use the remainder of the string
        Bytes = m_Len - StartPos + 1
    Else
        Bytes = NumChars
        If Bytes < 0 Then
            ' raise error if new parameter is invalid
            Err.Raise 5, TypeName(Me), "Invalid length"
        ElseIf StartPos + Bytes > m_Len Then
            ' truncate it if too long
            Bytes = m_Len - StartPos + 1
        End If
    End If
     
    If Bytes > NewValue.Length Then Bytes = NewValue.Length
    If Bytes > 0 Then
        CopyMemory chars(StartPos - 1), ByVal NewValue.StrPtr, Bytes
    End If
     
End Property
 
' the ASC function, but returns -1 if the string is null
 
Function Asc() As Integer
    If m_Len > 0 Then
        Asc = chars(0)
    Else
        Asc = -1
    End If
End Function
 
' the ANSI code of a character, or -1 if out-of-range
 
Property Get Char(ByVal Index As Long) As Byte
    If Index > 0 Or Index <= m_Len Then
        Char = chars(Index - 1)
    Else
        Char = -1
    End If
End Property
 
Property Let Char(ByVal Index As Long, ByVal NewValue As Byte)
    ' no effect if index is out of valid range
    If Index > 0 Or Index <= m_Len Then
        chars(Index - 1) = NewValue
    End If
End Property
 
' find a substring
' only case-sensitive searches are supported
 
Function Instr(search As Variant, Optional StartPos As Long = 1) As Long
    Dim searchChars() As Byte
    Dim searchLen As Long
    Dim firstChar As Byte
    Dim i As Long, j As Long
     
    If TypeOf search Is CString Then
        ' if a CString object is passed, then make a local copy of it
        searchLen = search.Length
        ' if a null string, exit immediately
        If searchLen = 0 Then Instr = StartPos: Exit Function
        ReDim searchChars(0 To searchLen - 1) As Byte
        CopyMemory searchChars(0), ByVal search.StrPtr, searchLen
    Else
        ' if a string is passed, create the corresponding local array
        searchLen = Len(search)
        ' if a null string, exit immediately
        If searchLen = 0 Then Instr = StartPos: Exit Function
        searchChars() = StrConv(CStr(search), vbFromUnicode)
    End If
     
    ' cache the first character to be searched
    firstChar = searchChars(0)
     
    For i = StartPos - 1 To m_Len - searchLen
        If chars(i) = firstChar Then
            For j = 1 To searchLen - 1
                If chars(i + j) <> searchChars(j) Then Exit For
            Next
            If j = searchLen Then
                Instr = i + 1
                Exit For
            End If
        End If
    Next
 
End Function
 
' trasform the string to uppercase (returns Me)
 
Function UCase() As CString
    ' only characters in the range "a-z" are converted
    Dim i As Long, acode As Integer
    For i = 0 To m_Len - 1
        acode = chars(i)
        If acode >= 97 And acode <= 122 Then chars(i) = acode - 32
    Next
    Set UCase = Me
End Function
 
' trasform the string to lowercase (returns Me)
 
Function LCase() As CString
    ' only characters in the range "A-Z" are converted
    Dim i As Long, acode As Integer
    For i = 0 To m_Len - 1
        acode = chars(i)
        If acode >= 65 And acode <= 90 Then chars(i) = acode + 32
    Next
    Set LCase = Me
End Function
 
' reverse the string (returns Me)
 
Function ReverseStr() As CString
    Dim i As Long, acode As Byte
    For i = 0 To m_Len \ 2 - 1
        acode = chars(i)
        chars(i) = chars(m_Len - 1 - i)
        chars(m_Len - 1 - i) = acode
    Next
    Set ReverseStr = Me
End Function
 
' append one or more strings or CString objects (returns Me)
 
' append a string or a CString object (returns Me)
 
Function Append(arg As Variant) As CString
    Dim i As Long, j As Long
    Dim argObj As CString
    Dim newLength As Long
    Dim argLen As Long
     
    ' prepare the result
    Set Append = Me
     
    If TypeOf arg Is CString Then
        Set argObj = arg
        argLen = argObj.Length
    Else
        argLen = Len(arg)
    End If
     
    ' exit if null string
    If argLen = 0 Then Exit Function
     
    ' prepare the receiving buffer
    newLength = m_Len + argLen
    If newLength > m_MaxLength Then
        SetBufferSize newLength, False
    End If
     
    ' append the string
    If argObj Is Nothing Then
        ' this is a regular string argument
        CopyMemory chars(m_Len), ByVal CStr(arg), argLen
    Else
        ' this is a CString argument
        CopyMemory chars(m_Len), ByVal argObj.StrPtr, argLen
    End If
 
    ' update m_Len to point after the appended characters
    m_Len = newLength
 
End Function
 
' search a substring using Boyer & Moore algorithm
 
Function Find(search As String, Optional StartPos As Long = 1) As Long
    Dim Bytes() As Byte
    Dim i As Long, searchLen As Long, dist As Long, Index As Long
     
    ' save results from previous call
    Static saveSearch As String
    Static distance() As Integer
     
    ' it is better to have the substring in a byte array
    Bytes() = StrConv(search, vbFromUnicode)
    searchLen = Len(search)
    Index = StartPos + searchLen - 1
     
    ' build the distance table
    ' this is a 256-item array that, for each possible
    ' ANSI character, stores the "distance" of this char
    ' from the end of the search substring (if the char
    ' appears in the substring), or the length of the
    ' substring (if the character doesn't appear in the
    ' substring). Note that the last character in the
    ' substring corresponds to a null Value in the table
 
    ' this block is executed only if the search substring
    ' differs from the last call to this method
    If search <> saveSearch Then
        ReDim distance(0 To 255) As Integer
        For i = 0 To 255
            distance(i) = searchLen
        Next
        For i = 1 To searchLen
            distance(Bytes(i - 1)) = searchLen - i
        Next
        ' remember for next time
        saveSearch = search
    End If
     
    ' scan the string
    Do While Index <= m_Len
        ' retrieve the distance of this character from the
        ' end of the search substring
        dist = distance(chars(Index - 1))
        If dist Then
            ' increment Index of found distance - in fact there
            ' is no reason to scan all the characters in the middle
            Index = Index + dist
        Else
            ' this might be the last character in the string
            ' check if the substring is all there
            For i = 1 To searchLen - 1
                If chars(Index - searchLen - 1 + i) <> Bytes(i - 1) Then Exit For
            Next
             
            If i = searchLen Then
                ' we've found a match
                Find = Index - searchLen + 1
                Exit Function
            End If
            ' the search failed, skip this character and continue
            Index = Index + 1
        End If
    Loop
 
End Function
 
' write the string to a binary file
' optionally prefix it with string length
' Open destination For Binary Access Write As #x
Sub WriteToFile(ByVal FileNum As Integer, Optional PrefixLength As Boolean)
    If PrefixLength Then
        Put #FileNum, , m_Len
    End If
    ' temporarily shorten the internal buffer
    ' (we need this to use VB's Put statement)
    ReDim Preserve chars(0 To m_Len - 1) As Byte
    ' write all chars to file
    Put #FileNum, , chars()
    ' restore the buffer
    ReDim Preserve chars(0 To m_MaxLength) As Byte
End Sub
 
' read the string from a binary file
' if PrefixLength is True, uses stored length prefix, else
' uses current string length
 
Sub ReadFromFile(ByVal FileNum As Integer, Optional PrefixLength As Boolean)
    If PrefixLength Then
        ' read the string length
        Get #FileNum, , m_Len
        ' enlarge the buffer if necessary
        If m_Len > m_MaxLength Then
            SetBufferSize m_Len, True
        End If
    End If
    ' temporarily shorten the internal buffer
    ' (we need this to use VB's Put statement)
    ReDim Preserve chars(0 To m_Len) As Byte
    ' get chars from file
    Get #FileNum, , chars()
    ' restore the buffer
    ReDim Preserve chars(0 To m_MaxLength) As Byte
End Sub
 
' truncate the string to its first null char, returns new length
 
' this function is useful when dealing with API calls that return
' null-terminate strings in the buffer
 
Function TrimToNull() As Long
    Dim i As Long
    ' assume there is no null char
    m_Len = m_MaxLength
    ' scan the string searching for the first null character
    For i = 1 To m_MaxLength
        If chars(i) = 0 Then
            ' set new length and exit
            m_Len = i - 1
            Exit For
        End If
    Next
    ' new length is also the return Value
    TrimToNull = m_Len
End Function


c0Title: High Precision/Accuracy Timer
c1Code:
These functions record the elapsed time for some event with 1ms accuracy. timeGetTime can also be called in between to get the current time. If timeBeginPeriod(1) and TimeEndPeriod(1) aren't used, timeGetTime is only updated every 15.625 ms or more.

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private m_lT As Long

'Start timing some period with 1ms accuracy
Private Sub StartTiming()
   timeBeginPeriod 1 'This sets the update period of timeGetTime to 1 ms.
   m_lT = timeGetTime
End Sub

'Finish timing and return the elapsed time
Private Function EndTiming() As Long
   EndTiming = timeGetTime() - m_lT
   timeEndPeriod 1 'This restores the update period of timeGetTime to whatever it was when you started.
End Function


c0Title: Add Incremental Search to a Combo Box
c1Code:

VB4 32, VB5, VB6

As the user types into a drop-down combo box, he or she passes keystrokes to the ComboIncrementalSearch routine, which then searches the combo box�s data for the best match:

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const CB_FINDSTRING = &H14C

Private Sub Combo1_KeyPress(KeyAscii As Integer)
	Call ComboIncrementalSearch(Combo1, KeyAscii) 
End Sub

Public Sub ComboIncrementalSearch(cbo As ComboBox, KeyAscii As Integer)
	Static dTimerLast As Double
	Static sSearch As String
	Static hWndLast As Long
	Dim nRet As Long
	Const MAX_KEYPRESS_TIME = 0.5

	' Weed out characters that are not scanned
	If (KeyAscii < 32 Or KeyAscii > 127) Then Exit Sub
		If (Timer - dTimerLast) < MAX_KEYPRESS_TIME And hWndLast = cbo.hWnd Then
			sSearch = sSearch & Chr$(KeyAscii)
		Else
			sSearch = Chr$(KeyAscii)
			hWndLast = cbo.hWnd
		End If

		' Search the combo box
		nRet = SendMessage(cbo.hWnd, _
		CB_FINDSTRING, -1, ByVal sSearch)
		If nRet >= 0 Then
			cbo.ListIndex = nRet
	End If
	KeyAscii = 0
	dTimerLast = Timer
End Sub

�Michael Hill, Northridge, California


c0Title: Allow Only Programmatic Input to Combo
c1Code:

Database applications often need to forbid user input to combo boxes, which limits the user to a given set of choices. But just as often, these apps need to assign values to the Text property.
Setting a combo�s Style property to �2 - Dropdown list� accomplishes the first goal, but prevents the second, throwing an error if an assignment is made to the Text property.
The solution: Set the Style property to �0 - Dropdown combo� at design time, and eat all keystrokes in the combo�s KeyPress event (to prevent further processing of the keystrokes), allowing programmatic assignment to the Text property but disallowing user input:
Private Sub Combo1_KeyPress(KeyAscii As Integer) 
KeyAscii = 0 
End Sub 

�Kishore Gnanananda, Dubai, United Arab Emirates


c0Title: Change the Width of a ComboBox's Dropdown
c1Code:

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Sub SetComboWidth(cboCombo As ComboBox, lngWidth As Long)
    SendMessage cboCombo.hwnd, &H160, lngWidth, 0& 
End Sub


c0Title: Edit Field In DataGrid
c1Code:
Sometimes you want to give your DataGrid the ability to edit fields, while the original data in the field is highlighted. Normally, you can click on the field to start editing it. However, in case your users prefer to use the keyboard instead of the mouse, put this code in the grdDataGrid_KeyDown event: 
Private Sub grdDataGrid_KeyDown(KeyCode As Integer, Shift As Integer)
       Select Case KeyCode
             Case vbKeyF2
                    grdDataGrid.SelStart = 1
                    SendKeys "{End}"
       End Select
End Sub

�Decha Srivorapun, Bangkok, Thailand


c0Title: Enumerate a Dictionary Object
c1Code:
Although the Dictionary object does not have an enumerator, it does have an Items method that returns a Variant array. You can use the For...Each construct on the array:
 
Dim vItem As Variant
Dim dict As Scripting.Dictionary
 
Set dict = New Scripting.Dictionary
dict.Add "Item1", "Item data 1"
dict.Add "Item2", "Item data 2"
dict.Add "Item3", "Item data 3"
 
For Each vItem In dict.Items
     Debug.Print vItem
Next
 
Set dict = Nothing

Before you can use the Dictionary object in your application, you must set a Project Reference to the Microsoft Scripting Runtime (scrrun.dll).

�Steve Griffs, Niskayuna, New York


c0Title: Avoid Regenerating Overlay Images
c1Code:
If you�re creating overlays with the ListImages.Overlay method, always set the ImageList control�s BackColor property to the MaskColor property before calling the OverLay method. Return the BackColor to its previous value (probably vbWindow-Background) after calling OverLay. If you generate overlay images with MaskColor = BackColor, then the images don�t have to be regenerated when the user changes system colors.

�Matt Curland, Redmond, Washington


c0Title: Ascertain OK or Cancel From InputBox
c1Code:
VB5, VB6

When the user presses Cancel on a VB InputBox, the string returned is a vbNullString. If the user inputs a zero-length string and presses OK, the return string is empty (""). Unfortunately, in VB, you can�t compare an empty string to vbNullString because VB equates "" to be equal to vbNullString even though the two are quite different.
However, you can use the undocumented StrPtr function to determine whether the return string is indeed a vbNullString. A vbNullString�s pointer is, by definition, zero:

Dim strReturn as String
strReturn = InputBox("Enter in a value") 

If StrPtr(strReturn) = 0 Then
	' User pressed Cancel
End If

�Bill McCarthy, Barongarook, Victoria, Australia


c0Title: Create A "Super" ListBox
c1Code:
By: David McCarter
August 1997

One of the problem that programmers have always faced with ListBoxes is that it can not "hide" data about the item in the list very well. All we have is the ItemData property which can only be a long integer... not very usefull. Lets say that you are displaying file names from a MAPI attachment collection in the list box... you will of course need the file name, but you also might need the source name, file type and position. Well you can not store this information right with the file name that is displayed in the ListBox. Sure, you could create an array or collection and use the ItemData as the key, but neither of these seemd like an easy and fast solution to me.

I wanted a ListBox that would hold this inforamtion so it would be easily accessable. What I did was creat a list box using the ListView control that comes in the Microsoft Common Controls that is already included with Win95 and WinNT. The ListBox can have SubItems that can be hidden from the user to store information. SubItems hold strings, so you can put just about any type of data that you want there. The cool thing is that the ListView control can look just like a ListBox, so your users would never know the difference. Okay, you might call this way of doing this a "hack", but hey... sometimes an "hack" might be the easyiest way to implement and understand. Here are the steps to create your own "super" ListBox.

1. Setup The ListView Control

Add a ListView control to your form. Use custom properties and set the View to Report. Under Column Headers add as many columns that you need for your data plus one for the first column that will be displayed to the customer. For every column that you don't want the user to see (where you hide your data) set the Width to zero. Column number 1 will always display the Item's Text property.

2. Add Data

In this article, we will be displaying a list of MAPI attachemnts in the ListView control. We will have only one visible column (the file name) and hide the rest of the information.

First to make the different fields (SubItem) more understandable lets create a Enum:
Private Enum AttachField
    Source = 1
    AttachType = 2
    Position = 3
End Enum

Now lets add our data.
Private Sub Form_Load()

Dim Item As ListItem

    Set Item = ListView1.ListItems.Add()

    Item.Text = "VBTT.EXE"

    Item.SubItems(AttachField.Source) = "C:\VBTT\VBTT.EXE"

    Item.SubItems(AttachField.AttachType) = 1

    Item.SubItems(AttachField.Position) = 1

    'Set icons here if you have them in a ImageList control.

    'Item.Icon = 2

    'Item.SmallIcon = 2

End Sub

3. Read The Data

Reading the data is just as easy:
Private Sub ListView1_Click()

Dim pstrFile As String
Dim pstrFileSource As String
Dim pintPos As Integer
Dim pintFileType As Integer

    pstrFile = ListView1.SelectedItem.Text

    pstrFileSource = ListView1.SelectedItem.SubItems(AttachField.Source)

    pintPos = ListView1.SelectedItem.SubItems(AttachField.Position)

    pintFileType = ListView1.SelectedItem.SubItems(AttachField.AttachType)

    Label1.Text = pstrFile & "," & pstrFileSource & "," & pintPos & "," & pintFileType

End Sub

Here is a sample of what this would look like:

So as you can see, this is very flexable. And if you use an Enum to keep track of your SubItem names, it's very easy to add or remove values. Also, this "Super" ListBox is very fast!


c0Title: Change Appearance Property at Run Time
c1Code:
Here�s a way of changing the �read-only at run time� Appearance property for numerous types of controls. It works especially well
with the ListBox, TextBox, and PictureBox controls, without re-creating the control.

Paste this code in a module and pass references to controls you want to alter. By default, this routine changes the style from 3-D to Flat, but you can change it back to 3-D by passing True for the optional second parameter:
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const WS_BORDER = &H800000
Private Const WS_EX_CLIENTEDGE = &H200
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20

Public Sub ChangeStyle(ctrl As Control, Optional ByVal ThreeD As Boolean = False)
    Dim nStyle As Long
    Dim nStyleEx As Long
    Const swpFlags = SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_FRAMECHANGED

    ' Get current styles
    nStyle = GetWindowLong(ctrl.hWnd, GWL_STYLE)
    nStyleEx = GetWindowLong(ctrl.hWnd, _
    GWL_EXSTYLE)

    If ThreeD Then
        ' Turn Border off, ClientEdge on
        nStyle = nStyle Or WS_BORDER
        nStyleEx = nStyleEx And Not WS_EX_CLIENTEDGE
    Else
        ' Turn Border on, ClientEdge off
        nStyle = nStyle And Not WS_BORDER
        nStyleEx = nStyleEx Or WS_EX_CLIENTEDGE
    End If

    ' Set new styles and force redraw
    Call SetWindowLong(ctrl.hWnd, GWL_STYLE, nStyle)
    Call SetWindowLong(ctrl.hWnd, GWL_EXSTYLE, nStyleEx)
    Call SetWindowPos(ctrl.hWnd, 0, 0, 0, 0, 0, swpFlags)
End Sub

You might observe the control shrinking when you click on the button several times. You can reproduce this behavior by repeatedly changing the Appearance property of the control from the design-time Properties window. You can inhibit this resizing with ListBox controls by setting IntegralHeight to False. With other controls, you can consider a sizing correction after changing the border style.

�Gilbert R. Rosal, Miami, Florida


c0Title: Adding a horizontal scroll bar to a list box
c1Code:
lRes = sendmessage(lst1.hWnd, LB_SETHORIZONTALEXTENT, 400, 0) 
'the 400 gives the length that the scroll bar will show in dialogue units(4 dialogue units appox = 1 char)


c0Title: Copy Listview Contents to Clipboard
c1Code:
This easy routine copies the contents of a listview, including column headers, to the clipboard for pasting into Excel or other applications:
Public Sub SendToClipboard(ByVal ListViewObj As MSComctlLib.ListView)
    Dim ListItemObj As MSComctlLib.ListItem
    Dim ListSubItemObj As MSComctlLib.ListSubItem
    Dim ColumnHeaderObj As MSComctlLib.ColumnHeader
    Dim ClipboardText As String
    Dim ClipboardLine As String

    Clipboard.Clear

    For Each ColumnHeaderObj In ListViewObj.ColumnHeaders
        Select Case ColumnHeaderObj.Index
        Case 1
            ClipboardText = ColumnHeaderObj.Text
        Case Else
            ClipboardText = ClipboardText & vbTab & ColumnHeaderObj.Text
        End Select
    Next ColumnHeaderObj

    For Each ListItemObj In ListViewObj.ListItems
        ClipboardLine = ListItemObj.Text

        For Each ListSubItemObj In ListItemObj.ListSubItems
            ClipboardLine = ClipboardLine & vbTab & ListSubItemObj.Text
        Next ListSubItemObj

        ClipboardText = ClipboardText & vbCrLf & ClipboardLine
    Next ListItemObj

    Clipboard.SetText ClipboardText
End Sub

�Chris Schneider, Newark, Delaware


c0Title: Determine Which ListView Column was Checked
c1Code:
When using the ListView control in list mode (Listview.View = lvwList), no property indicates which column the user clicked on within the selected row. The ListView�s HitTest method returns only a reference to the ListItem the user clicked on, not the specific subitem. Use the SendMessage API function in the ListView�s MouseUp or MouseDown event to provide this information:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 
Private Const LVM_SUBITEMHITTEST As Long = 4153
 
Private Type POINTAPI
     X As Long
     Y As Long
End Type
 
Private Type LVHITTESTINFO
     pt As POINTAPI
     lngFlags As Long
     lngItem As Long
     lngSubItem As Long
End Type
 
Private Sub ListView1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
     Dim hti As LVHITTESTINFO
     Dim lngRet As Long
     hti.pt.X = X / Screen.TwipsPerPixelX
     hti.pt.Y = Y / Screen.TwipsPerPixelY
     lngRet = SendMessage(ListView1.hWnd, _
          LVM_SUBITEMHITTEST, 0&, hti)
     Debug.Print "Row=" & hti.lngItem,
     Debug.Print "Col=" & hti.lngSubItem
End Sub

�Brian Pursley, Cincinnati, Ohio


c0Title: Bind Option Buttons to Data Controls
c1Code:
The Option button is a convenient way to display multiple options from which only one can be selected. One problem is that the Option button cannot be bound to a data control. Here�s an easy workaround: Create an array of Option buttons and also create a hidden text field and bind it to your data control. Place this code in your form:
{{{
Private Sub Option1_Click(Index As Integer) 
Text1.Text = Index 
End Sub 

Private Sub Text1_Change 
Option1(Val(Text1.Text)).Value = True 
End Sub 
}}
Whenever the value in Text1 is changed by the data control, it sets the Option button of the corresponding index value to True. Whenever the Option button is changed, it stores the corresponding Index in the textbox. Because the textbox is bound to the data control, the value is saved in the database.

�Chris Schneider, Newark, Delaware


c0Title: Enhance the Printers Collection
c2File: Printers.zip
c1Code:
Filling some of the most-requested holes is only a few API calls away.

Project: Printers.zip

Classic VB offers an interesting and sometimes useful Printers collection. Still, those Printer objects never seem to provide the key functionalities you desire�or so I've gathered from working on this magazine's Q&A column for years. In response, I put together an assortment of the dozen-odd Printer object properties and methods you've most requested�including queue positioning, job cancel/pause/resume, printer purge/pause/resume, and default get/set�then built a little demo around them (download a complete list here).

Figure 1. Mine the Win32 API for Printer Object Enhancements.

The demo shows you how you can duplicate in your code most of the capabilities presented by the Windows Explorer Printers folder and Printer windows that open when you double-click on any of the individual printers (see Figure 1). I'll show you some of the neater ideas in this column, then you can download the whole demo.

DeviceName probably represents the most valuable property offered by VB's Printer objects. This string, with a few API calls, lets you perform most any printer operation you can think of. My demo app creates a collection of CPrinterInfo objects by instantiating one object for each Printer in the Printers collection and passing it Printer's DeviceName as a signal to initialize it. Each CPrinterInfo object exposes a PRINTER_INFO_2 structure, as returned by GetPrinter, along with a few other custom properties and methods.

You must first obtain a printer handle (hPrn) by passing a DeviceName to the OpenPrinter API. You can call GetPrinter with an hPrn to retrieve scads of information about that printer. Usually you make the first call to GetPrinter without passing a buffer to be filled. GetPrinter returns the buffer size needed, then a second call to GetPrinter fills the buffer. Then you can start interpreting the results (see Listing 1). Note that you might have a simpler case where you need only a single item, such as the number of jobs currently spooling to a given printer (see Listing 2).

Pause and Purge Print Queues
Have you noticed that you can't pause or purge a print queue if you don't have administrative privileges? Well, neither can apps whose users lack the required status. You can address this with the third parameter to OpenPrinter, which supports a request for administrative access by setting the PRINTER_DEFAULTS pDesiredAccess element to PRINTER_ACCESS_ADMINISTER. Of course, your process must have sufficient rights, or the OpenPrinter call will fail (see Listing A). You can toggle the related UI elements of your app with a simple test: 
Public Property Get CanAdminister() _
   As Boolean
   Dim hPrn As Long
   Dim pd As PRINTER_DEFAULTS
   ' Try to open printer, requesting
   ' administrative privileges.
   pd.pDesiredAccess = _
      PRINTER_ACCESS_ADMINISTER
   Call OpenPrinter(m_DevName, _
      hPrn, pd)
   CanAdminister = (hPrn <> 0)
   Call ClosePrinter(hPrn)
End Property

Occasionally, an app might need to discover which printer is currently the system default, or even to set the default. Classic VB's Printers collection doesn't offer this capability despite hints that it does. When your app starts, the Printer object points to the current system default printer and continues to do so even if the user changes that default. But once you select a default printer for your app, you can't reset this pointer to the system default printer.

A Microsoft Knowledge Base article (Q246772) details three ways to set and three more to retrieve the system default printer: one each for Windows 9x, Windows NT4 or before, and Windows 2000 and beyond (see Resources). Under Windows 9x, calling EnumPrinters with PRINTER_ENUM_DEFAULT at level 5 provides a quick answer by returning a pointer to the string sought. Curiously, the PRINTER_ENUM_DEFAULT flag is available only in Win9x environments. In NT4, you read the mapped WINini values ("device" key from the "[Windows]" section) from the Registry using GetProfileString. And in Windows 2000, the GetDefaultPrinter API provides a dedicated answer (see Listing B).

Setting the default system printer can be similarly convoluted. Two OSs provide a clear method, however. In Win9x, you get hPrn with OpenPrinter, using GetPrinter to retrieve a PRINTER_INFO_2 structure. Pick the Attribute element from the structure and use PRINTER_ATTRIBUTE_DEFAULT to toggle the default bit on. Once you set the Attribute value, store it in the structure and pass it back to the system with a call to SetPrinter (see Listing C). By comparison, Windows 2000/XP offer a nice boring call to the SetDefaultPrinter API.

In NT4, however, you set the default printer by passing WriteProfileString (key "device" in section "[Windows]") a value of the form "printer name,driver name,port." Unfortunately, no API directly supports finding the correct values for those last two elements. However, NT maps what was once the "[PrinterPorts]" section of WIN.ini to a key in the Registry, from which you can extract the info needed for any installed printer (see Listing C). And if you aren't running under Win2K or better, you also must alert every other running app of this change, using SendMessage to send WM_SETTINGCHANGE to the special handle HWND_BROADCAST.

Under VB5, you'll also need to call GetProfileString to ensure you have a complete Printers collection. Request all the keys in the "[PrinterPorts]" section and parse the null-delimited list that returns.

The demo code is bulky�the class modules alone take up nearly 100K. But you'll find more cool stuff there, including how to modify individual job properties (such as their position in the queue) and how to interpret the status bytes of a job or printer to be human-readable.

About the Author
Karl E. Peterson is a GIS analyst with a regional transportation-planning agency and serves as a member of the Visual Studio Magazine Technical Review and Editorial Advisory boards. He's also a Microsoft MVP and a section leader on several VSM forums. Find more of Karl's VB samples at www.mvps.org/vb.


c0Title: Add a Document Name to Your Printouts
c1Code:
I wanted to distinguish between different print jobs. I tried to find a way to set the print job name that appears in the printer queue, but even some nasty API calls didn�t work well. I found a simple trick, though it works only after compiling to an EXE:

 
Dim sAppTitle As String
 
sAppTitle = App.Title
App.Title = "What ever Print Job Name you wish"
 
' Start Printing....
 
' End Printing
Printer.EndDoc
App.Title = sAppTitle


�Yoram Shechori, Netanya, Israel


c0Title: Does VB support pointers to functions?
c1Code:
Yes, useAddressOf, there is some limitations ton using this function. Any code you write to call a function pointer from Visual Basic must be placed in a standard .BAS module. You can't put the code in a class module or attach it to a form.

You can only use AddressOf with user-defined subs, functions, or properties - you cannot use it with external functions declared with the Declare statement, or with functions referenced from type libraries. You can pass a function pointer to an argument that is typed As Any or As Long in a declared Sub, Function, or user-defined type definition.


c0Title: RegEx Wrapper Function
c1Code:
Option Compare Database
Option Explicit

Dim moRegEx As VBScript_RegExp_55.RegExp

Global Const gcRegExMatchCollection = -2
Global Const gcRegExMatchBoolean = -1

'Search the target string for the specified regular expression
'
'nMatch     Specifies the match number to return. If invalid, an empty string is returned
'           Set to cRegExMatchCollection to return the matches collection
'           Set to cRegExMatchBoolean (default) to return TRUE if the string matches, otherwise FALSE
'
'nSubmatch  Specifies the number of the submatch value to return (default -1 means ignore submatch)
'
'Note: Match and submatch numbers start with 0
'
Public Function RegExMatch(sTarget As String, sPattern As String, Optional nMatch As Long = gcRegExMatchBoolean, Optional nSubmatch As Long = -1) As Variant

    Dim oMatches As VBScript_RegExp_55.MatchCollection
    
    If moRegEx Is Nothing Then Set moRegEx = New VBScript_RegExp_55.RegExp
    
    With moRegEx
        'Only set properties if they're different to avoid unnecessary recompiles of regex
        If .Pattern <> sPattern Then .Pattern = sPattern
        If .IgnoreCase <> True Then .IgnoreCase = True
        If .Global <> True Then .Global = True
        If .MultiLine <> True Then .MultiLine = True
    End With
    
    
    Select Case nMatch
    
    Case gcRegExMatchBoolean     'Check for match only
        
        RegExMatch = moRegEx.Test(sTarget)
    
    Case gcRegExMatchCollection
        
        Set RegExMatch = moRegEx.Execute(sTarget)
        
    Case Else               'Return specified matching string
    
        Set oMatches = moRegEx.Execute(sTarget)
    
        If oMatches.Count >= nMatch + 1 Then
        
            If nSubmatch = -1 Then
                RegExMatch = oMatches(nMatch).Value
            Else
                
                If oMatches(nMatch).SubMatches.Count >= nSubmatch + 1 Then
                    RegExMatch = oMatches(nMatch).SubMatches(nSubmatch)
                Else
                    RegExMatch = vbNullString
                End If
            
            End If
            
        Else
            RegExMatch = vbNullString
        End If
        
    End Select

End Function


c0Title: Automating A Settings Dialog Form
c1Code:
Does your application have a preferences form, where your users can save a bunch of settings? It can be tedious to write the code to save all those values to the Registry (or your INI file) and read them back. During the development of your project, the types and number of settings can grow and grow. With these routines, you can write the code once, then you usually won't need to update this code even when you add new controls.

For each setting that you save, whether to the Registry or an INI, you'll need to define "section" and "key" strings. See the help on GetSetting and/or SaveSetting for examples.

For each control that you'll use to maintain a setting, put the name of the "key" in the control's TAG property. Put the default value of that key in the control itself at design time. For the section name, you must put your control into a container control with the desired "section" string in its own .TAG field. Often, this is actually very convenient, as controls get grouped into frames and other logical containers. When that isn't fully effective, use any kind of invisible container which supports a .TAG property, or use the TAG of the form itself. I usually reserve that last tactic for the most general of settings.

Call GetOptions before showing the form to the user (I usually call it from form_load) and call PutOptions whenever you need to save settings.

Code

Public Sub GetOptions(Frm As Form)
Dim Ctrl As Control
    For Each Ctrl In Frm.Controls
        With Ctrl
            If .Enabled Then
                If Len(.Parent.Tag & .Tag) Then
                    If TypeOf Ctrl Is TextBox Then
                        .Text = Trim$(GetSettingString(.Parent.Tag, .Tag, .Text))
                        ElseIf TypeOf Ctrl Is CheckBox _
                            Or TypeOf Ctrl Is HScrollBar _
                            Or TypeOf Ctrl Is VScrollBar _
                            Then
                            .Value = GetSettingInt(.Parent.Tag, .Tag, .Value)
                    End If
                End If
            End If
        End With
    Next
End Sub
 
Public Sub PutOptions(Frm As Form)
Dim Ctrl As Control
    For Each Ctrl In Frm.Controls
        With Ctrl
            If .Enabled Then
                If Len(.Parent.Tag & .Tag) Then
                    If TypeOf Ctrl Is TextBox Then
                        SaveSettingString .Parent.Tag, .Tag, .Text
                        ElseIf TypeOf Ctrl Is CheckBox _
                            Or TypeOf Ctrl Is HScrollBar _
                            Or TypeOf Ctrl Is VScrollBar _
                            Then
                            SaveSettingInt .Parent.Tag, .Tag, .Value
                    End If
                End If
            End If
        End With
    Next
End Sub


You'll need to include GetSettingInt, GetSettingString, SaveSettingInt, and SaveSettingString routines to save the settings to your own INI file.

Also, you can certainly adjust the code for other types of controls besides the TextBox, CheckBox, HScrollBar and VScrollBar.

Additional Code

'Set this public variable before you call GetOptions or PutOptions
Public gsIniFile As String
Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Function FixString(sInString As String) As String
Dim nPos As Integer
    On Error Resume Next
    nPos = InStr(sInString, Chr$(0))
    If nPos Then
        FixString = Left$(sInString, nPos - 1)
        Else
            FixString = sInString
    End If
End Function
Private Function GetSettingString(sSection As String, sKey As String, sDefault As String) As String
Const INI_BUF_SIZE = 255
Dim iReturn As Integer
Dim sBuffer As String
    On Error Resume Next
    sBuffer = String$(INI_BUF_SIZE + 1, 0)
    iReturn = GetPrivateProfileString(sSection, sKey, sDefault, sBuffer, INI_BUF_SIZE, gsIniFile)
    GetSettingString = FixString(sBuffer)
End Function
Private Function GetSettingInt(sSection As String, sKey As String, nDefault As Integer) As Integer
    On Error Resume Next
    GetSettingInt = GetPrivateProfileInt(sSection, sKey, nDefault, gsIniFile)
End Function
Private Function SaveSettingInt(sSection As String, sKey As String, nValue As Integer) As Boolean
    On Error Resume Next
    SaveSettingInt = IniPrivateWriteString(sSection, sKey, CStr(nValue), gsIniFile)
End Function
Private Function SaveSettingString(sSection As String, sKey As String, sValue As String) As Boolean
    On Error Resume Next
    SaveSettingString = IniPrivateWriteString(sSection, sKey, sValue, gsIniFile)
End Function
Private Function IniPrivateWriteString(sSection As String, sKey As String, sValue As String, sIniFile As String) As Boolean
    On Error Resume Next
    If (Len(sKey) > 0) Then
        IniPrivateWriteString = (WritePrivateProfileString(sSection, sKey, sValue, sIniFile) <> 0)
        Else
        '----- Delete all keys in this section
        IniPrivateWriteString = (WritePrivateProfileString(sSection, vbNullString, sValue, sIniFile) <> 0)
    End If
End Function


Tip Submitted By: Bob O`Bob


c0Title: Create GUID
c1Code:
This function is a simple wrapper function to wrap the API work of calling CoCreateGuid to return a string representation of a GUID. Simple returns the new GUID.

Option Explicit

Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Declare Function CoCreateGuid Lib "ole32" (pguid As GUID) As Long 
Declare Function UuidToString Lib "rpcrt4" Alias "UuidToStringA" (pguid As GUID, pszGuid As Long) As Long 
Declare Function RpcStringFree Lib "rpcrt4" Alias "RpcStringFreeA" (psz As Long) As Long
Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal length As Long) As Long 
Declare Function CopyLongToString Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, lpString2 As Any) As Long

Public Function CreateGuid() As String
    Dim TheGuid As GUID
    Dim pszGuid As Long
    
    CoCreateGuid TheGuid
    UuidToString TheGuid, pszGuid
    
    CreateGuid = Space(256)
    CopyLongToString CreateGuid, ByVal pszGuid
    
    RpcStringFree pszGuid
    CreateGuid = Mid(CreateGuid, 1, InStr(1, CreateGuid, vbNullChar) - 1)
End Function


Sample Usage:

        
Debug.Print CreateGuid


c0Title: Alpha Resource IDs Can Spell Trouble
c1Code:
Resource files are a great way to store text strings and images, but beware�use of a resource file can override the property setting for your application�s icon. When Windows needs an icon to represent your application, it always grabs the first one available.

You can use the VB Resource Editor add-in to store icons. Normally, VB assigns an ID of �1� to the icon you assign as the application default. However, if you assign alphanumeric IDs in the Resource Editor, instead of using only numerics, the icon used for your application will be the first one listed under Icons. I always preface the desired application icon�s ID with the string �AAA� to ensure that it remains first alphabetically.

�Al Meadows, Oklahoma City, Oklahoma


c0Title: Asymmetric Encryption (Public/Private Key)
c1Code:
Errata: I did some more research into RSA Public Key encryption and I found that I was slightly in error....the public key is actually a pair of numbers. One is the huge product of 2 primes, as I said, but the other is a smaller, possibly non-prime number called the public exponent. The private key is also a pair of numbers. The same huge product plus another number called the private exponent.

The encoding/decoding functions are the same:

A = B^E MOD P


where A and B are the characters to be encoded/decoded, E is the exponent (public or private) and P is the huge prime product.

It's a simple enough algorithm, but VB has no easy way to handle numbers that large.

For an explanation of how these numbers are derived, I recommend this site: http://world.std.com/~franl/crypto/rsa-guts.html

Here is an example using very small numbers:
P, Q = initial prime numbers
E = Public exponent
D = Private exponent
T = Plain text character
C = encoded character

To start, let's have P=11 and Q = 13. Thus the "huge" prime product (PQ) would be P*Q = 143.

E is determined to be a number between 1 and (P-1) * (Q-1) that has no prime factors in common with (P-1)*(Q-1). It doesn't have to be prime.

(P-1)*(Q-1) = 120 = 2*2*2*3*5 'prime factors


So we decide to choose E = 7

D is selected such that D *E - 1 = ((P-1)*(Q-1)) * X where X is any integer. In other words, D*E - 1 MOD ((P-1)*(Q-1)) = 0

In our case, D * 7 - 1 = 120 * X

D = (120*X + 1) / 7


We now just select a value for X that yields an integer value for D. As it happens, X = 6 works.

D = (120 * 6 +1)/7 = 721/7 = 103


So now we have the following keys.
Public Key:

PQ = 143 E = 7


Private Key:

PQ = 143 D = 103


Let's now encode the letter "a" (ascii value 97 so T=97)

C = 97 ^ 7 MOD 143 = 59


To Decode, we simply use the private key

T = 59 ^ 103 MOD 143 = 97


Why I think it works:

C = T^E MOD PQ
T = C^D MOD PQ


So

T = (T^E MOD PQ) ^ D MOD PQ


This simplifies to:

T = T ^ED MOD PQ


c0Title: Creating Registration Number
c1Code:
The following code I use with Visual Basic Professional 3.0. This procedure reads a INI file and looks for two entries, 'UserName' and 'UserNumber'. If they are existing UserName will be recalculated by the same routine it was created and compared to UserNumber. If they are right, a program may goes on. In case of wrong or absent entries the routine will detect this and the program may show a reminder screen or anything else. I use this routine in my shareware programs. The user may register by entering his name and a number that must be created by the author of the program. For this purposes I wrote an own routine (in a separate program!) that uses the same procedure as the controlling code in the main program:

Code in the load procedure of the start form. First read the INI file and look for the entries of the variables UserName and UserNumber:

Dim LpRetStr As String
    LpRetStr = String(255, Chr(0))
    UserName = Left(LpRetStr, GetPrivateProfileString(APP_NAME, ByVal USER_NAME, "", LpRetStr, Len(LpRetStr), INI_FILENAME))
    UserNumber = GetPrivateProfileInt(APP_NAME, USER_NUMBER, 0, INI_FILENAME)


Second after getting the UserName from the INI file read it char to char and creates a number from it. This will be done and stored in the variable TestCode. You may change the code of this line. Be sure to use the same procedure when you are creating the numbers:

    For i% = 1 To Len(UserName)
        Zeichen = Mid$(UserName, i%, 1)
        pchar% = Asc(Zeichen)
        TestCode =(TestCode1 + pchar%) + 2 * ( pchar% + 7) + 343
    Next i%


Now compare the built number to number read from the INI file:

    If Format$(TestCode) = Format$(UserNumber) Then
        'Calculated and read number are identically
        'Enter here the code to go on with the program
        Else
           'Numbers are not identically! 
           'Enter here the code to show the Copyright, Shareware reminder or do anything else
    End If


Of course you must declare in the BAS module:

Declare Function GetPrivateProfileString Lib "Kernel" (ByVal Appname As String, KeyName As Any, ByVal lpDefault As String, ByVal ReturnedString As String, ByVal nSize As Integer, ByVal FileName As String) As Integer
Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal Appname As String, ByVal KeyName As String, ByVal DEFAULT1 As Integer, ByVal Filename As String) As Integer


The following variables do not need to be declared as 'Global'. This is necessary only if you need them in different modules and forms. INI_FILENAME is the name for the INI file in the Windows directory, APP_NAME the name for the 'Section' of the INI file. Code APP_NAME and INI_FILENAME as listed below. The section name must appear inside the INI file in [brackets].

Global Const INI_FILENAME = "SAMPLE.INI"
Global Const APP_NAME = "SectionName"
Global Const USER_NAME = "UserName"
Global Const USER_NUMBER = "UserNumber"
Global UserName As String
Global UserNumber As Integer


If you want to able the user to register the program you must declare a function to write the entries into the INI file. The declaration must be done in the BAS module:

Declare Function WritePrivateProfileString Lib "Kernel" (ByVal Appname As String, ByVal KeyName As String, ByVal NewString As String, ByVal Filename As String) As Integer


The code to write the entries for UserName and UserNumber is:

Z = WritePrivateProfileString(APP_NAME, USER_NAME, Format$(Text1.Text), INI_FILENAME)
Z = WritePrivateProfileString(APP_NAME, USER_NUMBER, Format$(Text2.Text), INI_FILENAME)


These two lines above creates the entries in the INI file and also writes the brackets for you. These lines can be positioned at any place of your program. The user must enter the name and number he received from me in two text boxes called Text1 and Text2. After controlling this entries (with the routine above) they will be written to the INI file if they are correct. At least you must have the routine (in a separate program!) to build the UserNumber. Please notify that line 5 (TestCode) is identically with the corresponding lines in the test routine of the main program. This MUST be.

Sub Command1_Click ()
    For i% = 1 To Len(Text1.Text)
        Zeichen = Mid$(Text1.Text, i%, 1)
        pchar% = Asc(Zeichen)
        TestCode = (TestCode + pchar%) + 2 * ( pchar% + 7) + 343
    Next i%
    Text2.Text = TestCode
End Sub


Put the users name in the text field (Text1.Text) and press the button Command1. The built number will be shown in a second text box (Text2). Name and number should be send to the user who wants to register. enjoy and modify the code as you want.

Tip Submitted By: Dr. Jochen Strauss


c0Title: Closing a DOS prompt window
c1Code:
After you run a DOS application in Windows 95, the MS-DOS Prompt window doesn't close. To prevent this behavior, you can use the API to find the Window handle for the DOS prompt window, wait for the program to finish running, then zap the DOS prompt window into oblivion.

This technique doesn't require any forms. It's just a simple VB 4.0 DLL with two properties: the EXE name of the DOS program and the text that will appear as the caption of the DOS prompt window displaying this application. The core of this app lies in three API calls. Place the following code in a standard module:

Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const WM_CLOSE = &H10


The rest of the code goes in the following class module, named Cclose:

Private m_sEXEName As String
Private m_sDosCaption As String

Public Sub RunDosApp()

    Dim vReturnValue As Variant
    Dim lRet As Long
    Dim i As Integer

    vReturnValue = Shell(m_sEXEName, 1) 'Run EXE
    AppActivate vReturnValue 'Activate EXE Window

    Do
        Sleep (10000)
        lRet = FindWindow(vbNullString, m_sDosCaption)

        If (lRet <> 0) Then
            vReturnValue = SendMessage(lRet, WM_CLOSE, &O0, &O0)
            Exit Do
        End If
    Loop
End Sub


Tip by James Limm


c0Title: Insertion Sort a 2D Array In Reverse Order
c1Code:
'Sort 2-d string array by the specified column in reverse order
Public Sub InsertionSort2dRev(sArray() As String, nColumn As Long, Optional iUbound As Long = -1)
    Dim iOuter As Long
    Dim iInner As Long
    Dim iLBound As Long
    Dim sTemp() As String
    Dim nField As Long
    Dim nFieldMin As Long
    Dim nFieldMax As Long
    
    nFieldMin = LBound(sArray, 2)
    nFieldMax = UBound(sArray, 2)
    
    ReDim sTemp(nFieldMin To nFieldMax)
    
    iLBound = LBound(sArray, 1)
    If iUbound = -1 Then iUbound = UBound(sArray, 1)
    
    For iOuter = iLBound + 1 To iUbound
        
        For nField = nFieldMin To nFieldMax
            sTemp(nField) = sArray(iOuter, nField)
        Next
        
        For iInner = iOuter - 1 To iLBound Step -1
            If sArray(iInner, nColumn) > sTemp(nColumn) Then Exit For
            
            For nField = nFieldMin To nFieldMax
                sArray(iInner + 1, nField) = sArray(iInner, nField)
            Next
        Next iInner
        
        For nField = nFieldMin To nFieldMax
            sArray(iInner + 1, nField) = sTemp(nField)
        Next
    Next iOuter
End Sub


c0Title: Bubble Sort (Avoid)
c1Code:
This is perhaps the most widely known and used sort, and is certainly one of the simplest. The algorithm consists of a series of passes through the data, with the larger values bubbling up to one end and at the same time smaller values sinking to the other end.

Example (underline shows where values are being compared):

Code:
Array of data [6,7,9,3,2,5]

Bubbling pass 1
[6,7,9,3,2,5]
[6,7,9,3,2,5]
[6,7,9,3,2,5]
[6,7,3,9,2,5]
[6,7,3,2,9,5]

Bubbling pass 2
[6,7,3,2,5,9]
[6,7,3,2,5,9]
[6,3,7,2,5,9]
[6,3,2,7,5,9]

Bubbling pass 3
[6,3,2,5,7,9]
[3,6,2,5,7,9]
[3,2,6,5,7,9]

Bubbling pass 4
[3,2,5,6,7,9]
[2,3,5,6,7,9]

Bubbling pass 5
[2,3,5,6,7,9]

Finish [2,3,5,6,7,9]

The code to implement this is fairly simple. As you might have already spotted, a nested loop of some kind is in order. I choose to use 2 nested For..Next loops:

Public Sub BubbleSort(ByRef lngArray() As Long)
    Dim iOuter As Long
    Dim iInner As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    
    'Which bubbling pass
    For iOuter = iLBound To iUBound - 1
        'Which comparison
        For iInner = iLBound To iUBound - iOuter - 1
        
            'Compare this item to the next item
            If lngArray(iInner) > lngArray(iInner + 1) Then
                'Swap
                iTemp = lngArray(iInner)
                lngArray(iInner) = lngArray(iInner + 1)
                lngArray(iInner + 1) = iTemp
            End If
            
        Next iInner
    Next iOuter
End Sub


c0Title:
Multiple Sort Algorithms (Bubble, Selection, Insertion, Binary, Min, Shell, Comb, Heap, Merge, Quick, Counting)

c1Code:

'**************************************************
'**************************************************
'* Sorting algorithms
'**************************************************
'**************************************************

'==================================================
'= Introduction to the sort algorithms
'==================================================

'Following sort parameters are common to all sorts:

'ByRef A() As Long: one dimensional array to be sorted
'ByVal L As Long  : low index of the part of array to be sorted
'ByVal H As Long  : high index of the part of the array to be sorted.

'Adapt the type of A() when sorting other value types.

'All other sort parameters are specific to the sorting routine. Leave
'their type as is when adapting for sorting other value types except
'otherwise noted.

'Some of the local vars often used are:

'I As Long, J As Long: hold array indexes, used in loops
'T As Long           : holds temporarily array values, used for swapping
'PIV As Long         : holds temporarily array values, used for comparison (a pivot element)

'All other local vars are specific to the sorting routine or have been named
'other than I,J or T for the sake of being more explanative.

'When adapting for sorting other value types:
'all local vars whose type has to be adapted are on one Dim line (the last one)
'with a trailing comment: "'*** Adapt!".

'The non Fast mode sorts are interspersed with administration calls to
'procedures which *do not* belong to the sorting algorithm. They are *not*
'needed by the sorting algorithm and are *irrelevant* for the functionality
'of the sorts. They are called to provide statistical measures or for other
'purposes. All calls to such procedures are marked with a trailing comment,
'starting with three asterisks and followed by some explanatory text. The
'procedure names are prefixed with 'S_'.

'Example:

'S_BreakPoint '*** Wait

'is a call to a routine, which stops the sorting temporarily. The user then can
'eg. visually inspect the current array state and afterwards continue the sorting.

'The code for Fast and non Fast mode sorts is *identical*. Of course those administration
'calls are not present in the Fast mode sorts. And in the non Fast mode sorts
'all assignments, stores, swaps and comparisons *of array elements* are replaced
'with procedure calls, such being able to count them. Index manipulation actions
'are not counted and such do not use calls. They always are implemented in direct.

'If you want to change the sort order from ascending to descending, note that
'all comparisons which compare *array elements* and such define the sort direction
'use the "<" or "<=" operator. As first step change all occurrences
'of "<" to ">" and of "<=" to ">=". Further adaptions may be needed
'(depends on the sort algorithm). A simple method for changing the sort order
'without changing the sort implementation would be to use the implementation in
'this class for sorting ascending and then in a further step flip the elements to
'descending order by another simple self written routine.

'For being callable by CallByName and as well having accurate timing resolution
'for the Fast mode, each algorithm needs a public dispatcher, having the same
'name as the sort prefixed with "Do".

'For cancel handling (without loosing the capability of detecting real
'unexpected errors which eg. may arise in a faulty sorting algorithm),
'these dispatchers have to have "On Error Resume Next" error protection!
'The error protection unfortunately can not be handled in the calling "Sort"
'main dispatcher, as CallByName seems to be not able to handle errors
'in the called routine.


'==================================================
'= Sort categorizations
'==================================================

'Sort                        |Fast|Recur-|Stable|Wide  |Comment
'                            |    |sive  |      |number|
'                            |    |      |      |range |
'----------------------------|----|------|------|------|
'01 Bubble sort              |No  |No    |Yes   |Yes   |
'02 Selection sort           |No  |No    |Yes   |Yes   |
'03 Insertion sort           |No  |No    |Yes   |Yes   |
'04 Binary sort              |No  |No    |Yes   |Yes   |
'05 Min sort                 |No  |No    |No    |Yes   |
'06 Shell sort               |Yes |No    |No    |Yes   |
'07 Shell sort A             |Yes |No    |No    |Yes   |Uses insertion sort
'08 Comb sort                |Yes |No    |No    |Yes   |
'09 Heap sort                |Yes |No    |No    |Yes   |
'10 Merge sort               |Yes |Yes   |Yes   |Yes   |
'11 Merge sort A             |Yes |Yes   |Yes   |Yes   |Uses insertion sort
'12 Merge sort B             |Yes |Yes   |Yes   |Yes   |Optimized version
'13 Quick sort               |Yes |Yes   |No    |Yes   |
'14 Quick sort A             |Yes |Yes   |No    |Yes   |Uses insertion sort
'15 Quick sort B             |Yes |Yes   |No    |Yes   |Uses insertion sort
'16 Quick sort C             |Yes |Yes   |No    |Yes   |Uses insertion sort
'17 Quick sort D             |Yes |Yes   |No    |Yes   |Optimized for safety, uses insertion sort and heap sort
'18 Counting sort real swap  |Yes |No    |Yes   |No    |
'19 Counting sort pseudo swap|Yes |No    |No?   |No    |
'----------------------------|----|------|------|------|

'Sort                        |Order O(n)                      |Stable    |
'                            |average |worst case  |best case |          |
'----------------------------|--------|------------|----------|----------|
'01 Bubble sort              |n^2     |n^2         |n         |Yes       |
'02 Selection sort           |n^2     |n^2         |n^2       |Yes       |
'03 Insertion sort           |n^2     |n^2         |n         |Yes       |
'04 Binary sort              |n^2     |n^2         |n*log(n)  |Yes       |
'05 Min sort                 |n^2     |n^2         |n^2       |No        |
'06 Shell sort               |?       |n^1.5       |n^1.25    |No        |
'08 Comb sort                |?       |n^2         |n*log(n)  |No        |
'09 Heap sort                |n*log(n)|n*log(n)    |n*log(n)  |No        |
'10 Merge sort               |n*log(n)|n*log(n)    |n*log(n)  |Yes       |
'13 Quick sort               |n*log(n)|n^2         |n*log(n)  |No        |
'18 Counting sort real swap  |n       |n           |n         |Yes       |
'19 Counting sort pseudo swap|n       |n           |n         |No?       |
'----------------------------|--------|------------|----------|----------|

'Some *measured* sort order factors (work in progress)

'Method for test       : Order stats
'Repetitions           : 1
'Input array generator : "D Random" or "N Random" (used for counting sorts only),
'                        with fixed random sequences

'The general formula is:
'
'X(n) = O(n) * F + A
'
'where n is the number of elements to sort, O(n) is a function of n, F is a
'constant factor, A is a constant and X(n) is the number of assignments
'or the number of comparisons done for n elements to sort. A is unknown,
'but neglecticable for bigger arrays.

'Sort                  |Moves               |Comparisons
'                      |Order O(n)|Factor F |Order O(n)|Factor F
'----------------------|----------|---------|----------|-------------
'Bubble                |n**2      |0.75     |n**2      |0.50
'Selection             |n**2      |0.25     |n**2      |0.50
'Insertion             |n**2      |0.25     |n**2      |0.25
'Binary                |n**2      |0.25     |n*log(n)  |0.90
'Min                   |n         |3.00     |n**2      |0.50


'==================================================
'= Implementations
'==================================================

'**************************************************
'* Bubble Sort O(n*n) stable
'**************************************************

Private Sub BubbleSortFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long)

Dim i As Long, j As Long, Sorted As Boolean
Dim t As Long '*** Adapt!

For j = H - 1 To L Step -1
  Sorted = True
  For i = L To j
    If A(i + 1) < A(i) Then t = A(i): A(i) = A(i + 1): A(i + 1) = t: Sorted = False
  Next i
  If Sorted Then Exit Sub
Next j

End Sub


'**************************************************
'* Selection Sort O(n*n) stable
'**************************************************

Private Sub SelectionSortFast(ByRef A() As Long, _
                              ByVal L As Long, _
                              ByVal H As Long)

Dim i As Long, j As Long
Dim t As Long '*** Adapt!

For i = L To H - 1
  For j = H To i + 1 Step -1
    If A(j) < A(i) Then t = A(i): A(i) = A(j): A(j) = t
  Next j
Next i

End Sub


'**************************************************
'* Insertion Sort O(n*n) stable
'**************************************************

'Use it for small lists (< 20 items) and for almost sorted (then may be big) lists.

Private Sub InsertionSortFast(ByRef A() As Long, _
                              ByVal L As Long, _
                              ByVal H As Long)

Dim i As Long, j As Long
Dim PIV As Long '*** Adapt!

For j = L + 1 To H
  PIV = A(j)
  For i = j To L + 1 Step -1
    If PIV < A(i - 1) Then A(i) = A(i - 1) Else Exit For
  Next i
  A(i) = PIV
Next j

End Sub


'**************************************************
'* Binary Sort O(n*n) stable (modified insertion sort)
'**************************************************

'BinarySort uses much fewer comparisons than InsertionSort on random arrays because
'it uses a binary search on the already sorted lower part of the array for searching
'the correct place where to put the next element in. However for nearly sorted or
'sorted arrays InsertionSort is better than BinarySort as it always has to do the
'binary search. And, as InsertionSort has lower overhead, BinarySort for small arrays
'is slower than InsertionSort too. So BinarySort should be used in favour of InsertionSort
'only for small, unsorted lists and then only when comparisons are very expensive
'(like for strings).

Private Sub BinarySortFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long)

Dim i As Long, P As Long, le As Long, ri As Long
Dim PIV As Long '*** Adapt!

For i = L + 1 To H
  le = L: ri = i: PIV = A(i)
  Do
    P = le + (ri - le) \ 2
    If PIV < A(P) Then ri = P Else le = P + 1
  Loop While (le < ri)
  For P = i To le + 1 Step -1
    A(P) = A(P - 1)
  Next P
  A(le) = PIV
Next i

End Sub


'**************************************************
'* Min Sort O(n*n) instable
'**************************************************

Private Sub MinSortFast(ByRef A() As Long, _
                        ByVal L As Long, _
                        ByVal H As Long)

Dim i As Long, j As Long, k As Long, t As Long

For i = L To H - 1
  k = i
  For j = i + 1 To H
    If A(j) < A(k) Then k = j
  Next j
  If k <> i Then t = A(k): A(k) = A(i): A(i) = t
Next i

End Sub


'**************************************************
'* Shell-Sort O(n^1.25) best case, O(n^1.5) worst case, instable
'**************************************************

'Algorithm uses a GAP sequence from:
'Donald E. Knuth
'Art of Computer Programming, Volume 3: Sorting and Searching
'Addison-Wesley Professional; 2nd edition (April 24, 1998)
'ISBN: 0201896850
'See also an article (which formerly, AFAIR, was on www.epaperpress.com):
'http://oopweb.com/Algorithms/Documents/Sman/Volume/ShellSort_files/s_shl.htm
'from where this algo, using Knuths GAP sequence, has been taken.
'The article is from a series of articles:
'A Compact Guide to Sorting and Searching by Thomas Niemann
'http://oopweb.com/Algorithms/Documents/Sman/Volume2.html

Private Sub ShellSortFast(ByRef A() As Long, _
                          ByVal L As Long, _
                          ByVal H As Long)

Dim i As Long, j As Long, GAP As Long
Dim PIV As Long '*** Adapt!

j = H - L + 1: GAP = 1
If (j > 13) Then
  Do While GAP < j: GAP = 3 * GAP + 1: Loop
  GAP = GAP \ 3:  GAP = GAP \ 3
End If

Do While GAP > 0
  
  For j = L + GAP To H
    PIV = A(j)
    For i = j - GAP To L Step -GAP
      If PIV < A(i) Then A(i + GAP) = A(i) Else Exit For
    Next i
    A(i + GAP) = PIV
  Next j
  
  GAP = GAP \ 3

Loop

End Sub


'**************************************************
'* Shell-Sort A rough sorts, then uses Insertion sort
'**************************************************

Private Sub ShellSortAFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long, _
                           ByVal CutOff As Long)

Dim i As Long, j As Long, GAP As Long
Dim PIV As Long '*** Adapt!

j = H - L + 1: GAP = 1
If (j > 13) Then
  Do While GAP < j: GAP = 3 * GAP + 1: Loop
  GAP = GAP \ 3:  GAP = GAP \ 3
End If

Do While GAP > CutOff
  
  For j = L + GAP To H
    PIV = A(j)
    For i = j - GAP To L Step -GAP
      If PIV < A(i) Then A(i + GAP) = A(i) Else Exit For
    Next i
    A(i + GAP) = PIV
  Next j
  
  GAP = GAP \ 3

Loop

InsertionSortFast A, L, H

End Sub


'**************************************************
'* Comb Sort O(n*log(n)) best case, O(n*n) worst case, instable
'**************************************************

Private Sub CombSortFast(ByRef A() As Long, _
                         ByVal L As Long, _
                         ByVal H As Long)

Dim i As Long, GAP As Long, SWAPPED As Boolean
Dim t As Long '*** Adapt!

GAP = H - L + 1

Do
  
  SWAPPED = False: GAP = (10 * GAP) \ 13
  Select Case GAP: Case 0: GAP = 1: Case 9, 10: GAP = 11: End Select
  
  For i = L To H - GAP
    If A(i + GAP) < A(i) Then t = A(i): A(i) = A(i + GAP): A(i + GAP) = t: SWAPPED = True
  Next i

Loop While SWAPPED Or GAP > 1

End Sub


'**************************************************
'* Heap Sort O(n*log(n)) instable
'**************************************************

Private Sub HeapSortFast(ByRef A() As Long, _
                         ByVal L As Long, _
                         ByVal H As Long)

Dim i As Long
Dim t As Long '*** Adapt!

For i = (H + L) \ 2 To L Step -1
  HeapSortHeapifyFast A, i, L, H
Next i

For i = H To L + 1 Step -1
  t = A(L): A(L) = A(i): A(i) = t
  HeapSortHeapifyFast A, L, L, i - 1
Next i

End Sub

Private Sub HeapSortHeapifyFast(ByRef A() As Long, _
                                ByVal NODE As Long, _
                                ByVal L As Long, _
                                ByVal H As Long)

Dim LEAF As Long
Dim t As Long '*** Adapt!

Do
  LEAF = NODE + NODE - (L - 1)
  If LEAF > H Then Exit Sub
  If LEAF < H Then If A(LEAF) < A(LEAF + 1) Then LEAF = LEAF + 1
  If A(LEAF) < A(NODE) Then Exit Sub
  t = A(NODE): A(NODE) = A(LEAF): A(LEAF) = t
  NODE = LEAF
Loop

End Sub


'**************************************************
'* Merge Sort O(n*log(n)) stable
'**************************************************

'Adapt the type of B() too for sorting other value types

Private Sub MergeSortFast(ByRef A() As Long, _
                          ByVal L As Long, _
                          ByVal H As Long, _
                          ByRef B() As Long)

Dim LP As Long, HP As Long, OP As Long, MIDP As Long

If L = H Then Exit Sub

MIDP = (L + H) \ 2
MergeSortFast A, L, MIDP, B
MergeSortFast A, MIDP + 1, H, B

LP = L: HP = MIDP + 1: OP = L

Do
  If A(LP) <= A(HP) Then
    B(OP) = A(LP)
    OP = OP + 1: LP = LP + 1
    If LP > MIDP Then
      Do
        B(OP) = A(HP)
        OP = OP + 1: HP = HP + 1
      Loop Until HP > H
      Exit Do
    End If
  Else
    B(OP) = A(HP)
    OP = OP + 1: HP = HP + 1
    If HP > H Then
      Do
        B(OP) = A(LP)
        OP = OP + 1: LP = LP + 1
      Loop Until LP > MIDP
      Exit Do
    End If
  End If
Loop

For OP = L To H
  A(OP) = B(OP)
Next OP

End Sub


'**************************************************
'* Merge Sort A (uses InsertionSort for small arrays)
'**************************************************

'Adapt the type of B() too for sorting other value types

Private Sub MergeSortAFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long, _
                           ByRef B() As Long, _
                           ByVal CutOff As Long)

Dim LP As Long, HP As Long, OP As Long, MIDP As Long

Select Case (H - L)
  Case 0
    Exit Sub
  Case Is < CutOff
    InsertionSortFast A, L, H
    Exit Sub
End Select

MIDP = (L + H) \ 2
MergeSortAFast A, L, MIDP, B, CutOff
MergeSortAFast A, MIDP + 1, H, B, CutOff

LP = L: HP = MIDP + 1: OP = L

Do
  If A(LP) <= A(HP) Then
    B(OP) = A(LP)
    OP = OP + 1: LP = LP + 1
    If LP > MIDP Then
      Do
        B(OP) = A(HP)
        OP = OP + 1: HP = HP + 1
      Loop Until HP > H
      Exit Do
    End If
  Else
    B(OP) = A(HP)
    OP = OP + 1: HP = HP + 1
    If HP > H Then
      Do
        B(OP) = A(LP)
        OP = OP + 1: LP = LP + 1
      Loop Until LP > MIDP
      Exit Do
    End If
  End If
Loop

For OP = L To H
  A(OP) = B(OP)
Next OP

End Sub


'**************************************************
'* Merge Sort B (uses optimization for subarrays having 1 or 2 elements)
'**************************************************

'Adapt the type of B() too for sorting other value types

Private Sub MergeSortBFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long, _
                           ByRef B() As Long)

Dim LP As Long, HP As Long, OP As Long, MIDP As Long
Dim t As Long '*** Adapt!

Select Case (H - L)
  Case 0
    Exit Sub
  Case 1
    If A(H) < A(L) Then t = A(H): A(H) = A(L): A(L) = t
    Exit Sub
End Select

MIDP = (L + H) \ 2
MergeSortBFast A, L, MIDP, B
MergeSortBFast A, MIDP + 1, H, B

LP = L: HP = MIDP + 1: OP = L

Do
  If A(LP) <= A(HP) Then
    B(OP) = A(LP)
    OP = OP + 1: LP = LP + 1
    If LP > MIDP Then
      Do
        B(OP) = A(HP)
        OP = OP + 1: HP = HP + 1
      Loop Until HP > H
      Exit Do
    End If
  Else
    B(OP) = A(HP)
    OP = OP + 1: HP = HP + 1
    If HP > H Then
      Do
        B(OP) = A(LP)
        OP = OP + 1: LP = LP + 1
      Loop Until LP > MIDP
      Exit Do
    End If
  End If
Loop

For OP = L To H
  A(OP) = B(OP)
Next OP

End Sub


'**************************************************
'* Quick Sort O(n*log(n)), worst case O(n*n), instable
'**************************************************

' Adopted from the german book (page 143 ff):
' Ulrich Breymann
' C++: Eine Einf�hrung
' 5. aktualisierte und erweiterte Auflage 1999
' ISBN 3-446-21272-8
'This is the most powerful quick sort implementation I have ever seen.
'It is very short, easy to understand, elegant, implicitly takes care for
'special cases and does not suffer from common worst case run time deteriorations.
'You will very very seldom found other runtime behavior than O(n*log(n)).
'Literature says sorted or reverse sorted input leads to worst case
'behaviour for quick sort. This implementation in the contrary behaves very well
'in these cases (more best case than average case). However if *each* time when
'a partition is done the pivot (middle index element) is greatest or smallest
'value in the list, this implementation degrades to O(n*n) and worse stack depth
'goes up to a value proportional to n, such perhaps blowing the stack.

'I slightly modified the original implementation. In case of the original

'If LP < HP Then T = A(LP): A(LP) = A(HP): A(HP) = T
'If LP <= HP Then LP = LP + 1: HP = HP - 1
  
'following is used:

'If LP <= HP Then
'  If LP < HP Then T = A(LP): A(LP) = A(HP): A(HP) = T
'  LP = LP + 1: HP = HP - 1
'End If

'which makes the procedure some nanoseconds faster :-)

Private Sub QuickSortFast(ByRef A() As Long, _
                          ByVal L As Long, _
                          ByVal H As Long)

Dim LP As Long, HP As Long
Dim t As Long, PIV As Long '*** Adapt!

PIV = A((L + H) \ 2): LP = L: HP = H

Do
  While (A(LP) < PIV): LP = LP + 1: Wend
  While (PIV < A(HP)): HP = HP - 1: Wend
  If LP <= HP Then
    If LP < HP Then t = A(LP): A(LP) = A(HP): A(HP) = t
    LP = LP + 1: HP = HP - 1
  End If
Loop While (LP <= HP)

If HP > L Then QuickSortFast A(), L, HP
If LP < H Then QuickSortFast A(), LP, H

End Sub


'**************************************************
'* Quick Sort A (uses InsertionSort for small array parts)
'* On *sub*lists having one element only insertion sort is not called
'**************************************************

Private Sub QuickSortAFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long, _
                           ByVal CutOff As Long)

Dim LP As Long, HP As Long
Dim t As Long, PIV As Long '*** Adapt!

If (H - L) < CutOff Then

  InsertionSortFast A, L, H

Else

  PIV = A((L + H) \ 2): LP = L: HP = H
  
  Do
    While (A(LP) < PIV): LP = LP + 1: Wend
    While (PIV < A(HP)): HP = HP - 1: Wend
    If LP <= HP Then
      If LP < HP Then t = A(LP): A(LP) = A(HP): A(HP) = t
      LP = LP + 1: HP = HP - 1
    End If
  Loop While (LP <= HP)
  
  If HP > L Then QuickSortAFast A(), L, HP, CutOff
  If LP < H Then QuickSortAFast A(), LP, H, CutOff

End If

End Sub


'**************************************************
'* Quick Sort B (does not sort small array parts,
'* then sorts the array as a whole with InsertionSort)
'* On *sub*lists having one element only quick sort is not called
'**************************************************

Private Sub QuickSortBFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long, _
                           ByVal CutOff As Long)

QuickSortBRoughSortFast A, L, H, CutOff
InsertionSortFast A, L, H

End Sub

Private Sub QuickSortBRoughSortFast(ByRef A() As Long, _
                                    ByVal L As Long, _
                                    ByVal H As Long, _
                                    ByVal CutOff As Long)

Dim LP As Long, HP As Long
Dim t As Long, PIV As Long '*** Adapt!

PIV = A((L + H) \ 2): LP = L: HP = H

Do
  While (A(LP) < PIV): LP = LP + 1: Wend
  While (PIV < A(HP)): HP = HP - 1: Wend
  If LP <= HP Then
    If LP < HP Then t = A(LP): A(LP) = A(HP): A(HP) = t
    LP = LP + 1: HP = HP - 1
  End If
Loop While (LP <= HP)

If (HP - L) >= CutOff Then QuickSortBRoughSortFast A(), L, HP, CutOff
If (H - LP) >= CutOff Then QuickSortBRoughSortFast A(), LP, H, CutOff

End Sub


'**************************************************
'* Quick Sort C (Jost Schwider version, uses InsertionSort for small array parts,
'* where the modified quick sort depends on this. InsertionSort is called
'* even if a sublist has one element only
'**************************************************

Private Sub QuickSortCFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long, _
                           ByVal CutOff As Long)

Dim LP As Long, HP As Long
Dim t As Long, PIV As Long '*** Adapt!

If H - L < CutOff Then

  InsertionSortFast A, L, H

Else

  PIV = A((L + H) \ 2): LP = L: HP = H
  
  Do
    While A(LP) < PIV: LP = LP + 1: Wend
    While PIV < A(HP): HP = HP - 1: Wend
    If LP < HP Then
      t = A(LP): A(LP) = A(HP): A(HP) = t
      LP = LP + 1: HP = HP - 1
    Else
      Exit Do
    End If
  Loop
  
  QuickSortCFast A, L, HP, CutOff
  QuickSortCFast A, LP, H, CutOff

End If

End Sub


'**************************************************
'* Quick Sort D (restricted stack depth)
'**************************************************

'This is the "safe" version of quicksort. The parameter MAXSTACKDEPTH limits
'the maximum stack depth of quicksort, which then will *never* exceed MAXSTACKDEPTH.

'This solves the problem, that under very rare circumstances the partition algorithm
'used in this implementation degenerates and produces a very unbalanced tree (in
'extreme it degenerates to a linear list) of subarrays. If this happens, the execution
'times will go up (quicksort behaving as being of order O(n*n)) *and* worse the stack
'depth goes up (up to order N in the extreme, where N is the array element count).

'Limiting the max stack depth solves both problems: under all circumstances stack size
'used will be limited and execution times stay with order O(n*log(n)), when after reaching
'the maximum stack depth a switch is made for using an alternative sort method of order
'O(n*log(n)).

'If MAXSTACKDEPTH is set to a reasonable high value, this variant of quicksort will execute
'almost as fast as the unlimited quicksort in virtually all cases. The small performance hit
'that this stack depth limiting costs is constant (does not depend on N), as long as
'the limit is not reached.

'Now what is a reasonable high value? If quicksort would balance the subarray tree ideally
'by partitioning each subarray into two equal sized subarrays, the maximum stack depth would
'be ld(n), that is 10 for 1000 elements, 20 for 1 million elements and 30 for 1 billion elements.
'In this case we would not have any needs to limit the stackdepth.

'In reality due to its simple partition algorithm numbers are worser. Do your own experiments
'with quicksort in Stats mode where the maximum stack depth is output. From these one will
'see that at least a factor of three should be taken into account (but this depends strongly
'on the unsorted number distributions), which would lead to 90 as a sufficient stack depth
'limit even when sorting one billion numbers and a limit of 60 when sorting up to 1 million
'numbers.

'On the other side VB allocates a max of 1 megabyte of stack (actually the max stack size
'is &HFF000, that is 4 kB smaller than 1 megabyte). Not all of this is available to the
'program (the runtime dll uses some space and of course the program itself just when
'starting recursion already has eaten up some stack space). But this amount is small,
'around some 10 kB or so. Lets assume there are at least 990 kB available.

'Each call to the quicksort in *fast* mode uses 4 longs as parameters, one long for the
'return adress and one long for the this pointer (only, as is the case here, if the sort
'is called as a class function). Additionally 4 longs are used as local parameters. This
'sums up to 10 longs, meaning at least 10*4 = 40 bytes of stack space are consumed with
'each call. Additionally VB uses some extra stack space for register preservation,
'error handling, local expression evaluation and such. It also can save stack space eg. when
'local variables are handled clever and therefore not for all local vars stack space needs
'to be reserved. VB uses an optimizing compiler, which can swirl code quite a bit. All this
'sums up for the fast mode version of quicksort to a total of 48 bytes per call
'(figured out experimentally).

'Things change, when the quicksort is called in non-fast mode. Then the stack consumption
'per call is much higher. This is mainly due to the high amount of hidden local var space
'the compiler allocates for use with the param array, which must be created when calling
'S_BreakPoint. Param arrays use variants, so each param counts 16 bytes alone (quicksort
'non-fast uses 6 param array elements per call to S_BreakPoint) plus the space needed for
'the safe array structure. Also due to using a param array and also because string constants
'are used as parameters to S_BreakPoint, extra stack space is allocated for extended
'error handling.

'Lets return to the stack sizes used by the fast mode quicksort. If we would set the stack
'depth limit to say 1000, this would consume at max 48 kilobytes of stack, which is not
'much compared to the 990 kilobytes available. We could go up to a stack depth of around
'21000 without problems (this stack depth is reached by using the "pivot biggest" random
'number generator with an array size of 42000).

'The big stack size of VB programs such would allow for big stack depth limits, but it
'would not be wise to really use them. The program execution would be safe (no out
'of stack errors), but sorting would slow down very much if such high stack depths
'are hit. So it is better to choose a smaller value for the limit, which on the other
'side is sufficiently high so it will not be reached in most cases.

'And even if the stack depth limit is set to a too small value, such having the limiting in
'effect often (instead of quicksort the alternative sorts are called on subarrays), this
'would not do much harm as the alternative sorts used are quite fast too. The insertion
'sort on small subarrays is nearly as fast as the quicksort. The heap sort always has
'order of sort O(n*log(n)) which is the normal case for quicksort (not the best case),
'but is slower in execution. However it will be called really only when the partition algo
'heavily degenerates and this is very, very unlikely.

'So the conclusion is: a sufficient large value for the stack depth limit, when sorting
'arrays up to one million elements, should be about 60. In practice, when using this
'program sorting up to 1 million elements, I never reached a stack depth of 60, except you
'choose those degenerating number distributions. And quick sort remains (excluding the
'counting sorts) the overall quickest sort of all.

Private Sub QuickSortDFast(ByRef A() As Long, _
                           ByVal L As Long, _
                           ByVal H As Long, _
                           ByVal MAXSTACKDEPTH As Long)

Const INSERTIONSORT_CUTOFF As Long = 16 'use Insertionsort for array parts having 16 or fewer elements
Dim LP As Long, HP As Long
Dim t As Long, PIV As Long '*** Adapt!

MAXSTACKDEPTH = MAXSTACKDEPTH - 1

If MAXSTACKDEPTH = 0 Then

  If (H - L) < INSERTIONSORT_CUTOFF Then
    InsertionSortFast A, L, H
  Else
    HeapSortFast A, L, H
  End If

Else

  PIV = A((L + H) \ 2): LP = L: HP = H
  
  Do
    While (A(LP) < PIV): LP = LP + 1: Wend
    While (PIV < A(HP)): HP = HP - 1: Wend
    If LP <= HP Then
      If LP < HP Then t = A(LP): A(LP) = A(HP): A(HP) = t
      LP = LP + 1: HP = HP - 1
    End If
  Loop While (LP <= HP)
  
  If HP > L Then QuickSortDFast A(), L, HP, MAXSTACKDEPTH
  If LP < H Then QuickSortDFast A(), LP, H, MAXSTACKDEPTH

End If

End Sub


'**************************************************
'* Counting Sort RealSwap   O(n) stable
'* Counting Sort PseudoSwap O(n) instable?
'**************************************************

'----------

'Following two implementations of the counting sort algorithm.

'Counting sorts are in general of order O(n) as they do not make comparisons,
'such being blindingly fast. The price one has to pay is higher memory consumption
'and they can be used for sorting of integral numeric values only (if a map-function is
'available other types can be sorted too, see below).

'Their run time behaviour also depends on the range of values (the difference
'between the lowest and greatest value) in the array to be sorted. The best case
'is a range of 1 (all values equal), a reasonable good range is a range nearly
'equal to the number of array elements, a bad range is much greater than the number
'of array elements. For example lets take a to be sorted array which has two elements
'with the values 1 and 100'000'000. This results in a range of 100 millions. The
'auxiliary counting array C() then must be big enough to hold 100 millions of entries.
'This will not please your computers memory and the runtime greatly slows down as at
'least once it must be iterated over the complete counting array which means a loop
'running 100 million times for an array to be sorted which has two elements.

'Therefore counting sorts should not be used on arrays of bad range.
'For this reason in this programm all array modes delivering bad ranges (those
'with the prefix "D") are not allowed in combination with counting sorts.

'----------

'CountingSortRealSwap is general purpose, stable sort. There can be sorted
'any types including strings and structs, if a function map(A(),i) can be provided
'which can map an array element A(i) to an integral number representing the
'sorting order.

'For example sorting strings with only the first four characters of the string
'used for sorting could be done with:

'Function map(ByRef A() as String, ByVal I as Long) as Long
'dim s as string
's = A(i)
'map = asc(mid(s,1,1)) * 128^3 + asc(mid(s,2,1)) * 128^2 +
'      asc(mid(s,3,1)) * 128 + asc(mid(s,4,1))
'End Function

'assuming individual charactervalues are lower than 128 and setting
'asc(mid(s,n,1)) to zero if character is not present

'Or sorting structure TmyType for TmyType.a:

'Type TmyType
'a as Long
'b as String
'End Type

'Use A(i).a for sorting, A(i) for swapping (which means map(A(),I) would return
'A(I).a.

'Example code for using a map function for sorting strings (of course it would be
'better to do the mapping once and store the results in a separate array!):

'----------------------------------------------------------------------------------

'Private Function Map(ByRef Element As String) As Long
''Map = ....
'End Function
'
'Private Sub CountingSortRealSwapMappedFast(ByRef A() As String, _
'                                           ByVal L As Long, _
'                                           ByVal H As Long)
'
'Dim I As Long, Min As Long, Max As Long, T As Long
'Dim B() As String
'Dim C() As Long
'
'ReDim B(1 To (H - L + 1))
'Min = Map(A(L)): Max = Min
'For I = L + 1 To H
'  T = Map(A(I))
'  If Min > T Then Min = T
'  If Max < T Then Max = T
'Next I
'ReDim C(Min To Max)
'
'For I = L To H
'  T = Map(A(I))
'  C(T) = C(T) + 1
'Next I
'
'For I = Min + 1 To Max
'  C(I) = C(I) + C(I - 1)
'Next I
'
'For I = H To L Step -1
'  T = Map(A(I))
'  B(C(T)) = A(I)
'  C(T) = C(T) - 1
'Next I
'
'For I = L To H
'  A(I) = B(I - L + 1)
'Next I
'
'End Sub

'----------------------------------------------------------------------------------

'Sizes of the auxiliary arrays:

'Size(B) = Size(A)
'Size(C) = Max(A) - Min(A) + 1

Private Sub CountingSortRealSwapFast(ByRef A() As Long, _
                                     ByVal L As Long, _
                                     ByVal H As Long)

Dim i As Long, Min As Long, Max As Long
Dim B() As Long
Dim c() As Long

Min = A(L): Max = A(L)
For i = L + 1 To H
  If A(i) < Min Then Min = A(i)
  If Max < A(i) Then Max = A(i)
Next i
ReDim c(Min To Max)
ReDim B(1 To (H - L + 1))

For i = L To H
  c(A(i)) = c(A(i)) + 1
Next i

For i = Min + 1 To Max
  c(i) = c(i) + c(i - 1)
Next i

For i = H To L Step -1
  B(c(A(i))) = A(i)
  c(A(i)) = c(A(i)) - 1
Next i

For i = L To H
  A(i) = B(i - L + 1)
Next i

End Sub

'CountingSortPseudoSwap works like CountingSortRealSwap except that it does no
'real swaps and therefore can only sort integral numeric values, but this
'faster than CountingSortRealSwap!
'Sizes of the auxiliary array:
'Size(C) = Max(A) - Min(A) + 1

Private Sub CountingSortPseudoSwapFast(ByRef A() As Long, _
                                       ByVal L As Long, _
                                       ByVal H As Long)

Dim i As Long, j As Long, Min As Long, Max As Long
Dim c() As Long

Min = A(L): Max = A(L)
For i = L + 1 To H
  If A(i) < Min Then Min = A(i)
  If Max < A(i) Then Max = A(i)
Next i
ReDim c(Min To Max)

For i = L To H
  c(A(i)) = c(A(i)) + 1
Next i

For i = Min To Max
  If c(i) > 0 Then
    For j = 1 To c(i)
      A(L) = i: L = L + 1
    Next j
  End If
Next i

End Sub


c0Title: A Comparison of Sorting Algorithms
c2File: TableImages.zip
c1Code:
http://www.devx.com/vb2themax/Article/19900

A Comparison of Sorting Algorithms

Methods for sorting have been intensively studied and optimized. Nevertheless, many poor algorithms (or poor versions of good algorithms) are still in circulation. VB2TheMax's friend David B. Ring have translated a variety of sorting routines into Visual Basic and compared their performance. The collection includes some of the faster algorithms known (e.g., QuickSort, RadixSort and Merge-Sort) and incorporates many optimizations known to increase speed and/or consistency. In this article he discusses and compares the various sorting methods, and provides code to use them in your own applications.

by David B. Ring

January 13, 2003

Methods for sorting have been intensively studied and optimized. Nevertheless, many poor algorithms (or poor versions of good algorithms) are still in circulation. Recently, I have translated a variety of sorting routines into Visual Basic and compared their performance. The collection includes some of the faster algorithms known (e.g., QuickSort, RadixSort and Merge-Sort) and incorporates many optimizations known to increase speed and/or consistency. On an 800 mhz PowerBook running the VBA routines in Excel 2001, I observe sorting speeds as high as a million random strings or doubles per minute (Table 1). I hope you will find the code for these sorts useful and interesting.

(See attached table image 1)

What makes a good sorting algorithm? Speed is probably the top consideration, but other factors of interest include versatility in handling various data types, consistency of perform-ance, memory requirements, length and complexity of code, and the property of stability (preserving the original order of records that have equal keys). As you may guess, no single sort is the winner in all categories simultaneously (Table 2).

(See attached table image 2)

Let's start with speed, which breaks down into "order" and "overhead". When we talk about the order of a sort, we mean the relationship between the number of keys to be sorted and the time required. The best case is O(N); time is linearly proportional to the number of items. We can't do this with any sort that works by comparing keys; the best such sorts can do is O(N log N), but we can do it with a RadixSort, which doesn't use comparisons. Many simple sorts (Bubble, Insertion, Selection) have O(N^2) behavior, and should never be used for sorting long lists. But what about short lists? The other part of the speed equation is overhead resulting from complex code, and the sorts that are good for long lists tend to have more of it. For short lists of 5 to 50 keys or for long lists that are almost sorted, Insertion-Sort is extremely efficient and can be faster than finishing the same job with QuickSort or a RadixSort. Many of the routines in my collection are "hybrids", with a version of InsertionSort finishing up after a fast algorithm has done most of the job.

The third aspect of speed is consistency. Some sorts always take the same amount of time , but many have "best case" and "worst case" performance for particular input orders of keys. A famous example is QuickSort, generally the fastest of the O(N log N) sorts, but it always has an O(N^2) worst case. It can be tweaked to make this worst case very unlikely to occur, but other O(N log N) sorts like HeapSort and MergeSort remain O(N log N) in their worst cases. QuickSort will almost always beat them, but occasionally they will leave it in the dust.

Along with worst cases, the nature of keys can also dramatically affect the speed (and the relative speed) of sorts. This is especially true for string keys, which can vary significantly in length and relatedness. Longer keys take longer to copy or compare, and highly related keys take longer to compare because we have to examine more digits before finding a difference. Two sorts may run neck and neck on short keys, but if one is more efficient in doing fewer comparisons or moves, the difference on longer keys may be dramatic. Likewise, a sort that manipulates pointers to long keys can be far faster than one that moves the keys themselves.

Speed is usually the largest issue, but certainly not the only one. If you're sorting a very large number of keys, having enough memory may still be an issue, and methods that sort "in place" (i.e., without extra room) will be more desirable than those that use a duplicate array (e.g. MergeSort) or those that use a significant amount of stack space for recursive calls. The length of the sorting algorithms themselves is not much of an issue today, but there is considerable variation, and short, simple algorithms are appealing and easy to maintain. Similarly, algorithms that can easily be applied to all data types (strings, integers, longs, doubles, etc.) are convenient, although they may not be as fast as more specialized algorithms focused on a single data type.

A final issue is "stability" or the ability to preserve the original order of records that have equal keys. Some sorts have it (Insertion, Selection, Bubble, Merge, Radix, Ternary Quick) and others don't (Shell, Comb, Heap, Quick). If you want to sequentially sort records on multiple fields, you'll need it.

This article comes with nine sorting algorithms in VB: Selection, Insertion, Shell, Comb, Heap, Merge, Quick, Multi-Key Quick and MSD Radix. If I could choose only one of these, it would be MergeSort, because it is quite fast, stable, readily adapts to all data types and never behaves worse than O(N log N). QuickSort is often faster and just as adaptable, but is not stable; the well-tuned version described by Robert Sedgewick and included here is highly unlikely to actually show O(N^2) worst case behavior. Next on my list would be MSD RadixSort; this one is specialized for strings, but it's O(N) linear behavior will make it faster than anything else if you have millions of strings to sort (and it's stable). Ternary QuickSort can also be very fast, but may shine better in languages like C that offer faster byte-level access to strings. Finally, HeapSort is compact in both code length and memory demands, adaptable to all data types and never worse than O(N log N). Although I include Comb, Shell and SelectionSort, I think they are outclassed by the sorts mentioned above, and I include InsertionSort as an auxiliary to Merge, Quick and Radix, and not for independent usage.

Except for MSD RadixSort and Ternary QuickSort (which are specialized for strings), I provide two versions of each sort�a "pointerized" version set up for strings and a "direct" version set up for longs. For example, pMergeSortS is a pointerized sort for strings and MergeSortL is its direct counterpart for longs. The direct versions rearrange the keys themselves, while the pointerized versions leave the keys in their original positions and only rearrange pointers. The pointer approach saves time for strings and doubles�data types that are longer than 4 byte pointers. The direct approach is just as fast or faster for short data types like integers, longs or singles. To adapt a string version to handle doubles or a long version to handle integers or singles, just change the declaration of the array that holds the keys.

Along with the sorts, I include a SortBase file containing a number of support routines for generating, listing or loading sets of random strings, longs and doubles. SortBase also contains global constants and arrays used by the sorts, and examples of timing routines for testing them. More details, references, usage hints and commented VB code are found in the files for each sort. Enjoy.

SortBase - Support sorting routines http://www.devx.com/vb2themax/Tip/19477
Code and details for CombSort http://www.devx.com/vb2themax/Tip/19467
Code and details for HeapSort http://www.devx.com/vb2themax/Tip/19468
Code and details for InsertionSort http://www.devx.com/vb2themax/Tip/19469
Code and details for MergeSort http://www.devx.com/vb2themax/Tip/19470
Code and details for MSD RadixSort http://www.devx.com/vb2themax/Tip/19471
Code and details for QuickSort http://www.devx.com/vb2themax/Tip/19472
Code and details for SelectionSort http://www.devx.com/vb2themax/Tip/19473
Code and details for ShellSort http://www.devx.com/vb2themax/Tip/19474
Code and details for ShuttleMergeSort http://www.devx.com/vb2themax/Tip/19475
Code and details for Ternary QuickSort http://www.devx.com/vb2themax/Tip/19476


c0Title: Comb Sort
c1Code:
The main problem with the bubblesort is something called the rabbit-turtle effect. Large values at the bottom bubble up very quickly (rabbits) but small values at the top take many many passes to sink (turtles). The comb sort overcomes this by comparing non-adjacent values. This means turtles have the chance to jump down the list much quicker. We repeat the process with smaller and smaller spacings until we finish with a simple bubblesort.

Example:

Array of data [6,7,9,3,2,5]

[6,7,9,3,2,5]
^ Potential turtle

Combing pass with a spacing of 4
[6,7,9,3,2,5]
[2,7,9,3,6,5]

Combing pass with a spacing of 3
[2,5,9,3,6,7]
[2,5,9,3,6,7]
[2,5,9,3,6,7]

Combing pass with a spacing of 2
[2,5,7,3,6,9]
[2,5,7,3,6,9]
[2,3,7,5,6,9]
[2,3,6,5,7,9]

Combing pass with a spacing of 1
[2,3,6,5,7,9]
[2,3,6,5,7,9]
[2,3,6,5,7,9]
[2,3,5,6,7,9]
[2,3,5,6,7,9]

Finish [2,3,5,6,7,9]

If you trawl the web for a bit you'll find this sort, like every other, has been well studied. It has been found that if the spacing ever reaches 11, the remaining few passes are much more efficient than if 9 or 10 are used. The result is often called the Comb11 Sort:

Public Sub CombSort(ByRef lngArray() As Long)
    Dim iSpacing As Long
    Dim iOuter As Long
    Dim iInner As Long
    Dim iTemp As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iArrSize As Long
    Dim iFinished As Long
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    
    'Initialise comb width
    iSpacing = iUBound - iLBound
    
    Do
        If iSpacing > 1 Then
            iSpacing = Int(iSpacing / 1.3)
            
            If iSpacing = 0 Then
                iSpacing = 1  'Dont go lower than 1
            ElseIf iSpacing > 8 And iSpacing < 11 Then
                iSpacing = 11 'This is a special number, goes faster than 9 and 10
            End If
        End If
        
        'Always go down to 1 before attempting to exit
        If iSpacing = 1 Then iFinished = 1
        
        'Combing pass
        For iOuter = iLBound To iUBound - iSpacing
            iInner = iOuter + iSpacing
            
            If lngArray(iOuter) > lngArray(iInner) Then
                'Swap
                iTemp = lngArray(iOuter)
                lngArray(iOuter) = lngArray(iInner)
                lngArray(iInner) = iTemp
                
                'Not finished
                iFinished = 0
            End If
        Next iOuter
        
    Loop Until iFinished
End Sub


c0Title: Count Sort, a special case of indexed sort
c1Code:
CountSort is yet another sort algorithm, which can be applied only under very particular conditions but that, when such conditions are met, turns to be the fastest of the lot. Count Sort can be used when the key is of Integer type, or when it is of Long type but the range of values is not too large.
The idea underlying the algorithm is that each key data can indirectly work an initial index for itself. The routine parses the original array determining its minimum and maximum value, then builds a temporary array of Long with one element for each possible value of the key. The routine parses the original array again, this time counting the occurrences of each distinct value. After this step, it is very easy to evaluate where each value has to go in the definitive, sorted array, and this can be accomplished in the third step. Here is the complete routine:

Sub NdxCountSortI(arr() As Integer, ndx() As Long, Optional ByVal numEls As _
    Variant)
    Dim index As Long
    Dim inverseOrder As Boolean
    Dim value As Integer
    Dim minValue As Integer
    Dim maxValue As Integer
    Dim saveCount As Integer
    Dim newIndex As Long

    ' account for optional arguments
    If IsMissing(numEls) Then numEls = UBound(arr)

    ' search min and max value
    minValue = arr(LBound(arr))
    maxValue = minValue
    For index = LBound(arr) To numEls
        value = arr(index)
        If value < minValue Then
            minValue = value
        ElseIf value > maxValue Then
            maxValue = value
        End If
    Next

    ' declare the temporary index arr
    ReDim Count(minValue To maxValue) As Long
    ' fill each item of the temporary arr with
    ' number of occurrences for that value
    For index = LBound(arr) To numEls
        value = arr(index)
        Count(value) = Count(value) + 1
    Next

    ' parse the count() array to replace the count
    ' value with the definitive position
    ' in the sorted array
    newIndex = LBound(ndx)
    For index = minValue To maxValue
        saveCount = Count(index)
        Count(index) = newIndex
        newIndex = newIndex + saveCount
    Next

    ' finally build the index
    For index = LBound(arr) To numEls
    ' get position of the item in the index
        newIndex = Count(arr(index))
        ' remember the original position
        ndx(newIndex) = index
        ' next time store value in subsequent item
        Count(arr(index)) = newIndex + 1
    Next
End Sub


The most interesting detail on this sorting algorithm is that its total time is proportional to the number of items to be sorted, therefore is even more convenient than Quick Sort, whose processing time grows proportionally to N * Log2(N). When sorting 10,000 items, Count Sort is 2.5 faster than Quick Sort, and is about five times faster when sorting one hundred thousand values.

Francesco Balena


c0Title: SortBase - Support sorting routines
c1Code:
Language: VB5, VB6
January 13, 2003

Option Explicit
Option Compare Binary
Option Base 1

Public Type TRIAL
    nKEYS As Long
    nITS As Integer
    PT As Long
    TT As Long
    ST As Long
End Type

Public Const RAD = 1
Public Const TQK = 2
Public Const QUI = 3
Public Const MER = 4
Public Const HEA = 5
Public Const COM = 6
Public Const SHE = 7
Public Const INS = 8
Public Const SEL = 9

Public Const LNG = 1
Public Const DBL = 2
Public Const STR = 3

Public Const MinDbl = -1.7976931348623E+308
Public Const MaxDbl = 1.7976931348623E+308

Public Const MinLng = -2147483647
Public Const MaxLng = 2147483647

Public Const MinStr = "                           "
Public Const MaxStr = "???????????????"

Public TIMES(LNG To STR, RAD To SEL, 1 To 8) As TRIAL

Public L0() As Long         'buffer for unsorted longs
Public L1() As Long         'buffer for sorted longs
Public L2() As Long         'extra buffer used by MergeSort

Public D() As Double        'buffer for unsorted doubles
Public pD0() As Long        'buffer for unsorted pointers to doubles

Public S() As String        'buffer for unsorted strings
Public pS0() As Long       'buffer for unsorted pointers to strings

Public B() As Byte           'buffers used by TernaryQuickSort & MSDRadixSort
Public pB() As Long

Public P() As Long         'buffer used for sorted pointers

Public RAW_LNGS As Range
Public SORTED_LNGS As Range

Public RAW_DBLS As Range
Public SORTED_DBLS As Range

Public RAW_STRS As Range
Public SORTED_STRS As Range

Public RESULTS As Range

Public NAMES
Public ROW As Integer

Sub TrySorts()
    Dim NK
    Dim ITS
    Dim ITS2
    Dim LEVEL As Integer
    Dim SORT As Integer
    Dim nKEYS As Long
    Dim nITS As Integer
    Dim nITS2 As Integer
    Dim T As Long
    Dim tL As Long
    Dim tD As Long
    Dim tS As Long
    Dim tB As Long
    Dim tL2 As Long
    Dim tD2 As Long
    Dim tS2 As Long
    Dim I As Integer
    
    NK = Array(150, 500, 1500, 5000, 15000, 50000, 150000, 500000)
    ITS = Array(3000, 1000, 300, 100, 30, 10, 3, 1)
    ITS2 = Array(2000, 200, 20, 2, 0, 0, 0, 0)
    NAMES = Array("RadixSort", "TernQuickSort", "QuickSort", "MergeSort", _
        "HeapSort", "CombSort", "ShellSort", "InsertionSort", "SelectionSort")
    
    Say "Setting up ranges."
    Set RAW_LNGS = Cells(2, 1).Resize(50, 1)
    Set SORTED_LNGS = Cells(2, 2).Resize(50, 1)
    Set RAW_DBLS = Cells(2, 3).Resize(50, 1)
    Set SORTED_DBLS = Cells(2, 4).Resize(50, 1)
    Set RAW_STRS = Cells(2, 5).Resize(50, 1)
    Set SORTED_STRS = Cells(2, 6).Resize(50, 1)
    Set RESULTS = Cells(2, 8).Resize(1000, 8)
    
    RAW_LNGS.Clear
    SORTED_LNGS.Clear
    RAW_DBLS.Clear
    SORTED_DBLS.Clear
    RAW_STRS.Clear
    SORTED_STRS.Clear
    RESULTS.Clear
    
    Cells(1, 1).Value = "raw lngs"
    Cells(1, 2).Value = "sorted lngs"
    Cells(1, 3).Value = "raw dbls"
    Cells(1, 4).Value = "sorted dbls"
    Cells(1, 5).Value = "raw strs"
    Cells(1, 6).Value = "sorted strs"
    
    Cells(1, 8).Value = "sort"
    Cells(1, 9).Value = "type"
    Cells(1, 10).Value = "# of keys"
    Cells(1, 11).Value = "repeats"
    Cells(1, 12).Value = "prep time"
    Cells(1, 13).Value = "total time"
    Cells(1, 14).Value = "sort time"
    Cells(1, 15).Value = "time/rep"
    
    Say "Dimensioning arrays."
    ReDim L0(0 To 500001)
    ReDim L1(0 To 500001)
    ReDim L2(0 To 500001)
    
    ReDim D(0 To 500001)
    ReDim pD0(0 To 500001)
    
    ReDim S(0 To 500001)
    ReDim pS0(0 To 500001)
    
    ReDim B(0 To 5000001)
    ReDim pB(0 To 500001)
    
    ReDim P(0 To 500001)
    
    ROW = 1
    For LEVEL = 4 To 8
        Say "Level " & CStr(LEVEL)
        nKEYS = CLng(NK(LEVEL))
        nITS = CInt(ITS(LEVEL))
        nITS2 = CInt(ITS2(LEVEL))
        
        Say "Measuring long prep times."
        GetRndLngs nKEYS, L0
        ListLngs RAW_LNGS, L0, 50
        ACopyL 1, nKEYS, L0, L1
        T = Timer
        For I = 1 To nITS
            ACopyL 1, nKEYS, L0, L1
        Next I
        tL = Timer - T
        T = Timer
        For I = 1 To nITS2
            ACopyL 1, nKEYS, L0, L1
        Next I
        tL2 = Timer - T
        
        Say "Measuring double prep times."
        GetRndDbls nKEYS, D, pD0
        pListDbls RAW_DBLS, D, pD0, 50
        ACopyL 1, nKEYS, pD0, P
        T = Timer
        For I = 1 To nITS
            ACopyL 1, nKEYS, pD0, P
        Next I
        tD = Timer - T
        T = Timer
        For I = 1 To nITS2
            ACopyL 1, nKEYS, pD0, P
        Next I
        tD2 = Timer - T
        
        Say "Measuring string prep times."
        GetRndStrs nKEYS, 10, S, pS0
        pListStrs RAW_STRS, S, pS0, 50
        ACopyL 1, nKEYS, pS0, P
        T = Timer
        For I = 1 To nITS
            ACopyL 1, nKEYS, pS0, P
        Next I
        tS = Timer - T
        T = Timer
        For I = 1 To nITS2
            ACopyL 1, nKEYS, pS0, P
        Next I
        tS2 = Timer - T
        Strs2Bytes S, 1, nKEYS, B, pB
        T = Timer
        For I = 1 To nITS
            Strs2Bytes S, 1, nKEYS, B, pB
        Next I
        tB = Timer - T
        
        For SORT = RAD To SEL
            Select Case SORT
                Case RAD
                    RunSortB RAD, LEVEL, nKEYS, nITS, tB
                Case TQK
                    RunSortB TQK, LEVEL, nKEYS, nITS, tB
                Case QUI
                    RunSortL QUI, LEVEL, nKEYS, nITS, tL
                    RunSortD QUI, LEVEL, nKEYS, nITS, tD
                    RunSortS QUI, LEVEL, nKEYS, nITS, tS
                Case MER
                    RunSortL MER, LEVEL, nKEYS, nITS, tL
                    RunSortD MER, LEVEL, nKEYS, nITS, tD
                    RunSortS MER, LEVEL, nKEYS, nITS, tS
                Case HEA
                    RunSortL HEA, LEVEL, nKEYS, nITS, tL
                    RunSortD HEA, LEVEL, nKEYS, nITS, tD
                    RunSortS HEA, LEVEL, nKEYS, nITS, tS
                Case COM
                    RunSortL COM, LEVEL, nKEYS, nITS, tL
                    RunSortD COM, LEVEL, nKEYS, nITS, tD
                    RunSortS COM, LEVEL, nKEYS, nITS, tS
                Case SHE
                    RunSortL SHE, LEVEL, nKEYS, nITS, tL
                    RunSortD SHE, LEVEL, nKEYS, nITS, tD
                    RunSortS SHE, LEVEL, nKEYS, nITS, tS
                Case INS
                    If LEVEL < 5 Then
                        RunSortL INS, LEVEL, nKEYS, nITS2, tL2
                        RunSortD INS, LEVEL, nKEYS, nITS2, tD2
                        RunSortS INS, LEVEL, nKEYS, nITS2, tS2
                    End If
                Case SEL
                    If LEVEL < 5 Then
                        RunSortL SEL, LEVEL, nKEYS, nITS2, tL2
                        RunSortD SEL, LEVEL, nKEYS, nITS2, tD2
                        RunSortS SEL, LEVEL, nKEYS, nITS2, tS2
                    End If
            End Select
            Cells(2, 1).Resize(1000, 15).Select
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            Cells(ROW, 1).Select
        Next SORT
        ROW = ROW + 1
        Say "Waiting for possible break."
        Beep
        WaitFor 5
     Next LEVEL
End Sub

Sub WaitFor(NSECS As Long)
    Dim TZERO As Long
            
    TZERO = Timer
    Do While Timer < TZERO + NSECS
        DoEvents
    Loop
End Sub

Sub RunSortL(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _
    PT As Long)
    Dim T As Long
    Dim I As Integer
    
    SORTED_LNGS.Clear
    Say NAMES(SORT) & " longs"
    
    Select Case SORT
        Case INS
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, L0, L1
                InsertL 1, nKEYS, L1
            Next I
        Case SEL
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, L0, L1
                SelectionSortL 1, nKEYS, L1
            Next I
        Case SHE
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, L0, L1
                ShellSortL 1, nKEYS, L1
            Next I
        Case COM
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, L0, L1
                CombSortL 1, nKEYS, L1
            Next I
        Case HEA
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, L0, L1
                HeapSortL 1, nKEYS, L1
            Next I
        Case MER
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, L0, L1
                MergeSortL 1, nKEYS, L1, L2
            Next I
        Case QUI
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, L0, L1
                QuickSortL 1, nKEYS, L1
            Next I
    End Select
    
    With TIMES(LNG, SORT, LEVEL)
        .nKEYS = nKEYS
        .nITS = nITS
        .PT = PT
        .TT = Timer - T
        .ST = .TT - .PT
        ListLngs SORTED_LNGS, L1, 50
        RESULTS(ROW, 1).Value = NAMES(SORT)
        RESULTS(ROW, 2).Value = "long"
        RESULTS(ROW, 3).Value = nKEYS
        RESULTS(ROW, 4).Value = nITS
        RESULTS(ROW, 5).Value = .PT
        RESULTS(ROW, 6).Value = .TT
        RESULTS(ROW, 7).Value = .ST
        RESULTS(ROW, 8).Value = CDbl(.ST) / nITS
    End With
    ROW = ROW + 1
End Sub

Sub RunSortD(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _
    PT As Long)
    Dim T As Long
    Dim I As Integer
    
    SORTED_DBLS.Clear
    Say NAMES(SORT) & " doubles"
    
    Select Case SORT
        Case INS
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pD0, P
                pInsertD 1, nKEYS, D, P
            Next I
        Case SEL
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pD0, P
                pSelectionSortD 1, nKEYS, D, P
            Next I
        Case SHE
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pD0, P
                pShellSortD 1, nKEYS, D, P
            Next I
        Case COM
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pD0, P
                pCombSortD 1, nKEYS, D, P
            Next I
        Case HEA
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pD0, P
                pHeapSortD 1, nKEYS, D, P
            Next I
        Case MER
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pD0, P
                pMergeSortD 1, nKEYS, D, P, L2
            Next I
        Case QUI
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pD0, P
                pQuickSortD 1, nKEYS, D, P
            Next I
    End Select
    
    With TIMES(DBL, SORT, LEVEL)
        .nKEYS = nKEYS
        .nITS = nITS
        .PT = PT
        .TT = Timer - T
        .ST = .TT - .PT
        pListDbls SORTED_DBLS, D, P, 50
        RESULTS(ROW, 1).Value = NAMES(SORT)
        RESULTS(ROW, 2).Value = "double"
        RESULTS(ROW, 3).Value = nKEYS
        RESULTS(ROW, 4).Value = nITS
        RESULTS(ROW, 5).Value = .PT
        RESULTS(ROW, 6).Value = .TT
        RESULTS(ROW, 7).Value = .ST
        RESULTS(ROW, 8).Value = CDbl(.ST) / nITS
    End With
    ROW = ROW + 1
End Sub

Sub RunSortS(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _
    PT As Long)
    Dim T As Long
    Dim I As Integer
    
    SORTED_STRS.Clear
    Say NAMES(SORT) & " strings"
    
    Select Case SORT
        Case INS
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pS0, P
                pInsertS 1, nKEYS, S, P
            Next I
        Case SEL
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pS0, P
                pSelectionSortS 1, nKEYS, S, P
            Next I
        Case SHE
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pS0, P
                pShellSortS 1, nKEYS, S, P
            Next I
        Case COM
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pS0, P
                pCombSortS 1, nKEYS, S, P
            Next I
        Case HEA
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pS0, P
                pHeapSortS 1, nKEYS, S, P
            Next I
        Case MER
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pS0, P
                pMergeSortS 1, nKEYS, S, P, L2
            Next I
        Case QUI
            T = Timer
            For I = 1 To nITS
                ACopyL 1, nKEYS, pS0, P
                pQuickSortS 1, nKEYS, S, P
            Next I
    End Select
    
    With TIMES(DBL, SORT, LEVEL)
        .nKEYS = nKEYS
        .nITS = nITS
        .PT = PT
        .TT = Timer - T
        .ST = .TT - .PT
        pListStrs SORTED_STRS, S, P, 50
        RESULTS(ROW, 1).Value = NAMES(SORT)
        RESULTS(ROW, 2).Value = "string"
        RESULTS(ROW, 3).Value = nKEYS
        RESULTS(ROW, 4).Value = nITS
        RESULTS(ROW, 5).Value = .PT
        RESULTS(ROW, 6).Value = .TT
        RESULTS(ROW, 7).Value = .ST
        RESULTS(ROW, 8).Value = CDbl(.ST) / nITS
    End With
    ROW = ROW + 1
End Sub

Sub RunSortB(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _
    PT As Long)
    Dim T As Long
    Dim I As Integer
    
    SORTED_STRS.Clear
    Say NAMES(SORT) & " strings"
    
    Select Case SORT
        Case RAD
            T = Timer
            For I = 1 To nITS
                Strs2Bytes S, 1, nKEYS, B, pB
                pRadixSortS B, pB, nKEYS
            Next I
        Case TQK
            T = Timer
            For I = 1 To nITS
                Strs2Bytes S, 1, nKEYS, B, pB
                pTernaryQuickSortS 1, nKEYS, B, pB
            Next I
    End Select
    
    With TIMES(STR, SORT, LEVEL)
        .nKEYS = nKEYS
        .nITS = nITS
        .PT = PT
        .TT = Timer - T
        .ST = .TT - .PT
        pListBytes SORTED_STRS, B, pB, nKEYS, 50
        RESULTS(ROW, 1).Value = NAMES(SORT)
        RESULTS(ROW, 2).Value = "string"
        RESULTS(ROW, 3).Value = nKEYS
        RESULTS(ROW, 4).Value = nITS
        RESULTS(ROW, 5).Value = .PT
        RESULTS(ROW, 6).Value = .TT
        RESULTS(ROW, 7).Value = .ST
        RESULTS(ROW, 8).Value = CDbl(.ST) / nITS
    End With
    ROW = ROW + 1
End Sub

Sub Say(S As String)
    Application.DisplayStatusBar = True
    Application.StatusBar = S
End Sub

Sub LoadLngs(BLK As Range, A() As Long, N As Long)
    Dim ROW As Long
    Dim COL As Integer
    Dim V
    
    N = BLK.Columns.COUNT * BLK.Rows.COUNT
    If UBound(A) < N + 1 Then ReDim A(0 To N + 1)
    A(0) = MinLng
    N = 1
    For COL = 1 To BLK.Columns.COUNT
        For ROW = 1 To BLK.Rows.COUNT
            V = BLK(ROW, COL).Value
            If Not IsEmpty(V) Then
                A(N) = CLng(V)
                N = N + 1
                If N Mod 10000 = 0 Then Say CStr(N) & " longs loaded"
            End If
        Next ROW
    Next COL
    A(N) = MaxLng
End Sub

Sub ListLngs(BLK As Range, A() As Long, ByVal N As Long, _
    Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1)
    Dim I As Long
    Dim ROW As Long
    Dim COL As Integer
    
    For I = 1 To N
        ROW = I Mod MAXROWS
        If ROW = 0 Then
            ROW = MAXROWS
        ElseIf ROW = 1 Then
            COL = COL + 1
            If COL > MAXCOLS Then Exit Sub
        End If
        BLK(ROW, COL).Value = A(I)
        If I Mod 10000 = 0 Then Say CStr(I) & " longs listed"
    Next I
End Sub

Sub LoadDbls(BLK As Range, A() As Double, P() As Long, N As Long)
    Dim ROW As Long
    Dim COL As Integer
    Dim V
    
    N = BLK.Columns.COUNT * BLK.Rows.COUNT
    If UBound(A) < N + 1 Then ReDim A(0 To N + 1)
    A(0) = MinDbl
    N = 1
    For COL = 1 To BLK.Columns.COUNT
        For ROW = 1 To BLK.Rows.COUNT
            V = BLK(ROW, COL).Value
            If Not IsEmpty(V) Then
                A(N) = CDbl(V)
                P(N) = N
                N = N + 1
                If N Mod 10000 = 0 Then Say CStr(N) & " doubles loaded"
            End If
        Next ROW
    Next COL
    A(N) = MaxDbl
End Sub

Sub pListDbls(BLK As Range, A() As Double, P() As Long, ByVal N As Long, _
    Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1)
    Dim I As Long
    Dim ROW As Long
    Dim COL As Integer
    
    For I = 1 To N
        ROW = I Mod MAXROWS
        If ROW = 0 Then
            ROW = MAXROWS
        ElseIf ROW = 1 Then
            COL = COL + 1
            If COL > MAXCOLS Then Exit Sub
        End If
        BLK(ROW, COL).Value = A(P(I))
        If I Mod 10000 = 0 Then Say CStr(I) & " doubles listed"
    Next I
End Sub

Sub LoadStrs(BLK As Range, A() As String, P() As Long, N As Long)
    Dim ROW As Long
    Dim COL As Integer
    Dim V
    
    N = BLK.Columns.COUNT * BLK.Rows.COUNT
    If UBound(A) < N + 1 Then ReDim A(0 To N + 1)
    A(0) = MinStr
    N = 1
    For COL = 1 To BLK.Columns.COUNT
        For ROW = 1 To BLK.Rows.COUNT
            V = BLK(ROW, COL).Value
            If Not IsEmpty(V) Then
                A(N) = CStr(V)
                P(N) = N
                N = N + 1
                If N Mod 10000 = 0 Then Say CStr(N) & " strings loaded"
            End If
        Next ROW
    Next COL
    A(N) = MaxStr
End Sub

Sub pListStrs(BLK As Range, A() As String, P() As Long, ByVal N As Long, _
    Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1)
    Dim I As Long
    Dim ROW As Long
    Dim COL As Integer
    
    For I = 1 To N
        ROW = I Mod MAXROWS
        If ROW = 0 Then
            ROW = MAXROWS
        ElseIf ROW = 1 Then
            COL = COL + 1
            If COL > MAXCOLS Then Exit Sub
        End If
        BLK(ROW, COL).Value = A(P(I))
        If I Mod 10000 = 0 Then Say CStr(I) & " strings listed"
    Next I
End Sub

Sub pListBytes(BLK As Range, B() As Byte, P() As Long, ByVal N As Long, _
    Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1)
    Dim I As Long
    Dim ROW As Long
    Dim COL As Integer
    Dim J As Long
    Dim S As String
    
    For I = 1 To N
        ROW = I Mod MAXROWS
        If ROW = 0 Then
            ROW = MAXROWS
        ElseIf ROW = 1 Then
            COL = COL + 1
            If COL > MAXCOLS Then Exit Sub
        End If
        S = ""
        J = P(I)
        Do
            S = S & Chr(B(J))
            J = J + 1
        Loop Until B(J) = 0
        BLK(ROW, COL).Value = S
        If I Mod 10000 = 0 Then Say CStr(I) & " strings listed"
    Next I
End Sub

Sub Strs2Bytes(A() As String, L As Long, R As Long, B() As Byte, P() As Long)
    Dim StrNum As Long
    Dim nPtrs As Long
    Dim nBytes As Long
    Dim DEPTH As Integer
    
    nBytes = 0
    nPtrs = 0
    For StrNum = L To R
        nBytes = nBytes + Strings.Len(A(StrNum)) + 1
        nPtrs = nPtrs + 1
    Next StrNum
    ReDim B(1 To nBytes)
    ReDim P(1 To nPtrs)
    
    nPtrs = 1
    nBytes = 1
    For StrNum = L To R
        P(nPtrs) = nBytes
        For DEPTH = 1 To Strings.Len(A(StrNum))
            B(nBytes) = Asc(Strings.MID(A(StrNum), DEPTH, 1))
            nBytes = nBytes + 1
        Next DEPTH
        B(nBytes) = 0
        nBytes = nBytes + 1
        nPtrs = nPtrs + 1
        If StrNum Mod 10000 = 0 Then Say CStr(StrNum) & " converted"
    Next StrNum
End Sub

Sub ACopyS(L As Long, R As Long, A() As String, B() As String)
    Dim I As Long
    
    For I = L To R
        B(I) = A(I)
    Next I
End Sub

Sub ACopyL(L As Long, R As Long, A() As Long, B() As Long)
    Dim I As Long
    
    For I = L To R
        B(I) = A(I)
    Next I
End Sub

Sub ACopyD(L As Long, R As Long, A() As Double, B() As Double)
    Dim I As Long
    
    For I = L To R
        B(I) = A(I)
    Next I
End Sub

Sub GetRndStrs(CNT As Long, LENGTH As Integer, A() As String, P() As Long)
    Dim I As Long
    Dim J As Integer
    Dim C As Integer
    Dim S As String
    
    Randomize
    ReDim A(0 To CNT + 1)
    For I = 1 To CNT
        S = ""
        For J = 1 To LENGTH
            C = (Rnd() * 2999) Mod 47
            If C < 10 Then
                C = C + 48
            ElseIf C = 46 Then
                C = 32
            Else
                C = C + 55
            End If
            If C > 90 Then
                If I < 1 Then Exit For
            Else
                S = S & Strings.Chr(C)
            End If
        Next J
        J = 1
        While Strings.MID(S, J, 1) = " "
            J = J + 1
        Wend
        A(I) = Strings.MID(S, J)
        P(I) = I
        If I Mod 1000 = 0 Then Say "GetRndStrs " & CStr(I)
    Next I
End Sub

Sub GetRndDbls(CNT As Long, A() As Double, P() As Long)
    Dim I As Long
    Dim D As Double
    
    Randomize
    ReDim A(0 To CNT + 1)
    For I = 1 To CNT
        D = CDbl(Exp(Rnd() * WorksheetFunction.LN(MaxDbl)))
        If Rnd < 0.5 Then A(I) = -D Else A(I) = D
        P(I) = I
    Next I
End Sub

Sub GetRndLngs(CNT As Long, A() As Long)
    Dim I As Long
    Dim L As Long
    
    Randomize
    ReDim A(0 To CNT + 1)
    For I = 1 To CNT
        L = CLng(Exp(Rnd() * WorksheetFunction.LN(MaxLng)))
        If Rnd < 0.5 Then A(I) = -L Else A(I) = L
    Next I
End Sub


David B. Ring


c0Title: CombSort - A compact routine that sorts data in place
c1Code:

' CombSort.  A compact routine that sorts data in place (no extra memory needed)
'  and runs in approximately O(N log N) time.  Not stable (does not preserve 
' original order of records with equal keys).  Like InsertionSort,
'  works by taking a key from the right side of the list and comparing it with 
' keys to the left until the correct position is found to insert it.  Differs 
' from InsertionSort (and resembles ShellSort) by moving leftward by interval 
' GAP instead of one key at a time.  GAP is initially large (to move keys close 
' to their final position rapidly) and is repeatedly reduced until it equals 1 
' and the list is sorted.  Rare sequences of keys may not fit the series of GAP 
' values, leading to slow sorting.  Two versions are given.  pCombSortS is an 
' indirect (pointerized) version for strings, which can be adapted to doubles 
' by changing the declaration of A().  CombSortL is a direct version for longs,
'  which can be adapted to integers.
'
' Reference:  Stephen Lacy and Richard Box, "A Fast, Easy Sort", Byte,
'  April 1991, p.315 ff.
'
' Speed:  pCombSortS sorts 500,000 random strings in 100 sec; sorts 100186 
' library call numbers in 16.5 sec; sorts 25479 dictionary words in 3.5 sec 
' (random order), 2.7 sec (presorted) or 2.9 sec (reverse sorted).  CombSortL 
' sorts 500,000 random longs in 52 seconds.  Timed in Excel 2001 on an 800 mhz 
' PowerBook.
'
' Bottom line:  about as fast as HeapSort, but lacks HeapSort's guarantee of O
' (NlogN) worst case speed.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim L1(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pCombSortS L, R, S1, P1
CombSortL L, R, L1

' CODE:

Sub CombSortS(L As Long, R As Long, A() As String, P() As Long)
    Dim GAP As Long
    Dim SWAPPED As Boolean
    Dim I As Long
    Dim J As Long
    Dim TMP As Long

    'Initialize GAP to length of list.
    GAP = CLng(1 + R - L)
    Do
    'For each pass, divide GAP by 1.3.
        GAP = (10 * GAP) \ 13
    'The most efficient series of final GAP values starts with 11.
        If GAP = 0 Then
            GAP = 1
        ElseIf GAP = 9 Or GAP = 10 Then
            GAP = 11
        End If
    'Use SWAPPED to tell whether we made a pass without any exchanges.
        SWAPPED = False
    'Compare and possibly swap values/pointers separated by GAP.
        For I = L To R - GAP
            J = I + GAP
            If A(P(I)) > A(P(J)) Then
                TMP = P(I)
                P(I) = P(J)
                P(J) = TMP
                SWAPPED = True
            End If
        Next I
    'If GAP = 1 and we didn't move anything, we're done.
    Loop While SWAPPED Or GAP > 1
End Sub

Sub CombSortL(L As Long, R As Long, A() As Long)
    Dim GAP As Long
    Dim SWAPPED As Boolean
    Dim I As Long
    Dim J As Long
    Dim TMP As Long

    GAP = CLng(1 + R - L)
    Do
        GAP = (10 * GAP) \ 13
        If GAP = 0 Then
            GAP = 1
        ElseIf GAP = 9 Or GAP = 10 Then
            GAP = 11
        End If
        SWAPPED = False
        For I = L To R - GAP
            J = I + GAP
            If A(I) > A(J) Then
                TMP = A(I)
                A(I) = A(J)
                A(J) = TMP
                SWAPPED = True
            End If
        Next I
    Loop While SWAPPED Or GAP > 1
End Sub


David B. Ring


c0Title: HeapSort - A compact routine that sorts data in place
c1Code:

' HeapSort.  A compact routine that sorts data in place (no extra memory needed)
'  and is guaranteed to run in O(N log N) time no matter how the input data is 
' arranged.  On the down side, it's slower than other N log N sorts (Quick and 
' Merge) and not stable (does not preserve the original order of records with 
' equal keys)  Works by organizing records into a "heap" data structure where 
' each node is larger than its two leaves, and then repeatedly selecting the 
' largest key from the root of the heap.  Two versions are given.  pHeapSortS 
' is an indirect (pointerized) version for strings,
'  which can be adapted to doubles by changing the declaration of A().  
' HeapSortL is a direct version for longs, which can be adapted to integers.
'
' Speed:  pHeapSortS sorts 500,000 random strings in 88 sec; sorts 100186 
' library call numbers in 16.2 sec; sorts 25479 dictionary words in 3.3 sec 
' (random order), 3.4 sec (presorted) or 3.2 sec (reverse sorted).  HeapSortL 
' sorts 500,000 random longs in 92 seconds.  Timed in Excel 2001 on an 800 mhz 
' PowerBook.
'
' Bottom line:  compact, adapts to any date type and guarantees N log N sorting 
' times, but not the fastest and not stable.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim L1(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pHeapSortS L, R, S1, P1
HeapSortL L, R, L1

' CODE:

Sub pHeapSortS(L As Long, R As Long, A() As String, P() As Long)
    Dim Node As Long
    Dim Last As Long
    Dim TMP As Long
    
    'build heap
    For Node = (R + L) \ 2 To L Step -1
        pHeapS Node, L, R, A, P
    Next Node

    'repeatedly select item at root of heap
    For Last = R To L + 1 Step -1
        'swap root item to final position
        TMP = P(L)
        P(L) = P(Last)
        P(Last) = TMP
        'get swapped item into right place in heap
        pHeapS L, L, Last - 1, A, P
    Next Last
End Sub

Sub pHeapS(ByVal Node As Long, L As Long, R As Long, A() As String, P() As Long)
    Dim LEAF As Long
    Dim TMP As Long

    Do
        LEAF = Node + Node - (L - 1)
        If LEAF > R Then Exit Sub
        'pick the larger leaf
        If LEAF < R Then If A(P(LEAF + 1)) > A(P(LEAF)) Then LEAF = LEAF + 1
        'if node > leaves, we're done
        If A(P(Node)) > A(P(LEAF)) Then Exit Sub
        'if not, swap larger leaf with node
        TMP = P(Node)
        P(Node) = P(LEAF)
        P(LEAF) = TMP
        'and move further into the heap
        Node = LEAF
    Loop
End Sub

Sub HeapSortL(L As Long, R As Long, A() As Long)
    Dim Node As Long
    Dim Last As Long
    Dim TMP AS Long
    
    For Node = (R + L) \ 2 To L Step -1
        HeapL Node, L, R, A
    Next Node
    For Last = R To L + 1 Step -1
    TMP = A(L)
    A(L) = A(Last)
    A(Last) = TMP
        HeapL L, L, Last - 1, A
    Next Last
End Sub

Sub HeapL(ByVal Node As Long, L As Long, R As Long, A() As Long)
    Dim LEAF As Long
    Dim TMP AS Long

    Do
        LEAF = Node + Node - (L - 1)
        If LEAF > R Then Exit Sub
        If LEAF < R Then If A(LEAF + 1) > A(LEAF) Then LEAF = LEAF + 1
        If A(Node) > A(LEAF) Then Exit Sub
        TMP = A(Node)
    A(Node) = A(LEAF)
    A(LEAF) = TMP
        Node = LEAF
    Loop
End Sub


David B. Ring


c0Title: InsertionSort - A simple routine with minimal overhead
c1Code:

' InsertionSort.  A simple routine with minimal overhead.  Should never be used 
' to sort long lists because of its O(N^2) behavior,
'  but is the method of choice for sorting short (5-50 key) lists or long lists 
' that have been mostly sorted by a faster algorithm.  InsertionSort is faster 
' than either Bubble or SelectionSort and should be used anywhere you would 
' consider using those.  Sorts in place (no extra memory needed) and is stable 
' (preserves the original order of records with equal keys).  Works by creating 
' a sorted list at the beginning of the array of keys.  As each unsorted key to 
' the right is examined, it is compared back thru the sorted list until the 
' right position to insert it is found.  Two versions are given.  pInsertS is 
' an indirect (pointerized) version for strings,
'  which can be adapted to doubles by changing the declaration of A().  InsertL 
' is a direct version for longs, which can be adapted to integers.
' 
' Speed:  Abysmally slow for anything but short lists.
'
' Bottom line:  should be used only to finish up for faster sorts with higher 
' overhead; for that purpose, this is the sort to choose.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim L1(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pInsertS L, R, S1, P1
InsertL L, R, L1

' CODE:

Sub pInsertS(L As Long, R As Long, A() As String, P() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    Dim T As String

    'RP points to the first unsorted key.   
    For RP = L + 1 To R
     'Get the new value.
       TMP = P(RP)
        T = A(TMP)
    'Compare it back thru the sorted part as long as it's bigger.
        For LP = RP To L + 1 Step -1
            If T < A(P(LP - 1)) Then P(LP) = P(LP - 1) Else Exit For
        Next LP
    'It's bigger than all keys to the left, so insert it here.
        P(LP) = TMP
    Next RP
End Sub

Sub InsertL(L As Long, R As Long, A() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    
    For RP = L + 1 To R
        TMP = A(RP)
        For LP = RP To L + 1 Step -1
            If TMP < A(LP - 1) Then A(LP) = A(LP - 1) Else Exit For
        Next LP
        A(LP) = TMP
    Next RP
End Sub


David B. Ring


c0Title: MergeSort - A stable sort
c1Code:

' MergeSort.  A stable sort (preserves original order of records with equal 
' keys).  Like HeapSort, easily adapted to any data type and guaranteed to run 
' in O(N log N) time, but almost twice as fast.  On the down side,
'  needs an extra array of N items, but these can be pointers if the keys 
' themselves are larger than pointers.  Works by repeatedly merging short 
' sorted sequences (created by InsertionSort) into longer ones.  Two versions 
' are given.  pMergeSortS is an indirect (pointerized) version for strings,
'  which can be adapted to doubles by changing the declaration of A().  
' MergeSortL is a direct version for longs, which can be adapted to integers.
'
' Speed:  pMergeSortS sorts 500,000 random strings in 55.3 sec; sorts 100186 
' library call numbers in 9.8 sec; sorts 25479 dictionary words in 3.3 sec 
' (random order), 2.9 sec (presorted) or 3.6 sec (reverse sorted).  MergeSortL 
' sorts 500,000 random longs in 42 seconds.  Timed in Excel 2001 on an 800 mhz 
' PowerBook.
'
' Bottom line:  fast stable sort that easily handles all data types,
'  but a heavy memory user.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim P2(L To R) As Long
Dim L1(L To R) As Long
Dim L2(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pMergeSortS L, R, S1, P1, P2
MergeSortL L, R, L1, L2

' CODE:

Sub pMergeSortS(L As Long, R As Long, A() As String, P() As Long, Q() As Long)
    Dim LP As Long        'left pointer
    Dim RP As Long        'right pointer
    Dim OP As Long        'output pointer
    Dim MID As Long
    
    'This version is for strings; for other data types,
    '  change declaration of A().
    'MergeSort recursively calls itself until we have lists short enough for 
    ' InsertionSort.
    If R - L < 10 Then
       'call an indirect (pointerized) version of InsertionSort
        pInsertS L, R, A, P
    Else
       'if too long for InsertionSort, split list and recurse
        MID = (L + R) \ 2
        pMergeSortS L, MID, A, P, Q
        pMergeSortS MID + 1, R, A, P, Q
        
       'Each half of the array is sorted; now we'll merge them into the extra 
       ' array.
       'We'll work via pointers, to keep the extra array smaller.
        LP = L
        RP = MID + 1
        OP = L
        Do
        'Copy the pointer to the smaller string.
            If A(P(LP)) <= A(P(RP)) Then
                Q(OP) = P(LP)
                OP = OP + 1
                LP = LP + 1
                If LP > MID Then
             'We ran out of the left half, so transfer the rest of the right 
             ' half.
                    Do
                        Q(OP) = P(RP)
                        OP = OP + 1
                        RP = RP + 1
                    Loop Until RP > R
             'This merge is done.
                    Exit Do
                End If
            Else
         'This part is a mirror image of the last part.
                Q(OP) = P(RP)
                OP = OP + 1
                RP = RP + 1
                If RP > R Then
                    Do
                        Q(OP) = P(LP)
                        OP = OP + 1
                        LP = LP + 1
                    Loop Until LP > MID
                    Exit Do
                End If
            End If
        Loop
    'Finally, we copy the pointers back from the extra array to the main array.
        For OP = L To R
             P(OP) = Q(OP)
        Next OP
    End If
End Sub

Sub pInsertS(L As Long, R As Long, A() As String, P() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    Dim T As String
    
    For RP = L + 1 To R
        TMP = P(RP)
        T = A(TMP)
        For LP = RP To L + 1 Step -1
            If T < A(P(LP - 1)) Then P(LP) = P(LP - 1) Else Exit For
        Next LP
        P(LP) = TMP
    Next RP
End Sub

Sub MergeSortL(L As Long, R As Long, A() As Long, B() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim OP As Long
    Dim MID As Long
    
    If R - L < 12 Then
        InsertL L, R, A()
    Else
        MID = (L + R) \ 2
        MergeSortL L, MID, A, B
        MergeSortL MID + 1, R, A, B
        LP = L
        RP = MID + 1
        OP = L
        Do
            If A(LP) <= A(RP) Then
                B(OP) = A(LP)
                OP = OP + 1
                LP = LP + 1
                If LP > MID Then
                    Do
                        B(OP) = A(RP)
                        OP = OP + 1
                        RP = RP + 1
                    Loop Until RP > R
                    Exit Do
                End If
            Else
                B(OP) = A(RP)
                OP = OP + 1
                RP = RP + 1
                If RP > R Then
                    Do
                        B(OP) = A(LP)
                        OP = OP + 1
                        LP = LP + 1
                    Loop Until LP > MID
                    Exit Do
                End If
            End If
        Loop
        For OP = L To R
             A(OP) = B(OP)
        Next OP
    End If
End Sub

Sub InsertL(L As Long, R As Long, A() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    
    For RP = L + 1 To R
        TMP = A(RP)
        For LP = RP To L + 1 Step -1
            If TMP < A(LP - 1) Then A(LP) = A(LP - 1) Else Exit For
        Next LP
        A(LP) = TMP
    Next RP
End Sub



David B. Ring


c0Title: MSD RadixSort - An algorithm that can achieve O(N) behavior
c1Code:

' MSD RadixSort.  No sort based on comparisons can be faster than O(N log N).  
' RadixSort makes no comparisons and can therefore achieve O(N) behavior.  To 
' do this, it examines keys one byte at a time, counting the number of keys 
' that have each possible byte value.  The counts are then used to build an 
' offset table specifying the sorted order of the keys.  It's easiest to work 
' backwards from the least significant digit of the keys (LSD Radix),
'  since order based on more significant digits is not disturbed by less 
' significant digits.  Unfortunately, the LSD approach requires padding short 
' keys if key length is variable, and guarantees that all digits will be 
' examined even if the first 3-4 digits contain all the information needed to 
' achieve sorted order.  Most significant digit (MSD) RadixSort takes a lot 
' more bookkeeping -- the list must repeatedly be split into sublists for each 
' value of the last digit processed -- but the pay-off is that only as many 
' digits will be examined as are needed.  As in QuickSort and MergeSort,
'  it's worthwhile to hand off the sublists to InsertionSort when they get 
' short enough.
'
' MSD RadixSort is stable and runs in linear O(N) time.  It is fairly memory 
' intensive, needing space for some extra counting arrays and stack space for 
' recursive calls, but still uses less memory than MergeSort.  This version is 
' set up for strings and would take some work to adapt to other data types.  
' Integers and longs could be handled by converting them to strings (and 
' limiting the arrays CNT and IND to the ten numerical digit values plus the 
' minus sign); this is probably worthwhile only if you have hundreds of 
' thousands of integers or longs to sort.  Doubles are more of a challenge,
'  requiring conversion to an array of bytes by type casting.  I have not 
' pursued this, since VBA on the Mac does not include the CopyMemory function 
' that enables type casting on Windows systems.  
'
' NOTE:  This version is set up to count byte values from 1 to 127.  If your 
' keys use (for instance) only lowercase or only uppercase alphabetic 
' characters or only numerical digits, you can trim the CNT and IND arrays  and 
' your sorts will run correspondingly faster.
'
' Reference:  P. M. McIlroy, K. Bostic and M. D. McIlroy,
'  "Engineering  Radix Sort", Computing Systems 6(1):5-27 (1993).
'
' Speed:  MSDRadixSortS sorts 500,000 random strings in 28.3 sec; sorts 100186 
' library call numbers in 21.3 sec; sorts 25479 dictionary words in 1.8 sec 
' (random order), 1.5 sec (presorted) or 1.9 sec (reverse sorted).  Timed in 
' Excel 2001 on an 800 mhz PowerBook.
'
' Bottom line:  complex and best suited to strings, but there's nothing faster 
' for really long lists.

' Usage:  

Dim S1(L To R) As Strings
Dim B1(1 To nChars) As Byte
Dim P1(L To R) As Long

For I = L To R
    S1(I) = GetRandomString()
Next I

StrsToBytes S1, B1, P1    'a routine that stores the strings in 0 terminated 
                          ' byte arrays with
                    'P1() holding pointers to the start of each byte series.

MSDRadixSortS L, R, B1, P1


' CODE:

Sub MSDRadixSortS(N As Long)
    Dim CH() As Integer
    
    ReDim CH(1 To N)  
    'See below for type PILE (stack records)
    ReDim STACK(1 To 1000)
    StackPtr = 1
    With STACK(StackPtr)
        .L = 1
        .R = N
        .D = 0
    End With
    StackPtr = StackPtr + 1
    RadixS CH
End Sub

Sub RadixS(CH() As Integer)
    Dim L As Long
    Dim R As Long
    Dim D As Integer
    Dim I As Long
    Dim J As Long
    Dim TMP As Long
    Dim C As Integer
    Dim NextC As Integer
    Dim CNT(-1 To 127) As Long
    Dim IND(-1 To 127) As Long
    Dim NuCnt As Long
    Dim BigCnt As Long
    Dim OldSp As Long
    Dim BigSp As Long
    
    While StackPtr > 1
    'Pop a PILE off the stack.
        StackPtr = StackPtr - 1
    'Get left and right limits of sublist and depth of byte to examine
        With STACK(StackPtr)
            L = .L
            R = .R
            D = .D
        End With
    'Sublists of <= 24 keys will be finished by InsertionSort
        If R - L > 24 Then
        'Clear the count array.
            For I = -1 To 127
                CNT(I) = 0
            Next I
        'Get the byte at depth D in each key and count the number of each byte 
        ' value.
            For I = L To R
                C = CInt(B(P(I) + D))
                CH(I) = C
                CNT(C) = CNT(C) + 1
            Next I
        'We will add the counts to create sorted addresses in array IND().
            IND(-1) = L
        'At the same time we'll push the sublists for each byte value onto the 
        ' stack.
            OldSp = StackPtr
        'We'll track the biggest sublist and make sure it comes off the stack 
        ' last;
        'this ensures the stack will not get more than logarithmically deep.
            BigCnt = 0
        'Now we build the addresses out of the counts.
            For I = 0 To 127
                J = I - 1
                NuCnt = CNT(J)
                IND(I) = IND(J) + NuCnt
         'If there is a sublist of keys starting with the current byte value,
         '  stack it.
                If NuCnt > 1 Then
                    With STACK(StackPtr)
                        .L = IND(J)
                        .R = IND(I) - 1
                        .D = D + 1
                    End With
                    StackPtr = StackPtr + 1
             'Keep track of the largest count / sublist.
                    If NuCnt > BigCnt Then
                        BigCnt = NuCnt
                        BigSp = StackPtr
                    End If
                End If
            Next I
        'Swap the biggest sublist down into the stack so it comes off last.
            TMP = BigSp
            BigSp = OldSp
            OldSp = TMP
        'Now use the counts to move the pointers to their sorted positions 
        ' based on the
        'bytes examined so far; doing this in place this gets a bit ugly.
            For I = L To R
         'We will use the byte at I to find what address P(I) should be mapped 
         ' to.
                C = CH(I)
         'We use -1 to flag pointers already moved.
                CH(I) = -1
         'If C = -1 we skip the loop and increment I until we find a pointer 
         ' not already moved.
                Do While C >= 0
             'We go to IND(C) to get the destination address for P(I).
                    J = IND(C)
             'We swap the current pointer for the one at that address.
                    TMP = P(I)
                    P(I) = P(J)
                    P(J) = TMP
             'Now we determine where to map the pointer we just displaced.
             'We get the byte value from its key.
                    NextC = CH(J)
             'We flag it as moved.
                    CH(J) = -1
             'Once we've used each address we increment it unless we've hit R.
                    If J < R Then IND(C) = J + 1 Else Exit Do
             'We set C to the byte of the key of the displaced pointer; ready 
             ' to loop!
                    C = NextC
                Loop
         'If a series of displacements circles back to a pointer already moved,
         '  we 
         'increment I until we find a pointer not yet moved or until we end at 
         ' R.
            Next I
        Else
            DeepInsertS B, P, L, 1 + R - L, D
        End If
    Wend
End Sub

Type PILE
    L As Long
    R As Long
    D As Integer
End Type

Dim STACK() As PILE
Dim StackPtr As Integer

Sub DeepInsertS(B() As Byte, P() As Long, L As Long, N As Long, D As Integer)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    Dim I As Long
    Dim J As Long
    
    For RP = L + 1 To L + N - 1
        TMP = P(RP)
        For LP = RP To L + 1 Step -1
            I = TMP + D
            J = P(LP - 1) + D
            Do While B(I) = B(J)
                If B(I) = 0 Or B(J) = 0 Then Exit Do
                I = I + 1
                J = J + 1
            Loop
            If CInt(B(I)) - CInt(B(J)) < 0 Then P(LP) = P(LP - 1) Else Exit For
        Next LP
        P(LP) = TMP
    Next RP
End Sub


David B. Ring


c0Title: QuickSort-Exploiting the Principle of Exchanging Keys
c1Code:

' QuickSort.  QuickSort, CombSort and ShellSort all exploit the principle of 
' exchanging keys that are far apart in the list rather than adjacent.  
' QuickSort does this most elegantly and rapidly.  The approach is to choose a 
' "pivot" value (ideally, the median key) and then to work from each end of the 
' list toward the middle.  A key at each end is compared to the pivot and 
' nothing is done if the left key is less than the pivot or the right key is 
' greater.  When a left key greater than the pivot and a right key less than 
' the pivot have been found, those keys (or their pointers) are swapped,
'  and the process continues until the left and right pointers cross.  We then 
' recursively call QuickSort on the left and right sublists until the lists are 
' small (and delegate final sorting to low overhead InsertionSort).
'
' QuickSort does not need any auxiliary arrays, but uses a modest amount of 
' stack space for recursion.  It is not stable (although its descendent Ternary 
' QuickSort is).  On average, it is the fastest of the O(N log N) sorts,
'  but it suffers from rare "worst case" behavior where certain input orders of 
' keys cause speed to deteriorate to O(N^2).  Naive implementations of 
' QuickSort that choose the middle key for pivot exhibit O(N^2) behavior on 
' sorted lists.  The version of QuickSort presented here makes worst case 
' behavior very unlikely by choosing the median of the first,
'  last and middle keys as pivot.  Two versions are provided.  pQuickSortS is 
' set up for strings and can be adapted to doubles by changing the declaration 
' of array A().  QuickSortL is set up for longs, or A() can be redeclared for 
' integers.  
'
' Reference:  Robert Sedgewick, "Implementing Quicksort Programs",
'  Comm. of the ACM 21(10):847-857 (1978).
'
' Speed:  pQuickSortS sorts 500,000 random strings in 30.3 sec; sorts 100186 
' library call numbers in 11.3 sec; sorts 25479 dictionary words in 2.0 sec 
' (random order), 1.3 sec (presorted) or 1.8 sec (reverse sorted).  QuickSortL 
' sorts 500,000 random longs in 56 seconds.  Timed in Excel 2001 on an 800 mhz 
' PowerBook.
'
' Bottom line:  contends with RadixSort for fastest; better adapted than Radix 
' for non-string data, but not stable.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim L1(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pQuickSortS L, R, S1, P1
QuickSortL L, R, L1

' CODE:

Sub pQuickSortS(L As Long, R As Long, A() As String, P() As Long)
    'We put "sentinel" values flanking the real keys to avoid an extra test in 
    ' the inner loop.
    A(L - 1) = MinStr
    A(R + 1) = MaxStr
    'We mostly sort the list with QuickSort.
    pQuickS L, R, A(), P
    'Then we finish up with low overhead InsertionSort
    pInsertS L, R, A(), P
End Sub

Sub pQuickS(L As Long, R As Long, A() As String, P() As Long)
    Dim MED As Long
    Dim LP As Long
    Dim RP As Long
    Dim Pivot As String
    Dim TMP As Long
    
    'Sublists <= 12 keys will be finished by running the whole list once thru 
    ' InsertionSort.
    If R - L > 12 Then
    'Get the median pointer...
        MED = (L + R) \ 2
    'and swap it to the leftmost position.
        TMP = P(MED)
        P(MED) = P(L)
        P(L) = TMP
    'Now compare the leftmost, next leftmost & rightmost to choose a median of 
    ' 3...
        If A(P(L + 1)) > A(P(R)) Then
            TMP = P(L + 1)
            P(L + 1) = P(R)
            P(R) = TMP
        End If
        If A(P(L)) > A(P(R)) Then
            TMP = P(L)
            P(L) = P(R)
            P(R) = TMP
        End If
        If A(P(L + 1)) > A(P(L)) Then
            TMP = P(L + 1)
            P(L + 1) = P(L)
            P(L) = TMP
        End If
    'and use its key as our pivot.
        Pivot = A(P(L))
    'Now work inward from each end.
        LP = L
        RP = R + 1
        Do
        'Scan right for a pointer whose key >= Pivot.  In case Pivot is the 
        ' largest key, we have
        'a sentinel value of MaxStr in A(R + 1) that will end a runaway loop.  
        ' Using the sentinel
        'avoids having a second test in the inner loop,
        '  so it can be as fast as possible.
            Do
                LP = LP + 1
            Loop While A(P(LP)) < Pivot
        'Scan left for a pointer whose key <= Pivot.  Again,
        '  we have a sentinel value of MinStr
        'in A(L - 1) to stop the loop if Pivot is the smallest value in the 
        ' list.
             Do
                RP = RP - 1
            Loop While A(P(RP)) > Pivot
        'If the pointers have crossed we're done.
            If RP <= LP Then Exit Do
        'Otherwise, swap the pair we've identified.
            TMP = P(LP)
            P(LP) = P(RP)
            P(RP) = TMP
        Loop
    'Swap the pointer of the Pivot value back into place.
        TMP = P(L)
        P(L) = P(RP)
        P(RP) = TMP
    'Sort the shorter sublist first so the recursion stack is limited to 
    ' logarithmic depth.
        If (RP - 1) - L <= R - LP Then
            pQuickS L, RP - 1, A, P
            pQuickS LP, R, A, P
        Else
            pQuickS LP, R, A, P
            pQuickS L, RP - 1, A, P
        End If
    End If
End Sub

Sub pInsertS(L As Long, R As Long, A() As String, P() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    Dim T As String
    
    For RP = L + 1 To R
        TMP = P(RP)
        T = A(TMP)
        For LP = RP To L + 1 Step -1
            If T < A(P(LP - 1)) Then P(LP) = P(LP - 1) Else Exit For
        Next LP
        P(LP) = TMP
    Next RP
End Sub

Sub QuickSortL(L As Long, R As Long, A() As Long)
    A(L - 1) = MinStr
    A(R + 1) = MaxStr
    QuickL L, R, A
    InsertL L, R, A
End Sub

Sub QuickL(L As Long, R As Long, A() As Long)
    Dim MED As Long
    Dim LP As Long
    Dim RP As Long
    Dim Pivot As String
    Dim TMP As Long
    
    If R - L > 12 Then
        MED = (L + R) \ 2
        TMP = A(MED)
        A(MED) = A(L)
        A(L) = TMP
        If A(L + 1) > A(R) Then
            TMP = A(L + 1)
            A(L + 1) = A(R)
            A(R) = TMP
        End If
        If A(L) > A(R) Then
            TMP = A(L)
            A(L) = A(R)
            A(R) = TMP
        End If
        If A(L + 1) > A(L) Then
            TMP = A(L + 1)
            A(L + 1) = A(L)
            A(L) = TMP
        End If
        Pivot = A(L)
        LP = L
        RP = R + 1
        Do
            Do
                LP = LP + 1
            Loop While A(LP) < Pivot
            Do
                RP = RP - 1
            Loop While A(RP) > Pivot
            If RP <= LP Then Exit Do
            TMP = A(LP)
            A(LP) = A(RP)
            A(RP) = TMP
        Loop
        TMP = A(L)
        A(L) = A(RP)
        A(RP) = TMP
        If (RP - 1) - L < R - LP Then
            QuickL L, RP - 1, A
            QuickL LP, R, A
        Else
            QuickL LP, R, A
            QuickL L, RP - 1, A
        End If
    End If
End Sub

Sub InsertL(L As Long, R As Long, A() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    
    For RP = L + 1 To R
        TMP = A(RP)
        For LP = RP To L + 1 Step -1
            If TMP < A(LP - 1) Then A(LP) = A(LP - 1) Else Exit For
        Next LP
        A(LP) = TMP
    Next RP
End Sub


David B.


c0Title: SelectionSort - Short, simple and sloooow
c1Code:
' SelectionSort.  Short, simple and sloooow.  This is another O(N^2) sort that 
' should never be used on long lists.  Like InsertionSort,
'  it needs no extra memory (in place) and preserves the existing order of 
' records with equal keys.  Unfortunately, it's slower,
'  and there's no reason to use it instead of InsertionSort.  Works by looking 
' thru the list for the smallest key and placing it first,
'  then looking for the next largest, and so on.  If the slow linear search for 
' each key is replaced by a faster "priority queue" approach,
'  a reasonably fast algorithm can be created (see HeapSort).  Two versions are 
' given.  pSelSortS is an indirect (pointerized) version for strings,
'  which can be adapted to doubles by changing the declaration of A().  
' SelSortL is a direct version for longs, which can be adapted to integers.
'  
' Speed:  Don't ask.
'
' Bottom line:  Included because it's a clear and simple approach,
'  but too slow to be useful.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim L1(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pSelSortS L, R, S1, P1
SelSortL L, R, L1

' CODE:

Sub pSelSortS(L As Long, R As Long, A() As String, P() As Long)
    Dim I As Long
    Dim J As Long
    Dim Min As Long
    Dim TMP As Long

    For I = L To R - 2
    'Start with the first key.
        Min = I
    'Compare to each key to the right
        For J = I + 1 To R
        'Every time we find a lower value, keep that pointer.
            If A(P(J)) < A(P(Min)) Then
                Min = J
            End If
        Next J
    'When we've scanned all keys, swap the low key's pointer to the end of the 
    ' sorted list.
        TMP = P(I)
        P(I) = P(Min)
        P(Min) = TMP
    Next I
End Sub

Sub SelSortL(L As Long, R As Long, A() As Long)
    Dim I As Long
    Dim J As Long
    Dim Min As Long
    Dim TMP As Long

    For I = L To R - 2
        Min = I
        For J = I + 1 To R
            If A(J) < A(Min) Then
                Min = J
            End If
        Next J
        TMP = A(I)
        A(I) = A(Min)
        A(Min) = TMP
    Next I
End Sub


David B. Ring


c0Title: ShellSort - A compact routine that sorts data in place
c1Code:
' ShellSort.  A compact routine that sorts data in place (no extra memory 
' needed) and runs in O(N (log N)^2) time.  Not stable (does not preserve 
' original order of records with equal keys).
' Like InsertionSort, works by taking a key from the right side of the list and 
' comparing it with keys to the left until the correct position is found to 
' insert it.  Differs from InsertionSort (and resembles CombSort) by moving 
' leftward by interval GAP instead of one key at a time.  GAP is initially 
' large (to move keys close to their final position rapidly) and is 
' subsequently reduced until it equals 1 and the list is sorted.  Two versions 
' are given.  pShellSortS is an indirect (pointerized) version for strings,
'  which can be adapted to doubles by changing the declaration of A().  
' ShellSortL is a direct version for longs, which can be adapted to integers.
'
' Speed:  pShellSortS sorts 500,000 random strings in 115 sec; sorts 100186 
' library call numbers in 18 sec; sorts 25479 dictionary words in 3.2 sec 
' (random order), 0.83 sec (presorted) or 1.4 sec (reverse sorted).  ShellSortL 
' sorts 500,000 random longs in 67 seconds.  Timed in Excel 2001 on an 800 mhz 
' PowerBook.
'
' Bottom line:  with O(N (log N)^2) behavior, there are better choices.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim L1(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pShellSortS L, R, S1, P1
ShellSortL L, R, L1

' CODE:

Sub pShellSortS(L As Long, R As Long, A() As String, P() As Long)
    Dim GAP As Long
    Dim I As Long
    Dim J As Long
    Dim TMP As Long

    GAP = 1
    'Find largest possible GAP.
    While GAP * 3 < R - L
        GAP = GAP * 3 + 1
    Wend
    While GAP > 0
        For I = GAP + 1 To R
        'Start with a right hand pointer.
            TMP = P(I)
            J = I
        'Compare it leftward at intervals of GAP.
            Do While J > GAP
         'If the left pointer's value is higher, shift it right & go left 
         ' another GAP.
                If A(P(J - GAP)) > A(TMP) Then
                    P(J) = P(J - GAP)
                    J = J - GAP
                Else
                    Exit Do
                End If
            Loop
        'The right pointer's value was equal or higher, so insert it here.
            P(J) = TMP
        Next I
    'Shrink the GAP until it reaches 1.
        GAP = GAP / 3
    Wend
End Sub

Sub ShellSortL(L As Long, R As Long, A() As Long)
    Dim GAP As Long
    Dim I As Long
    Dim J As Long
    Dim TMP As Long

    GAP = 1
    While GAP * 3 < R - L
        GAP = GAP * 3 + 1
    Wend
    While GAP > 0
        For I = GAP + 1 To R
            TMP = A(I)
            J = I
            Do While J > GAP
                If A(J - GAP) > TMP Then
                    A(J) = A(J - GAP)
                    J = J - GAP
                Else
                    Exit Do
                End If
            Loop
            A(J) = TMP
        Next I
        GAP = GAP / 3
    Wend
End Sub


David B. Ring


c0Title: ShuttleMergeSort - An improved MergeSort
c1Code:
' 2/4/03.  The previous version of ShuttleMergeSort failed on very short lists. 
'  The code below corrects the problem and eliminates a couple of unnecessary 
' variables.  Sorting times for one million random longs,
'  double or strings are 67, 90 and 95 seconds (Excel 2001 / 800 mhz PowerBook /
'  MacOS 10.2.3).

' 1/7/03.  Here is a 20-25% faster version of MergeSort.  The old version 
' merged into an auxiliary array, and copied the result back to the primary 
' array at the end of each pass.  This version plans ahead for an even number 
' of passes, and alternates direction each time, first merging to the auxiliary 
' array and then back to the primary array.  It also replaces recursive calls 
' with an explicit stack, and calls to a separate InsertionSort with in-line 
' code.  Because of the back and forth merging,
'  I call this version "ShuttleMergeSort".

' Another frequently proposed optimization for MergeSort is to set runs up in 
' alternating directions (low to high, then high to low).  This allows 
' replacing separate boundary tests for LP and RP with a single test for LP 
' crossing RP.  I tried this, and it wasn't faster in practice.  Probably the 
' gain from fewer loop tests was offset by time spent in extra comparisons; in 
' the simpler version, when one run is used up, the rest of the other run is 
' copied to the output array with no further comparisons.  Also,
'  the run-alternating version was significantly slower on presorted inputs,
'  which often occur in practice.

' QuickSort is still faster for strings (64 sec vs. 95),
'  but MergeSort is faster for doubles (90 sec vs. 162) and longs (67 sec vs. 
' 116).  Given that MergeSort is stable and guaranteed NlogN,
'  while QuickSort is unstable and always has an N^2 worst case,
'  MergeSort is my choice for a single all-purpose sort.

' The first example below is a pointerized version for strings.  It can be 
' adapted to doubles by changing the declaration of A() and T.  The second 
' example is a direct version for longs that can be adapted to integers.

Sub pShuttleMergeSortS(LO As Long, HI As Long, A() As String, P() As Long, _
    Q() As Long)
    'LO and HI point to first and last keys; A() is the buffer of string keys.
    'P() and Q() are buffers of pointers to the keys in A()
    Dim Length As Double    'length of initial runs to be made by InsertionSort
    Dim nRuns As Long        'the number of runs at each stage
    Dim Stack() As Long        'bookkeeping stack for merge passes
    Dim I As Long
    Dim L As Long            'left limit
    Dim R As Long            'right limit
    Dim LP As Long            'left pointer
    Dim RP As Long            'right pointer
    Dim OP As Long            'other pointer
    Dim TMP As String
    Dim Forward As Boolean    'toggle for direction of alternate merge passes
    
    'Calculate how many merge passes will be needed.
    'Each back & forth pair of merges will convert 4N sublists into N.
    Length = 1 + HI - LO
    nRuns = 1
    While Length > 20
        Length = Length / 4
        nRuns = nRuns * 4
    Wend

    'Set up stack to keep track of sublists being merged.
    ReDim Stack(1 To nRuns)
    For I = 1 To nRuns - 1
        Stack(I) = LO + (Length * CDbl(I))
    Next I
    Stack(nRuns) = HI
    
    'Build short runs using low overhead InsertionSort.
    L = LO
    For I = 1 To nRuns
        R = Stack(I)
        For RP = L + 1 To R
            OP = P(RP)
            TMP = A(OP)
            For LP = RP To L + 1 Step -1
                If TMP < A(P(LP - 1)) Then P(LP) = P(LP - 1) Else Exit For
            Next LP
            P(LP) = OP
        Next RP
        L = R + 1
    Next I
    
    'Make back & forth passes of MergeSort until all runs are merged.
    Forward = True
    While nRuns > 1
        R = LO - 1
        If Forward Then
            'Half the passes are forward, merging from P() into Q().
            For I = 2 To nRuns Step 2
                LP = R + 1
                OP = LP
                L = Stack(I - 1)
                RP = L + 1
                R = Stack(I)
                Do
                    If A(P(LP)) <= A(P(RP)) Then
                        Q(OP) = P(LP)
                        OP = OP + 1
                        LP = LP + 1
                        If LP > L Then
                            Do
                                Q(OP) = P(RP)
                                OP = OP + 1
                                RP = RP + 1
                            Loop Until RP > R
                            Exit Do
                        End If
                    Else
                        Q(OP) = P(RP)
                        OP = OP + 1
                        RP = RP + 1
                        If RP > R Then
                            Do
                                Q(OP) = P(LP)
                                OP = OP + 1
                                LP = LP + 1
                            Loop Until LP > L
                            Exit Do
                        End If
                    End If
                Loop
                Stack(I \ 2) = R
            Next I
        Else
        'Half the passes are backward, merging from Q() into P().
            For I = 2 To nRuns Step 2
                LP = R + 1
                OP = LP
                L = Stack(I - 1)
                RP = L + 1
                R = Stack(I)
                Do
                    If A(Q(LP)) <= A(Q(RP)) Then
                        P(OP) = Q(LP)
                        OP = OP + 1
                        LP = LP + 1
                        If LP > L Then
                            Do
                                P(OP) = Q(RP)
                                OP = OP + 1
                                RP = RP + 1
                            Loop Until RP > R
                            Exit Do
                        End If
                    Else
                        P(OP) = Q(RP)
                        OP = OP + 1
                        RP = RP + 1
                        If RP > R Then
                            Do
                                P(OP) = Q(LP)
                                OP = OP + 1
                                LP = LP + 1
                            Loop Until LP > L
                            Exit Do
                        End If
                    End If
                Loop
                Stack(I \ 2) = R
            Next I
        End If
        'After each merge, we have half as many runs and we switch direction.
        nRuns = nRuns \ 2
        Forward = Not Forward
    Wend
End Sub

Sub ShuttleMergeSortL(LO As Long, HI As Long, A() As Long, B() As Long)
    'LO and HI point to the first and last keys.
    'A() and B() are the primary and auxiliary buffers of keys
    Dim Length As Double    'length of initial runs to be made by InsertionSort
    Dim nRuns As Long        'the number of runs at each stage
    Dim Stack() As Long        'bookkeeping stack for merge passes
    Dim I As Long
    Dim L As Long            'left limit
    Dim R As Long            'right limit
    Dim LP As Long            'left pointer
    Dim RP As Long            'right pointer
    Dim OP As Long            'other pointer
    Dim TMP As String
    Dim Forward As Boolean    'toggle for direction of alternate merge passes
    
    'Calculate how many merge passes will be needed.
    'Each back & forth pair of merges will convert 4N sublists into N.
    Length = 1 + HI - LO
    nRuns = 1
    While Length > 20
        Length = Length / 4
        nRuns = nRuns * 4
    Wend

    'Set up stack to keep track of sublists being merged.
    ReDim Stack(1 To nRuns)
    For I = 1 To nRuns - 1
        Stack(I) = LO + (Length * CDbl(I))
    Next I
    Stack(nRuns) = HI
    
    'Build short runs using low overhead InsertionSort.
    L = LO
    For I = 1 To nRuns
        R = Stack(I)
        For RP = L + 1 To R
            TMP = A(RP)
            For LP = RP To L + 1 Step -1
                If TMP < A(LP - 1) Then A(LP) = A(LP - 1) Else Exit For
            Next LP
            A(LP) = TMP
        Next RP
        L = R + 1
    Next I
    
    'Make back & forth passes of MergeSort until all runs are merged.
    Forward = True
    While nRuns > 1
        R = LO - 1
        If Forward Then
            'Half the passes are forward, merging from P() into Q().
            For I = 2 To nRuns Step 2
                LP = R + 1
                OP = LP
                L = Stack(I - 1)
                RP = L + 1
                R = Stack(I)
                Do
                    If A(LP) <= A(RP) Then
                        B(OP) = A(LP)
                        OP = OP + 1
                        LP = LP + 1
                        If LP > L Then
                            Do
                                B(OP) = A(RP)
                                OP = OP + 1
                                RP = RP + 1
                            Loop Until RP > R
                            Exit Do
                        End If
                    Else
                        B(OP) = A(RP)
                        OP = OP + 1
                        RP = RP + 1
                        If RP > R Then
                            Do
                                B(OP) = A(LP)
                                OP = OP + 1
                                LP = LP + 1
                            Loop Until LP > L
                            Exit Do
                        End If
                    End If
                Loop
                Stack(I \ 2) = R
            Next I
        Else
         'Half the passes are backward, merging from Q() into P().
           For I = 2 To nRuns Step 2
                LP = R + 1
                OP = LP
                L = Stack(I - 1)
                RP = L + 1
                R = Stack(I)
                Do
                    If B(LP) <= B(RP) Then
                        A(OP) = B(LP)
                        OP = OP + 1
                        LP = LP + 1
                        If LP > L Then
                            Do
                                A(OP) = B(RP)
                                OP = OP + 1
                                RP = RP + 1
                            Loop Until RP > R
                            Exit Do
                        End If
                    Else
                        A(OP) = B(RP)
                        OP = OP + 1
                        RP = RP + 1
                        If RP > R Then
                            Do
                                A(OP) = B(LP)
                                OP = OP + 1
                                LP = LP + 1
                            Loop Until LP > L
                            Exit Do
                        End If
                    End If
                Loop
                Stack(I \ 2) = R
            Next I
        End If
       'After each merge, we have half as many runs and we switch direction.
        nRuns = nRuns \ 2
        Forward = Not Forward
    Wend
End Sub

David B. Ring


c0Title: Ternary QuickSort - A modification of QuickSort
c1Code:
' Ternary QuickSort.  See the summary of QuickSort for background before 
' reading this one.  Ternary QuickSort (also called MultiKey QuickSort) differs 
' from the original QuickSort by examining keys one byte at a time (like 
' RadixSort), and by handling keys in three categories -- less than pivot,
'  equal to pivot, and more than pivot -- instead of two.  (Separate handling 
' of equal keys is why this sort is stable while ordinary QuickSort is not.)  
' As in QuickSort, the left and right sublists are processed recursively until 
' they are short enough for InsertionSort.  The equal-to-pivot sublist is also 
' handled recursively, except that a pointer indicating the "depth" of the byte 
' to be examined is advanced to the next position before the call.  Since 
' sublists handed off to InsertionSort consist of keys whose first bytes are 
' identical up to DEPTH - 1, we use a special version of InsertionSort that 
' compares keys only from DEPTH onward.
'
' Needs no extra arrays, but uses some stack space for recursion.  In practice 
' in VBA, I don't find this sort to be as fast as the original QuickSort,
'  but results may differ in languages that offer faster access to bytes within 
' strings.  This algorithm is definitely oriented toward strings; see comments 
' under MSD Radix Sort on possible adaptation to integers and longs.
'
' Reference:  Jon Bentley and Robert Sedgewick, "Fast Algorithms for Sorting 
' and Searching Strings", Proceedings of the 8th Annual ACM-SIAM Symposium on 
' Discrete Algorithms, January 1997.  See also http://www.cs.princeton.edu/~rs/
' strings/.
'
' Speed:  TernaryQuickSort sorts 500,000 random strings in 39 sec; sorts 100186 
' library call numbers in 14 sec; sorts 25479 dictionary words in 1.8 sec 
' (random order), 1.9 sec (presorted) or 1.8 sec (reverse sorted).  Timed in 
' Excel 2001 on an 800 mhz PowerBook.
'
' Bottom line:  a stable version of QuickSort good for strings,
'  but not (at least in VBA) as fast as the original.

' Usage:  

Dim S1(L To R) As Strings
Dim B1(1 To nChars) As Byte
Dim P1(L To R) As Long

For I = L To R
    S1(I) = GetRandomString()
Next I

StrsToBytes S1, L, R, B1, P1        'a routine that stores the strings in 0-
                                    ' terminated byte
                            'arrays with P1() holding pointers to the first 
                            ' byte of
                            'each string

TernaryQuickSort L, R, B1, P1

' CODE:

Sub TernaryQuickSort(L As Long, R As Long, B() As Byte, P() As Long)
    TernQuick L, R, B, P, 0
End Sub

Sub TernQuick(L As Long, R As Long, B() As Byte, P() As Long, _
    ByVal DEPTH As Integer)
    Dim TMP As Long
    Dim I As Long
    Dim J As Long
    Dim pMED As Long
    Dim Pivot As Integer
    Dim OuterL As Long
    Dim InnerL As Long
    Dim InnerR As Long
    Dim OuterR As Long
    Dim DIF As Long
    Dim N As Long
    Dim SwapN As Long
    Dim NLO As Long
    Dim NHI As Long
    Dim NEQ As Long

    N = 1 + R - L
    'Short sublists will be handled by lower overhead InsertionSort.
    If N > 10 Then
    'Get a pivot value from the median of three or nine keys.
        pMED = BGetMed(B, P, L, N, DEPTH)
    'Swap the median into the leftmost position.
        TMP = P(L)
        P(L) = P(pMED)
        P(pMED) = TMP
    'Our pivot will be the byte value at DEPTH.
        Pivot = B(P(L) + DEPTH)
    'Set up two pointers on the left and two on the right.
        OuterL = L
        InnerL = OuterL
        OuterR = R
        InnerR = OuterR
        Do
        'Look for a lefthand key/pointer to swap.
            Do While InnerL <= InnerR
         'DIF is the key's byte minus the Pivot byte.
                DIF = B(P(InnerL) + DEPTH) - Pivot
         'If the key's byte is greater, we've found a pointer to swap to the 
         ' right side.
                If DIF > 0 Then Exit Do
         'If our byte is equal to the Pivot byte, we swap it to the extreme 
         ' left end.
                If DIF = 0 Then
                    TMP = P(OuterL)
                    P(OuterL) = P(InnerL)
                    P(InnerL) = TMP
                    OuterL = OuterL + 1
                End If
         'If our byte is less than Pivot, we just scan over it.
                InnerL = InnerL + 1
            Loop
        'Now look for a righthand key/pointer to swap.
            Do While InnerL <= InnerR
                DIF = B(P(InnerR) + DEPTH) - Pivot
         'If the key's byte is less, we've found a pointer to swap to the left 
         ' side.
                If DIF < 0 Then Exit Do
         'If our byte is equal to the Pivot byte, we swap it to the extreme 
         ' right end.
                If DIF = 0 Then
                    TMP = P(OuterR)
                    P(OuterR) = P(InnerR)
                    P(InnerR) = TMP
                    OuterR = OuterR - 1
                End If
                InnerR = InnerR - 1
            Loop
        'If the inner pointers have crossed, we're done.
            If InnerL > InnerR Then Exit Do
        'Otherwise, we do the left/right swap we just set up.
            TMP = P(InnerL)
            P(InnerL) = P(InnerR)
            P(InnerR) = TMP
            InnerL = InnerL + 1
            InnerR = InnerR - 1
        Loop
    'We've arranged pointers to equal bytes on the far left and right,
    '  pointers to lower bytes 
    'on the inner left, and pointers to higher bytes on the inner right.  Now 
    ' we will swap the 
    'equals to the center, between the lowers and the highers.
        NLO = InnerL - OuterL
        NHI = OuterR - InnerR
        NEQ = N - (NLO + NHI)
        If OuterL - L < NLO Then SwapN = OuterL - L Else SwapN = NLO
        I = L
        J = InnerL - SwapN
    'Move the lefthand equals to center.
        Do While SwapN > 0
            TMP = P(I)
            P(I) = P(J)
            P(J) = TMP
            I = I + 1
            J = J + 1
            SwapN = SwapN - 1
        Loop
        If R - OuterR < NHI Then SwapN = R - OuterR Else SwapN = NHI
        I = InnerL
        J = R + 1 - SwapN
    'Move the righthand equals to center.
        Do While SwapN > 0
            TMP = P(I)
            P(I) = P(J)
            P(J) = TMP
            I = I + 1
            J = J + 1
            SwapN = SwapN - 1
        Loop
    'If there are more bytes, we increment DEPTH and recurse on the equals.
        If B(P(L+NLO) + DEPTH) <> 0 Then TernQuick L+NLO, L+NLO+NEQ-1, B, P, _
            DEPTH+1
    'Now we recurse on the lowers and highers; we do the shorter sublist first 
    ' to hold stack 
    'depth to log N.
        If NLO < NHI Then
            TernQuick L, L + NLO - 1, B, P, DEPTH
            TernQuick L + NLO + NEQ, L + NLO + NEQ + NHI - 1, B, P, DEPTH
        Else
            TernQuick L + NLO + NEQ, L + NLO + NEQ + NHI - 1, B, P, DEPTH
            TernQuick L, L + NLO - 1, B, P, DEPTH
        End If
    Else
    'A special version of InsertionSort that compares keys starting at depth 
    ' (since the
    'sublists we hand off to it will have identical prefixes.
        DeepInsertS B, P, L, N, DEPTH
    End If
End Sub

Function BGetMed(B() As Byte, P() As Long, L As Long, N As Long, _
    DEPTH As Integer) As Long
    Dim D As Long
    Dim PL As Long
    Dim PM As Long
    Dim PN As Long

        PL = L
        PN = L + N - 1
        PM = (PL + PN) \ 2
        If N > 30 Then
            D = N \ 8
            PL = BMed3(B, P, PL, PL + D, PL + 2 * D, DEPTH)
            PM = BMed3(B, P, PM - D, PM, PM + D, DEPTH)
            PL = BMed3(B, P, PN - 2 * D, PN - D, PN, DEPTH)
        End If
        BGetMed = BMed3(B, P, PL, PM, PN, DEPTH)
End Function

Function BMed3(B() As Byte, P() As Long, I As Long, J As Long, K As Long, _
    DEPTH As Integer) As Long
    Dim CI As Byte
    Dim CJ As Byte
    Dim CK As Byte
    
    CI = B(P(I) + DEPTH)
    CJ = B(P(J) + DEPTH)
    CK = B(P(K) + DEPTH)
    If (CI <= CJ And CJ <= CK) Or (CI >= CJ And CJ >= CK) Then
        BMed3 = J
    ElseIf (CJ <= CI And CI <= CK) Or (CJ >= CI And CI >= CK) Then
        BMed3 = I
    ElseIf (CI <= CK And CK <= CJ) Or (CI >= CK And CK >= CJ) Then
        BMed3 = K
    End If
End Function

Sub DeepInsertS(B() As Byte, P() As Long, L As Long, N As Long, D As Integer)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    Dim I As Long
    Dim J As Long
    
    For RP = L + 1 To L + N - 1
        TMP = P(RP)
        For LP = RP To L + 1 Step -1
            I = TMP + D
            J = P(LP - 1) + D
            Do While B(I) = B(J)
                If B(I) = 0 Or B(J) = 0 Then Exit Do
                I = I + 1
                J = J + 1
            Loop
            If CInt(B(I)) - CInt(B(J)) < 0 Then P(LP) = P(LP - 1) Else Exit For
        Next LP
        P(LP) = TMP
    Next RP
End Sub

Sub Strs2Bytes(A() As String, L As Long, R As Long, B() As Byte, P() As Long)
    Dim I As Long
    Dim nPtrs As Long
    Dim nBytes As Long
    Dim DEPTH As Integer
    
    nBytes = 0
    nPtrs = 0
    For I = L To R
        nBytes = nBytes + Strings.Len(A(I)) + 1
        nPtrs = nPtrs + 1
    Next I
    ReDim B(1 To nBytes)
    ReDim P(1 To nPtrs)
    
    nPtrs = 1
    nBytes = 1
    For I = L To R
        P(nPtrs) = nBytes
        For DEPTH = 1 To Strings.Len(A(I))
            B(nBytes) = Asc(Strings.MID(A(I), DEPTH, 1))
            nBytes = nBytes + 1
        Next DEPTH
        B(nBytes) = 0
        nBytes = nBytes + 1
        nPtrs = nPtrs + 1
    Next I
End Sub



David B. Ring


c0Title: Creating Splitter Bars
c1Code:
When designing a Visual Basic application, you may want to include code that allows the user to resize, for example, two Text Boxes by dragging and dropping a splitter bar. This article explains how to create a program that uses a splitter bar to enlarge or shrink the two Text Boxes to different sizes.

Resizing Text Boxes with a Splitter Bar

You can add both visual appeal and ease of use to a Visual Basic� application by including splitter bars. A splitter bar is a horizontal or vertical bar that the user clicks on to automatically resize a control, such as a Text Box, on a form. By using splitter bars, for instance, you can have two Text Boxes displayed on the application's window, one at the top of the form and the other at the bottom of the form. The splitter bar is positioned between the two text boxes. When the user drags the splitter bar (which is actually a Picture Box control) towards the top of the window, the first Text Box is made smaller and the second Text Box is made larger. Conversely, when the splitter bar is dragged towards the bottom of the window, the first Text Box grows in size vertically while the second Text Box shrinks in size vertically. This technique allows users to size the Text Box controls according to their own preferences, which also allows them to see more or less data in each individual control.

The key to creating a splitter bar in a Visual Basic application is the DragDrop event. Almost every control supports the DragDrop event. Each time a control is dropped at a new location, the DragDrop event is triggered. When the DragDrop event is triggered, the target control that you want to manipulate must contain the code to do whatever it is you want to do. In our example program below, we want to resize the text boxes, therefore we set the DragDrop event to trigger the Resize event for each Text Box on the form.

Each Text Box control is responsible for calling the Resize event of the program's main form, Form1. This Resize event causes Visual Basic to draw each Text Box control to its new size at its new position. This same technique can be applied to almost any other form or control except menus, timers, lines, and shapes.

Example Program
Create a new project in Visual Basic. Form1 is created by default. Set the following properties for Form1:

Height: 3735
Left: 1470
Top: 1320
Width: 6720


Add the following code to the Resize event for Form1:

Sub Form_Resize()
  Picture1.Left = 0
  'Make sure the form is not minimized!
  If Form1.ScaleHeight < Picture1.Height + 1 Then
      Form1.Height = Form1.Height - Form1.ScaleHeight + Picture1.Height + 1
  Else
      If Form1.ScaleHeight < Picture1.Top + Picture1.Height Then
          Picture1.Top = Form1.ScaleHeight - Picture1.Height - 1
  End If
 
  'Set Text1 to the Width and Height of form1
  Text1.Width = Form1.ScaleWidth
  Text1.Height = Form1.Picture1.Top
 
  Picture1.Width = Form1.ScaleWidth
 
  'Set Text2 to the Width and Height of Form1
  Text2.Top = Picture1.Top + Picture1.Height
  Text2.Width = Form1.ScaleWidth
  Text2.Height = Form1.ScaleHeight - Picture1.Top - Picture1.Height
  End If
End Sub


Add a Text Box control to Form1. Text1 is created by default. Set the following properties for Text1:

Height: 1815
Left: 0
Top: 0
Width: 6615


Add the following code to the DragDrop event for Text1:

Sub Text1_DragDrop(Source As Control, X As Single, Y As Single)
  If Y > 0 Then
      Picture1.Top = Y    'Move splitter bar.
      Form_Resize
  End If
End Sub


Add a second Text Box control to Form1. Text2 is created by default. Set the following properties for Text2:

Height: 1455
Left: 0
Top: 1920
Width: 6615


Add the following code to the DragDrop event for Text2:

Sub Text2_DragDrop(Source As Control, X As Single, Y As Single)
  If Y < Text2.Height Then
      Picture1.Top = Y + Text2.Top - Picture1.Height
      Form_Resize
  End If
End Sub


Add a Picture Box control to Form1. Picture1 is created by default. Set the following properties for Picture1:

BackColor: &H000000C0 (the color red)
DragMode: 1 (automatic)
DrawStyle: 0 (solid)
Height: 135
Left: 0
MousePointer: 7 (size n s)
Top: 1800
Width: 6495


Run the example program. A red bar (that is, the Picture Box control) separates the top Text Box from the bottom Text Box. You can resize either Text Box by clicking on the red bar and dragging the bar towards the top or bottom of Form1. When you release the mouse button, both Text Boxes are resized accordingly.


c0Title: Creating An Easy Status Bar
c1Code:
This tip contains code that creates a Status bar using only a Picture box and a Timer. I have modularized this code to the point where you should be able to just drop it into your projects and go. In order for this to work all you need is a form, a picture box, and a timer. Do the following:

Create A Form

In the Form_KeyDown() Event, add the following snippet:

UpdateKeyPanels StatPanel, sb_panels()


In the Form_Load() Event, add the following snippet:

    Dim iSuc%
    CreatePanels sb_panels()
    iSuc% = InitializeStatusBar(Me, sb_panels())
    sb_initialize = True


In the General Declarations Section add the following lines

Dim sb_panels() as cPanelData
Dim sb_initialized as Integer


Add a PictureBox with the following properties set:

Name - StatPanel


In the Resize Event of the PictureBox add the following code snippet:

If Me.WindowState <> 1 Then
    If sb_initialized Then DisplayStatusBar Me.StatPanel, sb_panels()
End If


Add a Timer Control with the following properties set:

Name=StatTimer      
Enabled = False
Interval = 200


In the Timer Event add the following code snippet

UpdateStatusPanels StatPanel, sb_panels()


In this code, a status bar is divided into panels. Each panel is an element of an array of type cPanelData (see the STATBAR2.BAS file for the description). Order of how the panels are placed are also dependent on you. You set the panel descriptions and the order in the CreatePanels procedure. (see the procedure on the STATBAR2.BAS on how to configure the panels.) If you want to use multiple forms, then cut and paste the CreatePanels procedure into each form's General Declaration section. I have tried these using MDI forms with many child forms and it seems to work with no problem. At least, I haven't had it crash as of yet.

Below are the types of panels in the code.

SBAR_TEXT - Panel Containing only Text (Dynamic width - changes during a resize event. All others are static)
SBAR_DATE - Panel that displays the date.
SBAR_TIME - Panel that displays the time.
SBAR_CAPSLOCK - Panel that displays the current status of the CAPSLOCK key
SBAR_NUMLOCK - Panel that displays the current status of the NUMLOCK key
SBAR_SCROLL - Panel that displays the current status of the SCROLL LOCK key
SBAR_COUNTER - Panel that displays counts.. for whatever. - it's right aligned.

The SBAR_TEXT panel has dynamic width in that its width changes when you resize the Form. All others maintain there width, regardless of the size of the form. The SBAR_TEXT types are easily lost in real small windows, but if a user decides to reduce the window size to a point where you can't see it anyway, what difference does it make?

Some Notes on the Code

This code works fairly consistently but is intentionally left ambiguous so that you can modify it for your needs. This is just merely a template and there are other ways to use it. You certainly can add more types of panel properties, or settings or types, or whatever. The idea behind this whole thing was to provide something that is easy to use and effective without having to add a VBX and yet increase functionality.

All of the code is documented in such a way as to explain each function and how you can use it. I have tried to modularize it in such a way to make it easy to incorporate. My library files are getting larger and larger and so now, when I need some functionality, I just add the file, make the calls and voila'.. a new program. This code is the work of some of that library work and is for your use. This is just my way of returning a little bit back to all those who I have learned and borrowed.

Tip Submitted By:M. John Rodriguez


c0Title: Converting Numbers to Words
c1Code:
Through popular demand, we have written this function for converting a number into words. Although not fully tested, in theory it will work for numbers up to one billion billion (10^24), which should cater for most people's needs. If you can think of a better way to do this, please send me an email.

Public Function numtoword(numstr As Variant) As String
    'The best data type to feed in is 
    'Decimal, but it is up to you
    Dim tempstr As String
    Dim newstr As String

    numstr = CDec(numstr)

    If numstr = 0 Then
        numtoword = "zero "
        Exit Function
    End If

    If numstr > 10 ^ 24 Then
        numtoword = "Too big"
        Exit Function
    End If

    If numstr >= 10 ^ 12 Then
        newstr = numtoword(Int(numstr / 10 ^ 12))
        numstr = ((numstr / 10 ^ 12) - Int(numstr / 10 ^ 12)) * 10 ^ 12

        If numstr = 0 Then
            tempstr = tempstr & newstr & "billion "
        Else
            tempstr = tempstr & newstr & "billion, "
        End If
    End If

    If numstr >= 10 ^ 6 Then
        newstr = numtoword(Int(numstr / 10 ^ 6))
        numstr = ((numstr / 10 ^ 6) - Int(numstr / 10 ^ 6)) * 10 ^ 6

        If numstr = 0 Then
            tempstr = tempstr & newstr & "million "
        Else
            tempstr = tempstr & newstr & "million, "
        End If
    End If

    If numstr >= 10 ^ 3 Then
        newstr = numtoword(Int(numstr / 10 ^ 3))
        numstr = ((numstr / 10 ^ 3) - Int(numstr / 10 ^ 3)) * 10 ^ 3

        If numstr = 0 Then
            tempstr = tempstr & newstr & "thousand "
        Else
            tempstr = tempstr & newstr & "thousand, "
        End If
    End If

    If numstr >= 10 ^ 2 Then
        newstr = numtoword(Int(numstr / 10 ^ 2))
        numstr = ((numstr / 10 ^ 2) - _
        Int(numstr / 10 ^ 2)) * 10 ^ 2

        If numstr = 0 Then
            tempstr = tempstr & newstr & "hundred "
        Else
            tempstr = tempstr & newstr & "hundred and "
        End If
    End If

    If numstr >= 20 Then
        Select Case Int(numstr / 10)
        Case 2
            tempstr = tempstr & "twenty "
        Case 3
            tempstr = tempstr & "thirty "
        Case 4
            tempstr = tempstr & "forty "
        Case 5
            tempstr = tempstr & "fifty "
        Case 6
            tempstr = tempstr & "sixty "
        Case 7
            tempstr = tempstr & "seventy "
        Case 8
            tempstr = tempstr & "eighty "
        Case 9
            tempstr = tempstr & "ninety "
        End Select

        numstr = ((numstr / 10) - Int(numstr / 10)) * 10
    End If

    If numstr > 0 Then
        Select Case numstr
        Case 1
            tempstr = tempstr & "one "
        Case 2
            tempstr = tempstr & "two "
        Case 3
            tempstr = tempstr & "three "
        Case 4
            tempstr = tempstr & "four "
        Case 5
            tempstr = tempstr & "five "
        Case 6
            tempstr = tempstr & "six "
        Case 7
            tempstr = tempstr & "seven "
        Case 8
            tempstr = tempstr & "eight "
        Case 9
            tempstr = tempstr & "nine "
        Case 10
            tempstr = tempstr & "ten "
        Case 11
            tempstr = tempstr & "eleven "
        Case 12
            tempstr = tempstr & "twelve "
        Case 13
            tempstr = tempstr & "thirteen "
        Case 14
            tempstr = tempstr & "fourteen "
        Case 15
            tempstr = tempstr & "fifteen "
        Case 16
            tempstr = tempstr & "sixteen "
        Case 17
            tempstr = tempstr & "seventeen "
        Case 18
            tempstr = tempstr & "eighteen "
        Case 19
            tempstr = tempstr & "nineteen "
        End Select

        numstr = ((numstr / 10) - Int(numstr / 10)) * 10
    End If

    numtoword = tempstr
End Function


Thanks to an anonymous person from Cheats World for this alternative, shorter function:

Dim Number2s(2 To 9) As String
Dim Number1s(1 To 19) As String
Dim Steps(1 To 4) As String

Public Function NumToWord(Numstring As Variant) As String
If Steps(1) = "" Then initstrings
Dim Tempstring As String
Dim Newstring As String
Dim What As Double

If Numstring = 0 Then
  NumToWord = "zero"
  Exit Function
End If

If Numstring > (10 ^ 24) Then _
  NumToWord = "Number is too big"
  Exit Function
End If

Counter = 0
Do
  Counter = Counter + 1
  If Counter > 1 Then
    What = 10 ^ (12 \ ((Counter - 1) * 2))
  Else
    What = 10 ^ 12
  End If

  If Numstring >= What Then
  Newstring = NumToWord(Fix(Numstring / What))
  Numstring = ((Numstring / What) - Fix(Numstring / What)) * What
  If Numstring = 0 Then
    Tempstring = Tempstring & Newstring & Steps(Counter) & " "
  Else
    If Counter = 4 Then
    Tempstring = Tempstring & Newstring & _
    Steps(Counter) & " and ": GoToSkipit
    Tempstring = Tempstring & Newstring & _
    Steps(Counter) & ", "
    Skipit:
  End If
End If

Loop Until Counter = 4

If Numstring >= 20 Then _
Tempstring = Tempstring & _
Number2s(Fix(Numstring / 10)) & " "

If Numstring >= 10 And Numstring < 20 Then _
Tempstring = Tempstring & Number1s(CInt(Numstring)) _
& " ": GoTo Skip2

Numstring = ((Numstring / 10) - Fix(Numstring / 10)) * 10

If Numstring > 0 Then Tempstring = Tempstring & _
Number1s(CInt(Numstring)) & " "
Skip2:

NumToWord = Tempstring

End Function

Public Sub initstrings()
Steps(1) = "billion"
Steps(2) = "million"
Steps(3) = "thousand"
Steps(4) = "hundred"
Number1s(1) = "one"
Number1s(2) = "two"
Number1s(3) = "three"
Number1s(4) = "four"
Number1s(5) = "five"
Number1s(6) = "six"
Number1s(7) = "seven"
Number1s(8) = "eight"
Number1s(9) = "nine"
Number1s(10) = "ten"
Number1s(11) = "eleven"
Number1s(12) = "twelve"
Number1s(13) = "thirteen"
Number1s(14) = "fourteen"
Number1s(15) = "fifteen"
Number1s(16) = "sixteen"
Number1s(17) = "seventeen"
Number1s(18) = "eighteen"
Number1s(19) = "nineteen"
Number2s(2) = "twenty"
Number2s(3) = "thirty"
Number2s(4) = "forty"
Number2s(5) = "fifty"
Number2s(6) = "sixty"
Number2s(7) = "seventy"
Number2s(8) = "eighty"
Number2s(9) = "ninety"
End Sub


Tip by John Percival


c0Title: Enhanced Trim Function
c1Code:
The Trim function has a serious shortcoming: It handles only space characters�not all the usual white spaces such as tabs, carriage returns, and line feeds. Instead of the standard Trim function, use my TrimAll function, which handles all white spaces. In fact, you can extend it to trim off any character by editing the assignment to the ToEliminate string variable:

Public Function TrimAll(ToTrim As String) As String
       Static ToEliminate As String
       Dim Start As Long, Finish As Long

       ' Base condition test
       If Len(ToTrim) = 0 Then
             TrimAll = ""
              Exit Function
       End If

       ' Define the characters (once) that we want to trim off
       If Len(ToEliminate) = 0 Then
             ToEliminate = Chr(0) & Chr(8) & Chr(9) & Chr(10) & Chr(13) & Chr(32)
       End If

       ' Find the beginning of nonblank string by checking  
       ' each char against a list of blank chars.
       Start = 1

       Do While Start <= Len(ToTrim)
             If InStr(ToEliminate, Mid$(ToTrim, Start, 1)) Then
                    Start = Start + 1
             Else
                    Exit Do
             End If
       Loop

       ' Find the end of nonblank string.
       Finish = Len(ToTrim)

       Do While Finish > 1
             If InStr(ToEliminate, Mid$(ToTrim, Finish, 1)) Then
                           Finish = Finish - 1
             Else
                    Exit Do
             End If
       Loop

       If Start > Finish Then
             ' If the string is completely blank,
             ' Start will be greater than Finish.
             TrimAll = ""
             Exit Function
       Else
             ' Trim out the real contents
             TrimAll = Mid$(ToTrim, Start, Finish - Start + 1)
       End If
End Function


�Konstantin Komissarchik, Brier, Washington


c0Title: Enhanced Replace Function
c1Code:
If you�re faced with a string that needs to have certain characters removed from it, use the Replace() function to make the problem more manageable. For instance, use this code to remove all a�s from a particular string:

Debug.Print Replace("abababa", "a", "")


This statement works fine when you want only a single character removed, but if you have a long list of suspects, you have to do serious copy-and-paste. Avoid that by using this function:

Public Function StripOut(ByVal From As String, ByVal What As String) As String
       Dim i As Integer

       For i = 1 To Len(What)
             From = Replace(From, Mid$(What, i, 1), "")
       Next i

       StripOut = From
End Function


Just place this code somewhere in your program�preferably in a module�and call it like this:

Debug.Print StripOut("abcdefg", "bdf")


This call returns a string with all b, d, and f characters removed.

�Konstantin Komissarchik, Brier, Washington


c0Title: Catch Every TabStrip Click Event
c1Code:
You might have noticed that if you click on a TabStrip tab, then move the mouse pointer until it�s no longer over the TabStrip without releasing the mouse button, the Click event doesn�t fire even though the tab is changed. To detect this behavior, use this code:

 
Private Sub TabStrip1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
     If X < 0 Or X > TabStrip1.Width Or _
          Y < 0 Or Y > TabStrip1.Height Then 
               TabStrip1_Click
     End If
End Sub


This calls the Click event code if you do not release the mouse button above the TabStrip. You can�t just put the Click handling code in the MouseUp event because then keyboard tab changes wouldn�t work.

�Matt Hart, Tulsa, Oklahoma


c0Title: Contain Tab Groupings Within a Frame
c1Code:
The best way to work with the tab control is to set up a different frame for each tab. If you set the frames to be indexed, you can quickly move and make the correct frame visible with this code:

' Move and resize the frames to the tabstrip ' control and make the first one visible.
' This should be called in the Form_Load event.
For i = 0 To fraTab.Count - 1
	fraTab(i).Move TabStrip1.ClientLeft, _
	TabStrip1.ClientTop, TabStrip1. _
	ClientWidth, TabStrip1.ClientHeight
	fraTab(i).Visible = (i = 0)
Next i

' To make the correct frame visible use the value ' SelectedItem.Index -1 as the index for the Frames.
' Put this code in the TabStrip1_Click event.
For i = 0 To fraTab.Count - 1
	fraTab(i).Visible = (i = (TabStrip1.SelectedItem.Index - 1)) Next i


This approach works with any number of tabs on the TabStrip control.

�Wayne Matheson, Elizabethtown, Kentucky


c0Title: Emulating Overstrike Mode In Text Boxes
c1Code:
Windows text boxes always work in insert mode and don�t provide an overstrike mode. However, overstrike mode can easily be emulated as shown here:

Sub Text1_KeyPress (KeyAscii As Integer)
    If KeyAscii >= 32 Then
        If Text1.SelLength = 0 Then
            If Text1.SelStart < Len(Text1) Then
                Text1.SelLength = 1
            End If
        End If
    End If
End Sub


If a key is typed when no text is selected, the code selects the current character by setting the SelLength property to 1, causing it to be overwritten by the key typed. If the cursor is already at the end of the text, setting the SelLength property to 1 is silently ignored. Several conditions are tested to ensure that a control character (such as Tab or Enter) was not pressed, that the user hasn�t already highlighted text to be replaced, and that the caret is not at the end of the existing text.

�Jonathan Wood and Karl Peterson


c0Title: Check For TextBox Entries
c1Code:
A few times I've had a Form with a lot of TextBoxes on it, and all of them had to be filled by the user. If even one TextBox was left empty, the program could not proceed. Rather than looping manually through every TextBox on the Form, I came up with the following: A function with the Form as a single argument. Loop through each control on the Form, (using "For Each Control etc") and if it's a TextBox which is empty, it returns Err.Number = 0. If this is true, I change the BackColor of the offending TextBox to light pink, and the function returns True. (If the TextBox is not empty, and it's BackColor is light pink, I return the BackColor to white. One can store the original color and restore it.) Then call Err. Clear, and continue in the loop. All TextBoxes which are empty will show up as light pink.

To test, create a Form with several TextBoxes on it; their names are immaterial, and they can even be in some container, like a Frame. Create a Command Button, named TestEmpty. Following is the code:

Private Sub TestEmpty_Click()

  If IsEmpty(Me) Then
    MsgBox "Some textboxes are still empty"
  End If

End Sub

Function IsEmpty(Frm As Form) As Boolean Dim tmpControl As Control

  On Error Resume Next

  IsEmpty = False
  For Each tmpControl In Frm.Controls
    If Trim(tmpControl.Text) = "" Then
      If Err.Number = 0 Then
        IsEmpty = True
        tmpControl.BackColor = &HFFC0FF 'light pink
      End If
      Err.Clear
    Else
      If tmpControl.BackColor = &HFFC0FF Then
        tmpControl.BackColor = QBColor(15) 'White
      End If

    End If

  Next tmpControl

End Function


Run the program. Fill in some of the TextBoxes, and click on the Command Button, You will see the empty TextBoxes BackColor change to light pink. If you fill these in and click again, their BackColor will change to white. Note: If the procedure is in a Module, then the argument is the Form name.

Tip Submitted By: Yehuda Hilewitz 


c0Title: Disabling The TextBox Beep
c1Code:
Normally, the Text Box control will beep when the user presses the Enter key. This behavior can be annoying, especially when you�re using the Enter key to tab from one Text Box to the next. Here�s an easy way to disable the Text Box beep.

Sub Text1_KeyPress (KeyAscii As Integer)
     If KeyAscii = 13 Then      '13 is Key_Return
           KeyAscii = 0 '0 is nothing
     End If
End Sub


c0Title: Allow Interval Greater Than Timer Controls
c1Code:
VB5, VB6

Allow Interval Greater Than Timer Controls

When you need a timer for a larger interval than the Timer control allows, insert this code into a BAS module. The procedure starts when the timer interval has passed:

Dim lTimerId As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long 

Private Sub TimerProc(ByVal lHwnd As Long, ByVal lMsg As Long, ByVal lTimerId As Long, ByVal lTime As Long) 
Dim lResult As Long 
lResult = StopTimer(lTimerId) 
Call InsertYourProcessNameHere 'code to be executed after interval 
End Sub 

Public Sub StartTimer(lInterval As Long) 
'convert interval to milliseconds prior to passing 
lTimerId = SetTimer(0, 0, lInterval, AddressOf TimerProc) 
End Sub 

Public Function StopTimer(lTimerId As Long) As Long 
'must pass the TimerId returned by SetTimer 
StopTimer = KillTimer(0, lTimerId) 
End Function 


This call executes the procedure:

Call StartTimer(5000) '5 seconds


You can stop the timer before the interval by calling the StopTimer function.
�Alex Whyte, Como, Australia


c0Title: Build Your Own Floating Toolbar
c1Code:
Ever wanted a floating toolbar? To make one form "owned" by another, all it takes is a simple API call. Afterwards, the owned form will float above the form that owns it, and will be automatically hidden whenever the owner form is minimized. To set up such a relationship, use SetWindowWord with the constant SWW_HPARENT:

Declare Sub SetWindowWord Lib "User" (ByVal hWnd%, ByVal nCmd%, ByVal nVal%) Global Const SWW_HPARENT = -8 Call SetWindowWord(frmOwned.hWnd, SWW_HPARENT, frmOwner.hWnd)


�Karl E. Peterson


c0Title: Check if a Node Exists with the Specified Key
c1Code:

'Returns TRUE if there is a tree node with the specified key
Public Function TreeNodeExists(oTree As TreeView, sKey As String) As Boolean
    
    Dim oNode As Node
    
    On Error GoTo ErrorHandler
    
    Set oNode = oTree.Nodes(sKey)
    TreeNodeExists = True
    Exit Function
    
ErrorHandler:
    TreeNodeExists = False
End Function


c0Title: Convert Empty Strings to Nulls
c1Code:
'Opposite of Nz function: If the value is an empty string
'return a null variant, otherwise return the original value
Public Function Zn(vValue As Variant) As Variant
    If vValue = vbNullString Then
        Zn = Null
    Else
        Zn = vValue
    End If
End Function


c0Title: Convert Boolean Values Between 0/1 and 0/-1
c1Code:
'Converts 0/1 values to 0/-1 for boolean comparisons
'All non-zero values are converted to -1 (true)
'Blank values are converted to 0 (false)
Function IntToBool(vValue As Variant) As Long
    If IsNumeric(vValue) Then
        IntToBool = (vValue <> 0)
    Else
        IntToBool = 0
    End If
End Function


'Converts boolean values to 0/1 values
Function BoolToInt(bValue As Boolean) As Long
    
    If (bValue = True) Then
        BoolToInt = 1
    Else
        BoolToInt = 0
    End If

End Function


c0Title: Check if an Object is Nothing
c1Code:
'Check if an object is nothing
Public Function IsNothing(ByRef objReference As Object) As Boolean
    If objReference Is Nothing Then
        IsNothing = True
    Else
        IsNothing = False
    End If
End Function


c0Title: Endian Reverse
c1Code:
This function uses the CopyMemory API two switch to and from little-endian and big-endian formats. This could be useful if you need to exchange data with other platforms.

Code:

Option Explicit

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal length As Long) As Long

Private Sub EndianReverse(lpPointer As Long, nLen As Long)
    'Reverses the data pointed to by lpPointer
    ' nLen is the length of the data

    Dim nArray() As Byte
    ReDim nArray(1 To nLen)
    Dim i As Long
    
    'Copy the data to the byte array
    CopyMemory nArray(1), ByVal lpPointer, nLen
    
    'Copy the data from the byte array back to the main
    ' buffer, reversing the data as we go
    For i = 1 To nLen
        CopyMemory ByVal lpPointer + i - 1, nArray(nLen - i + 1), 1
    Next

End Sub


Sample Usage:

        
Dim TheNumber As Long
    
TheNumber = &H12345678
EndianReverse VarPtr(TheNumber), Len(TheNumber)
Debug.Print Hex(TheNumber) ' = 78563412


c0Title: Close a Window in another Application
c1Code:
Modify the lnghWND variable to be the Window Handle of the window you want to close and this code will close the Window. You can use the FindWindow API to find the Window Handle of the form you are looking for.

Private Const WM_CLOSE = &H10

Dim lngResult As Long
Dim lnghWND as Long
    
lngResult = SendMessage(lnghWND, WM_CLOSE, 0&, 0&)


c0Title: Enable/Disable Windows XP ClearType Font Smoothing
c1Code:
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

Const SPI_SETFONTSMOOTHING As Long = 75
Const SPIF_UPDATEINIFILE As Long = &H1
Const SPIF_SENDWININICHANGE As Long = &H2 Const SPIF_SENDCHANGE As Long = SPIF_SENDWININICHANGE Const SPI_SETFONTSMOOTHINGTYPE As Long = &H200B Const FE_FONTSMOOTHINGCLEARTYPE As Long = &H2


Sub ClearTypeMode(Mode As Boolean)
    If Mode = True Then
        'Enable font smoothing
        SystemParametersInfo SPI_SETFONTSMOOTHING, True, 0, SPIF_UPDATEINIFILE Or SPIF_SENDCHANGE
        'Set ClearType smoothing style
        SystemParametersInfo SPI_SETFONTSMOOTHINGTYPE, FE_FONTSMOOTHINGCLEARTYPE, 0, SPIF_UPDATEINIFILE Or SPIF_SENDCHANGE
    Else
        'Disable font smoothing
        SystemParametersInfo SPI_SETFONTSMOOTHING, False, 0, SPIF_UPDATEINIFILE Or SPIF_SENDCHANGE
    End If
End Sub


c0Title: Enable/Disable ScreenSaver
c1Code:
Public Const SPI_SETSCREENSAVEACTIVE = 17

Public Declare Function SystemParametersInfo Lib "user32" _ 
     Alias "SystemParametersInfoA" (
     ByVal uAction As Long, 
     ByVal uParam As Long, 
     ByRef lpvParam As Any, 
     ByVal fuWinIni As Long) As Long


Public Sub ShowScreenSaver(blnActive As Boolean)
    Dim lngActive As Long

    lngActive = IIf(blnActive, 1, 0)
    SystemParametersInfo SPI_SETSCREENSAVEACTIVE, lngActive, 0, 0

End Sub


c0Title: Blocking Shell Command
c1Code:
This function mimics the VB Shell function, however it waits for the completion of the shelled function to finish, which can be very useful sometimes.

Code:

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long 
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const INFINITE = &HFFFF
Private Const SYNCHRONIZE = &H100000
Private Const WAIT_TIMEOUT = &H102

Public Sub ShellAndWait(PathName, Optional WindowStyle As VbAppWinStyle = vbMinimizedFocus, Optional bDoEvents As Boolean = False)

    Dim dwProcessID As Long
    Dim hProcess As Long
    
    dwProcessID = Shell(PathName, WindowStyle)
    
    If dwProcessID = 0 Then
        Exit Sub
    End If
    
    hProcess = OpenProcess(SYNCHRONIZE, False, dwProcessID)
    
    If hProcess = 0 Then
        Exit Sub
    End If
    
    If bDoEvents Then
        Do While WaitForSingleObject(hProcess, 100) = WAIT_TIMEOUT
            DoEvents
        Loop
    Else
        WaitForSingleObject hProcess, INFINITE
    End If
    
    CloseHandle hProcess
    
End Sub


Sample Usage:

        
Dim nStart As Date
nStart = Now
ShellAndWait "notepad", vbNormalFocus, True
MsgBox "You spent " & DateDiff("s", nStart, Now) & " second(s) in notepad.", vbCritical


c0Title: Blocking or Non-Blocking Shell With Notification of Completion
c1Code:
Option Compare Database
Option Explicit

Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   dwX As Long
   dwY As Long
   dwXSize As Long
   dwYSize As Long
   dwXCountChars As Long
   dwYCountChars As Long
   dwFillAttribute As Long
   dwFlags As Long
   wShowWindow As Integer
   cbReserved2 As Integer
   lpReserved2 As Long
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Private Const STATUS_PENDING = &H103&

'Execute an application and wait for it to terminate
Public Function ShellBlocking(ByVal sCommand As String, ByVal sPath As String) As Long
    Dim Proc As PROCESS_INFORMATION
    Dim Start As STARTUPINFO
    Dim iReturn As Long
        
    ' Initialize the STARTUPINFO structure:
    Start.cb = Len(Start)
    
    ' Start the shelled application:
    iReturn = CreateProcessA(vbNullString, sCommand, 0&, 0&, 1&, _
                             NORMAL_PRIORITY_CLASS, 0&, sPath, Start, Proc)
    
    Do
        GetExitCodeProcess Proc.hProcess, iReturn
        DoEvents
        Sleep 100
    Loop While iReturn = STATUS_PENDING
    
    Call CloseHandle(Proc.hThread)
    Call CloseHandle(Proc.hProcess)
    ShellBlocking = iReturn
End Function


'Run a program and return the process handle (which can be used by ShellWait)
'The handle must be closed by calling ShellFinished until the program ends or
'by calling ShellKill to terminate the application
Public Function ShellHandle(ByVal sCommand As String, ByVal sPath As String) As Long
    
    Dim Proc As PROCESS_INFORMATION
    Dim Start As STARTUPINFO
    Dim iReturn As Long
        
    ' Initialize the STARTUPINFO structure:
    Start.cb = Len(Start)
    
    ' Start the shelled application:
    CreateProcessA vbNullString, sCommand, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, sPath, Start, Proc
    ShellHandle = Proc.hProcess
    
    Call CloseHandle(Proc.hThread)

End Function


'Check if the specified process has finished
'If the application has ended, the handle is closed
Public Function ShellFinished(hProcess As Long) As Boolean
    Dim iReturn As Long
    
    GetExitCodeProcess hProcess, iReturn
    
    If iReturn = STATUS_PENDING Then
        ShellFinished = False
    Else
        CloseHandle hProcess
        ShellFinished = True
    End If

End Function


'Terminate the specified process and close the handle
Public Function ShellKill(hProcess As Long) As Boolean

    If TerminateProcess(hProcess, 0&) <> 0 Then
        ShellKill = True    'Success
    Else
        ShellKill = False
    End If

    CloseHandle hProcess
    
End Function


c0Title: Adding Custom File Types To The Win95 Registry
c1Code:
Here is some cool information on how to add your own program file. By this I mean how to add one of those things like when you click a HTML file, Netscape or Internet Explorer open up, or when you click a DOC file, Word opens up. This is not a very hard task, it involves some simple registry edits.

What each File type has, is some information in the 'HKEY_CLASSES_ROOT' Registry Root. This is where we will place our little file type. In this little document, we will call our file type *.hyp and the File Name will be Test_File_Hype (you can't have spaces).

Firstly you need to make an edit in the HKEY_CLASSES_ROOT under .hyp. So:

HKEY_CLASSES_ROOT\.hyp

In the [Default] part of the Key, you will need to place "Test_File_Hype". Then we need another edit and that is the Test_File_Hype under HKEY_CLASSES_ROOT. So:

HKEY_CLASSES_ROOT\Test_File_Hype

Under that we need another one:

HKEY_CLASSES_ROOT\Test_File_Hype\Shell

And another under that:

HKEY_CLASSES_ROOT\Test_File_Hype\Shell\Open

Under open goes Command. So:

HKEY_CLASSES_ROOT\Test_File_Hype\Shell\Open\Command

As the default value of the Command, place:

     your application path.exe %1

     (eg. C:\WINDOWS\HYP\HYP.EXE %1)

You must remember that you need to already expect the File to be opened that way in your application, checking the Command$() whenever your application is opened. That is important, otherwise your application will not open it.

You would probably like your file to carry your EXE's Icon as well. This is very simply done with the following Registry edit:

HKEY_CLASSES_ROOT\Test_File_Hype\DefaultIcon

As the Default Value place:

     your application path.EXE,0


Pretty cool, huh?! The last part, the zero, means that the icon is the main icon as the program. You could place other numbers if your application contains multiple icons (For example an icon just for the file.).


c0Title: Call Windows Shell Features
c1Code:
Here�s a little routine that provides a quick and dirty way to call up some of the more oddball features of the Windows shell. It works by emulating user keystrokes, so you�ll need to modify the keys for non-English versions. Simply paste this code into a standard module and pass the Enum of choice:

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Public Enum SystemKeyShortcuts
    ExplorerNew = &H45            ' Asc("E")
    FindFiles = &H46              ' Asc("F")
    MinimizeAll = &H4D            ' Asc("M")
    RunDialog = &H52              ' Asc("R")
    StartMenu = &H5B              ' Asc("[")
    StandbyMode = &H5E            ' Asc("^") -- Win98 only!
End Enum

Public Sub SystemAction(VkAction As SystemKeyShortcuts)
    Const VK_LWIN = &H5B
    Const KEYEVENTF_KEYUP = &H2
    Call keybd_event(VK_LWIN, 0, 0, 0)
    Call keybd_event(VkAction, 0, 0, 0)
    Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
End Sub


�Randy Birch, East York, Ontario, Canada


c0Title: Closing another Application
c1Code:
1. Start a new Standard.Exe Project.
2. Place 2 Command buttons on Form1 (Command1 & Command2).
3. Copy/Paste the following into the Form1 code window.

Option Explicit 

Private m_lngProcessId As Long 

Private Sub Command1_Click() 
   m_lngProcessId = Shell("calc.exe", vbNormalFocus) 
End Sub 

Private Sub Command2_Click() 
   Call xCloseWindow(m_lngProcessId) 
End Sub 

Private Sub Form_Load() 
   Command1.Caption = "Start Calculator" 
   Command2.Caption = "Close Calculator" 
End Sub 

Private Sub Form_Resize() 
   With Screen 
      Form1.Move .Width * 0.25, .Height * 0.25, .Width * 0.5, .Height * 0.5 
   End With 

   With Me 
      Command1.Move 0, 0, .ScaleWidth * 0.5, .ScaleHeight 
      Command2.Move .ScaleWidth * 0.5, 0, .ScaleWidth * 0.5, .ScaleHeight 
   End With 
End Sub 


4. Add a (Vb Menu -> Project -> Add Module) Module to the Project (Module1).
5. Copy/Paste the following into Module1.

Option Explicit 

Private Const WM_CLOSE = &H10 

Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long 
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long 
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 

Public Function xCloseWindow(ByVal lngProcessId As Long) As Boolean 
   Call EnumWindows(AddressOf xCloseWindowCallBack, lngProcessId) 
End Function 

Private Function xCloseWindowCallBack(ByVal i_hWnd As Long, ByVal i_lpData As Long) As Long 
   Dim lngParenthWnd As Long 
   Dim lngThreadId As Long 
   Dim lngProcessId As Long 
   lngThreadId = GetWindowThreadProcessId(i_hWnd, lngProcessId) 
   If i_lpData = lngProcessId Then 
       lngParenthWnd = GetParent(i_hWnd) 
       If lngParenthWnd = 0 Then 
           Call SendMessage(i_hWnd, WM_CLOSE, 0&, 0&) 
       End If 
   End If 
   xCloseWindowCallBack = 1 
End Function 


6 Press F5 to run.
Click on the "Start Calculator" command button..
.. and the Windows Calculator program will begin.
Click on the "Close Calculator" command button..
.. and the Windows Calculator program will end. 


c0Title: Closing another Program
c1Code:
' Close an existing program
title = "MyAPP" 'The title of the app you want to close.
ihWnd = findWindow(0&, Title)
ihTask = GetWindowTask (ihWnd)
iRet = PostAppMessage(ihTask, WM_QUIT, 0, 0&)


Now this code requires the use of a few Api calls, but you can use the api wizard to grab their declarations and paste them into your code!


c0Title: Control the Panel
c1Code:
Need to run items from the Control Panel? This sneaky set of code snippets show you how to do everything, from launching the Display Properties through to starting the Dial-Up Networking Wizard - all in one line of code.

Simply scroll through the below list and copy-and-paste the command you require!

This code works by using the shell command to execute RunDLL32.exe, passing it special arguments pertaining to individual Control Panel items.

' Display the Control Panel
Call Shell("rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus)

'Display the Accessibility Properties
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl", vbNormalFocus)

'Display Add/Remove Programs
Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl", vbNormalFocus)

'Show the Display Settings (Background)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", vbNormalFocus)

'Show the Display Settings (Screensaver)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1", vbNormalFocus)

'Show the Display Settings (Appearance)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2", vbNormalFocus)

'Show the Display Settings (Settings)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3", vbNormalFocus)

'Display Internet Properties
Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl", vbNormalFocus)

'Display Regional Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl", vbNormalFocus)

'Display the Joystick Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL joy.cpl", vbNormalFocus)

'Display the Mouse Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", vbNormalFocus)

'Display the Keyboard Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", vbNormalFocus)

'Display Printers
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @2", vbNormalFocus)

'Display Fonts
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @3", vbNormalFocus)

'Display Multimedia Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl", vbNormalFocus)

'Display Modem Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", vbNormalFocus)

'Display Dial-Up Networking Wizard (on Win9x)
Call Shell("rundll32.exe rnaui.dll,RnaWizard", vbNormalFocus)

'Display System Properties
Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl", vbNormalFocus)

'Run 'Add New Hardware' Wizard (on Win9x)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", vbNormalFocus)

'Display 'Add New Printer' Wizard (on Win9x)
Call Shell("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus)

'Display Themes Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL themes.cpl", vbNormalFocus)

'Display Time/Date Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", vbNormalFocus)


Tip by Karl Moore


c0Title: CreateFileAssociation - Associate a file extension to a program
c1Code:
Private Declare Sub SHChangeNotify Lib "shell32.dll" (ByVal wEventId As Long, ByVal uFlags As Long, ByVal dwItem1 As Long, ByVal dwItem2 As Long) 
Const SHCNE_ASSOCCHANGED = &H8000000 
Const SHCNF_IDLIST = 0

' Create the new file association
'
' Extension is the extension to be registered (eg ".cad"
' ClassName is the name of the associated class (eg "CADDoc") ' Description is the textual description (eg "CAD Document"
' ExeProgram is the app that manages that extension (eg "c:\Cad\MyCad.exe") '
' NOTE: requires CreateRegistryKey and SetRegistryValue functions

Sub CreateFileAssociation(ByVal Extension As String, ByVal ClassName As String, ByVal Description As String, ByVal ExeProgram As String)
  Const HKEY_CLASSES_ROOT = &H80000000
  
  ' ensure that there is a leading dot
  If Left(Extension, 1) <> "." Then
    Extension = "." & Extension
  End If
  
  ' create a new registry key under HKEY_CLASSES_ROOT
  CreateRegistryKey HKEY_CLASSES_ROOT, Extension
  ' create a value for this key that contains the classname
  SetRegistryValue HKEY_CLASSES_ROOT, Extension, "", ClassName
  ' create a new key for the Class name
  CreateRegistryKey HKEY_CLASSES_ROOT, ClassName & "\Shell\Open\Command"
  ' set its value to the command line
  SetRegistryValue HKEY_CLASSES_ROOT, ClassName & "\Shell\Open\Command", "", ExeProgram & " ""%1"""

  ' notify Windows that file associations have changed
  SHChangeNotify SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0 
End Sub


c0Title: Creating Program Manager Groups & Icons
c1Code:
The first step is to add a label to a form. This example assumes you are using a label named "Label1". This label will be used in the DDE conversation between Program Manager and your proram. This example contains two SUBs. Both are placed into a BAS module. The first SUB creates the Program Manager Group, and the second SUB creates an icon within that group. These SUBs are called independantly (to allow for flexibility and clarity of illustration).

The following SUB creates the Program Manager group. It requires 3 arguments to be passed to it. They are:

   1. The form that contains Label1 (x)
   2. A string variable containing the group's name (GroupName$)
   3. A string variable containing the path to the group (*.GRP) file (GroupPath$) 

Sub CreateProgManGroup (x As Form, GroupName$, GroupPath$)
    Dim i%, z%                'Declare required working variables
    Screen.MousePointer = 11  'hourglass mousepointer while working
    On Error Resume Next      'Not good to have program crash :-)
    ' Set LinkTopic & LinkMode parameters
    x.Label1.LinkTopic = "ProgMan|Progman"
    x.Label1.LinkMode = 2
    For i% = 1 To 10          ' Give the DDE process time to take place
      z% = DoEvents() 
    Next              
    x.Label1.LinkTimeout = 100 
    ' Actually create the group now
    x.Label1.LinkExecute "[CreateGroup(" + GroupName$ + Chr$(44) + GroupPath$ + ")]"    
    ' Reset label properties and mousepointer
    x.Label1.LinkTimeout = 50
    x.Label1.LinkMode = 0
    Screen.MousePointer = 0
End Sub


The following SUB creates the Program Manager icon. It requires 3 arguments to be passed to it. They are:

   1. The form that contains Label1 (x)
   2. A string variable containing the icon's Command Line (CmdLine$)
   3. A string variable containing the icon's Caption (IconTitle$) 

Sub CreateProgManItem (x As Form, CmdLine$, IconTitle$)
    Dim i%, z%                'Declare required working variables
    Screen.MousePointer = 11  'hourglass mousepointer while working
    On Error Resume Next      'Not good to have program crash :-)
    ' Set LinkTopic & LinkMode parameters
    x.Label1.LinkTopic = "ProgMan|Progman"
    x.Label1.LinkMode = 2
    For i% = 1 To 10          ' Give the DDE process time to take place
      z% = DoEvents() 
    Next              
    x.Label1.LinkTimeout = 100
    x.Label1.LinkExecute "[AddItem(" + CmdLine$ + Chr$(44) + IconTitle$ + Chr$(44) + ",,)]"    
    ' Reset label properties and mousepointer
    x.Label1.LinkTimeout = 50
    x.Label1.LinkMode = 0    
    Screen.MousePointer = 0
End Sub


Finally, the last thing you need is for an event procedure (or any other form level routine) to call the 2 SUBs and provide the necessary information. In this example, I am creating a group window called VB Library and am placing it into the Windows directory. Then, I am creating an icon called "VB Library" within the group. This example creates an icon for the currently running program which happens to be Library.EXE.

CreateProgManGroup Me, "VB Library", "c:\windows"  
CreateProgManItem Me, app.Path + "\library", "VB Library"


A little side note here. Thanks to Microsoft making Windows 95 backward-compatible, this routine runs fine within it. The group file will appear as an entry in the Start Menu's Programs section and the icon will be a sub-menu of that entry. 


c0Title: Detecting 32-bit Program Terminations
c1Code:
Windows 3.1 allowed the programmer to use the GetModuleUsage() function to poll whether a selected application (module) was still running. Visual Basic programmers began to use this method to wait until a process completed before continuing.
Windows 95 (and Windows NT) entered the picture, where each process is running in a distinct environment, which precludes polling a processes' status.

Microsoft provided a few functions, namely the WaitForSingleObject and WaitForMultipleObjects functions that provide this type of functionality, and you can find Tips and Tricks that use these. However, this technique can be only too effective, at times. Any program that is spawned from that launched process (object) will in turn wait for its parent to complete. DDE conversations can not take place. An example of where this takes place is Microsoft's Internet Explorer; if you launch it and WaitForSingleObject, then select the help menu, and click on a topic that should feed an address back to the browser (jump to the web), you will be deadlocked, and have to terminate your WaitForSingleObject application.

The purpose of this lengthy explanation is to suggest a very functional alternative; as demonstrated below.

Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredaccess&, ByVal bInherithandle&, ByVal dwProcessid&) As Long
Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpexitcode As Long) As Long

' Required Constants
Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400

Sub ShellWait(cCommandLine As String)
    Dim hShell As Long
    Dim hProc As Long
    Dim lExit As Long

    hShell = Shell(cCommandLine, vbNormalFocus)
    hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)

    Do
        GetExitCodeProcess hProc, lExit
        DoEvents
    Loop While lExit = STILL_ACTIVE

End Sub


Simply call ShellWait and control will not resume to that process until the launched application terminates.

Tip Submitted By: Jonathan Markevich


c0Title: Determine if Program Stopped Responding
c1Code:
The example opens a copy of Internet Explorer then grabs the handle to check if the program is running. If you do not have IE then simply create an object of something else such as an Instance or Word, or Excel.

Place this code on a form and add a Command button to the form called Command1. Run the program and click on the Command Button. Internet Explorer should open and a msgbox should open (you may have to click on the form to set focus to that window so you can see the msgbox.) letting you know if the process is responding or not.

Const SMTO_BLOCK = &H1
Const SMTO_ABORTIFHUNG = &H2
Const WM_NULL = &H0
  
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
 
Private objIE As Object
Private lngIEHandle As Long
 
Private Sub Command1_Click()
    Dim lngResult As Long
    Dim lngRetVal As Long
       
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = True
    objIE.Navigate2 "http://excite.com/"
    DoEvents
    lngIEHandle = objIE.hwnd
    lngRetVal = SendMessageTimeout(lngIEHandle, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, 1000, lngResult)
         
    If lngRetVal Then
        Debug.Print "Responding"
    Else
        Debug.Print "Not Responding"
    End If
End Sub


c0Title: Determine the Correct Screen Dimensions
c1Code:
The latest video drivers can change the display resolution without rebooting. Unfortunately, the Screen object doesn�t always properly return the new display size; it only remembers the display size when the app first used it. This behavior appears to be driver-dependent, although it might be produced by the operating system (it occurs on my Windows NT machine but not on my Windows 98 system). If you need to determine screen dimensions at any time other than the Form_Load event, use the Windows API rather than the Screen object:

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

Private Declare Function GetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
Private Declare Function GetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hwnd As Long, lpRect As RECT) As Long

Public Function ScreenWidth() As Single
Dim R As RECT

GetWindowRect GetDesktopWindow(), R
ScreenWidth = R.Right * Screen.TwipsPerPixelX
End Function

Public Function ScreenHeight() As Single
Dim R As RECT

GetWindowRect GetDesktopWindow(), R
ScreenHeight = R.Bottom * Screen.TwipsPerPixelY
End Function
}}}
�Matt Hart, Tulsa, Oklahoma


c0Title: Disable Alt-TAB And Ctrl-ALT-DEL In Win95
c1Code:
The following code will disable Alt-Tab or Ctrl-Alt-Del in Win95 using VB4 32-bit or VB5.

Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Integer, ByVal aBOOL As Integer) As Integer
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Integer) As Integer
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Integer) As Integer
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Private TaskBarhWnd As Long
Private IsTaskBarEnabled As Integer
Private TaskBarMenuHwnd As Integer

Sub FastTaskSwitching(bEnabled As Boolean)
    Dim X As Long, bDisabled As Long

    bDisabled = Not bEnabled
    X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub

Public Sub DisableTaskBar()

    Dim EWindow As Integer

    TaskBarhWnd = FindWindow("Shell_traywnd", "")

    If TaskBarhWnd <> 0 Then
        'check to see if window is enabled
        EWindow = IsWindowEnabled(TaskBarhWnd)
        If EWindow = 1 Then 'need to disable it
            IsTaskBarEnabled = EnableWindow(TaskBarhWnd, 0)
        End If
    End If
End Sub

Public Sub EnableTaskBar()
    If IsTaskBarEnabled = 0 Then
        IsTaskBarEnabled = EnableWindow(TaskBarhWnd, 1)
    End If
End Sub


Example:

To disable use:

DisableTaskBar

FastTaskSwitching False

To enable use:

EnableTaskBar

FastTaskSwitching True


c0Title: Disable Ctl-Alt-Del
c1Code:
Use the SystemParametersInfo API function to tell the system a screen saver is running.

 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Const SPI_SETSCREENSAVERRUNNING = 97

Private Sub chkCtlAltDelDisabled_Click()    
    SystemParametersInfo SPI_SETSCREENSAVERRUNNING, (chkCtlAltDelDisabled.Value = vbChecked), 0&, 0
End Sub

' Reenable Ctl-Alt-Del.
Private Sub Form_Unload(Cancel As Integer)
    SystemParametersInfo SPI_SETSCREENSAVERRUNNING, False, 0&, 0
End Sub


c0Title: Display in a message box the current version of Windows being used.
c1Code:
This routine will require the declaration of the Windows API function GetVersion&(). It needs to be coded as in the following line:

Declare Function GetVersion Lib "kernel32" Alias "GetVersion" () As Long


This routine will also require the creation of 3 module level functions: The first of the three functions is MakeNybble() which is a routine to convert a hexadecimal digit into its binary counterpart. The second of these functions is DecimalValue() which converts a binary byte into a decimal value. The final of these three functions is GetWindowsVersion() which manipulates the other two functions and returns the Windows version in use. Below are these three functions in their entirety.

Function MakeNybble (HexCharacter As String)
'   This routine is called from the GetWindowsVersion routine
    Select Case Left$(HexCharacter, 1)
        Case "0": MakeNybble = "0000"
        Case "1": MakeNybble = "0001"
        Case "2": MakeNybble = "0010"
        Case "3": MakeNybble = "0011"
        Case "4": MakeNybble = "0100"
        Case "5": MakeNybble = "0101"
        Case "6": MakeNybble = "0110"
        Case "7": MakeNybble = "0111"
        Case "8": MakeNybble = "1000"
        Case "9": MakeNybble = "1001"
        Case "A": MakeNybble = "1010"
        Case "B": MakeNybble = "1011"
        Case "C": MakeNybble = "1100"
        Case "D": MakeNybble = "1101"
        Case "E": MakeNybble = "1110"
        Case "F": MakeNybble = "1111"
    End Select
End Function

Function DecimalValue (BinaryByte As String) As Integer
'   This routine is called from the GetWindowsVersion routine
    Dim x As Integer
    Dim v As Integer
    Dim TempVal As Integer
    v = 128
    For x = 1 To 8
        If Mid$(BinaryByte, x, 1) = "1" Then TempVal = TempVal + v
        v = v / 2
    Next x
    DecimalValue = TempVal
End Function

Function GetWindowsVersion () As String
'   This routine also requires the following two functions:
'       MakeNybble()
'       DecimalValue()
    Dim x As Long, y As String, z As Integer, t As String
    Dim HN As String, LN As String
    x = GetVersion()
    x = x - 117440512     ' Don't need High Word returned for Windows version
    t = Hex$(x)           ' Make the numeric value a Hexadecimal string
    y = Str$(Val(Right$(t, 2))) + "."' Hold the Major release # (ie  3.xx)
    HN = MakeNybble(Left$(t, 1))
    LN = MakeNybble(Mid$(t, 2, 1))
    z = DecimalValue(HN + LN)
    If z = 95 Then
        GetWindowsVersion = "Windows 95"
    Else
        GetWindowsVersion = "Windows " + y + Trim$(Str$(z))
    End If
End Function


Finally, you would call the Function and display its results as follows:

T = GetWindowsVersion()
MsgBox T, 48, "Current Windows Version"


Now please keep in mind that this routine was put together in great haste and there may likely be a more efficient means to accomplish this same task. If you know what it is - please let me know!


c0Title: Drag & Drop From The Win95 Explorer
c1Code:
Coding your program to accept files dropped on to it from the Win95 Explorer is easier than you think. First declare the following:

Type POINTAPI
    x As Long
    y As Long
End Type

Type MSG
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

' Declares
Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hWnd As Long, ByVal fAccept As Long)
Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)
Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long

' Constants
Public Const PM_NOREMOVE = &H0
Public Const PM_NOYIELD = &H2
Public Const PM_REMOVE = &H1
Public Const WM_DROPFILES = &H233


Add the following routine:

Public Sub WaitForDrop()

    ' This Sub waits for the file to be dropped...
    ' Dim Variables

    Dim FileDropMessage As MSG ' Msg Type
    Dim FileDropped As Boolean ' True if Files where dropped
    Dim hDrop As Long ' Pointer to the dropped file structure
    Dim Filename As String * 128 ' the dropped filename
    Dim NumOfDroppedFiles As Long ' the amount of dropped files
    Dim CurFile As Long ' the current file number

    ' Keep Looping to see if there was a file dropped...
    ' ** NOTE : Do any code you want to execute before this set. **
    Do

        ' Check if there was a File Dropped Message...
        FileDropped = PeekMessage(FileDropMessage, 0, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD)

        If FileDropped Then
                  ' ... If there was a file dropped then get the pointer to the
          ' dropped file structure...
          hDrop = FileDropMessage.wParam
          ' ...Get the total number of files dropped...
          NumOfDroppedFiles = DragQueryFile(hDrop, True, Filename, 127)
          Form1.List1.Clear

          For CurFile = 1 To NumOfDroppedFiles
            ' ...For each file dropped...
            ' ...Get the file name...
            ret% = DragQueryFile(hDrop, CurFile - 1, Filename, 127)
            Form1.lblNumDropped = LTrim$(Str$(NumOfDroppedFiles))
            Form1.List1.AddItem Filename
            ' ...Add it to the ListBox...
          Next CurFile
                   ' ...Stop the Drag Messages...
          DragFinish (hDrop)
        End If
        ' ...DoEvents to make everything back again.
        DoEvents
    Loop
End Sub


The all the following API call to let it know what form to use:

DragAcceptFiles Form1.hWnd, True


Pretty easy!


c0Title: Enumerate DSNs
c1Code:
This function encapsulates the API code necessary to enumerate through the DSNs and puts them in a collection. Usage should be straightforward enough, see the sample code. 
        
Code: 

Public Enum enumDSNTypes
    dsn_User = 31
    dsn_System = 32
End Enum

Private Const SQL_FETCH_NEXT = 1
Private Declare Function SQLGetInstalledDrivers Lib "ODBCCP32.DLL" _
   (ByVal s As String, ByVal sl As Integer, ByRef so As Integer) As Long
   
Private Declare Function SQLFreeEnv Lib "ODBC32.DLL" (ByVal han As Long) _
   As Long
   
Private Declare Function SQLAllocEnv Lib "ODBC32.DLL" (ByRef han As Long) _
   As Long
   
Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal han As _
   Long, ByVal iDir As Integer, ByVal sServerName As String, ByVal _
   iBuf1 As Integer, ByRef iRealBuf1 As Integer, ByVal sDesc As String, _
   ByVal iBuf2 As Integer, ByRef iRealBuf2 As Integer) As Long
                
Public Function EnumDSNs(DSNList As Collection, _
   Optional dsnType As enumDSNTypes = dsn_System)

    Dim sDSN As String
    Dim sDesc As String
    
    Dim iLenDSN As Integer
    Dim iLenDesc As Integer
    Dim nRet As Long
    Dim hSQL As Long
    
    Dim bContinue As Boolean
    
    bContinue = False

    SQLAllocEnv hSQL
    
    Do
        sDSN = Space(1024)
        sDesc = Space(1024)
        
        If bContinue Then
            nRet = SQLDataSources(hSQL, SQL_FETCH_NEXT, sDSN, _
                   1024, iLenDSN, sDesc, 1024, iLenDesc)
        Else
            nRet = SQLDataSources(hSQL, dsnType, sDSN, 1024, _
                   iLenDSN, sDesc, 1024, iLenDesc)
                   
            bContinue = True
        End If
        
        If nRet = 0 Then
            DSNList.Add Mid(sDSN, 1, iLenDSN)
        End If
    
    Loop While iLenDSN <> 0 And nRet = 0
        
    SQLFreeEnv hSQL
    
End Function

     
        
      Sample Usage: 
        
         Dim colDSN As New Collection
    EnumDSNs colDSN
    
    Dim vDSNEntry
    For Each vDSNEntry In colDSN
        Debug.Print vDSNEntry
    Next



c0Title: Enumerate Flags for Easier Coding
c1Code:
If you do a lot of work with the Windows API, you might notice that some API functions have flag-type parameters, and you usually pass API constants as the values for these parameters. Instead of putting multiple Public Const statements in a module the way the API Viewer gives them to you, you can group similar constants into enumerations and change the type of the parameter in the API function prototype to be the enumeration instead of a Long integer. This technique works only with Longs. The benefit is that the possible parameter values are displayed in the constant list as you�re coding your API function calls. 

�Thomas Weiss, Deerfield, Illinois


c0Title: Excel: Check if a workbook is open or if a worksheet reference is valid
c1Code:
'Returns TRUE if the specified workbook name is open in Excel
Function WorkbookIsOpen(sName As String) As Boolean
    On Error Resume Next
    WorkbookIsOpen = (Len(Workbooks(sName).Name) > 0)
End Function
 

'Returns TRUE if the specified worksheet reference is still valid
Function WorksheetIsValid(oWorksheet As Worksheet) As Boolean
    On Error Resume Next
    WorksheetIsValid = (Len(oWorksheet.Name) > 0)
End Function


c0Title: Execute a console program and capture its output
c1Code:
Description This example shows how to execute a console program and capture its output in Visual Basic 6. 
Keywords console program, capture output, stdout, execute 
Categories Software Engineering, Windows 
 
Thanks to Dipak Auddy. 
Subroutine ExecAndCapture creates a pipe and executes the console application, telling it to send output and error information to the pipe. It then reads from the pipe until there's no output left to read. 
 
 
Option Explicit
 
Private Sub Command1_Click()
 
    If LenB(Text1.Text) = 0 Then
        Exit Sub
    End If '<:-) Structure Expanded.
    Text2.Text = ""
    Screen.MousePointer = 11
    Call ExecAndCapture(Text1.Text, Text2)
    Text2.SelStart = 0
    Screen.MousePointer = 0
 
End Sub
 
Private Sub Form_Load()
Text2.BackColor = RGB(16, 132, 208)
Text2.ForeColor = RGB(255, 255, 255)
End Sub
 
Private Sub Text1_KeyDown(KeyCode As Integer, _
                          Shift As Integer)
 
    If KeyCode = 13 Then
        Command1.Value = True
    End If '<:-) Structure Expanded.
 
End Sub
 
 
 
'---------------------------------------------------
' Module CaptureConsoleOutput
'
' Purpose: Excute a console app. & capture output
'
' Author: Dipak Auddy
' E-mail: dauddy@gmail.com
'
' Date: Dec 01, 2004
'---------------------------------------------------
Option Explicit
' Contants
Private Const STARTF_USESHOWWINDOW     As Long = &H1
Private Const STARTF_USESTDHANDLES     As Long = &H100
Private Const SW_HIDE                  As Integer = 0
' Types
Private Type SECURITY_ATTRIBUTES
    nLength                                As Long
    lpSecurityDescriptor                   As Long
    bInheritHandle                         As Long
End Type
Private Type STARTUPINFO
    cb                                     As Long
    lpReserved                             As String
    lpDesktop                              As String
    lpTitle                                As String
    dwX                                    As Long
    dwY                                    As Long
    dwXSize                                As Long
    dwYSize                                As Long
    dwXCountChars                          As Long
    dwYCountChars                          As Long
    dwFillAttribute                        As Long
    dwFlags                                As Long
    wShowWindow                            As Integer
    cbReserved2                            As Integer
    lpReserved2                            As Long
    hStdInput                              As Long
    hStdOutput                             As Long
    hStdError                              As Long
End Type
Private Type PROCESS_INFORMATION
    hProcess                               As Long
    hThread                                As Long
    dwProcessId                            As Long
    dwThreadId                             As Long
End Type
' Declares
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, _
                                                    phWritePipe As Long, _
                                                    lpPipeAttributes As Any, _
                                                    ByVal nSize As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, _
                                                  lpBuffer As Any, _
                                                  ByVal nNumberOfBytesToRead As Long, _
                                                  lpNumberOfBytesRead As Long, _
                                                  lpOverlapped As Any) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, _
                                                                              ByVal lpCommandLine As String, _
                                                                              lpProcessAttributes As Any, _
                                                                              lpThreadAttributes As Any, _
                                                                              ByVal bInheritHandles As Long, _
                                                                              ByVal dwCreationFlags As Long, _
                                                                              lpEnvironment As Any, _
                                                                              ByVal lpCurrentDriectory As String, _
                                                                              lpStartupInfo As STARTUPINFO, _
                                                                              lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
'---------------------------------------------------
' Call this sub to execute and capture a console app.
' Ex: Call ExecAndCapture("ping localhost", Text1)
Public Sub ExecAndCapture(ByVal sCommandLine As String, _
                          cTextBox As TextBox, _
                          Optional ByVal sStartInFolder As String = vbNullString)
Attribute ExecAndCapture.VB_Description = "'---------------------------------------------------\r\n' Call this sub to execute and capture a console app.\r\n' Ex: Call ExecAndCapture(""ping localhost"", Text1)"
 
Const BUFSIZE         As Long = 1024 * 10
Dim hPipeRead         As Long
Dim hPipeWrite        As Long
Dim sa                As SECURITY_ATTRIBUTES
Dim si                As STARTUPINFO
Dim pi                As PROCESS_INFORMATION
Dim baOutput(BUFSIZE) As Byte
Dim sOutput           As String
Dim lBytesRead        As Long
    
    With sa
        .nLength = Len(sa)
        .bInheritHandle = 1    ' get inheritable pipe handles
    End With 'SA
    
    If CreatePipe(hPipeRead, hPipeWrite, sa, 0) = 0 Then
        Exit Sub
    End If
 
    With si
        .cb = Len(si)
        .dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
        .wShowWindow = SW_HIDE          ' hide the window
        .hStdOutput = hPipeWrite
        .hStdError = hPipeWrite
    End With 'SI
    
    If CreateProcess(vbNullString, sCommandLine, ByVal 0&, ByVal 0&, 1, 0&, ByVal 0&, sStartInFolder, si, pi) Then
        Call CloseHandle(hPipeWrite)
        Call CloseHandle(pi.hThread)
        hPipeWrite = 0
        Do
            DoEvents
            If ReadFile(hPipeRead, baOutput(0), BUFSIZE, lBytesRead, ByVal 0&) = 0 Then
                Exit Do
            End If
            sOutput = Left$(StrConv(baOutput(), vbUnicode), lBytesRead)
            cTextBox.SelText = sOutput
        Loop
        Call CloseHandle(pi.hProcess)
    End If
    ' To make sure...
    Call CloseHandle(hPipeRead)
    Call CloseHandle(hPipeWrite)
 
End Sub
 
':)Code Fixer V2.2.0 (25/02/2005 2:08:57 PM) 57 + 62 = 119 Lines Thanks Ulli for inspiration and lots of code.
 
 


c0Title: DAO: Execute Parametrized QueryDefs Simultaneously in DAO
c1Code:
VB4, VB5, VB6, DAO 3.x

Level: Intermediate

Execute Parametrized QueryDefs Simultaneously in DAO

In Microsoft Access, you can execute a parameterized query that uses other parameterized queries, as long as their parameter names are the same. Save these queries in an Access database:
"QueryOne"
PARAMETERS MyDate DateTime;
SELECT Date1 FROM TableOne WHERE Date1>MyDate; "QueryTwo"
PARAMETERS MyDate DateTime;
SELECT Date1 FROM TableTwo WHERE Date1>MyDate; "QueryUnion"
PARAMETERS MyDate DateTime;
SELECT * FROM QueryOne
UNION
SELECT * FROM QueryTwo;
You can execute QueryUnion from VB code by passing the MyDate parameter. This example is for DAO 3.5:
Sub ExecuteQuery()
Dim db As Database
Dim rs As Recordset
Dim qd As QueryDef
Set db = OpenDatabase("<database name>") Set qd = db.QueryDefs("QueryUnion") qd.Parameters(0).Value = CDate("3/1/00") Set rs = qd.OpenRecordset(dbOpenSnapshot) ' <.....> rs.Close db.Close End Sub �Pavel Maksimuk, Brooklyn, New York


c0Title: Execute VB Script code at run time
c1Code:
Title Execute VB Script code at run time 
Description This example shows how to execute VB Script code at run time in Visual Basic 6. The program uses the MSScriptControl to execute the VBScript code. 
Keywords VBScript, script 
Categories Software Engineering 
 
 
 
Thanks to Ziad Suliman. 
When the program loads, it creates a MSScriptControl and sets its language to VBScript. It adds the Form1 object to the control with the name "Form1" so the VBScript code can manipulate it. It then sets the form's TextBox to some VBScript code. 
 
 
 
Private Sub Form_Load()
    Set VBScript = New MSScriptControl.ScriptControl
    'set Language
    VBScript.Language = "VBScript"
    'Add object
    VBScript.AddObject "Form1", Form1
    'allowed to display user-interface elements.
    VBScript.AllowUI = True
    ' Example:
    'this code:  calculate a! , sum from 1 to a ,change
    ' form backcolor ,change form caption
    Text1 = _
        "'Programmed by Ziad Suliman" & vbCrLf & _
        "'Civil Engineering Tishreen University Syria" & _
            vbCrLf & _
        "'Email:Eckert@naharnet.com" & vbCrLf & vbCrLf & _
        "'This code:" & vbCrLf & _
        "'    Calculates A!" & vbCrLf & _
        "'    Calculates the sum from 1 to A" & vbCrLf & _
        "'    Changes the form's BackColor" & vbCrLf & _
        "'    Changes the form's Caption" & vbCrLf & vbCrLf _
            & _
        "a = InputBox(""Number"")" & vbCrLf & _
        "factorial = 1" & vbCrLf & _
        "sum = 0" & vbCrLf & _
        "For i = 1 To a" & vbCrLf & _
        "    factorial = factorial * i" & vbCrLf & _
        "    sum = sum + i" & vbCrLf & _
        "Next" & vbCrLf & _
        "'Display the results." & vbCrLf & _
        "MsgBox ""Factorial: "" & factorial & "", Sum: "" & " & _
            "sum" & vbCrLf & vbCrLf & _
        "'Change the form" & vbCrLf & _
        "Form1.Caption = ""Ziad Suliman""" & vbCrLf & _
        "Form1.BackColor = vbRed"
End Sub
 
 
 
When the user clicks the Run Code button, the program adds the code to the VBScript object. The code prompts the user for input and displays the results.  
 
 
Private Sub Command1_Click()
    'Add code that there is in text1
    On Error GoTo line1
    VBScript.AddCode Text1
    Exit Sub
line1:
    MsgBox Err.Number & Err.Description, vbCritical, "error"
    Err.Clear
End Sub
 


c0Title: Access: Executing Access Queries That Use VBA From Outside Access
c1Code:
custom VBA functions like this are only available to queries executed within Access. 

The only way to programmatically execute these queries from outside of Access is via COM automation of Access itself, which is a pretty heavy-handed way to execute a query. However, if you want to pursue this approach, here's some sample code (for brevity, it assumes you set a reference to the Access and DAO object libraries in your VB6 project):

Dim a As Access.Application
Set a = New Access.Application
a.OpenCurrentDatabase "c:\temp\sql.transform.mdb", False Dim rs As DAO.Recordset Dim sql As String sql = "SELECT stor_id, zip, CaseSearched(" & _ "zip = '92789', 'west', " & _ "zip Is Null, 'missing', " & _ "zip >= '96745', 'northwest', " & _ "'*'" & _
") AS [Searched Case] " & _
"FROM stores;"
Set rs = a.CurrentDb().OpenRecordset(sql, dbOpenForwardOnly) Do Until rs.EOF Debug.Print rs.Fields(0) & vbTab & rs.Fields(1) & vbTab & rs.Fields(2) rs.MoveNext Loop rs.Close Call a.Quit(acQuitSaveNone)

Note: For DAO, use CurrentDB(). For ADO, use CurrentProject.Connection or CurrentProject.AccessConnection.


c0Title: Export Records to CSV File for Excel
c1Code:
Most of my end users use laptops, which can have a wide variety of spreadsheet software installed. I often use this function when working with database tables or queries to produce a spreadsheet when I don�t know what program will be used to open it. The function takes any database table or SQL Select statement and turns it into a comma-delimited text file a user can open using Notepad, Excel, or any spreadsheet program, allowing you to send data easily to another user or program. In this sample, Db is a global object variable equal to the database and has already been set by the calling program. sSource is the table or SQL statement that needs to be written to a spreadsheet:

 

Public Function TableToSpreadsheet(sSource _
       As String, sFile As String) As Boolean

       On Error GoTo TableToSpreadsheet_Err

       ' SYNTAX:
       ' If TableToSpreadsheet("SELECT * FROM 
       ' Authors", "C:\Temp\Authors.csv") = True 
       ' Then....

       Dim rsTemp As Recordset
       Dim sHeader As String
       Dim sRow As String
       Dim i As Integer

       Set rsTemp = Db.OpenRecordset(sSource)

       With rsTemp

             '  Make sure there are records to write

             If .RecordCount = 0 Then

                    TableToSpreadsheet = False
                    .Close
                    Set rsTemp = Nothing
                    Exit Function

             End If

 

             '  Create new target file
             Open sFile For Output As #1

             '  Write the header row

             For i = 0 To .Fields.Count - 1

                    If i = 0 Then
                           sHeader = .Fields(i).Name
                    Else
                           sHeader = sHeader & "," & .Fields(i).Name
                    End If

             Next i

             Print #1, sHeader
 
             ' Loop through the table and write data rows

             .MoveFirst

             Do Until .EOF

                    For i = 0 To .Fields.Count - 1

                           If i = 0 Then
                                  sRow = .Fields(i).Value & ""
                           Else
                                  sRow = .Fields(i).Value & ""
                           End If

                    Next i

                    Print #1, sRow
                    .MoveNext
             Loop

             .Close
       End With

       Close #1 ' Target file is complete
       Set rsTemp = Nothing    

       ' Release recordset, but NOT database objects
       TableToSpreadsheet = True

TableToSpreadsheet_Exit:

       Exit Function

TableToSpreadsheet_Err:

       LogIt "TableToSpreadsheet : " & Err.Description
       ' LogIt is a function that creates an error log

       Resume Next 
       ' Most errors result in a blank cell and can be ignored.

End Function

�Robert Feldsien, Hillsboro, Missouri


c0Title: Fast Combo Population from Objects with VB6
c1Code:
Fast Combo Population from Objects with VB6 One of the most common tasks we have to undertake when creating a user form is to provide a dropdown list of values based on property values within one of our objects. A combo control, for example, might contain the names of all the employees in a certain division of the company. 
One of the most common methods of doing this (until VB6) was to populate the collection object, then enumerate each object in the collection and assign the particular value from each object into the combo control. The code looks something like this: 


     Set oEmployees = New Employees
         For i = 1 to oEmployees.Count
             If oEmployees.Exists(i) Then
                 Set oEmployee = oEmployees.Employee(i)
                      cboEmployees.AddItem oEmployee.Name
               Set oEmployee = Nothing
             End If
         Next i
     Set oEmployees = Nothing

The amount of processing and (if an object is remote) the massive amount of network traffic that this simple procedure can create is staggering! So when I found that functions can return arrays in VB6, I was delighted. This means that you can now execute a simple SQL query that returns to the client only an array containing the values of that field that you want to display in the list or combo box. Here's the server side code: 


     Public Property Get Names() As String()

         ReDim sTemp(0) As String
         Dim oADORec As ADODB.Recordset
         Dim lRecCount As Long
         Dim sSQL As String
         Dim iCounter As Integer
   
             Set oUtil = New PowerUtils.DBUtils
                 sSQL = "SELECT SName from Employees"
                 Set oADORec = oUtil.GetRecordset(sSQL)
                      If oADORec.RowCount > 0 Then
                          ReDim sTemp(oADORec.RowCount)
                          Do While Not oADORec.EOF
                              sTemp(iCounter) = oADORec!SName
                              iCounter = iCounter + 1
                              oADORec.MoveNext
                          Loop
                       End If
                 Set oADORec = Nothing
             Set oUtil = Nothing
          Names = sTemp

     End Property

If you can't get the RowCount property to work with your system, it is faster to execute a SQL Query that returns the row count and then do a single ReDim of the array, rather than to use ReDim Preserve. 

Here's how the Names property shown above is used at the client end: 


     Dim sNames() As String
     Dim vName As Variant
     Dim oEmps As Employees

     Set oEmps = New Employees
         sNames = oEmps.Names
         For Each vName In sNames
             cboEmployees.AddItem vName
         Next
     Set oEmps = Nothing

Note that only an array of string values is passed from the server object to the client. Therefore, the amount of traffic between the two objects is negligible. Also note that to assign an array from a function in VB6, your local variable must be dimensioned as a dynamic array. 


c0Title: Faster string concatenation with the Mid$ command
c1Code:
Arguably, string concatenation is among the slowest in-memory operations you can perform with VB. Expert developers know that the problem isn't in the concatenation operation itself; rather, VB spends a lot of time allocating a new memory block for the new (longer) string, and releasing the original memory block. If you can reduce this allocation/release activity, you'll be surprised at how fast your code becomes. 

      We carry several other tips for speeding up string operations, such as How to process string characters using Byte arrays and Non obvious uses for the LIKE operator. If you like low-level, blindly fast string code, don't miss the "Play VB Strings" online article. 

      Here's the tip:
      As you probably know, the "&" operator is rather slow, especially with long strings. When you have to repeatedly append chucks of characters to the same variable, you can speed up your code using a simple trick based on the Mid$ command. The idea is that you pre-allocate a buffer long enough to accommodate for the result of your operation. Here's an example of this technique. 

      Suppose you want to create a string given by appending the first 10000 integers, e.g. "1 2 3 4 5 6 7 ... 9999 10000". This is the easiest way to do so: 


res = ""
For i = 1 to 10000: res = res & Str(i): Next

      The problem with the standard approach is that the res variable is reallocated 10000 times. This is a better way to reach the same result: 


Dim res As String
Dim i As Long
Dim index As Long

' prepare a buffer long enough
res = Space(90000)
' this points to where we want to insert the string index = 1

' here we go
For i = 1 to 10000
    substr = Str(i)
    length = Len(substr)
    ' stuff the string inside the result variable
    Mid$(res, index, length) = substr
    ' advance index
    index = index + length
Next
' drop extra chars
res = Left$(res, index - 1)

      The standard code takes 2.2 seconds on my 333 MHz system computer, while the smart way takes only 0.08 seconds, so it's 25+ times faster. 
     



c0Title: File Copy With Version Checking
c1Code:
This routine checks the version and if it is the same or earlier, it is automatically upgraded to the new version, otherwise it is not copied at all. 

xFile - The filename (it copies from the application's own directory) 
xDest - The destination directory 
Declare

Declare Function GetVersion Lib "Kernel" () As Long

Declare Function GetFileVersionInfo% Lib "VER.DLL" (ByVal lpszFileName$, ByVal handle As Any, ByVal cbBuf&, ByVal lpvData$)

Code

Sub CheckFile(xFile As String, xDest As String)

On Error Resume Next

Dim retS%
Dim retD%

     If Right(xDest, 1) <> "\" Then xDest = xDest + "\"

     Form2.lblSource.Caption = App.Path + "\" + xFile

     Form2.lblDestination.Caption = xDest + xFile

     If Dir(xFile) = "" Then

           FileCopy App.Path + "\" + xFile, xDest + xFile

     Else

           'Check version

           retS% = GetFileVersionInfo(App.Path + "\" + xFile, 0&, 254, version)

           retD% = GetFileVersionInfo(xDest + xFile, 0&, 254, version)

           If retS% >= retD% Then

                 FileCopy App.Path + "\" + xFile, xDest + xFile

           End If

     End If

 

     'Just wait for a sec

     For i = 1 To 1000

           DoEvents

     Next i

 

End Sub

Tip Submitted By: Jeff Williams


c0Title: FileTime to VB Date Conversion
c1Code:
Description: 
This is a small hack that converts the Windows API FILETIME structure to a Visual Basic Date variable. 
        
Code: 

Option Explicit

Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As _
   FILETIME, lpSystemTime As SYSTEMTIME) As Long

Private Function FTtoDATE(ByRef FT As FILETIME) As Date
    
    Dim ST As SYSTEMTIME
    
    FileTimeToSystemTime FT, ST
    
    FTtoDATE = DateValue("" & Format(ST.wMonth, "0") & "/" & _
               Format(ST.wDay, "00") & "/" & Format(ST.wYear, "0000")) & _
               TimeValue(Format(ST.wHour, "00") & ":" & _
               Format(ST.wMinute, "00") & ":" & _
               Format(ST.wSecond, "00") & "")

End Function


     
        
      Sample Usage: 
        
     Dim FT as FILETIME

Debug.Print "The date in FT is " & FTtoDATE(FTtoDATE(FT))



c0Title: Fill a ComboBox with a list of countries
c1Code:
Keywords country, countries 
Categories Miscellany, Software Engineering 
 
 
 
Thanks to Dinesh Asanka. 
Enumerate the keys inside the Registry key: 


    HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\
    CurrentVersion\Telephony\Country List\
Those keys' Name values give the country names. 
 

 
Option Explicit
Dim CountryCol As Collection
Const ValueName As String = "Name"
Const MasterKey As String = "SOFTWARE\Microsoft\Windows\CurrentVersion\Telephony\Country List\"
 
Private Sub Form_Load()
    Dim KeyCol As Collection
    Dim strCountry As String
    If CheckRegistryKey(HKEY_LOCAL_MACHINE, MasterKey) Then
        
        Set KeyCol = EnumRegistryKeys(HKEY_LOCAL_MACHINE, MasterKey)
        Dim TheKey As Variant
        Set CountryCol = New Collection
        
        For Each TheKey In KeyCol
             If TheKey <> "800" And GetRegistryValue(HKEY_LOCAL_MACHINE, MasterKey & TheKey, "InternationalRule", "") <> "00EFG#" Then
                CboCountry.AddItem GetRegistryValue(HKEY_LOCAL_MACHINE, MasterKey & TheKey, ValueName, "")
             End If
        Next
    End If
End Sub

 
'mregistry.bas
 
Option Explicit
Public Const HKEY_CLASSES_ROOT As Long = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Const HKEY_USERS As Long = &H80000003
Public Const HKEY_PERFORMANCE_DATA As Long = &H80000004
Public Const HKEY_CURRENT_CONFIG As Long = &H80000005
Public Const HKEY_DYN_DATA As Long = &H80000006
 
 
 

Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ERROR_MORE_DATA = 234
Const KEY_READ = &H20019  ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
                          ' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
                          ' SYNCHRONIZE))
Const REG_OPENED_EXISTING_KEY = &H2
 
Const KEY_WRITE = &H20006  '((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or
                           ' KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
 

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
    ByVal cbData As Long) As Long
 

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
    "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
 
 
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
    Any, source As Any, ByVal numBytes As Long)
 

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
    (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
    ByVal cbName As Long) As Long
 
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
    (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
    lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
    lpData As Any, lpcbData As Long) As Long
    
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, phkResult As Long) As Long
 
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As _
    Long
 

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
    "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
    ByVal Reserved As Long, ByVal lpClass As Long, ByVal dwOptions As Long, _
    ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, _
    phkResult As Long, lpdwDisposition As Long) As Long
 

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
    "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal lpReserved As Long, lpType As Long, lpData As Any, _
    lpcbData As Long) As Long
 
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String) As Long
 
 
 
Sub DeleteRegistryKey(ByVal hKey As Long, ByVal KeyName As String)
    RegDeleteKey hKey, KeyName
End Sub
 
 
 

Function DeleteRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
    ByVal ValueName As String) As Boolean
    Dim handle As Long
    
    ' Open the key, exit if not found
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then Exit Function
    
    ' Delete the value (returns 0 if success)
    DeleteRegistryValue = (RegDeleteValue(handle, ValueName) = 0)
    ' Close the handle
    RegCloseKey handle
End Function
 
Function CheckRegistryKey(ByVal hKey As Long, ByVal KeyName As String) As _
    Boolean
    Dim handle As Long
    ' Try to open the key
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) = 0 Then
        ' The key exists
        CheckRegistryKey = True
        ' Close it before exiting
        RegCloseKey handle
    End If
End Function
 

Function CreateRegistryKey(ByVal hKey As Long, ByVal KeyName As String) As _
    Boolean
    Dim handle As Long, disposition As Long
    
    If RegCreateKeyEx(hKey, KeyName, 0, 0, 0, 0, 0, handle, disposition) Then
        Err.Raise 1001, , "Unable to create the registry key"
    Else
        ' Return True if the key already existed.
        CreateRegistryKey = (disposition = REG_OPENED_EXISTING_KEY)
        ' Close the key.
        RegCloseKey handle
    End If
End Function
 

Function EnumRegistryKeys(ByVal hKey As Long, ByVal KeyName As String) As _
    Collection
    Dim handle As Long
    Dim length As Long
    Dim index As Long
    Dim subkeyName As String
    
    ' initialize the result collection
    Set EnumRegistryKeys = New Collection
    
    ' Open the key, exit if not found
    If Len(KeyName) Then
        If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
        ' in all case the subsequent functions use hKey
        hKey = handle
    End If
    
    Do
        ' this is the max length for a key name
        length = 260
        subkeyName = Space$(length)
        ' get the N-th key, exit the loop if not found
        If RegEnumKey(hKey, index, subkeyName, length) Then Exit Do
        
        ' add to the result collection
        subkeyName = Left$(subkeyName, InStr(subkeyName, vbNullChar) - 1)
        EnumRegistryKeys.Add subkeyName, subkeyName
        ' prepare to query for next key
        index = index + 1
    Loop
   
    ' Close the key, if it was actually opened
    If handle Then RegCloseKey handle
        
End Function
 

Function EnumRegistryValues(ByVal hKey As Long, ByVal KeyName As String) As _
    Collection
    Dim handle As Long
    Dim index As Long
    Dim valueType As Long
    Dim name As String
    Dim nameLen As Long
    Dim resLong As Long
    Dim resString As String
    Dim dataLen As Long
    Dim valueInfo(0 To 1) As Variant
    Dim retVal As Long
    
    ' initialize the result
    Set EnumRegistryValues = New Collection
    
    ' Open the key, exit if not found.
    If Len(KeyName) Then
        If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
        ' in all cases, subsequent functions use hKey
        hKey = handle
    End If
    
    Do
        ' this is the max length for a key name
        nameLen = 260
        name = Space$(nameLen)
        ' prepare the receiving buffer for the value
        dataLen = 4096
        ReDim resBinary(0 To dataLen - 1) As Byte
        
        ' read the value's name and data
        ' exit the loop if not found
        retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, valueType, _
            resBinary(0), dataLen)
        
        ' enlarge the buffer if you need more space
        If retVal = ERROR_MORE_DATA Then
            ReDim resBinary(0 To dataLen - 1) As Byte
            retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, _
                valueType, resBinary(0), dataLen)
        End If
        ' exit the loop if any other error (typically, no more values)
        If retVal Then Exit Do
        
        ' retrieve the value's name
        valueInfo(0) = Left$(name, nameLen)
        
        ' return a value corresponding to the value type
        Select Case valueType
            Case REG_DWORD
                CopyMemory resLong, resBinary(0), 4
                valueInfo(1) = resLong
            Case REG_SZ, REG_EXPAND_SZ
                ' copy everything but the trailing null char
                resString = Space$(dataLen - 1)
                CopyMemory ByVal resString, resBinary(0), dataLen - 1
                valueInfo(1) = resString
            Case REG_BINARY
                ' shrink the buffer if necessary
                If dataLen < UBound(resBinary) + 1 Then
                    ReDim Preserve resBinary(0 To dataLen - 1) As Byte
                End If
                valueInfo(1) = resBinary()
            Case REG_MULTI_SZ
                ' copy everything but the 2 trailing null chars
                resString = Space$(dataLen - 2)
                CopyMemory ByVal resString, resBinary(0), dataLen - 2
                valueInfo(1) = resString
            Case Else
                ' Unsupported value type - do nothing
        End Select
        
        ' add the array to the result collection
        ' the element's key is the value's name
        EnumRegistryValues.Add valueInfo, valueInfo(0)
        
        index = index + 1
    Loop
   
    ' Close the key, if it was actually opened
    If handle Then RegCloseKey handle
        
End Function
Function EnumRegistryValuesEx(ByVal hKey As Long, ByVal KeyName As String) As _
    Collection
    Dim handle As Long
    Dim index As Long
    Dim valueType As Long
    Dim name As String
    Dim nameLen As Long
    Dim resLong As Long
    Dim resString As String
    Dim dataLen As Long
    Dim valueInfo(0 To 2) As Variant
    Dim retVal As Long
    
    ' initialize the result
    Set EnumRegistryValuesEx = New Collection
    
    ' Open the key, exit if not found.
    If Len(KeyName) Then
        If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
        ' in all cases, subsequent functions use hKey
        hKey = handle
    End If
    
    Do
        ' this is the max length for a key name
        nameLen = 260
        name = Space$(nameLen)
        ' prepare the receiving buffer for the value
        dataLen = 4096
        ReDim resBinary(0 To dataLen - 1) As Byte
        
        ' read the value's name and data
        ' exit the loop if not found
        retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, valueType, _
            resBinary(0), dataLen)
        
        ' enlarge the buffer if you need more space
        If retVal = ERROR_MORE_DATA Then
            ReDim resBinary(0 To dataLen - 1) As Byte
            retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, _
                valueType, resBinary(0), dataLen)
        End If
        ' exit the loop if any other error (typically, no more values)
        If retVal Then Exit Do
        
        ' retrieve the value's name
        valueInfo(0) = Left$(name, nameLen)
        
        ' return a value corresponding to the value type
        Select Case valueType
            Case REG_DWORD
                CopyMemory resLong, resBinary(0), 4
                valueInfo(1) = resLong
                valueInfo(2) = vbLong
            Case REG_SZ, REG_EXPAND_SZ
                ' copy everything but the trailing null char
                resString = Space$(dataLen - 1)
                CopyMemory ByVal resString, resBinary(0), dataLen - 1
                valueInfo(1) = resString
                valueInfo(2) = vbString
            Case REG_BINARY
                ' shrink the buffer if necessary
                If dataLen < UBound(resBinary) + 1 Then
                    ReDim Preserve resBinary(0 To dataLen - 1) As Byte
                End If
                valueInfo(1) = resBinary()
                valueInfo(2) = vbArray + vbByte
            Case REG_MULTI_SZ
                ' copy everything but the 2 trailing null chars
                resString = Space$(dataLen - 2)
                CopyMemory ByVal resString, resBinary(0), dataLen - 2
                valueInfo(1) = resString
                valueInfo(2) = vbString
            Case Else
                ' Unsupported value type - do nothing
        End Select
        
        ' add the array to the result collection
        ' the element's key is the value's name
        EnumRegistryValuesEx.Add valueInfo, valueInfo(0)
        
        index = index + 1
    Loop
   
    ' Close the key, if it was actually opened
    If handle Then RegCloseKey handle
        
End Function
 

Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
    ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
    Dim handle As Long
    Dim resLong As Long
    Dim resString As String
    Dim resBinary() As Byte
    Dim length As Long
    Dim retVal As Long
    Dim valueType As Long
    
    ' Prepare the default result
    GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
    
    ' Open the key, exit if not found.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
        Exit Function
    End If
    
    ' prepare a 1K receiving resBinary
    length = 1024
    ReDim resBinary(0 To length - 1) As Byte
    
    ' read the registry key
    retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
        length)
    ' if resBinary was too small, try again
    If retVal = ERROR_MORE_DATA Then
        ' enlarge the resBinary, and read the value again
        ReDim resBinary(0 To length - 1) As Byte
        retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
            length)
    End If
    
    ' return a value corresponding to the value type
    Select Case valueType
        Case REG_DWORD
            CopyMemory resLong, resBinary(0), 4
            GetRegistryValue = resLong
        Case REG_SZ, REG_EXPAND_SZ
            ' copy everything but the trailing null char
            resString = Space$(length - 1)
            CopyMemory ByVal resString, resBinary(0), length - 1
            GetRegistryValue = resString
        Case REG_BINARY
            ' resize the result resBinary
            If length <> UBound(resBinary) + 1 Then
                ReDim Preserve resBinary(0 To length - 1) As Byte
            End If
            GetRegistryValue = resBinary()
        Case REG_MULTI_SZ
            ' copy everything but the 2 trailing null chars
            resString = Space$(length - 2)
            CopyMemory ByVal resString, resBinary(0), length - 2
            GetRegistryValue = resString
        Case Else
            RegCloseKey handle
            Err.Raise 1001, , "Unsupported value type"
    End Select
    
    ' close the registry key
    RegCloseKey handle
End Function
 

 
 
Function SetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
    ByVal ValueName As String, value As Variant) As Boolean
    Dim handle As Long
    Dim lngValue As Long
    Dim strValue As String
    Dim binValue() As Byte
    Dim length As Long
    Dim retVal As Long
    
    ' Open the key, exit if not found
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then
        Exit Function
    End If
 
    ' three cases, according to the data type in Value
    Select Case VarType(value)
        Case vbInteger, vbLong
            lngValue = value
            retVal = RegSetValueEx(handle, ValueName, 0, REG_DWORD, lngValue, 4)
        Case vbString
            strValue = value
            retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, _
                Len(strValue))
        Case vbArray + vbByte
            binValue = value
            length = UBound(binValue) - LBound(binValue) + 1
            retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, _
                binValue(LBound(binValue)), length)
        Case Else
            RegCloseKey handle
            Err.Raise 1001, , "Unsupported value type"
    End Select
    
    ' Close the key and signal success
    RegCloseKey handle
    ' signal success if the value was written correctly
    SetRegistryValue = (retVal = 0)
End Function


c0Title: Fill Combo With Available Drive Letters
c1Code:
VB4 32, VB5, VB6

To create a drop-down control with a list of used or unused drive letters, place two ComboBox controls on a form, named Combo1 and Combo2, and include this code to initialize the lists:
Private Declare Function GetLogicalDrives Lib _ "kernel32" () As Long Private Sub Form_Load() FillCombo Combo1, True FillCombo Combo2, False End Sub Private Sub FillCombo(cbo As ComboBox, _ ByVal bUsed As Boolean) Dim DriveNum As Long cbo.Clear For DriveNum = 0 To 25 If CBool(GetLogicalDrives And (2 ^ _
DriveNum)) = bUsed Then
cbo.AddItem Chr$(Asc("A") + _
DriveNum) & ":"
End If
Next DriveNum
End Sub

�Brian Dial, Decatur, Alabama


c0Title: Fill In the E-Mail Fields
c1Code:
ShellExecute is one of the most flexible Win32 APIs. Using ShellExecute, you can pass any filename, and if the file�s extension is associated to a registered program on the user�s machine, the correct application opens and the file is played or displayed.

     In the February 1998 101 Tech Tips supplement, Jose Rodriguez Alvira showed ShellExecute�s Internet power (�Create Internet-Style Hyperlinks�). If you pass an HTTP URL, the user�s default 32-bit Web browser opens and connects to the site. If you pass an e-mail address that has been prefaced with �mailto:�, the user�s default 32-bit e-mail client opens a new e-mail note with the address filled in.

     Here�s how to automatically get a lot more than just the e-mail addresses filled in. If you want to include a list of CC recipients, BCC recipients, or your own subject text or body text, you can create a string variable, add the list of primary addresses (separated by semicolons), then a question mark character and element strings prefaced like this:

 

For CCs (carbon copies): &CC= (followed by list)

For blind CCs: &BCC= (followed by list)

For subject text: &Subject= (followed by text)

For body text: &Body= (followed by text)

To add an attachment: &Attach= (followed by a valid file path within chr(34)�s)

To use this trick, create a new VB project, add a form, and add six textboxes and a button (cmdSendIt). Paste this into the form�s Declarations section:

Private Declare Function ShellExecute Lib "shell32.dll" _
       Alias "ShellExecuteA" (ByVal hWnd As Long, _
       ByVal lpOperation As String, ByVal lpFile As String, _
       ByVal lpParameters As String, ByVal lpDirectory _
       As String, ByVal nShowCmd As Long) As Long

Private Const SW_SHOWNORMAL = 1


Paste this code into the button�s Click event:


Private Sub cmdSendIt_Click()

       Dim sText As String
       Dim sAddedText As String

       If Len(txtMainAddresses) Then
             sText = txtMainAddresses
       End If

       If Len(txtCC) Then
             sAddedText = sAddedText & "&CC=" & txtCC
       End If

       If Len(txtBCC) Then
             sAddedText = sAddedText & "&BCC=" & txtBCC
       End If

       If Len(txtSubject) Then
             sAddedText = sAddedText & "&Subject=" & txtSubject
       End If

       If Len(txtBody) Then
             sAddedText = sAddedText & "&Body=" & txtBody
       End If

       If Len(txtAttachmentFileLocation) Then
             sAddedText = sAddedText & "&Attach=" & _
                    Chr(34) & txtAttachmentFileLocation & Chr(34)

       End If

       sText = "mailto:" & sText

       ' clean the added elements

       If Len(sAddedText) <> 0 Then

             ' there are added elements, replace the first
             ' ampersand with the question character
              Mid$(sAddedText, 1, 1) = "?"

       End If

       sText = sText & sAddedText

       If Len(sText) Then

             Call ShellExecute(Me.hWnd, "open", sText, _
                    vbNullString, vbNullString, SW_SHOWNORMAL)

       End If

End Sub

 

You can�t have spaces between the ampersands and tags, or between the tags and the equal signs. You don�t have formatting options, so body text will be one paragraph. However, when you use this technique, program errors are e-mailed to you with full details, and you can create real e-mail applets in a just a few seconds. It beats automating a full e-mail program. 

In addition, almost all this functionality is possible in HTML MailTo tags. Here is a sample:
 

<A HREF="mailto:smith@smithvoice.com?subject=

Feedback From VisualBasic ett 

smithvoice.com/vbfun.htm&CC=smith@smithhome.org&BC

C=fred@fred.net;bill@home.com&body=hello how are 

you">feedback@smithvoice</A>

I have yet to get HTML to do the attachments, but attachments are no problem in VB.

Editor�s Note: The full functionality of these extra fields is available in e-mail clients that are totally Exchange-compliant. Some or all of the extra fields might not work with noncompliant e-mail clients.

�Robert Smith, Kirkland, Washington


c0Title: Find A File In Drives Or Folders
c1Code:
One common task Visual Basic programmers must accomplish is to verify the existence of a specific filename. Most often than not, a simple Dir$ function will suffice - if the path of that filename is known.

Sometimes (in our experience: more times than we care to remember) the path to that file is unknown. Attempting a recursion through the directory structure of today's hard drives, in the attempt to locate that file, is not exactly efficient: you must write a substantial amount of code, and the performance of your best coding effort is always somewhat disappointing.

The code and the sample project we present here demonstrates how to quickly locate a specific filename on

a drive.

Assume, for example, that you should verify the existence of the database file "NWIND.MDB". You know that the file could (or should) be stored on drive "C", but you have no knowledge or indication whatsoever about the folder in which the file may be stored.

One single call to our sysFileFind function would very quickly return the fully qualified filename for NWIND.MDB if the file exists, or a zero length string if it does not. In code:

Dim TheFileName As String

 

     TheFilename = sysFileFind("C", "NWIND.MDB")

     If Len(TheFileName) > 0 Then

           MsgBox "NWIND.MDB exists: " & TheFileName

           Else

                 MsgBox "NWIND.MDB was not found on drive C"

     End if

Should you have knowledge of the folder where NWIND.MDB is supposed to be located, you could use sysFileFind to scan that folder and any of its subfolders. For example:

Dim TheFileName As String

 

     TheFilename = sysFileFind("C:\Program Files", "NWIND.MDB")

     If Len(TheFileName) > 0 Then

           MsgBox "NWIND.MDB exists: " & TheFileName

           Else

           MsgBox "NWIND.MDB was not found in C:\Program Files or any of its subfolders."

     End if

Declare

Public Declare Function SearchTreeForFile Lib "imagehlp.dll" (ByVal lpRoothPath As String, ByVal lpInputName As String, ByVal lpOutputName As String) As Long

Public Function sysFileFind(ByVal WhichRootPath As String, ByVal WhichFileName As String) As String

Code

Dim iNull As Integer

Dim lResult As Long

Dim sBuffer As String

    'internal error handler

    On Error GoTo L_FILEFINDERROR

    'allocate buffer

    sBuffer = String$(1024, 0)

    'find file

    lResult = SearchTreeForFile(WhichRootPath, WhichFileName, sBuffer)

    'if file was found, trim to null

    'and return fully qualified path,

    'otherwise return zero length string

    If lResult Then

        iNull = InStr(sBuffer, vbNullChar)

        If Not iNull Then

            sBuffer = Left$(sBuffer, iNull - 1)

        End If

        sysFileFind = sBuffer

        Else

            sysFileFind = ""

    End If

Exit Function

L_FILEFINDERROR:

    'on error, returns string containing error number and description

    MsgBox "Function sysFilefind has returned error code.", vbInformation,     "sysFileFind::violation"

    sysFileFind = Format(Err.Number) & " - " & Err.Description

End Function

Tip Submitted By: Giorgio Vidali

The sample code for this project as well as other tips by Giorgio Vidali can be fount at http://user.mc.net/~gvsoft/


c0Title: Find Entries in List and Combo Boxes
c1Code:
Searching for an entry in a list box or a combo box involves scrolling through the list to find a match�a time-consuming process if there are many entries in the list. Here is the old way to search for an entry:

Dim nLoop As Integer
'Loop variable, current position of entry in list Dim sEntry As String 'String being searched Dim nIndex As Integer 'Location of entry in the list sEntry = "J"
nIndex = -1
For nLoop = 0 To list1.ListCount - 1
If sEntry = list1.List(nLoop) Then
nIndex = nLoop
Exit For
End If
Next
A faster way to do this is to send a CB_FINDSTRINGEXACT or LB_FINDSTRINGEXACT with the API function SendMessage. This will return the index of the entry if it is found in the box:

Global Const WM_USER = 1024
Global Const CB_FINDSTRINGEXACT = (WM_USER + 24) 'for Combobox only Global Const LB_FINDSTRINGEXACT = (WM_USER + 35) 'for Listbox only Declare Function SendMessage Lib "User" _ (ByVal hWnd As Integer, ByVal wMsg As Integer, _ ByVal wParam As Integer, lParam As Any) As Long Dim sSearch As String Dim nIndex As Long sSearch = "<Some Text>"
nIndex = SendMessage(List1.hWnd, _
LB_FINDSTRINGEXACT, -1, ByVal sSearch)
If nIndex < 0 Then
MsgBox "Not Found"
Else
'Make matching item the selected one
List1.ListIndex = nIndex
End If
Windows also has CB_FINDSTRING and LB_FINDSTRING. Try these constants if you want to search for strings that start with the specified string.

�Deepak Agrawal


c0Title: Find Matching Records as you Type
c1Code:
You can construct a search box to find information as you type using the textbox�s Change event. A SQL statement with the Like operator and an �*� added to the end gives you the matching record as you type. This example uses option buttons to allow searches in different fields. I have used this feature in several programs�some with more than 4,000 records�and it is quite fast:

 
Private Sub searchbox_Change()
     On Error Resume Next
     Select Case True
          Case Option1.Value
               Data1.Recordset.FindFirst _
                    "[accountnumber] Like '" & _
                    searchbox.Text + "*" & "'"
          Case Option2.Value
               Data1.Recordset.FindFirst _
                    "[customername] Like '" & _
                    searchbox.Text + "*" & "'"
          Case Option3.Value
               Data1.Recordset.FindFirst _
                    "[businesstype] Like '" & _
                    searchbox.Text + "*" & "'"
     End Select
End Sub
�Barry Rudd, Waycross, Georgia


c0Title: Find the Associated Executable
c1Code:
VB4 32, VB5, VB6

Sometimes you might need to determine the full path name to a Windows executable file associated with a given file extension.
The usual recourse is to use the FindExecutable API. However, there�s one hitch: FindExecutable requires an actual file. So to make use of this API, you first need to create a temporary file with the proper extension. Passing the desired extension to this GetAssociatedExecutable routine�for example, TXT or MDB�is an easy way to do this:

Private Declare Function 
FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long 

Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long 

Private Declare Function GetTempPath Lib _ "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

' Usage: GetAssociatedExecutable("MDB")

Public Function GetAssociatedExecutable(ByVal _ Extension As String) As String 

	Dim Path As String 
	Dim FileName As String 
	Dim nRet As Long 

	Const MAX_PATH As Long = 260 

	' Create a tempfile 
	Path = String$(MAX_PATH, 0) 

	If GetTempPath(MAX_PATH, Path) Then 
		FileName = String$(MAX_PATH, 0) 

		If GetTempFileName(Path, "~", 0, FileName) Then
			FileName = Left$(FileName, InStr(FileName, vbNullChar) - 1)

			' Rename it to use supplied extension
			Name FileName As Left$(FileName, _
			InStr(FileName, ".")) & Extension
			FileName = Left$(FileName, InStr(FileName, ".")) & Extension

			' Get name of associated EXE
			Path = String$(MAX_PATH, 0)
			Call FindExecutable(FileName, vbNullString, Path)
			GetAssociatedExecutable = Left$(Path, InStr(Path, vbNullChar) - 1)

			' Clean up
			Kill FileName
		End If
	End If
End Function

�Pier Minneci, Torino, Italy


c0Title: Find The Path Of A Loaded File
c1Code:
This function returns a path of any loaded executable

'Declares for GetLoadedFilePath

Declare Function GetModuleHandle Lib "Kernel" (ByVal FileName$) As Integer
Declare Function GetModuleFileName Lib "Kernel" (ByVal hModule%, ByVal FileName$, ByVal nsize%) As Integer
Function GetLoadedFilePath (FileName As String) As String

Dim hmod As Integer, Path As String, PathLen As Integer

    hmod = GetModuleHandle%(FileName)
    Path = Space(255)
    PathLen = GetModuleFileName%(hmod, Path, Len(Path))
    GetLoadedFilePath = Left(Path, PathLen)

End Function

Tips Submitted By: Jeff Williams


c0Title: Finding Hard/Floppy/Removable Drives
c1Code:
If you need to find what floppy drives, hard drives or removable drives (CD-ROM/Network) there is on a system, declare the following in a BAS file:

Declare Function GETDRIVETYPE Lib "Kernel" (ByVal nDrive As Integer) As Integer

You must pass this function the drive number, not a drive letter. Drive numbers always start a 0. For instance, drive A: is drive #0, Drive C: is drive #2.

DRIVETYPE = GETDRIVETYPE(DRIVENUM)

This function returns a 2 for removable drives, 3 for fixed drives or 4 for remote drives. This function will return a 0 if it is passed a drive number that does not exist on the system.

Submitted By: David McCarter


c0Title: The FlashSort Algorithm
c1Code:
FlashSort sorts n elements in O(n) time. Flash-Sort uses a vector L(k) of length m in a first step for the classification of the elements of array A. Then, in a second step, the resulting counts are accumulated and the L(k) point to the class boundaries. Then the elements are sorted by in situ permutation. During the permutation, the L(k) are decremented by a unit step at each new placement of an element of class k in the array A. A crucial aspect of FlashSort is that for identifying new cycle leaders. A cycle ends, if the the vector L(k) points to the position of an element below the classboundary of class k. The new cycle leader is the element situated in the lowest position complying to the complimentary condition, i.e. for which L(k) points to a position with L(k(A(i))) >= i. Evidently, in addition to the array A of length n which holds the n elements to be sorted, the only auxiliary vector is the L(k)-vector. The size of this vector is equal to the number m of classes which is small compared to n, e.g. m typically may be set to m=0.1 n in case of floating point numbers. 
Finally,a small number of partially distinguishable elements are sorted locally within their classes either by recursion or by a simple conventional sort algorithm. 
 
flashsrt.bas - FlashSort embedded

               in full functional demo inclusive runtime measurement.


CLS

DEFINT A-Z



INPUT " How many numbers to be sorted? N = ", N

REM INPUT " How many numbers classes? M = ", M
REM =================================================

DIM A(N)

REM =================================================

PRINT " Generate vector of N random integer numbers "

PRINT " ------------------------------------------- "

GOSUB RANDOMS

GOSUB DISPLAY

PRINT

PRINT

PRINT " -------------- START FlashSort ------------ "

PRINT " ******************************************* "

T0# = TIMER

       GOSUB FLASHSORT

T1# = TIMER

PRINT " -------------- FlashSort READY ------------ "

PRINT

PRINT USING " N = ##### Integers sorted"; N;

PRINT USING " in ##.### seconds "; T1# - T0#

PRINT USING " Number of classes M was ####"; M

PRINT " ------------------------------------------- "

GOSUB DISPLAY

END



REM =================================================

RANDOMS:

RANDOMIZE TIMER

FOR I = 1 TO N

    A(I) = INT(RND(1) * 10000)

NEXT I

RETURN



REM =================================================

DISPLAY:

PRINT " Display first 20 numbers: "

FOR I = 1 TO 20

PRINT USING "##### "; A(I);

NEXT I

PRINT

PRINT " Display last 20 numbers: "

FOR I = N - 20 TO N

  PRINT USING "##### "; A(I);

NEXT I

RETURN



REM =================================================

FLASHSORT:

REM sorts array A with N elements by use of

REM index vector L with M elements, with M ca. 0.1 N.

REM Translation of Karl-Dietrich Neubert's FlashSort

REM algorithm into BASIC by Erdmann Hess.

REM Integer Version.

REM The program was tested with MS-QBasic 1.1.

REM =============== CLASS FORMATION =================

M = .125 * N

DIM L(M)

ANMIN = A(1)

NMAX = 1

FOR I = 1 TO N

IF (A(I) < ANMIN) THEN ANMIN = A(I)

IF (A(I) > A(NMAX)) THEN NMAX = I

NEXT I

IF (ANMIN = A(NMAX)) THEN RETURN

C1# = (M - 1) / (A(NMAX) - ANMIN)

FOR K = 1 TO M

L(K) = 0

NEXT K

FOR I = 1 TO N

K = 1 + INT(C1# * (A(I) - ANMIN))

L(K) = L(K) + 1

NEXT I

FOR K = 2 TO M

L(K) = L(K) + L(K - 1)

NEXT K

HOLD = A(NMAX)

A(NMAX) = A(1)

A(1) = HOLD

REM ==================== PERMUTATION ================

NMOVE = 0

J = 1

K = M

WHILE (NMOVE < (N - 1))

WHILE (J > L(K))

J = J + 1

K = 1 + INT(C1# * (A(J) - ANMIN))

WEND

FLASH = A(J)

WHILE (NOT (J = (L(K) + 1)))

    K = 1 + INT(C1# * (FLASH - ANMIN))

    HOLD = A(L(K))

    A(L(K)) = FLASH

    FLASH = HOLD

    L(K) = L(K) - 1

    NMOVE = NMOVE + 1

WEND

WEND

REM ================= STRAIGHT INSERTION ============

FOR I = N - 2 TO 1 STEP -1

IF (A(I + 1) < A(I)) THEN

HOLD = A(I)

J = I

WHILE (A(J + 1) < HOLD)

A(J) = A(J + 1)

J = J + 1

WEND

A(J) = HOLD

END IF

NEXT I

REM ============== RETURN, END FLASHSORT ============

RETURN


c0Title: Float Buttons Over Tab Panels
c1Code:
VB3 and up

When using the SSTab control to build a tabbed dialog, I often find the design more pleasing when the OK/Cancel buttons or other controls appear on every tab. It�s easy to place a similar control on every tab page, but with more than a few tabs, this process can be resource-consuming and potentially more difficult to debug.
A better way to do this is to use the natural Z-order of controls.
If you draw and size the controls you want to be �floating� outside the SSTab control, then use the Bring to Front command on the Format bar, or right-click on them and select Bring to Front. The controls will appear above the tab control. Simply move them to a position that�s empty in every tab, and you have a floating control.
Lightweight controls, such as labels and image boxes, do not draw above the tabs, so test the design carefully.
�Michael Lewis, Chiang Mai, Thailand


c0Title: Force Slider to Specific Intervals
c1Code:
Try using a slider control in your UI if you�re tired of combo boxes. Users find this control intuitive to understand and operate. For example, you might use the slider control to obtain values from a user in increments of $1,000.  First, add the slider control to a form. Set the slider�s Min and Max properties to the appropriate range for your app. Then, set the TickFrequency property equal to any interval of interest. Using the example, try setting the slider properties to: Min=1,000 and Max=10,000. Unfortunately, if a user drags the slider instead of clicking on it, values between the tick marks are returned. Here�s a cool way to easily control this behavior. Place this code in the slider�s Change event, substituting your control�s name:

 

Private Sub slBWidth_Change()

       slBWidth = CInt(slBWidth.Value / slBWidth. _

              TickFrequency) * slBWidth.TickFrequency

End Sub

 

Now try it out to see how the control behaves. The result is the same as scaling the slider from 1 to 10, then multiplying by a scale factor for the value. The difference is that it now free-slides instead of jerking between ticks.

�Christopher K. Hausner, Sterling Heights, Michigan


c0Title: Force Tri-State Checkbox Cycling
c1Code:
The CheckBox control in VB supports three positions: Checked, Unchecked, and Grayed. Unfortunately, the default behavior for the control is to cycle between Checked and Unchecked. To set it to Grayed, you must do it programatically.
This code shows you how to cycle between the three positions (the order is Checked->Unchecked->Grayed->Checked ...):
Private Sub Check1_Click()
Static iState As CheckBoxConstants
Static bUserClick As Boolean
' Trap if the user clicked on the control ' or if the event was fired because you ' changed the value below bUserClick = (iState <> Check1.Value) ' Prevents you from entering an infinite ' loop and getting an Out of Stack Space error If bUserClick Then Select Case iState Case vbChecked iState = vbUnchecked Case vbUnchecked iState = vbGrayed Case vbGrayed iState = vbChecked End Select ' This will raise another click event but ' your boolean check prevents you from looping Check1.Value = iState End If End Sub �Eric Litwin, Thousand Oaks, California


c0Title: Format Names Consistently
c1Code:
People�s names come in many separate parts, some of which might not be present or known. The hassle begins when you�re dealing with a storage system�database or otherwise�where the parts are stored separately. You�re faced with the formidable task of putting it all together with correct formatting. A common mistake is formatting a person�s name whose middle initial is not known: John . Doe instead of John Doe. Using these functions, you can correct this problem without repeating effort:

 

Public Function FormatName(firstname As String, lastname As _

       String, Optional mi As String, Optional title As String, _

       Optional Suffix As String) As String

       Dim sRet As String

       If Len(Trim$(title)) > 0 Then

             sRet = StrConv(title, vbProperCase)

             If Right$(sRet, 1) <> "." Then sRet = sRet & "."

             sRet = sRet & " "

       End If

       If Len(Trim$(firstname)) > 0 Then

             sRet = sRet & StrConv(firstname, vbProperCase) & " "

       End If

       If Len(Trim$(mi)) > 0 Then

             sRet = sRet & StrConv(mi, vbProperCase)

             If Right$(sRet, 1) <> "." Then sRet = sRet & "."

             sRet = sRet & " "

       End If

       If Len(Trim$(lastname)) > 0 Then

             sRet = sRet & StrConv(lastname, vbProperCase) & " "

       End If

       If Len(Trim$(Suffix)) > 0 Then

             sRet = Trim$(sRet) & ", " & StrConv(Suffix, vbProperCase)

       End If

       FormatName = Trim$(sRet)

End Function

 

The next function resembles the previous one, except that it puts the last name first:

 

Public Function FormatNameReverse(firstname As String, _
       lastname As String, Optional mi As String) As String

       Dim sRet As String

       sRet = StrConv(lastname, vbProperCase)

       If Len(Trim$(firstname)) > 0 Or Len(Trim$(mi)) > 0 _
             Then

             sRet = sRet & ","

       End If

       If Len(Trim$(firstname)) > 0 Then

             sRet = sRet & " " & Trim$(StrConv(firstname, _     
                    vbProperCase))

       End If

       If Len(Trim$(mi)) > 0 Then

             sRet = sRet & " " & Trim$(StrConv(Left$(mi, 1), _

                    vbProperCase)) & "."

       End If

       FormatNameReverse = Trim$(sRet)

End Function

�Konstantin Komissarchik, Brier, Washington


c0Title: Format Your Version Info
c1Code:
Many professional applications are required to display a version number on all screens to indicate to users which version of the app is currently running. This also helps with configuration manage-ment.
Here�s a function that appends the VB project�s version number to a text description passed to the function as input. The version information is embedded in a project by assigning major, minor, and revision values on the Make tab of the Project Proper-ties dialog. Then when you right-click on the resulting EXE file in Windows, go to Properties, and click on the Version tab, the version number matches those on your screens, providing a nice consistency. Putting the function in a standard module�particu-larly one made of generic reusable functions and subprocedures� allows other developers to plug the module into their projects and use the routine:

Public Function GetVersion(strApp As String) _ As String ' Pass in the application name you want ' displayed as part of the form's caption. A ' blank character and the version number are ' appended to the application name ' completing the caption.
GetVersion = strApp & " " & _
Format(App.Major, "#0") & "." & _
Format(App.Minor, "#00") & "." & _
Format(App.Revision, "0000")
End Function
Here�s a sample call to this function:
Dim strVersion As String
strVersion = "Application XYZ Version"
frmMain.Caption = GetVersion(strVersion) ' Set form's caption

�Michael T. Hutman, Germantown, Maryland


c0Title: Functions Parse Command Lines
c1Code:
Handling multiple command-line arguments has always been ugly in VB, especially when some of the arguments are quoted because they contain characters such as spaces. For example, if you want to write a program that takes as an argument a filename, you must quote the filename to ensure a space inside it doesn�t confuse your application. Unfortunately, there�s no built-in functionality for handling this mess. Here are two functions�GetParam and GetParamCount�that I use all the time. Each can handle a mix of quoted and unquoted parameters:


Public Function GetParam(ByVal Count As Integer) As String

       Dim i As Long
       Dim j As Integer
       Dim c As String
       Dim bInside As Boolean
       Dim bQuoted As Boolean

       j = 1
       bInside = False
       bQuoted = False
       GetParam = ""

       For i = 1 To Len(Command)

             c = Mid$(Command, i, 1)

             If bInside And bQuoted Then

                    If c = """" Then

                           j = j + 1
                           bInside = False
                           bQuoted = False

                    End If

              ElseIf bInside And Not bQuoted Then

                    If c = " " Then

                           j = j + 1
                           bInside = False
                           bQuoted = False

                    End If

             Else

                    If c = """" Then

                           If j > Count Then Exit Function
                           bInside = True
                           bQuoted = True

                    ElseIf c <> " " Then

                           If j > Count Then Exit Function
                           bInside = True
                           bQuoted = False

                    End If
             End If

 

             If bInside And j = Count And c <> """" Then GetParam = GetParam & c
       Next i

End Function

 

Public Function GetParamCount() As Integer

       Dim i As Long
       Dim c As String
       Dim bInside As Boolean
       Dim bQuoted As Boolean

       GetParamCount = 0
       bInside = False
       bQuoted = False

       For i = 1 To Len(Command)

             c = Mid$(Command, i, 1)

             If bInside And bQuoted Then

                    If c = """" Then

                           GetParamCount = GetParamCount + 1
                           bInside = False
                           bQuoted = False

                    End If

             ElseIf bInside And Not bQuoted Then

                    If c = " " Then

                           GetParamCount = GetParamCount + 1
                           bInside = False
                           bQuoted = False

                    End If

             Else

                    If c = """" Then

                           bInside = True
                           bQuoted = True

                    ElseIf c <> " " Then

                           bInside = True
                           bQuoted = False

                    End If
             End If
       Next i

 

       If bInside Then GetParamCount = GetParamCount + 1

End Function

�Konstantin Komissarchik, Brier, Washington


c0Title: Generate GUIDs With One API Call
c1Code:
I read a great advanced tip on how to create a GUID in �Generate Unique String IDs� [�101 Tech Tips for VB Developers,� Supplement to VBPJ, August 1999]. However, you can use only one API call instead of four. The OLE32.dll contains a function called WinCoCreateGUID that does all the math for you. I have included a second function called PadZeros to format the GUID:

 

Option Explicit

Private Type GUIDType
       D1       As Long
       D2       As Integer
       D3       As Integer
       D4(8)    As Byte
End Type

Private Declare Function WinCoCreateGuid Lib "OLE32.DLL" Alias "CoCreateGuid" (g As GUIDType) As Long

Public Function CreateGUIDString() As String

       Dim g As GUIDType
       Dim sBuf As String

       Call WinCoCreateGuid(g)

       sBuf = PadZeros(Hex$(g.D1), 8, True) & _
              PadZeros(Hex$(g.D2), 4, True) & _
              PadZeros(Hex$(g.D3), 4, True) & _
              PadZeros(Hex$(g.D4(0)), 2) & _
              PadZeros(Hex$(g.D4(1)), 2, True) & _
              PadZeros(Hex$(g.D4(2)), 2) & _
              PadZeros(Hex$(g.D4(3)), 2) & _
              PadZeros(Hex$(g.D4(4)), 2) & _
              PadZeros(Hex$(g.D4(5)), 2) & _
              PadZeros(Hex$(g.D4(6)), 2) & _
              PadZeros(Hex$(g.D4(7)), 2)

       CreateGUIDString = sBuf
End Function

 

Private Function PadZeros(ByVal sBit As String, ByVal iStrLen As Integer, Optional bHyphen As Boolean) As String

       If iStrLen > Len(sBit) Then
             sBit = Right$(String$((iStrLen - Len(sBit)), "0") & sBit, iStrLen)
       End If

       If bHyphen Then sBit = sBit & "-"
       PadZeros = sBit

End Function

�Dj Hackney, received by e-mail


c0Title: Generate Memorable Paswords
c1Code:
You often need to generate passwords on the fly. Perhaps you�re creating a new user and need a temporary password - or need to assign short phrases to customers for identification purposes.

Either way, this little function will certainly prove useful. You simply call GeneratePassword, passing the length of the password you require.

It passes back a consonant-vowel-consonant-vowel combination, meaning the returned phrase is much easier to remember than most automatically generated passwords, such as YPSWW94441.

Usage

MsgBox GeneratePassword(5)
This returns a five character random password, such as BONES or LAMOT.

You can download a fully working sample of this code here.

Code

Public Function GeneratePassword(Length As Integer) As String

Dim blnOnVowel As Boolean
Dim strTempLetter As String
Dim strPassword As String

For i = 1 To Length

If blnOnVowel = False Then
   strTempLetter = Choose(GetRandomNumber(1, 17), _
   "B", "D", "F", "G", "H", "J", "K", "L", "M", _
   "N", "P", "R", "S", "T", "V", "W", "Y")
   
   'Choose a 'nice' consonant - no C, X, Z, or Q, thanks!
   strPassword = strPassword & strTempLetter
  
  'Append it to the password string
  blnOnVowel = True

 'Switch to vowel mode

Else
  
  strTempLetter = Choose(GetRandomNumber(1, 5), _
  "A", "E", "I", "O", "U")
  'Choose a vowel
  
  strPassword = strPassword & strTempLetter
  'Append it to the password string
  
  blnOnVowel = False
  'Switch back again, ready for next loop round

End If

Next i

GeneratePassword = strPassword
'Set function to the password string

End Function

Public Function GetRandomNumber(Upper As Integer, _
Lower As Integer) As Integer
'Returns a random number within the lower and upper limits
Randomize
GetRandomNumber = Int((Upper - Lower + 1) * Rnd + Lower)
End Function
Tip by Karl Moore


c0Title: Generate Ordinal Strings Simply
c1Code:
Sometimes, you have an integer value in code that you�d like to display in a string as an ordinal. For example, a variable contains the number 3, and you want to display a message like �The 3rd item...� You can use this function to convert the number into a string with �st,� �nd,� �rd,� or �th� attached properly:

Public Function GetOrdinal(ByVal Num As Long) As String

       Dim n As String

       ' Num is assumed to be greater than zero

       n = CStr(Num)

       Select Case Right$(n, 2)

             Case "11", "12", "13"

                    GetOrdinal = n & "th"

             Case Else

                    Select Case Right$(n, 1)

                           Case "0", "4" To "9"

                                  GetOrdinal = n & "th"

                           Case "1"

                                  GetOrdinal = n & "st"

                           Case "2"

                                  GetOrdinal = n & "nd"

                           Case "3"

                                  GetOrdinal = n & "rd"

                    End Select

       End Select

End Function

�Thomas Weiss, Deerfield, Illinois


c0Title: Generate Relative Path Between Folders
c1Code:
You can use a Shell Light Weight API to generate a relative path by using this code:

Private Declare Function PathRelativePathToW Lib "shlwapi.dll" (ByVal pszPath As Long, ByVal pszFrom As Long, ByVal dwAttrFrom As Long, ByVal pszTo As Long, ByVal dwAttrTo As Long) As Boolean

Private Function GetRelativePath(sRelativePath As String, ByVal sPathFrom As String, ByVal sPathTo As String) As Boolean
	Dim bResult As Boolean
	Const MAX_PATH As Long = 260
	sRelativePath = Space(MAX_PATH)

	' Set "dwAttr..." to vbDirectory for
	' directories, 0 for files
	bResult = PathRelativePathToW(StrPtr(sRelativePath), StrPtr(sPathFrom), vbDirectory, StrPtr(sPathTo), 0)
	If bResult Then
		sRelativePath = Left(sRelativePath, InStr(sRelativePath, vbNullChar) - 1)
	Else
		sRelativePath = ""
	End If

	GetRelativePath = bResult
End Function

Private Sub Command1_Click()
	Dim sRelative As String

	' txtFromPath should contain the directory
	' path to go from, txtToPath should contain
	' the file path to go to.
	' txtRelativePath will contain the result

	If GetRelativePath(sRelative, txtFromPath.Text, txtToPath.Text) Then
		txtRelativePath.Text = sRelative
	Else
		txtRelativePath.Text = "Error"
	End If
End Sub

PathRelativePathTo requires shlwapi.dll version 4.71 or higher, which ships with Internet Explorer 4. See http://msdn.microsoft.com/library/psdk/shellcc/shell/versions.htm for versioning details.

�Phil Fresle, Corfe Mullen, England


