# ftsItem_content

c0Title: Set Error Level in DOS
c1Code:
Use this code to set the error level in DOS, or as I use it, to return a calculated date:

 
Private Declare Sub ExitProcess Lib "kernel32" ( _
     ByVal uExitCode As Long)
 
Sub Main()
     Dim lngDate As Long
     Dim intCmd As Integer
     intCmd = 0
 
' Check CommandLine for parameters
     If Command <> "" Then
          intCmd = Val(Command)
     End If
 
' Format date and convert to Long    
     lngDate = CLng(Format$(Now + intCmd, "yymmdd"))
     ExitProcess lngDate
End Sub
 
Compile the program and save it as VB_Day.exe. For example, make a DOS batch file, and test the program:
 
@echo off
rem *** Calulate date from VB_Day
VB_Day -1
SET MyDay=%ERRORLEVEL%
echo Today - 1 = %MyDay%
 
VB_Day 7
SET MyDay=%ERRORLEVEL%
echo Today + 7 = %MyDay%
 
VB_Day 
SET MyDay=%ERRORLEVEL%
echo Today is  = %MyDay%
 

Do not call ExitProcess from anywhere but the end of Sub Main, and only after releasing all object references. ExitProcess has the same practical effect on your application as VB�s End statement, with the added �bonus� of also shutting down the IDE if you�re not running a compiled EXE.

�Peter Andr�, Malm�, Sweden


c0Title: Set tab stops
c1Code:
You can use an API call to set tab stops within a text box. There are internal tab stops in multiple-line (but not single-line) text box controls: If the text in the text box contains tab characters (character code 9 or vbTab), the text following the tab character is aligned at the next tab stop. You can set the position of these tab stops by calling the SendMessage function in the Windows API and passing an array that contains the new tab stop settings.

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

Const EM_SETTABSTOPS = &HCB

Public Sub SetTxtTabs(txt As TextBox, ParamArray Tabstops() As Variant)
    Dim i As Long
    Dim Tabs() As Long
    Dim NumColumns As Long            

    ReDim Tabs(LBound(Tabstops) To UBound(Tabstops))     
    For i = LBound(Tabstops) To UBound(Tabstops)
        Tabs(i) = Tabstops(i)
    Next I

    NumColumns = UBound(Tabs) - LBound(Tabs) + 1
    SendMessage txt.hwnd, EM_SETTABSTOPS, 0, vbNullString  'clear tabs
    SendMessage txt.hwnd, EM_SETTABSTOPS, NumColumns, Tabs(0) End Sub

When you call this procedure, you specify the name of the text box and the list of tab stops you want to use for the indent. The tab values are approximately 4 X NoCharacters. For example:

Private Sub Command1_Click()
   SetTxtTabs Text1, 120, 150, 200
End Sub



c0Title: Set the computer's time using the NIST atomic clock
c1Code:
Title Set the computer's time using the NIST atomic clock 
Keywords time, clock, NIST, atomic clock 
Categories Windows, Software Engineering, Utilities, Controls 
 
 
 
Thanks to Joe Sova. 
The following code uses a Winsock control to connect to a NIST time server. 
 

 
Option Explicit
 
'#######################################################
'*******************************************************
'Simple but very accurate time setting using Winsock
'By Joe Sova
'jsova@twmi.rr.com
'Copyright(c) 2003 'Just kidding
'Use at your own risk!
'Copy, mutilate, distribute, change and otherwise abuse
'Only real requirement is that you learn, learn, learn!
'*******************************************************
'#######################################################
 
'Wait 2 seconds between time settings else the server may not respond
 
'Timer1 gives the server 5 seconds to respond, else time setting is aborted
'Timer2 updates the current time on Form1 each second
 
'The program checks for three conditions of invalid time, aborts if not valid
'1) The string that was received from the server is not of the proper format
'2) If the server reports it's own condition to be bad
'3) If for some reason 'SetSystemTime' returns an error it will try upt to 10
'more times to set the time else it aborts
 
'This program requires that the local computer has it's timezone set correctly
'as the time the server sends is always UTC or a timezone of 0
'Daylight saving time is also the responsibility of the local computer
 
'The accuracy of this program, as far as I can tell from other programs that
'measure such things is +/- 100ms of perfect time a very impressive result!
 
'Finally
'This program sets the system time by directly modifying the SetSystemTime SYSTEMTIME data structure
'Microsoft apparently does not recommend doing it this way,
'see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/sysinfo/base/systemtime_str.asp
'Microsoft says... "It is not recommended that you add and subtract values from
'the SYSTEMTIME structure to obtain relative times.
'Instead, you should Convert the SYSTEMTIME structure to a FILETIME structure.
'Copy the resulting FILETIME structure to a ULARGE_INTEGER structure.
'Use normal 64-bit arithmetic on the ULARGE_INTEGER value."
 
'Then I would assume that after the 64-bit math is added, all the above steps would need to be reversed.
 
'If anyone successfully does this the 'correct' way, please send me a 'how to'
'Thanks So much
'-Joe
 
Private Declare Function SetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) As Long 'sets system time when arrives from server
 
Private 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
 
Private msAdj As Integer
Private SetIt As Integer
 
Private Sub Command1_Click() 'Main button to set the system time
    On Error GoTo ErrHandler
 
    Label3.Caption = "System Time has Not been Set Yet"
 
    SetIt = 1 'Used to only set time if the time from the time server is valid and reportedly accurate
 
    If Winsock1.State <> sckClosing Then 'Sometimes the Winsock gets delayed in the closing state, so make sure it is closed before trying again
       If Winsock1.State = sckClosed Then 'If closed, ok to open, else close it
          Timer1.Interval = 5000 'Start 5 second count to 'time' server
          Timer1.Enabled = True
          Screen.MousePointer = vbHourglass
          Winsock1.LocalPort = 0 'Must be set to 0
          Winsock1.RemoteHost = Trim$(Text1.Text) 'Address of NIST server
          Winsock1.RemotePort = 13 '13, 37 or 123 'Use 13!
          Winsock1.Protocol = 0 '1-UDP '0-TCP 'USE TCP!
          Winsock1.Connect 'This is what goes out and gets the time
       Else
          Winsock1.Close
          Screen.MousePointer = vbNormal
          Timer1.Interval = 0
          Timer1.Enabled = False
       End If
    Else
       Winsock1.Close
       Screen.MousePointer = vbNormal
       Timer1.Interval = 0
       Timer1.Enabled = False
    End If
    
    Exit Sub
ErrHandler:
    SetIt = 0
    Screen.MousePointer = vbNormal
    Timer1.Interval = 0
    Timer1.Enabled = False
    MsgBox "The Winsock Connection is Unavailable."
    Winsock1.Close
End Sub
 
Private Sub Command2_Click() 'Properly close the project
 
Timer1.Interval = 0
Timer1.Enabled = False
 
Timer2.Interval = 0
Timer2.Enabled = False
 
Unload Me
Set Form1 = Nothing
 
End Sub
 
Private Sub Command3_Click() 'Temporarily set the time back 90s for testing
 
MsgBox "It is not recommended to ever set the system time to an incorrect value," & vbCrLf & _
"after running this test, make sure the system time is returned to the correct time.", vbExclamation
 
Time = DateAdd("s", -90, Now)
Label1.Caption = "Before " & Now
Label2.Caption = "Time After Adjustment"
 
End Sub
 
Private Sub Form_Load()
 
'All these servers are valid for this system
'  ADDRESS              NAME                            LOCATION
'****************************************************************************
'128.138.140.44    utcnist.colorado.edu           University of CO, Boulder
'129.6.15.28       time-a.nist.gov                NIST, Gaithersburg, MD
'129.6.15.29       time-b.nist.gov                NIST, Gaithersburg, MD
'131.107.1.10      time-nw.nist.gov               Microsoft, Redmond, WA
'132.163.4.101     time-a.timefreq.bldrdoc.gov    NIST, Boulder, Colorado
'132.163.4.102     time-b.timefreq.bldrdoc.gov    NIST, Boulder, Colorado
'132.163.4.103     time-c.timefreq.bldrdoc.gov    NIST, Boulder, Colorado
'192.43.244.18     time.nist.gov                  NCAR, Boulder, Colorado
'205.188.185.33    nist1.aol-va.truetime.com      AOL TrueTime, Virginia
'207.126.98.204    nist1-sj.glassey.com           Abovenet, San Jose, CA
'207.200.81.113    nist1.aol-ca.truetime.com      AOL TT, Sunnyvale, CA
'208.184.49.9      nist1-ny.glassey.com           Abovenet, New York City
'216.200.93.8      nist1-dc.glassey.com           Abovenet, Virginia
'66.243.43.21      nist1.datum.com                Datum, San Jose, CA
 
'Also works just fine to use the name instead of the address in the text box but,
'it is not recommended 'cause the Name is likely to change although the address will not
Text1.Text = "192.43.244.18" 'time.nist.gov
 
End Sub
 
Private Sub Timer1_Timer() 'Server did not respond within 5 seconds
 
Winsock1.Close
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
 
MsgBox "There was no reponse from server, please wait 2 seconds and try again"
 
End Sub
 
Private Sub Timer2_Timer() 'Updates current time on Form1 each second
Label4.Caption = "Current Time is " & Now
End Sub
 
Private Sub Winsock1_Close() 'Fires when Winsock is closed
 
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
 
End Sub
 
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) 'Fires when data is received from server
Dim datDate As Date 'formatted date
Dim strData As String 'time string from net time server
Dim JSys As SYSTEMTIME
Dim RetVal As Integer
Dim Ct As Integer
 
    On Error GoTo ErrHandler
    
    Winsock1.GetData strData, vbString 'get string from server
    datDate = FormatDateTime(strData) 'go format the new string
    
    If msAdj <> 0 Then 'if msadj = 0 then do not set an offset
       datDate = DateAdd("s", -1, datDate) 'only if msadj <> 0, subtract 1 sec from new time so addition of msadj is positive
    End If
    
    Label1.Caption = "Before " & Now 'time before adjustment
    
    If SetIt = 1 Then 'If all is ok, set system time
    
       'Initialize SYSTIME with new data
       JSys.wYear = Year(datDate)
       JSys.wMonth = Month(datDate)
       JSys.wDayOfWeek = 0 'DayOfWeek(datDate)'Not used
       JSys.wHour = Hour(datDate)
       JSys.wMinute = Minute(datDate)
       JSys.wSecond = Second(datDate)
       JSys.wDay = Day(datDate)
       
       If msAdj = 0 Then
          JSys.wMilliseconds = 0 'No millisec offset
       Else
          JSys.wMilliseconds = ((10000 - msAdj) / 10) 'must be positive
       End If
 
       ' Set system time with new data
' Modified by Rod, 11/7/03
'       Do Until RetVal <> 0 Or Ct > 9 'Make up to 10 attempts to set the time
          RetVal = SetSystemTime(JSys)
'          Ct = Ct + 1
'       Loop
 
       Label2.Caption = "After " & Now 'time after adjustment
       
       If RetVal <> 0 Then
          Label3.Caption = "System Time was Set Successfully"
       Else
          Label3.Caption = "There was an Error in Setting Time"
       End If
 
       'Display time string that was sent from server
       Text2.Text = strData
    End If
    
    SetIt = 0
    Winsock1.Close
    Screen.MousePointer = vbNormal
    Timer1.Interval = 0
    Timer1.Enabled = False
    
    Exit Sub
ErrHandler:
    SetIt = 0
    Winsock1.Close
    Screen.MousePointer = vbNormal
    Timer1.Interval = 0
    Timer1.Enabled = False
End Sub
 
Private Function FormatDateTime(ByRef NetTime As String) As Date 'format the string received from time server
 
Dim strDate As String
Dim strTime As String
 
'Received string example
'JJJJJ YR-MO-DA HH:MM:SS TT L H msADV UTC(NIST) OTM
'52587 02-11-12 22:05:25 00 0 0 636.1 UTC(NIST) *
 
'Extract the Date from the received string
strDate = Mid$(NetTime, 11, 5) & "-" & Mid$(NetTime, 8, 2)
 
'Extract the time from the received string
strTime = Mid$(NetTime, 17, 8)
 
'Check that extracts are suitable date and time - then convert using CDate
If IsDate(strDate) And IsDate(strTime) Then
   FormatDateTime = CDate(strDate & " " & strTime)
   
   'Extract the downloaded millisec time offset 'this is the transmission line time delay the server calculated and offset the time by
   msAdj = Val(Mid$(NetTime, 33, 3) + Mid$(NetTime, 37, 1))
 
   'Server health is bad, server actually reports it's own condition, do not set if bad
   If Mid$(NetTime, 31, 1) <> "0" Then 'is servers' health bad?, then do not set
      SetIt = 0 'do not set time
      MsgBox "This server reports it's time may not be accurate at the moment," & vbCrLf & _
      "therefore the system time was not set." & vbCrLf & vbCrLf & "Try another server or wait and try again."
   End If
Else
   'Date / time format is wrong
   SetIt = 0 'do not set time
   MsgBox "The data string from this server caused a Time and/or Date formatting error," & vbCrLf & _
   "therefore, the system time was not set." & vbCrLf & vbCrLf & "Try another server, for the moment or try again later."
End If
  
End Function
 
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
 
'I have found that this error only generates if a dial-up system is not connected
'Does not generate if an "Always on" cable modem is deactivated. -strange
MsgBox "An error occurred during an attempt to set your system time," & vbCrLf & "your dial-up connection may not be connected."
 
Winsock1.Close
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
SetIt = 0
 
End Sub


c0Title: Set the dropdown height of a combobox
c1Code:
This sub uses the MoveWindow API to set the height of the dropdown area of a combo box. Use this sub what you like: it does not have to be in the combo's dropdown event.

To use this tip, call the SetComboHeight procuedure with the name of the combo box you wish to edit, and the size in pixels that the dropdown area should be set to. For Example:

Call SetComboHeight(Combo1, 1450)
Declarations

Paste this into the declarations section of a module:

Public Declare Function MoveWindow Lib "user32" _ (ByVal hwnd As Long, ByVal x As Long, ByVal y As _ Long, ByVal nWidth As Long, ByVal nHeight As Long, _ ByVal bRepaint As Long) As Long Procedure

Public Sub SetComboHeight(oComboBox As ComboBox, _ lNewHeight As Long)

Dim oldscalemode As Integer

'This procedure does not work with frames: you 'cannot set the ScaleMode to vbPixels, because 'the frame does not have a ScaleMode Property. 
'To get round this, you could set the parent control 'to be the form while you run this procedure.

If TypeOf oComboBox.Parent Is Frame Then Exit Sub

'Change the ScaleMode on the parent to Pixels.
oldscalemode = oComboBox.Parent.ScaleMode oComboBox.Parent.ScaleMode = vbPixels

'Resize the combo box window.
MoveWindow oComboBox.hwnd, oComboBox.Left, _ oComboBox.Top, oComboBox.Width, lNewHeight, 1

'Replace the old ScaleMode
oComboBox.Parent.ScaleMode = oldscalemode End Sub Tip by John Percival


c0Title: Set the dropdown width of a combobox
c1Code:
This sub sends a message to a combo box, setting the width of the drop down area. It is only a wrapper for the SendMessage API function. Pass it the combo box, and the new width, and it will send the appropriate message.

Declarations

Paste this into the declarations section of a module:

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

Public Const CB_SETDROPPEDWIDTH = &H160
Procedure

Public Sub SetComboWidth(oComboBox As ComboBox, _ lWidth As Long)

'lWidth is in pixels

SendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0

End Sub
Notes

Use this sub where you like: it does not have to be in the combo's dropdown event. Also, this code will not work if you specify a width that is less than the width of the combo box control. i.e. you can only make the drop down list part of the control wider that the control itself.

Tip by John Percival


c0Title: Set Thread Priority
c1Code:
These two subs allow you to easily switch in and out of "Time Critical" priority. When a thread is marked as Time Critical, windows will give all processing time to the thread, which will cause the mouse to stop moving, disc caches not to flush, and so on, so use this with extreme caution. 
        

Code: 


Option Explicit

Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long Declare Function GetCurrentThread Lib "kernel32" () As Long

Public Const THREAD_BASE_PRIORITY_LOWRT = 15 
Public Const THREAD_PRIORITY_NORMAL = 0 
Public Const THREAD_PRIORITY_TIME_CRITICAL = THREAD_BASE_PRIORITY_LOWRT

Public Sub MakePriorityTimeCritical()
	SetThreadPriority GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL
End Sub

Public Sub MakePriorityNormal()
	SetThreadPriority GetCurrentThread, THREAD_PRIORITY_NORMAL
End Sub

     
        
Sample Usage: 
        
MakePriorityTimeCritical
'Do something that can't be interrupted
MakePriorityNormal


c0Title: Setting Style Property of OptionButton and CheckBox at Runtime
c1Code:
"Can't assign to readonly property'"
Don't you just hate it when VB says this? You want to change the style property of a option button or check box, but it is read only at runtime. What can you do? You could load up a second checkbox . . . or you could use the API. In this neat little tip, you can change the style property at run time:

Declarations

Copy this code into the declarations section of a module:

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

Public Const GWL_STYLE = (-16) 
Public Const BS_PUSHLIKE = &H1000& 


Procedure


Public Sub SetGraphicStyle(StyleButton As Control, Flag As Boolean) 
	Dim curstyle As Long 
	Dim newstyle As Long

	If Not TypeOf StyleButton Is OptionButton And Not TypeOf StyleButton Is CheckBox Then Exit Sub

	curstyle = GetWindowLong(StyleButton.hwnd, GWL_STYLE)

	If Flag Then
		curstyle = curstyle Or BS_PUSHLIKE
	Else
		curstyle = curstyle And (Not BS_PUSHLIKE) 
	End If

	newstyle = SetWindowLong(StyleButton.hwnd, GWL_STYLE, curstyle)
	StyleButton.Refresh
End Sub

Tip by John Percival


c0Title: Setting Tab Stops in a ListBox
c1Code:
Want to create a simple list box that shows several fields of data? The columns property of the list box does not do this, but you can use this function to do it.

Public Const LB_SETTABSTOPS As Long = &H192 Public 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 DoTabs(lstListBox As ListBox, TabArray() As Long) 'clear any existing tabs Call SendMessage(lstListBox.hWnd, LB_SETTABSTOPS, 0&, ByVal 0&) 'set list tabstops Call SendMessage(lstListBox.hWnd, LB_SETTABSTOPS, _
CLng(UBound(TabArray)) + 1, TabArray(0)) End Sub

First, set up the columns:

Dim Tabs(2) As Long
Tabs(0) = 0
Tabs(1) = 100
Tabs(2) = 200
DoTabs List1, Tabs
Then, add your items:

List1.AddItem "John" & vbTab & "Percival" & vbTab & "Content Editor"
List1.AddItem "James" & vbTab & "Limm" & vbTab & "Senior Editor"
Tip by John Percival


c0Title: Setting the ToolTipText on a ListBox
c1Code:
If the width of a ListBox control is too small to show the content I have found it practical to set the ToolTipText property to reflect on the item the mouse is hovering over.

Code

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
	Dim YPos As Integer, iOldFontSize As Integer 

	iOldFontSize = Me.Font.Size 
	Me.Font.Size = List1.Font.Size 
	YPos = Y  
	Me.TextHeight("Xyz") + List1.TopIndex 
	Me.Font.Size = iOldFontSize 

	If YPos < List1.ListCount Then 
		List1.ToolTipText = List1.List(YPos) 
	Else 
		List1.ToolTipText = ""
	End If
End Sub

I found this to be more practical than using Windows API to get the horizontal scrollbar.

Tip by Joacim Andersson


c0Title: SHA-256 Hashing
c1Code:
'*******************************************************************************
' MODULE:       CSHA256
' FILENAME:     CSHA256.cls
' AUTHOR:       Phil Fresle
' CREATED:      10-Apr-2001
' COPYRIGHT:    Copyright 2001 Phil Fresle. All Rights Reserved.
'
' DESCRIPTION:
' This class is used to generate a SHA-256 'digest' or 'signature' of a string.
' The SHA-256 algorithm is one of the industry standard methods for generating
' digital signatures. It is generically known as a digest, digital signature,
' one-way encryption, hash or checksum algorithm. A common use for SHA-256 is
' for password encryption as it is one-way in nature, that does not mean that
' your passwords are not free from a dictionary attack. If you are using the
' routine for passwords, you can make it a little more secure by concatenating
' some known random characters to the password before you generate the signature
' and on subsequent tests, so even if a hacker knows you are using SHA-256 for
' your passwords, the random characters will make it harder to dictionary attack.
'
' *** CAUTION ***
' See the comment attached to the SHA256 method below regarding use on systems
' with different character sets.
'
' This is 'free' software with the following restrictions:
'
' You may not redistribute this code as a 'sample' or 'demo'. However, you are free
' to use the source code in your own code, but you may not claim that you created
' the sample code. It is expressly forbidden to sell or profit from this source code
' other than by the knowledge gained or the enhanced value added by your own code.
'
' Use of this software is also done so at your own risk. The code is supplied as
' is without warranty or guarantee of any kind.
'
' Should you wish to commission some derivative work based on this code provided
' here, or any consultancy work, please do not hesitate to contact us.
'
' Web Site:  http://www.frez.co.uk
' E-mail:    sales@frez.co.uk
'
' MODIFICATION HISTORY:
' 10-Apr-2001   Phil Fresle     Initial Version
'*******************************************************************************
Option Explicit
 
Private m_lOnBits(30)   As Long
Private m_l2Power(30)   As Long
Private K(63)           As Long
 
Private Const BITS_TO_A_BYTE  As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD  As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE
 
'*******************************************************************************
' Class_Initialize (SUB)
'*******************************************************************************
Private Sub Class_Initialize()
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - BITS SET FROM RIGHT
    m_lOnBits(0) = 1            ' 00000000000000000000000000000001
    m_lOnBits(1) = 3            ' 00000000000000000000000000000011
    m_lOnBits(2) = 7            ' 00000000000000000000000000000111
    m_lOnBits(3) = 15           ' 00000000000000000000000000001111
    m_lOnBits(4) = 31           ' 00000000000000000000000000011111
    m_lOnBits(5) = 63           ' 00000000000000000000000000111111
    m_lOnBits(6) = 127          ' 00000000000000000000000001111111
    m_lOnBits(7) = 255          ' 00000000000000000000000011111111
    m_lOnBits(8) = 511          ' 00000000000000000000000111111111
    m_lOnBits(9) = 1023         ' 00000000000000000000001111111111
    m_lOnBits(10) = 2047        ' 00000000000000000000011111111111
    m_lOnBits(11) = 4095        ' 00000000000000000000111111111111
    m_lOnBits(12) = 8191        ' 00000000000000000001111111111111
    m_lOnBits(13) = 16383       ' 00000000000000000011111111111111
    m_lOnBits(14) = 32767       ' 00000000000000000111111111111111
    m_lOnBits(15) = 65535       ' 00000000000000001111111111111111
    m_lOnBits(16) = 131071      ' 00000000000000011111111111111111
    m_lOnBits(17) = 262143      ' 00000000000000111111111111111111
    m_lOnBits(18) = 524287      ' 00000000000001111111111111111111
    m_lOnBits(19) = 1048575     ' 00000000000011111111111111111111
    m_lOnBits(20) = 2097151     ' 00000000000111111111111111111111
    m_lOnBits(21) = 4194303     ' 00000000001111111111111111111111
    m_lOnBits(22) = 8388607     ' 00000000011111111111111111111111
    m_lOnBits(23) = 16777215    ' 00000000111111111111111111111111
    m_lOnBits(24) = 33554431    ' 00000001111111111111111111111111
    m_lOnBits(25) = 67108863    ' 00000011111111111111111111111111
    m_lOnBits(26) = 134217727   ' 00000111111111111111111111111111
    m_lOnBits(27) = 268435455   ' 00001111111111111111111111111111
    m_lOnBits(28) = 536870911   ' 00011111111111111111111111111111
    m_lOnBits(29) = 1073741823  ' 00111111111111111111111111111111
    m_lOnBits(30) = 2147483647  ' 01111111111111111111111111111111
    
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - POWERS OF 2
    m_l2Power(0) = 1            ' 00000000000000000000000000000001
    m_l2Power(1) = 2            ' 00000000000000000000000000000010
    m_l2Power(2) = 4            ' 00000000000000000000000000000100
    m_l2Power(3) = 8            ' 00000000000000000000000000001000
    m_l2Power(4) = 16           ' 00000000000000000000000000010000
    m_l2Power(5) = 32           ' 00000000000000000000000000100000
    m_l2Power(6) = 64           ' 00000000000000000000000001000000
    m_l2Power(7) = 128          ' 00000000000000000000000010000000
    m_l2Power(8) = 256          ' 00000000000000000000000100000000
    m_l2Power(9) = 512          ' 00000000000000000000001000000000
    m_l2Power(10) = 1024        ' 00000000000000000000010000000000
    m_l2Power(11) = 2048        ' 00000000000000000000100000000000
    m_l2Power(12) = 4096        ' 00000000000000000001000000000000
    m_l2Power(13) = 8192        ' 00000000000000000010000000000000
    m_l2Power(14) = 16384       ' 00000000000000000100000000000000
    m_l2Power(15) = 32768       ' 00000000000000001000000000000000
    m_l2Power(16) = 65536       ' 00000000000000010000000000000000
    m_l2Power(17) = 131072      ' 00000000000000100000000000000000
    m_l2Power(18) = 262144      ' 00000000000001000000000000000000
    m_l2Power(19) = 524288      ' 00000000000010000000000000000000
    m_l2Power(20) = 1048576     ' 00000000000100000000000000000000
    m_l2Power(21) = 2097152     ' 00000000001000000000000000000000
    m_l2Power(22) = 4194304     ' 00000000010000000000000000000000
    m_l2Power(23) = 8388608     ' 00000000100000000000000000000000
    m_l2Power(24) = 16777216    ' 00000001000000000000000000000000
    m_l2Power(25) = 33554432    ' 00000010000000000000000000000000
    m_l2Power(26) = 67108864    ' 00000100000000000000000000000000
    m_l2Power(27) = 134217728   ' 00001000000000000000000000000000
    m_l2Power(28) = 268435456   ' 00010000000000000000000000000000
    m_l2Power(29) = 536870912   ' 00100000000000000000000000000000
    m_l2Power(30) = 1073741824  ' 01000000000000000000000000000000
    
    ' Just put together the K array once
    K(0) = &H428A2F98
    K(1) = &H71374491
    K(2) = &HB5C0FBCF
    K(3) = &HE9B5DBA5
    K(4) = &H3956C25B
    K(5) = &H59F111F1
    K(6) = &H923F82A4
    K(7) = &HAB1C5ED5
    K(8) = &HD807AA98
    K(9) = &H12835B01
    K(10) = &H243185BE
    K(11) = &H550C7DC3
    K(12) = &H72BE5D74
    K(13) = &H80DEB1FE
    K(14) = &H9BDC06A7
    K(15) = &HC19BF174
    K(16) = &HE49B69C1
    K(17) = &HEFBE4786
    K(18) = &HFC19DC6
    K(19) = &H240CA1CC
    K(20) = &H2DE92C6F
    K(21) = &H4A7484AA
    K(22) = &H5CB0A9DC
    K(23) = &H76F988DA
    K(24) = &H983E5152
    K(25) = &HA831C66D
    K(26) = &HB00327C8
    K(27) = &HBF597FC7
    K(28) = &HC6E00BF3
    K(29) = &HD5A79147
    K(30) = &H6CA6351
    K(31) = &H14292967
    K(32) = &H27B70A85
    K(33) = &H2E1B2138
    K(34) = &H4D2C6DFC
    K(35) = &H53380D13
    K(36) = &H650A7354
    K(37) = &H766A0ABB
    K(38) = &H81C2C92E
    K(39) = &H92722C85
    K(40) = &HA2BFE8A1
    K(41) = &HA81A664B
    K(42) = &HC24B8B70
    K(43) = &HC76C51A3
    K(44) = &HD192E819
    K(45) = &HD6990624
    K(46) = &HF40E3585
    K(47) = &H106AA070
    K(48) = &H19A4C116
    K(49) = &H1E376C08
    K(50) = &H2748774C
    K(51) = &H34B0BCB5
    K(52) = &H391C0CB3
    K(53) = &H4ED8AA4A
    K(54) = &H5B9CCA4F
    K(55) = &H682E6FF3
    K(56) = &H748F82EE
    K(57) = &H78A5636F
    K(58) = &H84C87814
    K(59) = &H8CC70208
    K(60) = &H90BEFFFA
    K(61) = &HA4506CEB
    K(62) = &HBEF9A3F7
    K(63) = &HC67178F2
End Sub
 
'*******************************************************************************
' LShift (FUNCTION)
'
' PARAMETERS:
' (In) - lValue     - Long    - The value to be shifted
' (In) - iShiftBits - Integer - The number of bits to shift the value by
'
' RETURN VALUE:
' Long - The shifted long integer
'
' DESCRIPTION:
' A left shift takes all the set binary bits and moves them left, in-filling
' with zeros in the vacated bits on the right. This function is equivalent to
' the << operator in Java and C++
'*******************************************************************************
Private Function LShift(ByVal lValue As Long, _
                        ByVal iShiftBits As Integer) As Long
    ' NOTE: If you can guarantee that the Shift parameter will be in the
    ' range 1 to 30 you can safely strip of this first nested if structure for
    ' speed.
    '
    ' A shift of zero is no shift at all.
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
        
    ' A shift of 31 will result in the right most bit becoming the left most
    ' bit and all other bits being cleared
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = &H80000000
        Else
            LShift = 0
        End If
        Exit Function
        
    ' A shift of less than zero or more than 31 is undefined
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If
    
    ' If the left most bit that remains will end up in the negative bit
    ' position (&H80000000) we would end up with an overflow if we took the
    ' standard route. We need to strip the left most bit and add it back
    ' afterwards.
    If (lValue And m_l2Power(31 - iShiftBits)) Then
    
        ' (Value And OnBits(31 - (Shift + 1))) chops off the left most bits that
        ' we are shifting into, but also the left most bit we still want as this
        ' is going to end up in the negative bit marker position (&H80000000).
        ' After the multiplication/shift we Or the result with &H80000000 to
        ' turn the negative bit on.
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
            m_l2Power(iShiftBits)) Or &H80000000
    
    Else
    
        ' (Value And OnBits(31-Shift)) chops off the left most bits that we are
        ' shifting into so we do not get an overflow error when we do the
        ' multiplication/shift
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
            m_l2Power(iShiftBits))
        
    End If
End Function
 
'*******************************************************************************
' RShift (FUNCTION)
'
' PARAMETERS:
' (In) - lValue     - Long    - The value to be shifted
' (In) - iShiftBits - Integer - The number of bits to shift the value by
'
' RETURN VALUE:
' Long - The shifted long integer
'
' DESCRIPTION:
' The right shift of an unsigned long integer involves shifting all the set bits
' to the right and in-filling on the left with zeros. This function is
' equivalent to the >>> operator in Java or the >> operator in C++ when used on
' an unsigned long.
'*******************************************************************************
Private Function RShift(ByVal lValue As Long, _
                        ByVal iShiftBits As Integer) As Long
    
    ' NOTE: If you can guarantee that the Shift parameter will be in the
    ' range 1 to 30 you can safely strip of this first nested if structure for
    ' speed.
    '
    ' A shift of zero is no shift at all
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
        
    ' A shift of 31 will clear all bits and move the left most bit to the right
    ' most bit position
    ElseIf iShiftBits = 31 Then
        If lValue And &H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
        
    ' A shift of less than zero or more than 31 is undefined
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If
    
    ' We do not care about the top most bit or the final bit, the top most bit
    ' will be taken into account in the next stage, the final bit (whether it
    ' is an odd number or not) is being shifted into, so we do not give a jot
    ' about it
    RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
    
    ' If the top most bit (&H80000000) was set we need to do things differently
    ' as in a normal VB signed long integer the top most bit is used to indicate
    ' the sign of the number, when it is set it is a negative number, so just
    ' deviding by a factor of 2 as above would not work.
    ' NOTE: (lValue And  &H80000000) is equivalent to (lValue < 0), you could
    ' get a very marginal speed improvement by changing the test to (lValue < 0)
    If (lValue And &H80000000) Then
        ' We take the value computed so far, and then add the left most negative
        ' bit after it has been shifted to the right the appropriate number of
        ' places
        RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
    End If
End Function
 
'*******************************************************************************
' AddUnsigned (FUNCTION)
'
' PARAMETERS:
' (In) - lX - Long - First value
' (In) - lY - Long - Second value
'
' RETURN VALUE:
' Long - Result
'
' DESCRIPTION:
' Adds two potentially large unsigned numbers without overflowing
'*******************************************************************************
Private Function AddUnsigned(ByVal lX As Long, _
                             ByVal lY As Long) As Long
    Dim lX4     As Long
    Dim lY4     As Long
    Dim lX8     As Long
    Dim lY8     As Long
    Dim lResult As Long
 
    lX8 = lX And &H80000000
    lY8 = lY And &H80000000
    lX4 = lX And &H40000000
    lY4 = lY And &H40000000
 
    lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
 
    If lX4 And lY4 Then
        lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
    ElseIf lX4 Or lY4 Then
        If lResult And &H40000000 Then
            lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
        Else
            lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
        End If
    Else
        lResult = lResult Xor lX8 Xor lY8
    End If
 
    AddUnsigned = lResult
End Function
 
'*******************************************************************************
' Ch (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function
'*******************************************************************************
Private Function Ch(ByVal x As Long, _
                    ByVal y As Long, _
                    ByVal z As Long) As Long
    Ch = ((x And y) Xor ((Not x) And z))
End Function
 
'*******************************************************************************
' Maj (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function
'*******************************************************************************
Private Function Maj(ByVal x As Long, _
                     ByVal y As Long, _
                     ByVal z As Long) As Long
    Maj = ((x And y) Xor (x And z) Xor (y And z))
End Function
 
'*******************************************************************************
' S (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function (rotate right)
'*******************************************************************************
Private Function S(ByVal x As Long, _
                   ByVal n As Long) As Long
    S = (RShift(x, (n And m_lOnBits(4))) Or LShift(x, (32 - (n And m_lOnBits(4)))))
End Function
 
'*******************************************************************************
' R (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function (just a right shift)
'*******************************************************************************
Private Function R(ByVal x As Long, _
                   ByVal n As Long) As Long
    R = RShift(x, CInt(n And m_lOnBits(4)))
End Function
 
'*******************************************************************************
' Sigma0 (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function
'*******************************************************************************
Private Function Sigma0(ByVal x As Long) As Long
    Sigma0 = (S(x, 2) Xor S(x, 13) Xor S(x, 22))
End Function
 
'*******************************************************************************
' Sigma1 (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function
'*******************************************************************************
Private Function Sigma1(ByVal x As Long) As Long
    Sigma1 = (S(x, 6) Xor S(x, 11) Xor S(x, 25))
End Function
 
'*******************************************************************************
' Gamma0 (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function
'*******************************************************************************
Private Function Gamma0(ByVal x As Long) As Long
    Gamma0 = (S(x, 7) Xor S(x, 18) Xor R(x, 3))
End Function
 
'*******************************************************************************
' Gamma1 (FUNCTION)
'
' DESCRIPTION:
' SHA-256 function
'*******************************************************************************
Private Function Gamma1(ByVal x As Long) As Long
    Gamma1 = (S(x, 17) Xor S(x, 19) Xor R(x, 10))
End Function
 
'*******************************************************************************
' ConvertToWordArray (FUNCTION)
'
' PARAMETERS:
' (In/Out) - sMessage - String - String message
'
' RETURN VALUE:
' Long() - Converted message as long array
'
' DESCRIPTION:
' Takes the string message and puts it in a long array with padding according to
' the SHA-256 rules (similar to MD5 routine).
'*******************************************************************************
Private Function ConvertToWordArray(sMessage As String) As Long()
    Dim lMessageLength  As Long
    Dim lNumberOfWords  As Long
    Dim lWordArray()    As Long
    Dim lBytePosition   As Long
    Dim lByteCount      As Long
    Dim lWordCount      As Long
    Dim lByte           As Long
    
    Const MODULUS_BITS      As Long = 512
    Const CONGRUENT_BITS    As Long = 448
    
    lMessageLength = Len(sMessage)
    
    ' Get padded number of words. Message needs to be congruent to 448 bits,
    ' modulo 512 bits. If it is exactly congruent to 448 bits, modulo 512 bits
    ' it must still have another 512 bits added. 512 bits = 64 bytes
    ' (or 16 * 4 byte words), 448 bits = 56 bytes. This means lNumberOfWords must
    ' be a multiple of 16 (i.e. 16 * 4 (bytes) * 8 (bits))
    lNumberOfWords = (((lMessageLength + _
        ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
        (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
        (MODULUS_BITS \ BITS_TO_A_WORD)
    ReDim lWordArray(lNumberOfWords - 1)
    
    ' Combine each block of 4 bytes (ascii code of character) into one long
    ' value and store in the message. The high-order (most significant) bit of
    ' each byte is listed first. However, unlike MD5 we put the high-order
    ' (most significant) byte first in each word.
    lBytePosition = 0
    lByteCount = 0
    Do Until lByteCount >= lMessageLength
        ' Each word is 4 bytes
        lWordCount = lByteCount \ BYTES_TO_A_WORD
        
        lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
        
        ' NOTE: This is where we are using just the first byte of each unicode
        ' character, you may want to make the change here, or to the SHA256 method
        ' so it accepts a byte array.
        lByte = AscB(Mid(sMessage, lByteCount + 1, 1))
        
        lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lByte, lBytePosition)
        lByteCount = lByteCount + 1
    Loop
 
    ' Terminate according to SHA-256 rules with a 1 bit, zeros and the length in
    ' bits stored in the last two words
    lWordCount = lByteCount \ BYTES_TO_A_WORD
    lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
 
    ' Add a terminating 1 bit, all the rest of the bits to the end of the
    ' word array will default to zero
    lWordArray(lWordCount) = lWordArray(lWordCount) Or _
        LShift(&H80, lBytePosition)
 
    ' We put the length of the message in bits into the last two words, to get
    ' the length in bits we need to multiply by 8 (or left shift 3). This left
    ' shifted value is put in the last word. Any bits shifted off the left edge
    ' need to be put in the penultimate word, we can work out which bits by shifting
    ' right the length by 29 bits.
    lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
    lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)
    
    ConvertToWordArray = lWordArray
End Function
 
'*******************************************************************************
' SHA256 (FUNCTION)
'
' PARAMETERS:
' (In/Out) - sMessage - String - Message to digest
'
' RETURN VALUE:
' String - The digest
'
' DESCRIPTION:
' Takes a string and uses the SHA-256 digest to produce a signature for it.
'
' NOTE: Due to the way in which the string is processed the routine assumes a
' single byte character set. VB passes unicode (2-byte) character strings, the
' ConvertToWordArray function uses on the first byte for each character. This
' has been done this way for ease of use, to make the routine truely portable
' you could accept a byte array instead, it would then be up to the calling
' routine to make sure that the byte array is generated from their string in
' a manner consistent with the string type.
'*******************************************************************************
Public Function SHA256(sMessage As String) As String
    Dim HASH(7) As Long
    Dim M()     As Long
    Dim W(63)   As Long
    Dim a       As Long
    Dim b       As Long
    Dim c       As Long
    Dim d       As Long
    Dim e       As Long
    Dim f       As Long
    Dim g       As Long
    Dim h       As Long
    Dim i       As Long
    Dim j       As Long
    Dim T1      As Long
    Dim T2      As Long
    
    ' Initial hash values
    HASH(0) = &H6A09E667
    HASH(1) = &HBB67AE85
    HASH(2) = &H3C6EF372
    HASH(3) = &HA54FF53A
    HASH(4) = &H510E527F
    HASH(5) = &H9B05688C
    HASH(6) = &H1F83D9AB
    HASH(7) = &H5BE0CD19
    
    ' Preprocessing. Append padding bits and length and convert to words
    M = ConvertToWordArray(sMessage)
    
    ' Main loop
    For i = 0 To UBound(M) Step 16
        a = HASH(0)
        b = HASH(1)
        c = HASH(2)
        d = HASH(3)
        e = HASH(4)
        f = HASH(5)
        g = HASH(6)
        h = HASH(7)
        
        For j = 0 To 63
            If j < 16 Then
                W(j) = M(j + i)
            Else
                W(j) = AddUnsigned(AddUnsigned(AddUnsigned(Gamma1(W(j - 2)), _
                    W(j - 7)), Gamma0(W(j - 15))), W(j - 16))
            End If
                
            T1 = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(h, Sigma1(e)), _
                Ch(e, f, g)), K(j)), W(j))
            T2 = AddUnsigned(Sigma0(a), Maj(a, b, c))
            
            h = g
            g = f
            f = e
            e = AddUnsigned(d, T1)
            d = c
            c = b
            b = a
            a = AddUnsigned(T1, T2)
        Next
        
        HASH(0) = AddUnsigned(a, HASH(0))
        HASH(1) = AddUnsigned(b, HASH(1))
        HASH(2) = AddUnsigned(c, HASH(2))
        HASH(3) = AddUnsigned(d, HASH(3))
        HASH(4) = AddUnsigned(e, HASH(4))
        HASH(5) = AddUnsigned(f, HASH(5))
        HASH(6) = AddUnsigned(g, HASH(6))
        HASH(7) = AddUnsigned(h, HASH(7))
    Next
    
    ' Output the 256 bit digest
    SHA256 = LCase(Right("00000000" & Hex(HASH(0)), 8) & _
        Right("00000000" & Hex(HASH(1)), 8) & _
        Right("00000000" & Hex(HASH(2)), 8) & _
        Right("00000000" & Hex(HASH(3)), 8) & _
        Right("00000000" & Hex(HASH(4)), 8) & _
        Right("00000000" & Hex(HASH(5)), 8) & _
        Right("00000000" & Hex(HASH(6)), 8) & _
        Right("00000000" & Hex(HASH(7)), 8))
End Function


c0Title: Shaker Sort (Non-Recursive)
c1Code:
The Comb Sort improved upon the Bubble Sort and the Shell Sort improved upon the Insertion Sort. What can we do to the Selection Sort? The Shaker Sort is a very very simple variation. As we move through the array selecting the largest value, we also select the smallest value, and then move that into position at the start. Simple, eh?

Example:

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

                        [6,7,9,3,2,5]
Which element goes here? ^         ^ Which element goes here?

                        [2,7,5,3,6,9]
  Which element goes here? ^     ^ Which element goes here?

                        [2,3,5,6,7,9]
    Which element goes here? ^ ^ Which element goes here?

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


Pretty simple, yes? Here's the code:


VB: 
--------------------------------------------------------------------------------
Public Sub ShakerSort(ByRef lngArray() As Long)
    Dim iLower As Long
    Dim iUpper As Long
    Dim iInner As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long
    Dim iMax As Long
    Dim iMin As Long
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    
    iLower = iLBound - 1
    iUpper = iUBound + 1
    
    Do While iLower < iUpper
                
        iLower = iLower + 1
        iUpper = iUpper - 1
                
        iMax = iLower
        iMin = iLower
        
        'Find the largest and smallest values in the subarray
        For iInner = iLower To iUpper
            If lngArray(iInner) > lngArray(iMax) Then
                iMax = iInner
            ElseIf lngArray(iInner) < lngArray(iMin) Then
                iMin = iInner
            End If
        Next iInner
        
        'Swap the largest with last slot of the subarray
        iTemp = lngArray(iMax)
        lngArray(iMax) = lngArray(iUpper)
        lngArray(iUpper) = iTemp
        
        'Swap the smallest with the first slot of the subarray
        iTemp = lngArray(iMin)
        lngArray(iMin) = lngArray(iLower)
        lngArray(iLower) = iTemp
        
    Loop
End Sub

--------------------------------------------------------------------------------


c0Title: Share Variables Between Multiple Apps
c1Code:
Sometimes it�s necessary to share variables between multiple instances of an application. For example, you might want to share a database connection. Here�s how: Create an ActiveX EXE with an exposed MultiUse class named Class1. An ActiveX DLL won�t work because it�s running in-process within each client. Include a module in the project and declare the required variable you want to share in this module as a public variable.

The code in an ActiveX DLL looks like this:

 
'**** Module code *****
Global gCon As Database
Global glngNrOfObjects As Long
 
'**** Code in Class ****
Public Property Set DBConn(Con As Database)
     Set gCon = Con
End Property
Public Property Get DBConn() As Database
     Set DBConn = gCon
End Property
 
Private Sub Class_Initialize()
     ' this variable keeps count of objects created
     glngNrOfObjects = glngNrOfObjects + 1
End Sub
Private Sub Class_Terminate()
     ' decrease object count
     glngNrOfObjects = glngNrOfObjects - 1
 
     ' if no objects exist, close the connection
     If glngNrOfObjects = 0 Then
          If Not gCon Is Nothing Then
               gCon.Close
               Set gCon = Nothing
          End If
     End If
End Sub
 
 
Now reference this ActiveX EXE in your project and use it. Here�s how I did it:
 
'** Code in application using the ActiveX EXE **
 
Dim clsDBConn As Class1
 
Private Sub Form_Load()
     Set clsDBConn = New Class1
     ' set the connection, when first object is 
     ' created
     If clsDBConn.DBConn Is Nothing Then
          Set clsDBConn.DBConn = _
               Workspaces(0).OpenDatabase( _
               "\temp\db1.mdb")
          End If
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
     Set clsDBConn = Nothing
End Sub
 
You don�t need to include the code to count the object instances and close the database if your variable is a simple one�that is, if it�s not an object reference. Also, in that case, change the Property Set to Property Let.

Both the projects have a reference to DAO because they�re using the database object.

�Ravindra Okade, Plainsboro, New Jersey


c0Title: Shell Sort (Unstable, Non-Recursive)
c1Code:
Suppose we apply this variable-spacing idea to other algorithms. For example, the Insertion Sort. Since this sort is like a special case of the bubble sort (each value is selected then bubbled into place), we can apply the same procedure. The result is the Shell Sort.

Example:

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

Shell with spacing of 4
[6,7,9,3,2,5]
         ^ Where does this fit in [6]?

Shell with spacing of 3
[2,7,9,3,6,5]
       ^ Where does this fit in [2]?     

Shell with spacing of 2
[2,7,9,3,6,5]
     ^ Where does this fit in [2]?
[2,7,9,3,6,5]
         ^ Where does this fit in [2,9]?

Shell with spacing of 1
[2,7,6,3,9,5]
   ^ Where does this fit in [2]?
[2,7,6,3,9,5]
     ^ Where does this fit in [2,7]?
[2,6,7,3,9,5]
       ^ Where does this fit in [2,6,7]?
[2,3,6,7,9,5]
         ^ Where does this fit in [2,3,6,7]?
[2,3,6,7,9,5]
           ^ Where does this fit in [2,3,6,7,9]?

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


Of course with the actual sort we dont use so many spacings, and the amount the array changes in each pass is more dramatic. Here is the code:


VB: 
--------------------------------------------------------------------------------
Public Sub ShellSort(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
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    
    'Calculate initial sort spacing
    iArrSize = (iUBound - iLBound) + 1
    iSpacing = 1
    
    If iArrSize > 13 Then
        Do While iSpacing < iArrSize
            iSpacing = (3 * iSpacing) + 1
        Loop
        
        iSpacing = iSpacing \ 9
    End If
        
    'Start sorting
    Do While iSpacing
                    
        For iOuter = iLBound + iSpacing To iUBound
        
            'Get the value to be inserted
            iTemp = lngArray(iOuter)
        
            'Move along the already sorted values shifting along
            For iInner = iOuter - iSpacing To iLBound Step -iSpacing
                'No more shifting needed, we found the right spot!
                If lngArray(iInner) <= iTemp Then Exit For
        
                lngArray(iInner + iSpacing) = lngArray(iInner)
            Next iInner
        
            'Insert value in the slot
            lngArray(iInner + iSpacing) = iTemp
        Next iOuter
        
        'Reduce the sort spacing
        iSpacing = iSpacing \ 3
    Loop
        
End Sub


c0Title: ShellSort - For Variants (Unstable)
c1Code:
' ShellSort an array of any type
'
' ShellSort behaves pretty well with arrays of any size, even
' if the array is already "nearly-sorted", even though in
' particular cases BubbleSort or QuickSort can be more efficient.
'
' LASTEL is the index of the last item to be sorted, and is
' useful if the array is only partially filled. This updated version accounts
' for arrays whose LBound is 0 and 1 (or whatever)
'
' Works with any kind of array, except UDTs and fixed-length
' strings, and including objects if your are sorting on their
' default property. String are sorted in case-sensitive mode.
'
' You can write faster procedures if you modify the first two lines
' to account for a specific data type, eg.
' Sub ShellSortS(arr() As Single, Optional lastEl As Variant,
'  Optional descending As Boolean)
'   Dim value As Single

Sub ShellSort(arr As Variant, Optional lastEl As Variant, _
    Optional descending As Boolean)
    Dim value As Variant
    Dim index As Long, index2 As Long
    Dim firstEl As Long
    Dim distance As Long
    Dim numEls As Long

    ' account for optional arguments
    If IsMissing(lastEl) Then lastEl = UBound(arr)
    firstEl = LBound(arr)
    
    numEls = lastEl - firstEl + 1
    ' find the best value for distance
    Do
        distance = distance * 3 + 1
    Loop Until distance > numEls

    Do
        distance = distance \ 3
        For index = distance + firstEl To lastEl
            value = arr(index)
            index2 = index
            Do While (arr(index2 - distance) > value) Xor descending
                arr(index2) = arr(index2 - distance)
                index2 = index2 - distance
                If index2 - distance < firstEl Then Exit Do
            Loop
            arr(index2) = value
        Next
    Loop Until distance = 1
End Sub

Francesco Balena


c0Title: Shorten Long Path 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: Show Non-Modal Forms From ActiveX DLLs
c1Code:
If your VB ActiveX DLL includes a non-modal form, you can�t summon it from a VC++ client if you call the native VB Show method of the form from within the DLL:

Public Sub Show()
	' Exposed method uses .Show
	Dim frm As New frmMyForm
	' Show can generate Error 406
	frm.Show
End Sub

Instead, use this technique in your exposed interface:

Private Declare Function ShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long 

Private Const SW_SHOW = 5 

Public Sub Show() 
	' Exposed method uses API call 
	Dim frm As New frmMyForm 
	Call ShowWindow(frm.hWnd, SW_SHOW) 
End Sub

�Alexander Meissel, Colorado Springs, Colorado


c0Title: Show the Standard File Properties Dialog
c1Code:
If your program has an Explorer shell-style interface, you probably want to supply the standard File � Properties dialog. Do this by using the ShellExecuteEx API function:

Private Type SHELLEXECUTEINFO
     cbSize As Long
     fMask As Long
     hWnd As Long
     lpVerb As String
     lpFile As String
     lpParameters As String
     lpDirectory As String
     nShow As Long
     hInstApp As Long
     lpIDList As Long
     lpClass As String
     hkeyClass As Long
     dwHotKey As Long
     hIcon As Long
     hProcess As Long
End Type
 
Private Declare Function ShellExecuteEx Lib "shell32" (lpSEIAs SHELLEXECUTEINFO) As Long

Private Const SEE_MASK_INVOKEIDLIST = &HC
 
Private Sub Form_Click()
     Call ShowFileProperties("c:\windows\system\msvbvm50.dll")
End Sub
 
Private Sub ShowFileProperties(ByVal aFile As String)
     Dim sei As SHELLEXECUTEINFO
     sei.hWnd = Me.hWnd
     sei.lpVerb = "properties"
     sei.lpFile = aFile
     sei.fMask = SEE_MASK_INVOKEIDLIST
     sei.cbSize = Len(sei)
     ShellExecuteEx sei
End Sub

�Matt Hart, Tulsa, Oklahoma


c0Title: Show Window w/o Activating it
c1Code:
Declaring the API
To acomplish this task we need to declare the ShowWindow API. This API when called will show our window, and the activation depends on the second parameter, which we will use SW_SHOWNOACTIVATE. 

Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Const SW_SHOWNOACTIVATE = 4



Example Usage
To use this API just call it like shown below. You can use any form you like as long as you can access its hWND property.

Private Sub Form_Load()
    ShowWindow Me.hWnd, SW_SHOWNOACTIVATE End Sub




c0Title: Showing A (+) Sign On TreeView Parent Nodes
c1Code:
Have you ever wondered how on earth to always show a plus (+) sign on a parent node in a TreeView control whenever it has one or more child nodes? The answer is simple, if obscure. Set the LineStyle property = 1 (tvwRootLines)

That's all there is to it.

Tip Submitted By: J. Kevin Meadows


c0Title: ShuttleMergeSort (Stable, Non-Recursive)
c1Code:
ShuttleMergeSort - An improved MergeSort
' 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: Simple Dial/Hangup/Status for DialUp Networking
c1Code:
Option Explicit

Const Internet_Autodial_Force_Unattended As Long = 2

Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long 
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long 
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByVal lpdwFlags As Long, ByVal dwReserved As Long) As Long

Private Sub Dial()
    InternetAutodial(Internet_Autodial_Force_Unattended, 0&) 
End Sub

Private Sub HangUp()
    InternetAutodialHangup(0&)
End Sub

Private Function IsConnected() As Boolean
    Dim ConnectType As Long
    Dim Result As Long

    IsConnected = InternetGetConnectedState(ConnectType, 0&) 
End Sub




c0Title: Simple Mail Sender
c2File: sendmail.zip
c1Code:
The information below will help you to create application, which offers the ability to send simple e-mail messages. "Simple" means that this message can be send to only one recipient and can contain only the plain text.

Create new project (Standard Exe). The Form1 will be created by default.

Change the Name property of the form to "frmSendMail" and Caption to "Simple Mail sender". Change the BorderStyle property value  to "1 - Fixed Single" as well.

Add MS Winsock Control to the project and place one instance of the control to the form. Add another controls and place them on the form as shown below:




Change the Name property of New Message, Send Message ? Close buttons to cmdNew, cmdSend ? cmdClose accordingly.

Now open the code editor for frmSendMail and add this code:

Private Sub cmdNew_Click()

    txtRecipient = ""
    txtSubject = ""
    txtMessage = ""
    
End Sub

Private Sub cmdClose_Click()

    Unload Me
    
End Sub 

Well, all is set and we are ready to go on to the main topic - writing the code for sending a message. 

If you have already read the introduction to SMTP protocol you know about some commands that you have to use to send e-mail message. This commands must be sent in strict predefine sequence. In order to track the sequence we'll use special variable m_State, which stores the current state of SMTP session. 

You might think of SMTP session state as of state of waiting for server's reply to one of client's command. Therefore, the quantity of such states is equal to the quantity of SMTP commands. It is useless way to describe the value of SMTP session state with one of VB data types. That is why I suggest creating special data type "SMTP_State" by means of enumeration of all the required constants with VB keyword - Enum: 

Private Enum SMTP_State
    MAIL_CONNECT
    MAIL_HELO
    MAIL_FROM
    MAIL_RCPTTO
    MAIL_DATA
    MAIL_DOT
    MAIL_QUIT
End Enum

As you see the quantity of Enum's members is bigger then the quantity of required command. The reason you'll get to know soon. And now add this enumeration into code of frmSendMail. Define the variable m_State as well.

Private m_State As SMTP_State

It's not difficult to guess that main events will happen after the pressing of Send Message button. We're going to add such a code into Click event.

Private Sub cmdSend_Click()

    Winsock1.Connect Trim$(txtHost), 25
    m_State = MAIL_CONNECT
    
End Sub

It's just two strings of code. The first one establishes connection to port number 25 (default SMTP port). And the second one makes assigning to m_State variable. "Is that all ?" you may ask. Yes. Currently it's all. We begin the communication between server and our application while establishing the link. We're going to manage this process by means of Winsock1_DataArrival events. This event will let us know about the server's response. According with the response we'll send the required command to the SMTP server. The skeleton of this algorithm looks like this:

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

    Dim strServerResponse   As String 
    Dim strResponseCode     As String 
    
    strResponseCode = Left(strServerResponse, 3)
    
    If strData = "250" Or _
       strData = "220" Or _
       strData = "354" Then 
       
        Select Case m_State 
            Case MAIL_CONNECT
            Case MAIL_HELO
            Case MAIL_FROM
            Case MAIL_RCPTTO
            Case MAIL_DATA
            Case MAIL_DOT
            Case MAIL_QUIT 
        End Select 
       
    Else 
        MsgBox "SMTP Error: " & strServerResponse, _
                vbInformation, "SMTP Error"
    End If 
    
End Sub 

The first executing string of code figures out the server's response. The next IF/ELSE/ENDIF verifies whether the response is equal to one of the predefine values. This three code of response is in use by SMTP server while communication with the client. All these responses indicate the success of executing the command the server has received. Any other response indicates the error, which will be displayed via standard dialog MessageBox. This dialog appears any time we receive the response, which differs from those three appeared in IF/ELSE/ENDIF block. In case of the one of the success response the verified expression will be equal to True and the execution skips to Select Case block. Here is the complete Winsock1_DataArrival routine with the all required comments.

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

    Dim strServerResponse   As String 
    Dim strResponseCode     As String 
    Dim strDataToSend       As String 
    ' 
    'Retrieve data from winsock buffer 
    ' 
    Winsock1.GetData strServerResponse
    ' 
    Debug.Print strServerResponse
    ' 
    'Get server response code (first three symbols) 
    ' 
    strResponseCode = Left(strServerResponse, 3)
    ' 
    'Only these three codes tell us that previous 
    'command accepted successfully and we can go on 
    ' 
    If strResponseCode = "250" Or _
       strResponseCode = "220" Or _
       strResponseCode = "354" Then 
       
        Select Case m_State
            Case MAIL_CONNECT
                'Change current state of the session 
                m_State = MAIL_HELO
                ' 
                'Remove blank spaces 
                strDataToSend = Trim$(txtSender)
                ' 
                'Retrieve mailbox name from e-mail address 
                strDataToSend = Left$(strDataToSend, _
                                InStr(1, strDataToSend, _
                                "@") - 1)
                'Send HELO command to the server 
                Winsock1.SendData "HELO " & _
                                  strDataToSend & vbCrLf
                ' 
                Debug.Print "HELO " & strDataToSend
                ' 
            Case MAIL_HELO
                ' 
                'Change current state of the session 
                m_State = MAIL_FROM
                ' 
                'Send MAIL FROM command to the server 
                Winsock1.SendData "MAIL FROM:" & _
                                  Trim$(txtSender) & vbCrLf
                ' 
                Debug.Print "MAIL FROM:" & Trim$(txtSender)
                ' 
            Case MAIL_FROM
                ' 
                'Change current state of the session 
                m_State = MAIL_RCPTTO
                ' 
                'Send RCPT TO command to the server 
                Winsock1.SendData "RCPT TO:" & _
                                  Trim$(txtRecipient) & vbCrLf
                ' 
                Debug.Print "RCPT TO:" & Trim$(txtRecipient)
                ' 
            Case MAIL_RCPTTO
                ' 
                'Change current state of the session 
                m_State = MAIL_DATA
                ' 
                'Send DATA command to the server 
                Winsock1.SendData "DATA" & vbCrLf
                ' 
                Debug.Print "DATA"
                ' 
            Case MAIL_DATA
                ' 
                'Change current state of the session 
                m_State = MAIL_DOT
                ' 
                'So now we are sending a message body 
                'Each line of text must be completed with 
                'linefeed symbol (Chr$(10) or vbLf) 
                'not with vbCrLf 
                ' 
                'Send Subject line 
                Winsock1.SendData "Subject:" & txtSubject & vbLf
                ' 
                Debug.Print "Subject:" & txtSubject
                ' 
                Dim varLines    As Variant 
                Dim varLine     As Variant 
                ' 
                'Parse message to get lines (for VB6 only) 
                varLines = Split(txtMessage, vbCrLf)
                ' 
                'Send each line of the message 
                For Each varLine In varLines
                    Winsock1.SendData CStr(varLine) & vbLf
                    ' 
                    Debug.Print CStr(varLine)
                Next 
                ' 
                'Send a dot symbol to inform server 
                'that sending of message completed 
                Winsock1.SendData "." & vbCrLf
                ' 
                Debug.Print "."
                ' 
            Case MAIL_DOT
                'Change current state of the session 
                m_State = MAIL_QUIT
                ' 
                'Send QUIT command to the server 
                Winsock1.SendData "QUIT" & vbCrLf
                ' 
                Debug.Print "QUIT"
            Case MAIL_QUIT
                ' 
                'Close connection 
                Winsock1.Close 
                ' 
        End Select
       
    Else 
        ' 
        'If we are here server replied with 
        'unacceptable response code therefore we need 
        'close connection and inform user about problem 
        ' 
        Winsock1.Close 
        ' 
        MsgBox "SMTP Error: " & strServerResponse, _
                vbInformation, "SMTP Error"
        ' 
    End If 
    
End Sub 

Please pay attention to the strings of the message we're going to send. They don't end with the vbCrLf. We're using vbLf instead. This rule applies to the header of the message (Subject) as well. Surely there are lots of another headers, which differ from Subject. But we're not going to discuss it here. Just remember that each one sends to the server ended by vbLf. Avoiding doing that results in server's misunderstanding the commands you are sending. The last thing you should make is to create the routine, which deals with the Windows Sockets errors.

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

    MsgBox "Winsock Error number " & Number & vbCrLf & Description, vbExclamation, "Winsock Error"

End Sub 


c0Title: Simple XOR Passkey Encryption
c1Code:
Encrypt a string using a passkey. Same function will decrypt key (if same passkey is used). Each character in the string is XOR'd with the corresponding character in the key. If the key is too short, it wraps. Only single-byte strings are acceptable because ASCII codes are used for the XOR.

Sub could be expanded for readability (as shown below) using intermediate variables, but it is about 15% slower.

'Sub Crypt(ByRef Data As String, Optional ByVal Key As String = "%Eric^$ Crypto En&ine!")
'    Dim count As Long
'    Dim DataByte As Byte
'    Dim KeyByte As Byte
'    Dim KeyLen As Long
'    Dim DataLen As Long
'
'    DataLen = Len(Data)
'    KeyLen = Len(Key)
'
'    For count = 1 To DataLen
'
'        DataByte = Asc(Mid$(Data, count, 1))
'        KeyByte = Asc(Mid$(Key, (count Mod KeyLen) + 1, 1))
'
'        Mid$(Data, count, 1) = Chr$(DataByte Xor KeyByte)
'    Next count
'
'End Function

Sub Crypt(ByRef Data As String, Optional ByVal Key As String = "%Eric^$ Crypto En&ine!")
    Dim Count As Long

    For Count = 1 To Len(Data)
        Mid$(Data, Count, 1) = Chr$(Asc(Mid$(Data, Count, 1)) Xor Asc(Mid$(Key, Count Mod Len(Key) + 1, 1)))
    Next Count

End Function


c0Title: Simulate "Hover Buttons" In VB Applications
c1Code:
Here is an easy way to routine simulates web style "hover buttons" in VB Applications. Place a call to this code in the _MouseMove event of the control to automatically change the background color of that control when the mouse pointer floats over it. As soon as the mouse pointer moves away from the control, the control background is restored to its original background color. The control must expose the hWnd property. This routine works well with PictureBox controls, VideoSoft's Elastic control, Sheridan's 3d panels.

Declare

Public Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function ReleaseCapture Lib "user32" () As Long

Code

Public Sub sysControlHighLight(ctl As Control, X As Single, Y As Single, OriginalBackColor As Long, NewBackColor As Long)

Dim HitTest As Long

    On Error Resume Next

    'test for control hwnd, if error simply exit

    HitTest = ctl.hwnd

    If Err.Number <> 0 Then Exit Sub

    With ctl

         If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then

            ReleaseCapture

            .BackColor = OriginalBackColor

            Else

                SetCapture .hwnd

                .BackColor = NewBackColor

        End If

   End With

    On Error GoTo 0

End Sub

Example

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

     sysControlHighLight Picture1, X, Y, vbBlue, vbRed

End Sub

Tip Submitted By: Giorgio Vidali


c0Title: Slam Selected Items into an Array
c1Code:
Use this code to retrieve all selected list items in a multiselect-style listbox in one API call. It�s a lot easier than iterating through a large list using For�Next. This code works against both normal and checkbox-style lists:


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 LB_GETSELCOUNT = &H190
Private Const LB_GETSELITEMS = &H191


Private Sub Command1_Click()
    Const LB_ERR = -1
    
    Dim numSelected As Long
    Dim r As Long
    Dim i As Integer
    
    'get the number of items selected.
    'If the listbox is single-select style,
    'numSelected will return -1 (LB_ERR).
    'If the listbox is multiselect style,
    'and nothing is selected, numSelected
    'returns 0. Otherwise, numSelected returns
    'the number selected (ala List1.SelCount)
    
    numSelected = SendMessage(List1.hWnd, LB_GETSELCOUNT, 0&, ByVal 0&)

    'debug ...
    Debug.Print numSelected; " items selected:"
    Debug.Print "index", "item"

    If numSelected <> LB_ERR Then
        'dim an array large enough to hold
        'the indexes of the selected items
        ReDim sSelected(1 To numSelected) As Long
        
        'pass the array so SendMessage can fill
        'it with the selected item indexes
        Call SendMessage(List1.hWnd, LB_GETSELITEMS, numSelected, sSelected(1))

        'debug ...
        'print out the items selected
        'note that their index is 0-based
        For i = 1 To numSelected
            Debug.Print List1.List(sSelected(i))
        Next
    End If
End Sub


�Randy Birch, East York, Ontario, Canada


c0Title: Sort a Collection By Any Property
c1Code:
Public Sub SortCollection(col As Collection, psSortPropertyName As String, pbAscending As Boolean, Optional psKeyPropertyName As String)
 
Dim obj As Object
Dim i As Integer
Dim j As Integer
Dim iMinMaxIndex As Integer
Dim vMinMax As Variant
Dim vValue As Variant
Dim bSortCondition As Boolean
Dim bUseKey As Boolean
Dim sKey As String
    
    bUseKey = (psKeyPropertyName <> "")
    
    For i = 1 To col.Count - 1
        Set obj = col(i)
        vMinMax = CallByName(obj, psSortPropertyName, VbGet)
        iMinMaxIndex = i
        
        For j = i + 1 To col.Count
            Set obj = col(j)
            vValue = CallByName(obj, psSortPropertyName, VbGet)
            
            If (pbAscending) Then
                bSortCondition = (vValue < vMinMax)
            Else
                bSortCondition = (vValue > vMinMax)
            End If
            
            If (bSortCondition) Then
                vMinMax = vValue
                iMinMaxIndex = j
            End If
            
            Set obj = Nothing
        Next j
        
        If (iMinMaxIndex <> i) Then
            Set obj = col(iMinMaxIndex)
            
            col.Remove iMinMaxIndex
            If (bUseKey) Then
                sKey = CStr(CallByName(obj, psKeyPropertyName, VbGet))
                col.Add obj, sKey, i
            Else
                col.Add obj, , i
            End If
            
            Set obj = Nothing
        End If
        
        Set obj = Nothing
    Next i
        
End Sub


c0Title: Sort and Reverse-Sort a ListView
c1Code:
This routine performs the standard column sorting on a ListView control found in many commercial applications, such as Windows Explorer and Outlook. Using this routine, the ListView sorts itself automatically whenever the user clicks on a column.
Clicking on the same column toggles the sort order between ascending and descending order. Call this routine from the ListView control�s ColumnClick event procedure by passing both a reference to the ListView and the ColumnHeader reference passed to the original event:

Public Sub ListView_ColumnClick(ByRef _
	MyListView As ListView, ByVal ColumnHeader As ColumnHeader)
	With MyListView
		.Sorted = False
		If .SortKey <> ColumnHeader.Index - 1 Then
			.SortKey = ColumnHeader.Index - 1
			.SortOrder = lvwAscending
		Else
			If .SortOrder = lvwAscending Then
				.SortOrder = lvwDescending
			Else
				.SortOrder = lvwAscending
			End If
		End If
		.Sorted = True
	End With
End Sub

�Jim Pragit, Glen Ellyn, Illinois


c0Title: Sort DBGrid Contents With Recordset Refresh
c1Code:
It�s often useful to sort a DBGrid field in either descending or ascending order. You do this by using the HeadClick event and the DataField property of columns. You must change the query string (Qry) with one of your own (be sure it contains the code in bold):


Private Sub DBGrid1_HeadClick(ByVal ColIndex As Integer)

       Dim Qry as string

       Qry = "SELECT * FROM MyTable WHERE Key='" & txtKey & "' "
       Qry = Qry & "ORDER BY " & DBGrid1.Columns(ColIndex).DataField & " " & DBGrid1.Tag

       data1.RecordSource = Qry
       data1.Refresh
       DBGrid1.ReBind

       'toggle ASC and DESC keywords
       If DBGrid1.Tag = "ASC" Then DBGrid1.Tag = "DESC" Else DBGrid1.Tag = "ASC"
End Sub

�Juan Jose Ochoa, Nogales, Arizona


c0Title: Sort Performance
c1Code:
And the benchmarking. A few changes from the first benchmark: 
Exactly the same start array for each sort, so they all get the same data - more accurate comparions 
4 of the Advanced Compiler Optimisations checked 
Scrapped the ordered list sorting - its not a good method of benchmarking sorting algorithms

And the results:

 
Sort            Total Time        Best Time       Worst Time       Average Time     Standard Deviation
 
10 numbers - 100000 iterations
Bubble sort     152.96469244      0.00111746      3.78316239       0.00152965       0.01336597
BubbleExit sort 152.61800033      0.00083810      4.94643872       0.00152618       0.01678431
Comb sort       176.76213038      0.00139683      2.33046379       0.00176762       0.00807599
Selection sort  161.91359516      0.00111746      1.84353039       0.00161914       0.01007209
Shaker sort     152.79120670      0.00111746      1.57533988       0.00152791       0.00668775
Insertion sort  132.75374384      0.00083810      3.45714330       0.00132754       0.01305081
Shell sort      201.02862235      0.00111746      50.44300323      0.00201029       0.16445773
Quick sort      161.20205222      0.00111746      0.99118743       0.00161202       0.00699075
Merge sort      282.97562958      0.00251429      1.26887635       0.00282976       0.00854858
Heap sort       291.11185919      0.00223492      4.95901015       0.00291112       0.02393678
Radix sort      589.53190978      0.00530794      2.23380346       0.00589532       0.01503699
 
100 numbers - 10000 iterations
Bubble sort     487.72371908      0.04190477      1.87817167       0.04877237       0.03345189
BubbleExit sort 495.88201852      0.04078731      11.25450302      0.04958820       0.11487248
Comb sort       148.41942202      0.01201270      9.07573449       0.01484194       0.09514210
Selection sort  399.61671106      0.02626032      108.24364549     0.03996167       1.08312136
Shaker sort     238.25849375      0.02234921      2.44416539       0.02382585       0.02610057
Insertion sort  294.96598031      0.01257143      124.98096825     0.02949660       1.24997237
Shell sort      240.92140202      0.01145397      109.40217262     0.02409214       1.09396767
Quick sort      111.51780464      0.00977778      2.21787965       0.01115178       0.02350238
Merge sort      315.22721463      0.01480635      148.60603792     0.03152272       1.48662178
Heap sort       185.44703307      0.01732064      0.71210168       0.01854470       0.01226964
Radix sort      138.20276041      0.01257143      2.17038758       0.01382028       0.02847120
 
1000 numbers - 1000 iterations
Bubble sort     5302.19259710     4.61371487      109.40915675     5.30219260       6.61005244
BubbleExit sort 5015.94699885     4.64360694      107.50137238     5.01594700       3.39177600
Comb sort       227.38839713      0.19164447      19.90504380      0.22738840       0.62692812
Selection sort  2787.95461434     2.16591774      162.10663646     2.78795461       7.76453592
Shaker sort     1952.84791782     1.80050817      104.74292124     1.95284792       3.25793136
Insertion sort  1480.41524831     1.26887635      106.66858497     1.48041525       3.32987222
Shell sort      212.30547458      0.19890796      0.78166359       0.21230547       0.03312238
Quick sort      160.96738552      0.12515557      23.60076490      0.16096739       0.74193239
Merge sort      191.77856404      0.17655875      2.01813359       0.19177856       0.08281318
Heap sort       236.91055707      0.22963812      0.80010169       0.23691056       0.03317844
Radix sort      265.12755113      0.15420954      105.92351821     0.26512755       3.34292368
 
10000 numbers - 100 iterations
Bubble sort     50333.40773758    469.18365323    629.35484817     503.33407738     32.63603076
BubbleExit sort 50254.40635612    474.52148248    648.95706019     502.54406356     33.35413768
Comb sort       295.44118037      2.84142258      4.78636251       2.95441180       0.28131880
Selection sort  22926.43282875    211.54560147    427.96835911     229.26432829     33.55725020
Shaker sort     18732.40090570    175.40916513    279.57519741     187.32400906     17.63665114
Insertion sort  14423.08980611    132.25340092    283.51927410     144.23089806     20.54782472
Shell sort      346.19232333      3.20292104      13.82214779      3.46192323       1.05030563
Quick sort      177.20408599      1.67842561      3.38590519       1.77204086       0.18563264
Merge sort      257.45478825      2.48858444      3.36439408       2.57454788       0.10004760
Heap sort       316.26505603      3.05262261      5.96416584       3.16265056       0.31633640
Radix sort      168.49264362      1.54796210      4.22986720       1.68492644       0.38273633
 
100000 numbers - 10 iterations
Bubble sort     584843.81283096   56844.45062152  60948.44400615   58484.38128310   1232.66414597
BubbleExit sort 593540.00578286   57006.79890880  61420.89232011   59354.00057829   1507.49203488
Comb sort       568.36553249      52.60026065     82.00260089      56.83655325      8.53268726
Selection sort  300871.93316469   29088.35508424  32581.69599768   30087.19331647   917.47691053
Shaker sort     211152.33332728   20092.12679265  22482.32722315   21115.23333273   790.97190654
Insertion sort  165414.38115738   15595.91177091  18918.27480867   16541.43811574   866.39375119
Shell sort      530.32857528      50.22426035     56.98126438      53.03285753      2.01733692
Quick sort      230.06974350      22.02849804     24.76013013      23.00697435      0.96052316
Merge sort      375.08705715      35.73275374     41.81173864      37.50870572      1.91683785
Heap sort       507.13847710      48.37095217     56.82118817      50.71384771      2.44218241
Radix sort      275.80432709      26.36396525     29.33333706      27.58043271      1.14522550


c0Title: SPEED UP LIST BOX UPDATES
c1Code:
When adding a large number of items to a list box, you can greatly speed up the process by disabling redraws of it. A quick call to SendMessage does the trick. Sandwich one to turn off redraws and one to turn them back on around a call to the routine that fills the list box, as shown here. Another method is to set the list box�s Visible property to False, but that may not offer as clean an appearance.

Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long 

Global Const WM_SETREDRAW = &HB

nRet& = SendMessage(List1.hWnd, WM_SETREDRAW, False, 0&) 
Call FillMyList(List1) 
nRet& = SendMessage(List1.hWnd, WM_SETREDRAW, True, 0&) 

�Karl E. Peterson


c0Title: Split Strings Cleanly
c1Code:
The Split function is great for parsing strings, but what happens when a string has more than one consecutive delimiter? It might seem odd that Split() returns empty substrings as placeholders for the data missing between delimiters, but that�s exactly what needs to happen so these data positions aren�t lost. Unfortunately, Split() does not have an option to ignore multiple delimiters. CleanSplit() uses the same arguments as Split() and efficiently discards empty substrings caused by more than one delimiter in a row:


Public Function CleanSplit(ByVal Expression As String, Optional ByVal Delimiter As String = " ", Optional ByVal Limit As Long = -1, Optional Compare As VbCompareMethod = vbBinaryCompare) As Variant

       Dim varSubstrings As Variant, i As Long

       varSubstrings = Split(Expression, Delimiter, Limit, Compare)

       'mark empty substrings with delimiter because 
       'the delimiter won't be around after Split()
       For i = LBound(varSubstrings) To UBound(varSubstrings)
             If Len(varSubstrings(i)) = 0 Then varSubstrings(i) = Delimiter
       Next i

       CleanSplit = Filter(varSubstrings, Delimiter, False)
End Function


�Mark Pickenheim, Springfield, Virginia


c0Title: Standard Browse for File Dialog
c1Code:
Option Compare Database
Option Explicit

Public Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (ofn As tagOPENFILENAME) As Boolean

Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (ofn As tagOPENFILENAME) As Boolean Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200 Public Const OFN_EXTENSIONDIFFERENT = &H400 Public Const OFN_PATHMUSTEXIST = &H800 Public Const OFN_FILEMUSTEXIST = &H1000 Public Const OFN_CREATEPROMPT = &H2000 Public Const OFN_SHAREAWARE = &H4000 Public Const OFN_NOREADONLYRETURN = &H8000 Public Const OFN_NOTESTFILECREATE = &H10000 Public Const OFN_NONETWORKBUTTON = &H20000 Public Const OFN_NOLONGNAMES = &H40000 Public Const OFN_EXPLORER = &H80000 Public Const OFN_NODEREFERENCELINKS = &H100000 Public Const OFN_LONGNAMES = &H200000


' This is the entry point you'll use to call the common ' file open/save dialog. The parameters are all optional.
'
'   Flags       One or more of the OFN_* constants, OR'd together (result flags are returned)
'   InitialDir  The directory in which to first look
'   Filter      A set of file filters: "<Desc>|<*.ex1>;<*.ex2>|<desc2>|<*.ext>".
'   FilterIndex 1-based integer indicating which filter set to use, by default (1 if unspecified)
'   DefaultExt  Extension to use if the user doesn't enter one. Only useful on file saves.
'   FileName    Default value for the file name text box.
'   DialogTitle Title for the dialog.
'   hWnd        Parent window handle
'   OpenFile    Boolean(True=Open File/False=Save As)
'
' Return Value: Either Null or the selected filename '
Public Function BrowseFile(Optional ByRef Flags As Long = 0, _
                                   Optional ByVal InitialDir As Variant, _
                                   Optional ByVal Filter As String = vbNullString, _
                                   Optional ByVal FilterIndex As Long = 1, _
                                   Optional ByVal DefaultExt As String = vbNullString, _
                                   Optional ByVal Filename As String = vbNullString, _
                                   Optional ByVal DialogTitle As String = vbNullString, _
                                   Optional ByVal hwnd As Variant, _
                                   Optional ByVal OpenFile As Boolean = True) As Variant
    Dim ofn As tagOPENFILENAME
    Dim strFileName As String
    Dim strFileTitle As String
    Dim fResult As Boolean
    Dim strResult As String
    
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp
    
    If Filter <> vbNullString Then
        Filter = Replace(Filter, "|", vbNullChar) & vbNullChar
    End If
    
    ' Allocate string space for the returned strings.
    strFileName = Left(Filename & String(256, 0), 256)
    strFileTitle = String(256, 0)
    
    ' Set up the data structure before you call the function
    With ofn
        .lStructSize = Len(ofn)
        .hwndOwner = hwnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        ' Didn't think most people would want to deal with
        ' these options.
        .hInstance = 0
        .lpfnHook = 0
        .strCustomFilter = vbNullString
        .nMaxCustFilter = 0
    End With
    
    ' This will pass the desired data structure to the
    ' Windows API, which will in turn it uses to display
    ' the Open/Save As Dialog.
    If OpenFile Then
        fResult = GetOpenFileName(ofn)
    Else
        fResult = GetSaveFileName(ofn)
    End If
    
    ' The function call filled in the strFileTitle member
    ' of the structure. You'll have to write special code
    ' to retrieve that if you're interested.
    If fResult Then
        ' You might care to check the Flags member of the
        ' structure to get information about the chosen file.
        ' In this example, if you bothered to pass in a
        ' value for Flags, we'll fill it in with the outgoing
        ' Flags value.
        If Not IsMissing(Flags) Then
            Flags = ofn.Flags
        End If
        
        strResult = ofn.strFile
        If ofn.Flags And OFN_ALLOWMULTISELECT Then
            ' They might have selected multiple files.
            Dim lngPos As Long
            Dim astrFiles As Variant
            
            ' Look for the two null characters at the end of the data.
            ' Trim the string at that point.
            lngPos = InStr(strResult, vbNullChar & vbNullChar)
            If lngPos > 0 Then
                strResult = Left(strResult, lngPos - 1)
            Else
                strResult = TrimNull(strResult)
            End If
        Else
            strResult = TrimNull(strResult)
        End If
        BrowseFile = strResult
    Else
        BrowseFile = vbNullString
    End If
End Function


c0Title: Standard Browse for Folder Dialog w/default folder option
c1Code:
Private Type BrowseInfo
   hwndOwner As Long
   pIDLRoot As Long
   pszDisplayName As String
   lpszTitle As String
   ulFlags As Long
   lpfnCallback As Long
   lParam As Long
   iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_EDITBOX = &H10
Public Const BIF_VALIDATE = &H20
Public Const BIF_NEWDIALOGSTYLE = &H40
Public Const BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
Public Const BIF_BROWSEINCLUDEURLS = &H80
Public Const BIF_UAHINT = &H100
Public Const BIF_NONEWFOLDERBUTTON = &H200
Public Const BIF_NOTRANSLATETARGETS = &H400
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_BROWSEINCLUDEFILES = &H4000
Public Const BIF_SHAREABLE = &H8000

Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Private mstrSTARTFOLDER As String

'Display Windows' standard folder selection dialog
'The default folder may be specified
Public Function BrowseFolder(ByVal hWndModal As Long, Optional StartFolder As String = "", Optional Title As String = "Please select a folder:", _
   Optional IncludeFiles As Boolean = False, Optional IncludeNewFolderButton As Boolean = False) As String
    Dim bInf As BrowseInfo
    Dim RetVal As Long
    Dim PathID As Long
    Dim RetPath As String
    Dim Offset As Integer
    'Set the properties of the folder dialog
    bInf.hwndOwner = hWndModal
    bInf.pIDLRoot = 0
    bInf.lpszTitle = Title
    bInf.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT
    If IncludeFiles Then bInf.ulFlags = bInf.ulFlags Or BIF_BROWSEINCLUDEFILES
    If IncludeNewFolderButton Then bInf.ulFlags = bInf.ulFlags Or BIF_NEWDIALOGSTYLE
    If StartFolder <> "" Then
       mstrSTARTFOLDER = StartFolder & vbNullChar
       bInf.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
   End If
    'Show the Browse For Folder dialog
    PathID = SHBrowseForFolder(bInf)
    RetPath = Space$(512)
    RetVal = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)
    If RetVal Then
         'Trim off the null chars ending the path
         'and display the returned folder
         Offset = InStr(RetPath, Chr$(0))
         BrowseFolder = Left$(RetPath, Offset - 1)
         'Free memory allocated for PIDL
         CoTaskMemFree PathID
    Else
         BrowseFolder = ""
    End If
End Function


Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
   On Error Resume Next
   Dim lpIDList As Long
   Dim ret As Long
   Dim sBuffer As String
   Select Case uMsg
       Case BFFM_INITIALIZED
           Call SendMessage(hwnd, BFFM_SETSELECTION, 1, mstrSTARTFOLDER)
       Case BFFM_SELCHANGED
           sBuffer = Space(MAX_PATH)
           ret = SHGetPathFromIDList(lp, sBuffer)
           If ret = 1 Then
               Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
           End If
   End Select
   BrowseCallbackProc = 0
End Function


Private Function GetAddressofFunction(add As Long) As Long
 GetAddressofFunction = add
End Function



c0Title: Start Up in Your Code Folder
c1Code:
I keep all my projects in a particular directory such as C:\work. When I save or open up a new project, I want the File dialog box to start at the directory C:\work. By default, it starts at the VB install directory, which is something like C:\Program Files\Microsoft Visual Studio\VB98. I don�t save any projects in the same directory with the VB executable.

     To get your project to open in the desired directory, change the �Start in� textbox in the shortcut for Microsoft Visual Basic to C:\work. It saves a mountain of clicks.

�Christian Gilstrap, Gilbert, Arizona


c0Title: Stop that Flickering!
c1Code:
Do your applications flicker whilst you update your controls? Find out how to stop it happening with one little-known API call, in this handy copy-and-paste code snippet.

To run, simply copy the below code into a module, then call the LockWindow method, passing the handle (.hWnd property) of the object you want to lock, such as your form or a particular control.

To unlock, simply run the UnlockWindow method.

This code works by calling the LockWindowUpdate API call of User32.dll, which simply 'locks' a form - effectively displaying just the image of it, until an unlock is performed.

Usage

LockWindow(Form1.hWnd)

'Do updating here

UnlockWindow


Code

Declare Function LockWindowUpdate Lib "user32" (ByVal hWnd As Long) As Long

Public Sub LockWindow(hWnd As Long)
    LockWindowUpdate hWnd
End Sub

Public Sub UnlockWindow()
    LockWindowUpdate 0
End Sub


Tip by Karl Moore


c0Title: Store Multiple Values in the Tag property
c1Code:
VB6

Level: Intermediate

Store Multiple Values in Tag

It would often be convenient to store multiple values in the Tag
property. Here are two simple functions that help you do that. The
first function stores the value in the control�s Tag, tagging the new
value with a key value of your choice:

Public Function SetTag(ctl As Control, ByVal Key As String, NewValue As String) As String
	Dim myArry() As String
	Dim i As Integer, k As Integer
	Dim yTag As String, yValue As String

	k = -1
	Key = UCase$(Key)

	If ctl.Tag = "" Then
		ctl.Tag = ctl.Tag & "|" & Key & "=" & NewValue
	Else
		myArry = Split(ctl.Tag, "|")

		For i = LBound(myArry) To UBound(myArry)
			If UCase$(Left$(myArry(i), Len(Key))) = Key Then k = i
		Next

		If k > -1 Then
			myArry(k) = Key & "=" & NewValue
			ctl.Tag = Join(myArry, "|")
		Else
			ctl.Tag = ctl.Tag & "|" & Key & "=" & NewValue
		End If
	End If

	SetTag = ctl.Tag
End Function


You can store the Tag value easily using a statement like this:


Call SetTag(myCtrl, "ID", LoginID)


A complementary function allows you to retrieve the stored value:


Public Function GetTag(ctl As Control, Key As String) As String
	Dim myArry() As String
	Dim i As Integer, k As Integer
	Dim yPoze As String, yValue As String

	k = -1

	If ctl.Tag = "" Then
		yValue = ""
	Else
		myArry = Split(ctl.Tag, "|")

		For i = LBound(myArry) To UBound(myArry)
			If UCase$(Left$(myArry(i), Len(Key))) = UCase$(Key) Then k = i
		Next i

		If k > -1 Then
			yPoze = InStr(myArry(k), "=")
			yValue = Mid$(myArry(k), yPoze + 1)
		Else
			yValue = ""
		End If
	End If

	GetTag = yValue
End Function

You can retrieve the code using a statement like this:

LoginID = GetTag(myCtrl, "ID")

As written, these functions are case-insensitive with the key names.
If you want case-sensitive key values, remove all UCase calls.

�Enrico Di Cesare, Arese, Italy


c0Title: Store Primary Key in ItemData
c1Code:
Loading a combo/listbox is pretty easy, and determining what the combo/listbox Text property selects is even easier. But if you load a table that might contain duplicate values, you might run into a problem�for example, many people might share the same last name.

Here�s the solution. First, load your combo box with a table from your database. A sub such as this works fine, by loading the list with names and storing a lookup key in each item�s ItemData property:

Public Sub FillComboBox(ctrControl As Control) Set rs = db.OpenDatabse("Contact", dbReadOnly)

	If Not rs.EOF Then
		With ctrControl
			Do Until rs.EOF
				.AddItem rs("LastName")
				.ItemData(.NewIndex) = rsTemp("ContactID") 
				rs.MoveNext 
			Loop 
		End With 
	End If 

	rs.Close 
	Set rs = Nothing 
End Sub 


You can now easily determine exactly which name is selected:

strSQL = "SELECT * FROM Contact Where " & _ "ContactID = " & cboMyComboBox.ItemData(
cboMyComboBox.ListIndex)


�Ken Kilar, Los Angeles, California


c0Title: Excel: Streamline Math in VBA
c1Code:
It�s possible to streamline some calculation procedures in Excel and add calculation capabilities that don�t exist in Word. Unfortunately, most textbooks on VB for Office 97 are focused on nonmathematical features such as text formatting or graphic displays. This situation creates a significant challenge for those who want to use VB macros for their superior mathematical capabilities, because the method for referencing numerical values in a cell of a Word table is significantly different from referencing a cell in an Excel spreadsheet. If you�re sufficiently persistent and a little clairvoyant, you can figure out the correct syntax from the Help found in the VB editors for Excel and Word. You can also get an almost complete set of hints on the subject from Microsoft Office 97: Visual Basic Programmer�s Guide by The Microsoft Corporation (Microsoft Press, 1997, ISBN: 1572313404). However, these are the only examples I know of that spell it out explicitly. They calculate the sum of cubes of the values for the first eight cells of column 1 and place the result in the ninth cell of column 1.

 
For Word VBA:
 
Sub columnmath()
     Dim x As Long, i As Long
     Dim myTable As Table
     Dim myStr As String
 
     x = 0
     Set myTable = ActiveDocument.Tables(1)
     For i = 1 To 8
          x = x + myTable.Cell(i, 1).Range. _
               Calculate ^ 3
     Next i
     myStr = Str(x)
     myTable.Cell(9, 1).Range.InsertAfter (myStr)
End Sub
 
For Excel VBA:
 
Sub columnmath()
     Dim x As Long, i As Long
     Sheets("Sheet1").Activate
     x = 0
     For i = 1 To 8
          x = x + Cells(i, 1).Value ^ 3
     Next i
     Range("a9").Value = x
End Sub
 
Although this calculation can be done entirely within the capabilities of Excel, it would take up an extra column. The calculation can�t be done at all within Word. In trying to make sense out of it all, consider that Word VBA has a nonintuitive syntax for referencing cells. To read the value of a cell, the terminal word must be Calculate. To write a value into a cell, it must first be converted to a string, and the nonintuitive terminal InsertAfter must be used. Tables are numbered consecutively in a Word document; therefore the Word example deals with the first table in the document. Each sheet of an Excel workbook is just one big table; therefore, the Excel example deals with the first sheet of the workbook. In the Excel example, the Range(�a9�) could be replaced by Cells(9,1), or one of several other variants involving the use of Range.

�Peter Gottlieb, Los Angeles, California


c0Title: Strip Comments off Strings Returned by GetPrivateProfileString
c1Code:
Windows doesn�t treat comments in INI files the same way VB does in code. Typically, comments must be on a single line of their own. When calling the GetPrivateProfileString function, if the requested entry contains a Rem statement�such as �; this is a rem�d statement��the entire entry, value and comment, will be returned.

     If your code anticipates the entry without comment, confusion could result from a user entering a comment following the entry rather than on a separate line. Use this VB code example to properly receive a return using the GetPrivateProfileString function call under any circumstance:

 
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
 
Private Sub Form_Click()
     Dim IniString As String
     Dim sDefault As String
     Dim lReturn As Long
 
     sDefault = "n/a"
     ' allocate sufficient buffer
     IniString = String$(260, 0)
     lReturn = GetPrivateProfileString("DB", "Path", sDefault, IniString, Len(IniString), "c:\test.ini")
     If lReturn > 0 Then
          IniString = Left$(IniString, lReturn)
          Debug.Print IniString
 
          ' added to strip out trailing comments
          If InStr(IniString, ";") > 0 Then
               IniString = Trim$(Left$(IniString, InStr(IniString, ";") - 1))
               If InStr(IniString, vbTab) > 0 Then
                    IniString = Trim$(Left$(IniString, InStr(IniString, vbTab) - 1))
               End If
          End If
     Else
          IniString = sDefault
     End If
     Debug.Print IniString
End Sub

�R. Van Volkenburgh, Keller, Texas


c0Title: Sub-Classing: Adding an About box to the control menu.
c1Code:
This week I will show you how to do something that I have always wanted to do. I remember reading many magazines with a similar question to this, but all of them just say that it is not possible in Visual Basic, well I have found a solution to this problem which includes sub-classing which I featured in last weeks newsletter.

Editor Note: This tips only works in Visual Basic 5, as previous versions of VB do not support the AddressOf operator.

Here goes!

1. Start a new Standard-Exe project, form1 is created by default.

2. Add a standard module to the project, project menu and click 'add module'

3. The new module should open up by default. Add the following code.

Remember and I keep telling people you write to me and say my samples do not work. Make sure that the API declarations are one line

Option Explicit

Declare Function AppendMenu Lib "user32" Alias _ "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags _ As Long, ByVal wIDNewItem As Long, ByVal _ lpNewItem As String) As Long

Declare Function GetSystemMenu Lib "user32" _ (ByVal hWnd As Long, ByVal bRevert As Long) As Long

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

Declare Function CallWindowProc Lib "user32" _ Alias "CallWindowProcA" (ByVal lpPrevWndFunc _ As Long, ByVal hWnd As Long, ByVal Msg As _ Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Const WM_SYSCOMMAND = &H112
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const GWL_WNDPROC = (-4)
Public Const IDM_ABOUT As Long = 1010
Public lProcOld As Long

Public Function SysMenuHandler(ByVal hWnd _ As Long, ByVal iMsg As Long, ByVal wParam _ As Long, ByVal lParam As Long) As Long

If iMsg = WM_SYSCOMMAND Then
    If wParam = IDM_ABOUT Then
        MsgBox "About . . .", vbInformation, "About"
        Exit Function
    End If
End If

SysMenuHandler = CallWindowProc(lProcOld, _ hWnd, iMsg, wParam, lParam) End Function

Public Function SubClass(FormName As Form) Dim lhSysMenu As Long, lRet As Long

lhSysMenu = GetSystemMenu(FormName.hWnd, 0&) lRet = AppendMenu(lhSysMenu, MF_SEPARATOR, 0&, _
vbNullString)
lRet = AppendMenu(lhSysMenu, MF_STRING, _ IDM_ABOUT, "About...")

FormName.Show
lProcOld = SetWindowLong(FormName.hWnd, GWL_WNDPROC, _ AddressOf SysMenuCode.SysMenuHandler) End Function 4. Open up the code window for form1 and type the following

Option Explicit

Private Sub Form_Load()
Dim d As String
d = SubClass(Form1) 'Type the name of the form d =
SubClass(<FormName>)
End Sub

Private Sub Form_Unload(Cancel As Integer) SetWindowLong Me.hWnd, GWL_WNDPROC, lProcOld End Sub 5. I have altered the code to work with any form just specify the form name where I have commented the code.

6. Run the project by clicking on run on the toolbar or from the run menu.

If you click on the control menu then you will see two items. One a separator and the other which says 'About...'. Click on about and a message box appears with my copyright.

Tip by Steve Anderson


c0Title: Sunrise/Sunset Calculation
c1Code:
This is a class I wrote based off a Java applet on a NOAA web page (see the source code for the URL). It calculates the sunrise, sunset, and solar noon given longitude and latitude coordinates. Additional, it knows the coordinates for about 40 cities.

      7/29/2000: Fixed the number of leap days, thanks to Ken Walthew for pointing out the problem.

      6/4/2001: Updated the source code off of NOAA's updates, including fixes for the extreme north and south regions. 
        
      Code: 
     ' ------ Class clsSunRiseSet
' Version 2.0

Option Explicit

' -- The following properties are exposed:
'Sunrise (r) - Sunrise time
'Sunset (r) - Sunset time
'SolarNoon (r) - Solar noon
'
'CityCount (r) - Number of cities
'CityName (r) - Name of city, by index
'City (w) - Sets the longitude/latitude/timezone based off a city
'           name or city index
'
'TimeZone (r/w) - Current Timezone
'DaySavings (r/w) - Daylight savings time in effect 'Longitude (r/w) - Longitude to calculate for 'Latitude (r/w) - Latitude to calculate for '
'DateDay (r/w) - Date to calculate for
'
'
' -- The following method is exposed
'CalculateSun - Calculate sunrise, sunset and solar noon '
'
' Scott Seligman <scott@scottandmichelle.net> ' Based off of
'   http://www.srrb.noaa.gov/highlights/sunrise/gen.html

Private Type typeMonth
    Name As String
    NumDays As Long
End Type

Private Type typeCity
    Name As String
    longitude As Double
    latitude As Double
    TimeZone As Long
End Type

Private m_cNumberCities As Long
Private m_Cities() As typeCity
    
Private m_monthList(0 To 11) As typeMonth Private m_monthLeap(0 To 11) As typeMonth

Private m_nTimeZone As Long
Private m_bDaySavings As Boolean
Private m_nLongitude As Double
Private m_nLatitude As Double
Private m_dateSel As Date

Private m_dateSunrise As Date
Private m_dateSunset As Date
Private m_dateNoon As Date

Public Property Get Sunrise() As Date
    Sunrise = m_dateSunrise
End Property

Public Property Get Sunset() As Date
    Sunset = m_dateSunset
End Property

Public Property Get SolarNoon() As Date
    SolarNoon = m_dateNoon
End Property

Public Property Get CityCount() As Long
    CityCount = m_cNumberCities + 1
End Property

Public Property Get CityName(nCity As Long) As String
    If nCity < 0 Or nCity > m_cNumberCities Then
        CityName = "(Error)"
    Else
        CityName = m_Cities(nCity).Name
    End If
End Property

Public Property Let City(City)
    Dim nCity As Long
    Dim bFound As Boolean
    
    If VarType(City) = vbString Then
        For nCity = 0 To m_cNumberCities
            If Trim(LCase(City)) = _
                Trim(LCase(m_Cities(nCity).Name)) Then
                bFound = True
                Exit For
            End If
        Next
        If Not bFound Then
            nCity = -1
        End If
    Else
        If IsNumeric(City) Then
            nCity = City
        Else
            nCity = -1
        End If
    End If
    
    If nCity < 0 Or nCity > m_cNumberCities Then
        m_nTimeZone = 0
        m_bDaySavings = False
        m_nLongitude = 0
        m_nLatitude = 0
    Else
        m_nTimeZone = m_Cities(nCity).TimeZone
        m_bDaySavings = False
        m_nLongitude = m_Cities(nCity).longitude
        m_nLatitude = m_Cities(nCity).latitude
    End If
    
End Property

Public Property Let TimeZone(nNew As Long)
    m_nTimeZone = nNew
End Property

Public Property Get TimeZone() As Long
    TimeZone = m_nTimeZone
End Property

Public Property Let DaySavings(bNew As Boolean)
    m_bDaySavings = bNew
End Property

Public Property Get DaySavings() As Boolean
    DaySavings = m_bDaySavings
End Property

Public Property Let longitude(nNew As Double)
    m_nLongitude = nNew
End Property

Public Property Get longitude() As Double
    longitude = m_nLongitude
End Property

Public Property Let latitude(nNew As Double)
    m_nLatitude = nNew
End Property

Public Property Get latitude() As Double
    latitude = m_nLatitude
End Property
    
Public Property Let DateDay(dateNew As Date)
    m_dateSel = dateNew
End Property
    
Public Property Get DateDay() As Date
    DateDay = m_dateSel
End Property


Private Function IsLeapYear(nYear As Long) As Boolean
    If (nYear Mod 4 = 0 And nYear Mod _
        100 <> 0) Or nYear Mod 400 = 0 Then
        IsLeapYear = True
    Else
        IsLeapYear = False
    End If
End Function

Private Function RadToDeg(angleRad As Double) As Double
    RadToDeg = 180 * angleRad / 3.1415926535 End Function

Private Function DegToRad(angleDeg As Double) As Double
    DegToRad = 3.1415926535 * angleDeg / 180 End Function

Private Function acos(X As Double) As Double
    On Error Resume Next
    acos = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1) End Function

Private Sub InitMonths()

    m_monthList(0).Name = "January": m_monthList(0).NumDays = 31
    m_monthList(1).Name = "February": m_monthList(1).NumDays = 28
    m_monthList(2).Name = "March": m_monthList(2).NumDays = 31
    m_monthList(3).Name = "April": m_monthList(3).NumDays = 30
    m_monthList(4).Name = "May": m_monthList(4).NumDays = 31
    m_monthList(5).Name = "June": m_monthList(5).NumDays = 30
    m_monthList(6).Name = "July": m_monthList(6).NumDays = 31
    m_monthList(7).Name = "August": m_monthList(7).NumDays = 31
    m_monthList(8).Name = "September": m_monthList(8).NumDays = 30
    m_monthList(9).Name = "October": m_monthList(9).NumDays = 31
    m_monthList(10).Name = "November": m_monthList(10).NumDays = 30
    m_monthList(11).Name = "DEcember": m_monthList(11).NumDays = 31
    
    m_monthLeap(0).Name = "January": m_monthLeap(0).NumDays = 31
    m_monthLeap(1).Name = "February": m_monthLeap(1).NumDays = 29
    m_monthLeap(2).Name = "March": m_monthLeap(2).NumDays = 31
    m_monthLeap(3).Name = "April": m_monthLeap(3).NumDays = 30
    m_monthLeap(4).Name = "May": m_monthLeap(4).NumDays = 31
    m_monthLeap(5).Name = "June": m_monthLeap(5).NumDays = 30
    m_monthLeap(6).Name = "July": m_monthLeap(6).NumDays = 31
    m_monthLeap(7).Name = "August": m_monthLeap(7).NumDays = 31
    m_monthLeap(8).Name = "September": m_monthLeap(8).NumDays = 30
    m_monthLeap(9).Name = "October": m_monthLeap(9).NumDays = 31
    m_monthLeap(10).Name = "November": m_monthLeap(10).NumDays = 30
    m_monthLeap(11).Name = "DEcember": m_monthLeap(11).NumDays = 31

End Sub

Private Sub AddCity(sCity As String, nLatitude As Double, _
    nLongitude As Double, nZone As Long)


    m_cNumberCities = m_cNumberCities + 1
    If m_cNumberCities > UBound(m_Cities) Then
        ReDim Preserve m_Cities(UBound(m_Cities) + 10)
    End If

    m_Cities(m_cNumberCities).Name = sCity
    m_Cities(m_cNumberCities).latitude = nLatitude
    m_Cities(m_cNumberCities).longitude = nLongitude
    m_Cities(m_cNumberCities).TimeZone = nZone

End Sub

Private Sub InitCities()

    m_cNumberCities = -1
    ReDim m_Cities(0)

    AddCity "Albuquerque, NM", 35.05, 106.39, 7
    AddCity "Anchorage, AK", 61.13, 149.54, 9
    AddCity "Atlanta, GA", 33.44, 84.23, 5
    AddCity "Boston, MA", 42.21, 71.03, 5
    AddCity "Boulder, CO", 40.125, 105.237, 7
    AddCity "Chicago, IL", 41.51, 87.39, 6
    AddCity "Dallas, TX", 32.46, 96.47, 6
    AddCity "Denver, CO", 39.44, 104.59, 7
    AddCity "Detroit, MI", 42.2, 83.03, 5
    AddCity "Honolulu, HA", 21.18, 157.51, 10
    AddCity "Indianapolis, IN", 39.46, 86.09, 5
    AddCity "Kansas City, MO", 39.05, 94.34, 6
    AddCity "Los Angeles, CA", 34.03, 118.14, 8
    AddCity "Miami, FL", 25.46, 80.11, 5
    AddCity "Minneapolis, nMonth", 44.58, 93.15, 6
    AddCity "New Orleans, LA", 29.57, 90.04, 6
    AddCity "New York City, NY", 40.43, 74.01, 5
    AddCity "Oklahoma City, OK", 35.28, 97.3, 6
    AddCity "Philadelphia, PA", 39.57, 75.09, 5
    AddCity "Phoenix, AZ", 33.26, 112.04, 7
    AddCity "Saint Louis, MO", 38.37, 90.11, 6
    AddCity "San Fransisco, CA", 37.46, 122.25, 8
    AddCity "Seattle, WA", 47.36, 122.19, 8
    AddCity "Washington DC", 38.53, 77.02, 5
    AddCity "Beijing, China", 39.55, -116.25, -8
    AddCity "Berlin, Germany", 52.33, -13.3, -1
    AddCity "Buenos Aires, Argentina", -34.36, 58.27, 3
    AddCity "Cairo, Egypt", -30.06, -31.22, -2
    AddCity "Cape Town, South Africa", -33.55, -18.22, -2
    AddCity "Caracas, Venezula", 10.3, 66.56, 4
    AddCity "Helsinki, Finland", 60.1, -24.58, -2
    AddCity "Hong Kong, China", 22.15, -114.1, -8
    AddCity "London, England", 51.3, 0.1, 0
    AddCity "Mexico City, Mexico", 19.24, 99.09, 6
    AddCity "Moscow, Russia", 55.45, -37.35, -3
    AddCity "New Delhi, India", 28.36, -77.12, -5.5
    AddCity "Ottawa, Canada", 45.25, 75.42, 5
    AddCity "Paris, France", 48.52, -2.2, -1
    AddCity "Rio de Janeiro, Brazil", -22.54, 43.14, 3
    AddCity "Riyadh, Saudi Arabia", 24.38, -46.43, -3
    AddCity "Rome, Italy", 41.54, -12.29, -1
    AddCity "Sydney, Australia", -33.52, -151.13, -10
    AddCity "Tokyo, Japan", 35.42, -139.46, -9
    AddCity "Zurich, Switzerland", 47.23, -8.32, -1

End Sub

Private Sub Class_Initialize()

    InitMonths
    InitCities
    m_dateSel = Now

End Sub

Private Function calcDayOfYear(ByVal nmn As Long, ByVal ndy As Long, _
    bLeapYear As Boolean) As Long

    calcDayOfYear = Int((275 * nmn) / 9) - IIf(bLeapYear, 1, 2) _
        * Int((nmn + 9) / 12) + ndy - 30

End Function

Private Function calcJD(ByVal nYear As Long, ByVal nMonth As Long, _
    ByVal nDay As Long) As Double

    If nMonth <= 2 Then
        nYear = nYear - 1
        nMonth = nMonth + 12
    End If
    Dim A As Long
    Dim B As Long
    
    A = Int(nYear / 100)
    B = 2 - A + Int(A / 4)
    
    calcJD = Int(365.25 * (nYear + 4716)) + Int(30.6001 * _
        (nMonth + 1)) + nDay + B - 1524.5

End Function

Private Function calcTimeJulianCent(ByVal njd As Double) As Double

    calcTimeJulianCent = (njd - 2451545#) / 36525#
    
End Function

Private Function calcJDFromJulianCent(ByVal nt As Double) As Double

    calcJDFromJulianCent = nt * 36525# + 2451545#

End Function

Private Function calcGeomMeanLongSun(ByVal nt As Double) As Double

    Dim nLO As Double
    nLO = 280.46646 + nt * (36000.76983 + 0.0003032 * nt)
    Do While nLO > 360#
        nLO = nLO - 360#
    Loop
    Do While nLO < 0
        nLO = nLO + 360#
    Loop
    calcGeomMeanLongSun = nLO

End Function

Private Function calcGeomMeanAnomalySun(ByVal nt As Double) As Double

    calcGeomMeanAnomalySun = 357.52911 + nt * (35999.05029 - _
        0.0001537 * nt)

End Function

Private Function calcEccentricityEarthOrbit(ByVal nt As Double) _
    As Double

    calcEccentricityEarthOrbit = 0.016708634 - nt * _
        (0.000042037 + 0.0000001267 * nt)

End Function

Private Function calcSunEqOfCenter(ByVal nt As Double) As Double

    Dim nm As Double
    Dim nmrad As Double
    Dim nsinm As Double
    Dim nsin2m As Double
    Dim nsin3m As Double

    nm = calcGeomMeanAnomalySun(nt)
    
    nmrad = DegToRad(nm)
    nsinm = Sin(nmrad)
    nsin2m = Sin(nmrad + nmrad)
    nsin3m = Sin(nmrad + nmrad + nmrad)
    
    calcSunEqOfCenter = nsinm * (1.914602 - nt * _
        (0.004817 + 0.000014 * nt)) + nsin2m * _
        (0.019993 - 0.000101 * nt) + nsin3m * 0.000289

End Function

Private Function calcSunTrueLong(ByVal nt As Double) As Double

    Dim n10 As Double
    Dim nc As Double
    
    n10 = calcGeomMeanLongSun(nt)
    nc = calcSunEqOfCenter(nt)
    
    calcSunTrueLong = n10 + nc

End Function

Private Function calcSunApparentLong(ByVal nt As Double) As Double
    Dim no As Double
    Dim nomega As Double
    
    no = calcSunTrueLong(nt)
    nomega = 125.04 - 1934.136 * nt
    calcSunApparentLong = no - 0.00569 - 0.00478 * _
        Sin(DegToRad(nomega))
    
End Function

Private Function calcMeanObliquityOfEcliptic(ByVal nt As Double) _
    As Double

    Dim nseconds As Double
    
    nseconds = 21.448 - nt * (46.815 + nt * _
        (0.00059 - nt * (0.001813)))
    calcMeanObliquityOfEcliptic = 23# + (26# + _
        (nseconds / 60#)) / 60#

End Function

Private Function calcObliquityCorrection(ByVal nt As Double) As Double

    Dim ne0 As Double
    ne0 = calcMeanObliquityOfEcliptic(nt)
    
    Dim nomega As Double
    nomega = 125.04 - 1934.136 * nt
    calcObliquityCorrection = ne0 + 0.00256 * Cos(DegToRad(nomega))

End Function

Private Function calcSunRtAscension(nt As Double) As Double

    Dim ne As Double
    Dim nlambda As Double
    Dim ntananum As Double
    Dim ntanadenom As Double
    
    ne = calcObliquityCorrection(nt)
    nlambda = calcSunApparentLong(nt)

    ntananum = (Cos(DegToRad(ne)) * Sin(DegToRad(nlambda)))
    ntanadenom = (Cos(DegToRad(nlambda)))
    
    calcSunRtAscension = RadToDeg(atan2(ntananum, ntanadenom))
    
End Function

Private Function atan2(ByVal Y As Double, ByVal X As Double) As Double

    If X > 0 Then
        atan2 = Atn(Y / X)
    ElseIf X < 0 Then
        atan2 = Atn(Y / X) + 3.1415926535
    Else
        atan2 = 3.1415926535 / 2 * Sgn(Y)
    End If

End Function

Private Function asin(ByVal X As Double) As Double
    asin = Atn(X / Sqr(-X * X + 1))
End Function

Private Function calcSunDeclination(ByVal nt As Double) As Double

    Dim ne As Double
    Dim nlambda As Double
    Dim nsint As Double
    
    ne = calcObliquityCorrection(nt)
    nlambda = calcSunApparentLong(nt)
    
    nsint = Sin(DegToRad(ne)) * Sin(DegToRad(nlambda))
    calcSunDeclination = RadToDeg(asin(nsint))
    
End Function

Private Function calcEquationOfTime(ByVal nt As Double) As Double

    Dim nepsilon As Double
    Dim nl0 As Double
    Dim ne As Double
    Dim nm As Double
    Dim ny As Double
    Dim nsin2l0 As Double
    Dim nsinm As Double
    Dim ncos2l0 As Double
    Dim nsin4l0 As Double
    Dim nsin2m As Double
    Dim nEtime As Double
    
    nepsilon = calcObliquityCorrection(nt)
    nl0 = calcGeomMeanLongSun(nt)
    ne = calcEccentricityEarthOrbit(nt)
    nm = calcGeomMeanAnomalySun(nt)
    
    ny = Math.Tan(DegToRad(nepsilon) / 2#)
    ny = ny * ny
    
    nsin2l0 = Sin(2# * DegToRad(nl0))
    nsinm = Sin(DegToRad(nm))
    ncos2l0 = Cos(2# * DegToRad(nl0))
    nsin4l0 = Sin(4# * DegToRad(nl0))
    nsin2m = Sin(2# * DegToRad(nm))
    
    nEtime = ny * nsin2l0 - 2# * ne * nsinm + 4# * ne * _
        ny * nsinm * ncos2l0 - 0.5 * ny * ny * nsin4l0 - _
        1.25 * ne * ne * nsin2m
    
    calcEquationOfTime = RadToDeg(nEtime) * 4# End Function

Private Function calcHourAngleSunrise(ByVal nlat As Double, _
    ByVal nsolarDec As Double) As Double

    Dim nlatRad As Double
    Dim nsdRad As Double
    Dim nHAarg As Double
    Dim nHA As Double

    nlatRad = DegToRad(nlat)
    nsdRad = DegToRad(nsolarDec)

    nHAarg = (Cos(DegToRad(90.833)) / (Cos(nlatRad) * _
        Cos(nsdRad)) - Tan(nlatRad) * Tan(nsdRad))

    Dim nTemp As Double
    nTemp = Cos(DegToRad(90.833)) / (Cos(nlatRad) * _
        Cos(nsdRad)) - Tan(nlatRad) * Tan(nsdRad)
    If Abs(nTemp) > 1 Then
        nHA = -999
    Else
        nHA = (acos(nTemp))
    End If

    calcHourAngleSunrise = nHA

End Function

Private Function calcHourAngleSunset(ByVal nlat As Double, _
    ByVal nsolarDec As Double) As Double

    Dim nlatRad As Double
    Dim nsdRad As Double
    Dim nHAarg As Double
    Dim nHA As Double

    nlatRad = DegToRad(nlat)
    nsdRad = DegToRad(nsolarDec)
    
    nHAarg = (Cos(DegToRad(90.833)) / (Cos(nlatRad) * _
        Cos(nsdRad)) - Tan(nlatRad) * Tan(nsdRad))
    
    Dim nTemp As Double
    nTemp = Cos(DegToRad(90.833)) / (Cos(nlatRad) * _
        Cos(nsdRad)) - Tan(nlatRad) * Tan(nsdRad)
    If Abs(nTemp) > 1 Then
        nHA = 999
    Else
        nHA = (acos(nTemp))
    End If
    
    calcHourAngleSunset = -nHA

End Function

Private Function calcSunriseUTC(ByVal njd As Double, _
    ByVal nLatitude As Double, ByVal nLongitude As Double) As Double

    Dim nt As Double
    Dim neqTime As Double
    Dim nsolarDec As Double
    Dim nhourAngle As Double
    
    Dim ndelta As Double
    Dim ntimeDiff As Double
    Dim ntimeUTC As Double
    
    nt = calcTimeJulianCent(njd)

    neqTime = calcEquationOfTime(nt)
    nsolarDec = calcSunDeclination(nt)
    nhourAngle = calcHourAngleSunrise(nLatitude, nsolarDec)
    If nhourAngle = -999 Then
        calcSunriseUTC = -999
        Exit Function
    End If

    ndelta = nLongitude - RadToDeg(nhourAngle)
    ntimeDiff = 4 * ndelta
    ntimeUTC = 720 + ntimeDiff - neqTime

    Dim nnewt As Double
    nnewt = calcTimeJulianCent(calcJDFromJulianCent(nt) + _
        ntimeUTC / 1440#)
    neqTime = calcEquationOfTime(nnewt)
    nsolarDec = calcSunDeclination(nnewt)
    nhourAngle = calcHourAngleSunrise(nLatitude, nsolarDec)
    If nhourAngle = -999 Then
        calcSunriseUTC = -999
        Exit Function
    End If
    ndelta = nLongitude - RadToDeg(nhourAngle)
    ntimeDiff = 4 * ndelta
    ntimeUTC = 720 + ntimeDiff - neqTime

    calcSunriseUTC = ntimeUTC
    
End Function

Private Function calcSolNoonUTC(ByVal nt As Double, _
    ByVal nLongitude As Double) As Double

    Dim nnewt As Double
    Dim neqTime As Double
    Dim nsolarNoonDec As Double
    Dim nsolNoonUTC As Double
    
    nnewt = calcTimeJulianCent(calcJDFromJulianCent(nt) + _
        0.5 + nLongitude / 360#)
    neqTime = calcEquationOfTime(nt)
    nsolarNoonDec = calcSunDeclination(nt)
    nsolNoonUTC = 720 + (nLongitude * 4) - neqTime
    
    calcSolNoonUTC = nsolNoonUTC

End Function

Private Function calcSunsetUTC(ByVal njd As Double, _
    ByVal nLatitude As Double, ByVal nLongitude As _
    Double) As Double

    Dim neqTime As Double
    Dim nsolarDec As Double
    Dim nhourAngle As Double
    
    Dim ndelta As Double
    Dim ntimeDiff As Double
    Dim ntimeUTC As Double
    Dim nnewt As Double
    Dim nt As Double

    nt = calcTimeJulianCent(njd)

    neqTime = calcEquationOfTime(nt)
    nsolarDec = calcSunDeclination(nt)
    nhourAngle = calcHourAngleSunset(nLatitude, nsolarDec)
    If nhourAngle = -999 Then
        calcSunsetUTC = -999
        Exit Function
    End If

    ndelta = nLongitude - RadToDeg(nhourAngle)
    ntimeDiff = 4 * ndelta
    ntimeUTC = 720 + ntimeDiff - neqTime
    
    nnewt = calcTimeJulianCent(calcJDFromJulianCent(nt) + _
        ntimeUTC / 1440#)
    neqTime = calcEquationOfTime(nnewt)
    nsolarDec = calcSunDeclination(nnewt)
    nhourAngle = calcHourAngleSunset(nLatitude, nsolarDec)
    If nhourAngle = -999 Then
        calcSunsetUTC = -999
        Exit Function
    End If
    
    ndelta = nLongitude - RadToDeg(nhourAngle)
    ntimeDiff = 4 * ndelta
    ntimeUTC = 720 + ntimeDiff - neqTime
    
    calcSunsetUTC = ntimeUTC

End Function

Private Function findRecentSunrise(ByVal njd As Double, _
    ByVal nLatitude As Double, ByVal nLongitude _
    As Double) As Double

    Dim njulianday As Double
    njulianday = njd
    Dim nBail As Long
    
    Dim ntime As Double
    ntime = calcSunriseUTC(njulianday, nLatitude, nLongitude)
    Do While ntime = -999 And nBail < 367
        nBail = nBail + 1
        njulianday = njulianday - 1
        ntime = calcSunriseUTC(njulianday, nLatitude, nLongitude)
    Loop
    
    findRecentSunrise = njulianday

End Function

Private Function findRecentSunset(ByVal njd As Double, _
    ByVal nLatitude As Double, ByVal nLongitude _
    As Double) As Double

    Dim njulianday As Double
    Dim ntime As Double
    Dim nBail As Long
    
    njulianday = njd

    ntime = calcSunsetUTC(njulianday, nLatitude, nLongitude)
    Do While ntime = -999 And nBail < 367
        nBail = nBail + 1
        njulianday = njulianday - 1
        ntime = calcSunsetUTC(njulianday, nLatitude, nLongitude)
    Loop
    
    findRecentSunset = njulianday

End Function

Private Function findNextSunrise(ByVal njd As Double, ByVal _
    nLatitude As Double, ByVal nLongitude As Double) As Double
    Dim njulianday As Double
    Dim ntime As Double
    Dim nBail As Long

    njulianday = njd

    ntime = calcSunriseUTC(njulianday, nLatitude, nLongitude)
    Do While ntime = -999 And nBail < 367
        nBail = nBail + 1
        njulianday = njulianday + 1
        ntime = calcSunriseUTC(njulianday, nLatitude, nLongitude)
    Loop
    
    findNextSunrise = njulianday

End Function

Private Function findNextSunset(ByVal njd As Double, ByVal _
    nLatitude As Double, ByVal nLongitude As Double) As Double

    Dim njulianday As Double
    Dim ntime As Double
    Dim nBail As Long
    njulianday = njd
    ntime = calcSunsetUTC(njulianday, nLatitude, nLongitude)
    Do While ntime = -999 And nBail < 367
        nBail = nBail + 1
        njulianday = njulianday + 1
        ntime = calcSunsetUTC(njulianday, nLatitude, nLongitude)
    Loop
    
    findNextSunset = njulianday

End Function

Public Function CalculateSun()
    Dim nLatitude As Double
    Dim nLongitude As Double
    nLatitude = m_nLatitude
    nLongitude = m_nLongitude

    If nLatitude >= -90 And nLatitude < -89.5 Then
        nLatitude = -89.5
    End If
    If nLatitude <= 90 And nLatitude > 89.8 Then
        nLatitude = 89.8
    End If

    Dim njd As Double
    Dim ndoy As Double
    Dim nt As Double
    
    njd = calcJD(Year(m_dateSel), Month(m_dateSel), Day(m_dateSel))
    ndoy = calcDayOfYear(Month(m_dateSel), Day(m_dateSel), _
        IsLeapYear(Year(m_dateSel)))
    nt = calcTimeJulianCent(njd)
    
    Dim nAlpha As Double
    Dim nTheta As Double
    Dim nEtime As Double
    
    nAlpha = calcSunRtAscension(nt)
    nTheta = calcSunDeclination(nt)
    nEtime = calcEquationOfTime(nt)
    
    Dim neqTime As Double
    Dim nsolarDec As Double
    
    neqTime = nEtime
    nsolarDec = nTheta
    
    'Calculate sunrise
    Dim bNoSunrise As Boolean
    bNoSunrise = False
    
    Dim nRiseTimeGMT As Double
    nRiseTimeGMT = calcSunriseUTC(njd, nLatitude, nLongitude)
    
    If nRiseTimeGMT = -999 Then
        bNoSunrise = True
    End If

    'Calculate sunset
    Dim bNoSunset As Boolean
    bNoSunset = False
    Dim nSetTimeGMT As Double
    nSetTimeGMT = calcSunsetUTC(njd, nLatitude, nLongitude)
    If nSetTimeGMT = -999 Then
        bNoSunset = True
    End If
    
    Dim ndaySavings As Double
    Dim nZone As Double
    
    ndaySavings = IIf(m_bDaySavings, 60, 0)
    nZone = m_nTimeZone
    If nZone > 12 Or nZone < -12.5 Then
        nZone = 0
    End If
    
    If Not bNoSunrise Then
        Dim nriseTimeLST As Double
        nriseTimeLST = nRiseTimeGMT - (60 * nZone) + ndaySavings
        
        m_dateSunrise = DateAdd("s", nriseTimeLST * 60, _
            Int(m_dateSel))
    End If

    If Not bNoSunset Then
        Dim nsetTimeLST As Double
        nsetTimeLST = nSetTimeGMT - (60 * nZone) + ndaySavings
        
        m_dateSunset = DateAdd("s", nsetTimeLST * 60, Int(m_dateSel))
    End If
    
    'Calculate solar noon for this date
    Dim nsolNoonGMT As Double
    Dim nsolNoonLST As Double
    nsolNoonGMT = calcSolNoonUTC(nt, nLongitude)
    nsolNoonLST = nsolNoonGMT - (60 * nZone) + ndaySavings
    
    m_dateNoon = DateAdd("s", nsolNoonLST * 60, Int(m_dateSel))

    Dim nnewjd As Double
    Dim nnewtime As Double

    If bNoSunrise Then
        If ((nLatitude > 66.4) And (ndoy > 79) And _
            (ndoy < 267)) Or ((nLatitude < -66.4) And _
            ((ndoy < 83) Or (ndoy > 236))) Then

            nnewjd = findRecentSunrise(njd, nLatitude, nLongitude)
            nnewtime = calcSunriseUTC(nnewjd, nLatitude, _
                nLongitude) - (60 * nZone) + ndaySavings

            If nnewtime > 1440 Then
                nnewtime = nnewtime - 1440
                nnewjd = nnewjd + 1
            End If
            If nnewtime < 0 Then
                nnewtime = nnewtime + 1440
                nnewjd = nnewjd - 1
            End If
            
            m_dateSunrise = DateAdd("s", nnewtime * 60, _
                Int(m_dateSel))
            m_dateSunrise = DateAdd("d", nnewjd - njd, m_dateSunrise)
        
        ElseIf ((nLatitude > 66.4) And ((ndoy < 83) Or _
            (ndoy > 263))) Or ((nLatitude < -66.4) And _
            (ndoy > 79) And (ndoy < 267)) Then

            nnewjd = findNextSunrise(njd, nLatitude, nLongitude)
            nnewtime = calcSunriseUTC(nnewjd, nLatitude, _
                nLongitude) - (60 * nZone) + ndaySavings
            If nnewtime > 1440 Then
                nnewtime = nnewtime - 1440
                nnewjd = nnewjd + 1
            End If
            If nnewtime < 0 Then
                nnewtime = nnewtime + 1440
                nnewjd = nnewjd - 1
            End If
            
            m_dateSunrise = DateAdd("s", nnewtime * 60, _
                Int(m_dateSel))
            m_dateSunrise = DateAdd("d", nnewjd - njd, m_dateSunrise)
        
        End If
    End If
    
    If bNoSunset Then
        If (((nLatitude > 66.4) And (ndoy > 79) And _
            (ndoy < 267)) Or ((nLatitude < -66.4) And _
            ((ndoy < 83) Or (ndoy > 263)))) Then

            nnewjd = findNextSunset(njd, nLatitude, nLongitude)
            nnewtime = calcSunsetUTC(nnewjd, nLatitude, _
                nLongitude) - (60 * nZone) + ndaySavings
            If nnewtime > 1440 Then
                nnewtime = nnewtime - 1440
                nnewjd = nnewjd + 1
            End If
            If nnewtime < 0 Then
                nnewtime = nnewtime + 1440
                nnewjd = nnewjd - 1
            End If

            m_dateSunset = DateAdd("s", nnewtime * 60, Int(m_dateSel))
            m_dateSunset = DateAdd("d", nnewjd - njd, m_dateSunset)

        ElseIf (((nLatitude > 66.4) And ((ndoy < 83) Or _
            (ndoy > 263))) Or ((nLatitude < -66.4) And _
            (ndoy > 79) And (ndoy < 267))) Then

            nnewjd = findRecentSunset(njd, nLatitude, nLongitude)
            nnewtime = calcSunsetUTC(nnewjd, nLatitude, _
                nLongitude) - (60 * nZone) + ndaySavings
            If nnewtime > 1440 Then
                nnewtime = nnewtime - 1440
                nnewjd = nnewjd + 1
            End If
            If nnewtime < 0 Then
                nnewtime = nnewtime + 1440
                nnewjd = nnewjd - 1
            End If

            m_dateSunset = DateAdd("s", nnewtime * 60, Int(m_dateSel))
            m_dateSunset = DateAdd("d", nnewjd - njd, m_dateSunset)

        End If
    End If
End Function

' ------ End of class clsSunRiseSet

     
        
      Sample Usage: 
        
         Dim srs As New clsSunRiseSet
    srs.City = "Dallas, TX"
    srs.CalculateSun
    Debug.Print srs.Sunrise, srs.Sunset



c0Title: Supply Users with More Icon Choices
c1Code:
In the past, VB allowed an app to have only one icon. However, resource files expose any contained icons to Windows. Simply add the icons you wish to show to a RES file and add the RES file to your project. Then compile the app, make a shortcut to it, and open the Shortcut tab under the Properties window with a right click and select Properties. Press the Change Icon button and voila!�all the icons are there to choose from.

�Michael Lewis, Chaing Mai, Thailand


c0Title: Swap Strings Faster
c1Code:
Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSource As Long, ByVal nBytes As Long)

Public Sub SwapStrings(String1 As String, String2 As String) '===========================================================================
'   SwapStrings - Swaps two strings by copying BSTR pointers, without
'   copying any of the underlying string data. Great for sorting functions.
'
'   String1/String2     The strings to swap.
'===========================================================================

    Dim temp As Long
      
    ' Hold first variable
    temp = StrPtr(String1)
    
    ' Swap the BSTR pointers
    CopyMemory ByVal VarPtr(String1), ByVal VarPtr(String2), 4
    CopyMemory ByVal VarPtr(String2), ByVal temp, 4

End Sub



c0Title: System Tray Class
c1Code:
This is an enhanced system tray class, similar to my clsSysTray class. Unlike that class however, this uses a class, and a standard module, to create a window to use for the callback message, instead of using a picture box. The technique this uses is slightly better than subclassing the form, but very similar to subclassing the form. One benefit of this approach is that you can look for more messages, indeed, this class watches for the "TaskbarCreated" message that IE4 and above send out when Explorer crashes and recreates itself, so the system tray icon is recreated. 
        
Code: 


'----------------------------------------------------------------------
'Start of Class Module: clsInTray

Option Explicit

Private m_hWndHidden As Long 'Dummy window used for call backs Private m_nid As NOTIFYICONDATA Private m_bVisible As Boolean 'Is the icon visible yet?
Private m_sClass As String

Public Event MouseMove()
Public Event MouseUp(Button As Integer)
Public Event MouseDown(Button As Integer) Public Event DblClick(Button As Integer)

'The handle of the hIcon to use
Public Property Get hIcon() As Long
    
    hIcon = m_nid.hIcon
    
End Property

Public Property Let hIcon(newhIcon As Long)
    
    m_nid.hIcon = newhIcon
    
End Property

'Tool tip for the system tray icon
Public Property Get Tip() As String
    
    Tip = m_nid.szTip
    
End Property

Public Property Let Tip(szTip As String)
    
    m_nid.szTip = szTip & vbNullChar
    
End Property

'Adds the icon to the system tray.
' Set hIcon and Tip before calling this function Public Sub AddIcon()
    
    Debug.Assert m_bVisible = False
    
    Shell_NotifyIcon NIM_ADD, m_nid
    
    m_bVisible = True
    
End Sub

'Updates the system tray icon to reflect any changes to ' hIcon or Tip Public Sub ModifyIcon()
    
    Debug.Assert m_bVisible
    
    Shell_NotifyIcon NIM_MODIFY, m_nid
    
End Sub

'Removes the system tray icon
Public Sub RemoveIcon()
    
    Debug.Assert m_bVisible
    
    Shell_NotifyIcon NIM_DELETE, m_nid
    
    m_bVisible = False
    
End Sub

Private Sub Class_Initialize()
    
    m_sClass = "VB InTray Class"
    
    'Register a class for, and create the dummy window
    Dim wc As WNDCLASS
    wc.style = 0
    wc.lpfnwndproc = Pass(AddressOf InTrayWndProc)
    wc.hInstance = App.hInstance
    wc.lpszClassName = m_sClass
    RegisterClass wc
    m_hWndHidden = CreateWindowEx(0, m_sClass, "VB InTray Hidde" & _
                 "n Window", 0, 0, 0, 100, 100, 0, 0, 0, ByVal 0)
    
    Dim lpMe As Long
    lpMe = CreateRef(Me)
    SetWindowLong m_hWndHidden, GWL_USERDATA, lpMe
    
    'Initialize the Notify Icon Data structure
    With m_nid
        .cbSize = Len(m_nid)
        .hIcon = 0
        .hwnd = m_hWndHidden
        .szTip = "" & vbNullString
        .uCallbackMessage = WM_USER_SYSTRAY
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uID = 0
    End With
    
End Sub

'Function should only be called from modInTray to process windows ' messages generated from the System Tray Public Sub ProcessMessage(wParam As Long, lParam As Long)
    
    Select Case lParam
        Case WM_MOUSEMOVE
            RaiseEvent MouseMove
        Case WM_LBUTTONDOWN
            RaiseEvent MouseDown(vbLeftButton)
        Case WM_LBUTTONUP
            RaiseEvent MouseUp(vbLeftButton)
        Case WM_LBUTTONDBLCLK
            RaiseEvent DblClick(vbLeftButton)
        Case WM_RBUTTONDOWN
            RaiseEvent MouseDown(vbRightButton)
        Case WM_RBUTTONUP
            RaiseEvent MouseUp(vbRightButton)
        Case WM_RBUTTONDBLCLK
            RaiseEvent DblClick(vbRightButton)
        Case WM_MBUTTONDOWN
            RaiseEvent MouseDown(vbMiddleButton)
        Case WM_MBUTTONUP
            RaiseEvent MouseUp(vbMiddleButton)
        Case WM_MBUTTONDBLCLK
            RaiseEvent DblClick(vbMiddleButton)
    End Select
    
End Sub

Private Sub Class_Terminate()
    
    'Close the dummy window
    SendMessage m_hWndHidden, WM_CLOSE, 0, ByVal 0&
    
    'Remove the icon if it exists
    If m_bVisible Then
        RemoveIcon
    End If
    
    UnregisterClass m_sClass, App.hInstance

End Sub

'This function should only be called from modInTray when the ' TaskBar is recreated (ie, in response to TaskbarCreated) Public Sub RecreateIcon()
    
    If m_bVisible Then
        m_bVisible = False
        AddIcon
    End If
    
End Sub

'End of Class Module: clsInTray
'----------------------------------------------------------------------


'----------------------------------------------------------------------
'Start of Module: modInTray

Option Explicit

'Windows API's
Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" _
        (Class As WNDCLASS) As Long
Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
        (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal _
        lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, _
        ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance _
        As Long, lpParam As Any) As Long Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) _
        As Long
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias _
        "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As _
        NOTIFYICONDATA) As Long
Declare Function RegisterWindowMessage Lib "user32" Alias _
        "RegisterWindowMessageA" (ByVal lpString As String) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As _
        Long) As Long
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 Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal _
        dest As Long, ByVal src As Long, ByVal length As Long) As Long Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long) As Long Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
        ByVal lParam As Long) As Long
Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" _
        (ByVal lpClassName As String, ByVal hInstance As Long) As Long

Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Type WNDCLASS
    style As Long
    lpfnwndproc As Long
    cbClsextra As Long
    cbWndExtra2 As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As Long
    lpszClassName As String
End Type

Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_USER = &H400
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MBUTTONDBLCLK = &H209
Public Const WM_USER_SYSTRAY = WM_USER + 5 Public Const WM_CLOSE = &H10 Public Const GWL_USERDATA = (-21)

'Have we initialized TaskbarRestart yet?
Private m_bMessageInited As Boolean
'Windows message sent out when the taskbar is restarted ' (ie4 and up) Private m_uTaskbarRestart As Long

'Dummy function to allow AddressOf to assign to a variable Public Function Pass(n As Long) As Long
    Pass = n
End Function

'Return a VB object pointed by nPointer
Public Function DeRef(nPointer As Long) As clsInTray
    CopyMemory VarPtr(DeRef), VarPtr(nPointer), 4 End Function

'Creates a pointer to a VB object
Public Function CreateRef(obj As clsInTray) As Long
    CopyMemory VarPtr(CreateRef), VarPtr(obj), 4 End Function

'Destroys a VB object created by DeRef (otherwise the VB's '  reference count would be incorrect) Public Sub DestroyRef(nobj As Long)
    Dim n As Long
    CopyMemory nobj, VarPtr(n), 4
End Sub

'The window procedure for the dummy windows that clsInTray creates Public Function InTrayWndProc(ByVal hwnd As Long, ByVal uMsg As Long, _
       ByVal wParam As Long, ByVal lParam As Long) As Long
    
    Dim lpObj As Long
    Dim obj As clsInTray
    
    If Not m_bMessageInited Then
        InitMessage
    End If
    
    Select Case uMsg
        'Pass WM_USER_SYSTRAY to the clsInTray object
        Case WM_USER_SYSTRAY
            lpObj = GetWindowLong(hwnd, GWL_USERDATA)
            Set obj = DeRef(lpObj)
            obj.ProcessMessage wParam, lParam
            DestroyRef VarPtr(obj)
        'If the TaskBar restarts, let clsInTray know about it
        Case m_uTaskbarRestart
            lpObj = GetWindowLong(hwnd, GWL_USERDATA)
            Set obj = DeRef(lpObj)
            obj.RecreateIcon
            DestroyRef VarPtr(obj)
    End Select
    
    InTrayWndProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
    
End Function

'Register the windows message TaskbarCreated so we can watch for it Private Function InitMessage()
    
    m_bMessageInited = True
    
    m_uTaskbarRestart = RegisterWindowMessage("TaskbarCreated")
    
End Function

'End of Module: modInTray
'----------------------------------------------------------------------

     
        
Sample Usage: 


        
Option Explicit

Private WithEvents SystemTray As clsInTray

Private Sub Form_Load()
    Set SystemTray = New clsInTray
    SystemTray.hIcon = Me.Icon.Handle
    SystemTray.Tip = "My App!"
    SystemTray.AddIcon
End Sub

Private Sub Form_Resize()
    If Me.WindowState = vbMinimized Then
        Me.Visible = False
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SystemTray.RemoveIcon
    Set SystemTray = Nothing
End Sub

Private Sub SystemTray_MouseUp(Button As Integer)
    Me.WindowState = vbNormal
    Me.Visible = True
    SetForegroundWindow Me.hwnd
    MsgBox "You clicked on the system tray icon"
End Sub


c0Title: Ternary QuickSort (Stable, Recursive)
c1Code:
Ternary QuickSort - A modification of QuickSort

' 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: Test for Alpha Characters Only
c1Code:
Although VB has an IsNumeric function, it has no IsAlpha function.
Use this routine whenever you want to determine whether a character or string of characters is alphabetic (A-Z or a-z). Add Case conditions for other characters you�re willing to allow, such as hyphens, apostrophes, or whatever you consider legal:

Public Function IsAlpha(ByVal MyString As String) As Boolean
	Dim i As Long
	' Assume success
	IsAlpha = True
	' Check to be sure
	For i = 1 To Len(MyString)
		Select Case Asc(Mid$(MyString, i, 1))
		Case vbKeyA To vbKeyZ
		Case (vbKeyA + 32) To (vbKeyZ + 32)
		Case vbKeySpace
			' Add more tests to suit
		Case Else
			IsAlpha = False
			Exit For
		End Select
	Next i
End Function

�Jim Pragit, Glen Ellyn, Illinois

=======================================================================

VB3 and up

Level: Beginning

Test for Alpha Characters Only, Part II

I have a much simpler form for the IsAlphaNum function:

Public Function IsAlphaNum(ByVal sString As String) As Boolean
	If Not sString Like "*[!0-9A-Za-z]*" Then IsAlphaNum = True End Function

You can modify this function for other conditions. Simply put the acceptable characters�such as a space, hyphen, or dot�into the square brackets.

�Rick Rothstein, Trenton, New Jersey

===================================================================

VB3 and up

Level: Beginning

Test for Alpha Characters Only, Part III

Traditional testing for alphabetic characters�for example, to restrict characters that can be entered in a textbox�uses the ASCII value of the keypress:

If KeyAscii >=65 And KeyAscii < 113 Then 

However, this test doesn�t allow for international code pages, which might include characters with an ASCII code higher than 113. A more logical definition of an alphabetical character is one that has a distinct upper and lowercase. To test whether some-thing is alphabetic, use this code:

' International IsAlpha character test.
' Returns true if the input letter is
' alphabetical in any code page or language.
Public Function IsAlphaIntl(sChar As String) As Boolean 
	IsAlphaIntl = Not (UCase$(sChar) = LCase$(sChar)) 
End Function 

�Duncan Jones, Caistor, Lincolnshire, England


c0Title: Test for Illegal Characters
c1Code:
Use this fast function to test for the occurrence of nonalphanumeric characters in a string:


Private Declare Function StrSpn Lib "SHLWAPI" Alias "StrSpnW" (ByVal psz As Long, ByVal pszSet As Long) As Long

Public Function IsAlphaNum(ByVal sString As String) As Boolean

       Dim lPos As Long

       Const ALPHA_NUM As String = "abcdefgihjklmnopqrstuvwxyz" & "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"

       ' Returns the first occurrence of nonmatching characters
       lPos = StrSpn(StrPtr(pString), StrPtr(pAlphaNum))

       ' If the return position is not equal to the length of the 
       ' input string, nonalphanumeric chars were found.
       IsAlphaNum = (lPos = Len(sString))

End Function
 

You can easily modify this function to scan for invalid characters by editing the ALPHA_NUM constant so it includes only characters you consider legal. 

Editor�s Note: The StrSpn function relies on the version of shlwapi.dll that ships with Internet Explorer 4.0 and later. Handle errors�and expectations�accordingly.

�Geir Arnesen, Oslo, Norway


c0Title: Test Sending Mail By Telnet
c1Code:
1. You can start a Telnet session by using the Telnet command in the following format: 

Note Press ENTER after you type each line. 
telnet servername portnumber
For example, type: 
telnet mail.contoso.com 25
Note You can replace servername with the IP address or the FQDN of the SMTP server that you want to connect to. Remember to press ENTER after each command. 

If the command works, you receive a response from the SMTP server that is similar to the following: 

220 site.contoso.com Microsoft Exchange Internet Mail Connector <version number of the IMC> 

Note There are different versions of Microsoft SMTP or third party SMTP servers, and you may receive different responses from the receiving server. What is important is that you receive the 220 response with the FQDN of the server and the version of SMTP. Additionally, all versions of Microsoft SMTP include the term "Microsoft" in the 220 response.  

2. Start communication by typing the following command: 
EHLO test.com

Note You can use the HELO command, but EHLO is a verb that exists in the Extended SMTP verb set that is supported in all current Microsoft implementations of SMTP. It is a good idea to use EHLO, unless you believe that there is a problem with the Extended SMTP Verbs. 

If the command is successful, you receive the following response: 
250 OK
 
3. Type the following command to tell the receiving SMTP server who the message is from: 

MAIL FROM:Admin@test.com

Note This address can be any SMTP address that you want, but it is a good idea to consider the following issues: 

a.  Some SMTP mail systems filter messages based on the MAIL FROM: address and may not permit certain IP addresses to connect or may not permit the IP address to send e-mail to the SMTP mail system if the connecting IP address does not match the domain where the SMTP mail system resides. In this example, that domain is test.com.

b.  If you do not use a valid e-mail address when you send a message, you cannot determine if the message had a delivery problem, because the non-delivery report (NDR) cannot reach an IP address that is not valid. If you use a valid e-mail address, you receive the following response from the SMTP server: 

250 OK - MAIL FROM Admin@test.com
 
4. Type the following command to tell the receiving SMTP server whom the message is to. 

Note It is a good idea to always use a valid recipient SMTP address in the domain that you are sending to. For example, if you are sending to john@domain.com, you must be certain that john@domain.com exists in the domain. Otherwise, you will receive an NDR. 

Type the following command with the SMTP address of the person you want to send to: 

RCPT TO: User@Domain.Com

You receive the following response: 

250 OK - Recipient User@ Domain.Com
 
5. Type the following command to tell the SMTP server that you are ready to send data: 

DATA

You receive the following response: 354 Send data. End with CRLF.CRLF
 
6. You are now ready to start typing the 822/2822 section of the message. The user will see this part of the message in their inbox. Type the following command to add a subject line: 

Subject: test message

Press ENTER two times. You do not receive a response from this command. 

Note The two ENTER commands comply with Request for Comments (RFC) 822 and 2822. 822 commands must be followed by a blank line.  

7. Type the following command to add message body text: 
This is a test message you will not see a response from this command. 

8. Type a period (.) at the next blank line, and then press ENTER. You receive the following response: 
250 OK
 
9. Close the connection by typing the following command: 
QUIT
You receive the following response: 
221 closing connection
 
10. Verify that the recipient received the message that you sent. If any error event messages appear in the application event log, or if there are problems receiving the message, check the configuration or the communication to the host.  


Advanced Testing
In addition to the basic testing steps that are listed in this article, you can use a delivery receipt to test mail in both directions. You can use this method to verify that the SMTP server can accept an inbound connection and generate a delivery receipt back to the sender to test outbound connectivity of the SMTP server. 

To request a delivery receipt for the test message, see step 4 in the "Basic Testing" section of this article to make sure that the information provided is a valid e-mail address that can receive the delivery receipt. Then in step 5 in the "Basic Testing" section of this article, type the following command in the Telnet session: 
RCPT TO:User@Site.Domain.Com notify=success,failure


c0Title: TESTING FOR A GIVEN FILE
c1Code:
There are lots of ways to test for whether a given file exists. The most common method is to use the Dir$ function. If Dir$ returns a null string, then the file doesn�t exist. Couldn�t be simpler, right? If an illegal filespec is tested, an error occurs. This function depends on an error to detect file existence, and rather than using Dir$, it uses Name.

Function Exists (ByVal FileSpec$)
    Dim TestSpec$
    Exists = False
    FileSpec = Trim(FileSpec)
    If Right$(FileSpec$, 1) = "\" Or _
        Right$(FileSpec$, 2) = "\." Or _
        Right$(FileSpec$, 3) = "\.." Then

        'Obviously passed a directory not a file!
        'Avoid *MAJOR BUG* with Name function by not
        'trying to rename the root directory.
        Exit Function
    End If

    On Local Error Resume Next
    Name FileSpec As FileSpec
    Select Case Err
        Case 5 'Illegal Function Call
        Case 53 'File Not Found
        Case 58 'File Already Exists (Maybe!)
            TestSpec = Dir$(FileSpec)
            If Len(TestSpec) Then Exists = True
        Case 64 'Bad Filename
        Case 68 'Device Unavailable
        Case 74 'Can�t rename with different drive
        Case 71 'Disk Not Ready
        Case 75 'Path/File Access Error
        Case 76 'Path Not Found
        Case Else
            MsgBox "Unexpected Error " & Err & " in Exists(): " & Error$
    End Select
End Function

Trying to rename a file to its current name generates error 58 �File Already Exists. If the file doesn�t exist, you get error 53 �File Not Found. These errors really tell you something, don�t they? There are a number of other possible errors, however, each revealing something about the filespec. The Exists function lists all the errors and their causes that I�ve been able to track down. Because a directory name generates the same error as a file when attempting to rename it to itself, I call Dir$ into action to confirm that a file and not a directory was passed as the filespec. As presented, Exists is an experimental function. You�d obviously want to trim it down if you want only the final answer. By modifying this function slightly, you could also return the cause of the error, which could help you help the user correct the situation. Also, by passing many different filespecs, you might discover new ways your users could devise to break your program.

�Karl E. Peterson


c0Title: The "Assume no Aliasing" compiler option
c1Code:
A procedure is said to contain aliased values if it refers to the same memory addresses in two or more distinct ways. A typical example is the following procedure: 

Dim g_GlobalVariable As Long
...
Sub ProcWithAliases(x As Long)
    x = x + 1
    g_GlobalVariable = g_GlobalVariable + 1 
End Sub

If the g_GlobalVariable is passed, this procedure is able to modify that variable in two ways, through a direct reference and through the x parameter. Another common variant of aliased values occurs when a procedure expects multiple arguments, and you pass the same variable to two or more of them. 

Alias values are often the effect of poor programming practice, but they are also harmful to optimization. In fact, if you are absolutely sure that your app never makes use of aliased variables, you can turn on the "Assume No Aliasing" advanced compile option. This option informs the compiler that no procedure is able to modify the same memory location in two distinct ways, which enables the compiler to generate more efficient assembly code. More specifically, if this option is enabled, the compiled program tries to cache the value of those variables into CPU registers, which speeds up execution. 

In closing, you don't have an aliased value when: (1) the procedure doesn't refer to any global variable, (2) if the procedure refers to global variables, you never pass the same variable as a ByRef argument to the procedure, (3) if the procedure expects multiple ByRef arguments, you never pass the same variable in two or more of them. If all these requirements are met, you can set the "Assume No Aliasing" compiler options safely and let the compile produce faster code. 





c0Title: THE MOVE METHOD IS FASTER
c1Code:
To move a control or form to a new location, you can set the Left and Top properties to new values:

frmCustomer.Left = frmCustomer.Left + 100
frmCustomer.Top = frmCustomer.Top + 50

Using the Move method, however, is about 40 percent faster:

frmCustomer.Move frmCustomer.Left + 100, frmCustomer.Top + 50


�Paul D. Sherriff/Visual Basic Power Guides


c0Title: The Registry Made Easy
c1Code:
A Classy Way to Bypass the Awkward Registry API

By Romke Soldaat

Compared with the bad old INI files, the Windows registry is not only a safer place for system and application settings, it also offers more ways to store different types of data, and lets you organize your settings in a hierarchical manner. But, unlike the straightforward functions that deal with INI files, the registry API is more complex. You can't just read and write data with a single function call - you must open a key before you can access it, and close the key when you're done with it. That's why Microsoft gave Visual Basic programmers a set of one-step routines that simplify their lives: SaveSetting, GetSetting, GetAllSettings, and DeleteSetting. When you use these statements and functions, you don't have to worry about opening and closing keys; VB takes care of that in the background. The only problem is these routines are too limited for power users. 

VB restricts registry access to the "HKEY_CURRENT_USER\Software\VB and VBA Program Settings" key. There's no way you can use VB to retrieve a value from any other location. Apart from that, VB functions can only cope with string settings. SaveSetting stores numbers as strings, whether you like it or not. If you use GetSetting to retrieve a numeric (i.e. DWORD) value, you're punished with an "Invalid procedure call or argument" error. If you use GetAllSettings, and one or more values under the specified key isn't a string, your code crashes with the same error. And if you call DeleteSetting to delete a key that contains subkeys, again you're accused of being an ignorant programmer. That's bad. 

Wrapping the Win API
These VB limitations force serious developers to stick with the Windows registry API. Fortunately, you can avoid the complexity of these functions by wrapping the nitty-gritty into a class module. Once the class is part of your application, you can create an object, access its properties and methods, and forget about API functions altogether. 

I've explored many Web sites and books for registry classes and libraries, but didn't find a single one that came close to my demands. Most limit themselves to getting and setting string values, just like VB. A few allow for the storage of numeric values, but none I've seen let you deal with environment variables or arrays. And all of them make the mistake of allowing you to overwrite values with new ones of a different data type. 

Most "solutions" (including the ones produced by Microsoft!) were built on the premise that everything in the registry is accessible for any operation. However, under Windows NT/ 2000, parts of the registry may have restricted access rights. So if you simply want to read a value, you shouldn't ask for full access. You might not get any. 

Therefore, I decided to write my own RegOp (short for Registry Operation) class. It's included in the download file (see end of article for details). This article explains how it works, and how you can use it in your applications. 

First, however, let's look at how the registry API works. An extensive description of each API function and its parameters would go beyond the scope of this article, but you can find them on the MSDN CD-ROM, and on the Microsoft Web site. Refer to Listing One for the declarations of the functions involved in the class. 

Registry Basics
The Windows registry is a database that contains settings for the operating system and installed applications. These settings are stored under a number of root keys. The RegOp class supports the three roots you're most likely to use; see FIGURE 1. 

Key name
 Abbr. 
 Contents
 Value
 
HKEY_CLASSES_ROOT
 HKCR
 Names and properties of registered file types and information about ActiveX components. 
 &H80000000
 
HKEY_CURRENT_USER
 HKCU
 Configuration information for the user profile of the currently logged on user. 
 &H80000001
 
HKEY_LOCAL_MACHINE
 HKLM
 Configuration data for the local computer and global software settings. 
 &H80000002
 

FIGURE 1: Registry roots supported by the RegOp class. 

Under each key, the registry contains a tree of subkeys, and each subkey can hold values, identified by unique value names. Each subkey can also hold one unnamed "default" value (which must be a string). Values can be stored in a number of formats. FIGURE 2 provides an overview of the data types supported by the RegOp class. There are other data types, but they're irrelevant for VB programmers, so I'll ignore them here. 

Data types
 Used for storage of
 Constant value
 
REG_SZ
 A fixed-length text string. Boolean (True or False) values and other short text values usually have this data type. 
 1
 
REG_EXPAND_SZ
 A variable-length text string that can include variables that are resolved when an application or service uses the data. 
 2
 
REG_DWORD
 Data represented by a number that is 4 bytes (32 bits) long. Also suitable for Boolean (1 or 0) values. 
 4
 
REG_MULTI_SZ
 Multiple text strings formatted as an array of null-terminated strings, and terminated by two null characters. 
 7
 

FIGURE 2: Registry data types supported by RegOp.

Registry ethics. If you have access to all parts of the registry, you probably don't want to use the "Software\VB and VBA Program Settings" key under HKCU. The commonly accepted rule is that you create a key with your company name under the "Software" key in both HKLM and HKCU. For each application you create a separate key under your company key. The HKLM branch is used for application-specific information (usually created at setup), and user-specific settings go under HKCU. Here's the blueprint: 

HKEY_LOCAL_MACHINE\Software\My Company\My Application
HKEY_CURRENT_USER\Software\My Company\My Application
Opening and Closing Keys
Before you can access a registry key, you must open it. Two API functions let you do this: RegOpenKeyEx and RegCreateKeyEx. The class uses RegCreateKeyEx, because this function automatically creates a key if it doesn't exist, and then opens the key. If the key already exists, the function simply opens it. 

Each of these functions gives you a handle to the open key. You need this handle to access the information under the key. Once you're done, you pass the handle to the RegCloseKey function. 

Access rights and security. Under Windows NT and 2000, a system administrator may restrict access to parts of the registry. The level of restriction is determined by a combination of parameters. If the current Windows version is NT 4.0 or 2000, the RegOp class only asks for access rights that are relevant for the desired operation: KEY_READ to query and enumerate values, KEY_WRITE to create keys and values, and KEY_ALL_ACCESS to delete values or keys. The values of these constants are shown in Listing One. 

Setting, Getting, and Deleting Values
To write a value to the registry, use the RegSetValueEx function. Specify the value name, the data type (one of the values shown in FIGURE 2), the data itself, and a value that specifies the size (in bytes) of the data you're storing. When you save a DWORD value, you specify the data by reference; in all other cases you do it by value.

The RegQueryValueEx function retrieves a value. If you know the data type of the value, you can specify the type directly and retrieve the value from a buffer you've created. If you're not sure about the data type, call the function first to receive the data type in a variable, then call the function again using this variable as the parameter that specifies the data type. The RegOp class, however, bypasses RegQueryValueEx. The first time you query a value, the class retrieves all values under the specified key at once, using the RegEnumValue function. (More about that later.) 

It takes a simple call to the RegDeleteValue function to get rid of a specified value. There are no complicated parameters involved. 

It's a bit trickier to delete an entire key. The RegDeleteKey function works fine under Windows 95/98, but under Windows NT/2000 this function won't delete a key if it contains subkeys. The standard solution is to recursively delete a key. In other words, delete the last branch that doesn't have subkeys, and then go up the tree, deleting every branch on your way until you get to the key you want to delete. That's a cumbersome process. The RegOp class takes a different approach by calling the SHDeleteKey key in the Shlwapi.dll file. This function deletes a key and all its values and subkeys, even under Windows NT/2000. There's a small sticking point: SHDeleteKey works only under Windows NT 4.0, if Internet Explorer 4.0 is also installed (Shlwapi.dll comes standard with Windows 2000). The class checks to see if Shlwapi (short for Shell Lightweight API) is available. If so, it uses the SHDeleteKey function; if not, the SHDeleteKey function is called. 

Enumerations
VB's GetAllSettings function enumerates settings under a specified key, and returns a two-dimensional variant array containing the value names and their associated data. As I mentioned earlier, the function can only access a small portion of the registry, and fails as soon as it finds a value that isn't a string. But we should be able to do one better. 

The registry API comes with two enumeration functions: RegEnumKeyEx enumerates all subkeys of a key, RegEnumValue enumerates all values. Both functions have a dwIndex parameter. The common way to enumerate keys or values is to start with a zero dwIndex value, and increment this value until there are no more subkeys or values. The class does things differently. Before any enumerations take place, it calls the RegQueryInfoKey function, which returns a host of details about a key, including the number of subkeys and values. This allows the class to use a simple For structure to get all keys and values. 

Unlike RegEnumKeyEx, RegEnumValue returns more than just names; it also gives you the data associated with each value name, and the size (in bytes) of the data. The RegOp class calls RegEnumValue the first time you query a value, and creates a mini-database of value names and data in a Dictionary object. The next time you query a value under the same key, the class doesn't have to go back to the registry, but can pull the value directly out of the database. 

What's a Dictionary? 
In their infinite wisdom, our friends in Redmond decided to create something better than a Collection object - and they named it Dictionary. So, if you're an Office programmer, you now have two types of Dictionary objects at your disposal: the spelling Dictionary objects that are part of Word, and the Dictionary object, exposed by VBScript (the Microsoft Visual Basic Scripting Edition). Confused? You're not the only one! 

The VBScript Dictionary object has nothing to do with spelling or grammar. In short, Dictionary is a high-performance data storage object that can contain sets of pairs, each consisting of an item (which can be any data type), and a unique key (usually a string). Unlike a Collection, a Dictionary object exposes an Exists method (so you never have to guess), a CompareMode property (so you can make case-sensitive or case-insensitive searches), and a RemoveAll method. 

There's no space here to discuss all the ins and outs of the Dictionary object, so I'll limit myself to the basics as they're used in the RegOp class. The class uses Dictionary as the database that contains the names and data of all values under a key. To create a Dictionary object, you call the CreateObject function. In the following example, the object variable is named ValueList:

Set ValueList = CreateObject("Scripting.Dictionary") 
To add pairs of keys and items, you can use the Add method, but you don't have to. If you assign a value to a key that doesn't exist, the Dictionary object creates the key automatically. The following instructions have the same result: 

ValueList.Add "MyValueName", "MyValue" 
  ValueList("MyValueName") = "MyValue" 
The advantage of the second syntax is that it allows you to replace the item associated with an existing key (the first line will generate an error if there is already a "MyValueName" key). 

Once you've added your key/item pairs to Dictionary, the Count property tells you how many pairs are stored. The Keys and Item methods return arrays containing all existing keys and items, respectively. 

Since Dictionary indexes all data alphabetically by key names, you can make very fast searches and retrievals, as shown here: 

If ValueList.Exists("MyValueName") Then_
  MsgBox ValueList("MyValueName") 
As I said before, the RegOp class uses Dictionary to store all pairs of value names and values when the first query comes in. From that point onwards, all subsequent values are retrieved from Dictionary. This may be overkill in cases where you want to retrieve only a single value, but it's a serious performance booster if you need more (or all) values from the same registry key. 

Using the RegOp Class
The RegOp class is designed to be easy to use. Once the class module is added to your project, you can create an object with the following instructions: 

With New RegOp
   ' ... properties and methods go here. 
End With
In the first line, the object is created, and the Class_Initialize routine in the module is executed. In the last line, the object is deleted, forcing the Class_Terminate routine to run. 

Specifying the registry address. The minimal information the class needs is the desired location in the registry. This is determined by two properties: Root and Key. These properties must be specified before you use any other property or method. Root is an enumeration value you can pick from a list. The options are listed in FIGURE 1. If you don't specify a value, the class defaults to HKEY_CURRENT_USER. Key is required, and must be a string. Here are two examples: 

' Accessing the Printers key under HKLM. 
.Root = HKEY_LOCAL_MACHINE
.Key = "System\CurrentControlSet\Control\Print\Printers" 
  'Accessing the FrontPage key under HKCU
'(no need to specify a Root value). 
.Key = "Software\Microsoft\FrontPage" 
Setting a value. Once the Root and Key properties are set, you use the Value property to store a value. The name of the value must be specified as an argument, the value itself can be a string, a number, a date, or even an array (more about arrays later). The class analyzes the data type of the value, and stores it in the appropriate format. If you omit the value name, the default value of the specified key is set. In that case the value is saved as a string. Here are some examples: 

' Creating named values. 
.Value("Name") = "Romke"         ' Stored as REG_SZ
.Value("Age") = 52               ' Stored as REG_DWORD
.Value("Windows") = "%windir%"   ' Stored as REG_EXPAND_SZ
.Value("Last Use") = Now         ' Stored as REG_SZ
' Setting the default value of a key: 
.Value = "ABC"                   ' Stored as REG_SZ
Retrieving a value. Evaluate the Value property to obtain the data associated with a value name. The value name must be specified as an argument; if omitted, the default value of the key is returned. The data is returned as a Variant: 

' Retrieving a named value. 
MyName = .Value("Name") 
' Retrieving the default value of a key. 
DefVal = .Value
Deleting a value. Use the DeleteValue method to remove a name/value pair. The value name must be specified as an argument; if omitted, the default value of the key is returned. If you call this method as a function, the return value is True if the deletion was successful, or False if not. For example: 

' Deleting a named value. 
.DeleteValue("Name") 
' Deleting the default value of a key. 
.DeleteValue
' Using DeleteValue as a function. 
If .DeleteValue("Name") = False Then
  MsgBox "Could not delete value" 
End If
Deleting a key. To delete a key and all its descendants, use the DeleteKey method. This method attempts to delete the last component of the key specified with the Key property. If you call this method as a function, the return value is True if the deletion was successful, or False if not. In the following examples, the "My App" key (including all its values and subkeys) is deleted: 

.Key = "Software\My Company\My App" 
.DeleteKey
' Using DeleteKey as a function. 
If .DeleteKey = True Then
  MsgBox "Key successfully deleted" 
End If
Obtaining a list of keys. The AllKeys property returns a Variant array of all subkeys under the key specified with the Key property. If there are no subkeys, AllKeys returns Empty. FIGURE 3 demonstrates how you can use this property to get a list of all local printers. The listing in FIGURE 4 uses a different approach to get the same information. 

Sub GetAllPrinters()
  With New RegOp
    .Root = HKEY_LOCAL_MACHINE
    .Key = _
      "System\CurrentControlSet\Control\Print\Printers" 
     Dim AllPrinters As Variant, i As Integer, Msg As String
    AllPrinters = .AllKeys
     If Not IsEmpty(AllPrinters) Then
       For i = LBound(AllPrinters) To UBound(AllPrinters) 
        Msg = Msg & AllPrinters(i) & vbCr
       Next
      MsgBox Msg
     End If
  End With
End Sub
FIGURE 3: Getting a list of all locally installed printers. The IsEmpty function is called to test for valid entries, and the For loop uses LBound and UBound to obtain the boundaries of the variant array. 

Sub GetAllPrinters2()
  With New RegOp
    .Root = HKEY_LOCAL_MACHINE
    .Key = _
      "System\CurrentControlSet\Control\Print\Printers" 
     Dim MyPrinter As Variant
     If .KeyCount > 0 Then
       For Each MyPrinter In .AllKeys
        Msg = Msg & MyPrinter & vbCr
       Next
      MsgBox Msg
     End If
  End With
End Sub
FIGURE 4: An alternative for the listing in FIGURE 3. The KeyCount property is evaluated, and a For Each loop is used to enumerate the printers. 

Obtaining a list of values. The AllValues property returns a Variant array of all value names and their associated data under a key. If there are no values, AllValues returns Empty. FIGURE 5 demonstrates how you can use this property to retrieve all user settings of Word 2000. 

Sub GetWordOptions()
  With New RegOp
     Dim AllSettings As Variant, i As Integer, Msg As String
    .Key = "Software\Microsoft\Office\9.0\Word\Options" 
    AllSettings = .AllValues
     If Not IsEmpty(AllSettings) Then
       For i = LBound(AllSettings, 1) To_
               UBound(AllSettings, 1) 
        Msg = Msg & AllSettings(i, 0) & " = " & _
              AllSettings(i, 1) & vbCr
       Next
       MsgBox Msg
     End If
  End With
End Sub
FIGURE 5: Getting all Word settings for the current user. Since these values are stored under HKEY_CURRENT_USER, no Root property needs to be specified. 

Storing and Retrieving Arrays
The registry API allows for an interesting data type, called REG_MULTI_SZ. This format lets you store multiple text strings under a single value name. The array is stored in a space-saving binary format. The RegOp class fully supports REG_MULTI_SZ values. 

The Windows concept of an "array" differs from what VB considers an array. Windows wants the substrings to be separated by null characters, and expects two null characters at the end of the string. In other words, we're dealing with a single string, not a real array. 

The class uses the Join function to create the string that contains all the elements of a specified array, and adds two null characters at the end, like this: 

MultiString = _
  Join(OriginalArray, vbNullChar) & String$(2, 0) 
This creates a Windows-friendly string, ready to be stored as a REG_MULTI_SZ value. When this value is retrieved from the registry, the trailing double null characters are removed, and the Split function is used to recreate the array: 

OriginalArray = Left$(MultiString, InStr( _
  MultiString, String$(2, 0)) - 1) 
OriginalArray = Split(OriginalArray, vbNullChar) 
So much for the class internals. Fortunately, you don't have to worry about it; all you have to do is specify an array as the data for a value, and the rest is taken care of. 

How do you use this in your own applications? That depends on your needs and creativity. If your application needs to store several related values for later use, the REG_MULTI_SZ data type saves space in the registry and can speed up data retrieval. For example, if your application has a dialog box (a.k.a. UserForm), you may want to save the dialog box position and size so you can recreate the same view the next time it's displayed. Currently, you probably store the position and size of the dialog as four separate values: 

.Value("Left") = Me.Left
.Value("Top") = Me.Top
.Value("Width") = Me.Width
.Value("Height") = Me.Height
Instead, you can use the Array function, and store all values as a single setting: 

.Value("Display") = _
  Array(Me.Left, Me.Top, Me.Width, Me.Height) 
Here's another example. If your software needs to keep MRU (Most Recently Used) file lists, you could save them in separate values, with names like "File1", "File2", etc. But you're saving space and time if you create an array of file names, and store the array as a single value: 

Dim MRUFile(3) As String
 MRUFile(0) = "Report.doc" 
MRUFile(1) = "Budget.xls" 
MRUFile(2) = "Customers.mdb" 
MRUFile(3) = "Meeting.ppt" 
With New RegOp
  .Key = "Software\Romke\My App" 
  .Value("MRU") = MRUFile
End With
The RegOp class can return REG_MULTI_SZ data in two ways. By default, the class returns the value as a single string, in which the substrings are separated by null characters (the terminating double null characters are removed). If you specify ReturnMultiStringsAsArrays as part of the Options property, the data is returned as an array. The following code demonstrates how you can obtain the array elements, regardless of the Options setting: 

Dim MRUFile As Variant, i As Long
 MRUFile = .Value("MRU") 
If Not IsArray(MRUFile) Then
  MRUFile = Split(MRUFile, vbNullChar) 
End If
For i = LBound(MRUFile) To UBound(MRUFile) 
   Debug.Print MRUFile(i) 
Next
Conclusion
The purpose of this series is to demonstrate that there is a lot more to VBA programming than you may think. With a bit of hacking, you can greatly enhance your Office applications, and facilitate your work as a developer. In this installment, I showed you how you can wrap the complex Windows registry API in a class module, so you only have to deal with some simple properties and methods (summarized in FIGURE 6). Watch this space for more VBA hacks! 

Properties & Methods
   

   Description
 
Root
 Write-only property. Optional Long. Specifies the registry root containing the path specified with the Key property. Must be one of the values in FIGURE 1. If omitted, HKEY_CURRENT_USER is assumed. 
 
Key
 Write-only property. Required string. Specifies the full path to the subkey where registry operations take place. This property must be specified before any of the other properties or methods are used. 
 
Value ( [ValueName])
 Read/write property. Variant. Saves or returns the data associated with ValueName under the subkey specified by the Key property. If ValueName is omitted, the default value for the key is saved or returned. 
 
DeleteValue ( [ValueName])
 Method. Deletes the value specified with ValueName. If ValueName is omitted, the default value for the key is deleted. When called as a function, DeleteValue returns True if the deletion was successful. 
 
DeleteKey
 Method. Deletes the last subkey component (including all its subkeys and values) of the path specified with the Key property. When called as a function, DeleteKey returns True if the deletion was successful. 
 
ValueCount
 Read-only property. Long. Returns the number of values under the subkey specified with the Key property. 
 
KeyCount
 Read-only property. Long. Returns the number of subkeys under the subkey specified with the Key property. 
 
AllValues
 Read-only property. Returns a two-dimensional Variant array of all value names and their values under the key specified with the Key property. If there are no values, AllValues returns Empty, and ValueCount returns zero. 
 
AllKeys
 Read-only property. Returns a Variant array of all subkeys under the key specified with the Key property. If there are no subkeys, AllKeys returns Empty, and KeyCount returns zero. 
 
Options
 Optional write-only property. Long. Lets you change the format in which values are set or returned. This property must be specified before the first Value property is set or evaluated. 

Â·          Use any combination of the following enumeration values: StoreNumbersAsStrings. Saves Integer and Long values as REG_SZ values rather than REG_DWORD values. (Note: any numeric value other than Integer or Long is always stored as a REG_SZ value.) 

Â·          ReturnMultiStringsAsArrays. If the data type is REG_MULTI_SZ, the data is converted into a variant array. You can then use the VB IsArray, LBound, and UBound functions to process the array. If this value isn't set, the data is returned as a single string, in which substrings are separated by null characters. Use the VB Split function to extract individual substrings. 

Â·          ExpandEnvironmentStrings. If the data type is REG_EXPAND_SZ, any substring that refers to an environment-variable (e.g. "%windir%") is replaced with its current value. 

Â·          ShowErrorMessages. Displays a message box when an error occurs. If not set, errors are displayed in the Immediate window. 
 

FIGURE 6: A summary of RegOp properties and methods. 

Dutchman Romke Soldaat was hired by Microsoft in 1988 to co-found the Microsoft International Product Group in Dublin, Ireland. That same year he started working with the prototypes of WinWord, writing his first macros long before the rest of the world. In 1992 he left Microsoft, and created a number of successful add-ons for Office. Living in Italy, he divides his time between writing articles for this magazine, enjoying the Mediterranean climate, and steering his Land Rover through the world's most deserted areas. Romke can be contacted at mailto:romke@soldaat.com.

Begin Listing One - RegOp.cls
Option Explicit
 DefStr S
DefLng H-I, L, N
DefVar V
DefBool B
 Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
End Type
  Private Type SECURITY_ATTRIBUTES
  nLength As Long
  lpSecurityDescriptor As Long
  bInheritHandle As Long
End Type
  ' RegCreateKeyEx creates the specified key. If the key
' already exists, the function opens it. The phkResult
' parameter receives the key handle. 
Private Declare Function RegCreateKeyEx _
   Lib "advapi32.dll" Alias
 "RegCreateKeyExA" ( _
   ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal Reserved As Long, ByVal lpClass As String, _
   ByVal dwOptions As Long, ByVal samDesired As Long, _
  lpSecurityAttributes As SECURITY_ATTRIBUTES, _
  phkResult As Long, lpdwDisposition As Long) As Long
  'RegCloseKey releases a handle to the specified key. 
'(Key handles should not be left open any longer than
'necessary.) 
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
   ByVal hCurKey As Long) As Long
 ' RegQueryInfoKey retrieves information about the specified
'key, such as the number of subkeys and values, the length
'of the longest value and key name, and the size of the
'longest data component among the key's values. 
Private Declare Function RegQueryInfoKey _
   Lib "advapi32.dll" Alias "RegQueryInfoKeyA" ( _
   ByVal hCurKey As Long, ByVal lpClass As String, _
  lpcbClass As Long, ByVal lpReserved As Long, _
  lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, _
  lpcbMaxClassLen As Long, lpcValues As Long, _
  lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, _
  lpcbSecurityDescriptor As Long, _
  lpftLastWriteTime As Long) As Long
  'RegEnumKeyEx enumerates subkeys of the specified open
'key. Retrieves the name (and its length) of each subkey. 
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" _
   Alias "RegEnumKeyExA" (ByVal hCurKey As Long, _
   ByVal dwIndex As Long, ByVal lpName As String, _
  lpcbName As Long, ByVal lpReserved As Long, _
   ByVal lpClass As String, lpcbClass As Long, _
  lpftLastWriteTime As Long) As Long
  'RegEnumValue enumerates the values for the specified open
  'key. Retrieves the name (and its length) of each value, 
'and the type, content and size of the data. 
Private Declare Function RegEnumValue Lib "advapi32.dll" _
   Alias "RegEnumValueA" (ByVal hCurKey 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
  'RegQueryValueEx retrieves the type, content and data for
' a specified value name. Note that if you declare the
' lpData parameter as String, you must pass it By Value. 
Private Declare Function RegQueryValueEx _
   Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
   ByVal hCurKey As Long, ByVal lpValueName As String, _
   ByVal lpReserved As Long, lpType As Long, _
  lpData As Any, lpcbData As Long) As Long
  'RegSetValueEx sets the data and type of a specified
' value under a key. 
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
   Alias "RegSetValueExA" (ByVal hCurKey As Long, ByVal _
  lpValueName As String, ByVal Reserved As Long, _
   ByVal dwType As Long, lpData As Any, _
   ByVal cbData As Long) As Long
  'RegDeleteValue removes a named value from specified key. 
Private Declare Function RegDeleteValue _
   Lib "advapi32.dll" Alias "RegDeleteValueA" ( _
   ByVal hCurKey As Long, ByVal lpValueName As String) _
   As Long
  'RegDeleteKey deletes a subkey. Under Win 95/98, also
'deletes all subkeys and values. Under Windows NT/2000, 
'the subkey to be deleted must not have subkeys. The class
'attempts to use SHDeleteKey (see below) before using
'RegDeleteKey. 
Private Declare Function RegDeleteKey Lib "advapi32.dll" _
   Alias "RegDeleteKeyA" (ByVal hKey As Long, _
   ByVal lpSubKey As String) As Long
  'SHDeleteKey deletes a subkey and all its descendants. 
'Under Windows NT 4.0, Internet Explorer 4.0 or later
'is required. 
Private Declare Function SHDeleteKey Lib "Shlwapi" _
   Alias "SHDeleteKeyA" (ByVal hKey As Long, _
   ByVal lpSubKey As String) As Long
 Private Declare Function LoadLibrary Lib "Kernel32" _
   Alias "LoadLibraryA" (ByVal lpLibFileName As String) _
   As Long
  Private Declare Function FreeLibrary Lib "Kernel32" ( _
   ByVal hLibModule As Long) As Long
  Private Declare Function ExpandEnvStrings Lib "Kernel32" _
   Alias "ExpandEnvironmentStringsA" ( _
   ByVal lpSrc As String, ByVal lpDst As String, _
   ByVal nSize As Long) As Long
  Private Declare Function GetVersionEx Lib "Kernel32" _
   Alias "GetVersionExA" ( _
  lpVersionInformation As OSVERSIONINFO) As Long
  Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_DWORD = 4
Private Const REG_DWORD_LITTLE_ENDIAN = REG_DWORD
Private Const REG_MULTI_SZ = 7
  
' The following values are only relevant under WinNT/2K, 
' and are ignored by Win9x. 
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const STANDARD_RIGHTS_WRITE = &H20000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const SYNCHRONIZE = &H100000
  ' Access right to query and enumerate values. 
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
  KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or _
  KEY_NOTIFY) And (Not SYNCHRONIZE)) 
'Access right to create values and keys. 
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or _
  KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And _
   (Not SYNCHRONIZE)) 
'Access right to create/delete values and keys. 
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
  KEY_QUERY_VALUE Or KEY_SET_VALUE Or _
  KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or _
  KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE)) 
  Private lRequiredAccess Private lPreviousAccess
 'Return values for all registry functions. 
Private Const ERROR_SUCCESS = 0
  'Property variables. 
Private lRoot 'default is HKEY_LOCAL_MACHINE
Private lOptions
Private strKeyName
Private strValueName
Private vData
  'Variables set in GetKeyHandle. 
Private hCurKey
Private nSubKeys
Private nValues
Private lMaxSubKeyLen
Private lMaxValueNameLen
Private lMaxValueLen
  Private bIsWinNT
  Public Enum RegOptions ' variable: lOptions
  StoreNumbersAsStrings = 1
  ReturnMultiStringsAsArrays = 2
  ExpandEnvironmentStrings = 4
  ShowErrorMessages = 8
End Enum
   Public Enum RegRoot ' variable: lRoot
  HKEY_CLASSES_ROOT = &H80000000
  HKEY_CURRENT_USER = &H80000001   ' default
  HKEY_LOCAL_MACHINE = &H80000002
End Enum
  'Message constants. 
Private Const ERROR_NO_KEY As String = _
  "No Key name specified!" 
Private Const ERROR_NO_HANDLE = _
  "Could not open Registry Key!" 
Private Const ERR_MSG_NO_OVERWRITE As String = _
  "Existing value has unsupported data type " & _
  "and will not be overwritten" 
Private Const RETURN_UNSUPPORTED As String = _
  "(unsupported data format)" 
  Private ValueList As Object
  Property Let Root(lProp As RegRoot) 
  ' Don't accept an invalid Root value. 
  Select Case lProp
    Case HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, _
          HKEY_LOCAL_MACHINE
       ' All is well. 
    Case Else
      lRoot = HKEY_CURRENT_USER
  End Select
  If lProp <> lRoot Then
    lRoot = lProp
     If Len(strKeyName) Then
      GetKeyHandle lRoot, strKeyName
     End If
  End If
  lRoot = lProp 
End Property
  Property Let Key(strProp) 
  ' Don't accept an empty key name. 
  If Len(strProp) = 0 Then Exit Property
  If Len(strKeyName) = 0 Then ' first time
    strKeyName = strProp
  ElseIf StrComp(strProp, strKeyName, _
                 vbTextCompare) <> 0 Then
    strKeyName = strProp
    GetKeyHandle lRoot, strKeyName
  Else
  End If
End Property
  Property Let Options(lProp As RegOptions) 
  ' Don't accept an invalid Options value. 
  Select Case lProp
    Case 0 To 15: lOptions = lProp
    Case Else: 
   End Select
End Property
   Property Let Value(Optional ValueName As String, vValue) 
  If IsEmpty(vValue) Then
     Exit Property
   Else
    vData = vValue
   End If
  If bIsWinNT Then lRequiredAccess = KEY_WRITE Or KEY_READ
  If PropertiesOK Then
     ' First see if this is an existing value, and, 
     ' if so, what data type we have here. 
     Dim strBuffer, lBuffer, lType
     If RegQueryValueEx(hCurKey, ValueName, 0, lType, _
        ByVal strBuffer, lBuffer) = ERROR_SUCCESS Then
       ' Make sure our new value is the same data type. 
       Select Case lType
         Case REG_SZ, REG_EXPAND_SZ ' existing string
          vData = CStr(vData) 
         Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
           ' existing long
          vData = CLng(vData) 
         Case REG_MULTI_SZ ' existing array
          vData = CVar(vData) 
         Case Else
          ShowErrMsg ERR_MSG_NO_OVERWRITE
           Exit Property
       End Select
     End If
     If (lOptions And StoreNumbersAsStrings) Then
       If IsNumeric(vData) Then vData = CStr(vData) 
     End If
     ' If nameless "(default)" value: 
     If Len(ValueName) = 0 Then vData = CStr(vData) 
     ' Look at the data type of vData, and store it
     ' in the appropriate registry format. 
     If VarType(vData) And vbArray Then   ' 8192
       Dim sTemp As String
       ' REG_MULTI_SZ values must end with 2 null characters. 
      sTemp = Join(vData, vbNullChar) & String$(2, 0) 
       Call RegSetValueEx(hCurKey, ValueName, 0, _
        REG_MULTI_SZ, ByVal sTemp, Len(sTemp)) 
     Else
       Select Case VarType(vData) 
         Case vbInteger, vbLong
           Call RegSetValueEx(hCurKey, ValueName, 0, _
            REG_DWORD, CLng(vData), 4) 
         Case vbString
           If ContainsEnvString(CStr(vData)) Then
             Call RegSetValueEx(hCurKey, ValueName, 0, _
              REG_EXPAND_SZ, ByVal CStr(vData), _
              Len(vData) + 1) 
           Else
             Call RegSetValueEx(hCurKey, ValueName, 0, _
              REG_SZ, ByVal CStr(vData), Len(vData) + 1) 
           End If
         Case Else ' Store any other data type as string. 
           Call RegSetValueEx(hCurKey, ValueName, 0, _
            REG_SZ, ByVal CStr(vData), Len(vData) + 1) 
       End Select
     End If
     ' Update Value Count. 
     Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, 0, _
       0, 0, nValues, 0, 0, 0, 0) 
     ' Clear the values database. 
    ValueList.RemoveAll
  End If
End Property
 Property Get Value(Optional ValueName As String) As Variant
  With ValueList
     If .Count = 0 Then FillDataList
     If .Exists(ValueName) Then Value = .Item(ValueName) 
  End With
End Property
  Property Get AllValues()As Variant
  If bIsWinNT Then lRequiredAccess = KEY_READ
  If PropertiesOK Then
     If nValues = 0 Then Exit Property
     With ValueList
       If .Count = 0 Then FillDataList
       If .Count Then
         Dim i, vKeys, vItems
        vKeys = .Keys
        vItems = .items
         ReDim vTemp(.Count - 1, 1) 
         For i = 0 To .Count - 1
          vTemp(i, 0) = vKeys(i) 
          vTemp(i, 1) = vItems(i) 
         Next
        AllValues = vTemp
       End If
     End With
  End If
End Property
  Property Get AllKeys()As Variant
  If bIsWinNT Then lRequiredAccess = KEY_READ
  If PropertiesOK Then
     If nSubKeys = 0 Then Exit Property
     Dim i: ReDim vTemp(nSubKeys - 1) 
     For i = 0 To nSubKeys - 1
      strKeyName = String$(lMaxSubKeyLen + 1, 0) 
       If RegEnumKeyEx(hCurKey, i, strKeyName, _
         lMaxSubKeyLen + 1, 0, vbNullString, 0, 0) = _
         ERROR_SUCCESS Then
        vTemp(i) = TrimNull(strKeyName) 
       End If
     Next
    AllKeys = vTemp
  End If
End Property
 Function DeleteValue(Optional ValueName As String) _
   As Boolean
   If bIsWinNT Then lRequiredAccess = KEY_ALL_ACCESS
  If PropertiesOK Then
    DeleteValue = (RegDeleteValue(hCurKey, ValueName) = _
      ERROR_SUCCESS) 
     If DeleteValue Then
       Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, _
        0, 0, 0, nValues, 0, 0, 0, 0) 
      ValueList.RemoveAll
     End If
  End If
End Function
  Function DeleteKey()As Boolean
  If Len(strKeyName) = 0 Then
    ShowErrMsg ERROR_NO_KEY
     Exit Function
  End If
  Dim n, strLastKey
  n = InStrRev(strKeyName, "\") 
  If n > 0 And n < Len(strKeyName) Then
    strLastKey = Mid$(strKeyName, n + 1) 
    strKeyName = Left$(strKeyName, n - 1) 
     If bIsWinNT Then lRequiredAccess = KEY_ALL_ACCESS
     Call GetKeyHandle(lRoot, strKeyName) 
     If hCurKey = 0 Then Exit Function
     If ShlwapiInstalled Then
       ' This should always work. 
      DeleteKey = (SHDeleteKey(hCurKey, strLastKey) = _
        ERROR_SUCCESS) 
     Else
       ' This will only work under Win95/98. 
      DeleteKey = (RegDeleteKey(hCurKey, strLastKey) = _
        ERROR_SUCCESS) 
     End If
     If DeleteKey Then
       Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, _
        nSubKeys, 0, 0, 0, 0, 0, 0, 0) 
      ValueList.RemoveAll
     End If
  End If
End Function
  Property Get ValueCount()As Long
  If PropertiesOK Then ValueCount = nValues
End Property
 Property Get KeyCount()As Long
  If PropertiesOK Then KeyCount = nSubKeys
End Property
  
Private Function PropertiesOK()As Boolean
  If Len(strKeyName) = 0 Then
    ShowErrMsg ERROR_NO_KEY
     Exit Function
  End If
  If lPreviousAccess Then
     If lRequiredAccess <> lPreviousAccess Then _
      CloseCurrentKey
  End If
  If hCurKey = 0 Then Call GetKeyHandle(lRoot, strKeyName) 
  If hCurKey = 0 Then 
    ShowErrMsg ERROR_NO_HANDLE
     Exit Function
  End If
  PropertiesOK = True
End Function
  Private Sub Class_Initialize()
  lRoot = HKEY_CURRENT_USER
  bIsWinNT = IsWinNT
  If bIsWinNT Then lRequiredAccess = KEY_READ
  On Error Resume Next
  Set ValueList = CreateObject("Scripting.Dictionary") 
  If IsObject(ValueList) Then
    ValueList.CompareMode = vbTextCompare
  Else
     End
  End If
End Sub
 Private Sub Class_Terminate()
  CloseCurrentKey
  Set ValueList = Nothing
End Sub
 Private Sub CloseCurrentKey()
  If hCurKey Then
     Call RegCloseKey(hCurKey) 
    hCurKey = 0
  End If
End Sub
 Private Sub GetKeyHandle(lKey, strKey) 
  CloseCurrentKey
  If lKey = 0 Then lKey = HKEY_CURRENT_USER
  Dim SA As SECURITY_ATTRIBUTES
  Call RegCreateKeyEx(lKey, strKey, 0, vbNull, 0, _
    lRequiredAccess, SA, hCurKey, 0) 
   If hCurKey Then
     Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, _
      nSubKeys, lMaxSubKeyLen, 0, nValues, _
      lMaxValueNameLen, lMaxValueLen, 0, 0) 
    ValueList.RemoveAll
    lPreviousAccess = lRequiredAccess
   End If
End Sub
 Private Function TrimNull(ByVal strIn) As String
  TrimNull = Left$(strIn, InStr(strIn, vbNullChar) - 1) 
End Function
  Private Function TrimDoubleNull(ByVal strIn) As String
  If Len(strIn) Then _
    TrimDoubleNull = _
      Left$(strIn, InStr(strIn, String$(2, 0)) - 1) 
End Function
  Private Function ExpandString(strIn) As String
  Dim nChars, strBuff, nBuffSize
  nBuffSize = 1024
  strBuff = String$(nBuffSize, 0) 
  nChars = ExpandEnvStrings(strIn, strBuff, nBuffSize) 
  If nChars Then ExpandString = Left$(strBuff, nChars - 1) 
End Function
 Private Function ShlwapiInstalled()As Boolean
  Dim hLib As Long
  hLib = LoadLibrary("Shlwapi") 
  If hLib Then
    ShlwapiInstalled = True
    FreeLibrary hLib
  End If
End Function
 Private Function ContainsEnvString(ByVal strTest) _
   As Boolean
   Const PCT As String = "%" 
  ' See if there is a percent sign. 
  Dim n As Long:
n = InStr(strTest, PCT) 
  If n = 0 Then Exit Function
  ' See if there is a second percent sign. 
  If n = InStrRev(strTest, PCT) Then Exit Function
  ' Now we have a potential environment string. 
  Dim Env As String, EnvSplit()As String
  Dim i As Long
  For i = 1 To 100
    Env = Environ(i) 
     If Len(Env) Then
      EnvSplit = Split(Env, "=") 
       If InStr(1, strTest, PCT & EnvSplit(0) & PCT, _
               vbTextCompare) Then
        ContainsEnvString = True
         Exit For
       End If
     Else
       Exit For
     End If
  Next
End Function
 Private Sub ShowErrMsg(strMsg) 
  If (lOptions And ShowErrorMessages) Then
    MsgBox strMsg, vbExclamation, "Registry Error" 
  Else
     Debug.Print strMsg
  End If
End Sub
  Private Function IsWinNT()
  ' Returns True if the OS is Windows NT/2000. 
  Const VER_PLATFORM_WIN32_NT As Long = 2
  Dim osvi As OSVERSIONINFO
  osvi.dwOSVersionInfoSize = Len(osvi) 
  GetVersionEx osvi
  IsWinNT = (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT) 
End Function
  Private Sub FillDataList(Optional Key As String)
  If Len(Key) Then strKeyName = Key
  If Len(strKeyName) = 0 Then _
    ShowErrMsg ERROR_NO_KEY: Exit Sub
  If bIsWinNT Then lRequiredAccess = KEY_READ
  If PropertiesOK Then
     If nValues = 0 Then Exit Sub
    ValueList.RemoveAll
     Dim i, lValuename, lType, lBuffer, strValue, strBuffer
     For i = 0 To nValues - 1
      lValuename = lMaxValueNameLen + 1
      strValue = String$(lValuename, 0) 
      lBuffer = lMaxValueLen + 1
      strBuffer = String$(lBuffer, 0) 
       If RegEnumValue(hCurKey, i, strValue, lValuename, _
         0, lType, ByVal strBuffer, lBuffer) = _
         ERROR_SUCCESS Then
        strValue = TrimNull(strValue) 
         Select Case lType
           Case REG_SZ
            ValueList(strValue) = TrimNull(strBuffer) 
           Case REG_EXPAND_SZ
             If (lOptions And ExpandEnvironmentStrings) Then
              ValueList(strValue) = _
                ExpandString(TrimNull(strBuffer)) 
             Else
              ValueList(strValue) = TrimNull(strBuffer) 
             End If
           Case REG_MULTI_SZ
             If (lOptions And _
                ReturnMultiStringsAsArrays) Then
              ValueList(strValue) = Split( _
                TrimDoubleNull(strBuffer), vbNullChar) 
             Else
              ValueList(strValue) = _
                TrimDoubleNull(strBuffer) 
             End If
           Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
             Dim nBuffer
             If RegEnumValue(hCurKey, i, strValue, _
               Len(strValue) + 1, 0, REG_DWORD, nBuffer, _
               4) = ERROR_SUCCESS Then
              ValueList(strValue) = nBuffer
             End If
           Case Else
            ValueList(strValue) = RETURN_UNSUPPORTED
         End Select
       End If
     Next
  End If

End Sub
End Listing One


c0Title: Tile With Lightweight Image Control Arrays
c1Code:
I write apps for companies where computer know-how is at an all-time low. Most applications scare people to death. However, Web-style forms and graphic buttons present soothing enough interfaces that they can be inviting to users.

I wanted my forms to look just like a Web page, so I devised a method to replicate and tile one Image control across a form. To achieve this effect, add an Image control to your form, set its Index to zero, set Visible to False, and set an appropriate background image for the Picture property. Pass your form to the CreateBackground routine during its Load event:
 

Private Sub Form_Load()
       Call CreateBackground(Me)
End Sub


Public Sub CreateBackground(frmCallingParent)

       Dim lTilesY As Long, lTilesX As Long
       Dim lLeft As Long, lTop As Long
       Dim oImg As Image
       Dim X As Integer

       Set oImg = frmCallingParent.Image1(0)

       lTilesX = oImg.Width
       lTilesY = oImg.Height

       Do While lTop < Screen.Height

             X = X + 1
             Load frmCallingParent.Image1(X)
             Set oImg = frmCallingParent.Image1(X)

             With oImg
                    .Left = lLeft
                    .Top = lTop
                    .Visible = True
             End With

             lLeft = lLeft + lTilesX

             If lLeft > Screen.Width Then
                    lLeft = 0
                    lTop = lTop + lTilesY
             End If
       Loop
End Sub


�Craig R. Gray, Clinton Township, Michigan


c0Title: Time/Date Conversions
c1Code:
Option Explicit

'          Time library 1.01
'  Written by Mike D Sutton of EDais
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 19/09/2004
' Last edited: 20/09/2004

'Version history:
'----------------

' Version 1.01 (20/09/2004):
'   Function names changed so as to not conflict with existing API code
'
' Version 1.0 (19/09/2004):
'   GetFileTimes()            - Returns the creation, last accessed and modified times of a file
'   SetFileTimes()            - Sets the creation, last accessed and modified times of a file
'   SystemTimeToVBTime()      - Converts a system time to a VB date type
'   VBTimeToSystemTime()      - Converts a VB date type to a system time
'   FileTimeToSystemTimeVB()  - Converts a 64-bit file time to a system time
'   SystemTimeToFileTimeVB()  - Converts a system time to a 64-bit file time
'   FileTimeToDosDateTimeVB() - Converts a 64-bit file time to a 32-bit DOS date time
'   DosDateTimeToFileTimeVB() - Converts a 32-bit DOS date time to a 64-bit file time
'   CompareFileTimes()        - Compares two file times
'   TimeOnly()                - [Private] Returns time only from date type
'   Millisecond()             - Returns number of milliseconds stored within a date type
'   Second()                  - New version of Second() that doesn't perform bankers rounding when using milliseconds
'   TimeSerial()              - New version of TimeSerial() that includes milliseconds (declared as optional for backwards compatibility)
'-----------------------------'

Private Declare Function GetFileTime Lib "Kernel32.dll" (ByVal hFile As Long, ByRef lpCreationTime As typFileTime, ByRef lpLastAccessTime As typFileTime, ByRef lpLastWriteTime As typFileTime) As Long
Private Declare Function SetFileTime Lib "Kernel32.dll" (ByVal hFile As Long, ByRef lpCreationTime As typFileTime, ByRef lpLastAccessTime As typFileTime, ByRef lpLastWriteTime As typFileTime) As Long
Private Declare Function FileTimeToLocalFileTime Lib "Kernel32.dll" (ByRef lpFileTime As typFileTime, ByRef lpLocalFileTime As typFileTime) As Long
Private Declare Function LocalFileTimeToFileTime Lib "Kernel32.dll" (ByRef lpLocalFileTime As typFileTime, ByRef lpFileTime As typFileTime) As Long
Private Declare Function FileTimeToSystemTime Lib "Kernel32.dll" (ByRef lpFileTime As typFileTime, ByRef lpSystemTime As typSystemTime) As Long
Private Declare Function SystemTimeToFileTime Lib "Kernel32.dll" (ByRef lpSystemTime As typSystemTime, ByRef lpFileTime As typFileTime) As Long
Private Declare Function FileTimeToDosDateTime Lib "Kernel32.dll" (ByRef lpFileTime As typFileTime, ByRef lpFatDate As Integer, ByRef lpFatTime As Integer) As Long
Private Declare Function DosDateTimeToFileTime Lib "Kernel32.dll" (ByVal wFatDate As Integer, ByVal wFatTime As Integer, ByRef lpFileTime As typFileTime) As Long
Private Declare Function CreateFile Lib "Kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByRef lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "Kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CompareFileTime Lib "Kernel32.dll" (ByRef lpFileTime1 As typFileTime, ByRef lpFileTime2 As typFileTime) As Long
Private Declare Function GetFileAttributes Lib "Kernel32.dll" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function SetFileAttributes Lib "Kernel32.dll" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long

Public Type typFileTime
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type typFileTimes
    ftCreation As typFileTime
    ftAccessed As typFileTime
    ftModified As typFileTime
End Type

Public Type typSystemTime
    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

Public Type typDOSDateTime
    ddtFatDate As Integer
    ddtFatTime As Integer
End Type

Public Enum enCompareFileTimeRes
    cfrEarlier = -1
    cfrEqual = 0
    cfrLater = 1
End Enum

Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const OPEN_EXISTING As Long = &H3
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const ERROR_ACCESS_DENIED As Long = 5&
Private Const INVALID_FILE_ATTRIBUTES As Long = -1

Private Const NumHours As Long = 24          ' Hours in a day
Private Const NumMinutes As Long = 60        ' Minutes in an hour
Private Const NumSeconds As Long = 60        ' Seconds in a minute
Private Const NumMilliseconds As Long = 1000 ' Milliseconds in a second

Public Const OneSecond As Date = 1 / NumHours / NumMinutes / NumSeconds
Public Const OneMillisecond As Date = OneSecond / NumMilliseconds

Public Function GetFileTimes(ByRef inFile As String, ByRef outTimes As typFileTimes) As Boolean
    Dim hFile As Long
    
    hFile = CreateFile(inFile, GENERIC_READ, 0&, ByVal 0&, OPEN_EXISTING, 0&, 0&)
    If (hFile <> INVALID_HANDLE_VALUE) Then
        With outTimes
            GetFileTimes = GetFileTime(hFile, .ftCreation, .ftAccessed, .ftModified) <> 0
        End With
        
        Call CloseHandle(hFile)
    End If
End Function

Public Function SetFileTimes(ByRef inFile As String, ByRef inTimes As typFileTimes, _
    Optional ByVal inForceChange As Boolean = True) As Boolean
    Dim hFile As Long
    Dim OldAttrib As Long
    
    hFile = CreateFile(inFile, GENERIC_WRITE, 0&, ByVal 0&, OPEN_EXISTING, 0&, 0&)
    If (hFile <> INVALID_HANDLE_VALUE) Then
        With inTimes
            SetFileTimes = SetFileTime(hFile, .ftCreation, .ftAccessed, .ftModified) <> 0
        End With
        
        Call CloseHandle(hFile)
    Else ' If the file is marked as read-only, temporarily mark it as normal to make the change
        If ((Err.LastDllError = ERROR_ACCESS_DENIED) And inForceChange) Then
            OldAttrib = GetFileAttributes(inFile)
            
            If ((OldAttrib <> FILE_ATTRIBUTE_NORMAL) And _
                (OldAttrib <> INVALID_FILE_ATTRIBUTES)) Then
                If (SetFileAttributes(inFile, FILE_ATTRIBUTE_NORMAL)) Then
                    SetFileTimes = SetFileTimes(inFile, inTimes)
                    Call SetFileAttributes(inFile, OldAttrib)
                End If
            End If
        End If
    End If
End Function

Public Function FileTimeToSystemTimeVB(ByRef inFile As typFileTime, _
    Optional ByVal inToLocal As Boolean = True) As typSystemTime
    Dim LocalTime As typFileTime
    
    If (inToLocal) Then
        Call FileTimeToLocalFileTime(inFile, LocalTime)
        Call FileTimeToSystemTime(LocalTime, FileTimeToSystemTimeVB)
    Else
        Call FileTimeToSystemTime(inFile, FileTimeToSystemTimeVB)
    End If
End Function

Public Function SystemTimeToVBTime(ByRef inTime As typSystemTime) As Date
    With inTime
        SystemTimeToVBTime = DateSerial(.wYear, .wMonth, .wDay) + _
            TimeSerial(.wHour, .wMinute, .wSecond, .wMilliseconds)
    End With
End Function

Public Function VBTimeToSystemTime(ByVal inTime As Date) As typSystemTime
    With VBTimeToSystemTime
        .wYear = Year(inTime)
        .wMonth = Month(inTime)
        .wDayOfWeek = Weekday(inTime)
        .wDay = Day(inTime)
        .wHour = Hour(inTime)
        .wMinute = Minute(inTime)
        .wSecond = Second(inTime)
        .wMilliseconds = Millisecond(inTime)
    End With
End Function

Public Function SystemTimeToFileTimeVB(ByRef inTime As typSystemTime, _
    Optional ByVal inFromLocal As Boolean = True) As typFileTime
    Dim LocalTime As typFileTime
    
    If (inFromLocal) Then
        Call SystemTimeToFileTime(inTime, LocalTime)
        Call LocalFileTimeToFileTime(LocalTime, SystemTimeToFileTimeVB)
    Else
        Call SystemTimeToFileTime(inTime, SystemTimeToFileTimeVB)
    End If
End Function

Public Function FileTimeToDosDateTimeVB(ByRef inTime As typFileTime) As typDOSDateTime
    With FileTimeToDosDateTimeVB
        Call FileTimeToDosDateTime(inTime, .ddtFatDate, .ddtFatTime)
    End With
End Function

Public Function DosDateTimeToFileTimeVB(ByRef inTime As typDOSDateTime) As typFileTime
    With inTime
        Call DosDateTimeToFileTime(.ddtFatDate, .ddtFatTime, DosDateTimeToFileTimeVB)
    End With
End Function

Public Function CompareFileTimes(ByRef inTimeA As typFileTime, ByRef inTimeB As typFileTime) As enCompareFileTimeRes
    CompareFileTimes = CompareFileTime(inTimeA, inTimeB) ' Result relative to time A.
End Function

Private Function TimeOnly(ByVal inDate As Date) As Date
    TimeOnly = inDate - Int(inDate)
End Function

Public Function Millisecond(ByRef inDate As Date) As Long
    Millisecond = (TimeOnly(inDate) * (1 / OneMillisecond)) Mod NumMilliseconds
End Function

Public Function Second(ByVal inDate As Date) As Integer
    Second = Int(TimeOnly(inDate) * (1 / OneSecond)) Mod NumSeconds
End Function

Public Function TimeSerial(ByVal inHour As Integer, ByVal inMinue As Integer, _
    ByVal inSecond As Integer, Optional ByVal inMillisecond As Integer = 0) As Date
    TimeSerial = VBA.TimeSerial(inHour, inMinue, inSecond) + (inMillisecond * OneMillisecond)
End Function


c0Title: Make an ActiveX DLL server
c1Code:
Start a new project and select the project type ActiveX DLL. This creates a class module. Give the class a name. For example, MathServer might be a good name if the DLL will contain math functions. 

Select the Project menu's Properties command. Change the project name to something meaningful like FunctionLibrary. 

Give the class the public functions and routines you want the DLL to support. For example, you might give it a LogN function to calculate logarithms base N.  
 
 
' Return the logarithm of operand in the given base.
Public Function LogN(ByVal operand As Single, ByVal base As Single) As Single
    LogN = Log(operand) / Log(base)
End Function
 
 
 
From the File menu, select the Make Funclib.dll command. 
Now you are ready to use the DLL in another program. 


Start a new program. Select the EXE type. 
Select the Project menu's References command. Find the DLL and select it. It will have the name you gave the project in step 2 (FunctionLibrary in this example). 
In the code, create a new MathServer object and invoke its methods.  
 
 
Private Sub Command1_Click()
	Dim math_server As MathServer
	Dim operand As Single
	Dim base As Single

    operand = CSng(txtOperand.Text)
    base = CSng(txtBase.Text)

    Set math_server = New MathServer
    txtResult.Text = Format$(math_server.LogN(operand, base))
End Sub
 


c0Title: To determine if an object variable is holding a valid reference
c1Code:
Have you ever needed to determine if an object variable is holding a valid reference? TypeName() returns a class name if the object holds a valid reference. It returns the word 'Nothing', if it does not
 
Public function IsObjectValid (obj as object) as boolean
	If typeName (obj) = "Nothing" then IsObjectValid = false Else Isobjectvalid = true
End function


c0Title: Toggle ListView Headers Between Flat and 3-D
c1Code:
Whenever you want a ListView control with flat, nonclickable headers, use this code to toggle the header style. Flat headers don�t give users the impression of sortability that 3-D headers do:


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 LVM_FIRST = &H1000
Private Const LVM_GETHEADER = (LVM_FIRST + 31)
Private Const HDS_BUTTONS = &H2
 
Call ToggleHeader(ListView1.hWnd)
 
Private Sub ToggleHeader(lsvhWnd As Long)
     Dim hHeader As Long, lStyle As Long
     hHeader = SendMessage(lsvhWnd, LVM_GETHEADER, 0, ByVal 0&)
     lStyle = GetWindowLong(hHeader, GWL_STYLE)
     SetWindowLong hHeader, GWL_STYLE, lStyle Xor HDS_BUTTONS
End Sub


�Matt Hart, Tulsa, Oklahoma


c0Title: Toggle ListView Sort Order Like Explorer
c1Code:
The following code will sort a listview column (in Report View) alternately ascending and descending on subsequent clicks:

Code

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ColumnHeader)

	Static iLastSortOrder As Integer
	Static iLastSortKey As Integer
	Static bIsClicked As Boolean

	Dim iSortKey As Integer

	iSortKey = ColumnHeader.Index - 1

 
	'if same column, but not first time clicked...
	If (iSortKey = iLastSortKey) And bIsClicked Then

		'toggle sort order
		iLastSortOrder = iLastSortOrder Xor lvwDescending

	Else

		'different column, or first time here
		iLastSortOrder = lvwAscending
	
	End If

	With ListView1
		.SortOrder = iLastSortOrder
		.SortKey = iSortKey
		.Sorted = True
	End With

	'set flag to say we've been
	bIsClicked = True

	'save sorted column
	iLastSortKey = iSortKey

End Sub


c0Title: Toggle Min/Max Buttons at Run Time
c1Code:
VB4 32, VB5, VB6

Here�s some code that toggles the MinButton and MaxButton
properties of a form at run time. To demonstrate, start a new
project, add two command buttons to the default form, and paste
this code into the form�s code window. One button toggles the
form�s MaxButton, and the other toggles the form�s MinButton.
The code works by flipping the WS_MAXIMIZEBOX and
WS_MINIMIZEBOX window-style bits back and forth. Make a final
call to SetWindowPos to force a redraw of the nonclient area. It will
be useful for Microsoft to drop the notion of �read-only at run time�
properties in VB:


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_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const GWL_STYLE = (-16)
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOSIZE = &H1


Private Sub Command1_Click()
	Dim nStyle As Long

	nStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
	Call SetWindowLong(Me.hWnd, GWL_STYLE, nStyle Xor WS_MAXIMIZEBOX)
	SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
End Sub


Private Sub Command2_Click()
	Dim nStyle As Long

	nStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
	Call SetWindowLong(Me.hWnd, GWL_STYLE, nStyle Xor WS_MINIMIZEBOX)
	SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
End Sub

�S. Partha Sarathy, Chennai, India


c0Title: Toggle Toolbar Captions Using Tag
c1Code:
Many applications have an option to show the toolbars as text and image or text-only. I have seen programmers handle this with two toolbars and show them based on the user�s selection. This code uses only one toolbar. The only requirement is to store the desired Caption in each button�s Tag property. This technique works only if you are not changing the toolbar button�s Tag at run time:

 
' tbmain is the only toolbar. At design time, the 
' caption of buttons are left blank.
Sub HideShowToolbarText(bShowText As Boolean)
     Dim i As Integer
 
     For i = 1 To tbMain.Buttons.Count
          tbMain.Buttons(i).Caption = IIf(bShowText, tbMain.Buttons(i).Tag, "")
     Next i
End Sub
 

Private Sub mnuToolbarImageText_Click()
     mnuToolbarImageText.Checked = Not mnuToolbarImageText.Checked
     HideShowToolbarText (mnuToolbarImageText.Checked)
End Sub


�Kanthi Chonachalarn, Lake In The Hills, Illinois


c0Title: Tokenize Your Strings
c1Code:
I find the strtoken function in C quite powerful. This function strips
tokens off a string-based delimiter in the string. The function
returns the token and stripped string so that the next call to
strtoken returns the next token. This sequence continues until
there are no more tokens, when the string would be empty. Here�s
a function in VB that provides the same functionality:


Public Function StrGetToken(ByRef psString As String, ByVal psDelim As String) As String
	Dim nPos As Long
	Dim sToken As String

	On Error GoTo ERROR_Handler

	sToken = psString

	' Check for empty string
	If (Len(psString)) Then

		' Check for position of delimeter
		nPos = InStr(psString, psDelim)

		' If delimeter is found, strip off token
		If (nPos > 0) Then
			sToken = Left$(psString, nPos - 1)

			' Strip token and delimiter from
			' string passed in
			psString = Mid$(psString, nPos + Len(psDelim))
		Else
			' No delimiter found, set string
			' passed into an empty string
			psString = ""
		End If
	End If

	StrGetToken = sToken
	Exit Function

ERROR_Handler:
	StrGetToken = ""
End Function


Here�s an example of how you might use this function:


Dim s As String

s = "Dim sToken As String"

Do While Len(s)
	Debug.Print StrGetToken(s, " ")
Loop


�Joe Halfman, received by e-mail


c0Title: Toss the Common Dialogs Control
c1Code:
In Chris Barlow�s article �Standardize Your Dialogs� [Getting Started, VBPJ June 1999], he explained the use of the CommonDialog control. However, you don�t need this control to use Windows� common dialog boxes. Microsoft provides a replacement DLL on the VB5 and VB6 CDs. This DLL is half the size of ComDlg32.ocx (64K vs. 126K) and doesn�t require placing a control on a form. And, perhaps best of all, it provides a Center property. See \Tools\Unsupprt\DlgObj on the VB5 CD-ROM (or \VB98\WIZARDS\ PDWIZARD on the VB6 CD-ROM) for installation details.

Add a reference to DlgObjs to your project by selecting Microsoft Dialog Automation Objects from the Project References dialog. This code gets a filename:
 

Public Function GetFilename(WinHandle As Long) As String

       Dim Dlg As ChooseFile

       On Error Resume Next

       Set Dlg = New ChooseFile

       With Dlg

             .Save = True 

             ' We want a Save As dialog box.

             .Center = True 

             ' We want the dialog centered.

             .hWnd = WinHandle ' Need a parent window.

              .HideReadOnly = True 

             ' Don't need the 'Open as Read Only' box.

             .MultiSelect = False 

             ' Don't select multiple files.

              .OverwritePrompt = True 

             ' Ask to overwrite an existing file.

             .Filters.Add "BAS Files (*.bas):*.bas" ' File mask.

             .Filters.Add "All Files (*.*):*.*" ' File mask.

             If .Show Then

                    GetFilename =.Directory & "\" & .filename

             Else

                    GetFilename = ""  ' User pressed Cancel

       End With

       Set Dlg = Nothing

End Function

 

Call GetFilename by passing the handle to the window that acts as the dialog�s parent:

 

Debug.Print GetFilename(Me.hWnd)

�Frank Mokry, Palgrave, Ontario, Canada


c0Title: Translate Color Values Faster
c1Code:
This tip is an update to �Translate Color Values,� which appeared in the last edition of this supplement [�101 Tech Tips for VB Developers� Supplement to VBPJ, February 1999]. That method converted numbers to strings, then performed string manipulation to get individual RGB values. This solution uses a concept near and dear to C programmers�unions�and is an order of magnitude faster.

With the RGB function, VB provides a neat and valuable tool for converting separate Red, Green, and Blue values into a single Long color value. However, VB doesn�t provide any way to convert this color value back to its constituent RGB values. Enter the much-feared LSet command, which copies the storage of one user-defined type (UDT) onto another.

Put this code in a module:

 
Public Type RGB_TYPE
     R As Byte
     G As Byte
     B As Byte
     Filler As Byte
End Type
 
Private Type RGB_FULL_TYPE
     lngRGB As Long
End Type
 
Public Function ToRGB(ByVal vlngColor As Long) As RGB_TYPE
     Dim udtRGBFull As RGB_FULL_TYPE
     udtRGBFull.lngRGB = vlngColor
     ' Poor man's C Union
     LSet ToRGB = udtRGBFull
End Function
 
To use this function, put a picture in a form�s Picture property, and insert this code:

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
     Dim udtRGB As RGB_TYPE
     udtRGB = ToRGB(Point(X, Y))
     With udtRGB
          Me.Caption = "R=" & .R & " G=" & .G & " B=" & .B
     End With
End Sub

Click on different places on the picture. VB3 users must return the values differently, because before VB4 VB didn�t support the return of a UDT.


�Richard Lindauer, Stroudsburg, Pennsylvania


c0Title: Translate OLE_COLOR to Actual RGB Value
c1Code:
Have you ever tried to pass a VB system color constant�such as vbButtonFace�to an API call that asks for a color? I frequently need to use system colors for GDI calls, and prefer to use the VB system color constants. The problem is that GDI doesn�t know what to do with them and the resultant color is always black. The solution is simple: Use the OleTranslateColor API, which takes any of these constants and converts them to literal RGB colors GDI can understand. I usually package the API in a simple wrapper as well:

Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long

Public Function TranslateColor(inCol As OLE_COLOR) As Long
     Dim retCol As Long
     OleTranslateColor inCol, 0&, retCol
     TranslateColor = retCol
End Function


From that point on, simply call TranslateColor() with a system color constant to get the color you need. Furthermore, if a standard RGB value is passed to TranslateColor, it returns unaltered, so you don�t have to worry about whether a color value you�re storing is a system constant or an actual color value.

�Ben Baird, Twin Falls, Idaho


c0Title: Treat a Form Like a Function
c1Code:
Some forms are merely dialog boxes that show something to the user and sometimes get something in return. For example, you might have to create a form that displays a tabulated listbox of information�contacts, for example. The form needs to know which item should be selected initially, and you want to know which item the user chose in the end. You can share this information through public variables, but wrapping the form into a function proves a better way. Create a standard EXE project and add an extra form to it. Place a command button on the first form and a listbox with a button on the second. Place this code in the first form:

 
Private Sub Command1_Click()
       MsgBox Form2.ShowList(4)
End Sub


Place this code in the second form:


Dim iSelectedIndex

Private Sub Command1_Click()
       Me.Hide
End Sub


Private Sub Form_Load()
       Dim i As Long

       For i = 0 To 20
             List1.AddItem "Item " & i
       Next i

       List1.ListIndex = iSelectedIndex

End Sub

 
' This is where the magic happens. Note that we have to 
' display a modal form to prevent the continuation of this 
' function until we are ready.
Public Function ShowList(Initial As Integer) As String

       iSelectedIndex = Initial
       ' Store the parameter for later use

       Me.Show vbModal
       ' Display the form

       ShowList = List1.List(List1.ListIndex)

       ' Return

       Unload Me

End Function


This technique not only lets you avoid using public variables, but it also gives you excellent portability because you can simply copy the form into a different project. None of the code is affected. You have wrapped a form into a function.

�Konstantin Komissarchik, Brier, Washington


c0Title: TRUE Returned From API Functions isn't -1
c1Code:
Win32 definition of True (nonzero) does not match the Visual Basic definition (-1). This means that you must compare the result to zero explicitly when testing the result of API functions. 



c0Title: Turn a Textbox or Label Into a Marquee
c1Code:
Sometimes you need to display information longer than the biggest textbox or label control you can have onscreen. I�ve written a routine that displays a textbox�s or label�s contents in marquee style, with the text moving from right to left. Animate your controls by adding a timer to the form and setting its Interval property to 250 (to update the display four times per second). On each timer tick, pass the control you want to animate to the ShiftChars routine. This routine works by reading the control�s contents, shifting the first character to the end, and reassigning the contents:


Private Sub Timer1_Timer()
       Call ShiftChars(Text1)
       Call ShiftChars(Label1)
End Sub

Private Sub ShiftChars(ctl As Control)

       Dim Buffer As String

       Select Case TypeName(ctl)
             Case "TextBox", "Label"
                    ' Rely on default property to accept/return contents.
                    Buffer = ctl
                    If Len(Buffer) > 1 Then
                           ctl = Mid$(Buffer, 2) & Left$(Buffer, 1)
                    End If
       End Select
End Sub


For a more natural display, make sure your text strings have a trailing space character.

�Rafat Sarosh, Tacoma, Washington


c0Title: Turning screen redraw off for a certain length of time and then back on
c1Code:
iRes=sendmessage(Me.hWnd,WM_SETREDRAW,FALSE,0) 'to turn off 
iRes=sendmessage(Me.hWnd,WM_SETREDRAW,TRUE,0) 'to turn back on again

You might have to force a redraw for all the controls after turning it back on again.

for i = 0 to me.controls.count-1 
me.controls(i).refresh 
next i 
me.refresh

I think u can do the same thing using RedrawWindow in win3.1 but I 've yet to figure out how to call it from VB.

Aside, you might want to add items to a combo/list box while screen/control redraw is off, the vb .additem method clears(the redraw flag I think) so u might want to add the items as follows:

iRes=sendmessage(lst.hwnd,LB_ADDSTRING,0, szStringtoAdd)

This appearantly is much faster than the VB additem when adding a *LOT* of items to a combo/list box while redraw is off, I've heard one person say it can be six times faster! Whether its faster or not you need to add items this way when you've redraw turned off.


c0Title: Undocumented Boolean Field Constant
c1Code:
Consider the Data Definition Language statements: "ALTER TABLE [My Table] ADD COLUMN  [My New Field] Single" and "ALTER TABLE [My Table] ADD COLUMN  [My New Field] Double". According to Microsoft documentation, Double and Single are correct constants for field types dbDouble and dbSingle. Boolean is also indicated as the Type property for dbBoolean, yet "ALTER TABLE [My Table] ADD COLUMN [My New Field] Boolean" doesn�t work. Why?

     Further reading about the Boolean datatype in the DAO documentation declares that Boolean is �A True/False or yes/no value. Boolean values are usually stored in Bit fields in a Microsoft Jet database; however, some databases don�t support this datatype directly.� "ALTER TABLE [My Table] ADD COLUMN  [My New Field] Bit" works. Ironically, nothing is listed in the table of Type properties for dbBit or Bit itself.

�Al Meadows, Oklahoma City, Oklahoma


c0Title: Unhook Subclassing When Windows is Ready
c1Code:
Don�t unhook your Windows procedures from Form_Unload when subclassing forms. When you subclass forms, the hook is often set during Form_Load with code like this:

OriginalProc = SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf MyWindowProc

A common mistake is forgetting to put the corresponding unhook call in your Form_Unload event:

SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf OriginalProc

If you forget to reinstate the old procedure in your Form_Unload event, it�s bye-bye VB. Instead, add this code within your sub-classing procedure:

Select Case Msg
Case WM_NCDESTROY
	If OriginalProc <> 0 Then
		Call SetWindowLong(hWnd, GWL_WNDPROC, OriginalProc)
		OriginalProc=0
	End If
Case ...

This code restores the original procedure automatically when the window is destroyed. To make it even safer, place all your subclassing code in a separate DLL and debug your subclassed forms without worrying about the Integrated Development Envi-ronment
(IDE) crashing. You can always move the code back to your EXE when it�s fully debugged.

�Simon Bryan, Newbury, Berkshire, England


c0Title: Unloading Forms
c1Code:
Compatible With    Visual Basic 4.0

I've seen lot of tips on how to unload forms. The problem with these tips is that they do not take into account that the Sub might be called from the QueryUnload or Unload event of a Form. If it is, then the program will bomb because you cannot unload a Form that is already being, or has been, unloaded.

Code

Public Sub UnloadAllForms(sFormName As String)

Dim Form As Form
     For Each Form In Forms
           If Form.Name <> sFormName Then
                 Unload Form
                 Set Form = Nothing
           End If
     Next Form
End Sub

This simply uses the Forms collection to unload all the forms. It also uses "Set Form = Nothing" to make sure all the memory is released that the Form was using. If you are calling it from a Form, pass it the Form name. Here is an example:

Call UnloadAllForms Me.Name

If you call it from a Sub or Function, use:

Call UnloadAllForms ""

Notice that the sFormName is not optional. This way you won't forget to pass it the Form Name.

This tip is reprinted from the VB Tips & Tricks Volume 1 book. 
Parts of this tip was submitted by: David McCarter


c0Title: ADO: Updatable Join Recordset Using ADO and SQL Server
c1Code:
VB4 32, VB5, VB6; SQL Server 6.5 and up; ADO 2.1 and up

Level: Intermediate

Updatable Join Recordset Using ADO and SQL Server

Contrary to popular thought, you can add new records to an ADO
2.1 Recordset object that is the result of a Join operation executed
on multiple-base tables. You must specify the UniqueTable, or the
name of the base table upon which updates, insertions, and
deletions are allowed. This example uses the SQLOLEDB.1 pro-vider
and a disconnected ADO recordset as a bonus:

Private Sub Form_Load()
' You could combine the following 5 steps in
' the .Open method
objRecordset.ActiveConnection = _
objConnection 'An ADO connection object
objRecordset.CursorLocation = adUseClient
' Must use client-side server with this
' property!
objRecordset.CursorType = adOpenStatic
' Must use this with client-sided server cursor
objRecordset.LockType = adLockBatchOptimistic
' Hooking this up to a bound grid in a
' disconnected mode using the Northwind
' database
objRecordset.Open "SELECT * " & _
"FROM Customers JOIN Orders ON " & _
"Customers.CustomerID = " & _
"Orders.CustomerID WHERE city = " & _
"'London' ORDER BY CustomerID"
objRecordset.Properties("Unique Table"). _
Value = "Orders"
objRecordset.Properties("Resync " & _
Command").Value = "SELECT * FROM " & _
"(SELECT * FROM Customers JOIN " & _
"Orders ON Customers.CustomerID = " & _
"Orders.CustomerID WHERE city = " & _
"'London' ORDER BY CustomerID) " & _
"WHERE Orders.OrderID = ?"
objRecordset.ActiveConnection = Nothing
' A disconnected ADO recordset
Set grdTest.Datasource = objRecordset
End Sub
Private Sub Save()
objRecordset.ActiveConnection = _
objConnection
' Reconnect for the purpose of saving only
objRecordset.UpdateBatch
' Don't forget to check the ADO errors
' collection!
objRecordset.ActiveConnection = Nothing
' Disconnect again
End Sub

It�s also imperative that you use the Resync command method to
instruct ADO how to uniquely identify all rows being refreshed. In
this method, you must supply the original Select statement and
append all primary keys of the UniqueTable in a Where clause with
open-ended ("?") tokens as R-values.

�Alexander Meissel, Colorado Springs, Colorado


c0Title: Access: Update a table joined with another table
c1Code:
Update table1 inner join table2 on table1.key = table2.key set table1.value = table2.value where criteria.


c0Title: Use a Visual Basic 6 DLL from VB .NET
c1Code:
In Visual Basic 6, create an ActiveX DLL application. Give it a public class with public methods. This are the methods that the Visual Basic .NET application will be able to call. 
This example builds a project named VB6Project. It has a public class named MyVB6Class with a public subroutine named VB6SayHi and a public function named VB6ReturnHi. 

Compile the project into a DLL. 

Next you need to register the DLL. Select the Start menu's Run command and execute the statement: 

regsvr32 VB6Project.dll

Next start a Visual Basic .NET project. Select the Project menu's Add Reference command. Click the COM tab and find the DLL or click the Browse button to select it. Now the .NET application can use the DLL's public classes as shown in the following code. 
 
 
Private Sub btnCallSubroutine_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnCallSubroutine.Click
    Dim vb6_class As New VB6Project.MyVB6Class
    vb6_class.VB6SayHi()
End Sub

Private Sub btnCallFunction_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnCallFunction.Click
    Dim vb6_class As New VB6Project.MyVB6Class
    MessageBox.Show("Returned: " & vb6_class.VB6ReturnHi())
End Sub


c0Title: Use a Visual Basic DLL file in an Excel spreadsheet
c1Code:
Before you start this, you should consider implementing the DLL's features within Excel using VBA. That is a lot less complicated although a DLL may give you better performance for very complicated calculations. 
In Visual Basic: 


Create a new ActiveX DLL project. 
Change the name of the default class to the name you want your server class to have. For this example, TestClass. 
In the Project menu, select the Properties command at the bottom. 
Set the Project Name to the name you want the server DLL to have. For this example, MyTestServer. 
Set the Project Description to the string you want to see when you select the DLL reference in Excel. For this example, My Test Server. 
In the File menu, select the Make command to compile the DLL. 
In the Excel workbook: 


Open Tools\Macro\Visual Basic Editor. 
In the Tools menu, select References. Locate the server class you created in Visual Basic and select it. If it isn't in the list, click Browse and select the DLL. 
Add a module to the workbook. Create a function that makes an instance of the server class and uses the instance's methods. The following example creates an instance of the TestClass class in the DLL project named MyTestServer. It then calls the object's SquareMe function. 
 
 
' Execute the MyTestServer.TestClass.SquareMe method.
Public Function CallSquareMe(ByVal v As Single) As Single
	Dim obj As MyTestServer.TestClass
    Set obj = New MyTestServer.TestClass
    CallSquareMe = obj.SquareMe(v)
End Function
 
 
Use the function in cell formulas as in: 

=CallSquareMe(C7)


c0Title: Use an Easier Autohighlight Method
c1Code:
Most of us have a routine we call to autohighlight the entire contents of a textbox when it receives focus. And most of us type the name of the textbox when we pass it to this routine. Instead of typing the control�s name in each GotFocus event, you can use this sub to highlight the currently active textbox on the passed form. Place this code in a module:


Sub HiLite(frm As Form)
       frm.ActiveControl.SelStart = 0
       frm.ActiveControl.SelLength = Len(frm.ActiveControl.Text)
End Sub


Then place this line of code in your textbox control�s GotFocus() event:
 

Private Sub Text1_GotFocus()
       HiLite Me
End Sub


Using this code, you can forget about typing your controls� names over and over.

�Achim Wengeler, San Jose, California


c0Title: Use Bitwise Comparison in SQL Server Queries
c1Code:
The newsgroups offer a lot of discussion about bitwise compari-son in SQL statements. VB supports true bitwise arithmetic with And, but SQL supports only a logical AND and returns only TRUE or FALSE. Here�s a quick way to test against a single bit in SQL:

SELECT MyField
FROM MyTable
WHERE (MyTable.MyField \ 2 ^ (MySingleBit - 1) _ MOD 2 = 1)

The \ operator specifies integer division, although you could have used INT (MyTable.MyField / ... ) just as easily. MySingleBit is the bit you want to test: 1,2,3,4,5, and so on. More complicated ways of doing this�such as with table joins�might be faster, but this is about as simple as it gets.

�Merv Pate, Houston, Texas


c0Title: USE BYVAL WHEN API CALLS CAUSE PROBLEMS
c1Code:
If an API call is not achieving the desired or expected effects, try placing ByVal in front of parameters. Likely ones to cause trouble are strings and anything declared "As Any." The APIs that trip people up the most are the various INI file calls, SendMessage, and HMemCpy. Be very suspicious any time a parameter is declared As Any rather than as an explicit type, or if a string isn�t declared ByVal.

�Karl E. Peterson


c0Title: Use DAO Code for Non-Jet Sources
c1Code:
DAO still has a number of features that make it wonderful, especially for ISAM-based apps. For example, it�s simple to use DAO code against non-Jet data sources such as Text(csv) and HTML tables with no MDB linking or importing required. Just use the correct ISAM specifier as part of the OpenDatabase method:

 
Dim db As Database
Dim tDef As TableDef
Dim Fld As Field
Set db = Workspaces(0).OpenDatabase("C:\MyDBFs", _
     False, False, "dBase III;")
For Each tDef In db.TableDefs
     Debug.Print "Table: " & tDef.Name
     For Each Fld In tDef.Fields
          Debug.Print Fld.Name
     Next
Next
db.Close
Set db = Nothing
 
For dBase III, dBase IV, Text, Excel 3 or 4, and HTML sources, the �Database� is the path to the directory in which the �tables� (files) are located. For Excel 5 (Excel 95) and Excel 97, the Database argument must be fully qualified to include the XLS file because later Excel files are workbooks that encapsulate worksheets the way Access encapsulates its tables. For more information, see the VB online help for the Connect (DAO) property and note that the specifier for Excel 97 is �Excel 8.0;� not �Excel97;� as the help page says.

�Robert Smith, Kirkland, Washington


c0Title: Use GetInputState in Loops
c1Code:
Some developers suggest putting DoEvents in loops to keep your application responsive. This is never a good idea. If the loop is short, you don�t need it; if the loop is long, you�ll take an unacceptable performance hit. But what if you want your user to be able to click on a Cancel button or perform some other action while a long loop is executing?

A good compromise is to call GetInputState. This API function returns 1 if the user has clicked on a mouse button or hit a key on the keyboard. The overhead for GetInputState is much less than for DoEvents, so your loop runs faster. If a keyboard or mouse event occurs, then you can call DoEvents. In other words, you call the expensive DoEvents only when you actually need it to process an event. You can further reduce overhead by checking only every x iterations (the exact number being dependent on how time-consuming each loop is):
 

Option Explicit

Private Declare Function GetInputState Lib "user32" () As Long

Private m_UserCancel As Boolean


Private Sub cmdCancel_Click()
       m_UserCancel = True
End Sub


Private Sub cmdGo_Click()

	Dim lCounter As Long

	m_UserCancel = False
	Me.MousePointer = vbHourglass

	For lCounter = 0 To 10000000

		'any long loop that may need to be interrupted

		If lCounter Mod 100 Then
			If GetInputState <> 0 Then
				'a mouse or keyboard event is in the
				'message queue so we call DoEvents 
				'so it can be processed
				DoEvents

				If m_UserCancel Then Exit For
			End If
		End If


		Next lCounter
		Me.MousePointer = vbDefault

End Sub

�Daniel R. Buskirk, Bronx, New York


c0Title: Use IE URL AutoComplete
c1Code:
Add a TextBox to your form called Text1. The Add the following code: 

Add this code to a new BAS Module: 

Option Explicit

Private Declare Function SHAutoComplete Lib "Shlwapi.dll" (ByVal hWndEdit As Long, ByVal dwFlags As Long) As Long

Public Enum SHAC_Constants
    Default = &H0
    FileSystem = &H1
    URLHistory = &H2
    URLMRU = &H4
    URLAll = (&H2 Or &H4)
End Enum

Public Sub AutoComplete(txtItem As TextBox, lngType As SHAC_Constants)
    On Error GoTo ErrHandler
    SHAutoComplete txtItem.hWND, lngType
    Exit Sub
    
ErrHandler:
End Sub

Add this code to your Form_Load Event: 
AutoComplete Text1, Default

Now when you run the project start typing in the TextBox something like "http://" and it should popup a list of items from your URL history just like the DropDown in IE does! 



c0Title: Use IE URL AutoComplete (Complex)
c1Code:
IE5 introduced the AutoComplete feature, and its available for both standard VB text boxes and combo boxes using style 0 or 1. The routine here just demonstrates the textbox, but its easily extended to include the combo by passing the handle of the edit control (not the handle to the combo box - see related topics above). When used with the combo box, the AutoComplete dropdown appears in addition to the standard drop down; its data does not replace the dropdown contents. 
Use of this API is limited to systems with IE5 or greater, so a handy routine for determining the IE version is included. And although the MSDN states that CoInitialize must be called before using this API, and CoUninitialize called when the edit control has been destroyed, VB takes care of handling this task naturally.



'Flags to control the operation of SHAutoComplete.
'The first four are used to override the Internet 'Explorer registry settings. The user can change 'these settings manually by launching the Internet 'Options property sheet from the Tools menu and 'clicking the Advanced tab. The last five can be 'used to specify which files or URLs will be 'available for auto append or autosuggest operations.

'Ignore registry default and force feature on Private Const SHACF_AUTOSUGGEST_FORCE_ON  As Long = &H10000000

'Ignore registry default and force feature off.
Private Const SHACF_AUTOSUGGEST_FORCE_OFF  As Long = &H20000000

'Ignore registry default and force feature on. (Also know as AutoComplete) Private Const SHACF_AUTOAPPEND_FORCE_ON  As Long = &H40000000

'Ignore registry default and force feature off. (Also know as AutoComplete) Private Const SHACF_AUTOAPPEND_FORCE_OFF  As Long = &H80000000

'Currently (SHACF_FILESYSTEM | SHACF_URLALL) Private Const SHACF_DEFAULT  As Long = &H0

'Includes the File System as well as the rest 'of the shell (Desktop\My Computer\Control Panel\) Private Const SHACF_FILESYSTEM  As Long = &H1

'URLs in the User's History
Private Const SHACF_URLHISTORY  As Long = &H2

'URLs in the User's Recently Used list
Private Const SHACF_URLMRU  As Long = &H4

Private Const SHACF_URLALL  As Long = (SHACF_URLHISTORY Or SHACF_URLMRU)

'Identifies the platform for which the DLL was built.
Private Const DLLVER_PLATFORM_WINDOWS As Long = &H1  'Windows 95
Private Const DLLVER_PLATFORM_NT As Long = &H2       'Windows NT

Private Type DllVersionInfo
   cbSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformID As Long
End Type

Private Declare Function SHAutoComplete Lib "shlwapi" _
  (ByVal hwndEdit As Long, _
   ByVal dwFlags As Long) As Long

Private Declare Function DllGetVersion Lib "shlwapi" _
  (dwVersion As DllVersionInfo) As Long


Private Function GetIEVersion(DVI As DllVersionInfo) As Long
   
   DVI.cbSize = Len(DVI)
   Call DllGetVersion(DVI)

   GetIEVersion = DVI.dwMajorVersion
   
End Function


Private Function GetIEVersionString() As String
   
   Dim DVI As DllVersionInfo
   
   DVI.cbSize = Len(DVI)
   Call DllGetVersion(DVI)

   GetIEVersionString = "Internet Explorer " & _
                        DVI.dwMajorVersion & "." & _
                        DVI.dwMinorVersion & "." & _
                        DVI.dwBuildNumber
   
End Function


Private Sub Command1_Click()

   Dim DVI As DllVersionInfo

   If GetIEVersion(DVI) >= 5 Then
   
     'Turn on auto-complete
      Call SHAutoComplete(Text1.hWnd, SHACF_DEFAULT)
      
     'update the captions and set focus to the textbox
      Command1.Caption = "SHAutoComplete is On"
      Command1.Enabled = False
      Text1.SetFocus
      Text1.SelStart = Len(Text1.Text)
   
   Else
   
     'damn!
      MsgBox "Sorry ... you need IE5 to use this demo", vbExclamation
      
   End If
   
End Sub


Private Sub Form_Load()

  'dim a DllVersionInfo type
   Dim DVI As DllVersionInfo

  'display the version of Shlwapi
   Label1.Caption = "Using Shlwapi.dll for " & GetIEVersionString
   
  'if not 5 or greater, can't do it
   Command1.Enabled = GetIEVersion(DVI) >= 5
   Command1.Caption = "SHAutoComplete is Off"

End Sub




c0Title: Use IsLoaded to Check for Forms
c1Code:
The IsLoaded function tests to determine if any instances of a form are already loaded or exist in memory:

 
If IsLoaded("frmMyForm") Then
     Debug.Print "frmMyForm is loaded"
End If
 
Public Function IsLoaded(sForm As String)
     Dim Frm As Form
     For Each Frm In Forms
          If Frm.Name = sForm Then
               IsLoaded = True
               Exit For
          End If
     Next
End Function
 
�Geir Arnesen, Oslo, Norway


c0Title: Use Mid$ on the Left Side of an Assignment
c1Code:
I�m always surprised when VB programmers don�t know an old trick from QuickBASIC: Using the Mid$ function on the left side of an assignment. Here�s an example:
 
Dim sName as string
sName = "Jack Smith, Jr."
Mid$(sName, 6, 5) = "Jones"

When this code is finished, sName contains �Jack Jones, Jr.�. This use of Mid$ is a lot easier�and a lot faster�than the way I�ve seen other VB programmers do the same operation: 

sName = left$(sName, 6) & �Jones� & right$(sName, 4)
 
�Billy Hollis, Nashville, Tennessee


c0Title: Use ObjPtr function to quickly locate an object in a collection
c1Code:
The ObjPtr undocumented function, which returns the address in memory where an object is stored, is typically used by expert developers to perform some low-level tricks. However, in some cases you can take advantage of this function to solve recurring programming problems as well. The Tip Bank hosts additional tips on non-trivial uses for this function, such as Use ObjPtr to test whether two object variables point to the same object or Storing objects in the Tag property. 

Here's the tip:

One of the simplest and most effective uses of the ObjPtr function is to provide a key for quickly locating an object in a Collection Let's suppose you have a collection of objects that doesn't expose a property that can be used as a key to retrieve them in a collection. You can work around this by using the value returned by the ObjPtr function as the key in the collection: 


Dim col As New Collection
Dim obj As CPerson

' create a new CPerson object and add it to the collection Set obj = New CPerson obj.Name = "John Smith"
col.Add obj, CStr(ObjPtr(obj))  'the key must be a string

Because each object has a distinct ObjPtr value, and this value is guaranteed immutable, it is very easily to quickly retrieved it in the collection: 


' remove the object from the collection
col.Remove CStr(ObjPtr(obj))

The same trick can be applied to any type of object, including VB forms and controls, and external objects.


c0Title: Use OLE Drag-and-Drop With a DBGrid Control
c1Code:
It�s easy to drag-and-drop from a DBGrid to Word or Excel, even though DBGrids don�t support OLE Automation. Just add a rich textbox to your form and make it invisible. Also set its OLEDragMode to 0 - rtfOLEDragManual. Then in the DBGrid�s MouseMove event, add this code:

Private Sub DBGrid1_MouseMove(Button As _ Integer, Shift As Integer, X As _ Single, Y As Single) 
	' start the drag from here...
	If Button = vbLeftButton Then
		rtfDrag.OLEDrag
	End If
End Sub

In the rich textbox�s OLEStartDrag event, set up the allowed format and effect:
Private Sub rtfDrag_OLEStartDrag(Data As _ RichTextLib.DataObject, AllowedEffects As Long) ' valid formats and effects Data.SetData , vbCFRTF Data.SetData , vbCFText AllowedEffects = vbDropEffectCopy End Sub In the OLESetData event for the rich textbox, you must generate the data you want to export. You can include tabs, or you can create a table in Word, select it, and drop it on the rich textbox to see what code it generates.

�William Wensley, received by e-mail


c0Title: Use Pointers to Parents
c1Code:
When trying to navigate through a complex class hierarchy from any given instance of an object, it�s useful to be able to reference its parent. But how do you clean up any circular references when terminating the objects? Here is a simple way to retrieve a parent object using the undocumented ObjPtr function in VB:

 
' Code for clsChild Class
Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source  As Any, ByVal numBytes As Long)
 
Private lngParent As Long
 
Property Set Parent(Frm As Form)
     ' obtain a pointer to the object
     lngParent = ObjPtr(Frm)
End Property
 
Property Get Parent() As Form
     Dim frmobj As Form
     CopyMemory frmobj, lngParent, 4
     Set Parent = frmobj
     CopyMemory frmobj, 0&, 4
End Property
 

To test the object�s new Parent property, create a new form and add a button called cmdTest. Place this code in the button�s Click event:

 
Option Explicit
 
Private Sub cmdTest_Click()
     Dim loChild As New clsChild
     With loChild
          Set .Parent = Me
          MsgBox  .Parent.Caption
     End With
End Sub
 
Because the child class only contains the pointer to the parent�s memory, there are no circular references to resolve.

�Jeff Turner, Loami, Illinois 


c0Title: Use Safer International Conversions
c1Code:
I have problems developing applications for non-English�speaking users because of the noninternational behavior of the Val function.
The functions CSng and CDbl provide internationally aware conver-sions, but they don�t work correctly if the argument is empty or contains alpha characters, as can often be the case when converting from nonvalidated TextBox controls. I avoid the errors with this simple function:

Private Function CTxtToSng(sInput As String) As Single ' CTxtToSng at beginning is worth 0 (zero) ' If CSng produces a conversion error, the ' value stays 0 (zero) On Error Resume Next CTxtToSng = CSng(sInput) End Function

You can edit this sample to produce a Double return, if that�s more desirable.

�Giovanni Buommino, Dreieich, Germany


c0Title: Use ScrollBar Instead of UpDown or Spin Controls
c1Code:
If you want the user to be able to select from a fixed range of numeric
values, you have a number of choices. In VB6, you can use the
UpDown control, part of Common Controls 2 (630K), or the Spin
control, part of the Forms 2.0 Object Library (more than 1 MB and
not redistributable). Instead of either of these controls, you can use
a standard vertical ScrollBar to provide the same functionality in
any VB version from VB3 through VB6, without any additional
baggage in your installation.
Place a TextBox (Text1) and a vertical ScrollBar (VScroll1) on
the form, with the ScrollBar touching the right edge of the TextBox.
Make sure that the ScrollBar is the same height as the TextBox, and
that the thumb is not visible. You do not want the user to be able
to change the TextBox value by entering a new value directly, so
you should set the TextBox Locked property to True.
You need to make the ScrollBar work the same way the other
controls do�that is, the value in the TextBox should increment
when the user clicks on the up arrow and decrement when the user
clicks on the down arrow. This is the reverse of normal ScrollBar
behavior, so you must reverse the assignment of the Minimum and
Maximum properties. Set the Minimum property to the highest
value you want the control to have, and set the Maximum property
to the lowest value. You also need to define an increment; the
TextBox value changes by this amount when the user clicks on the
up or down arrow:

Option Explicit
Const MIN_VALUE = 10
Const MAX_VALUE = 100
Const INCREMENT = 10
' Set ScrollBar to act as "up-down" control
Private Sub Form_Load()
With VScroll1
' max < min, so down arrow = decrement,
' up arrow = increment
.Max = MIN_VALUE
.Min = MAX_VALUE
.SmallChange = INCREMENT
' Start at LOWEST value
.Value = .Max
End With
End Sub


When the user changes the ScrollBar by clicking on the up or down
arrow, you need to update the value in the TextBox:


' Updates TextBox value when ScrollBar is changed
Private Sub VScroll1_Change()
Text1.Text = VScroll1.Value
If Me.Visible Then Text1.SetFocus
End Sub


If the input focus is on the ScrollBar, pressing the up and down
arrow keys works just like clicking on the corresponding arrow
button on the ScrollBar. If you want the arrow keys to work the
same way when the input focus is on the TextBox, use this code:


' Change ScrollBar value using up and down
' arrows when TextBox has the input focus
Private Sub Text1_KeyDown(KeyCode As Integer, _
Shift As Integer)
VScroll1.SetFocus
If KeyCode = vbKeyUp Then
SendKeys "{UP}"
ElseIf KeyCode = vbKeyDown Then
SendKeys "{DOWN}"
End If
End Sub


If you hold the arrow key down or keep the up/down button
pressed, the TextBox value continues to update until the upper or
lower limit is reached.


�Eric Schuyler, Snyder, New York


c0Title: Use Split To Get File Names From Paths
c1Code:
Before VB6, here is how we parsed a file name out of a path:

Dim i As Integer
Dim strFileName As String

  For i = Len(Text1.Text) To 1 Step -1
    If Mid(Text1.Text, i, 1) = "\" Then
      strFileName = Right(Text1.Text, Len(Text1.Text) - i)
      Exit For
    End If
  Next

Here is how we do it with VB6:

Dim strArray() As String
Dim strFileName As String

  strArray = Split(Text1.Text, "\")
  strFileName = strArray(UBound(strArray))

Tip Submitted By: Daniel Madden


c0Title: DAO: Use SQL Statement in DAO
c1Code:
When using DAO, if you use a DataControl to populate a bound grid quickly, it�s better to send the control�s RecordSource property a full SQL statement instead of passing a DAO Recordset object reference to the DataControl�s RecordSet property. When you pass a reference to a created Recordset object, the DataControl essentially reverse-engineers the Recordset object to SQL to figure field headers and other information. Once the DataControl hits the 255-character limit, it generates an error that implies there was a problem in your SQL statement (that doesn�t exist). However, if you pass a long and complex SQL string to the control�s RecordSource property, the control doesn�t do any analysis�it simply generates the result and displays it in bound controls.

�Robert Smith, Kirkland, Washington


c0Title: Use System Icons for MsgBox Lookalikes
c1Code:
When VB�s MsgBox function doesn�t provide everything you need, you have to create a message-box�like form. You might find yourself in a quandary if you want to include one of the icons that normally displays in a Windows message box. Instead of getting a screenshot of a standard message box, editing it in Paintbrush to get only the 32-by-32 icon, and loading the resulting bitmap into an image box control on your form, you can use the Windows API to extract these icons from the system directly. Add these declarations to a module in your application:

Private Enum StandardIconEnum
       IDI_ASTERISK = 32516&    ' like vbInformation
       IDI_EXCLAMATION = 32515& ' like vbExlamation
       IDI_HAND = 32513&        ' like vbCritical
       IDI_QUESTION = 32514&    ' like vbQuestion
End Enum

 
Private Declare Function LoadStandardIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconNum As StandardIconEnum) As Long

Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long


Then make your message box�s Paint event look like this:


Private Sub Form_Paint()
       Dim hIcon As Long
       hIcon = LoadStandardIcon(0&, IDI_EXCLAMATION)
       Call DrawIcon(Me.hDC, 10&, 10&, hIcon)
End Sub


The LoadStandardIcon prototype is a tweaked version of the normal LoadIcon prototype, edited to use StandardIconEnum instead of a Long for the lpIconNum parameter.

�Thomas Weiss, Deerfield, Illinois


c0Title: Use Tag Property in SQL Statements
c1Code:
When building SQL statements, use the Tag property to hold the Field Name and Data Format. I use a naming convention of str, int, dat, and so on to determine the datatype; the rest of the tag holds the field name in the database�such as strCompanyName, datStartDate, or intQuantity. This routine iterates through the controls on the form and determines whether the control has a tag (you should tag only the controls that hold data). The routine then checks the type of control�Textbox or MaskedEditBox�to determine whether it should use the Text or FormattedText property. If the control has a value, it builds a string consistent with the datatype. Otherwise, it adds a Null value. After running through the controls, it combines the strings. You can then use the resulting SQL statement to execute an Insert operation into the database:

 

Dim strSQL as String
Dim strColumns as String
Dim strValues as String

strSQL = "INSERT INTO [TableName] "
' start SQL statement
strColumns = "(" 
' hold column names
strValues = "VALUES(" 
' holds corresponding column values
 
For Each ctrl In frmSite.Controls
' iterate thru controls
       If Len(ctrl.Tag) > 0  Then
       ' if no tag, do not use
             strColumns = strColumns & Mid(ctrl.Tag, 4) & ", "   ' add column name
             Select Case TypeName(ctrl)
             ' find control type
                    Case "TextBox", "ComboBox"
                           If Len(ctrl.Text) > 0  Then
                                  Select Case Left(ctrl.Tag) 
                                  ' find datatype, whether to 
                                 ' include single quotes or not
                                        Case "str"
                                           strValues = strValues & "'" & ctrl.Text & "', "
                                        Case "int"
                                           strValues = strValues & ctrl.Text & ", "
                                  End Select
                           Else
                                  strValues = strValues & "Null, "
                           End If
                    Case "MaskEdBox"
                           If Len(ctrl.Text) > 0  Then
                                  Select Case Left$(ctrl.Tag, 3)  
                                 ' find data type, whether to 
                                 ' include single quotes or not
                                        Case "dat", "phn", "ipa"
                                          strValues = strValues & "'" & ctrl.FormattedText & "', "
                                        Case "int"
                                          strValues = strValues & ctrl.FormattedText & ", "
                                  End Select
                           Else
                                  strValues = strValues & "Null, "
                           End If
             End Select
       End If
Next

 
'remove last comma and space
strColumns = Left$(strColumns, Len(strColumns) - 2)
strValues = Left$(strValues, Len(strValues) - 2)

'add last parentheses
strColumns = strColumns & ") "
strValues = strValues & ")"

'combine strings
strSQL = strSQL & strColumns & strValues


�Blake Thomas, Highlands Ranch, Colorado


c0Title: USE THE CONTROLS COLLECTION
c1Code:
If you need to reference every control on a form, using the Controls collection will be faster than referencing every control directly.

For example, if you have four command buttons on a form and you want to set the Enabled property to False for all of them, you have two options.

Option 1:

cmdAdd.Enabled = False
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdNext.Enabled = False
Option 2 will execute approximately 10 to 15 percent faster than Option 1:

For iLoop = 0 To 3
    Controls(iLoop).Enabled = False
Next

�Paul D. Sherriff/Visual Basic Power Guides


c0Title: Use the Immediate Window to Write Repetitive Code
c1Code:
You can stop a program�s execution and use the debug window to generate code you can paste into your program. For example, you have a recordset called rs and you wish to manually move the contents into controls on your form or into declared variables.
Place a breakpoint after you open the recordset, press Ctrl-G to open the Immediate window, and type this:

for each x in rs.Fields : ?"= rs.Fields(""" & _ x.name & """)" : 

next When you press Enter, you get one line per field. The output should resemble this:

= rs.Fields("Edition")
= rs.Fields("Num")
= rs.Fields("Title")
= rs.Fields("ReaderName")
= rs.Fields("ReaderFrom")
= rs.Fields("Bits16")
= rs.Fields("Bits32")
= rs.Fields("Level")
= rs.Fields("Tip")

Copy and paste this output into your code. Now you only need to enter the destination control or variable�s name on the left side of the equal signs. If you have a recordset with a large number of fields, this tip is worth its weight in gold. It prevents typing errors and saves time because the field names are pulled right from the recordset.

�Larry Johnson, Trenton, Georgia


c0Title: Use the ListIndex Property to Store Primary Keys From a Recordset
c1Code:
Here�s an easy way to fill a listbox or combobox with names, then retrieve the UserID of that name. This example loads names into a listbox from a SQL Server stored procedure. When you click on a name in the listbox, the Key value is stored in the lngUserID variable. Then you can use the lngUserID variable in other parts of the program to retrieve related information for the selected name. The names are set up as character fields with the UserID being an AutoNumber field and also the primary key. This tip is valid only if you can translate the field value to a number:

Private Sub Form_Load()
    Call LoadData(List1)
End Sub

Private Sub List1_Click()
    If List1.ListIndex>=0 Then
        lngUserID = List1.ItemData(List1.ListIndex)
    End If
End Sub

Private Sub LoadData(ByRef obj As Object) ' Assumes the Object is either a ListBox or ComboBox 

	Dim com as ADODB.Command 
	Dim rs as ADODB.Recordset 

	Set com=CreateObject("ADODB.Command") 
	Set rs=CreateObject("ADODB.Recordset")

	com.CommandText = "procGetData"
	com.CommandType = adCmdStoredProc
	com.ActiveConnection = strConnect

	Set rs=com.Execute
	obj.Clear

	Do While Not rs.EOF
		obj.AddItem rs!Name
		obj.ItemData(obj.NewIndex) = rs!UserID
		rs.MoveNext
	Loop

	rs.Close
	set rs=Nothing
	set com=Nothing

End Sub

�Steve Ramsey, Tyrone, Pennsylvania


c0Title: Use This Higher-Resolution Stopwatch
c1Code:
Use this code to create a class called HiResTimer:
 
'The number is codified as HighPart*2^32+LowPart

Private Type LARGE_INTEGER
               LowPart As Long
               HighPart As Long
End Type


Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long

Private m_TicksPerSecond As Double
Private m_LI0 As LARGE_INTEGER
Private m_LI1 As LARGE_INTEGER
 

Friend Sub Class_Initialize()
               Dim LI As LARGE_INTEGER
 
               If QueryPerformanceFrequency(LI) <> 0 Then
                              m_TicksPerSecond = LI2Double(LI)
               Else
                              m_TicksPerSecond = -1
               End If
End Sub
 
Friend Property Get Resolution() As Double
               Resolution = 1# / m_TicksPerSecond
End Property
 
Friend Sub EnterBlock()
               QueryPerformanceCounter m_LI0
End Sub
 
Friend Sub ExitBlock()
               QueryPerformanceCounter m_LI1
End Sub
 
Friend Property Get ElapsedTime() As Double
               Dim EnterTime As Double, ExitTime As Double
 
               EnterTime = LI2Double(m_LI0) / m_TicksPerSecond
               ExitTime = LI2Double(m_LI1) / m_TicksPerSecond
               ElapsedTime = ExitTime - EnterTime
End Property
 
Friend Function LI2Double(LI As LARGE_INTEGER) As Double
               Dim Low As Double
               Const TWO_32 = 4# * 1024# * 1024# * 1024#
 
               Low = LI.LowPart
               If Low < 0 Then Low = Low + TWO_32
                              'Now Low is in the range 0...2^32-1
 
                              LI2Double = LI.HighPart * TWO_32 + Low
End Function
 
     Here�s an example of the HiResTimer in use:
 
Dim hrt As HiResTimer, d As Double
Set hrt = New HiResTimer
Debug.Assert hrt.Resolution > 0
MsgBox "Resolution [usecs]:" & hrt.Resolution * 1000000#
 
hrt.EnterBlock
hrt.ExitBlock
MsgBox "Call overhead [usecs]:" & hrt.ElapsedTime * 1000000#
 
hrt.EnterBlock
d = 355# / 113#
hrt.ExitBlock

MsgBox "Elapsed Time [usecs]:" & hrt.ElapsedTime * 1000000#


Believe it or not, you can time even native-compiled code division. For more information, look at the MSDN Library description of the kernel APIs used here. On x86 architectures, resolution is better that 1 microsecond. Be careful, however, of trusting single instance timings, as you�ll find the �resolution� of this performance counter varies over time. In fact, the overhead of simply calling QueryPerformanceCounter in VB is quite a measurable time period itself. 

Although you can time single operations, you�re still better off averaging the time required for hundreds or thousands of similar operations.

�Alessandro Coppo, Rapallo, Italy


c0Title: Use TreeView Control With Checkboxes
c1Code:
When the NodeCheck event triggers, you receive as a parameter the node that was checked. Say you need to do some validation and uncheck the node when there�s an error. You set Node.Checked = False, right? Wrong! That unchecks the node until the NodeCheck event finishes, but at the end of the event, the node changes to its previous value. The reason for that is that the Node parameter is passed ByVal. To work around this problem, add a timer to your form (Interval=50, Enabled=False). Enable the timer in the NodeCheck event:

 

Dim mNode As Node

Private Sub Timer1_Timer()

       Timer1.Enabled = False

       mNode.Checked = False

       Set mNode = Nothing

End Sub

Private Sub TreeView1_NodeCheck(ByVal Node As MSComctlLib.Node)

       If Node.Checked Then

             '...If Invalid Then...

             MsgBox "This Node Cannot be Checked."

             Set mNode = Node

              Timer1.Enabled = True

       End If

End Sub

�Gerardo Villeda, Drexel Hill, Pennsylvania


c0Title: Use UDTs as parameters or return types of public classes
c1Code:
The use of VB classes instead of UDTs to define custom data types was a major leap forward in the evolution of the language. You'd normally define a new class where in older times you used a User-defined type. This doesn't come without a price, though: VB classes have more memory overhead than UDT's and API functions don't understand classes. So, sometimes you just need that UDT. In VB 5.0 there was not a lot you could do: You could not pass UDT's around between classes and you could not assign a UDT to a Variant, meaning that you couldn't collect them in a Collection. As you may have guessed by now, in VB 6.0 you can. 

To define public UDTs and pass them around between classes, the classes need to be instanced as non-private. In other words, you need to wrap up the classes in a dll or Ax exe. You can then define the public UDT in the general declarations section of such a class module. This makes it appear as if the UDT is somehow related to the class, but it's not; the UDT will be effectively global and can be used from anywhere in the server and in clients. Just to prove the point the small example below shows the code for a DogOwner class that has a private member of the UDT Dog and a single read-write property, Dog: 

Option Explicit

'Class m_DogOwner:

Public Type Dog
  Name As String
  Race As String
  Weight As Integer
End Type

Private m_Dog As Dog

Public Property Get Dog() As Dog
  Dog = m_Dog
End Property

Public Property Let Dog(dg As Dog)
  'copy contents of dg to m_Dog
  m_Dog = dg
End Property

You'll note that the UDT is passed ByRef to the property let procedure; VB won't allow it to be passed ByVal.

To set up a client to use the sophisticated DogOwner server, add a reference to the server project in the client. Client code might look something like this: 

Option Explicit

Private m_DogOwner As DogOwner

Private Sub Form_Load()
  
  Set m_DogOwner = New DogOwner
  
  Dim aDog As Dog
  aDog.Name = "Sleepy"
  aDog.Race = "Greenlandic inland dog"
  aDog.Weight = 45
  
  m_DogOwner.Dog = aDog

End Sub

Private Sub Form_Click()
  
  With m_DogOwner.Dog
    Debug.Print .Name; .Race; .Weight
  End With
  
End Sub

You can assign a UDT to a Variant (VarType will return 36). This, in turn, means that you can stuff UDT's into a Collection or Dictionary.


--------------------------------------------------------------------------------

Niels Hede Pedersen, 1999


c0Title: Use UDTs for Irregular Arrays
c1Code:
If you use variable-length strings and/or dynamic arrays in a user-defined type (UDT), the actual data does not become part of the structure. Instead, four-byte pointers are stored in the structure, and the actual data is stored separately. Therefore, it doesn�t matter if the strings and/or arrays in variables A and B are different sizes; the type size is the same, assuming A and B are of the same UDT.

     It also means that if you create an array with a UDT that itself includes dynamic arrays, any �inside� array inside one element of the �outside� array is physically distinct from the corresponding �inside� array of any other �outside� array element. Therefore, code along these lines is perfectly fine:

 
Type AnotherType
     Something As Integer
     SomethingElse As Long
End Type
 
Type SomeType
     Something As Integer
     InsideArr() As AnotherType
     SomethingElse As Long
End Type
 
Sub Test()
     '   set up outside array
     ReDim OutsideArr(1 To 4) As SomeType
     '   set up inside arrays
     ReDim OutsideArr(1).InsideArr(1 To 3)
     ReDim OutsideArr(2).InsideArr(1 To 7)
     ReDim OutsideArr(3).InsideArr(-4 To 0)
     ReDim OutsideArr(4).InsideArr(1 To 3, 2 To 14)
End Sub
 
     You can use this code to create psuedo-multidimensional, nonrectangular arrays, or arrays in which more than one dimension is resized using ReDim Preserve. Both are impossible with ordinary multidimmed arrays.

�Robert Alan Gustafson II, Butler, Pennsylvania


c0Title: Use variables to call functions
c1Code:
Author(s) 
Dev Ashish 
 
How can I call a Function by using a variable instead of Function Name?

Use the Eval Function. If you pass to the Eval function a string that contains the name of a function, the Eval function returns the return value of the function. For example, 
Eval("Chr$(65)") returns "A".

So for example, in the following code,  if you call fEval with "A" as parameter, you should get the result "Test That", else "Test This".

Function fEval(status As String)
	Dim strFunctionName As String
	Dim x

    If status = "A" Then
        strFunctionName = "TestThat()"
    Else
        strFunctionName = "TestThis()"
    End If

    fEval = Eval(strFunctionName)
End Function

Function TestThis()
    Debug.Print "Test This"
End Function

Function testThat()
    Debug.Print "Test That"
End Function


c0Title: Use VC++ to create a DLL file and use its functions in Visual Basic 6
c1Code:
This example shows how to use VC++ to create a DLL file and use its functions in Visual Basic 6. 
 
I have found 2 methods to do this. The first makes the VC++ easier and the Visual Basic messier. The second makes the VC++ harder and the Visual Basic easier. 

Method 1: Easy VC++, Hard VB

VC++: Invoke New\Projects\Win32 Dynamic-Link Library. Enter the directory where you want the VC++ project and the project name (MyFuncsProject in the example). 

VC++: Invoke New\Files\C++ Source File. Check the Add To Project box. Enter the file name (MyFuncs.cpp in the example). 

VC++: Enter the function's source code. Use __declspec (note the two underscores) to export the function's symbol. Use 'extern "C"' to minimize name mangling by VC++. 
 
 
 
// Define DllExport to declare exported symbols.
#define DllExport __declspec( dllexport )

// Prototype the function.
// Use 'extern "C"' to minimize name mangling.
extern "C" DllExport long MyCFunc(long x);

// Define the function.
extern "C" DllExport long MyCFunc(long x)
{
    return x * x;
}
 
 
 
VC++: Set project options using Project\Settings. On the C/C++ tab, select the Code Generation category. Then change Calling Convention to __stdcall. 

VC++: Select Build\Set Active Configuration. Select the Release configuration. Repeat step 4 to make the options apply to the release configuration in addition to the debug configuration. Use Build\Set Active Configuration to reselect the debug configuration if desired. 

VC++: Build the project (press F7 or use the Build menu). This creates the DLL file. 

VB: In your Visual Basic program, declare the DLL function using the DLL file's full path name. The function's name in the DLL file has been slightly mangled by VC++. The name is an underscore, followed by the name you gave it, followed by "@", followed by the number of bytes in the function's argument list. In this example the name is _MyCFunc@4 because the function takes one 4 byte argument (a long integer). 
 
 
 
Private Declare Function MyCFunc Lib _
    "C:\VBHelper\VcDll\Method1\Release\MyFuncsProject.dll" _
    Alias "_MyCFunc@4" _
    (ByVal x As Long) As Long

Private Sub Command1_Click()
Dim x As Long
Dim y As Long

    x = CInt(Text1.Text)
    y = MyCFunc(x)
    Label1.Caption = Str$(y)
End Sub
 
 
 
*** HINT: To quickly determine the mangled name of the function, find the DLL file in Windows Explorer. Right click on the file and select the "Quick View" command. This presents an editor showing information about the DLL. Page down 2 or 3 pages and you will find a list of exported symbols available in the DLL. One of these will be the mangled function name. 


VB: Run the program. 


--------------------------------------------------------------------------------


Method 2, Hard VC++, Easy VB
Steps 1 through 5 are the same as in Method 1. 



VC++: New\Text File. Check the Add To Project box. Enter the file name. Give it a .DEF extension (MyFuncs.def in the example). 

VC++: Enter definition file information that tells VC++ to export the function with the mangled name using the name you want it to have. The following code makes the exported name MyCFunc equivalent to _MyCFunc@4. 
 
 
 
EXPORTS
	MyCFunc=_MyCFunc@4
 
 
 
VC++: Build the project (press F7 or use the Build menu). This creates the DLL file. 
*** HINT: Use Quick View to verify the exported names. Find the DLL file in Windows Explorer. Right click on the file and select the "Quick View" command. Page down 2 or 3 pages and you will find a list of exported symbols available in the DLL. This includes both the mangled name and the name you specified in the .DEF file. 


VB: In your Visual Basic program, declare the DLL function using the DLL file's full path name. Use the name you placed in the .DEF file not the mangled name. 
 
 
 
Private Declare Function MyCFunc Lib _
    "C:\VBHelper\VcDll\Method2\Release\MyFuncsProject.dll" _
    (ByVal x As Long) As Long

Private Sub Command1_Click()
Dim x As Long
Dim y As Long

    x = CInt(Text1.Text)
    y = MyCFunc(x)
    Label1.Caption = Str$(y)
End Sub


c0Title: Use Windowless Controls for Performance and Economy
c1Code:
VB6 comes with an ActiveX control named MSWLESS.ocx (�Microsoft Windowless Controls 6.0�), which contains lightweight equivalents for these standard controls:
 
WLText
WLFrame
WLCommand
WLCheck
WLOption
WLCombo
WLList
WLHScroll
WHVScroll
 
The controls have lower resource consumption than their regular counterparts, as well as better performance. Because they don�t have windows, they don�t have handles or DDE capability, and they can�t serve as containers. They�re also not installed automatically in the Visual Studio 6 setup, so you�ll need to dig them off your CD manually.

�Ron Schwarz, Mt. Pleasant, Michigan


c0Title: Use WithEvents to Communicate Between MDI and MDIChild Forms
c1Code:
Here�s a neat way to pass events such as toolbar clicks and menu selections from an MDIForm to an active MDIChild form. Suppose the MDI parent has a toolbar control called tbrMain. Add this code to the MDIForm:

 

Event ButtonClick(strKey As String)

Private Sub tbrMain_ButtonClick(ByVal Button _

       As MSComctlLib.Button)

       RaiseEvent ButtonClick(Button.Key)

End Sub

 

Then add this code to each MDIChild form you want to receive the custom ButtonClick event:

 

Private WithEvents m_mdiParent As mdiParent

Private Sub Form_Activate()

       Set m_mdiParent = mdiParent

End Sub

Private Sub Form_Deactivate()

       Set m_mdiParent = Nothing

End Sub

Private Sub m_mdiParent_ButtonClick(strKey As String)

       ' Sample code assuming Button.Key values of 

       ' "New", "Change", "Delete" and "Save"

       Select Case strKey

             Case "New"

                    PerformNewAction

             Case "Change"

                    PerformChangeAction

             Case "Delete"

                    PerformDeleteAction

             Case "Save"

                    PerformSaveAction

       End Select

End Sub

 

The effect is almost the same as declaring a control called m_mdiParent that has a ButtonClick event on your form. Use the Activate and Deactivate events to ensure that the active MDIChild is the only one that receives the ButtonClick event.

�Pat Dooley, Cleveland, Ohio


c0Title: USING AUTOTAB WITH A SET MAXLENGTH
c1Code:
To add AutoTab to text boxes that have a set MaxLength, add this code to the text box Change event:

Sub Text1_Change ()
    If Len(Text1) = Text1.MaxLength Then
        SendKeys "{Tab}"
    End If
End Sub

This saves the user one keystroke when moving from one field to the next. It�s best not to intersperse this behavior, but instead to use it on an all-or-nothing basis to prevent massive user confusion.

�Karl E. Peterson


c0Title: Using Drag and Drop with files and folders
c1Code:
In this article I will carry on from last week when I showed you how to search you computer for a specified program. This week I will show you how to allow the user to be able to drag a file or folder onto a list box or textbox and it will display the relative path and file name if you dragged a file. It will also tell you how many files you last dropped to the control on the form.

This is very useful, when you want a number of files, say to check the integrity of the specified file. It also can be used for many other functions, including the path of where certain files are. This can be accomplished by using four Windows API's. Which are: 

  a.. DragAcceptFile
  b.. DragFinish
  c.. DragQueryFile
  d.. PeekMessage
I have included an example of how this works below. If you would like the sample project then click here!

Sample Project

1. Start a new standard EXE project in Visual Basic. Form one is created by default

2. Add a normal module to the project, by clicking on the Project menu and choosing insert module.

3. You will need to declare the following types, by typing the following in to the beginning of the module

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
4. You now need to add the following Windows API calls to the module. Make sure that each API is on one line

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

Public Const PM_NOREMOVE = &H0
Public Const PM_NOYIELD = &H2
Public Const PM_REMOVE = &H1
Public Const WM_DROPFILES = &H233
5. You will now need to add the following procedures to the module.

' This is the sub main procedure, that is called 'for any of the forms are loaded.Sub Main() 'In order for this to function properly you should 'place of of your program execution code in 'the Sub Main(), Make sure you change the project 'startup to sub Main

Form1.Show

'This must be the last line! Nothing gets called 'after this

WatchForFiles

End Sub
Public Sub WatchForFiles()

'This subroutine watchs for all of your WM_DROPFILES 'messages '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

'loop to keep checking for files
'NOTE : Do any code you want to execute before this setDo

'check for Dropped file messages
fileDropped = PeekMessage(FileDropMessage, 0, _ WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD)

If fileDropped Then
    'Get the pointer to the dropped file structure
    hDrop = FileDropMessage.wParam
    
    'Get the toal number of files
    numOfDroppedFiles = DragQueryFile(hDrop, True, _
    filename, 127)
    
    For curFile = 1 To numOfDroppedFiles
    'Get the file name
    
    ret% = DragQueryFile(hDrop, curFile - 1, filename, 127)
    'at this pointer you can do what you want with the 
    'filename the filename will be a full qalified path
    
    Form1.lblNumDropped = LTrim$(Str$(numOfDroppedFiles))
    Form1.List1.AddItem filename
    Next curFile
    
    'We are now done with the structure, tell windows 
    'to discard it
    DragFinish (hDrop)
End If

DoEvents

Loop
End Sub
6. Open up form one. Draw the following 

  a.. 3 command buttons
  b.. 1 list box
  c.. 2 labels - one called "lblNumDropped" 
7. Now open up the code window for form1 and type the following

Private Sub Command1_Click()
'You can turn the form's / controls ability 'to accept the files by passing the hWnd as 'the first parameter and True/False as the 'SecondIf Command1.Caption = "&Accept Files" Then
    'allow the application to accept files
    DragAcceptFiles Form1.hWnd, True
    Command1.Caption = "&Do Not Accept"
Else
    DragAcceptFiles Form1.hWnd, False
    Command1.Caption = "&Accept Files"
End If
End Sub

Private Sub Command2_Click()
'Clears the contents of the list box
List1.Clear
End Sub

Private Sub Command3_Click()
'End the program
End
End Sub

Private Sub Form_Unload(Cancel As Integer) End End Sub

Private Sub List1_Click()
Dim x, y, z
Dim AnyString, MyStr
z = Right(List1.Text, 3) 'Define string.
If z = "EXE" Then
    y = List1.Text
    x = Shell(y, vbNormalFocus)
Else
    y = "Explorer " & List1.Text
    x = Shell(y, vbNormalFocus)
End If
End Sub

Private Sub Form_Load()
Command1.caption = "&Accept Files"
Command2.caption = "Clear"
Command3.caption = "End"
Label1.caption = "The number of files that were " & _ "last dropped on the list box"
End Sub
8. Go into the Project Properties dialog box and change the Startup Object to Sub Main.

9. Now run the project. Click on the Accept files command button. Now drag some files and folder on the list box. They will be disaplyed in the list box. If you click on a file or folder in the list box the folder or file will be opened.

Tip by Steve Anderson


c0Title: Using MAPI
c1Code:
There is also a function, MAPISendMail(), which you can use to send messages, but it is not as easy to use as the SendMail() method in Visual Basic for Applications.

First, take a look at the Microsoft Knowledge Base article:

Q163216: "Updated Mapivb32.bas for Simple MAPI on 32-Bit Platforms" (http://support.microsoft.com/support/kb/articles/Q163/2/16.asp)

This article has the function, data type, and constant declarations. Copy the code from that article into a module in a Visual Basic project. 

On a form in the same project, add a CommandButton and add the following code to its Click event procedure:

Private Sub Command2_Click()
Dim MessageOut As MAPIMessage
Dim Recipients(1) As MapiRecip
Dim Attachments(0) As MapiFile
Dim lResult As Long
'set message main properties
   With MessageOut
     .Reserved = 0
     .NoteText = "this is the message body"
     .FileCount = 0  'no attachments
     .RecipCount = 1  'only 1 recipient
     .Subject = "this is a test message"
     .MessageType = "IPM.Note"
   End With
'set recipients
   With Recipients(0)
     .RecipClass = 1  'To
     .Name = "add your display name here in quotes"
   End With
'set attachments
'not required because message.filecount = 0
      
   lResult = MapiSendMail(0, 0, MessageOut, Recipients, Attachments,
      0, 0&)
   MsgBox lResult
End Sub
The code takes into account a correction listed in the Microsoft Knowledge Base article:

Q163783: "XCLN: MAPISendMail Function Fails in 32-bit VB Environment" (http://support.microsoft.com/support/kb/articles/Q163/7/83.asp)

If the MAPISendMail call returns anything other than 0, you will know there is an error. For a list of the error code meanings, see the Microsoft Knowledge Base article:

Q119647: "PC MAPI: List of MAPI Error Codes" at (http://support.microsoft.com/support/kb/articles/Q119/6/47.asp)


c0Title: Using Multiple Check Boxes
c1Code:
There are two techniques that I have found useful when working with several check boxes on a form. First, it is often a good idea to include an "All" check box that allows the user to select/deselect all of the other check box controls on the form. Second, I assign values to each check box in the form/group as if each control represented a binary digit in a number. Specifically, I use the check box's index property or assigned number as the bit position within a binary-encoded (long) integer. If the check box is checked, the bit value is one; otherwise, it is zero. This is particularly useful when a series a check boxes are used to define program options or defaults. The binary-encoded number can be easily stored in an INI file and used to set the Values for each check box.

I have written two functions that implement these ideas. First, the SetChkBoxes function provides handling for an All-state check box and returns a long integer value indicating which check boxes have been selected. It is passed three parameters; an object array of check boxes, the index value of the all-state check box, and the index value of the current (last to be clicked on) check box. This function requires that there are at least two but not more than 31check boxes in the object array (31 is set as the maximum to avoid overflow erors when creating the binary-encoded long integer which the function returns). This function is called from within the Click event handler of each check box in the object array. Though it is not essential, it is probably easiest to place all of the check boxes that one wishes to control in a control array. The following code demonstrates the use of SetChkBoxes from within a Click event handler:

Sub chkOptions_Click (Index As Integer)

Dim lChkFlags As Long

 

If Not mfUpdating Then

mfUpdating = True

lChkFlags = SetChkBoxes(machkOptions(), Index, 0)

mfUpdating = False

End If

End Sub

Note that the mfUpdating variable (module-level variable) is used to prevent re-entrance into the click event caused by the setting of the check box Value property from within SetChkBoxes. The machkOptions() array is an object array that is defined in the declarations section of the form and is initialized in the Form_Load() procedure (load MULTICHK.MAK in Visual Basic to see how this works).

Here is the code for SetChkBoxes:

Function SetChkBoxes (achkOps() As CheckBox, ByVal iCurChkBox As Integer, ByVal iAllChkBox As Integer) As Long

'----------------------------------------------------------
' Sets the values in a check box object array in
' which one check box, specified by iAllChkBox
' parameter, can change the values of the remaining
' check boxes. The iCurChkBox parameter represents
' the object array index of the last control to be
' clicked on. Note that there must be at least two check
' box controls in the array.
'
' Date Modified:
'------------------------------------------------------
' February 12th, 1995
'
' Parameters:
'--------------------------------------------------------
' achkOps Check box object array
' iCurchkBox Current chk. box index value
' iAllChkBox Position of the "All" check box
'
' Returns (Long) a binary encoded long which
' represents thetotal of all of the
' checked boxes. The value of each check
' box = 2 ^ array index of control.
'------------------------------------------------------------------
'---variable declarations
Dim iCtlIndex As Integer
Dim lReturn As Long
Dim fAllChecked As Integer ' True if all buttons are checked
Dim iLastCtl As Integer ' index of last ctrl. in array
Dim iCtlCount As Integer ' no. of controls in array
Dim iAllValue As Integer ' Value of "All" box
 
'---start of code
SetChkBoxes = 0
lReturn = 0
iLastCtl = UBound(achkOps)
iCtlCount = UBound(achkOps) - LBound(achkOps) + 1
 
' verify parameters
If (iCtlCount < 2) Or (iCtlCount > 31) Then
' too few or too many control boxes in array
Exit Function
End If
If (iAllChkBox < 0) Or (iAllChkBox > iLastCtl) Then
' invalid index for the "all" check box
Exit Function
End If
If (iCurChkBox < 0) Or (iCurChkBox > iLastCtl) Then
' invalid index for the current check box
Exit Function
End If
 
iAllValue = achkOps(iAllChkBox)
 
If iCurChkBox = iAllChkBox Then
' set the value of all the check boxes
' to that of the "All" button.
For iCtlIndex = LBound(achkOps) To iLastCtl
achkOps(iCtlIndex) = iAllValue
Next iCtlIndex
If iAllValue Then lReturn = (2 ^ iCtlCount) - (2 * (iAllChkBox + 1))
Else
fAllChecked = True
For iCtlIndex = LBound(achkOps) To iLastCtl
If iCtlIndex <> iAllChkBox Then
If achkOps(iCtlIndex) = False Then
' not all of the boxes are checked
fAllChecked = False
Else
lReturn = lReturn + (2 ^ iCtlIndex)
End If
End If
Next iCtlIndex
If fAllChecked Then
achkOps(iAllChkBox) = 1
Else
achkOps(iAllChkBox) = 0
End If
End If
'---End of Code

SetChkBoxes = lReturn

End Function

The second routine, SetChkBoxesByValue, sets the check boxes in a passed object array according to a long integer parameter, lChkFlags. It is shown below:

Sub SetChkBoxesByValue (ByVal lChkFlags As Long, iAllChkBox As Integer, achkOps() As CheckBox)

'----------------------------------------------------------
' Sets the check boxes according to the value in lChkFlags
' The parameter lChkFlags is a binary encoded value in which
' each binary digit represents the value of a check box in the
' achkOps() object array.
'
' Date Modified:
'------------------------------------------------------
' February 12th, 1995
'
' Parameters:
'--------------------------------------------------------
' lChkFlags Long binary encoded number
' iAllChkBox Index of the "all" button
' achkOps Check box object array
'
' Returns Nothing
'------------------------------------------------------------------
'---start of code
Dim iCtlCount As Integer
Dim iCtlIndex As Integer
Dim iLastCtl As Integer
Dim lBitValue As Long
 
'---start of code
On Error Resume Next
 
iCtlCount = UBound(achkOps) - LBound(achkOps) + 1
iLastCtl = UBound(achkOps)
 
For iCtlIndex = LBound(achkOps) To iLastCtl
If iCtlIndex <> iAllChkBox Then
If lChkFlags And (2 ^ iCtlIndex) Then
achkOps(iCtlIndex) = 1
Else
achkOps(iCtlIndex) = 0
End If
end If
next iCtlIndex
End Sub

Tip Submitted By: Barth Riley


c0Title: Using Multiple OptionBox or CheckBox Set On The Same Form
c1Code:
A problem that I run into quite a bit revolves around the fact that you cannot have multiple option boxes (even if they are different control arrays) on the same form. This is especially evident when using a tab control because all the controls placed on tabs are stored on one virtual form. This means that as you change an option box on one tab, it is dynamically changing all the option boxes.

The only way that I know around this issue is to put all the option contols into separate frames. This works but may not be practical if you just don't want to use frame controls. The included demo program illustates this problem.

I came up with a solution which uses check boxes as pseudo option boxes. I have shown a way to make them either manditory (at least one option must be selected) or optional (none have to be selected).

To make it happen, I have to use a Global variable called chkOpt:

Global chkOpt As Integer

which will force the code only to be executed once per click. Because I set the values of the controls on/off in the code, they cause recursive calls to themselves which would lead to an 'Out of Stack Space' error message.

The following code should be placed in each checkbox's control array Click event with the For...Next loop to parameter to be changed to be the last member in the control array:

For regular checkbox where entry is manditory:

If chkOpt = True Then 

     chkOpt = False

     If Check1(Index).Value = False Then 'makes entry manditory

      Check1(Index).Value = 1

     End If

     For x = 0 To 3

      If x <> Index Then

           Check1(x).Value = False

      End If

     Next x

     chkOpt = True

End If

For regular checkbox where entry is not manditory:

If chkOpt = True Then 

     chkOpt = False

     For x = 0 To 3 

      If x <> Index Then

           Check2(x).Value = False

      End If

     Next x

     chkOpt = True

End If

For 3D checkbox where entry is manditory:

If chkOpt = True Then 

     chkOpt = False

     If Value = False Then 'makes entry manditory 

      Check3D1(Index).Value = True

     End If

     For x = 0 To 3 

      If x <> Index Then

           Check3D1(x).Value = False

      End If

     Next x

     chkOpt = True

End If

I hope you find this code as useful as I do!

Tip Submitted By: Paul A. Birkbeck


c0Title: Using Playsound to easily add simplex sound support
c1Code:
From time to time, the Win32 API offers up a rare jewel, something that is both easy to use and provides seemingly complex functionality to your applications. The Playsound multimedia API function falls into this category.

Playsound can read files from standard WAV files on disk, by reference from the system registry, or from a resource file. For the application developer, this means that you can create a registry entry for your sound effects, which means that the end user can use the control panel to customize their preferences in sounds. You avoid designing another configuration screen or panel, and the user can still customize the application.

Playsound is also perfect for ActiveX control development. You can add go-faster sound effects to your control with an absolute minimal amount of code and virtually no head-aches. Developers will appreciate the added support of being able to easily include sound events to the controls that you produce.

I admire the simplicity and usefulness of this particular function. I think that after you use it, you may come to the same conclusion.

The only "gotcha" with Playsound is the creation of dwFlag. It is possible to add too many flags, which will result in an overflow error.

Option Explicit

'*-------------------------------------*
'* Playsound flags: store in dwFlags   *
'*-------------------------------------*
' lpszName points to a registry entry
' Do not use SND_RESOURSE or SND_FILENAME Private Const SND_ALIAS& = &H10000 ' Playsound returns immediately ' Do not use SND_SYNC Private Const SND_ASYNC& = &H1 ' The name of a wave file.
' Do not use with SND_RESOURCE or SND_ALIAS Private Const SND_FILENAME& = &H20000 ' Unless used, the default beep will ' play if the specified resource is missing Private Const SND_NODEFAULT& = &H2 ' Fail the call & do not wait for ' a sound device if it is otherwise unavailable Private Const SND_NOWAIT& = &H2000 ' Use a resource file as the source.
' Do not use with SND_ALIAS or SND_FILENAME Private Const SND_RESOURCE& = &H40004 ' Playsound will not return until the ' specified sound has played.  Do not ' use with SND_ASYNC Private Const SND_SYNC& = &H0

Public Enum enSound_Source
    ssFile = SND_FILENAME&
    ssRegistry = SND_ALIAS&
End Enum

' These are common sounds available from the registry Public Const elDefault = ".Default"
Public Const elGPF = "AppGPFault"
Public Const elClose = "Close"
Public Const elEmptyRecycleBin = "EmptyRecycleBin"
Public Const elMailBeep = "MailBeep"
Public Const elMaximize = "Maximize"
Public Const elMenuCommand = "MenuCommand"
Public Const elMenuPopUp = "MenuPopup"
Public Const elMinimize = "Minimize"
Public Const elOpen = "Open"
Public Const elRestoreDown = "RestoreDown"
Public Const elRestoreUp = "RestoreUp"
Public Const elSystemAsterisk = "SystemAsterisk"
Public Const elSystemExclaimation = "SystemExclaimation"
Public Const elSystemExit = "SystemExit"
Public Const elSystemHand = "SystemHand"
Public Const elSystemQuestion = "SystemQuestion"
Public Const elSystemStart = "SystemStart"

Private Declare Function PlaySound& Lib "winmm.dll" Alias_
    "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, _
    ByVal dwFlags As Long)
' hModule is only used if SND_RESOURCE& is set and represents ' an HINSTANCE handle.  This example doesn't support playing ' from a resource file.

--------------------------------------------------------------------------------
' Plays sounds from the registry or a disk file ' Doesn't care if the file is missing Public Function EZPlay(ssname As String, _
    sound_source As enSound_Source) As Boolean
    
    If PlaySound(ssname, 0&, sound_source + _
        SND_ASYNC + SND_NODEFAULT) Then
        EZPlay = True
    Else
        EZPlay = False
    End If
    
End Function

If you want more details about Playsound, you may want to look at Windows 95 API How-To, from Waite Group Press (isbn 1-57169-060-3). Another reference is Programming Windows 95, by Charles Petzold (Microsoft Press, isbn 1-55615-676-6). I'm certain that you'll also find it in Microsoft' Multimedia Programmer's Reference, but I understand that this tome has been out of print for quite sometime. 




c0Title: Using Scrollbars with Pictureboxes
c1Code:
Many programmers have problems with pictureboxes and scrollbars. Here's a solution for that problem:

1. Add to Form1: two pictureboxes (Picture1, Picture2) and one vertical scrollbar (VScroll1). The positions doesn't matter, the objects are positioned automatically by the program. There's only one property that must be set at designtime: AutoRedraw = True of Picture2 (that's very important)!

2. Add following code to Form1

Private Sub Form_Activate()

'Clip image of picture2 to picture1
ScrollPic Picture2, Picture1, VScroll1

End Sub

Private Sub Form_Load()

'Set the properties and positions of the objects With Me .Height = 5000 .Width = 6500 End With

With VScroll1
.Left = 3200
.Top = 200
.Height = 1000
End With

With Picture1
.Left = 200
.Top = 200
.Width = 3000
.Height = 1000
End With

'AutoRedraw must be set to True!!!
With Picture2
.Left = 200
.Top = 1500
.Width = 3000
.Height = 2500
.Visible = False
End With

'Variables needed
TwipsX = Screen.TwipsPerPixelX
TwipsY = Screen.TwipsPerPixelY
DestPicx = Picture2.Width / TwipsX
DestPicY = Picture2.Height / TwipsY
VScroll1.Max = Picture2.Height / TwipsY _
- Picture1.Height / TwipsY

'Print A to L on Picture2
Dim i As Integer

For i = 0 To 11
Picture2.Print Chr$(65 + i)
Next i

End Sub
Private Sub VScroll1_Change()

ScrollPic Picture2, Picture1, VScroll1

End Sub
Private Sub VScroll1_Scroll()

ScrollPic Picture2, Picture1, VScroll1

End Sub
3. Add a module with following code:

Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Integer, ByVal x As Integer, _ ByVal y As Integer, ByVal nWidth As Integer, _ ByVal nHeight As Integer, ByVal _ hSrcDC As Integer, ByVal xSrc As Integer, _ ByVal ySrc As Integer, ByVal dwRop As _
Long) As Integer
Public Const SRCCOPY = &HCC0020
Public Const SRCAND = &H8800C6
Public Const SRCINVERT = &H660046

Public TwipsX As Long
Public TwipsY As Long
Public DestPicx As Long
Public DestPicY As Long

Public Sub ScrollPic(SourcePic As Object, _ DestPic As Object, Scroll As Object)

BitBlt DestPic.hDC, 0&, 0&, DestPicx, DestPicY, _ SourcePic.hDC, 0&, Scroll.Value, SRCCOPY

End Sub
Hope that it'll help many programmers!

Tip by Wolfgang


c0Title: Using the Registry and Reading/Editing an INI File in VBScript
c1Code:
Option Explicit

Const ForReading = 1
Const ForWriting = 2

Dim oFSO 'As FileSystemObject
Dim oSetupINITextStream 'As TextStream
Dim sText
Dim oWinShell 'As oWinShell
Dim sCitectBinPath
Dim nLine
Dim sGUID
Dim sSection
Dim sLine

Set oWinShell = CreateObject("WScript.Shell")

'Get registered path of Citect OPC server to find the Citect Bin folder sCitectBinPath = FolderName(oWinShell.RegRead("HKCR\CLSID\{BA198B61-32E3-11D1-A1B5-00805F35623C}\InprocServer32\"))

'Edit the EasySetup INI file to use the Citect Bin folder as the default installation path If sCitectBinPath <> "" Then
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oSetupINITextStream = oFSO.OpenTextFile("setup.ini", ForReading)
    sText = Split(oSetupINITextStream.ReadAll, vbCrLf)
    
    For nLine = LBound(sText) To UBound(sText)
	
		sLine = sText(nLine)
	
		If (InStr(sLine, "[") > 0) And _
		   (InStr(sLine, "]") > 0) And _
		   (InStr(sLine, "=") = 0) Then
			
			sSection = Trim(Replace(Replace(sLine, "[", ""), "]", ""))
			
		Else
	
			Select Case sSection
	
			Case "Info"		'Delete the installation registry key from a previous installation so the path can be overridden
		
		    	If InStr(sLine, "GUID") Then
			   		sGUID = Mid(sLine, Instr(sLine, "{"))
					On Error Resume Next
		   			OWinShell.RegDelete "HKCU\Software\EasySetup\" & sGUID & "\"
					On Error Goto 0
			   	End If
			   	
		    Case "Settings"	
		
		        If InStr(sLine, "DefaultDir") Then
		            sText(nLine) = "DefaultDir = " & sCitectBinPath & "\"
		        End If
	
			End Select
				
		End If

    Next
    
    oSetupINITextStream.Close
    
    Set oSetupINITextStream = oFSO.OpenTextFile("setup.ini", ForWriting)
    oSetupINITextStream.Write Join(sText, vbCrLf)
    oSetupINITextStream.Close
End If

WScript.Quit 0		'Set error level 0 for success or 1 to abort installation

    
'Return the drive\folder from a path & filename Function FolderName(PathName)
    Dim X
    
    X = InStrRev(PathName, "\", Len(PathName) - 1)
    FolderName = Left(PathName, X - 1)
End Function


c0Title: Using The Win95/NT4.0 SHFormatDrive Function To Format Drives
c1Code:
One commonly asked question in the Visual Basic programming forums is "How can I format a disk drive from my VB application?". The answer usually is to use the VB Shell function to access the DOS format command. (FORMAT.COM) This approach lacks elegance, to say the least. I have seen another hack using the Windows 3.1 File Manager format applet and somehow keeping the File Manager invisible. This "solution" also lacks in finesse. A viable alternative would be to use the built-in format applet in Windows 95/NT, but that API is not made available in any of the Microsoft documentation- this function is not intended to be used by non-Microsoft programmers. 

Public Declare Function SHFormatDrive Lib "shell32" _ 

    (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, _ 

    ByVal options As Long) As Long 

Const SHFMT_NOFORMAT = &HFFFFFFFD ' Drive cannot be formatted 

Const SHFMT_CANCEL = &HFFFFFFFE ' Last format was canceled 

Const SHFMT_ERROR = &HFFFFFFFF ' Error on last format,drive may be formatable 

Const SHFMT_OPT_QUICK = &H0 ' I made this one up- quick format 

Const SHFMT_OPT_FULL = &H1 ' Full format 

Const SHFMT_OPT_SYSONLY = &H2 ' System files only 

Const SHFMT_ID_DEFAULT = &HFFFF ' Default floppy size 

After a half hour of experimenting (And several GPF's!) I had a working program that could format any drive that Windows could format. The hwnd and drive parameters were obvious, the fmtID and options were not so easy to ascertain. The function wanted the hwnd (Handle) of the calling form in order to center itself correctly. The Drive is the drive number- Windows numbers its drives in "C" fashion- starting with zero. 0= a:\ drive , 1= b:\ drive, etc. The fmtID parameter was a little harder. The fmtID refers to what capacity do we want to format the disk- when referring to removable drives. (Don't ask me what it refers to with fixed drives, I don't have one I can experiment with.) The option parameter is for� well, options. The chart below shows what fmtID's and options I was able to come up with. 

fmtID      3.5"      5.25
"&H0      1.44      1.2
&H1      1.44      1.2
&H2      1.44      1.2
&H3      1.44      360
&H4      1.44      1.2
&H5      720      1.2
&H6      1.44      1.2
&H7      1.44      1.2
&H8      1.44      1.2
&H9      1.44      1.2
 
Full=Full format 
Quick=Quick Format 
SO=System Files only 
 
Options      3.5"      5.25"
&H0      Quick      Quick
&H1      Full      Full
&H2      SO      SO
&H3      SO      SO
&H4      Quick      Quick
&H5      Full      Full
&H6      SO      SO
&H7      SO      SO
&H8      Quick      Quick
&H9      Full      Full
 
There are most probably other fmtIDs and options, but the above covers just about anything a Visual Basic programmer would want to do with a floppy.  Remember, this is a undocumented function, you are on your own. The maker of the OS had no intention of anyone using this function for their own program. Neither myself or Microsoft can be held responsible for any havoc you might wreak with this code. (YOU CAN FORMAT YOUR HARD-DRIVE WITH THIS CODE!!!) 

In order to demonstrate the function I'll walk you through a quick sample app. This code will work in either VB4(32 bit) or VB5. In a fresh form insert the following code: 

Option Explicit 
Const DRIVE_REMOVABLE = 2 
Const DRIVE_FIXED = 3 
Const DRIVE_REMOTE = 4 
Const DRIVE_CDROM = 5 
Const DRIVE_RAMDISK = 6 
'---------- 
' Error messages 
Const SHFMT_NOFORMAT = &HFFFFFFFD ' Drive cannot be formatted 
Const SHFMT_CANCEL = &HFFFFFFFE ' Last format was canceled 
Const SHFMT_ERROR = &HFFFFFFFF ' Error on last format,drive may be formatable 
' Options 
Const SHFMT_OPT_QUICK = &H0 ' I made this one up- quick format 
Const SHFMT_OPT_FULL = &H1 ' Full format 
Const SHFMT_OPT_SYSONLY = &H2 ' System files only 
' fmtID 
Const SHFMT_ID_DEFAULT = &HFFFF ' Default floppy size 
'------------ 
Private Declare Function SHFormatDrive Lib "shell32" _ 
  (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, _ 
  ByVal options As Long) As Long 
Private Declare Function GetDriveType Lib "kernel32" Alias _ 
  "GetDriveTypeA" (ByVal nDrive As String) As Long 
 
We need the GetDriveType to determine if a drive is a fixed or removable drive. (We would at least like to warn the user he's about to format his harddrive.) 
 
Next put a DriveListBox and two CommandButtons on the form. Leave the default name for the DriveListBox (Drive1), name one of the buttons "cmdFormat" and the other "cmdExit". 
 
Behind the cmdFormat button put this code: 
 
Private Sub cmdFormat_Click() 
Dim DriveLetter As String 
Dim DriveNumber As Long 
Dim DriveType As Long 
Dim retval As Long 
Dim RetFromMsg As Integer 
     DriveLetter = UCase(Drive1.Drive) ' Get the Drive letter- A,B,C, etc 
     DriveNumber = (Asc(DriveLetter) - 65) ' Change letter to Number: A=0 
     DriveType = GetDriveType(DriveLetter) ' What kind of drive is this? 
     If DriveType = DRIVE_REMOVABLE Then ' Floppies, etc 
           retval = SHFormatDrive(Me.hwnd, DriveNumber, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICK) 
     Else 
           RetFromMsg = MsgBox("This drive is NOT a removeable" & vbCrLf & _ 
                 "drive! Format this drive?", 276, "SHFormatDrive Example") 
           Select Case RetFromMsg 
                 Case 6 'Yes 
                       ' UnComment to do it... "Yes, format the C:\ drive" 
                       'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICK) 
                 Case 7 'No 
                       ' Do nothing 
           End Select 
     End If 
'--------- 
' You could check retval for SHFMT_ERROR, etc, but 
' it is unnecessary since the format applet will 
' inform the user. 
End Sub 
 
Behind the cmdExit button insert this code: 
 
Private Sub cmdExit_Click() 
    Unload Me 
    End 
End Sub 
 
Finally, in the Form_Load event place this code- 
 
Private Sub Form_Load() 
    Me.Caption = "SHFormatDrive example" 
    cmdFormat.Caption = "&Format" 
    cmdExit.Caption = "E&xit" 
End Sub 
Save and run the program, now you have the ability to format any drive that Windows can format. This code works with Visual Basic 4.0 32-bit and Visual Basic 5.0.

Tip Submitted By: Joe LeVasseur


c0Title: Validate an E-Mail Address
c1Code:
Need to ensure an e-mail address is valid?

This copy-and-paste code snippet checks an address for its length, the @ sign, the period, the characters used, the suffix � and more!

Save your overworked fingers further strain and add this snippet to your code library.

To use it, simply call the IsEMailAddress function, passing in an e-mail address and an optional 'reason' string variable. The procedure will return a True if the e-mail address is valid, a False otherwise.

If False is returned, the reason for its failure will be passed back into the optional reason string.

With thanks to Paul Brown for the code base (slightly revised for publication).

Usage

Dim IsValid As Boolean
Dim InvalidReason As String
    
IsValid = IsEMailAddress("karl@karlmoore.com", InvalidReason)

MsgBox "Is the e-mail address valid? - " & IsValid

MsgBox "If invalid, the reason given is: " & InvalidReason
Code

Public Function IsEMailAddress(ByVal sEmail As String, _
    Optional ByRef sReason As String) As Boolean
        
	Dim sPreffix As String
	Dim sSuffix As String
	Dim sMiddle As String
	Dim nCharacter As Integer
	Dim sBuffer As String

	sEmail = Trim(sEmail)

	If Len(sEmail) < 8 Then
		IsEMailAddress = False
		sReason = "Too short"
		Exit Function
	End If


	If InStr(sEmail, "@") = 0 Then
		IsEMailAddress = False
		sReason = "Missing the @"
		Exit Function
	End If


	If InStr(InStr(sEmail, "@") + 1, sEmail, "@") <> 0 Then
		IsEMailAddress = False
		sReason = "Too many @"
		Exit Function
	End If


	If InStr(sEmail, ".") = 0 Then
		IsEMailAddress = False
		sReason = "Missing the period"
		Exit Function
	End If

	If InStr(sEmail, "@") = 1 Or InStr(sEmail, "@") = Len(sEmail) Or _
		InStr(sEmail, ".") = 1 Or InStr(sEmail, ".") = Len(sEmail) Then
		IsEMailAddress = False
		sReason = "Invalid format"
	Exit Function

End If


For nCharacter = 1 To Len(sEmail)
	sBuffer = Mid$(sEmail, nCharacter, 1)
	If Not (LCase(sBuffer) Like "[a-z]" Or sBuffer = "@" Or _
	sBuffer = "." Or sBuffer = "-" Or sBuffer = "_" Or _
	IsNumeric(sBuffer)) Then: IsEMailAddress = _
	False: sReason = "Invalid character": Exit Function
Next nCharacter

nCharacter = 0

On Error Resume Next

sBuffer = Right(sEmail, 4)
If InStr(sBuffer, ".") = 0 Then GoTo TooLong:
If Left(sBuffer, 1) = "." Then sBuffer = Right(sBuffer, 3)
If Left(Right(sBuffer, 3), 1) = "." Then sBuffer = Right(sBuffer, 2)
If Left(Right(sBuffer, 2), 1) = "." Then sBuffer = Right(sBuffer, 1)


If Len(sBuffer) < 2 Then
	IsEMailAddress = False
	sReason = "Suffix too short"
	Exit Function
End If

TooLong:

If Len(sBuffer) > 3 Then
	IsEMailAddress = False
	sReason = "Suffix too long"
	Exit Function
End If

sReason = Empty
IsEMailAddress = True

End Function
Tip by Karl Moore


c0Title: Validate phone numbers, zip codes, and Canadian postal codes
c1Code:
Use the LIKE statement to validate the format. The functions used in this program make validating these fields easy.  
 
 
' Validate a phone number. If there is an error,
' tell the user and return True.
Public Function ValidatePhoneNumber(ByVal text_box As _
    TextBox, ByVal required As Boolean, ByVal _
    allow_short_format As Boolean, ByVal allow_long_format _
    As Boolean) As Boolean
Dim txt As String

    ' Make sure some format is allowed.
    If Not (allow_short_format Or allow_long_format) Then _
        Stop

    ' Assume the field is valid.
    ValidatePhoneNumber = False

    ' Allow a blank entry if not required.
    txt = text_box.Text
    If (Not required) And (Len(txt) = 0) Then Exit Function

    ' Check short format.
    If (allow_short_format) And (txt Like "###-####") Then _
        Exit Function

    ' Check long format.
    If (allow_long_format) And (txt Like "(###)###-####") _
        Then Exit Function

    ' The validation fails.
    ' Display an error message.
    If allow_short_format And allow_long_format Then
        MsgBox "Phone number should have format ###-#### or " & _
            "(###)###-####."
    ElseIf allow_short_format Then
        MsgBox "Phone number should have format ###-####."
    ElseIf allow_long_format Then
        MsgBox "Phone number should have format " & _
            "(###)###-####."
    End If

    ' Set focus to the control.
    text_box.SelStart = 0
    text_box.SelLength = Len(txt)
    text_box.SetFocus
    ValidatePhoneNumber = True
End Function

' Validate a Zip code. If there is an error,
' tell the user and return True.
Public Function ValidateZip(ByVal text_box As TextBox, _
    ByVal required As Boolean, ByVal allow_short_format As _
    Boolean, ByVal allow_long_format As Boolean) As Boolean
Dim txt As String

    ' Make sure some format is allowed.
    If Not (allow_short_format Or allow_long_format) Then _
        Stop

    ' Assume the field is valid.
    ValidateZip = False

    ' Allow a blank entry if not required.
    txt = text_box.Text
    If (Not required) And (Len(txt) = 0) Then Exit Function

    ' Check short format.
    If (allow_short_format) And (txt Like "#####") Then _
        Exit Function

    ' Check long format.
    If (allow_long_format) And (txt Like "#####-####") Then _
        Exit Function

    ' The validation fails.
    ' Display an error message.
    If allow_short_format And allow_long_format Then
        MsgBox "Zip code should have format ##### or " & _
            "#####-####."
    ElseIf allow_short_format Then
        MsgBox "Zip code should have format #####."
    ElseIf allow_long_format Then
        MsgBox "Zip code should have format #####-####."
    End If

    ' Set focus to the control.
    text_box.SelStart = 0
    text_box.SelLength = Len(txt)
    text_box.SetFocus
    ValidateZip = True
End Function

' Validate a Canadian Postal Code. If there is
' an error, tell the user and return True.
Public Function ValidateCanadianPostalCode(ByVal text_box _
    As TextBox, ByVal required As Boolean) As Boolean
Dim txt As String

    ' Assume the field is valid.
    ValidateCanadianPostalCode = False

    ' Allow a blank entry if not required.
    txt = text_box.Text
    If (Not required) And (Len(txt) = 0) Then Exit Function

    ' Check the format.
    If (UCase$(txt) Like "[A-Z]#[A-Z] #[A-Z]#") Then Exit _
        Function

    ' The validation fails.
    ' Display an error message.
    MsgBox "Postal Code should have format A1B 2C3."

    ' Set focus to the control.
    text_box.SelStart = 0
    text_box.SelLength = Len(txt)
    text_box.SetFocus
    ValidateCanadianPostalCode = True
End Function


c0Title: Validating Credit Card Numbers
c1Code:
If the number is in a valid format if returns 'True'. If the number is in an invalid format it returns 'False'. This algorithm should work with all credit cards. If a card validates with this code it doesn't mean that the card is actually good, it just means that the numbers are arranged in a valid format. If they don't validate then you've saved some time because you don't have to process the card to find out that it is definitely bad. I use this function in CGI forms that process credit card orders.

Code

Function CheckCard(CCNumber As String) As Boolean
    Dim Counter As Integer, TmpInt As Integer
    Dim Answer As Integer

    Counter = 1
    TmpInt = 0

    While Counter <= Len(CCNumber)
        If IsEven(Len(CCNumber)) Then
            TmpInt = Val(Mid$(CCNumber, Counter, 1))
            If Not IsEven(Counter) Then
                TmpInt = TmpInt * 2
                If TmpInt > 9 Then TmpInt = TmpInt - 9
            End If
            Answer = Answer + TmpInt
            'Debug.Print Counter, TmpInt, Answer
            Counter = Counter + 1
        Else
            TmpInt = Val(Mid$(CCNumber, Counter, 1))
            If IsEven(Counter) Then
                TmpInt = TmpInt * 2
                If TmpInt > 9 Then TmpInt = TmpInt - 9
            End If
            Answer = Answer + TmpInt
            'Debug.Print Counter, TmpInt, Answer
            Counter = Counter + 1
        End If
    Wend

    Answer = Answer Mod 10

    If Answer = 0 Then CheckCard = True
End Function

Function IsEven(lngNumber As Long) As Boolean

If lngNumber Mod 2 = 0 Then
  IsEven = True
Else
  IsEven = False
End If

End Function


Tip by James Johnston


c0Title: VB JoyStick Programming, The Windows API and C Data Types
c1Code:
OVERVIEW

Recently I began a small experiment to see if there was an easy and cheap way to allow users who may have difficulty using the buttons on a mouse, to control mouse button actions (clicking) with another switch. For simplicity I decided that I would use the buttons on a JoyStick as the switch, since I knew Microsoft had provided an API for reading the JoyStick, I knew I would not have to write a DLL or construct a switch(hence using up one of the valuable system resources, the com port). Also for most Windows applications the user�s JoyStick lies dormant, therefore this would be a perfect way of utilizing a customers resources without an added hardware expense.

Located in the MMSYSTEM DLL are a number of JoyStick specific functions which allow a programmer quick and easy access to the events and properties associated with a JoyStick. Among these are functions that will determine the number of joysticks attached(Maximum two for Win 3.1, and 12 for Win 95?), set the polling period of the JoyStick, set the amount the JoyStick must move to generate a message, and a function to gather information about the currently captured JoyStick, such as its max and min x,y,z coordinates. The VB declarations are given below:

' joystick function prototypes 

Declare Function joyGetDevCaps% Lib "MMSYSTEM.DLL" (ByVal uJoyID%, lpCaps As JOYCAPS, ByVal uSize%)

Declare Function joyGetNumDevs% Lib "MMSYSTEM.DLL" ()

Declare Function joyGetPos% Lib "MMSYSTEM.DLL" (ByVal uJoyID%, lpInfo As JOYINFO)

Declare Function joyGetThreshold% Lib "MMSYSTEM.DLL" (ByVal uJoyID%, lpuThreshold%)

Declare Function joyReleaseCapture% Lib "MMSYSTEM.DLL" (ByVal uJoyID%)

Declare Function joySetCapture% Lib "MMSYSTEM.DLL" (ByVal hwnd%, ByVal uJoyID%, ByVal uPeriod%, ByVal bChanged%)

Declare Function joySetThreshold% Lib "MMSYSTEM.DLL" (ByVal uJoyID%, ByVal uThreshold%)

The data structure of the JOYINFO and JOYCAPS are as follows:

' joystick information data structure 

Type JOYINFO

wXpos As Integer ' x position 

wYpos As Integer ' y position 

wZpos As Integer ' z position 

wButtons As Integer ' button states 

End Type

 

' joystick device capabilities data structure 

Type JOYCAPS

wMid As Integer ' manufacturer ID 

wPid As Integer ' product ID 

szPname As String *32 ' product name (NULL terminated string) 

wXmin As Integer ' minimum x position value 

wXmax As Integer ' maximum x position value 

wYmin As Integer ' minimum y position value 

wYmax As Integer ' maximum y position value 

wZmin As Integer ' minimum z position value 

wZmax As Integer ' maximum z position value 

wNumButtons As Integer ' number of buttons 

wPeriodMin As Integer ' minimum message period when captured 

wPeriodMax As Integer ' maximum message period when captured 

End Type

Take special care when observing the JOYCAPS structure(or Type in VB lingo), we will come back to this. Do you notice anything special about this structure?

THE WINDOWS API

Through my reading of the Visual Basic Internet News Group I have notice a reluctance by many VB Programmers to use the API, or if not a reluctance to use the API then a reliance on the use of custom controls(VBXs). While VBXs certainly have their place, a failure of a VB programmer to utilize the Windows API is failure of a VB programmer to exploit VB to its fullest potential. There are many situations where using a VBX to perform a specific task would be wasteful or simply ridicules.

As an example, you want to know where the users Windows directory is located on their harddrive, so that you may store files in it during runtime. You could ask the user this information, but why bother them with trivial details, or you could use the VB command DIR and search for Windows, but this has many problems(network drives, More then one instance of Windows installed on same HD...). As a Visual Basic programmer you have three options. The first is to abandon the feature which you were going to implement, not very practical. The second is to search for a VBX that will return the Windows directory, but what if you can�t find a VBX that performs this task, you�ll have to sit and wait, or what if you find the VBX but it costs $50 US and your project supervisor wont allow you to spend any more money on the project. For arguments sake, lets say you find such a VBX and cost is no object. It could be called SYSINFO.VBX and can give back all sorts of information and allow you to set all kinds of system parameters(colour, wallpaper...).

You have gone ahead and purchased your new SYSINFO.VBX, you go to use it and find that it only gives back valid Windows directories on none Networked computers(this is just an example, not likely). Now what, you just spent $50 dollars, wasted time debugging someone�s else�s code, and have nothing to show for it. Your last option would have been to look at the Windows API and determine if there was a procedure or function that could help you.

Before looking for a VBX you should ask yourself two questions:

1.      Is the task which I want to perform simple or complex?

2.      Are there any Windows APIs that appear to relate to the task which I want to perform? 

The first question may appear to be ambiguous to some, and will vary from programmer to programmer. Examples of tasks that should fall into every VB programmers definition of simple are: making a Window toplevel or float, reading INI files, getting the Windows directory, etc... . There are tens of API calls which will perform useful and sometimes seemingly complex operations that require only a single function call and no message processing. The file APIDEMO.BAS contains a number of functions and procedures that demonstrate these simple APIs and how to efficiently use them in Visual Basic. For something that seems complex or tedious (Winsock programming, Voice/Fax routines) a VBX will probably be the most efficient route, but again this will vary from programmer to programmer.

The second question could be expanded to include "... and does Visual Basic currently provide a means to accomplish this task?". Remember VB provides many functions which act to encapsulate the API, a good example of this is the Clipboard object built into VB. You can use this object to successfully implement copy and paste, and for most circumstances the functionality of this VB object will be all that you need. But what if you wanted to do something that wasn�t provided with the Clipboard object?

You should obtain a good reference on the API. A reference that many VB programmers love is the Visual Basic Programmer�s Guide to the Windows API by Daniel Appleman. You might want to pick up a book that documents all the APIs with their C declarations, or at least a file that contains a listing of these declarations, because as we will see some VB declarations lack sufficient clarity.

Referring back to our example of finding the Windows directory, you ask yourself the question "Does finding the Windows Directory sound like something easy?" and your answer is "Yes". Next you do a quick search of the on-line help for �Directory� and �Windows� and come to the conclusion that their is no built in manor of finding the Windows directory with VB. Now after a quick search of your favorite API reference, you find exactly what you were looking for:

Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer

Now it is just a matter of adding the declaration to your project and calling the function.

C DATA TYPES

Below are the C data types, you should take time to familiarize yourself with these if you want to successfully call the API.

Data Types (16-bit)

Type            Length      Range

unsigned char      8 bits      0 to 255

char            8 bits      -128 to 127

enum            16 bits      -32,768 to 32,767

unsigned int      16 bits      0 to 65,535

short int      16 bits      -32,768 to 32,767

int            16 bits      -32,768 to 32,767

unsigned long      32 bits      0 to 4,294,967,295

long            32 bits      -2,147,483,648 to 2,147,483,647

float            32 bits      3.4 x 10-38 to 3.4 x 10+38

double            64 bits      1.7 x 10-308 to 1.7 x 10+308

long double      80 bits      3.4 x 10-4932 to 1.1 x 10+493

When the API was first written there were no provisions made to ensure that VB programs would be able to successfully call them. They were tailored to C and ASM type programs and assume C like data types to store their return parameters in. For most of these C data types VB provides an equivalent. But there is one particular C data type that is not duplicated in VB, and that you as a VB programmer, must know if you wish to successfully call the JOYSTICK API.

This is the Unsigned Integer, note that the Unsigned integer has a range of 0 to 65535, while the Signed(and VB Integer) has a range of -32,768 to 32,767. To the computer a Signed and Unsigned integer are represented the same way in memory(they occupy the same space, 16 bits), but they are encoded differently. Unsigned integers are encoded using their straight binary equivalents while Signed Integers use something called �Two�s Complement Notation� to store integer values. 

In Two�s Complement notation the left bit is used as a sign bit(1 is neg, 0 pos) this leaves only 15 bits to store the magnitude of the number, this is why the largest magnitude of Signed integers is smaller then the largest magnitude of Unsigned integers. Positive numbers are encoded using their straight binary equivalent, while to encode a negative integer, the binary equivalent of the magnitude is first complemented(0 �s go to 1�s, 1�s go to 0�s), and one is added.

As an example, to encode -127(In 8 bit Two�s Complement notation):

127 = 0111 1111 Complement it to 1000 0000 now add 1 to get 1000 0001 = -127 in two�s complement notation.

Below is a comparison of Unsigned and Signed bit encoding(8 bit numbers are used for simplicity):

Unsigned 8 Bit Numbers      Singed 8 Bit Numbers

range 2exp8 - 1 = 255(includes zero)      -2exp(8-1) to 2exp(8-1) - 1 = -128 to 127

Binary      Decimal      Binary      Decimal

0000 0000      zero      0000 0000      zero

0000 0001      1      0000 0001      1

0000 0010      2      0000 0010      2

....... .......            ....... .......      

0111 1110      126      0111 1110      126

0111 1111      127      0111 1111      127

1000 0000      128      1000 0000      -128 (note leftmost 1 = neg.)

1000 0001      129      1000 0001      -127

....... .......            ........ ......      

1111 1110      254      1111 1110      -2

1111 1111      255      1111 1111      -1

As a VB programmer you need not worry about the encoding of Signed integers, but you should be aware of it so that you may differentiate between Signed and Unsigned integers when calling C/Pascal DLL�s and the API.

Now lets take a look at the C data structure for JOYCAPS:

typedef struct joycaps_tag {

UINT wMid;

UINT wPid;

char szPname[MAXPNAMELEN];

UINT wXmin;

UINT wXmax;

UINT wYmin;

UINT wYmax;

UINT wZmin;

UINT wZmax;

UINT wNumButtons;

UINT wPeriodMin;

UINT wPeriodMax;

} JOYCAPS; 

UINT is used in the Windows SDK to refer to Unsigned 16 bit values. Now do you see a problem? While the structure( and each element) that is passed in VB is the same size as the one passed in a C program, the C program treats the individual integer elements as Unsigned integers, while a VB program treats them as Signed. What this translates to in VB is that JoyStick parameters greater then 32,767 will be in error if you simply read the integer value without converting it to an unsigned value. Also, when the JoyStick is moved, a message is generated(See JOYSTICK PROGRAMMING below) with a parameter that contains Unsigned integer values that correspond to the current x,y position of the JoyStick.

Now you might say to yourself "Well I tried the API and it looks as if I am going to need a VBX, since all the values returned seem to be in error". If you had no prior knowledge of C data types, namely, Unsigned Integers, this might be true. But while playing with the JoyStick and your VB code you noticed that if you moved the JoyStick from left to right the X coordinate seemed correct until you reached about 32000 or half way, then it went negative and started to decrease in magnitude. Even with no knowledge of the C JOYCAPS structure, but with a good knowledge of C data types, you should be able to figure out what is going wrong. Now all you need to do is find a way of representing Unsigned integers in VB so that you may manipulate them in a straight forward manor. 

JOYSTICK PROGRAMMING

Before we tackle the Unsigned integer problem we will address the problem of obtaining Windows messages that are not built into Visual Basic. When a user performs any action (Click on a form, moving the mouse) in Windows, the system generates a message. Associated with these messages is a Windows "Handle", the handle acts to identify which Form/Control generated the message, it can also be used to identify which Form/Control to send a message to, so that it may be processed by that Form/Control. Visual Basic has built in �message intercepting� for the most common messages. You can see this by opening up a new form and clicking on the events list. The events list contains a list of all the messages that a VB form can respond to. For most cases these events will be all that is needed, but there are many times when you will want to process messages not built into VB. Some examples are: the MCI notification message(notifies you when a MIDI/Wav/AVI file has finished playing), determine MENU selections, and the JoyStick event messages. 

Luckily all the hard work has been done for us, you can use a VBX called MSGBLASTER. This is a good example where you simply have no other choice but to use a VBX to perform the task you wish to accomplish, intercepting Windows messages. Since the tools to perform this task are not built into VB and there is no API available to a VB programmer to accomplish the task. The VBX works by telling it which messages to intercept and which handle to associated with these messages. The VBX will generate an event each time the message/handle combination are encountered. From here it is as easy as responding to any of the built in VB events. You can tell the msgblaster to intercept more then one message, but you will have to set up a Case statement to handle this.

For programming the JoyStick we are interested in intercepting three messages:

Global Const MM_JOY1MOVE = &H3A0 

Global Const MM_JOY1BUTTONDOWN = &H3B5

Global Const MM_JOY1BUTTONUP = &H3B7

There are similar messages for the second JoyStick (and movement in the z axis), but for simplicity we will only deal with one JoyStick. We will use a parameter passed to the Msgblaster event called the wParam(word) to distinguish which buttons have been pressed and any combinations, and a parameter called the lParam(long) to determine the x,y coordinates when a MM_JOY1MOVE message is intercepted. Below is the code for the msgblaster event(the code for the MM_JOY1BUTTONUP has been removed for space, it is similar to the MM_JOY1BUTTONDOWN event).

Sub MsgBlast1_Message (MsgVal As Integer, wParam As Integer, lParam As Long, action As Integer)

     Select Case msg �determine which message has been intercepted

           Case MM_JOY1BUTTONDOWN 'Button down on JoyStick one

                 Select Case wParam

                       'Case Is >= JOY_BUTTON2CHG ' Can be used if only want to know state of one button, not conbinations!

                             'put your code here must keep the order(Button2chg before Button1chg)

                       'Case Is >= JOY_BUTTON1CHG 'Can be used if only want to know state of one button, not combinations!

                             'put your code here

                       Case JOY_BUTTON1CHG + JOY_BUTTON1

                             'Call JoyButton1_DOWN(1) 'Call procedure for joystick button one down

                             NumberLabel.Caption = "Button 1 DOWN"

                       Case JOY_BUTTON1CHG + JOY_BUTTON1 + JOY_BUTTON2

                             'Call JoyButton1_DOWN(2) 'Call procedure for joystick button one down, while button two was pressed!

                             NumberLabel.Caption = "Button 1 DOWN, 2Pressed"

                       Case JOY_BUTTON2CHG + JOY_BUTTON2

                             'Call joyButton2_DOWN(2) 'Call procedure for joystick button two down(no other buttons pressed)

                             NumberLabel.Caption = "Button 2 down"

                       Case JOY_BUTTON2CHG + JOY_BUTTON2 + JOY_BUTTON1

                             'joyButton2_DOWN 2 'Call Procedure for joystick button two down, while one was held pressed!

                             NumberLabel.Caption = "Button 2 DN, 1Pressed"

                 End Select

                 Case MM_JOY1MOVE 'Joystick moved(x,y direction only)

                       mmJoyMove lParam 'wParam contains which joystick buttons are pressed, lParam has x,y position

           End Select

End Sub

As you can see, the use of the msgblaster makes intercepting and processing of Windows messages a simple task. Now that we know when a JoyStick event has occurred we must process it. Below is the mmJoyMove routine found in the accompanying demo program.

Sub mmJoyMove (joyPosition As Long)

Dim CurX As Integer 'current X position, SIGNED INTEGER VALUE

Dim CurY As Integer 'current Y position, SIGNED INTEGER VALUE

Dim UnCurX As Long 'current X position UNSIGNED INTEGER VALUE

Dim UnCurY As Long 'current Y position UNSIGNED INTEGER VALUE

 

Call mmConvertLong(joyPosition, CurY, CurX) 'convert to hi low

Call mmConvSignUn(CurX, UnCurX) 'change to unsigned

Call mmConvSignUn(CurY, UnCurY)

'***** OK PLACE YOUR CODE BELOW HERE *********

' What follows is just an example, use the UnCurX and UnCurY

'for any calculations involving the position.

The lParam value passed to the message blaster event holds the current X,Y position. We pass this value to the mmJoyMove procedure as joyPosition. The first thing we must do is separate the low and high order words of joyPosition so that we may observe the X and Y positions individually. The procedure mmConverLong is called, this will take a Long(joyPosition) and convert it to two Integer values(the X and Y). Next we will take the two integer values representing the current X, Y position and convert them from Signed values to Unsigned values. Below is the procedure to convert Signed values to Unsigned values.

Sub mmConvSignUn (ByVal OldSignVal As Integer, NewUnSigned As Long)

Dim TempInts As lowhi

Dim TempVal As Intlong

TempInts.hiword = &H0

TempInts.loword = OldSignVal

LSet TempVal = TempInts

NewUnSigned = TempVal.Value

'****** This is an alternate way, same results *******

' If OldSignVal < 0 Then

' NewUnSigned = 65536 + OldSignVal

' Else

' NewUnSigned = OldSignVal

' End If

End Sub

The procedure accepts a Signed integer as the value to convert, and passes back a Unsigned integer in a Long data type. A long data type must be used to hold the new Unsigned value. Remember that the maximum positive value of a Signed integer is 32 767, while the maximum positive(all unsigned integers are assumed positive) value of an Unsigned integer is 65 535, therefore we must use a data type that is capable of holding the maximum positive value of an Unsigned integer. Since the maximum positive value of a Long data type is 2,147,483,647 it will easily hold an unsigned integer. Now all we have to do is put the signed value into the long data type. There are two ways to do this, one is using VB�s Lset command, and another is using a knowledge of two�s complement. Using the Lset command it is possible to �glue� together an Unsigned integer. First we declare two user defined types, the first �lowhi� is used to hold the high and low order words(integers), the second �Intlong� is used to hold the result. 

Type Intlong                        Type lowhi

Value As Long                   loword As Integer

End Type                         hiword As Integer

Memory Used By lowhi Data Structure 

As you can see in the above code, the high order word is filled with zero, this will imply a positive value. The low order is used to hold the magnitude of the old signed value. Now using the Lset command we can take two user defined types and put the contents of one into the other. This works because our �lowhi� data type is made up of two integers, while the �Intlong� is made up of one long, which is equal in lenght to two integers(See Figure). 

  

So the contents of the two integers are now copied into the Intlong.Value field. Since the high order is zero(which makes the left most bit zero), the value will appear to VB as positive, and it will correctly read the lower order bits as a positive number.

Note the order of the �loword� and �hiword� elements in the declaration of the lowhi data type. The 80x86 based PC�s use the little endian method of storing words and double words in memory. The little endian method stores the least significant (Low order) data at lower (smaller) addresses than the more significant (High order) values. Therefore we must make sure that our data structure used to hold the high and low order words follows the Little endian convention. Look at the example in Fig1. to see how the hexadecimal number &H0000F1F2 is stored in memory. This is machine dependent code, on a lot of other processors Big Endian storage is used. If you ever find yourself porting code from one machine to another (A Mac to a PC or Visa Versa), ignoring this detail can lead to many wasted hours.

Using the two�s complement method, all we have to do is add 65 536(the Unsigned Max + 1), to any negative number(when it is read as a Signed Integer) and store the results in a Long data type. Why does this work?, lets review the Two�s Complement encoding of 8 bit numbers:

UnSigned                              Signed Two�s Complement

0111 1110      126                        0111 1110      126

0111 1111      127                        0111 1111      127

1000 0000      128                        1000 0000      -128 (note leftmost 1 = neg.)

1000 0001      129                        1000 0001      -127

....... .......                              ........ ......      

1111 1110      254                        1111 1110      -2

1111 1111      255                        1111 1111      -1

Notice that negative numbers begin encoding at 1000 0000 and end at 1111 1111, this is half of the available range. So how do we determine the actual unsigned number represented by the signed negative number? By subtracting �up� into the Unsigned range the amount of the signed negative number and adding one ( due to zero). Look at the above encoding, and try a few conversions. As you can see -127(Signed) and 129(Unsigned) have the same encoding, therefore our conversion of -127 should yield 129. 

255(Unsigned Max 8 bit) + (-127) + 1 = 129

Try a few more conversions if you are not convinced. 

Now that you know what an Unsigned Integer is, how it is stored in memory, and how it relates to Signed Integers, you should be able to program the JoyStick with ease. All of the APIs associated with the JoyStick are straight forward and do not require much explanation. There are only two important things to remember, before changing the threshold value(the amount the JoyStick must move to generate a message) you must release capture, and remember to release the capture when exiting the program. There are procedures provided in the accompanying demo file that make this quite simple.

There is a zip file that accompanies this article, JOYDEMO.ZIP, inside this archive are two other files JOYMAKE.ZIP and IBMJOY.ZIP. JOYMAKE.ZIP contains the demonstration VB files, and IBMJOY.ZIP contains a Windows driver for the JoyStick. You must install the JoyStick driver first, choose ADD from the driver control panel setup form, and go to the directory where you unzipped the IBMJOY file. After installing the driver a JoyStick icon should appear in your control panel, double click on it and calibrate your JoyStick. You may have to calibrate your JoyStick each time you start up Windows, the current driver does not seem to remember previous settings. And one last comment, the "Thrustmaster" brand of JoyStick did not seem to work correctly under Windows, others that I tested, made by Gravis, worked fine. 

The sample projects can be found in the August issue 


c0Title: View Right Side of Truncated String
c1Code:
You see trailing ellipses (...) when VB truncates either the expres-sion or data portion of a data tip (the mouse-hover watch value you get while debugging). This is great if you want to see the left side of a long string value, but not quite as compelling if you care about the right side. Hold the control key down and rehover over the expression to force VB to truncate on the left instead of the right.
VB truncates all instant watch strings at 251 characters, so you won�t see the end of very long strings.

�Matt Curland, Redmond, Washington


c0Title: View Selected Text From the Beginning
c1Code:
Most professional and commercial applications exhibit a specific behavior when using dialog boxes with text fields: When you tab to an input field, or hot-key (using some ALT-key combination), you fully select the existing text in the field. Any typing then replaces the entire field. However, simply clicking on the text field with the mouse just sets the focus without making any text selection.

     The VB Knowledge Base documents how to set this behavior by capitalizing on the GetKeyState API call. However, the technique results in some inconvenience where the text itself is too large for the field width. You wind up looking at the tail end of the highlighted text, not the front end, so it can be difficult to tell what the current text contains.

     By combining the GetKeyState API with use of SendKeys and the TextWidth method, you can define a complete subroutine solution where a tab or hot-key to a large text field selects the field, but leaves you looking at the text from the beginning, not the end.

     First, declare the GetKeyState API function, and add the SelectWholeText routine, in your form:

 

Option Explicit

 

               ' Recall that in a form, you need "Private" on an API.

 

               #If Win16 Then

                              Private Declare Function GetKeyState Lib "User" _

                                             (ByVal iVirtKey As Integer) As Integer

               #Else

                              Private Declare Function GetKeyState Lib "User32" _

                                             (ByVal lVirtKey As Long) As Integer

               #End If

 

               ' vbTab                              ' same as Chr$(&H9) - character constant

               ' vbKeyTab               ' same as decimal 9 - key code constant

               ' vbKeyMenu               ' same as decimal 18 (Alt key) - key code 

                                                                           ' constant

 

Private Sub SelectWholeText(Ctl As Control)

               ' If you got to the "Ctl" field via either TAB or an

               ' Alt-Key, highlight the whole field. Otherwise select 

               ' no text, since it must have received focus using a 

               ' mouse-click.

 

               ' Note difference between vbTab (character) and vbKeyTab 

               ' (numeric constant). If vbTab were used, we'd have to 

               ' Asc() it to get a number as an argument.

 

               ' Use VB4/5's "With" to improve maintainability in case 

               ' the parameter name changes.

               With Ctl

                              If (GetKeyState(vbKeyTab) < 0) Or _

                                             (GetKeyState(vbKeyMenu) < 0) Then

                                             ' We tabbed or used a hotkey - select all text. In

                                             ' the case of a long field, use Sendkeys so we

                                             ' see the beginning of the selected text.

 

                                             ' TextWidth Method tells how much width a string 

                                             ' takes up to display (default target object is 

                                             ' the Form).

                                             If TextWidth(.Text) > .Width Then

                                                            SendKeys "{End}", True

                                                            SendKeys "+{Home}", True

                                             Else

                                                            .SelStart = 0

                                                            .SelLength = Len(.Text)

                                             End If

                              Else

                                             .SelLength = 0

                              End If

               End With

End Sub

 

     Next, call the subroutine in the GotFocus event of any text field:

 

Private Sub txtPubID_GotFocus()

               SelectWholeText txtPubID

End Sub

 

Private Sub txtTitle_GotFocus()

               SelectWholeText txtTitle

End Sub

�Mark Cohen, Winnepeg, Manitoba, Canada


c0Title: Viewing A Large Picture Using Scroll Bars
c1Code:
Compatible With    Visual Basic 4.0 32-bit
Applies To         PictureBox


--------------------------------------------------------------------------------

A common requirement is to be able to display a very large picture, one larger than the available screen space. You can buy add-on components to do this, but there is another way using just Visual Basic code.

Declare

#If Win32 Then
     Declare Function BitBlt Lib "gdi32" (ByVal hDestDC _
           As Long, ByVal X As Long, ByVal Y As Long, _
           ByVal nWidth As Long, ByVal nHeight As Long, _
           ByVal hSrcDC As Long, ByVal XSrc As Long, _
           ByVal YSrc As Long, ByVal dwRop As Long) As Long
#ElseIf Win16 Then
     Declare Function BitBlt Lib "GDI" (ByVal hDestDC _
           As Integer, ByVal X As Integer, ByVal Y As _
           Integer, ByVal nWidth As Integer, ByVal nHeight _
           As Integer, ByVal hSrcDC As Integer, ByVal XSrc _
           As Integer, ByVal YSrc As Integer, ByVal dwRop _
           As Long) As Integer
#End If
 
Public Const SRCCOPY = &HCC0020
Code

To create a demo on how this works, first create four controls and set them up as per the following settings:

Control 1

PictureBox
Name = picSrc
AutoRedraw = TRUE
AutoSize = TRUE
Picture = (bitmap)
ScaleMode = 3 - Pixel
Visible = FALSE
Control 2

PictureBox
Name = picDest
ScaleMode = 3 - Pixel
Control 3

VScrollBar
Name = VScr
Min = 0
Max = (number of vertical steps)
Control 4

HScrollBar
Name = HScr
Min = 0
Max = (number of horizontal steps)
Parent Form

Name = Form1
ScaleMode = 3 - Pixel
Then add the following subroutine to the form�s code:

Sub UpdatePic ()
     Dim X
     X = bitblt(picDest.hDC, 0, 0, picDest.Width, _
           picDest.Height, picSrc.hDC, HScr.Value * _
           ((picSrc.Width - picDest.Width) / HScr.Max), _
           VScr.Value * ((picSrc.Height - picDest.Height) _
           / VScr.Max), SRCCOPY)
End Sub
And add call of this routine to following events: VScr_Scroll, VScr_Change, HScr_Scroll, HScr_Change, picDest_Paint, Form_Resize.

Private Sub Form_Resize()
     UpdatePic
End Sub
 
Private Sub HScr_Change()
     UpdatePic
End Sub
 
Private Sub HScr_Scroll()
     UpdatePic
End Sub
 
Private Sub picDest_Paint()
     UpdatePic
End Sub
 
Private Sub VScr_Change()
     UpdatePic
End Sub
 
Private Sub VScr_Scroll()
     UpdatePic
End Sub
 

This tip is reprinted from the VB Tips & Tricks Volume 1 book. 
Parts of this tip was submitted by: Joel Paula


c0Title: Visual Basic 6.0 SP5: Run-Time Redistribution Pack (vbrun60sp5.exe)
c1Code:
http://www.microsoft.com/downloads/details.aspx?FamilyID=bf9a24f9-b5c5-48f4-8edd-cdf2d29a79d5&DisplayLang=en


c0Title: Wait for the termination of a program using Windows Scripting Host
c1Code:
If you want to execute an application and waiting for its termination, you can follow two approaches. The "classic" approach is based on API functions such as OpenProcess, WaitForSingleObject and CloseHandle. However, there is a simpler technique based on the Windows Scripting Host object model. 

A method exposed by this library lets you to run a file, and specify whether you want to wait for its termination. To use the following code snippet you must add a reference to Windows Scripting Host Object model in the "References " dialog window. The method you're looking for is the Run method of the IWshShell_Class object. Its first argument is the file to run, the second specifies the styles of the application's window and the last is a Boolean value that tells whether you want to wait for the program termination. Here's a function that contains all the necessary code: 

 Click here to copy the following block Sub RunAndWait(ByVal sFile As String)
  Dim WSHShell As New IWshShell_Class
  WSHShell.Run sFile, , True
End Sub 

To test this function, write the following code in your form (it assumes that Notepad is on your system path): 

 Click here to copy the following block Private Sub Form_Click()
  RunAndWait "notepad.exe"
  MsgBox "Back to your application!"
End Sub 

You'll see that the message box will appear only when you close Notepad. 
 


c0Title: Wallpaper Control
c1Code:
Three functions, LoadWallpaper, ResetWallpaper, and CurrentWallpaper do what their name implies. 
        
      Code: 
     Option Explicit

Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_UPDATEINIFILE = &H1
Private Const HKEY_CURRENT_USER = &H80000001 Private Const REG_SZ = 1

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 Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, _
   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

Public Sub LoadWallpaper(sFilename As String)

    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, sFilename, _
                         SPIF_UPDATEINIFILE

End Sub

Public Sub ResetWallpaper()

    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, CurrentWallpaper, 0

End Sub

Public Function CurrentWallpaper() As String

    Dim sValue As String
    Dim nReturn As Long
    Dim hKey As Long
    
    RegOpenKeyEx HKEY_CURRENT_USER, "Control panel\desktop", 0, 0, hKey
    
    nReturn = 1024
    sValue = Space(1024)
    
    RegQueryValueEx hKey, "Wallpaper", 0, REG_SZ, sValue, nReturn

    sValue = Mid(sValue, 1, nReturn)

    RegCloseKey hKey

    CurrentWallpaper = sValue

End Function


     
        
      Sample Usage: 
        
     LoadWallpaper "c:\windows\clouds.bmp"

     



c0Title: Watch Out for Root Installs
c1Code:
Be careful when reading the Path property of the App object. If the path is in a subdirectory, the resulting string terminates with the name of the subdirectory�for example, "C:\dir_x\dir_y\dir_z". Unfortunately, if the path happens to be the root directory, the resulting string terminates with a backslash�such as "C:\". The difference between the two is the possible terminating backslash.

     If you use App.Path to find a program-related file, you need to add the backslash before the file name, except if the path is the root directory: 

strFullFileName = App.Path & IIf(Right$( _
     App.Path, 1) = "\", "", "\") & strFileName
 
If this code is too tiresome to type, use this AppPath function:
 
Public Function AppPath() As String
     ' NOTE: Replace all occurrences of "App.Path" 
     ' with "AppPath"
     Dim strAppPath As String
     strAppPath = App.Path
     If (Right$(strAppPath, 1) <> "\") Then
          strAppPath = strAppPath & "\"
     End If
     AppPath = strAppPath
End Function
 
If you automatically append a backslash to every App.Path call and the path happens to be the root directory, you get the uninformative error message, �Run-time error '5': Invalid procedure call.�

�Andrew J. Marshall, Fairfax, Virginia


c0Title: What are some of the consideration for a good VB program/User interface?
c1Code:
Check the Tabbing for the controls in a form. 
Be consistence with the fonts and size of the control.
All objects should follow a standard sizing scheme. 
After deletion always bring up the next record. 
Whenever the button or text box get the focus, change the font, for easy differentiation. 
Text boxes should be highlighted on the focus. 
User should always be able to navigate between text boxes using enter key. 
Always keep your developed DLL's in program directory. While compiling check the binary compatibility option in the project, properties option. New Compile DLL should also go in program directory. So all the time you will have only one copy of DLL. 
Prefer functions over sub, as functions can always be checked for the return value, and the program execution can be halted, or program can do the graceful exit. 
In the function
The first line should be on error goto eh, should be before variable declaration, as some Dim for the new object_name may fail.
The second line should be function_name = False, and in the function keep returning with out setting the value for the function. Last statement or the proper exit from the function should have function_name = true statement.
Actually there should be only one exit point for the function.
Never take any thing for granted, recheck the validity of the variable value. 
Data in Grid, Combo box and list boxes should always be sorted alphabetically.


c0Title: What is the normal order of form events?
c1Code:
Visual Basic Version: VB 4.0, VB 5.0, VB 6.0

Issue: There are several new form events in VB 4.0. In what order are these events normally generated?

This is a good question, and depends on your code. In most cases, the event will fire in the following order:

Form_Initialize - This event will occur as soon as the form is referenced in any way. Normally, any related objects are initialized in this event.

Form_Load - This event will occur as soon as you Load or Show the form of if you reference any controls or visual properties of the form. (The form will load automatically when it is shown, so a separate load is not required.) This event will not occur if you simply reference properties on the form that you created.

Form_Resize - This event resizes the form appropriately.

Form_Activate - Any code that must be run after the form has been loaded (such as a SetFocus call) can be put into the Activate event. The form will get additional Activate events whenever it becomes the active form in the application.

Form_GotFocus - This event will only occur if no other control on the form can get focus. Otherwise, the specific control (the first enabled control in the TabOrder) will get the focus.

Form_Paint - This event will occur whenever the form needs to be repainted.

Form_Unload - This event will occur whenever you close the form using the Close box or with an unload statement. Closing and unloading the form removes the form from memory, but not the code associated with the form. So you can still reference properties and methods you have created in the form code after the form itself has been unloaded.

Form_Terminate - This event will occur when all references to the form are terminated by going out of scope or with the Set frmXXX = Nothing syntax. To ensure you are cleaning up memory after you unload the form, you should set the form reference to Nothing. If you don't need access to any methods or properties, you can add this line to the Unload event:

Set frmPerson = Nothing
Note: You cannot use the Me key word here. You have to set the form reference to Nothing.


c0Title: When can I use the "!" operator?
c1Code:
Visual Basic Version: VB 4.0, VB 5.0, VB 6.0

Issue: The "!" operator is a shortcut for a keyed lookup in a collection provided by the Item method. So anytime you would code: x.Item("keystring") you could instead use: x!Keystring.

Limitations: This will not work with collection classes because the collection is Private (but it will work within the collection class). It will also not work using the index instead of the string key for the collection. i.e. x!1 generates a syntax error.

Code:

The following two lines provide the same results:

EmployeeList.Item("E00001").Name
EmployeeList.m_colEmployees!E00001.Name
In the example above, I had a collection class called EmployeeList. In it I have a collection called m_colEmployees. I also have methods and properties that wrap around the methods and properties exposed by the collection. So my EmployeeList collection class has an Item method that returns the same value as the collection Item method.


c0Title: WordWrap a String
c1Code:
This is a simple function that word wraps a string into smaller strings, separating each line with a newline. 
        
      Code: 
     Public Function WrapString( _
   sLineToWrap As String, _
   Optional nFirstLine As Long = 5, _
   Optional nOtherLines As Long = 0, _
   Optional nLineLength As Long = 72) As String

    Dim bFirst As Boolean
    Dim nPos As Long
    Dim bBreakFound As Boolean
    
    bFirst = True

    Do While Len(sLineToWrap) > nLineLength
        nPos = nLineLength
        bBreakFound = False
        Do Until nPos = 0 Or bBreakFound
            If Mid(sLineToWrap, nPos, 1) = " " Then
                bBreakFound = True
            ElseIf Mid(sLineToWrap, nPos, 1) = "-" Then
                bBreakFound = True
            Else
                nPos = nPos - 1
            End If
        Loop
        If nPos = 0 Then
            nPos = nLineLength
        End If
        WrapString = WrapString & Space(IIf(bFirst, nFirstLine, _
           nOtherLines)) & Mid(sLineToWrap, 1, nPos) & vbNewLine
        
        sLineToWrap = Mid(sLineToWrap, nPos + 1)
        bFirst = False
    Loop
    
    WrapString = WrapString & Space(IIf(bFirst, _
       nFirstLine, nOtherLines)) & sLineToWrap

End Function

     
        
      Sample Usage: 
        
         Dim sLine As String
    sLine = "This is a really long continuous line that I wrote to "
    sLine = sLine & "demonstrate the wrapping capabilities of the "
    sLine = sLine & "WrapString function.  This text serves no "
    sLine = sLine & "other purpose other than as an example for "
    sLine = sLine & "this function, feel free to ignore this text."

    Debug.Print WrapString(sLine)

     



c0Title: Work with 64bit Decimal Values
c1Code:
    Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSource As Long, ByVal nBytes As Long)

Public Enum VARENUM
    VT_EMPTY = 0
    VT_NULL = 1
    VT_I2 = 2
    VT_I4 = 3
    VT_R4 = 4
    VT_R8 = 5
    VT_CY = 6
    VT_DATE = 7
    VT_BSTR = 8
    VT_DISPATCH = 9
    VT_ERROR = 10
    VT_BOOL = 11
    VT_VARIANT = 12
    VT_UNKNOWN = 13
    VT_DECIMAL = 14
    VT_I1 = 16
    VT_UI1 = 17
    VT_UI2 = 18
    VT_UI4 = 19
    VT_I8 = 20
    VT_UI8 = 21
    VT_INT = 22
    VT_UINT = 23
    VT_VOID = 24
    VT_HRESULT = 25
    VT_PTR = 26
    VT_SAFEARRAY = 27
    VT_CARRAY = 28
    VT_USERDEFINED = 29
    VT_LPSTR = 30
    VT_LPWSTR = 31
    VT_FILETIME = 64
    VT_BLOB = 65
    VT_STREAM = 66
    VT_STORAGE = 67
    VT_STREAMED_OBJECT = 68
    VT_STORED_OBJECT = 69
    VT_BLOB_OBJECT = 70
    VT_CF = 71
    VT_CLSID = 72
    VT_VECTOR = &H1000&
    VT_ARRAY = &H2000&
    VT_BYREF = &H4000&
    VT_RESERVED = &H8000&
    VT_ILLEGAL = &HFFFF&
    VT_ILLEGALMASKED = &HFFF&
    VT_TYPEMASK = &HFFF&
End Enum

Private Type tagDECIMAL
  wReserved                 As Integer
  scale                     As Byte             ' // The number of decimal places for the
                                                ' // number. Valid values are from 0 to 28. So
                                                ' // 12.345 is represented as 12345 with a
                                                ' // scale of 3.
  sign                      As Byte             ' // 0 for positive numbers or DECIMAL_NEG for
                                                ' // negative numbers. So -1 is represented as
                                                ' // 1 with the DECIMAL_NEG bit set.
  Hi32                      As Long ' unsigned
  Lo32                      As Long ' unsigned
  Mid32                     As Long ' unsigned
End Type


Public Function MakeDecimal( _
  ByVal HighDword As Long, _
  ByVal LowDword As Long, _
  Optional ByVal HighestDWord As Long, _
  Optional ByVal DecimalPlaces As Byte, _
  Optional ByVal Signed As Boolean) As Variant '===========================================================================
' MakeDecimal - Convert up to three 32 bit integers into a 64 bit value.
'===========================================================================

  Const DECIMAL_NEG = &H80&
  Dim dec As tagDECIMAL

  ' NOTE: The Decimal data type uses all of the VARIANT
  ' structure except the 2 lead VARTYPE bytes. The Decimal
  ' data type is a 12 byte/96-bit value.

  ' Fill the decimal structure
  With dec
    .wReserved = VT_DECIMAL
    .Lo32 = LowDword
    .Mid32 = HighDword
    .Hi32 = HighestDWord
    Select Case DecimalPlaces
    Case 0 To 28
      .scale = DecimalPlaces
    Case Else
      Err.Raise 5
    End Select
    
    If Signed Then
      .sign = DECIMAL_NEG
    End If
  End With
  
  ' Copy the data into return value
  CopyMemory ByVal VarPtr(MakeDecimal), _
    ByVal VarPtr(dec.wReserved), LenB(dec)

End Function

Public Function HiDWord(ByVal vDecimal As Variant) As Long '===========================================================================
'   HiDWord - Returns the middle 32 bits of a 64 bit value [expressed as a
'   Decimal or Currency within a Variant].
'
'   NOTE: This function is often called when working with file system based API
'   calls. For that reason we force the "value" as a Decimal/Variant. This is to
'   avoid the hassle and confusion of scaling when using a Currency data type.
'   The technique of using the Currency data type in place of structures like
'   FILETIME and LARGE_INTEGER, et al., can be very tricky and is sometimes hard
'   to tell when and why they need to be scaled and de-scaled.
'
'   vDecimal       The 64 bit value.
'
'   RETURNS     The high order DWORD of the supplied 64 bit value.
'===========================================================================

  Dim dec As tagDECIMAL
  
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' File the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec)

  HiDWord = dec.Mid32

End Function

Public Function LoDWord(ByVal vDecimal As Variant) As Long '===========================================================================
'   LoDWord - Returns the lower 32 bits of a 64 bit value [expressed as a
'   Decimal or Currency within a Variant].
'
'   NOTE: This function is often called when working with file system based API
'   calls. For that reason we force the "value" as a Decimal/Variant. This is to
'   avoid the hassle and confusion of scaling when using a Currency data type.
'   The technique of using the Currency data type in place of structures like
'   FILETIME and LARGE_INTEGER, et al., can be very tricky and is sometimes hard
'   to tell when and why they need to be scaled and de-scaled.
'
'   vDecimal       The 64 bit value.
'
'   RETURNS     The low order DWORD of the supplied 64 bit value.
'===========================================================================
    
  Dim dec As tagDECIMAL
  
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' Fill the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec)

  LoDWord = dec.Lo32

End Function


Public Function HighestDWord(ByVal vDecimal As Variant) As Long '===========================================================================
'   HighestDWord - Returns the Highest 32 bits of a 64 bit value [expressed
'   as a Decimal or Currency within a Variant].
'
'   NOTE: This function is often called when working with file system based API
'   calls. For that reason we force the "value" as a Decimal/Variant. This is to
'   avoid the hassle and confusion of scaling when using a Currency data type.
'   The technique of using the Currency data type in place of structures like
'   FILETIME and LARGE_INTEGER, et al., can be very tricky and is sometimes hard
'   to tell when and why they need to be scaled and de-scaled.
'
'   vDecimal      The 64 bit value.
'
'   RETURNS       The low order DWORD of the supplied 64 bit value.
'===========================================================================
    
  Dim dec As tagDECIMAL
  
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' Fill the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec)

  HighestDWord = dec.Hi32

End Function

Public Sub SplitDecimal( _
  ByVal vDecimal As Variant, _
  ByRef LowDword As Long, _
  ByRef HighDword As Long, _
  Optional ByRef HighestDWord As Long)

  Dim dec As tagDECIMAL
  
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' Fill the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec)

  ' Return each part of the decimal value
  LowDword = dec.Lo32
  HighDword = dec.Mid32
  HighestDWord = dec.Hi32

End Sub





