# ftsItem_content

c0Title: Generic ListBox Columns Routine
c1Code:
Use the SendMessage API to set tab stops in a VB listbox by creating these declarations and this routine in a module:

 
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_SETTABSTOPS = &H192
 
Public Sub SetListTabStops(ListHandle As Long, _
     ParamArray ParmList() As Variant)
     Dim i As Long
     Dim ListTabs() As Long
     Dim NumColumns As Long
 
     ReDim ListTabs(UBound(ParmList))
     For i = 0 To UBound(ParmList)
          ListTabs(i) = ParmList(i)
     Next i
     NumColumns = UBound(ParmList) + 1
 
     Call SendMessage(ListHandle, LB_SETTABSTOPS, _
          NumColumns, ListTabs(0))
End Sub
Call the routine in Form_Load to set the tab stops where MyListBox is the listbox and the tab stop will be around the 12th character. Generally speaking, TabStop divided by four equals roughly the number of characters per column:

Call SetListTabStops(lstMyListBox.hWnd, 48)

If more columns are needed, simply add them to the function call:

Call SetListTabStops(lstMyListBox.hWnd, 48, 74, 100)

Add items to the listbox using vbTab to separate columns:

lstMyListBox.AddItem "Column1" & vbTab & "Column2"

�Jim Farrell, Lincolnshire, Illinois


c0Title: Get a list of Windows Language Codepages
c1Code:
Option Explicit
 
Private Declare Function EnumSystemCodePages Lib "kernel32" Alias "EnumSystemCodePagesA" (ByVal lpCodePageEnumProc As Long, ByVal dwFlags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal Length As Long)
 
Private mnCodepages() As Long
 
Const CodePages_INSTALLED = &H1
Const CodePages_SUPPORTED = &H2
 
Const MAX_DEFAULTCHAR = 2
Const MAX_LEADBYTES = 12
 
Private Type CPINFO
  MaxCharSize As Long
  DefaultChar(MAX_DEFAULTCHAR) As Byte
  LeadByte(MAX_LEADBYTES) As Byte
End Type
 
Public Function GetCodePages(Optional nFlags As Long = CodePages_INSTALLED) As Long()
    Dim nItem As Long
    Dim CPInf As CPINFO
    
    ReDim mnCodepages(0 To 0)
    EnumSystemCodePages AddressOf CodePageCallback, nFlags
    
    GetCodePages = CopyArray(mnCodepages)
    
End Function
 
Private Function CodePageCallback(nCodePages_Pointer&) As Long
    Dim Buffer As String
    Buffer = Space$(255)
    CopyMemory ByVal Buffer, nCodePages_Pointer, Len(Buffer)
    Buffer = Left$(Buffer, InStr(Buffer, Chr$(0)) - 1)
    mnCodepages(UBound(mnCodepages)) = CLng(Buffer)
    ReDim Preserve mnCodepages(0 To UBound(mnCodepages) + 1)
    CodePageCallback = 1&
End Function
 

                                
Private Function CopyArray(nSource() As Long) As Long()
    Dim nBytes As Long
    Dim nDest() As Long
    
    ReDim nDest(LBound(nSource) To UBound(nSource))
    nBytes = (UBound(nSource) - LBound(nSource) + 1) * Len(nSource(1))
    Call CopyMemory(nDest(LBound(nDest)), nSource(LBound(nSource)), nBytes)
    CopyArray = nDest()
End Function


c0Title: Get Computer Name
c1Code:
Option Explicit

Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerNameW Lib "kernel32" (ByVal lpBuffer As Long, nSize As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function WNetGetLastErrorA Lib "mpr.dll" (lpError As Long, ByVal lpErrorBuf As String, ByVal nErrorBufSize As Long, ByVal lpNameBuf As String, ByVal nNameBufSize As Long) As Long
Private Declare Function RasGetErrorStringA Lib "RasApi32.DLL" (ByVal uErrorValue As Long, ByVal lpszErrorString As String, ByVal cBufSize As Long) As Long
Private Declare Function RasGetErrorStringW Lib "RasApi32.DLL" (ByVal uErrorValue As Long, ByVal lpszErrorString As Long, ByVal cBufSize As Long) As Long
Private Declare Function InternetGetLastResponseInfoA Lib "WinInet.dll" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function FormatMessageA Lib "kernel32" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function FormatMessageW Lib "kernel32" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As Long, ByVal nSize As Long, Arguments As Long) As Long

Public Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)

Private Enum OSVersionEnum
    VER_PLATFORM_WIN32s = 0
    VER_PLATFORM_WIN32_WINDOWS = 1
    VER_PLATFORM_WIN32_NT = 2
End Enum

Private Type OSVERSIONINFO                      ' operating system version information [used by GetVersion]
    dwOSVersionInfoSize     As Long
    dwMajorVersion          As Long
    dwMinorVersion          As Long
    dwBuildNumber           As Long
    dwPlatformId            As Long
    szCSDVersion            As String * 128     ' Maintenance string for PSS usage
End Type

Private Const MAX_COMPUTERNAME_LENGTH As Long = 15&

Private Success             As Boolean          ' general return code [boolean]
Private OSVersion           As OSVERSIONINFO    ' private structure for various Public functions

Public Function ComputerName() As String
'===========================================================================
'   ComputerName - Returns the name of the local machine.
'===========================================================================
  
  Dim NameLength      As Long
  
  ' size buffer to fit
  ComputerName = String(MAX_COMPUTERNAME_LENGTH + 1, 0)
  NameLength = Len(ComputerName)
  
  ' Get the computer name
  Success = GetComputerName(ComputerName, NameLength)
  If Success Then
    ' strip null terminators
    ComputerName = Left$(ComputerName, NameLength)
  Else
    ApiRaise
  End If

End Function


Public Function GetComputerName(lpBuffer As String, nSize As Long) As Long
'===========================================================================
'   GetComputerName - ANSI/WIDE wrapper. Refer to the SDK.
'===========================================================================
    If Len(lpBuffer) = 0 Then lpBuffer = vbNullString   ' ensure blanks made NULL
    
    If IsWinNt Then                     ' running in NT, use WIDE calls
        GetComputerName = GetComputerNameW(StrPtr(lpBuffer), nSize)
    Else                                ' running on Win9X, use ANSI calls
        GetComputerName = GetComputerNameA(lpBuffer, nSize)
    End If
    
End Function

Public Function IsWinNt() As Boolean
'===========================================================================
'   IsWinNT - Returns true if we're running Windows NT.
'===========================================================================
Exit Function
    ' NOTE: OSVERSIONINFO is defined at the module
    ' for imporved performance.
    
    If OSVersion.dwOSVersionInfoSize = 0 Then               ' this is our first time making this call
        OSVersion.dwOSVersionInfoSize = Len(OSVersion)      ' initialize so API knows which version being used
        GetVersionEx OSVersion                              ' make the call once & then save/re-use it
    End If

    IsWinNt = OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT ' return the result
    
End Function

Public Sub ApiRaise(Optional ByVal Number As Long, _
                    Optional ByVal Source As String, _
                    Optional ByVal DescPrefix As String, _
                    Optional ByVal HelpFile As String, _
                    Optional ByVal HelpContext As Long, _
                    Optional ByVal NewLineCharacter As String = vbCrLf)
'===========================================================================
'   ApiRaise - Builds and throws an error returned from a Win32 API call.
'
'   NewLineCharacter    Allows the caller to convert linefeeds to a space or
'                       other character. This helps when displaying log entries
'                       in a List that cannot display multiple lines.
'
'   All other parameters are the same as Err.Raise method.
'
'   NOTE: &H80070000 will be added to Number. This number represents the
'   first 16 bits of an HRESULT (facility code of FACILITY_WIN32). Kudos
'   to Matt Curland for this technique!
'
'===========================================================================
        

    ' Use LastDllError if no Number supplied
    If Number = 0 Then
        Number = Err.LastDllError
    End If

    ' Use EXE name if no Source supplied
    If Len(Source) = 0 Then
        Source = App.EXEName
    End If
    
    ' If a msg prefix is used then massage the message
    If Len(DescPrefix) > 0 Then
        
        ' Terminate prefix with a period if not.
        DescPrefix = Trim$(DescPrefix)
        Select Case Right$(DescPrefix, 1)
        Case ".", "?", "!"
            ' this case perhaps not too locale friendly
        Case Else
            DescPrefix = DescPrefix & "."
        End Select
        
        ' Build error message and throw it
        On Error GoTo 0
        Err.Raise &H80070000 + Number, Source, _
            DescPrefix & NewLineCharacter & LastDllErrorMsg(Number, NewLineCharacter), _
            HelpFile, HelpContext
    
        ' NOTE: The Err.Raise(&H80070000 + nErr) will map the
        ' following Win32 errors to their VB equivilents.
        '
        ' Win32# -> maps to ->
        '        ->   VB#   VB Error Description
        ' --------------------------------------------------------------------
        '      5       70   Permission denied
        '     14        7   Out of memory
        '     87        5   Invalid procedure call or argument
        '   1722      462   The remote server machine does not
        '                   exist or is unavailable
    
    Else
        
        ' Build error message and throw it
        On Error GoTo 0
        Err.Raise &H80070000 + Number, Source, _
            LastDllErrorMsg(Number, NewLineCharacter), _
            HelpFile, HelpContext
    
    End If
    
End Sub


Public Function LastDllErrorMsg(Optional ByVal Number As Long, _
                                Optional ByVal NewLineCharacter As String = vbCrLf) As String
'===============================================================================
'   LastDllErrorMsg - Returns the description of the supplied error number.
'
'   Number              Optional. The number to decode if supplied, otherwise the
'                       Err.LastDllError is used.
'   NewLineCharacter    Optional. Use to specificy an alternate character for CR/LFs
'===============================================================================
    
    Const ERROR_INSUFFICIENT_Message = 122&
    Const FORMAT_MESSAGE_FROM_HMODULE = &H800&
    Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
    Const ERROR_EXTENDED_ERROR = 1208&
    Dim Message         As String   ' Place where error description will be nSize to.
    Dim Provider        As String   ' Place where error next provider output to
    Dim nSize           As Long     ' Number of bytes nSize to Message
    Dim Result          As Long     ' general return code
    Dim Success         As Boolean
    Dim ErrorCode       As Long
    Dim PreservedDllErr As Long     ' saved error number; since error functions w/be calling this


    On Error GoTo ExitLabel                     ' There shouldnt be any errors here.
    PreservedDllErr = Err.LastDllError          ' save LastDllError as it will be restored on exit
    
    If Number = 0 Then                          ' no error code supplied
        Number = Err.LastDllError               ' use the VB last known API error code
    ElseIf (Number And &H8000&) = 0 Then        ' 'possible' HRESULT
        ' NOTE: We must often contend with errors returned by VB
        ' and other interfaces with a description of "OLE Automation Error".
        ' These HRESULTS can OFTEN be translated to a Windows' system error
        ' by it's low word. This is typical when trying to create an object
        ' (perhaps via DCOM) or when accessing an object via a system
        ' interface such as IShellFolder.
        Number = Number And &HFFFF&             ' Essentially, we strip vbObjectError
    End If
    
    ' init output Message & clear LastDllError
    SetLastError 0
    nSize = 0
    
    '  Translate generic error descriptions
    Select Case Number
    Case ERROR_EXTENDED_ERROR
        ' server has extended error info
        
        ' Initialize output buffers
        Message = String(512, 0)
        Provider = String(128, 0)
        
        ' Get the error info from the server
        Result = WNetGetLastErrorA(ErrorCode, Message, Len(Message), Provider, Len(Provider))
        If Result = 0 Then
            ' call succeeded
            
            ' Strip NULLs from the strings
            Message = TrimNulls(Message)
            Provider = TrimNulls(Provider)
        
        End If
        
        ' Build friendly message
        Message = Provider & " returned error #" & ErrorCode & " " & Message & "."
        nSize = Len(Message)

    Case 600 To 799
        ' RAS specific codes have an error base of 600
        
        ' Initialize our Message and translate the error code
        Message = String(512, 0)
        nSize = Len(Message)
        Result = RasGetErrorStringA(Number, Message, nSize)
        If Result = 0 Then
            ' call succeeded
            
            ' Fetch message size
            nSize = InStr(Message, vbNullChar) - 1
            ' Sanity check
            If nSize < 0 Then nSize = 0
        End If
        
    Case 12003 'ERROR_INTERNET_EXTENDED_ERROR
        ' wininet extended errors
        
        ' Fetch Message size needed
        nSize = 0
        Success = InternetGetLastResponseInfoA(Result, Message, nSize)
        
        ' Size Message to fit
        Message = String(nSize + 1, 0)
        Success = InternetGetLastResponseInfoA(Result, Message, (nSize))

        ' ********************************************************
        ' BTW: Parsing this string may allow us to re-map
        '      to a real error. This is where we end up when
        '      the wininet parser fails (even on simple things
        '      that might not represent an error condition).
        ' ********************************************************
        ' CALLER should call my function MapFtpResponse() which
        ' will attempt to map an FTP response code marked as
        ' ERROR_INTERNET_EXTENDED_ERROR to a matching Win32 error.
        ' ********************************************************

    Case 12000 To 12999
        ' wininet specific errors
        
        ' This functions assume that wininet.dll is already mapped into memory
        Result = GetModuleHandleA("wininet.dll")
        
        If Result <> 0 Then
            
            ' Initialize our Message and translate the error code
            Message = Space(256)
            nSize = _
                FormatMessageA(FORMAT_MESSAGE_FROM_HMODULE, _
                               ByVal Result, Number, 0&, Message, 255, ByVal 0&)
        
        ' Else: we could be nice and temporarily load the library
        End If


    Case Else
        ' All other Windows errors
        
        ' Initialize our Message and translate the error code
        Message = Space(256)
        nSize = _
            FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, _
                           ByVal 0&, Number, 0&, Message, 255&, ByVal 0&)
    End Select

    ' return the error description
    LastDllErrorMsg = Left$(Message, nSize)

    ' If the caller wants to translate line breaks then do so
    If StrComp(NewLineCharacter, vbCrLf, vbBinaryCompare) <> 0 Then
        LastDllErrorMsg = Replace(LastDllErrorMsg, vbCrLf, Left$(NewLineCharacter, 1))
    End If
    
    ' Strip ending CR/LF's as many message tables like to add this.
    If Right$(LastDllErrorMsg, 2) = vbCrLf Then
        LastDllErrorMsg = Left$(LastDllErrorMsg, Len(LastDllErrorMsg) - 2)
    End If

    ' Terminate description with a period if not.
    Select Case Right$(LastDllErrorMsg, 1)
    Case ".", "?", "!"
        ' this case not very locale friendly
    Case Else
        LastDllErrorMsg = LastDllErrorMsg & "."
    End Select

ExitLabel:
    ' Restore Err.LastDllError value is it was on entry
    SetLastError PreservedDllErr
    
    Debug.Assert (Err.Number = 0)
    
End Function


Public Function TrimNulls(InString As String) As String
'===========================================================================
'   TrimNulls - Trims null terminators from a string.
'
'   InString        The string to strip nulls from.
'
'   RETURNS         The resulting string.
'===========================================================================
Dim Pos     As Long     ' location of null terminator

    Pos = InStr(InString, Chr$(0))              ' find null terminator
    If Pos > 0 Then                             ' terminator located
        TrimNulls = Left$(InString, Pos - 1)    ' strip terminator
    Else                                        ' no terminator found
        TrimNulls = InString                    ' return the supplied input string
    End If
    
End Function




c0Title: Get Computer Name (Simple)
c1Code:
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Function ComputerName() As String
  Dim lsBuffer As String
  Dim llReturn As Long
  Dim lsName As String
 
  lsName = ""
  lsBuffer = Space$(255)
  llReturn = GetComputerName(lsBuffer, 255)
  
  If llReturn Then
        lsName = Left$(lsBuffer, InStr(lsBuffer, Chr(0)) - 1)
  End If
  
  ComputerName = lsName
End Function


c0Title: Get data from a pointer
c1Code:
Option Explicit

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

Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Private Const INVALID_HANDLE_VALUE  As Long = -1

Private Type OSVERSIONINFO                      ' operating system version information [used by GetVersion]
    dwOSVersionInfoSize     As Long
    dwMajorVersion          As Long
    dwMinorVersion          As Long
    dwBuildNumber           As Long
    dwPlatformId            As Long
    szCSDVersion            As String * 128     ' Maintenance string for PSS usage
End Type

Private Enum OSVersionEnum
    VER_PLATFORM_WIN32s = 0
    VER_PLATFORM_WIN32_WINDOWS = 1
    VER_PLATFORM_WIN32_NT = 2
End Enum

Private OSVersion           As OSVERSIONINFO    ' private structure for various Public functions

Public Function PtrToStr(lpString As Long, Optional nBytes As Long = -1) As String '===========================================================================
'   PtrToStr - Wrapper function for PtrToStrA and PtrToStrW based on the current
'   operating system.
'===========================================================================

    If IsWinNt Then
        PtrToStr = PtrToStrW(lpString, nBytes)
    Else
        PtrToStr = PtrToStrA(lpString, nBytes)
    End If
    
End Function

Public Function PtrToStrA(ByVal lpString As Long, _
                          Optional ByVal nBytes As Long = -1) As String '===========================================================================
'   PtrToStrA - Converts a pointer to a ANSI string to a BSTR (string).
'
'   lpString        Pointer to an ANSI string.
'   nBytes          The size of the string in bytes. If -1, then lpString is
'                   assumed to be null terminated.
'
'   RETURNS         The string as pointed to by lpString, or vbNullString
'                   if lpString is zero.
'===========================================================================

    Dim Buffer()    As Byte     ' size of buffer

    PtrToStrA = vbNullString                        ' return null pointer by default
    
    Select Case lpString                            ' validate the pointer
    Case 0, INVALID_HANDLE_VALUE                    ' bogus pointer supplied
        Exit Function                               ' return an empty string for null address
    End Select
    
    If nBytes = 0 Then                              ' zero length string
        Exit Function                               ' we're done
    ElseIf nBytes = -1 Then
        nBytes = lstrlenA(ByVal lpString)           ' how big is the string?
    End If
    If nBytes <= 0 Then Exit Function               ' exit if empty
    
    ReDim Buffer(1 To nBytes)                       ' size array to fit
    CopyMemory ByVal VarPtr(Buffer(1)), _
        ByVal lpString, nBytes                      ' copy string to byte array work area
    
    PtrToStrA = StrConv(Buffer, vbUnicode)          ' convert to Unicode
    
End Function

Public Function PtrToData(ByVal lpData As Long, ByVal DataType As VbVarType, _
                           Optional ByVal Length As Long = -1) As Variant '===========================================================================
'   PtrToData - This functions takes a long pointer to a data element and
'   converts it to a variant of subtype DataType.
'
'   lpData          Pointer to the data element to convert.
'   DataType        Type of data being converted.
'   Length          Optional. Size of data [vbString and vbByte+vbArray only].
'                   However, in some cases we allow this member to be set.
'                   For instance, a caller may only need to copy the first 8
'                   bytes in the case of a Decimal data type which would be
'                   typical when working with API's and 64 bit values split
'                   into DWORDs.
'
'   RETURNS         The data element as a variant.
'===========================================================================

    Dim VType       As Integer      ' the VARTYPE member of the VARIANT structure

    On Error GoTo ErrHandler
    
    ' This SELECT CASE identifies the data type and initializes VARTYPE.
    ' The actual data is copied after the switch, except for the exceptions
    ' such as byte array, currency and string data types which are handled
    ' in-line.
    Select Case DataType
        
    Case vbByte
        
        PtrToData = CByte(PtrToData)
        Length = 1
        
    Case vbBoolean
        
        PtrToData = CBool(PtrToData)
        If Length = -1 Then Length = 2
        
    Case vbInteger
        
        PtrToData = CInt(PtrToData)
        If Length = -1 Then Length = 2
        
    Case vbLong
        
        PtrToData = CLng(PtrToData)
        If Length = -1 Then Length = 4
        
    Case vbSingle
        
        PtrToData = CSng(PtrToData)
        Length = 4
        
    Case vbDate
        
        PtrToData = CDate(PtrToData)
        Length = 8
        
    Case vbDouble
        
        PtrToData = CDbl(PtrToData)
        Length = 8
        
    Case vbDecimal
                
        ' Caller should use MakeDecimal
        Err.Raise 5
        
    Case vbObject
        
        Set PtrToData = PtrToObj(lpData)
        GoTo ExitLabel
        
    Case (vbByte Or vbArray)
        
        Dim bArray()    As Byte
        
        ' Size temp array to fit
        ReDim bArray(1 To Length)
        ' Copy the data into the array
        CopyMemory ByVal VarPtr(bArray(1)), ByVal lpData, Length
        
        ' return the array
        PtrToData = bArray
        GoTo ExitLabel
    
    Case vbCurrency
    
        ' This case handled out of the switch because of scaling
        PtrToData = CCur(PtrToData)
        Length = 8
        
        ' Copy the data into return value
        CopyMemory ByVal VarPtr(PtrToData) + 8, ByVal lpData, Length
        
        ' Handle the scale
        PtrToData = PtrToData * 10000
        GoTo ExitLabel
    
    Case vbString
        
        ' Assumed to be a VB native WIDE string
        
        ' Convert to unicode string
        PtrToData = PtrToStrW(lpData, Length)
        GoTo ExitLabel
    
    Case Else
    
        ' we should never be here
        Debug.Assert 0
        
        ' Throw error to caller
        On Error GoTo 0
        Err.Raise 5
    
    End Select
    
    ' NOTE: A Variant's descriptor, padding & union take up 8 bytes.
    ' Therefore, the data (or pointer to data) is located at bytes 9-12 or 9-16
    
    ' Copy the data into return value
    CopyMemory ByVal VarPtr(PtrToData) + 8, ByVal lpData, Length
        
ExitLabel:
    
    Exit Function
    Resume
ErrHandler:
    Debug.Assert 0
    Resume ExitLabel
    
End Function


Public Function PtrToObj(ByVal lpObject As Long) As Object

    Dim WeakRef     As Object

    On Error GoTo ErrHandler

    ' Get the object pointer attached to this window's user data
    If Not IsValidHandle(lpObject) Then Exit Function

    ' Create the weak reference
    Call CopyMemoryAny(WeakRef, lpObject, 4)

    ' Return the object reference
    If Not WeakRef Is Nothing Then
        Set PtrToObj = WeakRef
    End If

    ' Kill the illegal reference
    'ZeroMemory ByVal ObjPtr(WeakRef), 4
    Call CopyMemoryAny(WeakRef, 0&, 4&)
    
    Exit Function
    Resume
ErrHandler:
    Set PtrToObj = Nothing
    Resume Next
    
End Function


Public Function PtrToStrW(ByVal lpString As Long, _
                          Optional ByVal nBytes As Long = -1) As String '===========================================================================
'   PtrToStrW - Converts a pointer to a WIDE string to a BSTR (string).
'
'   lpString        Pointer to a WIDE string.
'   nBytes          The size of the string in bytes. If -1, then lpString is
'                   assumed to be null terminated.
'
'   RETURNS         The string as pointed to by lpString, or vbNullString
'                   if lpString is zero.
'===========================================================================
    
    Dim Buffer()    As Byte     ' size of buffer

    PtrToStrW = vbNullString                        ' return null pointer by default
    
    Select Case lpString                            ' validate the pointer
    Case 0, INVALID_HANDLE_VALUE                    ' bogus pointer supplied
        Exit Function                               ' return an empty string for null address
    End Select
    
    If nBytes = 0 Then                              ' zero length string
        Exit Function                               ' we're done
    ElseIf nBytes = -1 Then
        nBytes = lstrlenW(lpString) * 2             ' how big is the string?
    End If
    If nBytes <= 0 Then Exit Function               ' exit if empty
    
    ReDim Buffer(1 To nBytes)                       ' size array to fit
    CopyMemory ByVal VarPtr(Buffer(1)), _
        ByVal lpString, nBytes                      ' copy string to byte array work area
        
    PtrToStrW = Buffer                              ' Return the Unicode string

End Function

Public Function IsValidHandle(ByVal Handle As Long) As Boolean

    Const INVALID_HANDLE_VALUE = -1
    
    Select Case Handle
    Case 0, INVALID_HANDLE_VALUE
    Case Else
        IsValidHandle = True
    End Select
    
End Function



Public Function IsWinNt() As Boolean
'===========================================================================
'   IsWinNT - Returns true if we're running Windows NT.
'===========================================================================
Exit Function
    ' NOTE: OSVERSIONINFO is defined at the module
    ' for imporved performance.
    
    If OSVersion.dwOSVersionInfoSize = 0 Then               ' this is our first time making this call
        OSVersion.dwOSVersionInfoSize = Len(OSVersion)      ' initialize so API knows which version being used
        GetVersionEx OSVersion                              ' make the call once & then save/re-use it
    End If

    IsWinNt = OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT ' return the result
    
End Function




c0Title: Get Disk Free Space
c2File: getfree.zip
c1Code:
Techniques demonstrated in this project
---------------------------------------
-Handling GetDiskFreeSpaceEx() API which returns
 three 64bit long integers
-Using GetProcAddress() to determine at runtime
 if newer APIs are available on the current platform 
 

Useful functions in GetFree.bas
--------------------------------
ExistGetDiskFreeSpaceEx()
vbGetAvailableBytesAsString()
vbGetTotalBytesAsString()
vbGetAvailableKBytesAsString()
vbGetTotalKBytesAsString()
vbGetAvailableMBytesAsString()
vbGetTotalMBytesAsString()
vbGetPercentAvailable()
 
Another exclusive free product from Shrinkwrap Visual Basic(tm)!
http://www.shrinkwrapvb.com


c0Title: Get Dropdown�s hWnd Without Subclassing
c1Code:
I�ve written code to get the hWnd for a combo�s dropdown. When a combo�s DropDown event is fired, the dropdown is not yet visible on the screen. Post a WM_KEYDOWN to the combo, which causes the combo�s KeyDown event to fire after the dropdown is visible. Then use the Win32 API calls ClientToScreen, WindowFromPoint, and GetClassName to locate the dropdown window. Once you have the dropdown�s hWnd, you can move and resize the dropdown window using Win32 API calls such as SetWindowPos. You�ll find this technique useful where the width of the combo is less then the width of the combo�s longest item text. To shorten the code listing, I�m leaving to you the case where the dropdown is dropped above the combo:

 

Option Explicit

Private Type POINTAPI
       x As Long
       y As Long
End Type

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Const WM_KEYDOWN = &H100
Private Const KEY_CODE_DROPDOWN = 256

Private Sub Combo1_DropDown()
       'This will cause Combo1_KeyDown to fire 
       'after the DropDown is shown
       Call PostMessage(Combo1.hWnd, WM_KEYDOWN, KEY_CODE_DROPDOWN, 0)
End Sub

 
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer) Dim hwndDropdown As Long
       If KeyCode = KEY_CODE_DROPDOWN Then
              hwndDropdown = GetHwndDropdown(Combo1)
             Debug.Print hwndDropdown
       End If
End Sub


Private Function GetHwndDropdown(cbo As ComboBox) As Long
       Dim ptDropDown As POINTAPI
       Dim hwndDropdown As Long
       Dim sClassName As String
       Dim lRetLen As Long

       ptDropDown.x = (cbo.Width / 2) / Screen.TwipsPerPixelX
       ptDropDown.y = (cbo.Height * 1.1) / Screen.TwipsPerPixelY

       Call ClientToScreen(cbo.hWnd, ptDropDown)
       hwndDropdown = WindowFromPoint(ptDropDown.x, ptDropDown.y)
       sClassName = String$(255, Chr$(0))
       lRetLen = GetClassName(hwndDropdown, sClassName, Len(sClassName))

       If lRetLen > 1 Then
             If Left$(sClassName, lRetLen) = "ComboLBox" Then
                    GetHwndDropdown = hwndDropdown
             End If
       End If
End Function

�Mike Hill, Northridge, California


c0Title: Get Last Day Of Month
c1Code:
This is a small function that returns the last day of a month that it's passed. 
        
Code: 

Public Function GetLastDayOfMonth(FromDate As Date) As Date
    GetLastDayOfMonth = DateSerial(DatePart("yyyy", FromDate), DatePart("m", FromDate), 1)
    GetLastDayOfMonth = DateAdd("m", 1, GetLastDayOfMonth)
    GetLastDayOfMonth = DateAdd("d", -1, GetLastDayOfMonth)
End Function

     
Sample Usage: 
        
Debug.Print GetLastDayOfMonth(#12/1/1999#)


c0Title: Get Last Item In a String
c1Code:
The following function will return the last item of a string based on whatever delimiter you pass in. The default delimiter is the Space character. 

NOTE: This is only available in VB6. 

Code:
 
Function GetLastItem(ByVal strSource As String, Optional ByVal strDelimiter As String = " ") As String 
    'use InStrRev to locate the delimiter, then return the last part 
    ' using the Right$ function in conjunction with Len and InStrRev 
    GetLastItem = Right$(strSource, Len(strSource) - InStrRev(strSource, strDelimiter)) 
End Function


c0Title: Get Locale Information
c1Code:
Private Const LOCALE_ICENTURY = &H24                '  century format specifier
Private Const LOCALE_ICOUNTRY = &H5                 '  country code
Private Const LOCALE_ICURRDIGITS = &H19             '  # local monetary digits
Private Const LOCALE_ICURRENCY = &H1B               '  positive currency mode
Private Const LOCALE_IDATE = &H21                   '  short date format ordering
Private Const LOCALE_IDAYLZERO = &H26               '  leading zeros in day field
Private Const LOCALE_IDEFAULTCODEPAGE = &HB         '  default code page
Private Const LOCALE_IDEFAULTCOUNTRY = &HA          '  default country code
Private Const LOCALE_IDEFAULTLANGUAGE = &H9         '  default language id
Private Const LOCALE_IDIGITS = &H11                 '  number of fractional digits
Private Const LOCALE_IINTLCURRDIGITS = &H1A         '  # intl monetary digits
Private Const LOCALE_ILANGUAGE = &H1                '  language id
Private Const LOCALE_ILDATE = &H22                  '  long date format ordering
Private Const LOCALE_ILZERO = &H12                  '  leading zeros for decimal
Private Const LOCALE_IMEASURE = &HD                 '  0 = metric, 1 = US
Private Const LOCALE_IMONLZERO = &H27               '  leading zeros in month field
Private Const LOCALE_INEGCURR = &H1C                '  negative currency mode
Private Const LOCALE_INEGSEPBYSPACE = &H57          '  mon sym sep by space from neg amt
Private Const LOCALE_INEGSIGNPOSN = &H53            '  negative sign position
Private Const LOCALE_INEGSYMPRECEDES = &H56         '  mon sym precedes neg amt
Private Const LOCALE_IPOSSEPBYSPACE = &H55          '  mon sym sep by space from pos amt
Private Const LOCALE_IPOSSIGNPOSN = &H52            '  positive sign position
Private Const LOCALE_IPOSSYMPRECEDES = &H54         '  mon sym precedes pos amt
Private Const LOCALE_ITIME = &H23                   '  time format specifier
Private Const LOCALE_ITLZERO = &H25                 '  leading zeros in time field
Private Const LOCALE_NOUSEROVERRIDE = &H80000000    '  do not use user overrides
Private Const LOCALE_S1159 = &H28                   '  AM designator
Private Const LOCALE_S2359 = &H29                   '  PM designator
Private Const LOCALE_SABBREVCTRYNAME = &H7          '  abbreviated country name
Private Const LOCALE_SABBREVDAYNAME1 = &H31         '  abbreviated name for Monday
Private Const LOCALE_SABBREVDAYNAME2 = &H32         '  abbreviated name for Tuesday
Private Const LOCALE_SABBREVDAYNAME3 = &H33         '  abbreviated name for Wednesday
Private Const LOCALE_SABBREVDAYNAME4 = &H34         '  abbreviated name for Thursday
Private Const LOCALE_SABBREVDAYNAME5 = &H35         '  abbreviated name for Friday
Private Const LOCALE_SABBREVDAYNAME6 = &H36         '  abbreviated name for Saturday
Private Const LOCALE_SABBREVDAYNAME7 = &H37         '  abbreviated name for Sunday
Private Const LOCALE_SABBREVLANGNAME = &H3          '  abbreviated language name
Private Const LOCALE_SABBREVMONTHNAME1 = &H44       '  abbreviated name for January
Private Const LOCALE_SABBREVMONTHNAME10 = &H4D      '  abbreviated name for October
Private Const LOCALE_SABBREVMONTHNAME11 = &H4E      '  abbreviated name for November
Private Const LOCALE_SABBREVMONTHNAME12 = &H4F      '  abbreviated name for December
Private Const LOCALE_SABBREVMONTHNAME13 = &H100F
Private Const LOCALE_SABBREVMONTHNAME2 = &H45       '  abbreviated name for February
Private Const LOCALE_SABBREVMONTHNAME3 = &H46       '  abbreviated name for March
Private Const LOCALE_SABBREVMONTHNAME4 = &H47       '  abbreviated name for April
Private Const LOCALE_SABBREVMONTHNAME5 = &H48       '  abbreviated name for May
Private Const LOCALE_SABBREVMONTHNAME6 = &H49       '  abbreviated name for June
Private Const LOCALE_SABBREVMONTHNAME7 = &H4A       '  abbreviated name for July
Private Const LOCALE_SABBREVMONTHNAME8 = &H4B       '  abbreviated name for August
Private Const LOCALE_SABBREVMONTHNAME9 = &H4C       '  abbreviated name for September
Private Const LOCALE_SCOUNTRY = &H6                 '  localized name of country
Private Const LOCALE_SCURRENCY = &H14               '  local monetary symbol
Private Const LOCALE_SDATE = &H1D                   '  date separator
Private Const LOCALE_SDAYNAME1 = &H2A               '  long name for Monday
Private Const LOCALE_SDAYNAME2 = &H2B               '  long name for Tuesday
Private Const LOCALE_SDAYNAME3 = &H2C               '  long name for Wednesday
Private Const LOCALE_SDAYNAME4 = &H2D               '  long name for Thursday
Private Const LOCALE_SDAYNAME5 = &H2E               '  long name for Friday
Private Const LOCALE_SDAYNAME6 = &H2F               '  long name for Saturday
Private Const LOCALE_SDAYNAME7 = &H30               '  long name for Sunday
Private Const LOCALE_SDECIMAL = &HE                 '  decimal separator
Private Const LOCALE_SENGCOUNTRY = &H1002           '  English name of country
Private Const LOCALE_SENGLANGUAGE = &H1001          '  English name of language
Private Const LOCALE_SGROUPING = &H10               '  digit grouping
Private Const LOCALE_SINTLSYMBOL = &H15             '  intl monetary symbol
Private Const LOCALE_SLANGUAGE = &H2                '  localized name of language
Private Const LOCALE_SLIST = &HC                    '  list item separator
Private Const LOCALE_SLONGDATE = &H20               '  long date format string
Private Const LOCALE_SMONDECIMALSEP = &H16          '  monetary decimal separator
Private Const LOCALE_SMONGROUPING = &H18            '  monetary grouping
Private Const LOCALE_SMONTHNAME1 = &H38             '  long name for January
Private Const LOCALE_SMONTHNAME10 = &H41            '  long name for October
Private Const LOCALE_SMONTHNAME11 = &H42            '  long name for November
Private Const LOCALE_SMONTHNAME12 = &H43            '  long name for December
Private Const LOCALE_SMONTHNAME2 = &H39             '  long name for February
Private Const LOCALE_SMONTHNAME3 = &H3A             '  long name for March
Private Const LOCALE_SMONTHNAME4 = &H3B             '  long name for April
Private Const LOCALE_SMONTHNAME5 = &H3C             '  long name for May
Private Const LOCALE_SMONTHNAME6 = &H3D             '  long name for June
Private Const LOCALE_SMONTHNAME7 = &H3E             '  long name for July
Private Const LOCALE_SMONTHNAME8 = &H3F             '  long name for August
Private Const LOCALE_SMONTHNAME9 = &H40             '  long name for September
Private Const LOCALE_SMONTHOUSANDSEP = &H17         '  monetary thousand separator
Private Const LOCALE_SNATIVECTRYNAME = &H8          '  native name of country
Private Const LOCALE_SNATIVEDIGITS = &H13           '  native ascii 0-9
Private Const LOCALE_SNATIVELANGNAME = &H4          '  native name of language
Private Const LOCALE_SNEGATIVESIGN = &H51           '  negative sign
Private Const LOCALE_SPOSITIVESIGN = &H50           '  positive sign
Private Const LOCALE_SSHORTDATE = &H1F              '  short date format string
Private Const LOCALE_STHOUSAND = &HF                '  thousand separator
Private Const LOCALE_STIME = &H1E                   '  time separator
Private Const LOCALE_STIMEFORMAT = &H1003           '  time format string

Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long

' Return a piece of locale information.
Private Function LocaleInfo(ByVal locale As Long, ByVal lc_type As Long) As String Dim length As Long Dim buf As String * 1024

    length = GetLocaleInfo(locale, lc_type, buf, Len(buf))
    LocaleInfo = Left$(buf, length - 1)
End Function




c0Title: Get MAC Address
c1Code:
Description: 
This function accepts a collection, and returns all available network card MAC addresses. 
        
Code: 

Option Explicit

Private Const NCBNAMSZ = 16
Private Const MAX_LANA = 254
Private Const NCBENUM = &H37
Private Const NCBRESET = &H32
Private Const NCBASTAT = &H33

Private Type ADAPTER_STATUS
    adapter_address(0 To 5) As Byte
    rev_major As Byte
    reserved0 As Byte
    adapter_type As Byte
    rev_minor As Byte
    duration As Integer
    frmr_recv As Integer
    frmr_xmit As Integer
    iframe_recv_err As Integer
    xmit_aborts As Integer
    xmit_success As Long
    recv_success As Long
    iframe_xmit_err As Integer
    recv_buff_unavail As Integer
    t1_timeouts As Integer
    ti_timeouts As Integer
    reserved1 As Long
    free_ncbs As Integer
    max_cfg_ncbs As Integer
    max_ncbs As Integer
    xmit_buf_unavail As Integer
    max_dgram_size As Integer
    pending_sess As Integer
    max_cfg_sess As Integer
    max_sess As Integer
    max_sess_pkt_size As Integer
    name_count As Integer
End Type

Private Type NAME_BUFFER
    name_(0 To NCBNAMSZ - 1) As Byte
    name_num As Byte
    name_flags As Byte
End Type
 
Private Type ASTAT
    adapt As ADAPTER_STATUS
    NameBuff(0 To 29) As NAME_BUFFER
End Type

Private Type NCB
    ncb_command As Byte
    ncb_retcode As Byte
    ncb_lsn As Byte
    ncb_num As Byte
    p_ncb_buffer As Long
    ncb_length As Integer
    ncb_callname(0 To NCBNAMSZ - 1) As Byte
    ncb_name(0 To NCBNAMSZ - 1) As Byte
    ncb_rto As Byte
    ncb_sto As Byte
    p_ncb_post As Long
    ncb_lana_num As Byte
    ncb_cmd_cplt As Byte
    ncb_reserve(0 To 10 - 1) As Byte
    ncb_event As Long
End Type
 
Private Type LANA_ENUM
    length As Byte
    lana(0 To MAX_LANA - 1) As Byte
End Type
 
Private Declare Function Netbios Lib "netapi32.dll" _
        (pncb As NCB) As Byte
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (dest As Any, src As Any, ByVal length As Long) As Long

Public Sub GetMacAddress(colMacAddress As Collection)

    Dim Adapter As ASTAT
    Dim SNcb As NCB
    Dim uRetCode As Byte
    Dim NetName(0 To 49) As Byte
    Dim Blank(Len(SNcb)) As Byte
    Dim Blank2(Len(Adapter)) As Byte
    Dim lenum As LANA_ENUM
    Dim i As Long
    Dim j As Long
    Dim sMac As String

    CopyMemory SNcb, Blank(0), Len(SNcb)
    With SNcb
        .ncb_command = NCBENUM
        .p_ncb_buffer = VarPtr(lenum)
        .ncb_length = Len(lenum)
    End With
    uRetCode = Netbios(SNcb)
    
    For i = 0 To lenum.length - 1
        CopyMemory SNcb, Blank(0), Len(SNcb)
        With SNcb
            .ncb_command = NCBRESET
            .ncb_lana_num = lenum.lana(i)
        End With
    
        uRetCode = Netbios(SNcb)
        
        CopyMemory SNcb, Blank(0), Len(SNcb)
        CopyMemory Adapter, Blank2(0), Len(Adapter)
        With SNcb
            .ncb_command = NCBASTAT
            .ncb_lana_num = lenum.lana(i)
            .p_ncb_buffer = VarPtr(Adapter)
            .ncb_length = Len(Adapter)
            .ncb_callname(0) = Asc("*")
            For j = 1 To 15
                .ncb_callname(j) = Asc(" ")
            Next
        End With
        uRetCode = Netbios(SNcb)
        If uRetCode = 0 Then
            With Adapter.adapt
                sMac = Right("00" & Hex(.adapter_address(0)), 2) & _
                       Right("00" & Hex(.adapter_address(1)), 2) & _
                       Right("00" & Hex(.adapter_address(2)), 2) & _
                       Right("00" & Hex(.adapter_address(3)), 2) & _
                       Right("00" & Hex(.adapter_address(4)), 2) & _
                       Right("00" & Hex(.adapter_address(5)), 2)
            End With
            colMacAddress.Add sMac
        End If
    Next
End Sub

     
        
Sample Usage: 
        
Dim col As Collection
Dim vItem As Variant
    
Set col = New Collection
    
GetMacAddress col
    
For Each vItem In col
    Debug.Print vItem
Next

     



c0Title: Get Short or Long Filename
c1Code:
Just call the function, pass in a short filename and it will return the long filename. 

Public Function GetLongName(ByVal psShortName As String) As String
  Dim liPos As Integer
  Dim lsLongName As String
  Dim lsDirName As String
  
  psShortName = psShortName & "\"
  liPos = InStr(4, psShortName, "\")
  
  While liPos
    lsDirName = Dir(Left$(psShortName, liPos - 1), _
      vbNormal + vbHidden + vbSystem + vbDirectory)
    
    If lsDirName = "" Then
      GetLongName = ""
      Exit Function
    End If
    
    lsLongName = lsLongName & "\" & lsDirName
    liPos = InStr(liPos + 1, psShortName, "\")
  Wend

  GetLongName = Left$(psShortName, 2) & lsLongName End Function


Just change the variable lsLongName to any valid path for your system and run the example. A MsgBox should appear giving you the Short FileName. Private Declare Function apiGetShortPathName _ 
     Lib "Kernel32" Alias "GetShortPathNameA" _
     (ByVal lpszLongPath As String, _
      ByVal lpszShortPath As String, _
      ByVal cchBuffer As Long) As Long

Dim lsShortName As String
Dim lsLongName

lsLongName = "c:\Program Files"
    
lsShortName = String$(1000, " ")

apiGetShortPathName lsLongName, lsShortName, 1000

MsgBox Left$(lsShortName, Len(Trim$(lsShortName)) - 1)




c0Title: Get The List Separator Based On Locale
c1Code:
Usually when you display a list of values, you might show it like this:

    100,200,300

The problem is that in some countries using a comma could mean something completely different. For instance, commas in Germany have the same meaning as decimal points do here in the US.

Some Countries List Separators: 

United States = , 
France = ; 
German = ; 
Mexico = , 
Sweden = ; 
So whenever you need to display a list of values, always use the code below to find out what the users list separator is!

Declare
'Constant for default locale on default computer
Public Const LOCALE_USER_DEFAULT = &H400
'Constant for list separator
Public Const LOCALE_SLIST = &HC

'API Call for Locale Info can be used to get many things
Public Declare Function GetLocaleInfo& Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long)
Code
Function ListSeparator() As String
Dim lReturn As Long
Dim sSeparator As String

  'Set the string buffer to maximum
  sSeparator = Space(256)

  'Get the list separator from the API call
  lReturn = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SLIST, sSeparator, Len(sSeparator))

  'If the call was successful
  If lReturn Then
    'Clear off the empty spaces and need to subtract 1 from lReturn because it adds a null character "|"
    sSeparator = Left$(sSeparator, lReturn - 1)
  End If

  ListSeparator = sSeparator

End Function




c0Title: Get The Location Of The TaskBar
c1Code:
This procecure  will print the TaskBar location to a Form:


Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

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


Code


Public Sub GetTaskBarRect()
	Dim TaskBarRect As RECT
	Dim lTaskBarHandle As Long

	lTaskBarHandle = FindWindow("Shell_TrayWnd", "")

	GetWindowRect lTaskBarHandle, TaskBarRect

	With TaskBarRect
		Cls
		Print "Strat Bar Location & Size:"
		Print "Left:", .Left

		Print "Top:", .Top

		Print "Right:", .Right

		Print "Bottom:", .Bottom
	End With
End Sub


Tip Submitted By: Michael Johnson


c0Title: GetTreeViewNodeHandle - The handle of any node in a TreeView
c1Code:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal _
    hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long

Private Const TVM_GETNEXTITEM = &H110A
Private Const TVGN_CARET = 9

' The handle of any node in a TreeView
'
' While VB developers reason in terms of Node objects, TreeView 
' nodes are stored and referenced internally using 32-bit handles, 
' and when you want to pass a reference to a Node in a API call you 
' must pass the handle to it. The problem is that there is no easy 
' way to get an arbitrary node's handle, and you can only get 
' (or set) the handle of the selected node and a few others.
'
' However, we can get this information if we cheat a little, 
' by temporarily selecting the node and then restoring the original 
' selected node. This is very fast and the user won't notice any flickering. 

Function GetTreeViewNodeHandle(ByVal TV As TreeView, Node As Node) As Long
    Dim selNode As Node
    ' remember the node currently selected
    Set selNode = TV.SelectedItem
    ' select the new node
    Set TV.SelectedItem = Node
    ' send a message to retrieve the handle of current node
    GetTreeViewNodeHandle = SendMessage(TV.hWnd, TVM_GETNEXTITEM, TVGN_CARET, _
        ByVal 0&)
    ' restore the node that was selected
    Set TV.SelectedItem = selNode
End Function



c0Title: Get User Name (simple)
c1Code:
This works on both Win9x and WinNT and XP. (Not sure about Win2000) Private Declare Function GetUserName Lib "advapi32.dll" _
            Alias "GetUserNameA" (ByVal lpBuffer As String, _
            nSize As Long) As Long

Public Function UserName() As String

    Dim llReturn As Long
    Dim lsUserName As String
    Dim lsBuffer As String
    
    lsUserName = ""
    lsBuffer = Space$(255)
    llReturn = GetUserName(lsBuffer, 255)
    
    
    If llReturn Then
       lsUserName = Left$(lsBuffer, InStr(lsBuffer, Chr(0)) - 1)
    End If
    
    UserName = lsUserName
End Function



c0Title: Get UserName
c1Code:
Option Explicit

Private Declare Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long Private Declare Function WNetGetUserW Lib "mpr.dll" (ByVal lpName As Long, ByVal lpUserName As Long, lpnLength As Long) As Long Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long Private Declare Function GetUserNameA Lib "advapi32.dll" (ByVal lpBuffer As String, nSize As Long) As Long Private Declare Function GetUserNameW Lib "advapi32.dll" (ByVal lpBuffer As Long, nSize As Long) As Long

Private Enum OSVersionEnum
    VER_PLATFORM_WIN32s = 0
    VER_PLATFORM_WIN32_WINDOWS = 1
    VER_PLATFORM_WIN32_NT = 2
End Enum

Private Type OSVERSIONINFO                      ' operating system version information [used by GetVersion]
    dwOSVersionInfoSize     As Long
    dwMajorVersion          As Long
    dwMinorVersion          As Long
    dwBuildNumber           As Long
    dwPlatformId            As Long
    szCSDVersion            As String * 128     ' Maintenance string for PSS usage
End Type

Private OSVersion           As OSVERSIONINFO    ' private structure for various Public functions

Public Function GetUserId() As String
'===========================================================================
'   GetUserId
'
'   RETURNS     On success, the user name currently logged on to the network. If not
'               logged on to the network, returns the user id logged on to the system.
'               On failure, an empty string.
'===========================================================================
    Dim UserID      As String       ' The user currently logged on
    Dim ErrorCode   As Long         ' result
    Dim Success     As Boolean      ' result
    Dim Buffer      As String       ' output buffer
    Dim BufferLen   As Long         ' size of the output buffer

    On Error GoTo ErrHandler                        ' trap all errors

    If Len(UserID) > 0 Then                         ' we already know this info
        GoTo ExitLabel                              ' we're done
    End If
    
    Buffer = String(255, 0)                         ' pad buffer with nulls
    BufferLen = Len(Buffer)                         ' remember size of output buffer

    ' Fetch id user logged on to network [if logged on]
    ErrorCode = WNetGetUser(vbNullString, Buffer, BufferLen)

    If ErrorCode = 0 Then                           ' user is logged on to the network
        
        UserID = TrimNulls(Buffer)                  ' kill null terminators
    
    Else                                            ' not logged on to the network
        
        Success = GetUserName(Buffer, BufferLen)    ' get Windows' current user value
        If Success Then
            UserID = TrimNulls(Buffer)              ' kill null terminators
        End If
        
    End If

ExitLabel:
    GetUserId = UserID                              ' return the requested info

Exit Function
Resume
ErrHandler:
    Exit Function                                   ' just exit & return null string

End Function


Public Function WNetGetUser(ByVal lpName As String, lpUserName As String, lpnLength As Long) As Long '===========================================================================
'   WNetGetUser - ANSI/WIDE wrapper. Refer to the WNet SDK.
'===========================================================================
    If Len(lpName) = 0 Then lpName = vbNullString   ' ensure blanks made NULL
    
    If IsWinNt Then                     ' running in NT, use WIDE calls
        WNetGetUser = WNetGetUserW(StrPtr(lpName), StrPtr(lpUserName), lpnLength)
    Else                                ' running on Win9X, use ANSI calls
        WNetGetUser = WNetGetUserA(lpName, lpUserName, lpnLength)
    End If
    
End Function

Public Function IsWinNt() As Boolean
'===========================================================================
'   IsWinNT - Returns true if we're running Windows NT.
'===========================================================================
Exit Function
    ' NOTE: OSVERSIONINFO is defined at the module
    ' for imporved performance.
    
    If OSVersion.dwOSVersionInfoSize = 0 Then               ' this is our first time making this call
        OSVersion.dwOSVersionInfoSize = Len(OSVersion)      ' initialize so API knows which version being used
        GetVersionEx OSVersion                              ' make the call once & then save/re-use it
    End If

    IsWinNt = OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT ' return the result
    
End Function

Public Function TrimNulls(InString As String) As String '===========================================================================
'   TrimNulls - Trims null terminators from a string.
'
'   InString        The string to strip nulls from.
'
'   RETURNS         The resulting string.
'===========================================================================
Dim Pos     As Long     ' location of null terminator

    Pos = InStr(InString, Chr$(0))              ' find null terminator
    If Pos > 0 Then                             ' terminator located
        TrimNulls = Left$(InString, Pos - 1)    ' strip terminator
    Else                                        ' no terminator found
        TrimNulls = InString                    ' return the supplied input string
    End If
    
End Function


Public Function GetUserName(lpBuffer As String, nSize As Long) As Long '===========================================================================
'   GetUserName - ANSI/WIDE wrapper. Refer to the SDK.
'===========================================================================
    If Len(lpBuffer) = 0 Then lpBuffer = vbNullString   ' ensure blanks made NULL
    
    If IsWinNt Then                     ' running in NT, use WIDE calls
        GetUserName = GetUserNameW(StrPtr(lpBuffer), nSize)
    Else                                ' running on Win9X, use ANSI calls
        GetUserName = GetUserNameA(lpBuffer, nSize)
    End If
    
End Function





c0Title: Hashing (One Way Encryption) Algorithm
c1Code:
Author: Simon Johnson
Category: String Manipulation
Type: Snippets
Difficulty: Advanced  


Version Compatibility:  Visual Basic 5   Visual Basic 6  


More information: 
=========================
Epsilon Hashing Algorithm
==========================
Performs a one-way encryption operation on string of length x. i.e. The encrypted text can not be reversed to find the original. 

There are a number of situations in which one-way encryption provides added security as compared to two-way encryption. For instance, to protect passwords, you can compare a typed password to a hash stored on a network or a database. By contrast, using two way encryption (e.g., whereby an encrypted string can be decrypted) someone who gains access to the decrypt key can steal the password. Hashing is also used in private-public key signature solutions.


'Epsilon Algorithm, Created by Simon Johnson 'Uses storing encrypted passwd's, or producing message digests.
'

Public Function Hash(byval text as string) as string
a=1
For i = 1 to len(text)
    a=sqr(a*i*asc(mid(text,i,1))) 'Numeric Hash Next i
Rnd(-1)
Randomize a 'seed PRNG

For i = 1 to 16
    Hash = Hash & Chr(int(rnd*256))
Next i
End function


c0Title: Hashtables
c1Code:
Hashtables
A Hashtable is a lookup structure which aims to make finding a particular item more efficient. The idea is to reduce the number of data items which are accessed before you get the pointer to the data you're interested in, and the way it works is related to the way indexes in databases work (although it is less sophisticated).

A simple hashtable is implemented as follows: firstly, a hashing function is defined. This is a function which converts a key of arbitrary size to a number within a fixed range. The idea is that the hash function will produce a nicely even distribution of hash values for a given key. Then, an array for each of the possible hash values. Each element in this array then stores a linked list of the actual keys and then a pointer to the data itself within the main list.

So to find a particular item by its key, you do the following:

Determine the Hash of the key using the Hash function 
Find the linked list from the array containing all of the hash tables. If there isn't anything there, then the key doesn't exist, otherwise... 
Enumerate the values in the linked list until you find one with a matching key (remember that you are reducing a key of arbitrary size to a shorter, fixed range list, so different keys may have the same Hash code). When found, you have the item.
This may sound like it all takes a long time to do, but for long lists in fact turns out many times quicker than searching through the entire list because so much less searching is involved (assuming that the Hash function is any good!).

An example of a class which implements a string hash function in VB is as follows:

' Size of HashTable
Private m_lHashTableSize As Long          

' Pseudorandom cryptographic array used to mix up
' the input data and create a hash function with
' good chance of preventing clashes:
Private rand8(0 To 255) As Long

Private Sub Class_Initialize()
Dim i As Long, j As Long
Dim s As Byte, k As Long
   
   ' Create a pseudorandom array using the
   ' alleged RC4 algorithm.
   ' See:
   ' http://burtleburtle.net/bob/hash/pearson.html
   ' This initialisation is to prevent a low repeat count:
   For i = 0 To 255
      rand8(i) = i
   Next i
   ' Here we go:
   k = 7
   For j = 0 To 3
      For i = 0 To 255
         s = rand8(i)
         k = (k + s) Mod 256
         rand8(i) = rand8(k)
         rand8(k) = s
      Next i
   Next j
   ' Hash table is 65k in size.  This should remain
   ' very efficient for > 200,000 items.
   m_lHashTableSize = &HFFFF&
   
End Sub

Private Function Hash(ByVal sKey As String) As Long
Dim b() As Byte
Dim i As Long
Dim lKeyVal As Long
Dim h1 As Long, h2 As Long
   
   ' using hashing algorithm "Variable String Exclusive-Or
   ' method (tablesize up to 65,536)".  See
   ' Dictionaries ->Hash Tables section at
   ' http://members.xoom.com/thomasn/s_man.htm
   b = sKey
   h1 = b(0): h2 = h1 + 1
   For i = 1 To UBound(b)
      h1 = rand8(h1 Xor b(i))
      h2 = rand8(h2 Xor b(i))
   Next
   lKeyVal = h1 * &HFF& + h2
   Hash = lKeyVal Mod m_lHashTableSize
   
End Function


c0Title: Have Your Functions Both Ways
c1Code:
When you create generic functions, remember that many functions are a two-way street. For example, many general utility modules contain both LoWord and HiWord functions. However, to compose a Long, a MakeDWord or some related function is required. Instead, convert your LoWord and HiWord functions into properties. That way, they can exist on both sides of the equal sign, for retrieval and for assignment:

x = LoWord(Y)

Or:

LoWord(y) = x

Use this code to implement:

Public Property Get HiWord(L As Long) As Integer
       ' used to retrieve the HiWord of a long
       HiWord = <code to do it!>
End Property


Public Property Let HiWord(L As Long, ByVal NewValue As Integer)

       ' used to set the HiWord of a long L is the long to 
       ' modify, NewValue is the integer you want to set into 
       ' the HiWord of the long L
End Property


Also, remember you don�t have to put this in a class module. Property procedures are completely valid within a regular BAS module, but if you put them in a BAS module, you must precede their names with the module name when calling them.

You could also use this technique to create a path parse routine that lets you replace arbitrary elements of the path string (such as the drive, path, or filename), a timer function, or a Split function that lets you assign elements directly into the splitting string as well as retrieve them.

�Darin Higgins, Fort Worth, Texas


c0Title: Heap Sort
c1Code:
The heap sort is very different to all the others, and before I explain the sort itself, we need to know what exactly a heap is. A heap is a balanced binary tree where every parent node is greater than its children. The result is that the value at the top of any subtree will be the largest value in the tree.

The sort itself comprises of 2 steps - Firstly, the elements of the array are reordered so that it becomes a heap. This involves checking each child against its parent and moving values up the tree as needed. Once the heap is ready, we can start to read off values from it one at a time, so an extra array is required. Once each value has been removed, we restore the heap properties by moving the last element in the array to the front and then shifting it down as required.

Example:

Code:
Array of data [2,8,4,9,3,5,7,1,0,6]

As it stands, the data, when viewed as a tree, looks like this:
                    2
                  /   \
                8       4
              /   \   /   \
             9    3   5    7
            / \  /
            1 0  6

First, we restore the heap properties by shuffling children up and parents down:

                    9
                  /   \
                8      7
              /   \   /   \
             6    3   5    4
            / \  /
            1 0  2

Now we read off the top value and remove it, placing the last value at the top:

                    2
                  /   \
                8      7
              /   \   /   \
             6    3   5    4
            / \
            1 0

Restore the heap properties:

                    8
                  /   \
                6      7
              /   \   /   \
             2    3   5    4
            / \
            1 0

Continue until the heap is empty.

Finish [0,1,2,3,4,5,6,7,8,9] (place the items in the array in reverse order)


And here is the code:


VB: 
--------------------------------------------------------------------------------
Public Sub HeapSort(ByRef lngArray() As Long)
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iArrSize As Long
    Dim iRoot As Long
    Dim iChild As Long
    Dim iElement As Long
    Dim iCurrent As Long
    Dim arrOut() As Long
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    iArrSize = iUBound - iLBound
    
    ReDim arrOut(iLBound To iUBound)
    
    'Initialise the heap
    'Move up the heap from the bottom
    For iRoot = iArrSize \ 2 To 0 Step -1
    
        iElement = lngArray(iRoot + iLBound)
        iChild = iRoot + iRoot
        
        'Move down the heap from the current position
        Do While iChild < iArrSize
            
            If iChild < iArrSize Then
                If lngArray(iChild + iLBound) < lngArray(iChild + iLBound + 1) Then
                    'Always want largest child
                    iChild = iChild + 1
                End If
            End If
            
            'Found a slot, stop looking
            If iElement >= lngArray(iChild + iLBound) Then Exit Do
            
            lngArray((iChild \ 2) + iLBound) = lngArray(iChild + iLBound)
            iChild = iChild + iChild
        Loop
        
        'Move the node
        lngArray((iChild \ 2) + iLBound) = iElement
    Next iRoot
    
    'Read of values one by one (store in array starting at the end)
    For iRoot = iUBound To iLBound Step -1
    
        'Read the value
        arrOut(iRoot) = lngArray(iLBound)
        'Get the last element
        iElement = lngArray(iArrSize + iLBound)
        
        iArrSize = iArrSize - 1
        iCurrent = 0
        iChild = 1
        
        'Find a place for the last element to go
        Do While iChild <= iArrSize
            
            If iChild < iArrSize Then
                If lngArray(iChild + iLBound) < lngArray(iChild + iLBound + 1) Then
                    'Always want the larger child
                    iChild = iChild + 1
                End If
            End If
            
            'Found a position
            If iElement >= lngArray(iChild + iLBound) Then Exit Do
            
            lngArray(iCurrent + iLBound) = lngArray(iChild + iLBound)
            iCurrent = iChild
            iChild = iChild + iChild
            
        Loop
        
        'Move the node
        lngArray(iCurrent + iLBound) = iElement
    Next iRoot
    
    'Copy from temp array to real array
    For iRoot = iLBound To iUBound
        lngArray(iRoot) = arrOut(iRoot)
    Next iRoot
End Sub

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


c0Title: Help Search on the Menu Bar
c1Code:
Ever wanted to add a "Search for Help on..." item in the menu bar? Here�s the secret:

'Declares and Constant for Help Menu
Declare Function WinHelp% Lib "User" (ByVal hWnd%, ByVal HelpFile$, ByVal helpcode%, ByVal helpdata&) Declare Function WinHelpByString% Lib "User" Alias "WinHelp" (ByVal hWnd%, ByVal HelpFile$, ByVal helpcode%, ByVal helpdata$)

Const HELP_PARTIALKEY = &H105

'call the search engine in winhelp
Sub mnuSEARCH_Click ( )
    Dim R%
    R% = WinHelpByString(Me.hWnd, App.HelpFile, HELP_PARTIALKEY, " ") End Sub �Dr. B. Leckett



c0Title: Hide and Show the Scroll Bar in a Multiline TextBox
c1Code:
Have you ever wanted to make that pesky scroll bar disappear when it is not needed, and reappear when the text exceeds the viewable area of the text box? Setting the scroll bar properties at run time won�t do it. You could use API calls, but how do you decide when the lines have exceeded the viewing area? Here�s a set of declarations and procedures that will do just that for you:

'=USER TYPES =
Type pointapi
	x As Integer
	y As Integer
End Type

Type RECT '8 Bytes
	Left As Integer
	Top As Integer
	right As Integer
	bottom As Integer
End Type

Type TEXTMETRIC '31 Bytes
	TMHeight As Integer
	tmAscent As Integer
	tmDescent As Integer
	tmInternalLeading As Integer
	tmExternalLeading As Integer
	tmAveCharWidth As Integer
	tmMaxCharWidth As Integer
	tmWeight As Integer
	tmItalic As String * 1
	tmUnderlined As String * 1
	tmStruckOut As String * 1
	tmFirstChar As String * 1
	tmLastChar As String * 1
	tmDefaultChar As String * 1
	tmBreakChar As String * 1
	tmPitchAndFamily As String * 1
	tmCharSet As String * 1
	tmOverhang As Integer
	tmDigitizedAspectX As Integer
	tmDigitizedAspectY As Integer
End Type

Global apnt As pointapi

Declare Function SendMessage& Lib "User" (ByVal HWND%, ByVal wmsg%, ByVal wparam%, lparam As Any)
Declare Function GetTextMetrics% Lib "GDI" (ByVal hDC%, lpMetrics As TEXTMETRIC)
Declare Function GetDC% Lib "User" (ByVal HWND%)
Declare Function SelectObject% Lib "GDI" (ByVal hDC%, ByVal hObject%)
Declare Function ReleaseDC% Lib "User" (ByVal HWND%, ByVal hDC%)
Declare Function WindowFromPoint% Lib "User" (ByVal x As Any)
Declare Sub SHOWSCROLLBAR Lib "User" (ByVal HWND%, ByVal wbar%, ByVal bshow%)

'==============API CONSTANTS====================
Global Const WM_USER = &H400
Global Const EM_SETREADONLY = (WM_USER + 31)
Global Const EM_GETLINECOUNT = (WM_USER + 10)
Global Const EM_GETFIRSTVISIBLELINE = (WM_USER + 30)
Global Const EM_GETRECT = (WM_USER + 2)
Global Const WM_GETFONT = &H31


This sub is called from your form to make the scroll bars
visible or invisible, depending on whether the lines of text have
exceeded the viewable area in the text box. You must pass it the
hWnd of the text box and the scroll bar type that the text box is
using:


Sub Scroll_show (thwnd%, bartype%)
'==============================================
'This Subroutine controls the visibility of the
' scrollbars in the designated Edit Control. The
' requirements for this subroutine are:
' BarType%.......Integer selecting scrollbar type
' thwnd%.........Hwnd of the edit control
' API CONSTANTS
' EM_GETLINECOUNT
' EM_GETFIRSTVISIBLELINE
' !! MUST BE A TRUETYPE FONT IN USE !!
'==============================================
	LinECount% = SendMessage(thwnd%, EM_GETLINECOUNT, 0, 0)
	FirstVisible% = SendMessage(thwnd%, EM_GETFIRSTVISIBLELINE, 0, 0)

	If LinECount% > GETVISIBLELINES(thwnd%) Then
		SHOWSCROLLBAR thwnd%, 1, True
	Else
		SHOWSCROLLBAR thwnd%, 1, False
	End If
End Sub


This function returns the number of visible lines in a text box when you pass it the hWnd property of the text box:


Function GETVISIBLELINES% (thwnd%)
'==============================================
'This function returns the number of visible
' lines in an edit control. It requires:
' RC.........User Defined Type RECT
' TM.........User Defined Type TEXTMETRIC
' THWND%.....The hwnd of the edit control
' API FUNCTIONS:
' SendMessage()
' GetDC()
' SelectObject()
' ReleaseDC()
' API CONSTANTS:
' EM_GETRECT
' WM_GETFONT
'==============================================
	Dim RC As RECT
	Dim hDC%
	Dim LFONT%, OLFFONT%
	Dim TM As TEXTMETRIC
	Dim DI%

	'GET THE RECTANGLE
	LC% = SendMessage(thwnd%, EM_GETRECT, 0, RC)

	'GET THE FONT HANDLE
	LFONT% = SendMessage(thwnd%, WM_GETFONT, 0, 0&)

	'GET DEVICE CONTEXT
	hDC% = GetDC(thwnd%)

	'SELECT LOGICAL FONT
	If LFONT% <> 0 Then OLDFONT% = SelectObject(hDC%, LFONT%)
	DI% = GetTextMetrics(hDC%, TM)

	If LFONT% <> 0 Then LFONT% = SelectObject(hDC%, LFONT%)

	'GET VISIBLE LINES
	GETVISIBLELINES% = (RC.bottom - RC.Top) / TM.TMHeight
	DI% = ReleaseDC(thwnd%, hDC%)
End Function


This sub is the one that actually makes the scroll bars visible
or invisible, depending on the value of the flag variable. It requires
the hWnd property of the control:


Sub ListScrollShow (thwnd%, flag As Integer)
'==============================================
'Makes the control�s scrollbar visible or
'invisible depending on flag value.
'Flag = True to show
'FlAG = fALSE TO HIDE
'==============================================
	SHOWSCROLLBAR thwnd%, 1, flag
End Sub

�Ibrahim Malluf


c0Title: Hiding an App from the CTRL-ALT-DEL Process List
c1Code:
Call the HideApp subroutine and pass it true to hide your application or false to stop hiding your application.
Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0

Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long 
Public Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long 
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long

Public Sub HideApp(lbValue As Boolean)
    Dim lngProcessID As Long
    Dim lngReturn As Long
    
    lngProcessID = GetCurrentProcessId()
    
    If lbValue Then
        lngReturn = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
    Else
        lngReturn = RegisterServiceProcess(pid, RSP_UNREGISTER_SERVICE)
    End If
End Sub


c0Title: Hiding Your Program in the Ctrl-Alt-Del list
c1Code:
To do this, your must register your program as a service. This is done by passing the process ID of your application to the RegisterService API.

Declarations

Copy the following code into the declarations section of a module:

Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long

Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0


Procedures


To remove your program from the Ctrl+Alt+Delete list, call the MakeMeService procedure:


Public Sub MakeMeService()
	Dim pid As Long
	Dim reserv As Long

	pid = GetCurrentProcessId()
	regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
End Sub


To restore your application to the Ctrl+Alt+Delete list, call the UnMakeMeService procedure:


Public UnMakeMeService()
	Dim pid As Long
	Dim reserv As Long

	pid = GetCurrentProcessId()
	regserv = RegisterServiceProcess(pid, RSP_UNREGISTER_SERVICE)
'End Code

Don't forget to unregister your application as a service before it closes to free up system resources by calling UnMakeMeService.

Tip by John Percival


c0Title: High Performance StringBuilder Class (original)
c1Code:
'----------------------------------------------------------- 
' CSTRING Class 
' by Francesco Balena 
' 
' This class implements the string data type as an 
' object type, and also supports most string functions 
' It offers a few advantages on native VB strings: 
' 
' 1) chars are stored in ANSI format, use less memory 
' 2) you decide how much memory is allocated to each 
'    string, hence memory is not re-allocated with each 
'    new assignment 
' 3) since data is stored as ANSI, no internal conversion 
'    is necessary when printing to file or passing to APIs 
'    (in this case, pass the StrPtr Value as a pointer to chars) 
'----------------------------------------------------------- 
 
Option Explicit 
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal Bytes As Long) 
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long) 
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (dest As Any, ByVal numBytes As Long, ByVal fillByte As Integer) 
 
' number of chars initially allocated to the string 
Const DEFAULT_MAXLENGTH = 256 
 
' this array holds the character 
Private chars() As Byte 
' the current lenght of the string 
Private m_Len As Long 
' the current UBound() of the array (accounts for ending null char) 
Private m_MaxLength As Long 
 
 
Private Sub Class_Initialize() 
    ' create the chars() array 
    SetBufferSize DEFAULT_MAXLENGTH 
End Sub 
 
' set the size of the internal buffer 
' Use "mystr.SetBufferSize mystr.Length" to release unused memory 
 
Sub SetBufferSize(ByVal newSize As Long, Optional clearIt As Boolean) 
    m_MaxLength = newSize 
    If m_Len Or clearIt = 0 Then 
        ReDim Preserve chars(0 To m_MaxLength) As Byte 
    Else 
        ReDim chars(0 To m_MaxLength) As Byte 
    End If 
End Sub 
 
' the current Value as a Unicode string 
' this is the default item of the class, so you can use 
' the object variable as if it were a string variable 
 
Property Get Value() As String 
    If m_Len > 0 Then 
        Value = Space$(m_Len) 
        CopyMemory ByVal Value, chars(0), m_Len 
    End If 
End Property 
 
Property Let Value(NewValue As String) 
    ' check that the private array is large enough 
    m_Len = Len(NewValue) 
    If m_Len > m_MaxLength Then 
        SetBufferSize m_Len, True 
    End If 
    ' copy the characters into the private array 
    If m_Len > 0 Then 
        CopyMemory chars(0), ByVal NewValue, m_Len 
    End If 
End Property 
 
' the address of the first character (read-only) 
 
Function StrPtr() As Long 
    StrPtr = VarPtr(chars(0)) 
    ' append a null character to the internal string 
    ' in case this will be passed to an external DLL 
    chars(m_Len) = 0 
End Function 
 
' copy data from a memory address (Friend sub) 
 
Friend Sub CopyData(ByVal SourceAddr As Long, ByVal NumChars As Long) 
    ' raise error if new Length is invalid 
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' check that the private array is large enough 
    m_Len = NumChars 
    If m_Len > m_MaxLength Then 
        SetBufferSize m_Len, True 
    End If 
    ' copy the characters into the private array 
    If m_Len > 0 Then 
        CopyMemory chars(0), ByVal SourceAddr, m_Len 
    End If 
End Sub 
 
' the current Length (can also be written to) 
' ("Len" can't be used because it is a reserved word) 
 
Property Get Length() As Long 
    Length = m_Len 
End Property 
 
Property Let Length(ByVal NewValue As Long) 
    ' raise error if new Length is invalid 
    If NewValue < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' check that the private array is large enough 
    If NewValue > m_MaxLength Then 
        SetBufferSize NewValue, False 
    End If 
    ' fill with blanks if necessary 
    If NewValue > m_Len Then 
        FillMemory chars(m_Len), NewValue - m_Len, 32 
    End If 
    ' truncate or expand the string 
    m_Len = NewValue 
End Property 
 
' clear the string 
 
Sub Clear() 
    m_Len = 0 
End Sub 
 
' create a copy of this CString object 
 
Function Copy() As cString 
    Set Copy = New cString 
    Copy.CopyData StrPtr(), m_Len 
End Function 
 
' create a new CString object with leftmost characters 
 
Property Get Left(ByVal NumChars As Long) As cString 
    ' raise error if new Length is invalid 
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' adjust length if necessary 
    If NumChars > m_Len Then NumChars = m_Len 
    ' create a new CString object 
    Set Left = New cString 
    Left.CopyData StrPtr(), NumChars 
End Property 
 
' replace leftmost characters using a given string 
 
Property Let Left(ByVal NumChars As Long, NewValue As Variant) 
    ' raise error if new parameter is invalid 
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' can't copy more character than existing 
    If NumChars > m_Len Then NumChars = m_Len 
    ' can't copy more characters then the string's length 
    If NumChars > Len(NewValue) Then NumChars = Len(NewValue) 
    ' copy chars from the string into the local array 
    If NumChars > 0 Then 
        CopyMemory chars(0), ByVal CStr(NewValue), NumChars 
    End If 
End Property 
 
' replace leftmost characters using a CString object 
 
Property Set Left(ByVal NumChars As Long, NewValue As cString) 
    ' raise error if new parameter is invalid 
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' can't copy more character than existing 
    If NumChars > m_Len Then NumChars = m_Len 
    ' can't copy more characters then the string's length 
    If NumChars > NewValue.Length Then NumChars = NewValue.Length 
    ' copy chars from the string into the local array 
    If NumChars > 0 Then 
        CopyMemory chars(0), ByVal NewValue.StrPtr, NumChars 
    End If 
End Property 
 
' create a new CString object with rightmost characters 
 
Property Get Right(ByVal NumChars As Long) As cString 
    ' raise error if new Length is invalid 
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' adjust length if necessary 
    If NumChars > m_Len Then NumChars = m_Len 
    ' create a new CString object 
    Set Right = New cString 
    Right.CopyData VarPtr(chars(m_Len - NumChars)), NumChars 
End Property 
 
' replace rightmost characters using a given string 
 
Property Let Right(ByVal NumChars As Long, NewValue As Variant) 
    ' raise error if new parameter is invalid 
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' can't copy more character than existing 
    If NumChars > m_Len Then NumChars = m_Len 
    ' can't copy more characters then the string's length 
    If NumChars > Len(NewValue) Then NumChars = Len(NewValue) 
    ' copy chars from the string into the local array 
    If NumChars > 0 Then 
        CopyMemory chars(m_Len - NumChars), ByVal CStr(NewValue), NumChars 
    End If 
End Property 
 
' replace leftmost characters using a CString object 
 
Property Set Right(ByVal NumChars As Long, NewValue As cString) 
    ' raise error if new parameter is invalid 
    If NumChars < 0 Then Err.Raise 5, TypeName(Me), "Invalid length" 
    ' can't copy more character than existing 
    If NumChars > m_Len Then NumChars = m_Len 
    ' can't copy more characters then the string's length 
    If NumChars > NewValue.Length Then NumChars = NewValue.Length 
    ' copy chars from the string into the local array 
    If NumChars > 0 Then 
        CopyMemory chars(m_Len - NumChars), ByVal NewValue.StrPtr, NumChars 
    End If 
End Property 
 
' the Mid function 
' one- and two-params syntaxes are supported 
 
Property Get Mid(ByVal StartPos As Long, Optional NumChars As Variant) As cString 
    Dim Bytes As Long 
    ' raise error if the first parameter is invalid 
    If StartPos < 0 Then Err.Raise 5, TypeName(Me), "Invalid starting position" 
     
    If IsMissing(NumChars) Then 
        ' if missing, use the remainder of the string 
        Bytes = m_Len - StartPos + 1 
    Else 
        Bytes = NumChars 
        If Bytes < 0 Then 
            ' raise error if new parameter is invalid 
            Err.Raise 5, TypeName(Me), "Invalid length" 
        ElseIf StartPos + Bytes > m_Len Then 
            ' truncate it if too long 
            Bytes = m_Len - StartPos + 1 
        End If 
    End If 
     
    ' create a new CString object 
    Set Mid = New cString 
    If StartPos <= m_Len Then 
        Mid.CopyData VarPtr(chars(StartPos - 1)), Bytes 
    End If 
End Property 
 
' replace a portion of the string with another string 
' if the second parameter is omitted, the string is replaced up to its end 
 
Property Let Mid(ByVal StartPos As Long, Optional NumChars As Variant, NewValue As Variant) 
    Dim Bytes As Long 
    ' raise error if the first parameter is invalid 
    If StartPos < 0 Then Err.Raise 5, TypeName(Me), "Invalid starting position" 
     
    If IsMissing(NumChars) Then 
        ' if missing, use the remainder of the string 
        Bytes = m_Len - StartPos + 1 
    Else 
        Bytes = NumChars 
        If Bytes < 0 Then 
            ' raise error if new parameter is invalid 
            Err.Raise 5, TypeName(Me), "Invalid length" 
        ElseIf StartPos + Bytes > m_Len Then 
            ' truncate it if too long 
            Bytes = m_Len - StartPos + 1 
        End If 
    End If 
     
    If Bytes > Len(NewValue) Then Bytes = Len(NewValue) 
    If Bytes > 0 Then 
        CopyMemory chars(StartPos - 1), ByVal CStr(NewValue), Bytes 
    End If 
End Property 
 
' replace a portion of the string with another CString object 
' if the second parameter is omitted, the string is replaced up to its end 
 
Property Set Mid(ByVal StartPos As Long, Optional NumChars As Variant, NewValue As cString) 
    Dim Bytes As Long 
    ' raise error if the first parameter is invalid 
    If StartPos < 0 Then Err.Raise 5, TypeName(Me), "Invalid starting position" 
     
    If IsMissing(NumChars) Then 
        ' if missing, use the remainder of the string 
        Bytes = m_Len - StartPos + 1 
    Else 
        Bytes = NumChars 
        If Bytes < 0 Then 
            ' raise error if new parameter is invalid 
            Err.Raise 5, TypeName(Me), "Invalid length" 
        ElseIf StartPos + Bytes > m_Len Then 
            ' truncate it if too long 
            Bytes = m_Len - StartPos + 1 
        End If 
    End If 
     
    If Bytes > NewValue.Length Then Bytes = NewValue.Length 
    If Bytes > 0 Then 
        CopyMemory chars(StartPos - 1), ByVal NewValue.StrPtr, Bytes 
    End If 
     
End Property 
 
' the ASC function, but returns -1 if the string is null 
 
Function Asc() As Integer 
    If m_Len > 0 Then 
        Asc = chars(0) 
    Else 
        Asc = -1 
    End If 
End Function 
 
' the ANSI code of a character, or -1 if out-of-range 
 
Property Get Char(ByVal Index As Long) As Byte 
    If Index > 0 Or Index <= m_Len Then 
        Char = chars(Index - 1) 
    Else 
        Char = -1 
    End If 
End Property 
 
Property Let Char(ByVal Index As Long, ByVal NewValue As Byte) 
    ' no effect if index is out of valid range 
    If Index > 0 Or Index <= m_Len Then 
        chars(Index - 1) = NewValue 
    End If 
End Property 
 
' find a substring 
' only case-sensitive searches are supported 
 
Function Instr(search As Variant, Optional StartPos As Long = 1) As Long 
    Dim searchChars() As Byte 
    Dim searchLen As Long 
    Dim firstChar As Byte 
    Dim i As Long, j As Long 
     
    If TypeOf search Is cString Then 
        ' if a CString object is passed, then make a local copy of it 
        searchLen = search.Length 
        ' if a null string, exit immediately 
        If searchLen = 0 Then Instr = StartPos: Exit Function 
        ReDim searchChars(0 To searchLen - 1) As Byte 
        CopyMemory searchChars(0), ByVal search.StrPtr, searchLen 
    Else 
        ' if a string is passed, create the corresponding local array 
        searchLen = Len(search) 
        ' if a null string, exit immediately 
        If searchLen = 0 Then Instr = StartPos: Exit Function 
        searchChars() = StrConv(CStr(search), vbFromUnicode) 
    End If 
     
    ' cache the first character to be searched 
    firstChar = searchChars(0) 
     
    For i = StartPos - 1 To m_Len - searchLen 
        If chars(i) = firstChar Then 
            For j = 1 To searchLen - 1 
                If chars(i + j) <> searchChars(j) Then Exit For 
            Next 
            If j = searchLen Then 
                Instr = i + 1 
                Exit For 
            End If 
        End If 
    Next 
 
End Function 
 
' trasform the string to uppercase (returns Me) 
 
Function UCase() As cString 
    ' only characters in the range "a-z" are converted 
    Dim i As Long, acode As Integer 
    For i = 0 To m_Len - 1 
        acode = chars(i) 
        If acode >= 97 And acode <= 122 Then chars(i) = acode - 32 
    Next 
    Set UCase = Me 
End Function 
 
' trasform the string to lowercase (returns Me) 
 
Function LCase() As cString 
    ' only characters in the range "A-Z" are converted 
    Dim i As Long, acode As Integer 
    For i = 0 To m_Len - 1 
        acode = chars(i) 
        If acode >= 65 And acode <= 90 Then chars(i) = acode + 32 
    Next 
    Set LCase = Me 
End Function 
 
' reverse the string (returns Me) 
 
Function ReverseStr() As cString 
    Dim i As Long, acode As Byte 
    For i = 0 To m_Len \ 2 - 1 
        acode = chars(i) 
        chars(i) = chars(m_Len - 1 - i) 
        chars(m_Len - 1 - i) = acode 
    Next 
    Set ReverseStr = Me 
End Function 
 
' append one or more strings or CString objects (returns Me) 
 
' append a string or a CString object (returns Me) 
 
Function Append(arg As Variant) As cString 
    Dim i As Long, j As Long 
    Dim argObj As cString 
    Dim newLength As Long 
    Dim argLen As Long 
     
    ' prepare the result 
    Set Append = Me 
     
    If TypeOf arg Is cString Then 
        Set argObj = arg 
        argLen = argObj.Length 
    Else 
        argLen = Len(arg) 
    End If 
     
    ' exit if null string 
    If argLen = 0 Then Exit Function 
     
    ' prepare the receiving buffer 
    newLength = m_Len + argLen 
    If newLength > m_MaxLength Then 
        SetBufferSize newLength, False 
    End If 
     
    ' append the string 
    If argObj Is Nothing Then 
        ' this is a regular string argument 
        CopyMemory chars(m_Len), ByVal CStr(arg), argLen 
    Else 
        ' this is a CString argument 
        CopyMemory chars(m_Len), ByVal argObj.StrPtr, argLen 
    End If 
 
    ' update m_Len to point after the appended characters 
    m_Len = newLength 
 
End Function 
 
' search a substring using Boyer & Moore algorithm 
 
Function Find(search As String, Optional StartPos As Long = 1) As Long 
    Dim Bytes() As Byte 
    Dim i As Long, searchLen As Long, dist As Long, Index As Long 
     
    ' save results from previous call 
    Static saveSearch As String 
    Static distance() As Integer 
     
    ' it is better to have the substring in a byte array 
    Bytes() = StrConv(search, vbFromUnicode) 
    searchLen = Len(search) 
    Index = StartPos + searchLen - 1 
     
    ' build the distance table 
    ' this is a 256-item array that, for each possible 
    ' ANSI character, stores the "distance" of this char 
    ' from the end of the search substring (if the char 
    ' appears in the substring), or the length of the 
    ' substring (if the character doesn't appear in the 
    ' substring). Note that the last character in the 
    ' substring corresponds to a null Value in the table 
 
    ' this block is executed only if the search substring 
    ' differs from the last call to this method 
    If search <> saveSearch Then 
        ReDim distance(0 To 255) As Integer 
        For i = 0 To 255 
            distance(i) = searchLen 
        Next 
        For i = 1 To searchLen 
            distance(Bytes(i - 1)) = searchLen - i 
        Next 
        ' remember for next time 
        saveSearch = search 
    End If 
     
    ' scan the string 
    Do While Index <= m_Len 
        ' retrieve the distance of this character from the 
        ' end of the search substring 
        dist = distance(chars(Index - 1)) 
        If dist Then 
            ' increment Index of found distance - in fact there 
            ' is no reason to scan all the characters in the middle 
            Index = Index + dist 
        Else 
            ' this might be the last character in the string 
            ' check if the substring is all there 
            For i = 1 To searchLen - 1 
                If chars(Index - searchLen - 1 + i) <> Bytes(i - 1) Then Exit For 
            Next 
             
            If i = searchLen Then 
                ' we've found a match 
                Find = Index - searchLen + 1 
                Exit Function 
            End If 
            ' the search failed, skip this character and continue 
            Index = Index + 1 
        End If 
    Loop 
 
End Function 
 
' write the string to a binary file 
' optionally prefix it with string length 
' Open destination For Binary Access Write As #x 
Sub WriteToFile(ByVal FileNum As Integer, Optional PrefixLength As Boolean) 
    If PrefixLength Then 
        Put #FileNum, , m_Len 
    End If 
    ' temporarily shorten the internal buffer 
    ' (we need this to use VB's Put statement) 
    ReDim Preserve chars(0 To m_Len) As Byte 
    ' write all chars to file 
    Put #FileNum, , chars() 
    ' restore the buffer 
    ReDim Preserve chars(0 To m_MaxLength) As Byte 
End Sub 
 
' read the string from a binary file 
' if PrefixLength is True, uses stored length prefix, else 
' uses current string length 
 
Sub ReadFromFile(ByVal FileNum As Integer, Optional PrefixLength As Boolean) 
    If PrefixLength Then 
        ' read the string length 
        Get #FileNum, , m_Len 
        ' enlarge the buffer if necessary 
        If m_Len > m_MaxLength Then 
            SetBufferSize m_Len, True 
        End If 
    End If 
    ' temporarily shorten the internal buffer 
    ' (we need this to use VB's Put statement) 
    ReDim Preserve chars(0 To m_Len) As Byte 
    ' get chars from file 
    Get #FileNum, , chars() 
    ' restore the buffer 
    ReDim Preserve chars(0 To m_MaxLength) As Byte 
End Sub 
 
' truncate the string to its first null char, returns new length 
 
' this function is useful when dealing with API calls that return 
' null-terminate strings in the buffer 
 
Function TrimToNull() As Long 
    Dim i As Long 
    ' assume there is no null char 
    m_Len = m_MaxLength 
    ' scan the string searching for the first null character 
    For i = 1 To m_MaxLength 
        If chars(i) = 0 Then 
            ' set new length and exit 
            m_Len = i - 1 
            Exit For 
        End If 
    Next 
    ' new length is also the return Value 
    TrimToNull = m_Len 
End Function 


c0Title: How can I create a textbox that let's you insert tabs?
c1Code:
Q:  How can I create a textbox that let's you insert tabs? 
A:  Set tabstop on all the controls in a form to false.


c0Title: How can I log errors to the NT event log?
c1Code:
Visual Basic Version: VB 5.0, VB 6.0

Issue: When the application generates an unexpected error, I would like to log it to the NT event log. How do I do it?

VB 5.0 has a new method on the App object that allows you to log information to the NT event log. For example:

App.LogEvent sPrintMsg, lLogType
This will add the string defined in sPrintMsg to the NT event log. lLogType is the type of log entry.


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

I tested the NT event logging and it doesn't work!
Visual Basic Version: VB 5.0, VB 6.0

Issue: I added the code to log to the NT event log. Why doesn't it work?

To prevent you from filling up your NT event log during design time, the VB team decided it would be good to disable the logging at design time. In order to test your NT event log code, you need to compile your application first and then run your test.



c0Title: How can I make a form "Always on top"?
c1Code:
Put this code in a module: 

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 SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

public sub SetFormOnTop(YourForm as object)
        SetWindowPos YourForm.hWnd,  HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE 
end sub


c0Title:
How can I open a form or report in code and make the code wait until that form or report has been closed..

c1Code:
The simple answer for forms is to open the form as a modal dialog box, like this:

DoCmd OpenForm "frmFormName", , , , , A_DIALOG

Note the commas, the A_DIALOG parameter is the fifth parameter.

Of course, this will not work for reports in preview mode, and may not be the desired result for a particular form, some polling will be called for, e.g.

DoCmd OpenForm "frmFormName"
Do While IsFormLoaded("frmFormName")
  DoEvents
Loop

DoCmd OpenReport "rptReportName"
Do While IsReportLoaded("rptReportName")
  DoEvents
Loop

Then in a global module, the following functions will test if a particular form or report is loaded:


Function IsFormLoaded(pstrFormName As String) As Integer
  IsFormLoaded = SysCmd(SYSCMD_GETOBJECTSTATE, A_FORM, pstrFormName) End Function

Function IsReportLoaded(pstrReportName As String) As Integer
  IsReportLoaded = SysCmd(SYSCMD_GETOBJECTSTATE, A_REPORT, pstrReportName) End Function


c0Title: How can I pad a string with some character?
c1Code:
Public Function PadString(sText As String, nTotalCharacters As Long, Optional sPadChar As String = " ") As String

    Dim nTextCharacters As Integer
    
    nTextCharacters = Len(RTrim(sText))

    If nTotalCharacters < nTextCharacters Then
        PadString = sText
        Exit Function
    End If
    
    PadString = String(nTotalCharacters, sPadChar)
    Mid$(PadString, 1, nTextCharacters) = sText

End Function


c0Title: How Can I Parse String For the Dynamic SQL Statement
c1Code:
This function cleans the string for sql stament. eg. replace "'" with "''" etc.

Public Function ValidateCharactersInStringForSQL(ByVal sString As String) As String

    Dim icount As Integer
    Dim sCharacter As String * 1
    Const INVALIDCHARACTERSTRING = "|�"

    'replace single quote with double single quote
    If InStr(sString, "'") Then
        sString = ReplaceStringinString(sString, "'", "''")
    End If

    'remove any other characters that are in INVALIDCHARACTERSTRING
    For icount = 1 To Len(INVALIDCHARACTERSTRING)
        sCharacter = Mid$(INVALIDCHARACTERSTRING, icount, 1)
        If InStr(sString, sCharacter) Then
            sString = ReplaceStringinString(sString, sCharacter, "")
        End If
    Next icount
    ValidateCharactersInStringForSQL = sString

End Function


Public Function ReplaceStringinString(ByVal sString As String, ByVal sReplaceThis As String, ByVal sReplaceWithThis As String) As String

	Dim sNew As String
	Dim sRest As String

	sRest = sString
	sNew = ""

	Do While InStr(sRest, sReplaceThis) <> 0
	    sNew = sNew & Left$(sRest, InStr(sRest, sReplaceThis) - 1) & sReplaceWithThis
	    sRest = Right$(sRest, Len(sRest) - InStr(sRest, sReplaceThis) - Len(sReplaceThis) + 1) 
	Loop 

	ReplaceStringinString = Trim$(sNew & sRest) 
End Function 


c0Title: Why do I get a "No Current Record" error when I use a Data Control on an empty table?
c1Code:
That automatic record update occurs when you click the data control arrow or you enter text in the text box and then execute an AddNew or Edit method. The program does not know the table is empty until the automatic record update occurs.

To work around this behavior, execute the AddNew method on an empty database table before allowing the user to click the data control or enter text into the bound text box control.

Check MSDN Article ID: Q106494


c0Title: How do I call Windows Help files from a VB program?
c1Code:
 Private Sub TextBox1_Click()
  CommonDialog1.HelpFile = "VB5.HLP"
  CommonDialog1.HelpCommand = cdlHelpContents
  CommonDialog1.ShowHelp
End Sub


c0Title: How do I center a form?
c1Code:
If you are using VB4, the form does not have a StartUpPosition property. However, there is an easy way to center the form at startup. Simply copy the code below into a module in your project. You can then center every form by calling CenterForm(me) in the load event of all forms.

Public Sub CenterForm(frm As Form)
    frm.Top = (Screen.Height - frm.Height) / 2
    frm.Left = (Screen.Width - frm.Width) / 2 
End Sub 

Tip by James Limm



c0Title: How do I check to see if an object is set to nothing?
c1Code:
How many will remember to use Is Nothing? I can't tell you how many times I forget this. So, I created a function to remember for me. I am pretty lazy, so I do things to make me more effective. I remember IsNull(), IsMissing()...So, I create functions for IsZeroLength(), IsNullString(), and...IsNothing(). Then I can avoid all the stupid logic constructs need to test variables.

The top version is my preference. It is easy to read, easy to debug, and easy for the compiler to optimize. I don't worry about the extra time for the function call. What slows Visual Basic down is string handling. Plain and simple.

Public Function IsNothing(ByRef objReference As Object) As Boolean
    If objReference Is Nothing Then
        IsNothing = True
    Else
        IsNothing = False
    End If
End Function

Public Function IsNothing(objReference as Object) as Boolean
    IsNothing = Not (objReference Is Nothing)
End Function

Or, if you prefer:

If obj Is Nothing Then
    Set obj = objSomething
End If

If Not (obj Is Nothing) Then
    Set obj = Nothing
End If

Keywords: empty, uninitialized, exist


c0Title: How do I detect if my program is already running?
c1Code:
The App object in Visual Basic has a PrevInstance property that can be checked to see if the program already has an instance running. The code is as follows:

If App.PrevInstance = True Then
    MsgBox("The program is already running!")
    End
End If
You should include this code in the load event of the startup form, or the Main procedure in a module.

Tip by James Limm


c0Title: How do I do an Error class?
c1Code:
Visual Basic Version: VB 5.0, VB 6.0

Issue: What type of thing would I put into an error class?

One standard method we put into our error class is the ErrorLog method. This encapsulates the code to build a string and log it into the NT event log. For example:

Public Sub ErrorLog(sMessage As String, lLogType As Long) Dim sPrintMsg As String
	sPrintMsg = Now & Space(5) & sMessage 
	If lLogType = vbLogEventTypeError Then
		sPrintMsg = sMessage & vbCrLf & _
			" Error: [" & Err.Number & "]: " & _
			Err.Description & " Error in: " & Err.Source
	End If
	' Write it in the event log
	App.LogEvent sPrintMsg, lLogType 
	' Output the string to the debug window as well
	Debug.Print sPrintMsg
End Sub


Notice how this code logs to the NT event log. Since the logging does not work at design-time, it prints to the Immediate window at design-time.




c0Title: How do I find out how much disk space is occupied?
c1Code:
Use the function GetDiskFreeSpace. The declaration for this API function is:

Declare Function GetDiskFreeSpace Lib "kernel32" Alias _
"GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters _
As Long) As Long
Here is an example of how to find out how much free space a drive has:

Dim SectorsPerCluster&
Dim BytesPerSector&
Dim NumberOfFreeClusters&
Dim TotalNumberOfClusters&
Dim FreeBytes&
dummy& = GetDiskFreeSpace("c:\", SectorsPerCluster, _
BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)
FreeBytes = NumberOfFreeClusters * SectorsPerCluster * _
BytesPerSector
The Long FreeBytes contains the number of free bytes on the drive.

Tip by James Limm


c0Title: How do I get the number of free bytes on a disk?
c1Code:
See Article Q113590 (or Q106553) in Microsoft's VB KnowledgeBase. A short extract follows: 

Declare Function DiskSpaceFree Lib "SETUPKIT.DLL" () As Long Dim free_space& 'Holds number of bytes returned from DiskSpaceFree().

ChDrive "c:" 'Change to the drive you want to test. 

free_space& = DiskSpaceFree() 


c0Title: How do I implement Undo?
c1Code:
user can use ctrl-Z or Alt-Back space to do the undo in their text box. Programmatically you can  SendMessage EN_UNDO to the handle of the window.

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_USER = &h400 
Global Const EM_UNDO = WM_USER + 23 

'And in your Undo Sub do the following: 
UndoResult = SendMessage(myControl.hWnd, EM_UNDO, 0, 0) 

'UndoResult = -1 indicates an error. 


c0Title: How do I make the mouse cursor invisible/visible?
c1Code:
Me.MousePointer = vbHourglass or Me.MousePointer = vbNormal

Check MousePointer for more information. 


c0Title: How do I set the Windows wallpaper at runtime?
c1Code:
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2
Const SPIF_UPDATEINIFILE = &H1

Declare Function SystemParametersInfo Lib "User" (ByVal uAction As Integer, ByVal uParam As Integer, lpvParam As Any, ByVal fuWinIni As Integer) As Integer 

Call the function as follows... 

Result% = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ByVal BMPFile$, SPIFlags%) 


c0Title: How To Use a 32-Bit Application to Determine When a Shelled Process Ends
c1Code:
View products that this article applies to.
Article ID : 129796 
Last Review : July 13, 2004 
Revision : 2.1 

This article was previously published under Q129796
On This Page
SUMMARY 
MORE INFORMATION 
Creating the Shelled Process 
Waiting for the Shelled Process to Terminate 
Getting the Exit Code from the Shelled Application 
Step-by-Step Example 
REFERENCES 
SUMMARY
Executing the Shell() function in a Visual Basic for Windows program starts another executable program asynchronously and returns control to the Visual Basic application. This shelled program continues to run independently of your application until the user closes it. 

However, if your Visual Basic application needs to wait for the shelled process to terminate, you could use the Windows API to poll the status of the application, but this is not a very efficient technique. The example in this article demonstrates a better way. 

A 16-bit application would use a completely different technique to accomplish the same effect. 
For additional information, click the article number on the 16-bitprocess below to view the article on the 16-bitprocess in the Microsoft Knowledge Base: 
96844 (http://support.microsoft.com/kb/96844/EN-US/) How To Determine When a Shelled Process Has Terminated 
Back to the top

MORE INFORMATION
The Win32 API has integrated functionality that enables an application to wait until a shelled process has completed. To use these functions, you need a handle to the shelled process. The easiest way to achieve this is to use the CreateProcess() API function to launch your shelled program rather than Visual Basic's Shell() function. 
Back to the top

Creating the Shelled Process
In a 32-bit application, you need to create an addressable process. To do this, use the CreateProcess() function to start your shelled application. The CreateProcess() function gives your program the process handle of the shelled process through one of its passed parameters. 
Back to the top

Waiting for the Shelled Process to Terminate
Having used CreateProcess() to get a process handle, pass that handle to the WaitForSingleObject() function. This causes your Visual Basic application to suspend execution until the shelled process terminates. 
Back to the top

Getting the Exit Code from the Shelled Application
It was common for a DOS application to return an exit code indicating the status of the completed application. While Windows provides other ways to convey the same information, some applications only provide exit codes. Passing the process handle to the GetExitCodeProcess() API allows you to retrieve this information. 

Following are the steps necessary to build a Visual Basic for Windows program that uses the CreateProcess() function to execute the Windows Notepad (Notepad.exe) application. This code demonstrates how to use the Windows API CreateProcess() and WaitForSingleObject() functions to wait until a shelled process terminates before resuming execution. It also uses the GetExitCodeProcess() function to retrieve the exit code of the shelled process, if any. The syntax of the CreateProcess() function is extremely complicated, so in the example code, it is encapsulated into a function called ExecCmd(). ExecCmd() takes one parameter, the command line of the application to execute. 
Back to the top

Step-by-Step Example
1. Start a new project in Visual Basic. Form1 is created by default. 
2. Add the following code to the General Declarations section of Form1:
   Private Type STARTUPINFO
      cb As Long
      lpReserved As String
      lpDesktop As String
      lpTitle As String
      dwX As Long
      dwY As Long
      dwXSize As Long
      dwYSize As Long
      dwXCountChars As Long
      dwYCountChars As Long
      dwFillAttribute As Long
      dwFlags As Long
      wShowWindow As Integer
      cbReserved2 As Integer
      lpReserved2 As Long
      hStdInput As Long
      hStdOutput As Long
      hStdError As Long
   End Type

   Private Type PROCESS_INFORMATION
      hProcess As Long
      hThread As Long
      dwProcessID As Long
      dwThreadID As Long
   End Type

   Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
      hHandle As Long, ByVal dwMilliseconds As Long) As Long

   Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
      lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
      lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
      ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
      ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
      lpStartupInfo As STARTUPINFO, lpProcessInformation As _
      PROCESS_INFORMATION) As Long

   Private Declare Function CloseHandle Lib "kernel32" _
      (ByVal hObject As Long) As Long

   Private Declare Function GetExitCodeProcess Lib "kernel32" _
      (ByVal hProcess As Long, lpExitCode As Long) As Long

   Private Const NORMAL_PRIORITY_CLASS = &H20&
   Private Const INFINITE = -1&

   Public Function ExecCmd(cmdline$)
      Dim proc As PROCESS_INFORMATION
      Dim start As STARTUPINFO

      ' Initialize the STARTUPINFO structure:
      start.cb = Len(start)

      ' Start the shelled application:
      ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
         NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)

      ' Wait for the shelled application to finish:
         ret& = WaitForSingleObject(proc.hProcess, INFINITE)
         Call GetExitCodeProcess(proc.hProcess, ret&)
         Call CloseHandle(proc.hThread)
         Call CloseHandle(proc.hProcess)
         ExecCmd = ret&
   End Function

   Sub Form_Click()
      Dim retval As Long
      retval = ExecCmd("notepad.exe")
      MsgBox "Process Finished, Exit Code " & retval
   End Sub
					
 
3. Press the F5 key to run the application. 
4. Using the mouse, click the Form1 window. At this point the NotePad application is started. 
5. Quit NotePad. A MsgBox appears indicating termination of the NotePad application and an exit code of 0.

NOTE: The MsgBox statement following the ExecCmd() function is not executed because the WaitForSingleObject() function prevents it. The message box does not appear until Notepad is closed when the user chooses Exit from Notepad's File menu (ALT, F, X). 

Back to the top

REFERENCES
For additional information, click the article number below to view the article in the Microsoft Knowledge Base: 
288216 (http://support.microsoft.com/kb/288216/EN-US/) PRB: Call to ExitProcess() from Visual Basic Application Hinders Process Exit 
For more information, please see the "CreateProcess" topic in the MSDN Library CD-ROM. 


c0Title: How do I use Unsigned Ints?
c1Code:
you can avoid the VB type conversion arithmetic by using RtlMoveMemory API to copy the bits. Makes VB's lack of unsigned type support a little easier to live with <g>.
 
Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" _ (lpDest As Any, lpSource As Any, ByVal dwBytes As Long)
 
Private Function MakeVol(ByVal Lvol As Long, ByVal Rvol As Long) As Long
    'Uses lo word of Longs to simulate 16-bit unsigned types.
    MakeVol = Lvol 'lo word
    MemCopy ByVal (VarPtr(MakeVol) + 2), Rvol, 2 'hi word End Function
 
Private Function LoWordLong(ByVal L As Long) As Long
    Call MemCopy(LoWordLong, L, 2)
End Function
 
Private Function HiWordLong(ByVal L As Long) As Long
    Call MemCopy(HiWordLong, ByVal (VarPtr(L) + 2), 2) End Function


c0Title: How do I work with the Clipboard?
c1Code:
Visual Basic Version: VB 4.0, VB 5.0, VB 6.0

This code will also work with VB 3.0 if you take out references to the Err object.

Issue: To develop a production-quality application, the application should provide an Edit menu with Cut, Copy, and Paste options. These options should Cut text from a form and place it on the Clipboard, Copy text from a form and place it on the Clipboard, or Paste text from the Clipboard to the form.

Limitation: If you plan to support an Undo using the API undo facility, you need to user the API calls to work with the clipboard instead of using the Visual Basic Clipboard object.

Code:

The following is the code for the Copy:

' Constants for error handling
Const iCB_CLEAR_ERR = 3 + vbObjectError + 512 Const iCB_SET_ERR = 4 + vbObjectError + 512 Const iCB_PASTE_ERR = 5 + vbObjectError + 512

' Standard Copy procedure
' This could be enhanced to support alternative clipboard types Public Sub EditCopy() ' Set the error handler On Error Resume Next

' Clear the clipboard
Clipboard.Clear
If Err.Number Then
   Err.Raise iCB_CLEAR_ERR, "CApplication", "Could not clear clipboard."
Else
   ' Place selected text on the clipboard
   Clipboard.SetText Screen.ActiveControl.SelText
   If Err.Number Then
	Err.Raise iCB_SET_ERR, "CApplication", "Could not set text from active control to clipboard."
   End If
End If
End Sub
The following is the code for the Cut:

' Standard Cut procedure
' This could be enhanced to support alternative clipboard types Public Sub EditCut() ' Set the error handler On Error Resume Next

' Clear the clipboard
Clipboard.Clear
If Err.Number Then
   Err.Raise iCB_CLEAR_ERR, "CApplication", "Could not clear clipboard."
Else
   ' Place selected text on the clipboard
   Clipboard.SetText Screen.ActiveControl.SelText
   Screen.ActiveControl.SelText = ""
   If Err.Number Then
	Err.Raise iCB_SET_ERR, "CApplication", "Could not set text from active control to clipboard."
   End If
End If

End Sub
The following is the code for the Paste:

' Standard Paste procedure
' This could be enhanced to support alternative clipboard types Public Sub EditPaste() ' Set the error handler On Error Resume Next

' Place the text from the clipboard
Screen.ActiveControl.SelText = Clipboard.GetText() If Err.Number Then
   Err.Raise iCB_PASTE_ERR, "CApplication", "Could not paste text from clipboard to active control."
End If

End Sub



c0Title: How do you avoid the "Invalid use of null" error when reading null values from a database?
c1Code:
Add ""  to the field
TextBox.Text = MyTest.Fields("TestFld") & "" 
This code converts the Null-Value into an empty string.


c0Title: How I can I have continuous scrolling text?
c1Code:
Some times you require to display a information, which is bigger then the biggest text box you can have on the screen. e.g. You want to show the list of user logged on in your application.  
Define a timer on the form. Define a text box on the form, call it MurkyTextBox.
Define a Static variable called iStart as integer and initialize it to 1, may be in form load.

Static iStart as integer.
Private Sub Timer_Function ( )Private Sub Timer_Function ( )
    Dim sStr As String
    Dim sFirstPart As String
    Dim sSecondPart As String
    Dim iLen as integer
    sStr = MurkyTextBox.text
    iLen = Len$(sStr)
    iStart = iStart + 1
    sFirstPart = Mid$( sStr , iStart, iLen - iStart)
    sSecondPart = Mid$( sStr, 1, iStart)
    MurkyTextBox.text = sFirstPart & sSecondPart
    If iStart >= Len(sStr) Then
        iStart = 1
    End If
End Sub
Index

Remove a character from a String
Function RemoveCharFromStr(ByRef sMainStr As String, sChar As String) As String

On Error Resume Next
Dim i As Integer

    For i = 1 To Len(sMainStr) 'To 1 Step -1
        If Mid$(sMainStr, i, 1) = sChar Then
            sMainStr = Mid$(sMainStr, 1, i - 1) & Mid$(sMainStr, i + 1)
        End If
    Next

    RemoveCharFromStr = sMainStr
Exit Function
Index

Slice String - Breaks  the string in many segments, depending on  the terminating characters.  Pieces of string is returned in a array.
Public Sub SliceString(ArrayName() As Variant, TerminatorCharacter As String, TheString As                          String)
    Dim st_Len As Integer
    Dim intLen As Integer
    Dim i As Integer
    Dim tstr As String
    st_Len = 1
    intLen = 1
    i = 0
    TheString = Trim(TheString)
    Do While intLen <> 0
            intLen = InStr(st_Len, TheString, TerminatorCharacter, vbTextCompare)
            If intLen = 0 Then Exit Do
            tstr = Mid$(TheString, st_Len, intLen - st_Len)
            st_Len = intLen + 1
            ReDim Preserve ArrayName(i)
            ArrayName(i) = Trim(tstr)
            i = i + 1
Loop
End Sub
Index


c0Title: ADO: How to call stored procedure with parameters using ADO ?
c1Code:
Dim cn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim pClosingDate As ADODB.Parameter

Dim rs As Recordset

cn.ConnectionString = "DSN=SERVER;Database=Northwind;uid=USERNAME;pwd=PASSWORD"
cn.Open
cmd.ActiveConnection = cn

Set pClosingDate = cmd.CreateParameter("pClosingDate", adChar, adParamInput, 14, sClosingDate) cmd.Parameters.Append pClosingDate cmd.CommandText = "sp_UpdateHistory "
cmd.CommandType = adCmdStoredProc 'Call the stored procedure cmd.CommandTimeout = 120 cmd.Execute


c0Title: How to check for Leap Year ?
c1Code:
Function IsLeap(sYear As String) As boolean
 If IsDate("02/29/" & sYear) Then
  IsLeap = True
 Else
  IsLeap = False
 End If
End Function


c0Title: How to check if a program is running ?
c1Code:
Public Function IsEXERunning(sModule As String) As Integer

Dim lHwnd As Long, hInst As Long, lRet As Long Dim sBuffer As String * 255 IsEXERunning = False ' Grab the first window handle that Window's finds:
lHwnd = FindWindow(vbNullString, vbNullString) ' Loop until there are no more window handles:
Do Until lHwnd = 0
        lHwnd = GetWindow(lHwnd, GW_HWNDNEXT)
        If GetParent(lHwnd) = 0 Then
            lRet = GetWindowText(lHwnd, sBuffer, Len(sBuffer))
            If lRet > 0 Then
              If InStr(Left$(sBuffer, lRet), sModule) Then
                    IsEXERunning = True
                    Exit Do
              End If
            End If
        End If
Loop

End Function


c0Title: How to check if a TreeView Node Exists (by Key)
c1Code:
Public Function FindNode(MyTree as Treeview, FindKey as string) as Boolean dim MyNode as Node

On Error Goto ErrorHandler

  set MyNode = MyTree.Nodes(FindKey)

  FindNode = True

  exit function

ErrorHandler:

  FindNode = False

End Function


c0Title: How to check if the form is loaded
c1Code:
For Each Form In Forms
	If Form.Name = "Form1" Then MsgBox "Form1"     
	If Form.Name = "Form2" Then MsgBox "Form2" 
Next Form


c0Title: How to convert date from Julian Date ?
c1Code:
Function ConvertFromJulian(Datein As Long) As Long

Dim dateout As Long

On Error GoTo et

' will convert a (year + julian date) to mm/dd/yy string If Datein <= 0 Then
    dateout = Space$(8)
Else
    dateout = DateSerial((Int(Year(Now) / 100) * 100) + Int(Datein / 1000), 1, Datein Mod 1000)
    dateout = Format$(dateout, "mmddyy") End If

ConvertFromJulian = dateout
Exit Function
et:
dateout = Space$(8)
ConvertFromJulian = dateout

End Function


c0Title: How to convert date to Julian
c1Code:
Public Function ConvertToJulian(Datein As Variant) As Long

Dim iYear As String
Dim iJulDay As String
Dim iResult As Integer

' will convert a mm/dd/yy string to a julian date On Error GoTo et

'If Len(Trim$(Datein)) <= 0 Then
If Not IsDate(Datein) Then
    ConvertToJulian = 0
Else
    iYear = Format$(Datein, "yy")
    iJulDay = Format$(Str(Int(CVDate(Datein) - CVDate("Jan 1 " & iYear)) + 1), "000")
    ConvertToJulian = Val(iYear & iJulDay) End If

Exit Function

et:
ConvertToJulian = 0
End Function


c0Title: How to convert Number into binary equivalent. ?
c1Code:
'This function takes a integer and return a string.
'for e.g. if you will pass 12 it will return 0000 0000 0000 1100

Public Function sNumToBin(ByVal iNumber As Integer) As String
	Dim sBinary As String
	Dim i As Integer
	For i = 0 To 15
		sBinary = IIf((iNumber And (2 ^ i)), "1", "0") & sBinary
	Next
	sNumToBin = sBinary
End Function


c0Title: How to convert number into Hex equivalent?
c1Code:
'for e.g. if the number 140 is passed it will return 008C

'There is an equivalent function in VB Hex(int), but some time you may be asked in an interview to write this function 'without using Hex in front of half a dozen people, that too on a blackboard.

Public Function itoh(ByVal nNum As Integer) As String
    Dim s, sString, sReturn As String
    Dim i As Integer
    Dim nByte As Byte
    Dim x As Integer
    Const c As String = "0123456789ABCDEF"

    '--------------------------------------
    'get the number converted into Binary
    '--------------------------------------
    s = sNumToBin(nNum)

    For i = 0 To 15 Step 4
        sString = Mid$(s, i + 1, 4) 'Get the Byte, 4 bit
        x = 0
        'get the bit value
        For j = 1 To 4
            x = IIf(Mid$(sString, j, 1), 2 ^ (4 - j), 0) + x
        Next j
        sReturn = sReturn & IIf(x <= 15, Mid$(c, x + 1, 1), "?")
    Next i
        itoh = sReturn
End Function


c0Title: How to convert numbers to text ?
c1Code:
Convert numbers to text

Private sOnes(9) As String
Private sTeens(10) As String
Private sTens(9) As String
sOnes(0) = ""
sOnes(1) = "One"
sOnes(2) = "Two"
sOnes(3) = "Three"
sOnes(4) = "Four"
sOnes(5) = "Five"
sOnes(6) = "Six"
sOnes(7) = "Seven"
sOnes(8) = "Eight"
sOnes(9) = "Nine"
sTeens(0) = "Ten"
sTeens(1) = "Eleven"
sTeens(2) = "Twelve"
sTeens(3) = "Thirteen"
sTeens(4) = "Fourteen"
sTeens(5) = "Fifteen"
sTeens(6) = "Sixteen"
sTeens(7) = "Seventeen"
sTeens(8) = "Eighteen"
sTeens(9) = "Nineteen"
sTens(2) = "Twenty"
sTens(3) = "Thirty"
sTens(4) = "Forty"
sTens(5) = "Fifty"
sTens(6) = "Sixty"
sTens(7) = "Seventy"
sTens(8) = "Eighty"
sTens(9) = "Ninety"

'________________________________
' Converts a number to text
'________________________________
Public Function ConvertToText(ByVal dNum As Double) As String
    Dim sWorkString As String, sDigits As String
    Dim sHundreds As String, sThousands As String, sMillions As String,                              sBillions As String
    '********************
    '*** Parse all whole number digits up to 999,999,999,999
    '********************
    sDigits = Format(Fix(dNum), "0")
    sHundreds = Right(sDigits, 3)
    If Len(sDigits) > 3 Then
        sThousands = Right(Left(sDigits, Len(sDigits) - 3), 3)
    End If
    If Len(sDigits) > 6 Then
        sMillions = Right(Left(sDigits, Len(sDigits) - 6), 3)
    End If
    If Len(sDigits) > 9 Then
        sBillions = Right(Left(sDigits, Len(sDigits) - 9), 3)
    End If


    '********************
    '*** Break down to groups of 3 digits
    '********************
    If Len(sBillions) > 0 Then
        sWorkString = Hundreds(sBillions) & " Billion"
    End If
    If Len(sMillions) > 0 And sMillions <> "000" Then
    If Len(sWorkString) > 0 Then sWorkString = sWorkString & " "
        sWorkString = sWorkString & Hundreds(sMillions) & " Million"
    End If
    If Len(sThousands) > 0 And sThousands <> "000" Then
        If Len(sWorkString) > 0 Then sWorkString = sWorkString & " "
        sWorkString = sWorkString & Hundreds(sThousands) & " Thousand"
    End If
    If sHundreds <> "000" Then
        If Len(sWorkString) > 0 Then sWorkString = sWorkString & " "
        sWorkString = sWorkString & Hundreds(sHundreds)
    End If

    '***************
    '*** add Dollars and Cents
    '***************
    ConvertToText = sWorkString & " Dollars and " & Right(Format(dNum,                      ".00"), 2) & "/100"
End Function


'***************************************
'**** Process three digit numbers up to 999
'***************************************
Private Function Hundreds(ByVal sDigits As String) As String Dim sWorkString As String, i As Integer sDigits = CStr(Fix(CInt(sDigits)))

'************* Digit 3
If Len(sDigits) = 3 And Left(sDigits, 1) <> 0 Then
    sWorkString = sOnes(CInt(Left(sDigits, 1))) & " Hundred"
    sDigits = Right(sDigits, 2)
End If
'************* Digit 2
If Len(sDigits) = 2 Then
    Select Case Left(sDigits, 1) 'Check for 0,1 or other in digit 2
    Case "0"
        If Right(sDigits, 1) <> "0" Then
            If Len(sWorkString) > 0 Then sWorkString = sWorkString & " "
            sWorkString = sWorkString & sOnes(CInt(Right(sDigits, 1)))
        End If
    Case "1"
        If Len(sWorkString) > 0 Then sWorkString = sWorkString & " "
        sWorkString = sWorkString & Teens(sDigits)
    Case Else
        If Len(sWorkString) > 0 Then sWorkString = sWorkString & " "
        sWorkString = sWorkString & sTens(CInt(Left(sDigits, 1)))
        If Right(sDigits, 1) <> "0" Then
            sWorkString = sWorkString & " " & sOnes(CInt(Right(sDigits, 1)))
        End If
    End Select
End If

'************** Digit 1
If Len(sDigits) = 1 And sDigits <> "0" Then If Len(sWorkString) > 0 Then sWorkString = sWorkString & " "
    sWorkString = sWorkString & sOnes(CInt(Right(sDigits, 1))) End If Hundreds = sWorkString End Function

'*****************************
'*** numbers between 10 and 19
'*****************************
Private Function Teens(sNum As String) As String On Error Resume Next Dim i As Integer i = CInt(Right$(sNum, 1))
    Teens = sTeens(i)
End Function


c0Title: How To Create Quickly Create Directories
c1Code:
If you ever need to quickly create an entire directory structure for your application, the following example is a quick and easy way. It uses the CreateDirectory API and the Dir() function to quickly create all the directories in the path.

Declare


Private Type SECURITY_ATTRIBUTES
     nLength As Long
     lpSecurityDescriptor As Long
     bInheritHandle As Long
End Type

 
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long


Code


Public Sub CreateNewDirectory(NewDirectory As String)
	Dim sDirTest As String
	Dim SecAttrib As SECURITY_ATTRIBUTES
	Dim bSuccess As Boolean
	Dim sPath As String
	Dim iCounter As Integer
	Dim sTempDir As String

	iFlag = 0
	sPath = NewDirectory

	If Right(sPath, Len(sPath)) <> "\" Then
		sPath = sPath & "\"
	End If

	iCounter = 1

	Do Until InStr(iCounter, sPath, "\") = 0
		iCounter = InStr(iCounter, sPath, "\")
		sTempDir = Left(sPath, iCounter)
		sDirTest = Dir(sTempDir)
		iCounter = iCounter + 1

		'create directory
		SecAttrib.lpSecurityDescriptor = &O0
		SecAttrib.bInheritHandle = False
		SecAttrib.nLength = Len(SecAttrib)
		bSuccess = CreateDirectory(sTempDir, SecAttrib)
	Loop
End Sub


c0Title: How To Delete A File to the Windows Recycling Bin
c1Code:
Visual Basic 4.0 applications under Window 95 or Windows NT can call the Win32 API's SHFileOperation function to delete a file to the Windows 95 Recycling Bin. Users quickly become accustomed to using new operating system features such as the recycling bin and may be disappointed if they find that your programs do not support them.

Declare The Following

Type SHFILEOPSTRUCT
     hWnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Integer
     fAborted As Boolean
     hNameMaps As Long
     sProgress As String
End Type

Public Const FO_DELETE = &H3
Public Const FOF_ALLOWUNDO = &H40

Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long


Code


Public Function ShellDelete(ParamArray vntFileName() As Variant)

     Dim I As Integer
     Dim sFileNames As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For I = LBound(vntFileName) To UBound(vntFileName)
           sFileNames = sFileNames & vntFileName(I) & vbNullChar
     Next I

     sFileNames = sFileNames & vbNullChar

     With SHFileOp
           .wFunc = FO_DELETE
           .pFrom = sFileNames
           .fFlags = FOF_ALLOWUNDO
     End With

     ShellDelete = SHFileOperation(SHFileOp)
End Function


Example


The function's ParamArray argument allows you to call it in several ways:

'Delete a single file
lResult = ShellDelete("setupwizard.exe")

'Pass file names in an array
sFileName(1) = "setupwizard.exe"
sFileName(2) = "setupwizard.hlp"
sFileName(3) = "setupwizard.doc"
lResult = ShellDelete(sFileName())

'Pass file names as parameters
lResult = ShellDelete("setupwizard.exe", "setupwizard.hlp", "setupwizard.doc")


c0Title: How To Determine If RAS Is Connected
c1Code:
Here is an easy way to detect if a computer is connected to the Internet via a RAS connection.

Declare
Public Const RAS95_MaxEntryName = 256
Public Const RAS_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 128
Public Const RASCS_DONE = &H2000&

Public Type RASCONN95
  'set dwsize to 412
  dwSize As Long
  hRasConn As Long
  szEntryName(RAS95_MaxEntryName) As Byte
  szDeviceType(RAS_MaxDeviceType) As Byte
  szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Type RASCONNSTATUS95
  'set dwsize to 160
  dwSize As Long
  RasConnState As Long
  dwError As Long
  szDeviceType(RAS_MaxDeviceType) As Byte
  szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasConn As Long, lpRASCONNSTATUS As Any) As Long
Code
Public Function IsRASConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim lReturn As Long
Dim Tstatus As RASCONNSTATUS95

  TRasCon(0).dwSize = 412
  lg = 256 * TRasCon(0).dwSize
  lReturn = RasEnumConnections(TRasCon(0), lg, lpcon)

  If lReturn <> 0 Then
    MsgBox "ERROR"
    Exit Function
  End If

  Tstatus.dwSize = 160
  lReturn = RasGetConnectStatus(TRasCon(0).hRasConn, Tstatus)

  If Tstatus.RasConnState = RASCS_DONE Then
    IsRASConnected = True
      Else
        IsRASConnected = False
  End If

End Function



c0Title: How to Determine the Number of Lines in a Textbox
c1Code:
This method is straightforward: it uses SendMessage to retrieve the number of lines in a textbox.  A line to this method is defined as a new line after a word-wrap; it is independent of the number of hard returns in the text.


Declarations


Place the following API declare code into the general declarations area of a bas module.   If using VB4-32 or VB5, and this is a one-form project, the declares below could be placed into the general declaration section of the form instead, with all Public references changed to Private.

Option Explicit

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

Public Const EM_GETLINECOUNT = &HBA

Form Code


Sub Text1_Change()
    Dim lineCount as Long
    On Local Error Resume Next
  
   'get/show the number of lines in the edit control
    lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
    Label1 = Format$(lineCount, "##,###") 
End Sub 


Comments


The textbox passed to the SendMessage API must have its multiline property set to true at design time. The EM_GETLINECOUNT message does not pass additional parameters to the API in the wParam or lParam variables. These must be 0. 

Tip by James Limm


c0Title: Access: How To Disable/Enable the Shift Bypass Key in Microsoft Access:
c1Code:
QUESTION � Is there any way of preventing user's from holding down Shift Key when opening up my Microsoft Access database and bypassing the Start-Up options which have been disabled.

I however, still need some sort of facility to do this, so I can add new forms, queries etc. whenever necessary. 

SOLUTION � To prevent a user bypassing the start-up options you will need to apply the following function and code to a command button (or ideally a hidden option, such as to the double-click event of a label or graphic).

This will prevent anyone without the password bypassing the start-up by using the Shift key.

The below function and command button code will allow you to use a password protected input box to determine if the Shift key can be disabled or not.

You might have to set your "References" in the VBA editor to DAO 3.6.

When you are viewing a Module, click the Tools menu � References. Browse for Microsoft DAO 3.6

Select "Files of type: Executable Files (*.exe; *.dll)"

C:\Program Files\Common Files\Microsoft Shared\DAO)

Then explicitly dimension yourcode, i.e. Dim db As DAO.Database, prp As DAO.Property

'***************** Code Start ***************
'Copy this function into a new public module.
 
Option Compare Database
Option Explicit
 
Public Function SetProperties(strPropName As String, _
varPropType As Variant, varPropValue As Variant) As Integer
 
    On Error GoTo Err_SetProperties
 
    Dim db As DAO.Database, prp As DAO.Property
 
    Set db = CurrentDb
    db.Properties(strPropName) = varPropValue
    SetProperties = True
    Set db = Nothing
 
Exit_SetProperties:
    Exit Function
 
Err_SetProperties:
    If Err = 3270 Then    'Property not found
        Set prp = db.CreateProperty(strPropName, varPropType, varPropValue)
        db.Properties.Append prp
        Resume Next
    Else
        SetProperties = False
        MsgBox "SetProperties", Err.Number, Err.Description
        Resume Exit_SetProperties
    End If
End Function
'***************** Code End ***************
Once you have created the module, then you will need to attach the following code to a command button (or label, graphic etc.):
'***************** Code Start ***************
'Assign this to the OnClick event of a command button (or double-click event
'of a label or graphic) named "bDisableBypassKey"
'Change the "TypeYourBypassPasswordHere" default password to your password
 
Private Sub bDisableBypassKey_Click()
    On Error GoTo Err_bDisableBypassKey_Click
    'This ensures the user is the programmer needing to disable the Bypass Key
    Dim strInput As String
    Dim strMsg As String
    Beep
    strMsg = "Do you want to enable the Bypass Key?" & vbCrLf & vbLf & _
            "Please key the programmer's password to enable the Bypass Key."
    strInput = InputBox(Prompt:=strMsg, title:="Disable Bypass Key Password")
    If strInput = "TypeYourBypassPasswordHere" Then
        SetProperties "AllowBypassKey", dbBoolean, True
        Beep
        MsgBox "The Bypass Key has been enabled." & vbCrLf & vbLf & _
               "The Shift key will allow the users to bypass the startup & _
               options the next time the database is opened.", _
               vbInformation, "Set Startup Properties"
    Else
        Beep
        SetProperties "AllowBypassKey", dbBoolean, False
        MsgBox "Incorrect ''AllowBypassKey'' Password!" & vbCrLf & vbLf & _
               "The Bypass Key was disabled." & vbCrLf & vbLf & _
               "The Shift key will NOT allow the users to bypass the & _
               startup options the next time the database is opened.", _
               vbCritical, "Invalid Password"
        Exit Sub
    End If
Exit_bDisableBypassKey_Click:
    Exit Sub
Err_bDisableBypassKey_Click:
    MsgBox "bDisableBypassKey_Click", Err.Number, Err.Description
    Resume Exit_bDisableBypassKey_Click
End Sub
'***************** Code End ***************
Once this is in place, a user will not have access to bypass the Start-Up options.

As the administrator, you can then click on your command button, label or graphic and will be presented with the following input box:



If the correct password is entered you will see the following message:



An inncorrect password will give the following message and not allow the Shift key to bypass the Start-Up options:



Note: Always create a backup copy of the database, to test out any areas that may cause problems when working with start-up options or disabling Access features.

 


c0Title: How to display the item which the mouse is over in a list box
c1Code:
I have had many letters which have asked me how to you display in a tooltip or some other means, such as a text box, the current item's text in a list box which the mouse pointer is hovering over. I now have the answer which uses the SendMessage API.

  a.. Start A new Standard-EXE project, form1 is created by default. 
  b.. Add a list box and a text box to form1. 
  c.. Open up the code window for Form1 and type the following Option Explicit

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_ITEMFROMPOINT = &H1A9

Private Sub Form_Load()
With List1
    .AddItem "Visit"
    .AddItem "Steve Anderson Web Site AT"
    .AddItem "http://www.microweird.demon.co.uk"
End With
End Sub

Private Sub List1_MouseMove(Button _
As Integer, Shift As Integer, X As _
Single, Y As Single)
Dim lXPoint As Long
Dim lYPoint As Long
Dim lIndex As Long
If Button = 0 Then 'if no button was pressed
    lXPoint = CLng(X / Screen.TwipsPerPixelX)
    lYPoint = CLng(Y / Screen.TwipsPerPixelY)
    With List1
        'get selected item from list
        lIndex = SendMessage(.hwnd, _
        LB_ITEMFROMPOINT, 0, ByVal _
        ((lYPoint * 65536) + lXPoint))
        'show tip or clear last one
        If (lIndex >= 0) And _
        (lIndex <= .ListCount) Then
            .ToolTipText = .List(lIndex)
            Text1.Text = .List(lIndex)
        Else
            .ToolTipText = ""
        End If
    End With
End If
End Sub
  a.. Run the project(F5) and hover your cursor over different items in the list box and they will be displayed in a tooltip and in Text1. 
Tip by Steve Anderson



c0Title: How To Get A Disks Serial Number
c1Code:
As you might know DOS writes a serial number on a disk (hard disk or floppy disk) after it has been formatted. The serial number is not guaranteed to be unique, but since it's a 32-bit integer it's very unlikely you will find a duplicate. Many programmers use this serial number to copy-protect their programs. Under Windows 3.1 you would have to purchase a DLL to do this in Visual Basic. Well not any more! Microsoft has finally put it into the Win95 and WinNT Kernel API. To get a disks serial number do the following:

Declare The Following

Private Declare Function GetVolumeInformation _

     Lib "kernel32.dll" Alias "GetVolumeInformationA" _

     (ByVal lpRootPathName As String, ByVal _

     lpVolumeNameBuffer As String, ByVal nVolumeNameSize _

     As Integer, lpVolumeSerialNumber As Long, _

     lpMaximumComponentLength As Long, lpFileSystemFlags _

     As Long, ByVal lpFileSystemNameBuffer As String, _

     ByVal nFileSystemNameSize As Long) As Long

Code

Function GetSerialNumber(sRoot As String) As Long

     Dim lSerialNum As Long

     Dim R As Long

     Dim sTemp1 As String, sTemp2 As String

     sTemp1 = String$(255, Chr$(0))

     sTemp2 = String$(255, Chr$(0))

     R = GetVolumeInformation(sRoot, sTemp1, Len(sTemp1), _

           lSerialNum, 0, 0, sTemp2, Len(sTemp2))

     GetSerialNumber = lSerialNum

End Function

Usage

The Function will return an 0 if it the drive does not exist. You can pass it a directory name too, but if it does not exist, then it will also return a 0. To use, simply call:

lSerial = GetSerialNumber("c:\")


c0Title: How To Get the Address of Variables in Visual Basic
c1Code:
View products that this article applies to.
Article ID : 199824 
Last Review : July 1, 2004 
Revision : 2.1 

This article was previously published under Q199824
On This Page
SUMMARY 
MORE INFORMATION 
VarPtr 
VarPtrArray 
StrPtr 
VarPtrStringArray 
ObjPtr 
SUMMARY
It is uncommon for a Visual Basic programmer to need to obtain low level information on a variable, such as its memory address. However, there are some API functions that require such information. This article describes the following Visual Basic functions that may help a Visual Basic programmer obtain this information:


VarPtr - Returns the address of a variable.

VarPtrArray - Returns the address of an array.

StrPtr - Returns the address of the UNICODE string buffer.

VarPtrStringArray - Returns the address of an array of strings.

ObjPtr - Returns the pointer to the interface referenced by an object variable. 
Back to the top

MORE INFORMATION
WARNING: One or more of the following functions are discussed in this article; VarPtr, VarPtrArray, VarPtrStringArray, StrPtr, ObjPtr. These functions are not supported by Microsoft Technical Support. They are not documented in the Visual Basic documentation and are provided in this Knowledge Base article "as is." Microsoft does not guarantee that they will be available in future releases of Visual Basic.


Back to the top

VarPtr
This function can be used to get the address of a variable or an array element. It takes the variable name or the array element as the parameter and returns the address. However, you should be aware that unlocked Dynamic Arrays may be reallocated by Visual Basic, so you must be very careful when you use VarPtr to get the address of an array element. 

The following example gets the address of a variable:


Dim lngVariableAddress as Long
Dim dblMyVariable as Double
lngVariableAddress = VarPtr(dblMyVariable)
				

This example gets the address of the fourth element of an array: 


Dim lngElementAddress as Long
Dim lngArrayOfLongs(9) as Long
' following will get address of 4th element
lngElementAddress = VarPtr(lngArrayOfLongs(3))
				

Limitations: The VarPtr function cannot be used to get the address of an array. For more information, see the VarPtrArray function. 


Back to the top

VarPtrArray
Arrays in Visual Basic are stored as SAFEARRAYs. To get the address of the SAFEARRAY structure, you need to use the VarPtrArray function. The following are the Visual Basic 5.0 and Visual Basic 6.0 declarations respectively:


Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" _
(Var() as Any) As Long


Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" _
(Var() as Any) As Long
				

To get the address of a SAFEARRAY, pass the SAFEARRAY name (including the parenthesis) to the VarPtrArray function: 


Dim lngSafeArrayAddress as Long
Dim lngArrayOfLongs(9) as Long
lngSafeArrayAddress = VarPtrArray(lngArrayOfLongs())
				

Limitations: The VarPtrArray function cannot be used to get the address of an array of Strings, because Visual Basic does UNICODE/ANSI conversion for Strings. If you use VarPtrArray on an array of Strings, you will get the address of a temporary ANSI copy of the array. For more information, see the VarPtrStringArray function. 


Back to the top

StrPtr
Strings in Visual Basic are stored as BSTR's. If you use the VarPtr on a variable of type String, you will get the address of the BSTR, which is a pointer to a pointer of the string. To get the address of the string buffer itself, you need to use the StrPtr function. This function returns the address of the first character of the string. Take into account that Strings are stored as UNICODE in Visual Basic. 

To get the address of the first character of a String, pass the String variable to the StrPtr function. 

Example: 


Dim lngCharAddress as Long
Dim strMyVariable as String
strMyVariable = "Some String"
lngCharAddress = StrPtr(strMyVariable)
				

You can use this function when you need to pass a pointer to a UNIOCODE string to an API call.

Back to the top

VarPtrStringArray
VarPtrStringArray gets the address of an array of Strings. To avoid the intrinsic UNICODE/ANSI conversion performed by Visual Basic, the declaration has to be defined in a type library. 

Alternatively, you could use the MIDL compiler to compile your own type library from the following .odl files. 

For Visual Basic 6.0, create a text file named VB6ptrlib.odl with the content below: 


#define RTCALL _stdcall
[
uuid(C6799410-4431-11d2-A7F1-00A0C91110C3),
lcid (0), version(6.0), helpstring("VarPtrStringArray Support for VB6")
]
library PtrLib
{
importlib ("stdole2.tlb");
[dllname("msvbvm60.dll")]
module ArrayPtr
   {
   [entry("VarPtr")]
   long RTCALL VarPtrStringArray([in] SAFEARRAY (BSTR) *Ptr);
   }
}
				

For Visual Basic 5.0, create a text file named VB5ptrlib.odl with the content below: 


#define RTCALL _stdcall
[
uuid(6E814F00-7439-11D2-98D2-00C04FAD90E7),
lcid (0), version(5.0), helpstring("VarPtrStringArray Support for VB5")
]
library PtrLib
{
importlib ("stdole2.tlb");
[dllname("msvbvm50.dll")]
module ArrayPtr
   {
   [entry("VarPtr")]
   long RTCALL VarPtrStringArray([in] SAFEARRAY (BSTR) *Ptr);
   }
}
				

Use the following command lines to compile the preceding .odl files with the MIDL compiler to create a Visual Basic 6.0 or Visual Basic 5.0 type library (.tlb) file respectively: 


MIDL /t VB6ptrlib.odl MIDL /t VB5ptrlib.odl 

To use the VarPtrStringArray function in your project, you need to create a reference to the type library you just created. 

Example: 


Dim MyArrayOfStrings(2) As String
Dim AddressOfArray As Long
MyArrayOfStrings(0)="AAA"
MyArrayOfStrings(1)="BBB"
AddressOfArray = VarPtrStringArray ( MyArrayOfStrings() )
				


Back to the top

ObjPtr
ObjPtr takes an object variable name as a parameter and obtains the address of the interface referenced by this object variable.

One scenario of using this function is when you need to do a collection of objects. By indexing the object using its address as the key, you can get faster access to the object than walking the collection and using the Is operator. In many cases, the address of an object is the only reliable thing to use as a key.

Example: 


objCollection.Add MyObj1, CStr(ObjPtr(MyObj1))
...
objCollection.Remove CStr(ObjPtr(MyObj1))
				
Back to the top


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

APPLIES TO
� Microsoft Visual Basic 5.0 Learning Edition 
� Microsoft Visual Basic 6.0 Learning Edition 
� Microsoft Visual Basic 5.0 Professional Edition 
� Microsoft Visual Basic 6.0 Professional Edition 
� Microsoft Visual Basic 5.0 Enterprise Edition 
� Microsoft Visual Basic 6.0 Enterprise Edition 

Back to the top

Keywords:  kbhowto KB199824 


c0Title: How to get the current time with millisecond precision
c1Code:
See also 'Time/Date Conversions'


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 Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)


Function TimeMS() As String
    Dim sysLocalTime As SYSTEMTIME
    
    GetLocalTime sysLocalTime
    
    With sysLocalTime
        TimeMS = .wMonth & "/" & .wDay & "/" & .wYear & " " & .wHour & ":" & Format(.wMinute, "00") & ":" & Format(.wSecond, "00") & "." & Format(.wMilliseconds, "000")
    End With
End Function


c0Title: How To Get The Current Users Name
c1Code:
Here is some easy code to get the name of the user currently logged into Win95 or WinNT. This is the name the user types into the login dialog when Win95 or WinNT starts.

Declare

Declare Function WNetGetUser& Lib "Mpr" Alias "WNetGetUserA" (lpName As Any, ByVal lpUserName$, lpnLength&)

Code

Public Function GetMachineUserName() As String

	Dim pstrUserName As String
	Dim plngUserNameLen As Long
	Dim plngReturn As Long

    pstrUserName = Space(256)

    plngUserNameLen = Len(pstrUserName)

    plngReturn = WNetGetUser(ByVal 0&, pstrUserName, plngUserNameLen)

    If plngReturn = 0 Then

        ' Success - strip off the null.

        GetMachineUserName = Left(pstrUserName, InStr(pstrUserName, Chr(0)) - 1)

        Else

            GetMachineUserName = ""

    End If

End Function


c0Title: How To Get The Machine Name
c1Code:
Here is cool function to get the name of the computer the user is logged on to on Win95 and WinNT. This is the name of the computer as defined in the Network dialog in Control Panel.

Declare

Public Const MAX_COMPUTERNAME_LENGTH As Long = 15&

Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Code

Public Function GetMachineName() As String

Dim plngSize As Long

Dim pstrBuffer As String

    pstrBuffer = Space$(MAX_COMPUTERNAME_LENGTH + 1)

    plngSize = Len(pstrBuffer)

    If GetComputerName(pstrBuffer, plngSize) Then

        GetMachineName = Left$(pstrBuffer, plngSize)

    End If

End Function


c0Title: How to get the Previous instance of the application ?
c1Code:
Global Const SW_RESTORE=9

Declare Function FindWindow Lib "User" (ByVal lpClassName As Any, ByVal lbWindowName As Any) As Integer 
Declare Function ShowWindow Lib "User" (ByVal hWnd As Integer, ByVal nCmdShow As Integer) As Integer Declare Function SetFocusAPI Lib "User" Alias "SetFocus" (ByVal hWnd As Integer) As Integer

Sub Main () 
	Dim hWnd As Integer 
	Dim iResult As Integer 

	App.Title = "Title of your application."

	If App.PrevInstance Then 
		hWnd = FindWindow("Classnamefortheform_form", App.Title)
	        If hWnd <> 0 Then 
        	        iResult = ShowWindow(hWnd, SW_RESTORE)
	        End If
	End If
	frmMain.Show
End Sub


c0Title: How to get Unique file Name ?
c1Code:
Public Function GetUniqueFileName(sPath As String, sPrefix As String) As String

    Dim sTemp As String
    sPrefix = Mid$(sPrefix, 1, 1)

    Do
        If sPrefix <> "" Then
            sTemp = sPrefix & CStr(Month(Now)) & CStr(Hour(Now)) & CStr(Minute(Now)) &           CStr(Second(Now))
        Else
            sTemp = CStr(Month(Now)) & CStr(Hour(Now)) & CStr(Minute(Now)) & CStr(Second(Now))
        End If

	Loop Until Dir(sPath & sTemp) = ""
	GetUniqueFileName = sPath & Mid$(sTemp, 1, 8) 
End Function


c0Title: How to get valid date from Variant ?
c1Code:
Private Function GetValidDateFromVariant(ByVal vDefault As Variant) As Variant

If IsDate(vDefault) Then
    GetValidDateFromVariant = CDate(vDefault) Else
    GetValidDateFromVariant = ""
End If
End  Function

Private Function GetValidTimeFromVariant(ByVal vDefault As Variant) As Variant If IsDate(vDefault) Then
    GetValidTimeFromVariant = CVDate(vDefault) Else
    GetValidTimeFromVariant = ""
End If

End Function



Note :
Use the IsDate function to determine if date can be converted to a date or time. CDate recognizes date literals and time literals as well as some numbers that fall within the range of acceptable dates. When converting a number to a date, the whole number portion is converted to a date. Any fractional part of the number is converted to a time of day, starting at midnight.
CDate recognizes date formats according to the locale setting of your system. The correct order of day, month, and year may not be determined if it is provided in a format other than one of the recognized date settings. In addition, a long date format is not recognized if it also contains the day-of-the-week string.

A CVDate function is also provided for compatibility with previous versions of Visual Basic. The syntax of the CVDate function is identical to the CDate function, however, CVDate returns a Variant whose subtype is Date instead of an actual Date type. Since there is now an intrinsic Date type, there is no further need for CVDate. The same effect can be achieved by converting an expression to a Date, and then assigning it to a Variant. This technique is consistent with the conversion of all other intrinsic types to their equivalent Variant subtypes.
Index


c0Title: How to implement "What's this?" Help
c1Code:
Under Windows 95 and Windows NT 3.51, it is possible to right-click on items and get the "What's This?" window to appear. To set this up in Visual Basic, you need to use a pop-up menu.

Example

  a.. Start Visual Basic 4.0 or, if it is already running, click New Project on the File menu. 
  b.. Set the WhatsThisHelp and WhatsThisButton properties for Form1 to TRUE. 
  c.. Add the following code to reference the Hotspot Editor help file to the Form_Load procedure: 
Private Sub Form_Load()
'This should point to the hc directory
'under the VB4 directory
App.HelpFile = "c:vbhcshed.hlp"
End Sub
  d.. Add two menu items to Form1 using the following as a guide: 
Menu                   Property            Value
----------------------------------------------------
WhatsThis              Caption            WhatsThis
WhatsThis              Name               mnuWhatsThis
WhatsThis              Visible            False

What's This?           Caption            What's This?
What's This?           Name           mnuWhatsThisHelp

  e.. Indent "What's This?" to make it a sub-menu of WhatsThis by pressing the right-arrow button on the Menu Editor. 
  f.. Add the following code to the General Declarations section of Form1: 
Public ThisControl as control
  g.. Add the following code to the mnuWhatsThisHelp_Click procedure: 
Private Sub mnuWhatsThisHelp_Click()
ThisControl.ShowWhatsThis
End Sub
  h.. Add a Command Button control to the form and set the following Properties: 
WhatsThisHelpID = 1
HelpContextID = 5
  i.. Add following code to the Command1_MouseUp event: 
Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) If Button = vbRightButton Then
    Set ThisControl = Command1
    PopupMenu mnuWhatsThis
End If
Set ThisControl = Nothing
End Sub
  j.. Run the application. Right-click on the Command button and then left- Click on the "What's This?" popup to bring up the Help file.
Source: Microsoft Knowledge Base

Tip by James Limm



c0Title: How to make a form transparent
c1Code:
1. Code for a module


Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_TRANSPARENT = &H20&
Public Const SWP_FRAMECHANGED = &H20
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_SHOWME = SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_NOTOPMOST = -2 

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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


2. Add a commandbutton with following code to Form1


Private Sub Command1_Click()
	SetWindowLong Me.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
	SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0&, 0&, 0&, 0&, SWP_SHOWME
End Sub


3. The ShowInTaskbar property should be set to False and the BorderStyle to 0-None.



P.S.: BitBlt could also be used, but I think this code is better!

Tip by Wolfgang



c0Title: How To Make A Graphic Transparent
c1Code:
Ever want to make a graphic transparent in Visual Basic? Well it is kinda complicated, but the code below will do the trick. There is a lot of code there but it is very fast.

Declare

' Win32 API Declarations, Structures, and Constants
Private 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
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
 
' Constants used by new transparent support in NT.
Private Const CAPS1 = 94 ' other caps
Private Const C1_TRANSPARENT = &H1 ' new raster cap
Private Const NEWTRANSPARENT = 3 ' use with SetBkMode()
 
' Ternary raster operations
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Code

Public Sub TransBlt(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 TransColor As Long)
'
' 32-Bit Transparent BitBlt Function
' Written by Karl E. Peterson, 9/20/96.
' Portions borrowed and modified from KB.
' Other portions modified following input from users. <g>
'
' Parameters ************************************************************
' hDestDC: Destination device context
' x, y: Upper-left destination coordinates (pixels)
' nWidth: Width of destination
' nHeight: Height of destination
' hSrcDC: Source device context
' xSrc, ySrc: Upper-left source coordinates (pixels)
' TransColor: RGB value for transparent pixels, typically &HC0C0C0.
' ***********************************************************************
'
Dim OrigColor As Long ' Holds original background color
Dim OrigMode As Long ' Holds original background drawing mode
 
If (GetDeviceCaps(hDestDC, CAPS1) And C1_TRANSPARENT) Then
'
' Some NT machines support this *super* simple method!
' Save original settings, Blt, restore settings.
'
OrigMode = SetBkMode(hDestDC, NEWTRANSPARENT)
OrigColor = SetBkColor(hDestDC, TransColor)
Call BitBlt(hDestDC, x, y, nWidth, nHeight, hSrcDC, xSrc, ySrc, SRCCOPY)
Call SetBkColor(hDestDC, OrigColor)
Call SetBkMode(hDestDC, OrigMode)
 
Else
Dim saveDC As Long ' Backup copy of source bitmap
Dim maskDC As Long ' Mask bitmap (monochrome)
Dim invDC As Long ' Inverse of mask bitmap (monochrome)
Dim resultDC As Long ' Combination of source bitmap & background
Dim hSaveBmp As Long ' Bitmap stores backup copy of source bitmap
Dim hMaskBmp As Long ' Bitmap stores mask (monochrome)
Dim hInvBmp As Long ' Bitmap holds inverse of mask (monochrome)
Dim hResultBmp As Long ' Bitmap combination of source & background
Dim hSavePrevBmp As Long ' Holds previous bitmap in saved DC
Dim hMaskPrevBmp As Long ' Holds previous bitmap in the mask DC
Dim hInvPrevBmp As Long ' Holds previous bitmap in inverted mask DC
Dim hDestPrevBmp As Long ' Holds previous bitmap in destination DC
'
' Create DCs to hold various stages of transformation.
'
saveDC = CreateCompatibleDC(hDestDC)
maskDC = CreateCompatibleDC(hDestDC)
invDC = CreateCompatibleDC(hDestDC)
resultDC = CreateCompatibleDC(hDestDC)
'
' Create monochrome bitmaps for the mask-related bitmaps.
'
hMaskBmp = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)
hInvBmp = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)
'
' Create color bitmaps for final result & stored copy of source.
'
hResultBmp = CreateCompatibleBitmap(hDestDC, nWidth, nHeight)
hSaveBmp = CreateCompatibleBitmap(hDestDC, nWidth, nHeight)
'
' Select bitmaps into DCs.
'
hSavePrevBmp = SelectObject(saveDC, hSaveBmp)
hMaskPrevBmp = SelectObject(maskDC, hMaskBmp)
hInvPrevBmp = SelectObject(invDC, hInvBmp)
hDestPrevBmp = SelectObject(resultDC, hResultBmp)
'
' Create mask: set background color of source to transparent color.
'
OrigColor = SetBkColor(hSrcDC, TransColor)
Call BitBlt(maskDC, 0, 0, nWidth, nHeight, hSrcDC, xSrc, ySrc, vbSrcCopy)
TransColor = SetBkColor(hSrcDC, OrigColor)
'
' Create inverse of mask to AND w/ source & combine w/ background.
'
Call BitBlt(invDC, 0, 0, nWidth, nHeight, maskDC, 0, 0, vbNotSrcCopy)
'
' Copy background bitmap to result.
'
Call BitBlt(resultDC, 0, 0, nWidth, nHeight, hDestDC, x, y, vbSrcCopy)
'
' AND mask bitmap w/ result DC to punch hole in the background by
' painting black area for non-transparent portion of source bitmap.
'
Call BitBlt(resultDC, 0, 0, nWidth, nHeight, maskDC, 0, 0, vbSrcAnd)
'
' get overlapper
'
Call BitBlt(saveDC, 0, 0, nWidth, nHeight, hSrcDC, xSrc, ySrc, vbSrcCopy)
'
' AND with inverse monochrome mask
'
Call BitBlt(saveDC, 0, 0, nWidth, nHeight, invDC, 0, 0, vbSrcAnd)
'
' XOR these two
'
Call BitBlt(resultDC, 0, 0, nWidth, nHeight, saveDC, 0, 0, vbSrcInvert)
'
' Display transparent bitmap on background.
'
Call BitBlt(hDestDC, x, y, nWidth, nHeight, resultDC, 0, 0, vbSrcCopy)
'
' Select original objects back.
'
Call SelectObject(saveDC, hSavePrevBmp)
Call SelectObject(resultDC, hDestPrevBmp)
Call SelectObject(maskDC, hMaskPrevBmp)
Call SelectObject(invDC, hInvPrevBmp)
'
' Deallocate system resources.
'
Call DeleteObject(hSaveBmp)
Call DeleteObject(hMaskBmp)
Call DeleteObject(hInvBmp)
Call DeleteObject(hResultBmp)
Call DeleteDC(saveDC)
Call DeleteDC(invDC)
Call DeleteDC(maskDC)
Call DeleteDC(resultDC)
End If
End Sub
Usage

Private Sub Form_Load()
With Me
.ScaleMode = vbPixels
End With
With Picture1
.ScaleMode = vbPixels
.AutoRedraw = True
End With
End Sub
 
Private Sub Form_Paint()
     Call TransBlt(Me.hdc, 0, 0, 32, 32, Picture1.hdc, 0, 0, vbBlack)
End Sub
Tips Submitted By: Karl E. Peterson


c0Title: How to make the title bar flash
c1Code:
Create a new .exe project, add a module to it with the following code:

Public Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long


Put a timer and 2 commandbuttons on form1 with these properties:


command1.caption="Start"
command2.caption="Stop"
timer1.interval=500 'flashes every 1/2 second timer1.enabled=false


Code


Private Sub Timer1_Timer()
	a& = FlashWindow(Me.hwnd, 1)
End Sub

Private Sub Command1_Click()
	Timer1.Enabled = True
End Sub

Private Sub Command2_Click()
	Timer1.Enabled = False
End Sub


Execute the app. (F5) and click the buttons.

Tip by Gijs de Jong



c0Title: How to map OK button in VB to Enter Key and CANCEL button to ESC key?
c1Code:
In the properties for the OK button set "Default" to True. For the Cancel button, set the "Cancel" property true.


c0Title: How to move a form without a title bar
c1Code:
This tip demonstrates how you can allow a form to be moved using the mouse without using the title bar. In this example, you can click anywhere on the form and drag it as if you are using the title bar. This code can be useful in conjunction with programs that hide the title bar, i.e. clocks.

Declarations

Add the following code to the declarations section of a form

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 Declare Sub ReleaseCapture Lib "User32" () Const WM_NCLBUTTONDOWN = &HA1 Const HTCAPTION = 2 Add this code to the form's MouseMove procedure:

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
	Dim lngReturnValue As Long 

	If Button = 1 Then 
		Call ReleaseCapture 
		lngReturnValue = SendMessage(Form1.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&) 
	End If 
End Sub 

Tip by John Percival



c0Title: How to move the mousepointer to the control with focus
c1Code:
With some mouse utilities you can set that the mousepointer automaticlly moves to the control which has the focus, this tip shows how you can do the same in VB.
Create a .exe project with a module and add the following code to it:

Declare Function SetCursorPos Lib "user32" (ByVal x _ As Long, ByVal y As Long) As Long On Form1 put a few controls (textbox1,commandbutton1,combo1,list1 etc.) First add the following code to form1

Private Sub focus()
	If Me.BorderStyle = 0 Then
	   x& = Me.ActiveControl.Left  Screen.TwipsPerPixelX _
	   + ((Me.ActiveControl.Width / 2) / Screen.TwipsPerPixelX) _
	   + (Me.Left / Screen.TwipsPerPixelX)
	   y& = Me.ActiveControl.Top  Screen.TwipsPerPixelY _
	   + ((Me.ActiveControl.Height / 2) / Screen.TwipsPerPixelY) _
	   + (Me.Top / Screen.TwipsPerPixelY)
	Else
	   x& = Me.ActiveControl.Left  Screen.TwipsPerPixelX _
	   + ((Me.ActiveControl.Width / 2 + 60) / _
	   Screen.TwipsPerPixelX) + (Me.Left / _
	   Screen.TwipsPerPixelX)
	   '"+ 60" is for the border"
	   y& = Me.ActiveControl.Top  Screen.TwipsPerPixelY _
	   + ((Me.ActiveControl.Height / 2 + 360) / _
	   Screen.TwipsPerPixelY) + (Me.Top / _
	   Screen.TwipsPerPixelY)
	   '"+ 360 " is for the border and the tittle bar"
End If

a& = SetCursorPos(x&, y&)

End Sub

Then put " Call focus " in the gotfocus event of every control.
Execute the app. (F5) and Tab through the controls, you`ll see that the mousepointer moves it`s position to the control with focus

Tip by Gijs de Jong



c0Title: How To Obtain A Description Of A Win32 API Error
c2File: win32_api_errors.htm
c1Code:
If a description of a Visual Basic run-time error can be obtained with the Err object's Description property (or with the Error function), why couldn't a description of a Win32 API error be obtained? Well it can of course, but it's necessary to first understand a few details about Win32 API errors...

All versions of Windows maintain a system-defined string-table resource which contains descriptions of errors identified by respective error codes. A string description can be retrieved for a given error code with a call to the FormatMessage() API function specifying the FORMAT_MESSAGE_FROM_SYSTEM value in it's dwFlags parameter.

What is an error code?

An error code is a system-defined value which a Win32 API function sets in a calling thread after the function returns. This is similar to a DOS program's ERRORLEVEL return value. 
The error code can indicate success OR failure. 
Most Win32 API functions set error codes and will be noted as such in their documentation. This will include a reference to retrieving extended error information via the return value of a subsequent GetLastError() API call. 
A Visual Basic application (thread) has only one current error code. Calls to API functions will continually update the current error code. 
Visual Basic's Err.LastDLLError property maintains a Visual Basic application's current API error code. To obtain the error code set by an API function which has returned a value indicating an error, it is necessary to immediately retrieve the error code with the Err.LastDLLError property before the error code is updated.

If the GetLastError() API function is called to retrieve the error code, it will most likely return an inaccurate value. This is because Visual Basic will call it's own various internal API functions to execute API functions called from a Visual Basic application. When these internal function calls return, they can update the application's current error code.

What follows is a demonstration of how to use FormatMessage() to retrieve string descriptions for a given error code:

Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _

(ByVal dwFlags As Long, lpSource As Any, _

ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _

ByVal lpBuffer As String, ByVal nSize As Long, _

Arguments As Long) As Long

 

Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

Public Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200

Public Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF

Public Const LANG_USER_DEFAULT = &H400&

 

Function GetAPIErrorStr(errcode&) As String

' Rtns system error string associated w/ a given error code.

 

Dim msgbuf$, leng&

 

' 256 chars is the maximum length for

'a resource string (+ 1 for the null char)

msgbuf$ = String$(257, 0)

 

' Fills msgbuf$ w/ the system error string & rtns it's length.

' FORMAT_MESSAGE_IGNORE_INSERTS *must* be used as there are many

' error strings that contain inserts (replaceable parameters).

' There are also a few random length multi-line error strings,

' FORMAT_MESSAGE_MAX_WIDTH_MASK rtns them as one line...

leng& = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM _

Or FORMAT_MESSAGE_IGNORE_INSERTS _

Or FORMAT_MESSAGE_MAX_WIDTH_MASK, ByVal 0&, _

errcode&, LANG_USER_DEFAULT, _

ByVal msgbuf$, 256&, 0&)

 

If leng& Then

'lose the vbNullChars & any trailing spcs

GetAPIErrorStr = Trim$(Left$(msgbuf$, leng&))

Else

GetAPIErrorStr = "Unknown error."

End If

 

End Function

As an example we'll call the GetShortPathName() API function to get the 8.3 format of a file's explicit path and specify an invalid value for the lpszLongPath parameter. GetShortPathName() will return 0, indicating that there was an error. An inline error handler is used to return the description of the error:

' Note that this function is incorrectly declared w/ the 

' "GetShortPathName" alias in VB's Win32api.txt...

Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _

(ByVal lpszLongPath As String, ByVal lpszShortPath As String, _

ByVal cchBuffer As Long) As Long

 

Sub TestGetAPIErrorStr()

Dim length&, buffer$

buffer$ = String$(261, 0)

' sets error code #3

length& = GetShortPathName("a bogus explicit path", buffer$, 260)

If length& Then

' probably won't ever get here...

MsgBox "Short path: " & Left$(buffer$, length&), vbInformation

ElseIf Err.LastDllError then

' displays: "The system cannot find the path specified."

MsgBox "Error. " & GetAPIErrorStr(Err.LastDllError), vbExclamation

EndIf

End Sub

Tip submitted by Brad Martinez

Sample code for this tips can be found in the \VB-4 Sample Code\win32err directory.


c0Title: How to put your running code to sleep for some time ?
c1Code:
Use Sleep function 

Public Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

Call Sleep(2000)    '2 second sleep


c0Title: How to remove a Line from a File
c1Code:
Public Function RemoveLineFromFile(ByVal sFile As String, sText As String) As Integer

Dim sBuffer As String
Dim sTemp As String
On Local Error Resume Next

If GetFileExists(sFile) Then

	'read in file
	Open sFile For Input As #1

	Do
	    Line Input #1, sTemp
	    If InStr(sTemp, sText) = 0 Then sBuffer = sBuffer & sTemp & Chr$(13) & Chr$(10) 
	Loop While Not EOF(1) 

	Close

	'write file
	Open sFile For Output As #1
	Print #1, sBuffer
	Close

	If Err = 0 Then 
		RemoveLineFromFile = True 
	End If 
End Function


c0Title: How To Save Window Positions
c1Code:
This code enables you to save and reload the window positions of any form in your VB application. Place the calls to LoadWindowPosition and SaveWindowPosition in the Load/Unload event of the form you wish to save.

Public Sub LoadWindowPosition(frmSave As Form)

'LoadWindowPosition / SaveWindowPosition
'------------------------------------------------------
'Optional Tags - "W" = Ingore saved settings completly
' "E" = Don't load Window Position but
' do save it.
 
	Dim WindowLeft As Integer, WindowTop As Integer
	Dim WindowWidth As Integer, WindowHeight As Integer
	Dim Keyname As String
 
	If frmSave.Tag = "W" Or frmSave.Tag = "E" Then Exit Sub
 
	Keyname = frmSave.Caption
 
	WindowLeft = Val(GetSetting(pAppName, "Window Metrics", Keyname & " Left"))
	WindowTop = Val(GetSetting(pAppName, "Window Metrics", Keyname & " Top"))
	WindowWidth = Val(GetSetting(pAppName, "Window Metrics", Keyname & " Width"))
	WindowHeight = Val(GetSetting(pAppName, "Window Metrics", Keyname & "Height"))
 
	If WindowWidth = 0 Or WindowHeight = 0 Then Exit Sub
 
	frmSave.Left = WindowLeft
	frmSave.Top = WindowTop
	frmSave.Width = WindowWidth
	frmSave.Height = WindowHeight
End Sub
 
Public Sub SaveWindowPosition(frmSave As Form)
	Dim Keyname As String
 
	If frmSave.WindowState = 1 Or frmSave.Tag = "W" Then Exit Sub
 
	Keyname = frmSave.Caption
 
	SaveSetting pAppName, "Window Metrics", Keyname & " Left", frmSave.Left
	SaveSetting pAppName, "Window Metrics", Keyname & " Top", frmSave.Top
	SaveSetting pAppName, "Window Metrics", Keyname & " Width", frmSave.Width
	SaveSetting pAppName, "Window Metrics", Keyname & " Height", frmSave.Height
End Sub


c0Title: How to search a list box by typing text into a control
c1Code:
The second most popular questions that I received during the past week is how to search a list box by typing text into a control such as a textbox or combobox. This is very simple to do and uses the SendMessage API. This works with VB 4, 5 and 6

Here is the example:

  a.. Start a new Standard-EXE project. 
  b.. Add a command button, textbox and a listbox control to form 1
  c.. Add the following code to form1: 
Option Explicit

Private Declare Function SendMessage Lib _ "User32" Alias "SendMessageA" (ByVal hWnd _ As Long, ByVal wMsg As Integer, ByVal _ wParam As Integer, lParam As Any) As Long Const LB_FINDSTRING = &H18F

Private Sub Command1_Click()
End
End Sub

Private Sub Form_Load()
With List1
  .Clear
  .AddItem "CPU"
  .AddItem "RAM"
  .AddItem "ROM"
  .AddItem "Cache"
  .AddItem "Motherboard"
  .AddItem "Hard Disk"
  .AddItem "Floppy Disk"
End With
End Sub

Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hWnd, _ LB_FINDSTRING, -1, ByVal Text1.Text) Text1.Text = List1.Text End Sub
  a.. Run the project (F5) and type some text into the text box, and if it matches the text in the listbox then the text will be displayed in the text box. You can do this will any control such as a combo box that allows you to enter text into it and has a text property. 
Tip by John Percival



c0Title: How to Set Margins When Printing with RichTextBox Control's SelPrint Method
c1Code:
If you've used the SelPrint method to print the contents of a RichTextBox control, you may have noticed that the output features a generous one-inch margin on all sides of the page. The RichTextBox control offers no way to change that margin, but fortunately the Win32 API does: you can use the SendMessage API to send EM_SETTARGETDEVICE and EM_FORMATRANGE messages to the control. For details, see the following article in the Microsoft Knowledge Base: Q146022 -- How to Set Up the RichTextBox Control for WYSIWYG Printing
 
Microsoft Knowledge Base Article - 146022 
  
HOWTO: Set Up the RichTextBox Control for WYSIWYG Printing
The information in this article applies to: 
Microsoft Visual Basic Learning Edition for Windows 5.0 
Microsoft Visual Basic Learning Edition for Windows 6.0 
Microsoft Visual Basic Professional Edition for Windows 5.0 
Microsoft Visual Basic Professional Edition for Windows 6.0 
Microsoft Visual Basic Enterprise Edition for Windows 5.0 
Microsoft Visual Basic Enterprise Edition for Windows 6.0 
Microsoft Visual Basic Professional Edition, 32-bit, for Windows 4.0 
Microsoft Visual Basic Enterprise Edition, 32-bit, for Windows 4.0
This article was previously published under Q146022 
SUMMARY
The SelPrint method of the RichTextBox control does not allow a programmer to set the position of the output on the printer. In addition, the RichTextBox control does not provide a method for displaying its contents as they would show up on the printer. This article explains how to set up a RichTextBox with a WYSIWYG (What You See Is What You Get) display and then how to print it. 
MORE INFORMATION
The Visual Basic RichTextBox control is a sub-classed control based on the RichTextBox provided by the Win32 operating system. The operating system control supports many messages that are not exposed in Visual Basic. One of these messages is EM_SETTARGETDEVICE. The EM_SETTARGETDEVICE message is used to tell a RichTextBox to base its display on a target device such as a printer. Another message that is not fully exposed by Visual Basic is EM_FORMATRANGE. The EM_FORMATRANGE message sends a page at a time to an output device using the specified coordinates. Using these messages in Visual Basic, it is possible to make a RichTextBox support WYSIWYG display and output. 

The following example illustrates how to take advantage of the EM_SETTARGETDEVICE and EM_FORMATRANGE messages from Visual Basic. The example provides two re-usable procedures to send these messages. The first procedure WYSIWYG_RTF() sets a RichTextBox to provide a WYSIWYG display based on the default printer and specified margins. The second procedure PrintRtf() prints the contents of the RichTextBox with the specified margins. 
EXAMPLE
Start a new project in the Visual Basic 32-bit edition. Form1 is created by default. 
Put a CommandButton and a RichTextBox control on Form1. 
Add the following code to Form1:
Private Const AnInch As Long = 1440   '1440 twips per inch
Private Const QuarterInch As Long = 360

Private Sub Form_Load()
   Dim PrintableWidth As Long
   Dim PrintableHeight As Long
   Dim x As Single

   ' Initialize Form and Command button
   Me.Caption = "Rich Text Box WYSIWYG Printing Example"
   Command1.Move 10, 10, 600, 380
   Command1.Caption = "&Print"

   ' Set the font of the RTF to a TrueType font for best results
   RichTextBox1.SelFontName = "Arial"
   RichTextBox1.SelFontSize = 10
   
   'initialize the printer object
   x = Printer.TwipsPerPixelX
   Printer.Orientation = vbPRORPortrait  'vbPRORLandscape

   ' Tell the RTF to base it's display off of the printer
   Call WYSIWYG_RTF(RichTextBox1, QuarterInch, QuarterInch, QuarterInch, QuarterInch, PrintableWidth, PrintableHeight) '1440 Twips=1 Inch

   ' Set the form width to match the line width
   Me.Width = PrintableWidth + 200
   Me.Height = PrintableHeight + 800
End Sub

Private Sub Form_Resize()
   ' Position the RTF on form
   RichTextBox1.Move 100, 500, Me.ScaleWidth - 200, Me.ScaleHeight - 600
End Sub

Private Sub Command1_Click()
   ' Print the contents of the RichTextBox with a one inch margin
   PrintRTF RichTextBox1, AnInch, AnInch, AnInch, AnInch
End Sub

					
Insert a new standard module into the project, Module1.bas is created by default. 
Add the following code to Module1:
Option Explicit

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

Private Type CharRange
  cpMin As Long     ' First character of range (0 for start of doc)
  cpMax As Long     ' Last character of range (-1 for end of doc)
End Type

Private Type FormatRange
  hdc As Long       ' Actual DC to draw on
  hdcTarget As Long ' Target DC for determining text formatting
  rc As Rect        ' Region of the DC to draw to (in twips)
  rcPage As Rect    ' Region of the entire DC (page size) (in twips)
  chrg As CharRange ' Range of text to draw (see above declaration)
End Type

Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113

Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
   (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, _
   lp As Any) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" _
   (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As Long, ByVal lpInitData As Long) As Long

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' WYSIWYG_RTF - Sets an RTF control to display itself the same as it
'               would print on the default printer
'
' RTF - A RichTextBox control to set for WYSIWYG display.
'
' LeftMarginWidth - Width of desired left margin in twips
'
' RightMarginWidth - Width of desired right margin in twips
'
' Returns - The length of a line on the printer in twips
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub WYSIWYG_RTF(RTF As RichTextBox, LeftMarginWidth As Long, RightMarginWidth As Long, TopMarginWidth As Long, BottomMarginWidth As Long, PrintableWidth As Long, PrintableHeight As Long)
   Dim LeftOffset As Long
   Dim LeftMargin As Long
   Dim RightMargin As Long
   Dim TopOffset As Long
   Dim TopMargin As Long
   Dim BottomMargin As Long
   Dim PrinterhDC As Long
   Dim r As Long

   ' Start a print job to initialize printer object
   Printer.Print Space(1)
   Printer.ScaleMode = vbTwips
   
   ' Get the left offset to the printable area on the page in twips
   LeftOffset = GetDeviceCaps(Printer.hdc, PHYSICALOFFSETX)
   LeftOffset = Printer.ScaleX(LeftOffset, vbPixels, vbTwips)
   
   ' Calculate the Left, and Right margins
   LeftMargin = LeftMarginWidth - LeftOffset
   RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
   
   ' Calculate the line width
   PrintableWidth = RightMargin - LeftMargin
   
   ' Get the top offset to the printable area on the page in twips
   TopOffset = GetDeviceCaps(Printer.hdc, PHYSICALOFFSETY)
   TopOffset = Printer.ScaleX(TopOffset, vbPixels, vbTwips)
   
   ' Calculate the Left, and Right margins
   TopMargin = TopMarginWidth - TopOffset
   BottomMargin = (Printer.Height - BottomMarginWidth) - TopOffset
   
   ' Calculate the line width
   PrintableHeight = BottomMargin - TopMargin
    
   
   ' Create an hDC on the Printer pointed to by the Printer object
   ' This DC needs to remain for the RTF to keep up the WYSIWYG display
   PrinterhDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)

   ' Tell the RTF to base it's display off of the printer
   '    at the desired line width
   r = SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, _
      ByVal PrintableWidth)

   ' Abort the temporary print job used to get printer info
   Printer.KillDoc
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' PrintRTF - Prints the contents of a RichTextBox control using the
'            provided margins
'
' RTF - A RichTextBox control to print
'
' LeftMarginWidth - Width of desired left margin in twips
'
' TopMarginHeight - Height of desired top margin in twips
'
' RightMarginWidth - Width of desired right margin in twips
'
' BottomMarginHeight - Height of desired bottom margin in twips
'
' Notes - If you are also using WYSIWYG_RTF() on the provided RTF
'         parameter you should specify the same LeftMarginWidth and
'         RightMarginWidth that you used to call WYSIWYG_RTF()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, _
   TopMarginHeight, RightMarginWidth, BottomMarginHeight)
   Dim LeftOffset As Long, TopOffset As Long
   Dim LeftMargin As Long, TopMargin As Long
   Dim RightMargin As Long, BottomMargin As Long
   Dim fr As FormatRange
   Dim rcDrawTo As Rect
   Dim rcPage As Rect
   Dim TextLength As Long
   Dim NextCharPosition As Long
   Dim r As Long

   ' Start a print job to get a valid Printer.hDC
   Printer.Print Space(1)
   Printer.ScaleMode = vbTwips

   ' Get the offsett to the printable area on the page in twips
   LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
      PHYSICALOFFSETX), vbPixels, vbTwips)
   TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
      PHYSICALOFFSETY), vbPixels, vbTwips)

   ' Calculate the Left, Top, Right, and Bottom margins
   LeftMargin = LeftMarginWidth - LeftOffset
   TopMargin = TopMarginHeight - TopOffset
   RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
   BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset

   ' Set printable area rect
   rcPage.Left = 0
   rcPage.Top = 0
   rcPage.Right = Printer.ScaleWidth
   rcPage.Bottom = Printer.ScaleHeight

   ' Set rect in which to print (relative to printable area)
   rcDrawTo.Left = LeftMargin
   rcDrawTo.Top = TopMargin
   rcDrawTo.Right = RightMargin
   rcDrawTo.Bottom = BottomMargin

   ' Set up the print instructions
   fr.hdc = Printer.hdc   ' Use the same DC for measuring and rendering
   fr.hdcTarget = Printer.hdc  ' Point at printer hDC
   fr.rc = rcDrawTo            ' Indicate the area on page to draw to
   fr.rcPage = rcPage          ' Indicate entire size of page
   fr.chrg.cpMin = 0           ' Indicate start of text through
   fr.chrg.cpMax = -1          ' end of the text

   ' Get length of text in RTF
   TextLength = Len(RTF.Text)

   ' Loop printing each page until done
   Do
      ' Print the page by sending EM_FORMATRANGE message
      NextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, fr)
      If NextCharPosition >= TextLength Then Exit Do  'If done then exit
      fr.chrg.cpMin = NextCharPosition ' Starting position for next page
      Printer.NewPage                  ' Move on to next page
      Printer.Print Space(1) ' Re-initialize hDC
      fr.hdc = Printer.hdc
      fr.hdcTarget = Printer.hdc
   Loop

   ' Commit the print job
   Printer.EndDoc

   ' Allow the RTF to free up memory
   r = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))
End Sub

					
Save the project. 
Run the project. 
Enter or paste some text into the RichTextBox. 
Press the Print command button. Note that the printed output should word-wrap at the same locations as displayed on the screen. Also, the output should be printed with the specified one-inch margin all around. 


c0Title: How to show and hide a combo box dropdown list
c1Code:
This code shows how to programmatically drop and retract a combo box list portion.

Declarations

Add the following code to the declarations section of a basic module.

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

Public Const CB_SHOWDROPDOWN = &H14F
Form Code

Add 2 command buttons and a combo box to a form.  Add the following code to the form.

Sub Form_Load()
Combo1.AddItem "Item 1"
Combo1.AddItem "Item 2"
Combo1.AddItem "Item 3"
End Sub
Private Sub Command1_Click()
'label this button Show List
Dim r as Long
r = SendMessageLong(Combo1.hWnd, CB_SHOWDROPDOWN, True, 0) End Sub Private Sub Command2_Click() 'label this button Hide List Dim r as Long r = SendMessageLong(Combo1.hWnd, CB_SHOWDROPDOWN, False, 0) End Sub Comments

Run the project, and click command1 to show the combo box list, or command2 to hide it.

This routine only applies to combo boxes whose style is 0 - Dropdown Combo, or 2 - Dropdown List.

Tip by VBNet



c0Title: How to trap the mouse to a form
c1Code:
This tip demonstrates how to use the clip cursor API function to prevent the mouse pointer from being moved outside of a form.

Editor Note: If the BorderStyle of the form is sizable (either 2 or 5) the user can escape from the form by resizing it ! This can be avoided by setting BorberStyle=0, 1, 3 or 4

Module Code

1) Add the following code to a module.

Option Explicit
Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Declare Function ClipCursor Lib "user32" _ (lpRect As Any) As Long

Public Sub DisableTrap(CurForm As Form)
Dim erg As Long
'Declare a variable for the procedure
'to set the new coordinates
Dim NewRect As RECT
CurForm.Caption = "Mouse released"
'Set the new coordinates to full screen
With NewRect
  .Left = 0&
  .Top = 0&
  .Right = Screen.Width / Screen.TwipsPerPixelX
  .Bottom = Screen.Height / Screen.TwipsPerPixelY End With

erg& = ClipCursor(NewRect)
End Sub

Public Sub EnableTrap(CurForm As Form)
Dim x As Long, y As Long, erg As Long
'Declare a variable for the procedure
'to set the new coordinates
Dim NewRect As RECT
'Get the TwipsperPixel
'The Form's ScaleMode must be set to Twips!!!
x& = Screen.TwipsPerPixelX
y& = Screen.TwipsPerPixelY
CurForm.Caption = "Mouse trapped"
'Set the Cursor-Region to the coordinates 'of the form With NewRect
  .Left = CurForm.Left / x&
  .Top = CurForm.Top / y&
  .Right = .Left + CurForm.Width / x&
  .Bottom = .Top + CurForm.Height / y&
End With
erg& = ClipCursor(NewRect)
End Sub
Form Code

2. Two command buttons to Form1

3. Add the Following code to Form1

Private Sub Command1_Click()
EnableTrap Form1
End Sub

Private Sub Command2_Click()
DisableTrap Form1
End Sub

Private Sub Form_Unload(Cancel As Integer) 'App is closed -> release the mouse!!
DisableTrap Form1
End Sub
Tip by Wolfgang



c0Title: How To Use A TextBox For Currency Input
c1Code:
To use the standard text box as a masked edit box for currency input, set the following properties at design time.

text1.Alignment = 1 'right alignment
text1.Multiline=true 'required for right alignment
text1.Height=315 'minimum setting for MS Sans Serif 8.25
text1.Text = "0.00"


Sub Text1_Keypress(KeyAscii as Integer)

	'Allow only numeric 0 through 9 plus backspace
	if (KeyAscii < 48 or KeyAscii > 57) and KeyAscii <> 8 then
		KeyAscii=0
	end if
End Sub



Sub Text1_Change()
	Dim CursorPosition as integer
	Static AlreadyHere as integer

	If AlreadyHere Then
		Exit Sub
	Else
		AlreadyHere = True
	End If

	CursorPosition = text1.SelStart

	'this next statement will cause the change event to call itself
	'but the AlreadyHere flag will prevent a cascade.
	text1 = Format$(text1, "###,###.00")
	text1.SelStart = CursorPosition

	AlreadyHere = False

End Sub

Tip By: Chuck Stuart




c0Title: How you can create a Tool tip programmatically ?
c1Code:
Creating the cool Tips ( Or get the formual used to calculate the field in jiffy )
Create a hidden label ,  put the following code into the mouse double click, may be

Label1.Caption = Field1.Tag
Label1.Top = Field1.Top + Field1.Height
Label1.Left = Field1.Left + Field1.Width / 2
Label1.Visible = TRUE

Set the Tag property of the control to the text you want to display as the tag tip: 

Field1.TAG = "This is the formula I used to calculate this field x2 = (y * z)/100"

Add this to the MouseMove event of the form. It turns off the tag tip when you move your mouse off the control: 

Label1.Visible = FALSE


c0Title: HTMLHelp API - VBA, VB6 and VB2003
c1Code:
http://www.help-info.de/en/Help_Info_HTMLHelp/hh_api.htm
HTMLHelp API - Declaration 
HTMLHelp API - HH_CLOSE_ALL Note 
HTMLHelp API - Search from Application 
HTMLHelp API - Visual Basic for Applications 
HTMLHelp API - Visual Basic 6 
HTMLHelp API - Visual Basic 2003 (.net) 
 



HTMLHelp API - Deklaration
The HtmlHelp() API function is declared as follows: 

Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, ByVal dwData As Long) As Long

hwndCaller
The hwndCaller member is defined as a handle to an application window or Null. If a window handle is specified, the HTML Help window will be forced to be on-top of the calling window. If a 0 (zero) is specified, this condition will not occur.

When a handle, the corresponding window owns the html help window and receives any messages sent by htmlhelp back to the owner. By setting this to null (0& in VB parlance), one can effectively telling it that the desktop is the owner, thus allowing the window to fall behind the application.

pszFile
File to display; optionally also specifies which window type to display it in, delimited with the right angle bracket character (filename>windowtype). If you omit the window type, the HtmlHelp function will use the default window type specified in the HTML Help project file. For uCommand values that don't require a source file, pszFile can be Null, or 0 (zero), in VBA. However, a compiled HTML Help file is typically specified.

uCommand
The action to perform; see the remainder of this section for examples of how to display a Help topic by using either the HH_HELP_CONTEXT or HH_DISPLAY_TOPIC command. 
HH_DISPLAY_TOPIC
Displays a Help topic by passing the URL of the HTML file that contains the topic as the dwData argument. 
HH_HELP_CONTEXT
Displays a Help topic by passing the mapped context ID for the topic as the dwData argument.

dwData
Specifies additional data depending on the value of uCommand. Note that in this declaration this argument is declared As Any, because this argument accepts several different data types. You must be careful to pass the correct data type or risk an invalid page fault (also known as general protection fault [GPF]).

Return Values 

If the function succeeds, the return value is the handle of the HTML help window.

 



HTMLHelp API - HH_CLOSE ALL Note
If you call the HH API directly from your application, and not via a second helper program like HH.EXE or KEYHH.EXE, then you MUST close any open help windows before shutting down the application or you will probably crash Windows.

The call to close all windows is simply. Because of a bug in the HH API make sure you call this in your main form's Query_Unload event not OnClose.
For more info see:
http://helpware.net/FAR/far_faq.htm#HH_CLOSE_ALL

Private Sub Query_Unload(Cancel As Integer)
   Call HtmlHelp(Me.hWnd, "", HH_CLOSE_ALL, 0)
End Sub. 

EXCEL VBA Workaround:
See also: Download EXCEL Example

Trying to get around Excel crashing with a GPF General Protection Fault (Microsoft Windows program crash/error) when I tried to close the help file using HTMLHelp 0&, "", HH_CLOSE_ALL, 0&. The Microsoft knowledge base and other solutions on the Net suggested changes to the registry, which is not practical as would have to go to each user's PC to implement that. So had to use the tried and tested method of problem solving: Used random changes to see what works. The method that works, is to not leave the pszFile parm blank as the API says in the close_all call, but to give the CHM file name there. 

So this seems to work if only one help window is open:

Call HtmlHelp(0, ThisWorkbook.Path & "\CHM-example.chm", HH_CLOSE_ALL, 0)
 



Search From Application
Download Example C++ Code 
Download Example VB6 Code 
HH Workshop API documents how to move to the search tab and initiate a search. Unfortunately the initiating a search part has always been broken in HH. The only way around this would be to find the HH window and search pane controls. Then control those controls from your application using via low level Windows API calls.

Dmitry Karpezo, <dkarpezo AT lycosmail.com> posted a small code example on MSHelp2 Yahoo group.

The Visual Basic form this site includes a Visual Basic 6 translation and GUI example. See modul below:

Attribute VB_Name = "modHelpSearch"
'******************************************************************************
'----- Modul HH API for Visual Basic 6 - (c) Ulrich Kulle
'----- 2006-08-28 Version 1.0 first release for performing a search from application
'******************************************************************************
'----- Thanks to Dimitry Karpezo for the C++ version of this code
'------------------------------------------------------------------------------

Private Declare Function HtmlHelpSearch Lib "hhctrl.ocx" Alias "HtmlHelpA" _
                (ByVal hwndCaller As Long, ByVal pszFile As String, _
                ByVal uCommand As Long, dwData As HH_FTS_QUERY) 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 Any) As Long
                
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
                (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, _
                ByVal lpClassName As String, ByVal lpWindowName As String) As Long
                
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
                (ByVal hwnd As Long, ByVal lpClassName As String, _
                ByVal nMaxCount As Long) As Long
        
Public Declare Function GetDlgItem Lib "user32" _
                (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
                
' API const
'------------------------------------------------------------------------------
Public Const WM_COMMAND As Long = &H111     ' WM_COMMAND = 0x0111
Public Const WM_SETTEXT As Long = &HC       ' WM_SETTEXT = 0x000C

                
' HH API const
'------------------------------------------------------------------------------
Public Const HH_DISPLAY_TOPIC = &H0         ' select last opened tab, [display a specified topic]
Public Const HH_DISPLAY_TOC = &H1           ' select contents tab, [display a specified topic]
Public Const HH_DISPLAY_INDEX = &H2         ' select index tab and searches for a keyword
Public Const HH_DISPLAY_SEARCH = &H3        ' select search tab (perform a search is fixed here)
      
Private Const HH_SET_WIN_TYPE = &H4
Private Const HH_GET_WIN_TYPE = &H5
Private Const HH_GET_WIN_HANDLE = &H6
Private Const HH_DISPLAY_TEXT_POPUP = &HE   ' Display string resource ID or
  
Private Const HH_HELP_CONTEXT = &HF          ' display mapped numeric value in dwData
     
Private Const HH_TP_HELP_CONTEXTMENU = &H10 ' Text pop-up help, similar to WinHelp
Private Const HH_TP_HELP_WM_HELP = &H11     ' text pop-up help, similar to WinHelp

' HH_DISPLAY_SEARCH Command Related Structures and Constants
'-----------------------------------------------------------
Public Const HH_FTS_DEFAULT_PROXIMITY = -1
Public Const HH_MAX_TABS = 19               ' maximum number of tabs

Public Type HH_FTS_QUERY                    ' UDT for accessing the Search tab
  cbStruct          As Long                 ' Sizeof structure in bytes.
  fUniCodeStrings   As Long                 ' TRUE if all strings are unicode.
  pszSearchQuery    As String               ' String containing the search query.
  iProximity        As Long                 ' Word proximity.
  fStemmedSearch    As Long                 ' TRUE for StemmedSearch only.
  fTitleOnly        As Long                 ' TRUE for Title search only.
  fExecute          As Long                 ' TRUE to initiate the search.
  pszWindow         As String               ' Window to display in
End Type

Public Sub PerformSearch(ByVal intHelpFile As Integer, ByVal sSearch As String, _
Optional ByVal bShowFirstResult As Boolean)
'------------------------------------------------------------------------------
' show search tab and perform search
' ** BUG: ** HTML Help: HH_DISPLAY_SEARCH API Command Does Not Perform a Search
' http://support.microsoft.com/kb/241381/en-us
' fixed by translation from C++ code from Dimitry Karpezo
'------------------------------------------------------------------------------
Dim bDisplayFirstTopic As Boolean
Dim searchIt As HH_FTS_QUERY
Dim RetVal As Long
Dim hwndhelp As Long            '---
Dim hPaneWnd As Long            '---
Dim hPaneLast As Long           '---
Dim hTabWnd As Long             '---
Dim hDlgWnd As Long             '---
Dim hCtlWnd As Long             '---

  '--- check for search term --------------------------------------------------
  If Len(sSearch) = 0 Then
    MsgBox "Please input a Search Term!"
    Exit Sub
  End If

  '--- First, invoke HtmlHelp with HH_DISPLAY_SEARCH.
  '--- It doesn't execute search, but it's need for showing 'search' tab.
  '----------------------------------------------------------------------------
  With searchIt
    .cbStruct = Len(searchIt)               ' Size of structute in bytes
    .fUniCodeStrings = 0&                   ' TRUE if all strings are unicode
    .pszSearchQuery = sSearch               ' String containing the search query
    .iProximity = HH_FTS_DEFAULT_PROXIMITY  ' word proximity
    .fStemmedSearch = 0&                    ' TRUE for StemmedSearch only
    .fTitleOnly = 1&                        ' TRUE for Title Search only
    .fExecute = 0&                          ' TRUE to initiate the search
    .pszWindow = ""                         ' Window to display in
  End With
  hwndhelp = HtmlHelpSearch(0&, HFile(intHelpFile), HH_DISPLAY_SEARCH, searchIt)
  '--- Find query combobox at help viewers search tab and set query text.
  '----------------------------------------------------------------------------
  hPaneWnd = FindWindowEx(hwndhelp, ByVal CLng(0), "HH Child", vbNullString)
  For i = 1 To HH_MAX_TABS        '--- tab's limited to 19
    '--- last HH Child --------------------------------------------------------
    hPaneLast = FindWindowEx(hwndhelp, hPaneWnd, "HH Child", vbNullString)
    If hPaneLast = 0 Then Exit For
    hPaneWnd = hPaneLast
  Next i
  '--- skip Tab Control -------------------------------------------------------
  hCtlWnd = FindWindowEx(hPaneWnd, ByVal CLng(0), "Button", vbNullString)
  
  If hCtlWnd <> 0 Then
    '----------------------------------------------------------------------------
    ' There are two types of interfaces:
    '
    ' 1.
    ' Window hierarchy:
    ' + Main window
    '   + HH Child
    '     + Browser ...
    '   + HH Child       <- second "HH Child" window
    '         - Edit     <- we have to fill this edit
    '         - Buttons  <- and press this buttons
    '         ...
    '----------------------------------------------------------------------------
    '--- skip Tab Control -----
    hCtlWnd = FindWindowEx(hPaneWnd, ByVal CLng(0), "Edit", vbNullString)
    ' Set window text and fill it by our query
    '--------------------------------------------------------------------------
    SendMessage hCtlWnd, WM_SETTEXT, ByVal CLng(0), sSearch
    '--- // 0x3ee (?) 0xbc7 -- 'List Topics' button, it runs search
    SendMessage hwndhelp, WM_COMMAND, &HBC7, ByVal CLng(0)
    
    '--- // 0x3f1 (?) 0xbbe -- 'Display' button, it shows first item
    If bShowFirstResult Then
      SendMessage hwndhelp, WM_COMMAND, &HBBE, ByVal CLng(0)
    End If
  
  Else
    '----------------------------------------------------------------------------
    ' 2.
    ' Window hierarchy:
    ' + Main window
    '   + HH Child
    '     + Browser ...
    '   + HH Child       <- second "HH Child" window
    '     + Tab Control
    '       + Dialog
    '         - Combobox <- we have to fill this combo
    '         - Buttons  <- and press this buttons
    '         ...
    '----------------------------------------------------------------------------
    '--- skip Tab Control
    hTabWnd = FindWindowEx(hPaneWnd, ByVal CLng(0), "SysTabControl32", vbNullString)
    '--- skip dialog
    hDlgWnd = FindWindowEx(hTabWnd, ByVal CLng(0), vbNullString, vbNullString)
    '--- create a string-buffer
    Dim szClass As String * 255
    RetVal = GetClassName(hDlgWnd, szClass, 255)
    
    ' e.g. a standard Windows Message Box has the class name "#32770".
    '--------------------------------------------------------------------------
    If Not Left(szClass, 1) = "#" Then                  '--- Is it dialog?
      '--- skip dialog      
      hDlgWnd = FindWindowEx(hTabWnd, hDlgWnd, vbNullString, vbNullString)     
    End If
    '--- well, it's combobox
    hCtlWnd = FindWindowEx(hDlgWnd, ByVal CLng(0), "ComboBox", vbNullString)    

    ' Set window text and fill it by our query
    '--------------------------------------------------------------------------
    SendMessage hCtlWnd, WM_SETTEXT, ByVal CLng(0), sSearch

    ' Run search
    ' -------------------------------------------------------------------------
    '--- 0x3ee -- 'List Topics' button, it runs search
    SendMessage hwndhelp, WM_COMMAND, &H3EE, ByVal CLng(0)

    ' Show first query result [optional]
    ' -------------------------------------------------------------------------
    '--- 0x3f1 -- 'Display' button, it shows first item
    If bShowFirstResult Then
      SendMessage hwndhelp, WM_COMMAND, &H3F1, ByVal CLng(0)
    End If 
  End If
End Sub

 






HTMLHelp and Visual Basic for Applications
How to call HTMLHelp from a VBA Macro?

Download EXCEL Example 
Declare

Function HtmlHelp Lib "hhctrl.ocx" _
    Alias "HtmlHelpA" _
   (ByVal hWnd As Long, _
    ByVal lpHelpFile As String, _
    ByVal wCommand As Long, _
    ByVal dwData As Long) As Long
    
Const HH_DISPLAY_TOPIC = &H0
Const HH_SET_WIN_TYPE = &H4
Const HH_GET_WIN_TYPE = &H5
Const HH_GET_WIN_HANDLE = &H6
Const HH_DISPLAY_TEXT_POPUP = &HE   ' Display string resource ID or text in a pop-up window.
Const HH_HELP_CONTEXT = &HF         ' Display mapped numeric value in dwData.
Const HH_TP_HELP_CONTEXTMENU = &H10 ' Text pop-up help, similar to WinHelp's HELP_CONTEXTMENU.
Const HH_TP_HELP_WM_HELP = &H11     ' text pop-up help, similar to WinHelp's HELP_WM_HELP.


Sub OpenHelp(ByVal ContextId As Long)
'The return value is the window handle of the created help window.
Dim hwndHH as Long
    hwndHH = HtmlHelp(0, ThisWorkbook.Path & "\" & AppId & ".chm", HH_HELP_CONTEXT, ContextId)
End Sub

to call the default topic of the HTMLHelp file please try:

hwndHH = HtmlHelp(0, ThisWorkbook.Path & "\" & "Helpfile" & ".chm", HH_DISPLAY_TOPIC, 0)

The Context_ID will submit. 

 



HTMLHelp and Visual Basic 6
 

Using a module for Visual Basic 6 projects
At the control element for which the help shall be called set the HelpContextID property to 1030 e.g. in Visual Basic. The exact procedure can be recognized in the example project. 

Example:

'******************************************************************************
'----- Modul - definition for HTMLHelp - (c) Ulrich Kulle
'----- 2002-08-26 Version 1.0 first release
'----- 2005-07-17 Version 1.1 updated for Pop-Up help
'******************************************************************************
'----- Portions of this code courtesy of David Liske.
'----- Thanks to David Liske, Don Lammers, Matthew Brown and Thomas Schulz
'------------------------------------------------------------------------------
Type HH_IDPAIR
  dwControlId As Long
  dwTopicId As Long
End Type

'This array should contain the number of controls that have
'context-sensitive help, plus one more for a zero-terminating
'pair.

Public ids(2) As HH_IDPAIR

Declare Function GetDlgCtrlID Lib "user32" _
  (ByVal hwnd As Long) As Long

Public Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" _
               (ByVal hwndCaller As Long, ByVal pszFile As String, _
                ByVal uCommand As Long, ByVal dwData As Long) As Long
                
Declare Function HTMLHelpTopic Lib "hhctrl.ocx" Alias "HtmlHelpA" _
               (ByVal hwndCaller As Long, ByVal pszFile As String, _
                ByVal uCommand As Long, ByVal dwData As String) As Long
         
Private Declare Function HtmlHelpSearch Lib "hhctrl.ocx" Alias "HtmlHelpA" _
               (ByVal hwndCaller As Long, ByVal pszFile As String, _
                ByVal uCommand As Long, dwData As HH_FTS_QUERY) As Long
         

Public Const HH_DISPLAY_TOPIC = &H0         ' select last opened tab, [display a specified topic]
Public Const HH_DISPLAY_TOC = &H1           ' select contents tab, [display a specified topic]
Public Const HH_DISPLAY_INDEX = &H2         ' select index tab and searches for a keyword
Public Const HH_DISPLAY_SEARCH = &H3        ' select search tab and perform a search
      
Private Const HH_SET_WIN_TYPE = &H4
Private Const HH_GET_WIN_TYPE = &H5
Private Const HH_GET_WIN_HANDLE = &H6
Private Const HH_DISPLAY_TEXT_POPUP = &HE   ' Display string resource ID or
  
Public Const HH_HELP_CONTEXT = &HF          ' display mapped numeric value in dwData
     
Private Const HH_TP_HELP_CONTEXTMENU = &H10 ' Text pop-up help, similar to WinHelp's HELP_CONTEXTMENU.
Private Const HH_TP_HELP_WM_HELP = &H11     ' text pop-up help, similar to WinHelp's HELP_WM_HELP.


Public Type HH_FTS_QUERY                ' UDT for accessing the Search tab
  cbStruct          As Long             ' Sizeof structure in bytes.
  fUniCodeStrings   As Long             ' TRUE if all strings are unicode.
  pszSearchQuery    As String           ' String containing the search query.
  iProximity        As Long             ' Word proximity.
  fStemmedSearch    As Long             ' TRUE for StemmedSearch only.
  fTitleOnly        As Long             ' TRUE for Title search only.
  fExecute          As Long             ' TRUE to initiate the search.
  pszWindow         As String           ' Window to display in
End Type

Public Function HFile(ByVal i_HFile As Integer) As String
'----- Set the string variable to include the application path of helpfile
  Select Case i_HFile
  Case 1
    HFile = App.Path & "\help\CHM-example.chm"
  Case 2
'----- Place other Help file paths in successive case statements
    HFile = App.Path & "\help\CHM-other-language.chm"
  End Select
End Function

Public Sub ShowContents(ByVal intHelpFile As Integer)
   HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0
End Sub

Public Sub ShowIndex(ByVal intHelpFile As Integer)
    HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_INDEX, 0
End Sub

Public Sub ShowTopic(ByVal intHelpFile As Integer, strTopic As String)
    HTMLHelpTopic hwnd, HFile(intHelpFile), HH_DISPLAY_TOPIC, strTopic
End Sub

Public Sub ShowTopicID(ByVal intHelpFile As Integer, IdTopic As Long)
  HtmlHelp hwnd, HFile(intHelpFile), HH_HELP_CONTEXT, IdTopic
End Sub
'------------------------------------------------------------------------------
'----- display the search tab
'----- bug: start searching with a string dosn't work
'------------------------------------------------------------------------------
Public Sub ShowSearch(ByVal intHelpFile As Integer)
Dim searchIt As HH_FTS_QUERY
  With searchIt
    .cbStruct = Len(searchIt)
    .fUniCodeStrings = 1&
    .pszSearchQuery = "foobar"
    .iProximity = 0&
    .fStemmedSearch = 0&
    .fTitleOnly = 1&
    .fExecute = 1&
    .pszWindow = ""
  End With
  Call HtmlHelpSearch(0&, HFile(intHelpFile), HH_DISPLAY_SEARCH, searchIt)
End Sub



HTMLHelp and Visual Basic 2003 (.net)
Providing help in your application should be one of the things that you shouldn't skip. Use the appropiate type of help based on specific need of your application. Sometimes it's better to use HTMLHelp files (CHM), but sometimes it will be enough to have only Pop-Up help or ToolTips.

If you already have experience with VB6, the first thing you may notice about .NET applications is they no longer support calling help using numeric Context IDs. But look, what has changed when using the good old HTMLHelp API call ..

Note:
At VB.net a basic problem consists in the declaration of the API function. You'll need to convert the LONG declares in the API to IntPtr or Int32 for .NET, since integers in .NET are 32bit, whereas they are 16bit in VB6.

  Public Declare Function HTMLHelp_BaseCall Lib "hhctrl.ocx" Alias "HtmlHelpA" _
  (ByVal hWnd As IntPtr, ByVal lpHelpFile As String, _
  ByVal uCommand As Int32, ByVal dwData As Int32) As Int32
 

Using a module for VB.net projects
Example:

Module modHelp
  '------------------------------------------------------------------------
  '--- (c) Ulrich Kulle, 2004-09-03
  '--- The HTMLHelp function starts HTML Help and passes additional data
  '--- If the function succeeds, the return value is nonzero.
  '--- If the function fails, the return value is zero.

  Public Const HH_DISPLAY_TOPIC As Short = &H0    ' select last opened tab, [display a specified topic]
  Public Const HH_DISPLAY_TOC As Short = &H1      ' select contents tab, [display a specified topic]
  Public Const HH_DISPLAY_INDEX As Short = &H2    ' select index tab and searches for a keyword
  Public Const HH_DISPLAY_SEARCH As Short = &H3   ' select search tab and perform a search

  Public Const HH_HELP_CONTEXT As Short = &HF     ' display mapped numeric value in dwData

  '--- The parameters of the API call MUST be an Integer type
  '--- old VB6 definition of the parameters was 'As Long'
  '*** hWnd is the handle of the window requesting help
  '*** lpHelpFile is a string containing path, name of the helpfile
  '               [optional]: file of the specific topic
  '               [optional]: name of a secondary window
  '*** uCommand specifies the type of help requested
  '               see some Help Command Constants above
  '*** dwData specifies additional data. The value used despends on the value of uCommand
  '               VB6 declaration is 'As Any' or 'As Long' !!!

  '  ********** Changes  **********
  ' (VB.net):  Integer => IntPtr
  ' (VB.net):  Long => Int32
  ' (VB.net):  Long => Int32

  Public Declare Function HTMLHelp_BaseCall Lib "hhctrl.ocx" Alias "HtmlHelpA" _
  (ByVal hWnd As IntPtr, ByVal lpHelpFile As String, _
  ByVal uCommand As Int32, ByVal dwData As Int32) As Int32

Call to show Table of Contents

  Public Sub ShowContents(ByVal intHelpFile As Integer)
    '--- Call to show Table of Contents ---
    Dim RetVal As Int32
    RetVal = HTMLHelp_BaseCall(IntPtr.Zero, HFile(intHelpFile), HH_DISPLAY_TOC, 0)
  End Sub

Call to show Index

  Public Sub ShowIndex(ByVal intHelpFile As Integer)
    '--- Call to show Index --- 
    Dim RetVal As Int32
    RetVal = HTMLHelp_BaseCall(IntPtr.Zero, HFile(intHelpFile), HH_DISPLAY_INDEX, 0)
  End Sub

Call to show topic

  Public Sub ShowTopic(ByVal intHelpFile As Integer, ByVal strTopic As String)
    '--- Call to show topic ---
    Dim RetVal As Int32
    RetVal = HTMLHelp_BaseCall(IntPtr.Zero, HFile(intHelpFile) & "::/" & strTopic, HH_DISPLAY_TOC, 0)
  End Sub

Call to show a topic by ContextID

  Public Sub ShowTopicID(ByVal intHelpFile As Integer, ByVal IdTopic As Int32)
    '--- Call to show a topic by ContextID --- 
    Dim RetVal As Int32
    RetVal = HTMLHelp_BaseCall(IntPtr.Zero, HFile(intHelpFile), HH_HELP_CONTEXT, IdTopic)
  End Sub

To select a specific help file

  Public Function HFile(ByVal i_HFile As Integer) As String
    Dim sHelpFile As String
    Dim sStartupPath As String
    '--- Initialize context-sensitive help ---
    sStartupPath = Application.StartupPath.ToString

    Select Case i_HFile
      Case 1
        sHelpFile = Replace(sStartupPath, "\bin", "\hlp") & "\VBnetCHM.chm"
        Return sHelpFile
      Case 2
        '--- Place other help file paths in successive case statements
        sHelpFile = Replace(sStartupPath, "\bin", "\hlp") & "\Help_Coding-Example_VB6.chm"
        Return sHelpFile
    End Select
  End Function



Dowmload
 see download section at "Help Authoring in Visual Basic .NET" 
FAQ
Pocket CHM: How to Use HTML Help API in a Visual Basic Application 
Pocket CHM: How To Prepare HTML Help Files for Context-Sensitive Help 
Pocket CHM: How To Create Context-Sensitive HTML Help in a Visual Basic App 
Links
HTMLHelp Center: Using HTML Help with VB.NET 
 

 


c0Title: Huffman Coding Compression / Decompression Algorithm
c1Code:
'################################################################
' Huffman Coding Compression / Decompression Algorithm
' Created 1 August 2000 by James Vincent Carnicelli
'
' NOTES
'
' The Huffman algorithm, named after its inventor, was created
' around about 1952.  It's the method used by most commercial
' compression utilities, like PKZIP, and even by the JPEG image
' file format.  It's generally thought to offer an average of
' 50% compression, given a typical mix of text and binary data.
' For long strings that contain lots of repeating characters or
' only a handful of different characters, the compression ratio
' could get as high as 80%.  While efficient, this algorithm is
' not guaranteed to result in a compressed string that is
' smaller than the original source.
'
' This is a less-than-optimal implementation of this compression
' algorithm.  It's very simple to use in your programs (even if
' it is difficult to understand how it works).  You need only
' call:
'
'         Compressed = HuffmanEncode(SourceText, [Force])
'
' passing in the text you want compressed.  If the compressed
' version is actually larger than the original source, this
' algorithm spits out a special string that contains a four-
' byte header and the original source string, so the resulting
' string will always be at most four bytes larger than the
' source string.  If you pass in True for Force, the result will
' always be huffman-encoded, bypassing this neat optimization.
' Be aware that the output is binary data, so it might not work
' nicely with some things like text boxes, certain Windows
' API calls, and some SQL and database field formats.
'
' To decode a string encoded with HuffmanEncode, simply call
' the following:
'
'         UncompressedText = HuffmanDecode(Compressed)
'
' One cool application of this algorithm is encryption.  Because
' Huffman coding relies on variable-bit-length character
' representations, it's next to impossible to decrypt a string
' compressed with this algorithm without recognizing the
' lookup tables in the header as the key to decrypting it.  You
' could even strip out this lookup table and keep it as a
' private key to be shared only with those you want.  Without
' the lookup table, even someone equiped with this very code
' would not likely be able to decrypt the string.
'
' One last thing.  While I've tested this algorithm with plain
' text strings and even some binary files, I don't know how
' much data you can cram into the compression engine before it
' breaks.  With luck, it's something like 2GB.  In that case,
' though, this would be pretty slow.  Also, I have not proven
' beyond a doubt that this won't choke on some data, so I would
' encourage you to do so to your satisfaction before putting
' this into full production.  Be sure to let me know if you find
' anything interesting.
'################################################################
 
Option Explicit
 
Private Enum HuffmanTreeNodeParts
    htnWeight = 1
    htnIsLeaf = 2
    htnAsciiCode = 3
    htnBitCode = 4
    htnLeftSubtree = 5
    htnRightSubtree = 6
End Enum
 

'Compress the text.
Public Function HuffmanEncode(Text As String, Optional Force As Boolean) As String
    Dim TextLen As Long, Char As Byte, i As Long, j As Long
    Dim CodeCounts(255) As Long, BitStrings(255), BitString
    Dim HuffmanTrees As Collection
    Dim HTRootNode As Collection, HTNode As Collection
    Dim NextByte As Byte, BitPos As Integer, Temp As String
    
    'Initialize for processing.
    TextLen = Len(Text)
    Set HuffmanTrees = New Collection
    
    'Is there anything to encode?
    If TextLen = 0 Then
        HuffmanEncode = "HE0" & vbCr  'Version 0 = Plain text
        Exit Function  'No point in continuing
    End If
    
    HuffmanEncode = "HE2" & vbCr  'Version 1
    
    'Count how many times each ASCII code is encountered in text.
    For i = 1 To TextLen
        Char = Asc(Mid(Text, i, 1))
        CodeCounts(Char) = CodeCounts(Char) + 1
    Next
    
    'Initialize the forest of Huffman trees; one for each ASCII
    'character used.
    For i = 0 To UBound(CodeCounts)
        If CodeCounts(i) > 0 Then
            Set HTNode = NewNode
            S HTNode, htnAsciiCode, Chr(i)
            S HTNode, htnWeight, CDbl(CodeCounts(i) / TextLen)
            S HTNode, htnIsLeaf, True
            
            'Now place it in its reverse-ordered position.
            For j = 1 To HuffmanTrees.Count + 1
                If j > HuffmanTrees.Count Then
                    HuffmanTrees.Add HTNode
                    Exit For
                End If
                If HTNode(htnWeight) >= HuffmanTrees(j)(htnWeight) Then
                    HuffmanTrees.Add HTNode, , j
                    Exit For
                End If
            Next
        End If
    Next
    
    'Now assemble all these single-level Huffman trees into
    'one single tree, where all the leaves have the ASCII codes
    'associated with them.
    If HuffmanTrees.Count = 1 Then
        Set HTNode = NewNode
        S HTNode, htnLeftSubtree, HuffmanTrees(1)
        S HTNode, htnWeight, 1
        HuffmanTrees.Remove (1)
        HuffmanTrees.Add HTNode
    End If
    While HuffmanTrees.Count > 1
        Set HTNode = NewNode
        S HTNode, htnRightSubtree, HuffmanTrees(HuffmanTrees.Count)
        HuffmanTrees.Remove HuffmanTrees.Count
        S HTNode, htnLeftSubtree, HuffmanTrees(HuffmanTrees.Count)
        HuffmanTrees.Remove HuffmanTrees.Count
        S HTNode, htnWeight, HTNode(htnLeftSubtree)(htnWeight) + HTNode(htnRightSubtree)(htnWeight)
        
        'Place this new tree it in its reverse-ordered position.
        For j = 1 To HuffmanTrees.Count + 1
            If j > HuffmanTrees.Count Then
                HuffmanTrees.Add HTNode
                Exit For
            End If
            If HTNode(htnWeight) >= HuffmanTrees(j)(htnWeight) Then
                HuffmanTrees.Add HTNode, , j
                Exit For
            End If
        Next
    Wend
    Set HTRootNode = HuffmanTrees(1)
    AttachBitCodes BitStrings, HTRootNode, Array()
    For i = 0 To UBound(BitStrings)
        If Not IsEmpty(BitStrings(i)) Then
            Set HTNode = BitStrings(i)
            Temp = Temp & HTNode(htnAsciiCode) _
              & BitsToString(HTNode(htnBitCode))
        End If
    Next
    HuffmanEncode = HuffmanEncode & Len(Temp) & vbCr & Temp
    
    'The next part of the header is a checksum value, which
    'we'll use later to verify our decompression.
    Char = 0
    For i = 1 To TextLen
        Char = Char Xor Asc(Mid(Text, i, 1))
    Next
    HuffmanEncode = HuffmanEncode & Chr(Char)
    
    'The final part of the header identifies how many bytes
    'the original text strings contains.  We will probably
    'have a few unused bits in the last byte that we need to
    'account for.  Additionally, this serves as a final check
    'for corruption.
    HuffmanEncode = HuffmanEncode & TextLen & vbCr
    
    'Now we can encode the data by exchanging each ASCII byte for
    'its appropriate bit string.
    BitPos = -1
    Char = 0
    Temp = ""
    For i = 1 To TextLen
        BitString = BitStrings(Asc(Mid(Text, i, 1)))(htnBitCode)
        'Add each bit to the end of the output stream's 1-byte buffer.
        For j = 0 To UBound(BitString)
            BitPos = BitPos + 1
            If BitString(j) = 1 Then
                Char = Char + 2 ^ BitPos
            End If
            'If the bit buffer is full, dump it to the output stream.
            If BitPos >= 7 Then
                Temp = Temp & Chr(Char)
                'If the temporary output buffer is full, dump it
                'to the final output stream.
                If Len(Temp) > 1024 Then
                    HuffmanEncode = HuffmanEncode & Temp
                    Temp = ""
                End If
                BitPos = -1
                Char = 0
            End If
        Next
    Next
    If BitPos > -1 Then
        Temp = Temp & Chr(Char)
    End If
    If Len(Temp) > 0 Then
        HuffmanEncode = HuffmanEncode & Temp
    End If
    
    'If it takes up more space compressed because the source is
    'small and the header is big, we'll leave it uncompressed
    'and prepend it with a 4 byte header.
    If Len(HuffmanEncode) > TextLen And Not Force Then
        HuffmanEncode = "HE0" & vbCr & Text
    End If
End Function
 

'Decompress the string back into its original text.
Public Function HuffmanDecode(ByVal Text As String) As String
    Dim Pos As Long, Temp As String, Char As Byte, Bits
    Dim i As Long, j As Long, CharsFound As Long, BitPos As Integer
    Dim CheckSum As Byte, SourceLen As Long, TextLen As Long
    Dim HTRootNode As Collection, HTNode As Collection
    
    'If this was left uncompressed, this will be easy.
    If Left(Text, 4) = "HE0" & vbCr Then
        HuffmanDecode = Mid(Text, 5)
        Exit Function
    End If
    
    'If this is any version other than 2, we'll bow out.
    If Left(Text, 4) <> "HE2" & vbCr Then
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "The data either was not compressed with HE2 or is corrupt"
    End If
    Text = Mid(Text, 5)
    
    'Extract the ASCII character bit-code table's byte length.
    Pos = InStr(1, Text, vbCr)
    If Pos = 0 Then
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "The data either was not compressed with HE2 or is corrupt"
    End If
    On Error Resume Next
    TextLen = Left(Text, Pos - 1)
    If Err.Number <> 0 Then
        On Error GoTo 0
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "The header is corrupt"
    End If
    On Error GoTo 0
    Text = Mid(Text, Pos + 1)
    Temp = Left(Text, TextLen)
    Text = Mid(Text, TextLen + 1)
    'Now extract the ASCII character bit-code table.
    Set HTRootNode = NewNode
    Pos = 1
    While Pos <= Len(Temp)
        Char = Asc(Mid(Temp, Pos, 1))
        Pos = Pos + 1
        Bits = StringToBits(Pos, Temp)
        Set HTNode = HTRootNode
        For j = 0 To UBound(Bits)
            If Bits(j) = 1 Then
                If HTNode(htnLeftSubtree) Is Nothing Then
                    S HTNode, htnLeftSubtree, NewNode
                End If
                Set HTNode = HTNode(htnLeftSubtree)
            Else
                If HTNode(htnRightSubtree) Is Nothing Then
                    S HTNode, htnRightSubtree, NewNode
                End If
                Set HTNode = HTNode(htnRightSubtree)
            End If
        Next
        S HTNode, htnIsLeaf, True
        S HTNode, htnAsciiCode, Chr(Char)
        S HTNode, htnBitCode, Bits
    Wend
    
    'Extract the checksum.
    CheckSum = Asc(Left(Text, 1))
    Text = Mid(Text, 2)
    
    'Extract the length of the original string.
    Pos = InStr(1, Text, vbCr)
    If Pos = 0 Then
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "The header is corrupt"
    End If
    On Error Resume Next
    SourceLen = Left(Text, Pos - 1)
    If Err.Number <> 0 Then
        On Error GoTo 0
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "The header is corrupt"
    End If
    On Error GoTo 0
    Text = Mid(Text, Pos + 1)
    TextLen = Len(Text)
    
    'Now that we've processed the header, let's decode the actual data.
    i = 1
    BitPos = -1
    Set HTNode = HTRootNode
    Temp = ""
    While CharsFound < SourceLen
        If BitPos = -1 Then
            If i > TextLen Then
                Err.Raise vbObjectError, "HuffmanDecode()", _
                  "Expecting more bytes in data stream"
            End If
            Char = Asc(Mid(Text, i, 1))
            i = i + 1
        End If
        BitPos = BitPos + 1
        
        If (Char And 2 ^ BitPos) > 0 Then
            Set HTNode = HTNode(htnLeftSubtree)
        Else
            Set HTNode = HTNode(htnRightSubtree)
        End If
        If HTNode Is Nothing Then
            'Uh oh.  We've followed the tree to a Huffman tree to a dead
            'end, which won't happen unless the data is corrupt.
            Err.Raise vbObjectError, "HuffmanDecode()", _
              "The header (lookup table) is corrupt"
        End If
        
        If HTNode(htnIsLeaf) Then
            Temp = Temp & HTNode(htnAsciiCode)
            If Len(Temp) > 1024 Then
                HuffmanDecode = HuffmanDecode & Temp
                Temp = ""
            End If
            CharsFound = CharsFound + 1
            Set HTNode = HTRootNode
        End If
        
        If BitPos >= 7 Then BitPos = -1
    Wend
    If Len(Temp) > 0 Then
        HuffmanDecode = HuffmanDecode & Temp
    End If
    If i <= TextLen Then
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "Found extra bytes at end of data stream"
    End If
    
    'Verify data to check for corruption.
    If Len(HuffmanDecode) <> SourceLen Then
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "Data corrupt because check sums do not match"
    End If
    Char = 0
    For i = 1 To SourceLen
        Char = Char Xor Asc(Mid(HuffmanDecode, i, 1))
    Next
    If Char <> CheckSum Then
        Err.Raise vbObjectError, "HuffmanDecode()", _
          "Data corrupt because check sums do not match"
    End If
End Function
 
 
 
'----------------------------------------------------------------
' Everything below here is only for supporting the two main
' routines above.
'----------------------------------------------------------------
 

'Follows the tree, now built, to its end leaf nodes, where the
'character codes are, in order to tell those character codes
'what their bit string representations are.
Private Sub AttachBitCodes(BitStrings, HTNode As Collection, ByVal Bits)
    If HTNode Is Nothing Then Exit Sub
    If HTNode(htnIsLeaf) Then
        S HTNode, htnBitCode, Bits
        Set BitStrings(Asc(HTNode(htnAsciiCode))) = HTNode
    Else
        ReDim Preserve Bits(UBound(Bits) + 1)
        Bits(UBound(Bits)) = 1
        AttachBitCodes BitStrings, HTNode(htnLeftSubtree), Bits
        Bits(UBound(Bits)) = 0
        AttachBitCodes BitStrings, HTNode(htnRightSubtree), Bits
    End If
End Sub
 
'Turns a string of '0' and '1' characters into a string of bytes
'containing the bits, preceeded by 1 byte indicating the
'number of bits represented.
Private Function BitsToString(Bits) As String
    Dim Char As Byte, i As Long
    BitsToString = Chr(UBound(Bits) + 1)  'Number of bits
    For i = 0 To UBound(Bits)
        If i Mod 8 = 0 Then
            If i > 0 Then BitsToString = BitsToString & Chr(Char)
            Char = 0
        End If
        If Bits(i) = 1 Then  'Bit value = 1
            'Mask the bit into its proper position in the byte
            Char = Char + 2 ^ (i Mod 8)
        End If
    Next
    BitsToString = BitsToString & Chr(Char)
End Function
 
'The opposite of BitsToString() function.
Private Function StringToBits(StartPos As Long, Bytes As String)
    Dim Char As Byte, i As Long, BitCount As Long, Bits
    Bits = Array()
    BitCount = Asc(Mid(Bytes, StartPos, 1))
    StartPos = StartPos + 1
    For i = 0 To BitCount - 1
        If i Mod 8 = 0 Then
            Char = Asc(Mid(Bytes, StartPos, 1))
            StartPos = StartPos + 1
        End If
        ReDim Preserve Bits(UBound(Bits) + 1)
        If (Char And 2 ^ (i Mod 8)) > 0 Then   'Bit value = 1
            Bits(UBound(Bits)) = 1
        Else  'Bit value = 0
            Bits(UBound(Bits)) = 0
        End If
    Next
    StringToBits = Bits
End Function
 
'Remove the specified item and put the specified value in its place.
Private Sub S(Col As Collection, Index As HuffmanTreeNodeParts, Value)
    Col.Remove Index
    If Index > Col.Count Then
        Col.Add Value
    Else
        Col.Add Value, , Index
    End If
End Sub
 
'Creates a new Huffman tree node with the default values set.
Private Function NewNode() As Collection
    Dim Node As New Collection
    Node.Add 0  'htnWeight
    Node.Add False  'htnIsLeaf
    Node.Add Chr(0)  'htnAsciiCode
    Node.Add ""  'htnBitCode
    Node.Add Nothing  'htnLeftSubtree
    Node.Add Nothing  'htnRightSubtree
    Set NewNode = Node
End Function
 

 


c0Title:
ImageToIPicture - Generic function to convert various image types to a IPicture object. Icons, bitmaps, meta & enhanced meta files supported

c1Code:
Option Explicit

Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal pclsid As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL" (lpPictDesc As PICTDESC, riid As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function InternetGetLastResponseInfoA Lib "wininet.dll" _
    (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Long
Private Declare Function WNetGetLastErrorA Lib "mpr.dll" _
    (lpError As Long, ByVal lpErrorBuf As String, ByVal nErrorBufSize As Long, _
     ByVal lpNameBuf As String, ByVal nNameBufSize As Long) As Long
Private Declare Function WNetGetLastErrorW Lib "mpr.dll" _
    (lpError As Long, ByVal lpErrorBuf As Long, ByVal nErrorBufSize As Long, _
     ByVal lpNameBuf As Long, ByVal nNameBufSize As Long) As Long
Public Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Private Declare Function RasGetErrorStringA Lib "RasApi32.DLL" (ByVal uErrorValue As Long, ByVal lpszErrorString As String, ByVal cBufSize As Long) As Long
Private Declare Function FormatMessageA Lib "kernel32" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function FormatMessageW Lib "kernel32" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As Long, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Private Enum OSVersionEnum
    VER_PLATFORM_WIN32s = 0
    VER_PLATFORM_WIN32_WINDOWS = 1
    VER_PLATFORM_WIN32_NT = 2
End Enum

Private Type OSVERSIONINFO                      ' operating system version information [used by GetVersion]
    dwOSVersionInfoSize     As Long
    dwMajorVersion          As Long
    dwMinorVersion          As Long
    dwBuildNumber           As Long
    dwPlatformId            As Long
    szCSDVersion            As String * 128     ' Maintenance string for PSS usage
End Type

Private Type PICTDESC                       ' This version is generic & supports all 4 types
    cbSizeofstruct  As Long                 ' defines the version of structure
    picType         As Long
    hImage          As Long                 ' hBitmap, hIcon, hMeta or hEnahanceMeta
    xExt_Or_hPal    As Long                 ' handle to a palette [bitmap] or width [metafile]
    yExt            As Long                 ' height [metafile]
End Type

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

Private OSVersion           As OSVERSIONINFO    ' private structure for various Public functions

Public Function ImageToIPicture(hImage As Long, ByVal PictureType As PictureTypeConstants, _
                                 Optional ByVal hPalette As Long, _
                                 Optional ByVal Width As Long, _
                                 Optional ByVal Height As Long, _
                                 Optional ByVal SharedImage As Boolean) As IPicture
'===========================================================================
'   ImageToIPicture - Generic function to convert various image types to a
'   IPicture object. Icons, bitmaps, meta & enhanced meta files supported. For
'   cursors, use vbPicTypeIcon.
'
'   hImage          The image to convert.
'   PictureType     The kind of image to convert.
'   hPalette        Optional. BMP only - uses specified palette. Not required.
'   Width/Height    Optional. WMF only - specifies extents of image. Required.
'
'   RETURNS         The IPicture object for supplied image.
'===========================================================================

    Dim IID_IPicture    As GUID
    Dim PicDef          As PICTDESC
    Dim ErrorCode       As Long
    
    ' Ensure picture type is supported, and reference correct structure
    Select Case PictureType
    Case vbPicTypeBitmap
        PicDef.cbSizeofstruct = 12  ' members: cbSizeofStruct, picType, hImage
        PicDef.xExt_Or_hPal = hPalette
    
    Case vbPicTypeIcon
        PicDef.cbSizeofstruct = 16  ' members: cbSizeofStruct, picType, hImage, hPalette
    
    Case vbPicTypeMetafile
        PicDef.xExt_Or_hPal = Width
        PicDef.yExt = Height
        PicDef.cbSizeofstruct = 20  ' members: cbSizeofStruct, picType, hImage, xExt, yExt
    
    Case vbPicTypeEMetafile
        PicDef.cbSizeofstruct = 12  ' members: cbSizeofStruct, picType, hImage
    
    Case Else
        Err.Raise 5, App.ProductName, "Invalid picture type."
    End Select
    
    ' FYI IPictureDisp GUID: "{7BF80981-BF32-101A-8BBB-00AA00300CAB}" [see OCIDL.H]
    ' Convert GUID string for IPicture interface to binary
    ErrorCode = CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), VarPtr(IID_IPicture))
    If ErrorCode <> 0 Then
        ApiRaise ErrorCode, App.ProductName, "Could not convert image to Picture."
    End If
    
    ' Fill remainder of picture description
    PicDef.picType = PictureType
    PicDef.hImage = hImage

    ' Convert it to a IPicture object. The image is destroyed when object is destroyed.
    Call OleCreatePictureIndirect(PicDef, IID_IPicture, Abs(Not SharedImage), ImageToIPicture)

End Function

Public Sub ApiRaise(Optional ByVal Number As Long, _
                    Optional ByVal Source As String, _
                    Optional ByVal DescPrefix As String, _
                    Optional ByVal HelpFile As String, _
                    Optional ByVal HelpContext As Long, _
                    Optional ByVal NewLineCharacter As String = vbCrLf)
'===========================================================================
'   ApiRaise - Builds and throws an error returned from a Win32 API call.
'
'   NewLineCharacter    Allows the caller to convert linefeeds to a space or
'                       other character. This helps when displaying log entries
'                       in a List that cannot display multiple lines.
'
'   All other parameters are the same as Err.Raise method.
'
'   NOTE: &H80070000 will be added to Number. This number represents the
'   first 16 bits of an HRESULT (facility code of FACILITY_WIN32). Kudos
'   to Matt Curland for this technique!
'
'===========================================================================
        

    ' Use LastDllError if no Number supplied
    If Number = 0 Then
        Number = Err.LastDllError
    End If

    ' Use EXE name if no Source supplied
    If Len(Source) = 0 Then
        Source = App.EXEName
    End If
    
    ' If a msg prefix is used then massage the message
    If Len(DescPrefix) > 0 Then
        
        ' Terminate prefix with a period if not.
        DescPrefix = Trim$(DescPrefix)
        Select Case Right$(DescPrefix, 1)
        Case ".", "?", "!"
            ' this case perhaps not too locale friendly
        Case Else
            DescPrefix = DescPrefix & "."
        End Select
        
        ' Build error message and throw it
        On Error GoTo 0
        Err.Raise &H80070000 + Number, Source, _
            DescPrefix & NewLineCharacter & LastDllErrorMsg(Number, NewLineCharacter), _
            HelpFile, HelpContext
    Else
        
        ' Build error message and throw it
        On Error GoTo 0
        Err.Raise &H80070000 + Number, Source, _
            LastDllErrorMsg(Number, NewLineCharacter), _
            HelpFile, HelpContext
    
    End If
    
End Sub


Public Function LastDllErrorMsg(Optional ByVal Number As Long, _
                                Optional ByVal NewLineCharacter As String = vbCrLf) As String
'===============================================================================
'   LastDllErrorMsg - Returns the description of the supplied error number.
'
'   Number              Optional. The number to decode if supplied, otherwise the
'                       Err.LastDllError is used.
'   NewLineCharacter    Optional. Use to specificy an alternate character for CR/LFs
'===============================================================================
    
    Const ERROR_INSUFFICIENT_Message = 122&
    Const FORMAT_MESSAGE_FROM_HMODULE = &H800&
    Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
    Const ERROR_EXTENDED_ERROR = 1208&
    Dim Message         As String   ' Place where error description will be nSize to.
    Dim Provider        As String   ' Place where error next provider output to
    Dim nSize           As Long     ' Number of bytes nSize to Message
    Dim Result          As Long     ' general return code
    Dim Success         As Boolean
    Dim ErrorCode       As Long
    Dim PreservedDllErr As Long     ' saved error number; since error functions w/be calling this


    On Error GoTo ExitLabel                     ' There shouldnt be any errors here.
    PreservedDllErr = Err.LastDllError          ' save LastDllError as it will be restored on exit
    
    If Number = 0 Then                          ' no error code supplied
        Number = Err.LastDllError               ' use the VB last known API error code
    ElseIf (Number And &H8000&) = 0 Then        ' 'possible' HRESULT
        ' NOTE: We must often contend with errors returned by VB
        ' and other interfaces with a description of "OLE Automation Error".
        ' These HRESULTS can OFTEN be translated to a Windows' system error
        ' by it's low word. This is typical when trying to create an object
        ' (perhaps via DCOM) or when accessing an object via a system
        ' interface such as IShellFolder.
        Number = Number And &HFFFF&             ' Essentially, we strip vbObjectError
    End If
    
    ' init output Message & clear LastDllError
    SetLastError 0
    nSize = 0
    
    '  Translate generic error descriptions
    Select Case Number
    Case ERROR_EXTENDED_ERROR
        ' server has extended error info
        
        ' Initialize output buffers
        Message = String(512, 0)
        Provider = String(128, 0)
        
        ' Get the error info from the server
        Result = WNetGetLastErrorA(ErrorCode, Message, Len(Message), Provider, Len(Provider))
        If Result = 0 Then
            ' call succeeded
            
            ' Strip NULLs from the strings
            Message = TrimNulls(Message)
            Provider = TrimNulls(Provider)
        
        End If
        
        ' Build friendly message
        Message = Provider & " returned error #" & ErrorCode & " " & Message & "."
        nSize = Len(Message)

    Case 600 To 799
        ' RAS specific codes have an error base of 600
        
        ' Initialize our Message and translate the error code
        Message = String(512, 0)
        nSize = Len(Message)
        Result = RasGetErrorStringA(Number, Message, nSize)
        If Result = 0 Then
            ' call succeeded
            
            ' Fetch message size
            nSize = InStr(Message, vbNullChar) - 1
            ' Sanity check
            If nSize < 0 Then nSize = 0
        End If
        
    Case 12003 'ERROR_INTERNET_EXTENDED_ERROR
        ' wininet extended errors
        
        ' Fetch Message size needed
        nSize = 0
        Success = InternetGetLastResponseInfoA(Result, Message, nSize)
        
        ' Size Message to fit
        Message = String(nSize + 1, 0)
        Success = InternetGetLastResponseInfoA(Result, Message, (nSize))

        ' ********************************************************
        ' BTW: Parsing this string may allow us to re-map
        '      to a real error. This is where we end up when
        '      the wininet parser fails (even on simple things
        '      that might not represent an error condition).
        ' ********************************************************
        ' CALLER should call my function MapFtpResponse() which
        ' will attempt to map an FTP response code marked as
        ' ERROR_INTERNET_EXTENDED_ERROR to a matching Win32 error.
        ' ********************************************************

    Case 12000 To 12999
        ' wininet specific errors
        
        ' This functions assume that wininet.dll is already mapped into memory
        Result = GetModuleHandleA("wininet.dll")
        
        If Result <> 0 Then
            
            ' Initialize our Message and translate the error code
            Message = Space(256)
            nSize = _
                FormatMessageA(FORMAT_MESSAGE_FROM_HMODULE, _
                               ByVal Result, Number, 0&, Message, 255, ByVal 0&)
        
        ' Else: we could be nice and temporarily load the library
        End If


    Case Else
        ' All other Windows errors
        
        ' Initialize our Message and translate the error code
        Message = Space(256)
        nSize = _
            FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, _
                           ByVal 0&, Number, 0&, Message, 255&, ByVal 0&)
    End Select

    ' return the error description
    LastDllErrorMsg = Left$(Message, nSize)

    ' If the caller wants to translate line breaks then do so
    If StrComp(NewLineCharacter, vbCrLf, vbBinaryCompare) <> 0 Then
        LastDllErrorMsg = Replace(LastDllErrorMsg, vbCrLf, Left$(NewLineCharacter, 1))
    End If
    
    ' Strip ending CR/LF's as many message tables like to add this.
    If Right$(LastDllErrorMsg, 2) = vbCrLf Then
        LastDllErrorMsg = Left$(LastDllErrorMsg, Len(LastDllErrorMsg) - 2)
    End If

    ' Terminate description with a period if not.
    Select Case Right$(LastDllErrorMsg, 1)
    Case ".", "?", "!"
        ' this case not very locale friendly
    Case Else
        LastDllErrorMsg = LastDllErrorMsg & "."
    End Select

ExitLabel:
    ' Restore Err.LastDllError value is it was on entry
    SetLastError PreservedDllErr
    
    Debug.Assert (Err.Number = 0)
    
End Function

Public Function TrimNulls(InString As String) As String
'===========================================================================
'   TrimNulls - Trims null terminators from a string.
'
'   InString        The string to strip nulls from.
'
'   RETURNS         The resulting string.
'===========================================================================
Dim Pos     As Long     ' location of null terminator

    Pos = InStr(InString, Chr$(0))              ' find null terminator
    If Pos > 0 Then                             ' terminator located
        TrimNulls = Left$(InString, Pos - 1)    ' strip terminator
    Else                                        ' no terminator found
        TrimNulls = InString                    ' return the supplied input string
    End If
    
End Function

Public Function FormatMessage(ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

    If IsWinNt Then                             ' running on WinNT use WIDE calls
        FormatMessage = FormatMessageW(dwFlags, ByVal lpSource, dwMessageId, dwLanguageId, StrPtr(lpBuffer), nSize, Arguments)
    Else                                        ' running on Win95 use ANSI calls
        FormatMessage = FormatMessageA(dwFlags, ByVal lpSource, dwMessageId, dwLanguageId, lpBuffer, nSize, Arguments)
    End If

End Function

Public Function IsWinNt() As Boolean
'===========================================================================
'   IsWinNT - Returns true if we're running Windows NT.
'===========================================================================
    
    ' NOTE: OSVERSIONINFO is defined at the module
    ' for imporved performance.
    
    If OSVersion.dwOSVersionInfoSize = 0 Then               ' this is our first time making this call
        OSVersion.dwOSVersionInfoSize = Len(OSVersion)      ' initialize so API knows which version being used
        GetVersionEx OSVersion                              ' make the call once & then save/re-use it
    End If

    IsWinNt = OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT ' return the result
    
End Function




c0Title: Implement a For Each...Next Statement against a Collection Class
c1Code:
Most of the time, we take for granted the For Each...Next loop, which iterates the members of an array or a collection. It's the fastest, most efficient method of visiting all the members of the collection or array, and we could care less that, as it enumerates the collection, the unseen code is actually generating new references to members of the collection with each iteration of the loop. However, as the provider of a collection class, it is up to you to provide an interface that the For Each...Next statement can work with. 
This may sound a little daunting, but you'll be pleasantly surprised how easy it is to implement a property that enumerates members of the collection within your class. First of all, you must create a Property Get procedure called NewEnum with the type of IUnknown. Its syntax is always the same: 


     Public Property Get NewEnum() As IUnknown
        Set NewEnum = mCol.[_NewEnum]
     End Property

where mCol is the name of your private collection object variable. 

Second, set the Procedure ID for this Property Get procedure to -4. To do this, select the Procedure Attributes option from the Tools menu, then click the Advanced button on the Procedure Attributes dialog. Enter a Procedure ID of -4. You should also check the "Hide this member" option to prevent the property from appearing in the IntelliSense drop down. 



c0Title: Implement an Exists Method within a Collection Class
c1Code:
One of my long standing gripes about the Collection object is the complete absence lack of an easy method to determine whether the member you're looking for exists within the collection. Therefore, when I'm writing a wrapper class for a collection, I always include my own. 
However, I add a little more to the method than simply determining if the member exists in the collection. If the member is not found within the collection, I attempt to add it to the collection. This way, I can simplify the code at the client end by always calling the Exists method prior to assigning the member to a local object variable. Therefore, I know that if the Exists method returns true, I can safely go on to assign the member to the local object variable. 

The code for a typical Exists method is shown below: 


     Public Function Exists(sDomainName As String) As Boolean
   
        On Error GoTo Exists_Err
   
        Dim oTemp As Domain
        Set oTemp = mcolDomains.Item(sDomainName)
        Exists = True
        Set oTemp = Nothing
        Exit Function
    
     TrytoGet:
         If Not LoadDomain(sDomainName) Then
             Exit Function
         Else
            Exists = True
         End If
         Exit Function
    
     Exists_Err:
         If Err.Number = 5 Then
             Resume TrytoGet
         Else
         'further error handling here for other error types
         End If
        
     End Function

As you can see, the idea is to test for the presence of a particular member of the collection by attempting to assign it to a temporary local object variable. If the member is not present, then error 5 ("Invalid Procedure Call or Argument") is raised. Trapping this, program flow proceeds to the LoadDomain function, which attempts to load the member into the collection. 

The new VB6 Dictionary object (found in the Scripting Runtime Library) contains its own built-in Exists property. The custom Exists method for the collection object can therefore be cut down dramatically but still achieve the same results, as the following method illustrates: 


     Public Function Exists(sDomainName As String) As Boolean 
         If mdicWebsites.Exists(sDomainName) Then
             Exists = True
         Else
             Exists = GetWebsite(sDomainName)
         End If
     End Function

Whether you're using the (now old fashioned) Collection object or the (new and fast) Dictionary object, your client code is identical, as the following fragment shows: 


     Private Sub cboDomainName_Click()
         If moWebsites.Exists(cboDomainName.Text) Then
             Set moWebsite = moWebsites.Website(cboDomainName.Text)
         End If
     End Sub


c0Title: Improved DoEvents For NT Users
c1Code:
DoEvents was great to keep a tight process from hogging the system, but in NT 4.0 if you check you'll find your CPU usage going to 100 percent quick.

Try adding a line with Sleep 1 after DoEvents to your tight loops, this will only cost you 1 ms and if you just call the sleep command every 150 or 200 passes, it doesn't cost you much. On my PC the procedure below shows 1% or less change to my CPU usage. If you REM out the sleep line CPU usage hits 100% quick.

Declare

Private Declare Sub Sleep Lib "Kernel32" (ByVal dwmilliseconds As Long)

Sample Code

Private Sub Command1_Click()

Dim iCounter As Integer

    Do

        'Your Process

        For iCounter = 1 To 10000

            DoEvents

            ' 200 seems like a good value to ensure

            ' min. slow down with min. load on CPU usage

            ' according to NT 40's Task Manager

            ' the next line will cost you t ms for every

            ' 200 passes

            If iCounter Mod 200 = 0 Then

                Sleep 1

            End If

        Next

    Loop

End Sub

Tip Submitted By: Jim Lewey

Editors Note: On my NT machine, calling Sleep after every 200 loops put my CPU usage to about 92%. I dropped it to 10 and my usage went to 1%. Just beware of this... your mileage might vary.


c0Title: Insert an Element Into an Array without Looping
c1Code:
Author: Jason Thorn  
Category: Lists, Collections, and Arrays  
Type: Snippets  
Difficulty: Advanced  


Version Compatibility:  Visual Basic 5   Visual Basic 6    


More information: Use the example below to allow you to insert one or more elements into the middle of an array without the need to loop through each element in the array. You can modify the routine to support any structure or variable type by simply changing the declaration. This can improve performance when manipulating large arrays. 

Thanks to Davide Di Loreto for helping to debug this code. 

This code has been viewed 24664 times. 

Instructions: Copy the declarations and code below and paste directly into your VB project. 


Option Explicit

Public Type TestType2
    lVal As Long
    bVal As Boolean
End Type

Public Type TestType
    lValue As Long
    sValue As String
    bBool As Boolean
    tVal As TestType2
End Type

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

Private m_arrTypes() As TestType

Public Sub InsertByPtr(pArray() As TestType, ByVal StartIndex As Long, Optional ByVal NumElements As Long = 1)
    Dim lSize As Long, lBase As Long
    Dim lMemSize As Long
    Dim tempBytes() As Byte

    ' Stupidity Check
    If NumElements < 1 Then Exit Sub
    
    ' Get the Array Size
    lBase = LBound(pArray)
    lSize = (UBound(pArray) - (lBase - 1))

    ' Stupidity Check
    If StartIndex < lBase Or (StartIndex + NumElements) > lSize Then
        ' Subscript out of range
        Err.Raise 9
    ElseIf (StartIndex + NumElements) = lSize Then
        ' Increase the size by NumElements
        ReDim Preserve pArray(lBase To (lSize - lBase - 1) + NumElements)
        Exit Sub
    End If
    
    ' Get the size of the element type passed in
    lMemSize = LenB(pArray(lBase))
    
    ' Create a Temporary storage area for the new element(s)
    ReDim tempBytes(1 To (NumElements * lMemSize)) As Byte

    ' Increase the size by NumElements
    ReDim Preserve pArray(lBase To (lSize - lBase - 1) + NumElements)
    
    ' Move the elements in memory
    Call CopyMemory(ByVal VarPtr(pArray(StartIndex)) + (NumElements * lMemSize), _
                    ByVal VarPtr(pArray(StartIndex)), _
                    (lSize - StartIndex) * lMemSize)
    
    ' Copy uninitialized data to the new elements
    Call CopyMemory(ByVal VarPtr(pArray(StartIndex)), tempBytes(1), NumElements * lMemSize)
End Sub

Public Sub DeleteByPtr(pArray() As TestType, ByVal StartIndex As Long, Optional ByVal NumElements As Long = 1)
    Dim lSize As Long, lBase As Long
    Dim lMemSize As Long
    Dim tempBytes() As Byte

    ' Stupidity Check
    If NumElements < 1 Then Exit Sub
    
    ' Get the Array Size
    lBase = LBound(pArray)
    lSize = (UBound(pArray) - (lBase - 1))

    ' Stupidity Check
    If StartIndex < lBase Or (StartIndex + NumElements) > lSize Then
        ' Subscript out of range
        Err.Raise 9
    ElseIf (StartIndex + NumElements) = lSize Then
        ' Decrease the size by NumElements
        ReDim Preserve pArray(lBase To (lSize - lBase - NumElements - 1))
        Exit Sub
    End If
    
    ' Get the size of the element type passed in
    lMemSize = LenB(pArray(lBase))
    
    ' Create a Temporary storage area for the moved element(s)
    ReDim tempBytes(1 To (lMemSize * NumElements)) As Byte
    
    ' Copy the elements we are going to remove to temporary storage
    Call CopyMemory(ByVal VarPtr(tempBytes(1)), _
                    ByVal VarPtr(pArray(StartIndex)), _
                    lMemSize * NumElements)
    
    ' Move the elements in memory
    Call CopyMemory(ByVal VarPtr(pArray(StartIndex)), _
                    ByVal VarPtr(pArray(StartIndex)) + (NumElements * lMemSize), _
                    (lSize - (StartIndex + 1)) * lMemSize)
    
    ' Copy Temporary storage data to the end elements so VB will release the memory properly.
    Call CopyMemory(ByVal VarPtr(pArray(lSize - lBase - 1)) - (lMemSize * (NumElements - 1)), tempBytes(1), lMemSize * NumElements)
    
    ' Decrease the size by NumElements
    ReDim Preserve pArray(lBase To (lSize - lBase - NumElements - 1))
End Sub
' Example Usage
Public Sub Main()
    Dim lCount As Long
    
    ReDim m_arrTypes(0 To 9) As TestType
    
    Debug.Print "Original Array:"
    For lCount = LBound(m_arrTypes) To UBound(m_arrTypes)
        m_arrTypes(lCount).lValue = lCount
        m_arrTypes(lCount).sValue = "Value " & lCount
        Debug.Print "--- Element " & lCount
        Debug.Print "------ lValue: " & m_arrTypes(lCount).lValue
        Debug.Print "------ sValue: " & m_arrTypes(lCount).sValue
        Debug.Print "------ bBool: " & m_arrTypes(lCount).bBool
    Next
    Debug.Print: Debug.Print
    
    Call InsertByPtr(m_arrTypes(), 5, 2)
    
    m_arrTypes(5).lValue = 10
    m_arrTypes(5).sValue = "Value 10"
    m_arrTypes(5).bBool = True
    
    m_arrTypes(6).lValue = 11
    m_arrTypes(6).sValue = "Value 11"
    m_arrTypes(6).bBool = True
    
    Debug.Print "New Array:"
    For lCount = LBound(m_arrTypes) To UBound(m_arrTypes)
        Debug.Print "--- Element " & lCount
        Debug.Print "------ lValue: " & m_arrTypes(lCount).lValue
        Debug.Print "------ sValue: " & m_arrTypes(lCount).sValue
        Debug.Print "------ bBool: " & m_arrTypes(lCount).bBool
    Next
    
    Call DeleteByPtr(m_arrTypes(), 7)

    Debug.Print: Debug.Print
    Debug.Print "New Array:"
    For lCount = LBound(m_arrTypes) To UBound(m_arrTypes)
        Debug.Print "--- Element " & lCount
        Debug.Print "------ lValue: " & m_arrTypes(lCount).lValue
        Debug.Print "------ sValue: " & m_arrTypes(lCount).sValue
        Debug.Print "------ bBool: " & m_arrTypes(lCount).bBool
    Next
End Sub

 


c0Title: Insertion Sort (Stable, Non-Recursive)
c1Code:
The insertion sort is the exact opposite of the selection sort. Instead of selecting a position then finding the value which fits, we instead select a value and then find a position for it within the other sorted values. Any values which are in the way are shifted one by one. The number of sorted elements gradually increases until the whole array is sorted.

Example:

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

[6][7,9,3,2,5]
    ^ Where does this value go in [6]?
[6,7][9,3,2,5]
      ^ Where does this value go in [6,7]?
[6,7,9][3,2,5]
        ^ Where does this value go in [6,7,9]?
[3,6,7,9][2,5]
          ^ Where does this value go in [3,6,7,9]?
[2,3,6,7,9][5]
            ^ Where does this value go in [2,3,6,7,9]?

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


Once more, nested loops are the order of the day.


VB: 
--------------------------------------------------------------------------------
Public Sub InsertionSort(ByRef lngArray() As Long)
    Dim iOuter As Long
    Dim iInner As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    
    For iOuter = iLBound + 1 To iUBound
        
        'Get the value to be inserted
        iTemp = lngArray(iOuter)
        
        'Move along the already sorted values shifting along
        For iInner = iOuter - 1 To iLBound Step -1
            'No more shifting needed, we found the right spot!
            If lngArray(iInner) <= iTemp Then Exit For
            
            lngArray(iInner + 1) = lngArray(iInner)
        Next iInner
        
        'Insert value in the slot
        lngArray(iInner + 1) = iTemp
    Next iOuter
End Sub

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


c0Title: ADO: Instant Recordset Contents With the GetString Method
c1Code:
The GetString method replaces a pair of nested loops. If the defaults are acceptable, you can use the method without any arguments. This makes for a simple way to extract values from a recordset. Although nested loops can help you grasp how the columns within a row combine, the GetString method can achieve a similar result in single line. It accomplishes this without even one loop, whereas you need two loops to enumerate the columns within a row automatically.

The GetString method, which returns a recordset as a string, can take up to five arguments. This sample illustrates the use of three of those arguments. Designate the adClipString constant as the first argument, which is your only choice for this argument. It specifies the format for representing the recordset as a string. The second argument specifies the number of recordset rows to return�five, in this case. Leaving this argument blank would enable the method to return all the rows in the recordset. The third argument designates a semi-colon delimiter for the columns within a row (the default column delimiter is a tab): 

 
Sub NoEasyLoop()
     Dim rsCustomers As Recordset
     Set rsCustomers = New ADODB.Recordset
     rsCustomers.Open "customers", _
          "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=C:\Program Files\" & _
          "Microsoft Office\Office\" & _
          "Samples\Northwind.mdb;"
     ' Print records without a loop
     Debug.Print _
          rsCustomers.GetString( _
          adClipString, 5, "; ")
     rsCustomers.Close
End Sub
 
The fourth and fifth arguments, neither of which appears in the sample, specify a column delimiter and an expression to represent null values. The default values for these arguments are a carriage return and a zero-length string.

�Rick Dobson, Louisville, Kentucky


c0Title: Intercepting MouseEnter and MouseExit events without subclassing
c1Code:
I have seen several third-party controls that augment VB with the capability to detect when the mouse enters or leaves a control's area. The following tip shows that you need just a couple of API functions to reach the same result, and you don't even need any subclassing. 

Here's the tip: 

Visual Basic raises a MouseMove event when the mouse cursor is within a control, so it's easy to know when the cursor "enters" a control. However, determining when the mouse leaves the control is more difficult. You can solve this problem by monitoring the first time the control raises the MouseMove event, which in a sense corresponds to the missing MouseEnter event. in this occasion you "capture" the mouse with the SetCapture API function, so that your control will receive MouseMove messages even if the cursor is outside the control's window. 

Once you have captured the mouse input you can check the coordinates of the cursor and verify if it's still in the control area. When mouse leaves the control's window, it's time for the MouseExit event, and you must release the mouse capture with ReleaseCapture(). Here's the code that does the trick for the Command1 control, but it can be easily modified for any control: 


Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long 
Private Declare Function GetCapture Lib "user32" () As Long

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

    If (X < 0) Or (Y < 0) Or (X > Command1.Width) _
        Or (Y > Command1.Height) Then
        ' the MOUSELEAVE pseudo-event
        ReleaseCapture
        ' in this example revert the caption to normal
        Command1.Font.Bold = False
        
    ElseIf GetCapture() <> Command1.hwnd Then
        ' the MOUSEENTER pseudo-event
        SetCapture Command1.hwnd
        ' in this example, make the caption bold
        Command1.Font.Bold = True
    End If
End Sub


You can apply this technique to all controls that have the hWnd property, such as PictureBox, ListBox, etc., to easily implement hot-tracking effects. Here is another example that selects the text of a textbox (Text1) when the cursor is over that control. 


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

    If (X Or Y) < 0 Or (X > Text1.Width) Or (Y > Text1.Height) Then
        ReleaseCapture
        Text1.SelLength = 0
    ElseIf GetCapture() <> Text1.hWnd Then
        SetCapture Text1.hWnd
        Text1.SelStart = 0
        Text1.SelLength = Len(Text1)
        Text1.SetFocus
    End If
End Sub


     



c0Title: Is a Printer Installed?
c1Code:
When you're using the printer, ensure you don't make the fatal error of presuming your user actually has one.

It doesn't matter whether you�re doing a simple PrintForm or creating a mini word processor that uses the Printer object. If there's no printer, you�re out of luck.

This sneaky code snippet allows you to find out whether a printer is installed.

It works by attempting to retrieve the device name from the Printer object. If an error is registered, there is no printer and PrinterInstalled returns a False. If everything is A-OK, the function returns a True.

Usage

x = PrinterInstalled
Code

Public Function PrinterInstalled() As Boolean

    On Error Resume Next
    
    Dim strDummy As String
    strDummy = Printer.DeviceName
    
    If Err.Number Then
        PrinterInstalled = False
    Else
        PrinterInstalled = True
    End If
    
End Function
Tip by Karl Moore


c0Title: Iterate Control Arrays Without Error
c1Code:
Control arrays are odd beasts in that they can have missing ele-ments.
The simplest way to iterate a control array uses this method:

Dim i As Integer
For i = Text1.LBound To Text1.UBound ...

However, if you have holes in your array, that method tosses an error. To avoid that eventuality, treat the array like a collection:

Dim txt As TextBox
For Each txt In Text1
	txt.Text = "Hello, World!, My Index is " & txt.Index Next txt

�Guy Dafny, Tel Aviv, Israel


c0Title: JPG Control
c2File: savejpeg.zip
c1Code:
Intel freely provides a free DLL that provides a mechinism for quickly loading and saving JPG images. This DLL, along with some sample code available on the web, was modifed to easily allow you to load a JPG into a PictureBox, or save a PictureBox as a JPG.

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


c0Title: Keeping A Form On Top Of A Window
c1Code:
This is a how to keep a VB form window always on top, but only of the selected window, not above ALL windows. Instead of SetWindowPos, it uses SetWindowWord. This lets you create a floating toolbar that stays above its app's window without staying on top of ALL windows. Very handy for that professional look.

Declare Sub SetWindowWord Lib "USER" (ByVal hWnd, ByVal nCmd, ByVal nVal) 
Const SWW_hParent = (-8)

Form_Load of the form that you want to teep on top. Set it about form1.

Sub Form_Load () 
     SetWindowWord hWnd, SWW_hParent, form1.hWnd 
End Sub

Form_Unload of the from you want to keep on top this is for cleaning up.

Sub Form_Unload (Cancel As Integer) 
     SetWindowWord hWnd, SWW_hParent, 0 
End Sub

Tip Submitted By: Jonathon Twigg

 


c0Title: Large Library of Cryptographic Algorithms for VB Version 2.0
c2File: VBCrypto.zip
c1Code:
More information: A well compiled archive of 15 popular encryption algorithms (Blowfish, Twofish, Rijndael, Skipjack, Serpent, Gost, RC2, RC4, TEA, DES, 3DES, 3DES112, DESE, CAST5, IDEA), 6 popular one-way hash algorithms (MD2, MD4, MD5, SHA, SHA256, RipeMD) and a huffman compression algorithm. Extremely useful library for use in literally any type of VB project that calls for cryptography. The archive's website is at http://www.verino.com/~fyool2000/crypto/index.html. 

Updates in version 2.0 (02/01/03): New features in this library include Base 64 encoding instead of Hexadecimal encoding (which is far more efficient), fixed key initialization functions (that many users complained about), the updated EBCrypt library, a couple CryptoAPI demonstrations from other authors, the inclusion of several classical ciphers, and an HTML page of crypto links.


c0Title: Launching HTML Help
c1Code:
Need to launch a HTML help file direct from your application?

This sneaky code snippet handles it all for you, opening at just the right topic. It will also close the help file when the launching application quits.

To use, call our LaunchHTMLHelp function, passing the path of your help file, an optional window handle (such as Form1.hWnd - when this is closed, the help file also closes), plus an optional help file topic number.

The function returns a True or False success value.

Sample Usage

x = LaunchHTMLHelp("c:\myhelp.chm", Form1.hWnd, 5124)
Code

Public Const HH_DISPLAY_TOPIC = &H0
Public Const HH_HELP_CONTEXT = &HF

Public Declare Function HtmlHelp Lib "Hhctrl.ocx" _
    Alias "HtmlHelpA" (ByVal hWndCaller As Long, _
    ByVal pszFile As String, ByVal uCommand As Long, _
    ByVal dwData As Long) As Long

Public Function LaunchHTMLHelp(HelpFile As String, _
    Optional WindowHandle As Long, Optional Topic As Long) As Boolean

    'HelpFile - the path to your HTML help file.
    'WindowHandle - an optional handle to the window
    '               that the help stems from. When
    '               that window is closed, help will
    '               also close (only when compiled).
    'Topic - the help topic number you wish to call from
    '        your help file, if any. AKA context number.

    Dim lngReturn As Long

    If Len(Dir(HelpFile)) > 0 Then
        
        If Topic = 0 Then
            lngReturn = HtmlHelp(WindowHandle, HelpFile, HH_DISPLAY_TOPIC, 0)
        Else
            lngReturn = HtmlHelp(WindowHandle, HelpFile, HH_HELP_CONTEXT, Topic)
        End If
        
        LaunchHTMLHelp = CBool(lngReturn)
    
    End If

End Function
Tip by Karl Moore


c0Title: Let Users Resize Your Controls
c1Code:
You can allow users to resize a control�just like in VB design mode�with a mouse, using two simple API calls. You can resize the control�top-left, top, top-right, left, right, bottom-left, bottom, and right. When you make ranges for the mouse coordinates (such as x>0 and x<100), the MouseDown event activates the API functions and sizes your picture box when the mouse moves. This code assumes you have a picture box on the form:

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

Private Const WM_NCLBUTTONDOWN = &HA1

' You can find more of these (lower) in the API Viewer. Here 
' they are used only for resizing the left and right.

Private Const HTLEFT = 10
Private Const HTRIGHT = 11

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

       Dim nParam As Long

       With Picture1

             ' You can change these coordinates to whatever 
             ' you want
             If (X > 0 And X < 100) Then
                    nParam = HTLEFT
             ElseIf (X > .Width - 100 And X < .Width) Then 
             ' these too
                    nParam = HTRIGHT
             End If

             If nParam Then
                    Call ReleaseCapture
                    Call SendMessage(.hWnd, _
                           WM_NCLBUTTONDOWN, nParam, 0)
             End If
       End With
End Sub

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

       ' You can change these coordinates to whatever you want
       If (X > 0 And X < 100) Then
             NewPointer = vbSizeWE
       ElseIf (X > Picture1.Width - 100 And X < _
              Picture1.Width) Then ' these too
             NewPointer = vbSizeWE
       Else
             NewPointer = vbDefault
       End If

       If NewPointer <> Picture1.MousePointer Then
              Picture1.MousePointer = NewPointer
       End If
End Sub

�Fran Pregernik, Zagreb, Croatia


c0Title: Leverage Office to Spellcheck RichText
c1Code:
Integrate Microsoft Word 97�s spellchecking capability into VB apps while maintaining formatting within a rich textbox. To test this code:

1. Create a standard EXE project in VB.
2. Add the RichTextBox control from the Components menu.
3. Add a reference to the Microsoft Word 8.0 Object Library.
4. Drop a RichTextBox and a CommandButton onto the form.
5. Rename the RichTextBox to rtfText.
6. Change the caption of the CommandButton to Spell Check.
7. In the Click event of the CommandButton, add the next code listing.
8. Save and run the project.
9. Type some text in the RTF box and click on the CommandButton to check the spelling.
On Error GoTo SpellCheckErr

     Dim oWord As Object
 
     Set oWord = CreateObject("Word.Application")
 
     'Save the RTF Box contents to a temporary file
     rtfText.SaveFile "C:\TEST.RTF", rtfRTF
 
     'Open the saved document and spellcheck it
     oWord.Documents.Open ("C:\TEST.RTF")
     oWord.ActiveDocument.SpellingChecked = False
     oWord.Options.IgnoreUppercase = False
     oWord.ActiveDocument.CheckSpelling
 
     'Save the changes to the RTF file & close
     oWord.ActiveDocument.Save
     oWord.ActiveDocument.Close
     oWord.Quit
 
     'Load the changes back to the rtf text box.
     rtfText.LoadFile "C:\TEST.RTF", rtfRTF
 
     Set oWord = Nothing
     Screen.MousePointer = vbDefault
     MsgBox "Spell Check is complete", _
          vbInformation, "Spell Check"
     Exit Sub
 
SpellCheckErr:
     MsgBox Err.Description, vbCritical, _
          "Spell Check"
     Set oWord = Nothing
 
�Rohit Kapoor, Gaithersburg, Maryland


c0Title: Access: Limit Form Textbox's Text Length
c1Code:
There is a little known and undocumented method for limiting the number of
Input characters in an Access Text Box using the API, here it goes:

Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lngValue As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long

Private Const EM_SETLIMITTEXT As Long = &HC5


Code: ( text )


Private Sub LimitChars(txt As Textbox, lngLimit As Long)
	Dim hWnd As Long
	Dim lngResult As Long
	Dim lngNewMax As Long
 
	'Get Window Handle for the current Window
	hWnd = GetFocus()
 
	'Check for existing length of Text and adjust lngLimit
	lngNewMax = Len(txt.Text)

	If lngNewMax < lngLimit Then
	    lngNewMax = lngLimit
	End If
 
	'Send the Message to the Text Box to limit itself to lngNewMax _
	'characters
	SendMessageLong hWnd, EM_SETLIMITTEXT, lngNewMax, 0
End Sub


NOTE: As always, when using the API, the syntax must be exact. 
Hook the code in the Change() Event of the Text Box


c0Title: Limit User Typing in Combo Box
c1Code:
VB4 32, VB5, VB6

The standard textbox has a MaxChars property that lets you limit the number of characters a user can type into it. The drop-down combo does not, but you can emulate this property setting with a simple API call:

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const CB_LIMITTEXT = &H141

Private Sub Form_Load()
	Const Max_Char = 24
	Call SendMessage(Combo1.hWnd, _
	CB_LIMITTEXT, Max_Char, 0&)
End Sub

Editor�s Note: This tip works in 16-bit versions of VB as well, but you�ll need to substitute the correct 16-bit declarations for SendMessageandCB_LIMITTEXT.

�Jim Deutch, Syracuse, New York


c0Title: Limitations on WithEvents Variables
c1Code:
You should be aware of the following limitations on the use of WithEvents variables: 
? A WithEvents variable cannot be a generic object variable. That is, you cannot declare it As Object - you must specify the class name when you declare the variable.
� You cannot declare a WithEvents variable As New. The event source object must be explicitly created and assigned to the WithEvents variable.
� You cannot declare WithEvents variables in a standard module. You can declare them only in class modules, form modules, and other modules that define classes.
� You cannot create arrays of WithEvents variables.


c0Title: Limiting length in combo/text edit control
c1Code:
iRes=sendmessage(txt1.hwnd,EM_LIMITTEXT,0,LEN_OF_FIELD) 
iRes=sendmessage(cbo1.hwnd,CB_LIMITTEXT,0,LEN_OF_FIELD)


c0Title: Link List Contents to ListIndex in Another List
c1Code:
I recently needed to create two listboxes, where the items displayed in the second listbox depend upon the item selected in the first listbox. After seeing the amount of code it took to do this using standard arrays, I came up with a better solution using array functions that reduced the amount of code by half. As an added benefit, using array functions makes it easy to add items to the listboxes�you don�t need to modify any array dimensions, which makes the code much less error-prone. For example, to add the item �Candy Bars� to the first listbox, simply insert the subarray into the main array; nothing else is needed:

 

Array(3, "Candy Bars", "Milky Way", "Baby Ruth", _

     "Almond Joy")

 

The code uses one subarray for each item in the first listbox. The elements of each subarray are the number of items for the second listbox, followed by the item for the first listbox, followed by the items for the second listbox.

     To test the code, start a Standard EXE project and put two listboxes on the form, keeping the default names of List1 and List2:

 
Option Explicit
 
Private varArray As Variant
Private varSubArray As Variant
 
Private Sub Form_Initialize()
     varArray = Array(Array(4, "Fruit", "Apples", _
          "Oranges", "Peaches", "Pears"), Array(5, _
          "Vegetables", "Peas", "Beans", "Corn", _
          "Beets", "Onions"), Array(3, _
          "Dairy Products", "Milk", "Cream", _
          "Butter"))
End Sub
 
Private Sub Form_Load()
     Dim intIndex1 As Integer
     With List1
          For intIndex1 = 0 To UBound(varArray)
               varSubArray = varArray(intIndex1)
               .AddItem varSubArray(1)
          Next intIndex1
          .ListIndex = 0
     End With
End Sub
 
Private Sub List1_Click()
     Dim intIndex2 As Integer
     With List2
          varSubArray = varArray(List1.ListIndex)
          .Clear
          For intIndex2 = 0 To varSubArray(0) - 1
               .AddItem varSubArray(intIndex2 + 2)
          Next intIndex2
          .ListIndex = 0
          .Refresh
     End With
End Sub
 
This code works with VB5 and VB6, and should work with any version that supports the Array function.

�Paul Carlson, Fort Collins, Colorado


c0Title: List All Files in a Folder Structure Using FileSystemObject
c1Code:
'Get all files in a folders and all subfolders
'Returns them as an array. If the folder doesn't exist or no files are found
'a single null string element is returned
'Requires a reference to Microsoft Scripting Runtime
'
Public Function FolderGetFiles(Path As String) As String()
    
    Const ArrayBlockSize = 2
    Dim Folders() As String
    Dim Files() As String
    
    Dim FSO As FileSystemObject
    
    Dim FolderCount As Long
    Dim FolderIndex As Long
    Dim NextPath As String
    Dim objFiles As Files
    Dim objFile As File
    Dim objFolders As Folders
    Dim objFolder As Folder
    Dim FileNamesCount As Long
    
    FolderIndex = 1
    FolderCount = 1
    FileNamesCount = 0
    
    Set FSO = New FileSystemObject
    
    If (FSO.FolderExists(Path) = False) Then
        ReDim FolderGetFiles(0)
        Exit Function
    End If
    
    ReDim Folders(1 To ArrayBlockSize)
    ReDim Files(1 To ArrayBlockSize)
    
    Folders(FolderIndex) = Path
    
    Do
        Set objFolders = FSO.GetFolder(Folders(FolderIndex)).SubFolders
        For Each objFolder In objFolders
            FolderCount = FolderCount + 1
            
            If FolderCount > UBound(Folders) Then
                ReDim Preserve Folders(1 To FolderCount + ArrayBlockSize)
            End If
            
            Folders(FolderCount) = objFolder.Path
        Next
        
        Set objFiles = FSO.GetFolder(Folders(FolderIndex)).Files
        For Each objFile In objFiles
            
            FileNamesCount = FileNamesCount + 1
            
            If FileNamesCount > UBound(Files) Then
                ReDim Preserve Files(1 To FileNamesCount + ArrayBlockSize)
            End If
            
            Files(FileNamesCount) = objFile.Path
        Next
        
        FolderIndex = FolderIndex + 1
        
    Loop Until FolderIndex > FolderCount
    
    If FileNamesCount > 0 Then
        ReDim Preserve Files(1 To FileNamesCount)
        FolderGetFiles = Files
    Else
        ReDim FolderGetFiles(0)
    End If
    
End Function


c0Title: ADO: List All Row-Returning Objects With adSchemaTables
c1Code:
The Connection object�s OpenSchema method permits your application to browse the collections available through an ADO connection without enumeration. The method returns a recordset with fields characterizing the members of a collection. The output from the OpenSchema method with an adSchemaTables query type against the Jet 4.0 data provider contains information about local tables, linked tables, pass-through queries, system tables, and the Access table. You can specify any of more than 30 query type arguments to gather information about the contents of an OLE DB data source. Besides the adSchemaTables query type, selected others return information about familiar database objects such as check constraints, indexes, primary keys, foreign keys, procedures, and views. This listing reveals how you can use the OpenSchema method with the Jet 4.0 provider to list the views available through a connection:
 
Public Sub OpenSchemaX()
     Dim cnn1 As New ADODB.Connection
     Dim rstSchema As ADODB.Recordset
     cnn1.Open _
          "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=C:\Program Files\" & _
          "Microsoft Office\Office\" & _
          "Samples\Northwind.mdb;"
     Set rstSchema = _
          cnn1.OpenSchema(adSchemaTables)
     ' Print just views; other selection criteria 
     ' include TABLE, LINK, PASS-THROUGH, ACCESS 
     ' TABLE, and SYSTEM TABLE
     Do Until rstSchema.EOF
          If rstSchema.Fields("TABLE_TYPE") = _
               "VIEW" Then
               Debug.Print "View name: " & _
                    RstSchema.Fields("TABLE_NAME") & _
                    vbCr
          End If
          rstSchema.MoveNext
     Loop
     rstSchema.Close
     cnn1.Close
End Sub
�Rick Dobson, Louisville, Kentucky


c0Title: Load a Bitmap Resource From a DLL
c1Code:
You can employ any DLL�s bitmap resources in VB using this Load-Picture function. You need to set a reference to OLE Automation:
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function _
OleCreatePictureIndirect Lib _
"olepro32.dll" (PicDesc As PicBmp, RefIID _ As GUID, ByVal fPictureOwnsHandle As Long, _ IPic As IPicture) As Long Private Declare Function LoadBitmap Lib _ "user32" Alias "LoadBitmapA" (ByVal _ hInstance As Long, ByVal lpBitmapID As _
Long) As Long
Private Declare Function DeleteObject Lib _ "gdi32" (ByVal hObject As Long) 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 Public Function LoadPicture(sResourceFileName _ As String, lResourceId As Long) As Picture Dim hInst As Long Dim hBmp As Long Dim Pic As PicBmp Dim IPic As IPicture Dim IID_IDispatch As GUID Dim lRC As Long hInst = LoadLibrary(sResourceFileName) If hInst <> 0 Then hBmp = LoadBitmap(hInst, lResourceId) If hBmp <> 0 Then
IID_IDispatch.Data1 = &H20400
IID_IDispatch.Data4(0) = &HC0
IID_IDispatch.Data4(7) = &H46
Pic.Size = Len(Pic)
Pic.Type = vbPicTypeBitmap
Pic.hBmp = hBmp
Pic.hPal = 0
lRC = OleCreatePictureIndirect(Pic, _
IID_IDispatch, 1, IPic)
If lRC = 0 Then
Set LoadPicture = IPic
Set IPic = Nothing
Else
Call DeleteObject(hBmp)
End If
End If
Call FreeLibrary(hInst)
hInst = 0
End If
End Function
Private Sub Form_Load()
' Try ID 130 in Win98, or 131 in NT
' to see the Windows logo...
Set Me.Picture = _
LoadPicture("shell32.dll", 130)
End Sub
�Michael Hill, Northridge, California


c0Title: Load UI Graphics From the Resource File
c1Code:
Many VB programmers haven�t harnessed the power of VB6�s resource editor. They still use traditional LoadPicture or other primitive calls to load bitmaps and icons.  Before VB5, loading pictures into controls was somewhat harder, because of the inherent troubles associated with specifying the path and filename of the resource.With the resource editor, it�s easy to store icons, strings, and bitmaps in a single RES file. I had to load the same picture for several CommandButton controls in a current project. I set the Style property of the CommandButton to 1 (Graphical) and the Tag property to �calendar� so my app would know to load calendar.bmp. I then added and saved this BMP in a resource file and set the ID to �calendar.�

First paste this code into the general section of a form: 

 

'loads icons/bmps from resource files.
Sub FillPictures(psdFrm As Form)

       ' desired form is passed as an parameter.
       Dim lcl_Ctrl As Control

       For Each lcl_Ctrl In psdFrm.Controls

             ' controls collection is used here.
             If LCase(lcl_Ctrl.Tag) = "calendar" Then
	             ' checking the tag property.
                    Set lcl_Ctrl.Picture = LoadResPicture(lcl_ctrl.tag, vbResBitmap)
             End If

            ' extra code could have been added for 
             ' loading other picture files by setting 
             ' the tag property accordingly.
       Next
End Sub

 

Then call this function from the Form_Load event:

 

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

�Jishnu Bhattacharya, Jersey City, New Jersey


c0Title: Locate the Temp Folder
c1Code:
In your apps, do the right thing: Use the computer�s Temp folder to hold your temporary files. To find that location, paste this code into the Declarations section of a form: 

Private Declare Function GetTempPath Lib _
     "kernel32" Alias "GetTempPathA" (ByVal _
     nBufferLength As Long, ByVal lpBuffer As _
     String) As Long
Private Const MAX_PATH = 260
 
Public Property Get TempPathLocation() As String
     Dim sBuffer As String
     sBuffer = Space(MAX_PATH)
     If GetTempPath(MAX_PATH, sBuffer) <> 0 Then
          TempPathLocation = Left$(sBuffer, _
               InStr(sBuffer, vbNullChar) - 1)
     Else
          TempPathLocation = ""
     End If
End Property
 
This routine returns the computer�s established Temp folder. If none has been established, an empty string is returned, which may be interpreted as the current directory. Be sure to use Kill on all created temp files when you�re through with them.
�Robert Smith, Kirkland, Washington


c0Title: Look Up IP Address
c1Code:
This is a simple VB wrapper function for the Winsock API gethostbyname, but it can be rather useful. And, it's much cleaner than using the VB winsock control just to look up an IP address. 
        
      Code: 
     Option Explicit

Private Const WSADESCRIPTION_LEN = 256
Private Const WSASYS_STATUS_LEN = 128

Private Type HOSTENT
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Private Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(WSADESCRIPTION_LEN) As Byte
    szSystemStatus(WSASYS_STATUS_LEN) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal szName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequested As Integer, lpWSAData As WSADATA) As Long Private Declare Function WSACleanup Lib "wsock32.dll" () As Integer Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Function LookupIPAddress(ByVal sHostName As String) As String

    Dim wsa As WSADATA
    Dim nRet As Long
    Dim nTemp As Long
    Dim bTemp(0 To 3) As Byte
    Dim sOut As String
    Dim he As HOSTENT
    
    'Initialize WinSock
    WSAStartup &H10, wsa
        
    'Attempt to lookup the host
    nRet = gethostbyname(sHostName)
    
    'If it failed, just return nothing
    If nRet = 0 Then
        sOut = ""
    Else
        'Take a look at the resulting hostent structure
        CopyMemory he, ByVal nRet, Len(he)
        
        'Are there atlest four bytes, then we have
        ' at least one address
        If he.h_length >= 4 Then
            'Copy the address out,
            CopyMemory nTemp, ByVal he.h_addr_list, 4
            CopyMemory bTemp(0), ByVal nTemp, 4
            ' and format it
            sOut = Format(bTemp(0)) & "." & Format(bTemp(1)) & "." _
               & Format(bTemp(2)) & "." & Format(bTemp(3))
        Else
            sOut = ""
        End If
        
    End If
    
    WSACleanup

    LookupIPAddress = sOut

End Function
     
        
Sample Usage: 

        
Debug.Print LookupIPAddress("localhost")


c0Title: Loop on Non-Numeric Indices
c1Code:
You might occasionally need to execute a group of statements with different and unrelated values of a variable. For example, say you need to verify that a number isn�t a multiple of 2, 3, 5, 7, or 11. In these circumstances, you can�t use a regular For�Next loop, unless you store these values into a temporary array. Here�s a more concise solution:

Dim n As Variant 

For Each n In Array(2, 3, 5, 7, 11)
	If (TestNumber Mod n) = 0 Then 
		Print "Not prime"
		Exit For
	End If
Next
 

You can use the same technique to iterate on non-numeric values:


' check if a string embeds a shortened weekday name
Dim d As Variant 

For Each d In Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")

	If Instr(1, TestString, d, vbTextCompare) Then
		Print "Weekday = " & d
		Exit For
	End If
Next

�Francesco Balena, Bari, Italy


c0Title: Magnify the area under the mouse
c1Code:
Keywords mouse, magnify 
 
Thanks to Sergio Perciballi. 
When a Timer fires, the program grabs a copy of the desktop image, figures out where the mouse is, and copies the appropriate part of the desktop into a PictureBox at an enlarged scale. See the code for details. 

Use the scroll bar on the right to set the scale. 

 
'MagNifier by oigres P. Email oigres@postmaster.co.uk
'Based on the C++ tool Zoomin (Lupe?)
'New features :Resizeable form, new resolution, bug fix 12/sept/99
'All code written by oigres P.
'indented by indenter5 from http://www.BMSLtd.co.uk by Stephen Bullen
'
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private 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
 
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetPixel& Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, _
ByVal Y As Long)
 
Private Const HORZRES = 8
Private Const VERTRES = 10
 
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Const RDW_ERASE = &H4
Const RDW_INVALIDATE = &H1
Const SRCCOPY = &HCC0020
Const WM_PAINT = &HF
 
Dim frmH As Long, magnify As Integer, lastcpx, lastcpy
 
Private Sub Form_DblClick()
Unload Me
End Sub
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case Shift
    Case Shift And vbCtrlMask
        Select Case KeyCode
        Case vbKeyF1
            VScroll1.Value = 100
            'MsgBox "F1"
        Case vbKeyF2
            VScroll1.Value = 75
        Case vbKeyF3
            VScroll1.Value = 50
        Case vbKeyF4
            VScroll1.Value = 25
        Case vbKeyF5
            VScroll1.Value = 1
        End Select
    End Select
 
End Sub
 
Private Sub Form_Load()
   
    ret = SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
    Show
    Call VScroll1_Change
    
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
            X As Single, Y As Single)
    Dim lngReturnValue As Long
    'move the form if we click on in
    If Button = vbKeyLButton Then
        Call ReleaseCapture
        lngReturnValue = SendMessage(Form1.hwnd, WM_NCLBUTTONDOWN, _
                HTCAPTION, 0&)
    End If
End Sub
 
Private Sub Form_Resize()
    On Error GoTo errHandle
    'with setwindow rgn I got error (invalid value on vscroll1.height)
    Form1.Cls 'clear rubbish between labels when resize
    VScroll1.Left = Form1.ScaleWidth - VScroll1.Width
    VScroll1.Height = Form1.ScaleHeight - Label1.Height
    'resize picturebox to fill form
    Picture1.Left = 0: Picture1.Top = 0
    Picture1.ScaleWidth = Form1.ScaleWidth '- VScroll1.Width
    Picture1.ScaleHeight = Form1.ScaleHeight ' - Label1.Height
 
    Picture1.Width = Form1.ScaleWidth - VScroll1.Width
    Picture1.Height = Form1.ScaleHeight - Label1.Height
    
    Label1.Top = Form1.ScaleHeight - Label1.Height
    'magnification label
    Label2.Left = Form1.ScaleWidth - Label2.Width
    Label2.Top = Form1.ScaleHeight - Label2.Height
    'move red crosshair to middle
    Shape1.Left = (Form1.ScaleWidth \ 2) - (Shape1.Width \ 2)
    Shape1.Top = Form1.ScaleHeight - Shape1.Height
    'move colour patch to bottom and middle
    Shape2.Left = (Picture1.ScaleWidth \ 2) - (Shape2.Width \ 2)
    Shape2.Top = (Picture1.ScaleHeight \ 2) - (Shape2.Height \ 2)
    Exit Sub
errHandle:
    
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'see if we ant to clear the picture off the clipboard
    If Clipboard.GetFormat(vbCFBitmap) Then
        If MsgBox("Do you want to clear the clipboard?", vbYesNo, "Magnifier") = vbYes Then
            Clipboard.Clear
        End If
    
    End If
    'exit program
    Unload Me
    Set Form1 = Nothing ' delete variable object
End Sub
 
Private Sub Label1_Click()
    'display about info
    MsgBox "MagNifier by oigres P" & vbCrLf & _
            "Email: oigres@postmaster.co.uk", vbInformation, "MagNifier"
End Sub
 
Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyC) And (Shift = vbCtrlMask) Then
 
        'copy form to clipboard
        'Form1.AutoRedraw = True
        Picture1.Picture = Picture1.Image
        Clipboard.Clear
        Clipboard.SetData Picture1.Picture
        'Picture1.Picture = Clipboard.GetData
        MsgBox "Picture copied", , "MagNifier"
    End If
    'Form1.AutoRedraw = False
End Sub
 
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbKeyLButton Then
    Shape2.Visible = Not Shape2.Visible
End If
End Sub
 
Private Sub Timer1_Timer()
    Dim cp As POINTAPI 'cursor position
    Dim dsDC As Long, lpPT As POINTAPI
    Dim screenColour As Long
    GetCursorPos cp ' cp has cursor position assigned to it
    
    Label1.Caption = "X= " & cp.X & Space(6 - Len(CStr(cp.X))) & ":Y= " & cp.Y
 
    'check the screen size
    'get desktop device context- to copy from
    dsDC = GetDC(0&)
    screenColour = &HFFFFFF And GetPixel(dsDC, cp.X, cp.Y)
    Shape1.FillColor = screenColour
    Form1.Caption = "MagNifier - " & Hex(screenColour)
    'get screen width, height
    hr = GetDeviceCaps(dsDC, HORZRES)
    vr = GetDeviceCaps(dsDC, VERTRES)
 
    dshwnd = GetDesktopWindow()
    '      vscroll1=1..100 so 1/100=.1; 100/100=1;New Resolution
    Percent = VScroll1.Value / 100
    'new zoom size
    lengthx = (Form1.ScaleWidth - VScroll1.Width) * Percent
    lengthy = (Form1.ScaleHeight - Label1.Height) * Percent
    'center image about mouse
    offsetx = lengthx \ 2
    offsety = lengthy \ 2
    'actual area to blit to
    blitareax = Form1.ScaleWidth - VScroll1.Width
    blitareay = Form1.ScaleHeight - Label1.Height
    
    'stop copying the screen off the edges <0 and  >horzres
    'Store the last cursor position that were valid
    If cp.X - offsetx >= 0 And cp.X + offsetx < hr Then '800=screen width
        lastcpx = cp.X
        'Debug.Print "X= " & cp.X
     End If
     If cp.Y - offsety >= 0 And cp.Y + offsety < vr Then '600= screen height
        'Debug.Print "Y= " & cp.Y
          lastcpy = cp.Y  '                dest hdc ,destx,desty,width,height, sourceDC, source x,sourcey,sourcewidth,sourceheight,raster operation
            'ret = StretchBlt(Form1.hdc, 0, 0, blitareax, blitareay, dsDC, cp.X - offsetx, cp.Y - offsety, lengthx, lengthy, SRCCOPY)
    End If
    '
    '                destination dc                       , source dc
    ret = StretchBlt(Picture1.hdc, 0, 0, blitareax, blitareay, dsDC, lastcpx - offsetx, lastcpy - offsety, lengthx, lengthy, SRCCOPY)
    Picture1.Refresh
    ''Picture1.Line (0, (Picture1.ScaleHeight \ 2))-(Picture1.ScaleWidth, (Picture1.ScaleHeight \ 2)), &H0&
    'cross mark on form
    'Form1.Line (0, 0)-(Form1.ScaleWidth - VScroll1.Width, Form1.ScaleHeight - Label1.Height)
    'Form1.Line (Form1.ScaleWidth - VScroll1.Width, 0)-(0, Form1.ScaleHeight - Label1.Height)
    ReleaseDC dshwnd, dsDC 'previous bug not releasing memory
End Sub
 
Private Sub VScroll1_Change()
    'magnify = VScroll1.Value ;100 is max vscroll value
    'output 2 decimal places
    Label2.Caption = Format(100 / VScroll1.Value, "FIXED")
    Picture1.SetFocus
End Sub
 
Private Sub VScroll1_Scroll()
    Label2.Caption = Format(100 / VScroll1.Value, "FIXED")
    Picture1.SetFocus
End Sub

 
 
'module1.bas
 
Option Explicit
 
'Constants for topmost.
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Const ERRORAPI = 0
 
Public 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
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 Declare Sub ReleaseCapture Lib "user32" ()
 
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
Public Const RGN_XOR = 3
Public Const RGN_DIFF = 4
Public Const RGN_AND = 1
 
Public Const RGN_MIN = RGN_AND
Public Const RGN_OR = 2
 
'Private Sub Form_Load()
'    Command1.Caption = "Exit"
'End Sub
 
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 
Declare Function GetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long) As Long
Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
 
Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
 
Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Declare Function GetClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 

 


c0Title: Maintain Call Stack for Error Tracing
c1Code:
I program all reusable components into DLLs or OCXs. To provide a consistent error-handling technique across all my projects, I use the Raise method of the Err object in all these components and display the error only in the code module of first entry�such as Command1_Click. Because an error can be generated several layers deep in the code, I propagate the location of the error using this Raise statement in all my reusable components:


ThisProcEH:
	Err.Raise Err.Number, "ThisProc" & vbCr & Err.Source
Exit Sub


This way, the whole call stack is returned to�and can be displayed in�the calling procedure (through Err.Source), making errors much easier to find and solve.

�Harvey Flaisher, McLean, Virginia


c0Title: Make a DLL that contains icons or other pictures
c1Code:
Keywords DLL, icon, picture 
Categories Software Engineering 
 
Make a DLL project and add a form to it. Place the icons or other pictures in PictureBoxes on this form. 
Create a public class and give it a GetIcon method that returns one of the PictureBox's Picture properties. 
 
Public Function GetIcon(ByVal Index As Integer) As StdPicture
    Set GetIcon = frmIcons.picIcon(Index).Picture
End Function

 
The main program needs a reference to the DLL. If you build the main program in the same project group as the DLL project, open the Project menu, select References, and check the DLL project's entry. 
If the main program is in its own project, load the DLL project, open the File menu, and select the Make Xxx.dll command to build the DLL. Then load the main project, open the Project menu, select References, and check the DLL's entry. If you cannot find the DLL, click the Browse button to select it. 

After you have created the reference to the DLL, you can create an instance of the class and use it's public GetIcon method to retrieve the pictures stored in the DLL. 
 
Private Sub optIcon_Click(Index As Integer)
	Dim icon_holder As StorageIconHolder

    Set icon_holder = New StorageIconHolder
    Me.MouseIcon = icon_holder.GetIcon(Index)
    Me.MousePointer = vbCustom
    Picture1.Picture = icon_holder.GetIcon(Index)
End Sub
 


c0Title: Make a field for the user to enter an IP address
c1Code:
Keywords IP address, masked field, validation 
Categories Software Engineering 
 
By Erik Spaans. 
This program builds an input box that lets the user enter an IP address of the form 123.123.123.123. The subfields are numbers between 0 and 255. See the code for details. 

 
'Release Date : 5-11-2001
'Release Note : This code is FREE for personal & commercial use.
'Function : This code provides an inputbox with a value like a ipaddress or range.
'           Inputvalidation : all subnumbers are between 0 and 255.
'           Subnumber is automaticly centered when entered
'           Next subnumber is selected when 'SPACE','TAB','ENTER' or '.' is pressed
'           Previous subnumber is selected when area is clear and 'BACKSPACE' is pressed
'
'I hope you enjoy this function.
'For remarks you can send me mail on glashio@wanadoo.nl
'
'Succes!
'
'K  i  R  e
 
Option Explicit
 
Dim IPvalidated  As Boolean
Dim Cnt As Integer
Dim IPaddress As String
Dim FocusFlag As Boolean
 
Private Sub cmd_clear_Click()
    With txt_ip
        For Cnt = 0 To .UBound
            .Item(Cnt).Text = ""
            .Item(Cnt).Tag = "False"
        Next Cnt
    End With
End Sub
 
Private Sub cmd_validate_Click()
    IPvalidated = True
    IPaddress = ""
    With txt_ip
        For Cnt = 0 To .UBound
            If .Item(Cnt).Tag = "False" Then
                IPvalidated = False
                .Item(Cnt).SetFocus
                txt_ip_GotFocus (Cnt)
                Exit For
            End If
        Next Cnt
 
    If IPvalidated = False Then
        MsgBox ("No valid IP-address")
    Else
        For Cnt = 0 To txt_ip.UBound
            IPaddress = IPaddress & Trim(.Item(Cnt).Text) & "."
        Next Cnt
        MsgBox ("Entered IPaddress is : " & Left(IPaddress, Len(IPaddress) - 1))
    End If
    End With
End Sub
 
Private Sub Form_Load()
    With txt_ip
        For Cnt = 0 To .UBound
            .Item(Cnt).Text = ""
            .Item(Cnt).Tag = False
        Next Cnt
    End With
End Sub
 

Private Sub txt_ip_Change(Index As Integer)
Dim Chr_Cnt As Integer
Dim New_Txt As String
    If FocusFlag = True Then
        FocusFlag = False
        Exit Sub
    End If
    With txt_ip(Index)
        If Len(.Text) = 0 Then Exit Sub
        For Chr_Cnt = 1 To Len(.Text)
            If Mid(.Text, Chr_Cnt, 1) = "." Or Mid(.Text, Chr_Cnt, 1) = " " Then
                If Index < 3 Then
                    txt_ip(Index + 1).SetFocus
                End If
            End If
            If Mid(.Text, Chr_Cnt, 1) >= "0" And Mid(.Text, Chr_Cnt, 1) <= "9" Then
                New_Txt = New_Txt & Mid(.Text, Chr_Cnt, 1)
            End If
        Next Chr_Cnt
        .Text = New_Txt
        If Len(.Text) = 3 And Index < 3 Then txt_ip(Index + 1).SetFocus
        If Val(.Text) > 255 Then
            .BackColor = &HC0C0FF
            .Tag = "False"
        Else
            .BackColor = &H80000005
            .Tag = "True"
        End If
    End With
    
End Sub
 
Private Sub txt_ip_GotFocus(Index As Integer)
    txt_ip(Index).Text = LTrim(txt_ip(Index).Text)
    FocusFlag = False
End Sub
 
Private Sub txt_ip_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
    With txt_ip(Index)
        If Len(.Text) = 0 And KeyCode = 8 And Index > 0 Then 'Backspace pressed
            txt_ip(Index - 1).SetFocus
        End If
        If KeyCode = 13 And Index < 3 Then  'Backspace pressed
            txt_ip(Index + 1).SetFocus
        End If
    End With
End Sub
 
Private Sub txt_ip_LostFocus(Index As Integer)
    FocusFlag = True
    With txt_ip(Index)
        If .Text <> "" Then
            .Text = Val(.Text)
            FocusFlag = True
        Else
            .Tag = "False"
        End If
        If Len(.Text) = 1 Then .Text = "  " & .Text 'Center number
        If Len(.Text) = 2 Then .Text = " " & .Text 'Center number
    End With
End Sub
 
Private Sub txt_ipdot_GotFocus(Index As Integer)
    txt_ip(Index + 1).SetFocus
End Sub
 
 


c0Title: Make a Form Stay on Top Redux
c1Code:
Many routines use the SetWindowPos API to always keep a form on top. Most require the user to remember several nonintuitive arguments. I�ll not only show you how to simplify the arguments, but I�ll also illustrate the usefulness of the new Enum function. Enums have several advantages: Possible argument values are listed for you in the IDE using Microsoft�s IntelliSense, the arguments are listed in the Object Browser, and Enums are included automatically in the type library when used in a class module. This all translates into easier programming and more code reuse:

 
'Paste this code into a module
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 SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_NOACTIVATE = &H10
 
Public Enum WindowPos
     vbTopMost = -1&
     vbNotTopMost = -2&
End Enum
 
Public Sub SetFormPosition(hWnd As Integer, _
     Position As WindowPos)
     Const wFlags As Long = SWP_NOMOVE Or _
          SWP_NOSIZE Or SWP_SHOWWINDOW Or _
          SWP_NOACTIVATE 
     If Position = vbTopMost or Position = _
          vbNotTopMost Then
          SetWindowPos hWnd, Position, 0, 0, 0, 0, _
               wFlags
     End If
End Sub
 
'Add two command buttons to a form; then paste in 
'this code
Private Sub Command1_Click()
     'Makes form topmost
     SetFormPosition Me.hWnd, vbTopMost
End Sub
 
Private Sub Command2_Click()
     'Restore form to normal position
     SetFormPosition Me.hWnd, vbNotTopMost
End Sub
�Jared A. Faulkner, Roxana, Illinois


c0Title: MAKE A READ-ONLY TEXT BOX WITHOUT GRAYING THE TEXT
c1Code:
There may be situations in which you want to display text that the user cannot edit, but a label control doesn�t quite fit the bill. What you need is a read-only text box, which is done setting a text box�s Enabled property to False. Unfortunately, this also grays the text. An alternative is to place the text box on a picture box control and then set the picture box�s Enabled property to False. This technique will also disable the text box�s scroll bars if it has any. Another approach is to make the text box readonly by sending a EM_SETREADONLY message to the text box using the API function SendMessage as shown here:

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_USER = &H400 Global Const EM_SETREADONLY = (WM_USER + 31)

Sub Form_Load ()
    Dim i As Long
    'Prevent user from editing text box
    i = SendMessage(Text1.hWnd, EM_SETREADONLY, True, ByVal 0&) End Sub This technique allows the user to still select, copy, and scroll the contents of the text box but not edit it.

�Jonathan Wood and Barry Seymour



c0Title: Make a sorted collection class
c2File: coll.zip
c1Code:
Method

This class stores items in a normal collection. It inserts items in their proper places in the collection.

    ' Add an item at its correct position.
    Public Sub AddItem(ByVal new_item As String)
    Dim i As Integer
    
        ' See where the item belongs.
        For i = 1 To m_Items.Count
            If m_Items(i) >= new_item Then Exit For
        Next i
    
        ' Insert the item.
        If i > m_Items.Count Then
            ' Add at the end.
            m_Items.Add new_item
        Else
            ' Add at the right position.
            m_Items.Add new_item, , i
        End If
    End Sub

The main reason the class stores items in a collection rather than an array, linked list, or some other data structures is to provide the For Each operator. To do that, the class must provide a NewEnum function that returns an IUnknown interface object. The class can get such an object from a normal collection like this:

    Public Function NewEnum() As IUnknown
       Set NewEnum = m_Items.[_NewEnum]
    End Function

To register this function as the class enumerator, you must:

    1. Open the SortedCollection's class editor window.
    2. Select the Tools menu's Procedure Attributes command.
        a. Select NewEnum in the Name box.
        b. Click Advanced >>
        c. Click on the Procedure ID box and type -4.
        d. Check the "Hide this member" box so the user cannot see this method (it's really only useful indirectly via For each).
        e. Click Ok.

The Count, Remove, and Item methods are simply delegated to the m_Items collection.

    ' Return the number of items.
    Public Function Count() As Integer
        Count = m_Items.Count
    End Function

    ' Remove an item.
    Public Sub Remove(ByVal Index As Integer)
        m_Items.Remove Index
    End Sub

    ' Return an item.
    Public Function Item(ByVal Index As Integer) As String
        Item = m_Items(Index)
    End Function

The class makes its Item method its default method. That allows a program using it to refer to items as in:

    sorted_collection(K)

in addition to:

    sorted_collection.Item(K)

To make Item be the default method, you must:

    1. Open the SortedCollection's class editor window.
    2. Select the Tools menu's Procedure Attributes command.
        a. Select Item in the Name box.
        b. Click Advanced >>
        c. Select (Default) in the Procedure ID box.
        d. Click Ok.

 Disclaimer
This example program is provided "as is" with no warranty of any kind. It is intended for demonstration purposes only. In particular, it does no error handling. You can use the example in any form, but please mention www.vb-helper.com.



c0Title: Make a BLOB
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


Public Function MakeBLOB(ByVal lpBuffer As Long, ParamArray Params()) As Long '===========================================================================
'   MakeBLOB - Creates a BLOB from a list of variables.
'
'   This functions helps to convert UDT's to BLOBs. The BLOBs can then be used
'   to save to disk or transported over a socket.
'
'   NOTE:   The function assumes that the caller has allocated enough memory
'   pointed to in lpBuffer. The caller is also expected to know the format of
'   the BLOB and how to restore it.
'
'   lpBuffer        Long pointer to the data buffer to receive the BLOB.
'                   A value of zero tells the function NOT to perform any
'                   copying. This allows the function to be called a first
'                   time to determine the total # of bytes needed.
'   Params          Parameter array of variables that will be written to the
'                   BLOB. Presently only intrinsic data types and byte arrays
'                   are supported. The math is quite simple to add support for
'                   arrays of other types, and recursion can be used for multi-
'                   dimensional arrays, which is probably beyond the scope of
'                   it's usage. For sophisticated structured BLOBs consider
'                   using the DataBag class instead.
'===========================================================================

    Dim lpData      As Long         ' Pointer to the variants data item
    Dim Length      As Long         ' Size of a Param
    Dim VType       As Long         ' VARTYPE member of VARIANT structure
    Dim i           As Long         ' work
    
    On Error GoTo ErrHandler
    
    ' NOTE: There is an undocumented bug in VB6 when using For/Each
    ' iterations on a ParamArray that results in the enumerated item
    ' being filled with a pointer to the data item instead of the
    ' actual data item. For instance, Params(1) would equate to StrPtr(Param)
    ' instead of Param's value if it were of type vbString. My testing
    ' found it not to be a problem from a compiled project. Therefore,
    ' I use a For/Next.

    For i = LBound(Params) To UBound(Params)
    
        ' Get the VARTYPE value from the first 2 bytes of the VARIANT structure
        CopyMemory ByVal VarPtr(VType), ByVal VarPtr(Params(i)), 2
        
        ' Get the pointer to the Variant's data item
        ' NOTE: A Variant's descriptor, padding & union take up 8 bytes.
        CopyMemory ByVal VarPtr(lpData), ByVal VarPtr(Params(i)) + 8, 4

        ' Test if lpData is a pointer or a pointer to a pointer.
        If (VType And VT_BYREF) <> 0 Then
            ' Deref pointer
            CopyMemory ByVal VarPtr(lpData), ByVal lpData, 4
        End If
        
        ' This SELECT CASE identifies the data type and initializes VARTYPE.
        ' The actual data is copied after the switch, except for the exceptions.
        Select Case VarType(Params(i))
            
        Case vbByte
            
            ' Copy the variant's data value into the BLOB
            Length = 1
            If lpBuffer <> 0 Then _
                CopyMemory ByVal lpBuffer, ByVal VarPtr(Params(i)) + 8, Length
            
        Case vbBoolean, vbInteger
            
            ' Copy the variant's data value into the BLOB
            Length = 2
            If lpBuffer <> 0 Then _
                CopyMemory ByVal lpBuffer, ByVal VarPtr(Params(i)) + 8, Length
            
        Case vbLong, vbSingle
            
            ' Copy the variant's data value into the BLOB
            Length = 4
            If lpBuffer <> 0 Then _
                CopyMemory ByVal lpBuffer, ByVal VarPtr(Params(i)) + 8, Length
            
        Case vbDate, vbDouble, vbCurrency
            
            ' Copy the variant's data value into the BLOB
            Length = 8
            If lpBuffer <> 0 Then _
                CopyMemory ByVal lpBuffer, ByVal VarPtr(Params(i)) + 8, Length
            
        Case vbDecimal
            
            Length = 12
            If lpBuffer <> 0 Then _
                CopyMemory ByVal lpBuffer, ByVal VarPtr(Params(i)) + 2, Length
            
        Case (vbByte Or vbArray)
            
            ' An error will raise if the array is not dimensioned.
            ' This is OK, we'll just process the next parameter.
            On Error GoTo ForNext

            ' Size to # of elements in the byte array
            Length = Abs((LBound(Params(i))) - (UBound(Params(i)))) + 1
            
            ' NOTE: The pointer to array data (pvData) has a
            ' 12 byte offset in the SAFEARRAY structure.
            CopyMemory ByVal VarPtr(lpData), ByVal lpData + 12, 4
            
            ' Copy the data into the BLOB
            If lpBuffer <> 0 Then _
                CopyMemory ByVal lpBuffer, ByVal lpData, Length
        
        Case vbString
            
            ' Size to a unicode string
            Length = Len(Params(i)) * 2
            
            ' Copy the unicode string into the BLOB
            If lpBuffer <> 0 Then _
                CopyMemory ByVal lpBuffer, ByVal lpData, Length
            
        Case Else
        
            ' we should never be here
            Debug.Assert 0
            On Error GoTo 0
            Err.Raise 5
        
        End Select
        
        ' Move current pointer in the buffer
        If lpBuffer <> 0 Then _
            lpBuffer = lpBuffer + Length
            
        ' So caller knows how many bytes needed/copied
        MakeBLOB = MakeBLOB + Length

ForNext:
        ' restore error handler in case cleared from above.
        On Error GoTo ErrHandler
    
    Next i
    
ExitLabel:
    
    Exit Function
    Resume
ErrHandler:
    Debug.Assert 0
    Resume ExitLabel
    
End Function




c0Title: MAKE FORMS STAY ON TOP
c1Code:
To set a form to be always on top, use the subroutine listed here. Pass it the hWnd property of the form you want to float. The OnTop parameter is used to toggle the attribute. If True, floating is turned on; if False, the form will not float.

Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) Global Const SWP_NOSIZE = &H1 Global Const SWP_NOMOVE = &H2 Global Const HWND_TOPMOST = -1 Global Const HWND_NOTOPMOST = -2

Sub FormOnTop (hWnd%, OnTop%)
    If OnTop Then
        Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
    Else
        Call SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
    End If
End Sub

�Karl E. Peterson



c0Title: Make More Versatile Trim Functions
c1Code:
One of the nice things about VB is the ability to redefine most of the built-in commands. For example, you can extend the functionality of the Trim family of commands. LTrim and RTrim remove leading and trailing spaces from a string, but it also would be useful to remove other nonprinting characters, such as tabs, or carriage return/line feed pairs that might be present after reading in a text file. This code does exactly that by removing all leading and trailing characters with an ASCII value less than or equal to that of a space character: 

Public Function Trim(ByVal inString As String) _
     As String
     Trim = RTrim(LTrim(inString))
End Function
 
Public Function RTrim(ByVal inString As String) _
     As String
     Dim nPos As Long
     nPos = Len(inString)
     If nPos > 0 Then
          Do While (Asc(Mid$(inString, _
               nPos, 1)) <= 32)
               nPos = nPos - 1
               If nPos = 0 Then Exit Function
          Loop
          RTrim = Left$(inString, nPos)
     End If
End Function
 
Public Function LTrim(ByVal inString As String) _
     As String
     Dim nPos As Long, nLen As Long
     nLen = Len(inString)
     If nLen > 0 Then
          nPos = 1
          Do While Asc(Mid$(inString, nPos, 1)) <= 32
               nPos = nPos + 1
               If nPos = nLen Then Exit Function
          Loop
          LTrim = Mid$(inString, nPos)
     End If
End Function
 
�John Cullen, Pedroucos, Portugal


c0Title: Make Sure Data is Updated
c1Code:
When using bound controls, data is updated automatically when you Move to a different record. Data is not updated when you close the form. To ensure that data is saved when you close, perform a Move 0. This saves the changes before unloading the form.

�Deborah Kurata, Pleasanton, California


c0Title: Make Sure MsgBox is on Top
c1Code:
When you implement the Always on Top feature with VB forms using SetWindowPos and HWND_TOPMOST, message boxes are shown below the topmost form. To overcome this, you can use the vbSystemModal constant in the MsgBox function�s Style attribute. This forces the message box to show on top of the Always on Top form. This is necessary only with the 32-bit versions of VB.

�Srinivasa S. Sivakumar, Chicago, Illinois


c0Title: Make the Ants March
c1Code:
To implement a quick and easy version of the old �marching ants� line around a control, place two CommandButtons, a Shape, and a Timer control on a form. Then insert this code into the form:

Private Sub Command1_Click()
	StartMarchingAnts
End Sub

Private Sub Command2_Click()
	StopMarchingAnts
End Sub
 
Private Sub StartMarchingAnts()
	Timer1.Interval = 200
	Timer1.Enabled = True
	Shape1.Visible = True
End Sub

Private Sub StopMarchingAnts()
	Timer1.Enabled = False
	Shape1.Visible = False
End Sub

Private Sub Timer1_Timer()
	If Shape1.BorderStyle = vbBSDot Then
		Shape1.BorderStyle = vbBSDashDot
	Else
		Shape1.BorderStyle = vbBSDot
	End If
End Sub

Pressing Command1 starts the animation; Command2 stops it. This works for all shape types.

�George Hughen, Hamilton, Massachusetts


c0Title: Making a Text Box read only
c1Code:
Often times I have come across situations where I would want to make a read only text box. It would need to behave like a picture box. The problem is if you make the textbox disabled the text in the box will turn gray no matter what you set the color property to be. If you make it locked you can still put the cursor inside the text box but you will not be able to edit the text. The solution is to create a picture box that has no border. (So that it will be invisible). Next, you put the text box inside the picture box. You then set the picture box's enabled property to false. This will allow the text box to be read only. If you then want the text box to be enabled, set the picture box enabled property to true.

Tip by Levi Page



c0Title: Making a text box read-only
c1Code:

iRes=sendmessage(txt1.hwnd,EM_SETREADONLY,true,0)

Then to make it editable again:

iRes=sendmessage(txt1.hwnd,EM_SETREADONLY,FALSE,0)


c0Title: MAKING THE ENTER KEY WORK LIKE A TAB
c1Code:
To allow the Enter key to function as a Tab, enter this code in the KeyPress event of your text boxes:

Sub Text1_KeyPress (KeyAscii As Integer)
    If KeyAscii = 13 Then 'Enter
        SendKeys "{Tab}"
        KeyAscii = 0
    End If
End Sub

This allows the user to press Enter to move from one text box to the next. This technique will not work if you have a command button on the form whose default property is True. The button will respond to the Enter key before the text box sees it.

�Karl E. Peterson




c0Title: ComboBox Events Not Always Firing When Selection Changes
c1Code:
Typing causes a Change event, but using the mouse causes a Click event. You need to define both event handlers to catch both cases.


c0Title: Set tab stop positions for a multiline TextBox control
c1Code:
By default, multiline TextBox controls insert a tab stop position every 8 characters; in other words, if you press the Ctrl+Tab key while the focus is inside a multiline TextBox control, the caret advances to position 8,16,24, etc. (If the TextBox is the only control on the form that can receive the focus in that moment, you can also advance to the next tab stop with the Tab key.)

By sending the control a EM_SETTABSTOPS message, you can set individual tab stops at desired positions. You do so by loading an array of Longs with the position of individual tab stops, expressed in dialog units - where each dialog unit is 1/4 of the average character width. Then you pass the array to the SendMessage function, specifying the number of elements in wParam and the first element of the array in lParam. Here's an example:

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

' Set tab stops at character position 5, 10, and 20

Dim tabs(2) As Long

tabs(0) = 5 * 4
tabs(1) = 10 * 4
tabs(2) = 20 * 4

SendMessage Text1.hWnd, EM_SETTABSTOPS, 3, tabs(0)


The following routine encapsulates this call for you:


' Set tab stops. Each element of the array is expressed in dialog units,
' where each dialog unit is 1/4 of the average character width.
Sub TextBoxSetTabStops(tb As TextBox, tabStops() As Long)
    Dim numEls As Long
    numEls = UBound(tabStops) - LBound(tabStops) + 1
    SendMessage tb.hwnd, EM_SETTABSTOPS, numEls, tabStops(LBound(tabStops))
End Sub


The simplest case is when all the tab stops have the same distance, in which case you can use the following routine:


' Set the tab stop distance, expressed in dialog units.
Sub TextBoxSetTabStopDistance(tb As TextBox, ByVal distance As Long)
    SendMessage tb.hwnd, EM_SETTABSTOPS, 1, distance
End Sub

Francesco Balena


c0Title: Rnd2 - A random value in a range
c1Code:
' A random number in the range (low, high)

Function Rnd2(low As Single, high As Single) As Single
    Rnd2 = Rnd * (high - low) + low
End Function
Francesco Balena


c0Title: ArrayDeleteElement - Deleting an element in any type of array
c1Code:
' A generic routine that deletes an element in any type of array.
' Example: deleting the 2nd element of the array arr
'     ArrayDeleteElement(arr, 1) 

Sub ArrayDeleteElement(ByVal arr As Array, ByVal index As Integer)
    ' Shift elements from arr(index+1) to arr(index).
    Array.Copy(arr, index + 1, arr, index, UBound(arr) - index)
    ' Clear the last element.
    arr.Clear(arr, arr.GetUpperBound(0), 1)
End Sub


' Note: this code is taken from Francesco Balena's "Programming Microsoft 
' Visual Basic .NET" book (MS Press 2002)
Francesco Balena


c0Title: AddBackslash - Append a backslash to a path if needed
c1Code:
' Append a backslash (or any character) at the end of a path
' if it isn't there already

Function AddBackslash(Path As String, Optional Char As String = "\") As String
    If Right$(Path, 1) <> Char Then
        AddBackslash = Path & Char
    Else
        AddBackslash = Path
    End If
End Function
Francesco Balena


c0Title: GetFileExtension - The extension in a filename
c1Code:
' Return the extension of a file name

Function GetFileExtension(ByVal FileName As String) As String
    Dim i As Long
    For i = Len(FileName) To 1 Step -1
        Select Case Mid$(FileName, i, 1)
            Case "."
                GetFileExtension = Mid$(FileName, i + 1)
                Exit For
            Case ":", "\"
                Exit For
        End Select
    Next
End Function

Francesco Balena


c0Title: FilterString - Remove invalid characters from a string
c1Code:
' Filter out all invalid characters in a string.

Function FilterString(text As String, ValidChars As String) As String
    Dim i As Long, result As String
    For i = 1 To Len(text)
        If InStr(ValidChars, Mid$(text, i, 1)) Then
            result = result & Mid$(text, i, 1)
        End If
    Next
    FilterString = result
End Function
Francesco Balena


c0Title: ReplicateString - Replicate a string a given number of times
c1Code:
' Replicate a string a given number of times

Function ReplicateString(ByVal Source As String, ByVal Times As Integer) As _
    String
    Dim i As Integer
    Dim sb As New Text.StringBuilder(Source.Length * Times)
    For i = 1 To Times
        sb.Append(Source)
    Next
    Return sb.ToString
End Function
Francesco Balena


c0Title: ArrayInsertElement - Inserting an element in any type of array
c1Code:
' A generic routine that inserts an element in any type of array.
' Example: inserting an entry of value 5 between the 1st and 2nd entry of the 
' array arr
'     ArrayInsertElement(arr, 1, 5)

Sub ArrayInsertElement(ByVal arr As Array, ByVal index As Integer, _
    Optional ByVal newValue As Object = Nothing)
    ' shift elements from arr(index) to arr(index+1) to make room.
    Array.Copy(arr, index, arr, index + 1, arr.Length - index - 1)
    ' Assign the element using the SetValue method
    arr.SetValue(newValue, index)
End Sub


' Note: this code is taken from Francesco Balena's "Programming Microsoft 
' Visual Basic .NET" book (MS Press 2002)
Francesco Balena


c0Title: DeleteRegistryKey - Delete a key of the Registry
c1Code:
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String) As Long

' Delete a registry key
'
' Under Windows NT it doesn't work if the key contains subkeys

Sub DeleteRegistryKey(ByVal hKey As Long, ByVal KeyName As String)
    RegDeleteKey hKey, KeyName
End Sub


Francesco Balena


c0Title: ReplaceLast - Replace the last occurrence of a substring
c1Code:
' Replace the last occurrence of a string

Function ReplaceLast(Expression As String, Find As String, ReplaceStr As String, _
    Optional Compare As VbCompareMethod) As String
    Dim i As Long
    i = InStrRev(Expression, Find, , Compare)
    If i Then
        ' the search string is there
        ' note that the Replace function trims the first part
        ' of the string, so we must restore it using Left$
        ReplaceLast = Left$(Expression, i - 1) & Replace(Expression, Find, _
            ReplaceStr, i, 1, Compare)
    Else
        ' the search string isn't there
        ReplaceLast = Expression
    End If
End Function
Francesco Balena


c0Title: RunningAsExe - Determine whether the code is running in an EXE or DLL
c1Code:
' Return True if the application is running as an EXE
' Return False if the application is running as a DLL

Function RunningAsExe() As Boolean
    ' get the codebase of the running assembly
    Dim codeBase As String = Reflection.Assembly.GetExecutingAssembly.CodeBase
    ' extract the extension
    Dim ext As String = System.IO.Path.GetExtension(codeBase)
    ' return True if extension is EXE
    Return String.Compare(ext, ".exe", True) = 0
End Function

Francesco Balena


c0Title: Append a string to a textbox quickly and without flickering
c1Code:
The usual way to append text to a TextBox or a RichTextBox control is to concatenate the current contents with the new string:

Text1.Text = Text1.Text & newString

Here is a different approach, which is slightly faster and causes less flickering:

Text1.SelStart = Len(Text1.Text)
Text1.SelText = newString 

Francesco Balena


c0Title: StringFromBSTR - Convert a BSTR to a VB string
c1Code:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
    Any, source As Any, ByVal bytes As Long)

' convert a BSTR into a VB String

Function StringFromBSTR(ByVal pointer As Long) As String
    Dim temp As String
    ' copy the pointer into the temporary string's BSTR
    CopyMemory ByVal VarPtr(temp), pointer, 4
    ' now Temp points to the original string, so we can copy it
    StringFromBSTR = temp
    ' manually clear then temporary string to avoid GPFs
    CopyMemory ByVal VarPtr(temp), 0&, 4
End Function
Francesco Balena


c0Title: HasDuplicateValues - Check if an array has duplicate values
c1Code:
    ' Returns True if an array contains duplicate values
    ' it works with arrays of any type

    Function HasDuplicateValues(ByVal arr As Array) As Boolean
        Dim ht As New Collections.Hashtable(arr.Length * 2)
        Dim index As Integer

        For index = 0 To arr.Length - 1
            Dim value As Object = arr.GetValue(index)

            If ht.Contains(value) Then
                ' return True if the value is already in the hashtable
                Return True
            Else
                ' else just add it to the hashtable now
                ht.Add(value, Nothing)
            End If
        Next
    End Function

Francesco Balena


c0Title: Dec2Any - Convert a decimal number to any other base
c1Code:
' convert a number to any base
' BASE can be in the range 2-36

Function Dec2Any(ByVal number As Long, ByVal base As Integer) As String
    Dim index As Long
    Dim digits As String
    Dim digitValue As Long
    
    ' check base
    If base < 2 Or base > 36 Then Err.Raise 5
    ' get the list of valid digits
    digits = Left("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ", base)
    
    ' convert to the other base
    Do While number
        digitValue = number Mod base
        number = number \ base
        Dec2Any = Mid$(digits, digitValue + 1, 1) & Dec2Any
    Loop

End Function


c0Title: ArrayShuffle - Randomize the order of elements in an array
c1Code:
' Shuffle the elements of an array of any type
' (it doesn't work with arrays of objects or UDT)

Sub ArrayShuffle(arr As Variant)
    Dim index As Long
    Dim newIndex As Long
    Dim firstIndex As Long
    Dim itemCount As Long
    Dim tmpValue As Variant
    
    firstIndex = LBound(arr)
    itemCount = UBound(arr) - LBound(arr) + 1
    
    For index = UBound(arr) To LBound(arr) + 1 Step -1
        ' evaluate a random index from LBound to INDEX
        newIndex = firstIndex + Int(Rnd * itemCount)
        ' swap the two items
        tmpValue = arr(index)
        arr(index) = arr(newIndex)
        arr(newIndex) = tmpValue
        ' prepare for next iteration
        itemCount = itemCount - 1
    Next

End Sub
Francesco Balena


c0Title: TextBoxScroll - Programmatically scroll a multi-line TextBox control
c1Code:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal _
    hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long
Const EM_LINESCROLL = &HB6

' Scroll the contents of the control.
'
' Positive values scroll left and up, negative values scroll right and down.
' IMPORTANT: you can only scroll TextBox control to which the corresponding
'            scrollbar (horizontal or vertical) is associated

Sub TextBoxScroll(tb As TextBox, ByVal HorizScroll As Long, _
    ByVal VertScroll As Long)
    SendMessageByVal tb.hwnd, EM_LINESCROLL, HorizScroll, VertScroll
End Sub
Francesco Balena


c0Title: Determine whether the IDE is in design, break, or run mode
c1Code:
The VBIDE object model doesn't offer any native property or method to determine whether the IDE is in design-time mode, run-time mode, or debug (break) mode. However, it's easy to deduct this information by looking at the Enabled property of the menu commands in the Run top-level menu:
' this code assumes that VBInstance holds a reference
' the the VBE root object

With VBInstance.CommandBars("Run")
    If .Controls("End").Enabled = False Then
        ' we are in design mode
    ElseIf .Controls("Break").Enabled Then
        ' we are in run mode
    Else
        ' we are in break mode
    End if
End With
Note, however, that this code might not work under localized versions of Visual Basic.
Francesco Balena


c0Title: Manually Activate Screensaver
c1Code:
Place this code on a Form and add a command button (Command1) to the Form. Run it and click the CommandButton to start the ScreenSaver. 
This will not work if the user does not have a ScreenSaver setup. 


Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
Const comWM_SYSCOMMAND = &H112&
Const cSC_SCREENSAVE = &HF140&

Private Sub Command1_Click()
    'This can be your event to fire the screensaver.
    Dim lResult As Long
    lResult = SendMessage(Me.hWnd, comWM_SYSCOMMAND, cSC_SCREENSAVE, 0&) End Sub




c0Title: MCI Supports Multiple CD-ROMs
c1Code:
The Media Control Interface (MCI) can easily support multiple CD audio devices. You simply specify the drive letter in the MCI open command. To eject the CD from any drive, first place a listbox on a form. To detect which drives are CD-ROMs, place this code in the form�s General Declarations section:

 
Private Declare Function GetDriveType Lib _
     "kernel32" Alias "GetDriveTypeA" (ByVal _
     nDrive As String) As Long
Private Declare Function mciSendString Lib _
     "winmm.dll" Alias "mciSendStringA" (ByVal _
     lpstrCommand As String, ByVal _
     lpstrReturnString As String, ByVal _
     uReturnLength As Long, ByVal hWndCallback As _
     Long) As Long
 
Private Const DRIVE_CDROM = 5
 
The following code in the Form_Load event fills the listbox with available CD-ROM drives. Note that the code does not detect whether the CD-ROM drive can actually eject the CD. Use the �capabilities can eject� MCI command to determine that:
Private Sub Form_Load()
     Dim k As Long
     For k = Asc("A") To Asc("Z")
          If GetDriveType(Chr$(k) & ":") = _
               DRIVE_CDROM Then
               List1.AddItem Chr$(k) & ":"
          End If
     Next
End Sub
 
Place this code in the List1_DblClick event to eject the CD:
 
Private Sub List1_DblClick()
     mciSendString "open " & _
          List1.List(List1.ListIndex) & _
          " type cdaudio alias cdaudio", _
          vbNullString, 0, 0
     mciSendString "set cdaudio door open", _
          vbNullString, 0, 0
     mciSendString "close cdaudio", vbNullString, _
          0, 0
End Sub
�Matt Hart, Tulsa, Oklahoma


c0Title: Merge Sort (Non-Recursive)
c1Code:
At a first glance the merge sort appears to be identical to the quick sort. However, rather than separating the values into distinct left and right groups, we simply sort them straight away with no pivot values. The value comparisons are done when we come to merge the two sorts together, but since the groups are ordered, we need only compare the smallest of one group with the smallest of the other.

Example:

Code:
Array of data [2,8,4,9,3,5,7,1,0,6]

       [2,8,4,9,3,5,7,1,0,6]
         |               |             Recursive step
   [2,8,4,9,3]       [5,7,1,0,6]
    |       |         |       |        Recursive step
  [2,8]  [4,9,3]    [5,7]  [1,0,6]
    |     |   |       |     |   |      Recursive step
  [2,8]  [4][3,9]   [5,7]  [1][0,6]
    |     |   |       |     |   |      Merge step
  [2,8]  [3,4,9]    [5,7]  [0,1,6]
    |       |         |       |        Merge step
   [2,3,4,8,9]       [0,1,5,6,7]
         |               |             Merge step
       [0,1,2,3,4,5,6,7,8,9]

Finish [0,1,2,3,4,5,6,7,8,9]


The merge sort is different in other ways. For one, it requires a second array to hold the data, as we merge from one into the other. Another difference is that it can easily be implemented non-recursively, as I have done in the code below. The MergeSort procedure calls the InnerMergePass sub with larger and larger segment sizes.


VB: 
--------------------------------------------------------------------------------
Public Sub MergeSort(ByRef lngArray() As Long)
    Dim arrTemp() As Long
    Dim iSegSize As Long
    Dim iLBound As Long
    Dim iUBound As Long
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
        
    ReDim arrTemp(iLBound To iUBound)
    
    iSegSize = 1
    Do While iSegSize < iUBound - iLBound
        
        'Merge from A to B
        InnerMergePass lngArray, arrTemp, iLBound, iUBound, iSegSize
        iSegSize = iSegSize + iSegSize
        
        'Merge from B to A
        InnerMergePass arrTemp, lngArray, iLBound, iUBound, iSegSize
        iSegSize = iSegSize + iSegSize
        
    Loop
End Sub

Private Sub InnerMergePass(ByRef lngSrc() As Long, ByRef lngDest() As Long, ByVal iLBound As Long, iUBound As Long, ByVal iSegSize As Long)
    Dim iSegNext As Long
    
    iSegNext = iLBound
    
    Do While iSegNext <= iUBound - (2 * iSegSize)
        'Merge 2 segments from src to dest
        InnerMerge lngSrc, lngDest, iSegNext, iSegNext + iSegSize - 1, iSegNext + iSegSize + iSegSize - 1
        
        iSegNext = iSegNext + iSegSize + iSegSize
    Loop
    
    'Fewer than 2 full segments remain
    If iSegNext + iSegSize <= iUBound Then
        '2 segs remain
        InnerMerge lngSrc, lngDest, iSegNext, iSegNext + iSegSize - 1, iUBound
    Else
        '1 seg remains, just copy it
        For iSegNext = iSegNext To iUBound
            lngDest(iSegNext) = lngSrc(iSegNext)
        Next iSegNext
    End If

End Sub

Private Sub InnerMerge(ByRef lngSrc() As Long, ByRef lngDest() As Long, ByVal iStartFirst As Long, ByVal iEndFirst As Long, ByVal iEndSecond As Long)
    Dim iFirst As Long
    Dim iSecond As Long
    Dim iResult As Long
    Dim iOuter As Long
    
    iFirst = iStartFirst
    iSecond = iEndFirst + 1
    iResult = iStartFirst
    
    Do While (iFirst <= iEndFirst) And (iSecond <= iEndSecond)
    
        'Select the smaller value and place in the output
        'Since the subarrays are already sorted, only one comparison is needed
        If lngSrc(iFirst) <= lngSrc(iSecond) Then
            lngDest(iResult) = lngSrc(iFirst)
            iFirst = iFirst + 1
        Else
            lngDest(iResult) = lngSrc(iSecond)
            iSecond = iSecond + 1
        End If
        
        iResult = iResult + 1
    Loop
    
    'Take care of any leftover values
    If iFirst > iEndFirst Then
        'Got some leftover seconds
        For iOuter = iSecond To iEndSecond
            lngDest(iResult) = lngSrc(iOuter)
            iResult = iResult + 1
        Next iOuter
    Else
        'Got some leftover firsts
        For iOuter = iFirst To iEndFirst
            lngDest(iResult) = lngSrc(iOuter)
            iResult = iResult + 1
        Next iOuter
    End If
End Sub

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


c0Title: Mersenne Twister Pseudo Random Number Generator
c1Code:
Option Explicit
Option Base 0
'The above "Option X" commands must be the 1st.lines in the file.
'Option Compare Database    'DO NOT USE IN THIS MODULE, not even for MS Access

'This is the Visual Basic for Applications (VBA) version of the  MT19937ar,
'or   "MERSENNE TWISTER"   algorithm for pseudo random number generation,
'with initialization improved, by  MAKOTO MATSUMOTO  and  TAKUJI NISHIMURA,
'of  2002/1/26.
'This translation to VBA was made and tested by Pablo Mariano Ronchi (2005-Sep-12)

'Note 1: VBA is the Visual Basic language used in MS Access, MS Excel and, in general,
'        in MS Office, and is called simply "Visual Basic" or VBA, hereinafter.
'Note 2: This same code compiles in Visual Basic (VB) without modifications.

'Please read the comments about this VBA version that follow the ones below, by
'the authors of the "MERSENNE TWISTER" algorithm.

'/*
'   A C-program for MT19937, with initialization improved 2002/1/26.
'   Coded by Takuji Nishimura and Makoto Matsumoto.
'
'   Before using, initialize the state by using init_genrand(seed)
'   or init_by_array(init_key, key_length).
'
'   Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
'   All rights reserved.
'
'   Redistribution and use in source and binary forms, with or without
'   modification, are permitted provided that the following conditions
'   are met:
'
'     1. Redistributions of source code must retain the above copyright
'        notice, this list of conditions and the following disclaimer.
'
'     2. Redistributions in binary form must reproduce the above copyright
'        notice, this list of conditions and the following disclaimer in the
'        documentation and/or other materials provided with the distribution.
'
'     3. The names of its contributors may not be used to endorse or promote
'        products derived from this software without specific prior written
'        permission.
'
'   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
'   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
'   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
'   A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
'   CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
'   EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
'   PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
'   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
'   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
'   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
'   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
'
'   Any feedback is very welcome.
'   http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
'   email: m-mat @ math.sci.hiroshima-u.ac.jp (remove space)
'*/



'COMMENTS ABOUT THIS VISUAL BASIC FOR APPLICATIONS (VBA) VERSION OF
'THE  "Mersenne Twister"  ALGORITHM:
'
'- All the statements made by the authors of the original algorithm and implementation,
'  present in the original C code and copied above, including but not limiting to those
'  regarding the license, the usage without any warranties, and the conditions for
'  distribution, apply to this Visual Basic program for testing that algorithm.
'
'- If you use this Visual Basic version, just for the record please send me an email to:
'
'  pmronchi@yahoo.com.ar
'
'  with an appropriate reference to your work, the city and country where you reside,
'  and the word "MT19937ar" in the subject. Thanks.
'
'
'- FUNCTIONS AND PROCEDURES IMPLEMENTED:
'
'       Function                    Returns values in the range:
'       -------------------------   -------------------------------------------------------
'       genrand_int32()             [0, 4294967295]  (0 to 2^32-1, A Double OF INTEGER VALUE)
'
'       genrand_int31()             [0, 2147483647]  (0 to 2^31-1)
'
'       genrand_real1()             [0.0, 1.0]   (both 0.0 and 1.0 included)
'
'       genrand_real2()             [0.0, 1.0) = [0.0, 0.9999999997672...]
'                                                (0.0 included, 1.0 excluded)
'
'       genrand_real3()             (0.0, 1.0) = [0.0000000001164..., 0.9999999998836...]
'                                                (both 0.0 and 1.0 excluded)
'
'       genrand_res53()             [0.0,~1.0] = [0.0, 1.00000000721774...]
'                                                (0.0 included, ~1.0 included)
'
'       The following ADDITIONAL functions
'       ARE NOT PRESENT IN THE ORIGINAL C CODE:
'
'       NOTE: the limits shown below, marked with (*), are valid if gap==5.0e-13
'
'
'       genrand_int32SignedLong()  [-2147483648, 2147483647]   (-2^31 to 2^31-1)
'
'       genrand_real2b()           [0.0, 1.0)=[0, 1-(2*gap)] =[0.0, 0.9999999999990] (*)
'                                             (0.0 included, 1.0 excluded)
'
'       genrand_real2c()           (0.0, 1.0]=[0+(2*gap),1.0]=[1.0e-12, 1.0] (*)
'                                             (0.0 excluded, 1.0 included)
'
'       genrand_real3b()           (0.0, 1.0)=[0+gap, 1-gap] =[5.0e-13, 0.9999999999995] (*)
'                                             (both 0.0 and 1.0 excluded)
'
'
'       (See the "Acknowledgements" section for the following functions)
'
'       genrand_real4b()           [-1.0,1.0]=[-1.0, 1.0]
'                                             (-1.0 included, 1.0 included)
'
'       genrand_real5b()           (-1.0,1.0)=[-1.0+(2*gap), 1.0-(2*gap)]=
'                                                    [-0.9999999999990,0.9999999999990] (*)
'                                             (-1.0 excluded, 1.0 excluded)
'
'
'       Procedure                 Arguments
'       ------------------------  ---------------------------------------------------------
'       init_genrand(seed)        any seed included in [-2147483648, 2147483647]
'       init_by_array(array,len)  array has N elements of type Long;
'                                 len==N, is the number of elements in the array
'
'
'- USAGE:
'
'  In your Visual Basic application (MS Access, MS Excel, VB compiler, etc):
'
'  1) Add this source file as a module with the proper name (I suggest "mt19937ar").
'     If you want to use the Mersenne Twister algorithm, and not just to test it,
'     REMOVE THE main() FUNCTION, at the end of this file, and keep the rest untouched.
'
'  2) (Optionally) call either the procedure init_genrand() with a proper seed,
'     or init_by_array() with the proper arguments, in order to (optionally)
'     initialize the pseudorandom sequence.
'
'     Note: If init_genrand() or init_by_array() were not called previous to the call
'           to any of the genrand_X() functions listed above, anyone of them will
'           automatically call init_genrand() by default the first time that is used,
'           with a seed==kDefaultSeed==5489 . This feature is present in the original C code.
'
'  3) Then, simply call any of the genrand_X() functions listed above.
'

'  Example of usage:
'
'     'Optionally initialize the pseudorandom sequence in the following way:
'
'          init_genrand 69769        'any seed in the range [-2147483648, 2147483647]
'
'     'Or (optionally, too) declare an array, initialize it, and call init_by_array()
'     'with the array and the number of its elements as arguments, in the following way:
'
'          Dim init As Variant: init = Array(123, 234, 345, 456)
'          Dim length As Long: length = 4
'
'          init_by_array init, length
'
'     '(If you do not use any of the 2 procedures above to initialize, initialization
'     'is performed automatically by a call to: init_genrand 5489)
'
'
'     'Then, get a pseudorandom number and assign it to variable x (of the proper
'     'Long or Double type), by calling one of the genrand_X() functions:
'
'          Dim x As Double
'          x=genrand_real2()
'
'
'- ON THE NEED OF THE Mersenne Twister ALGORITHM:
'
'  If you are serious about (pseudo) randomness in your Visual Basic project, then
'  you MUST use this Visual Basic version of the Mersenne Twister algorithm.
'  DO NOT RELY on the randomize() and rnd() routines provided by Visual Basic!
'
'
'- ON PERFORMANCE:
'
'  - If you are using Visual Basic, then performance is hardly an issue, and very probable
'    these routines will not be a bottleneck. Anyway, I made my best to optimize the code
'    for speed without compromising its clarity and readability, and while strictly
'    following the original C code.
'    If you need better performance, consider using the C or PHP version of the
'    Mersenne Twister algorithm, and MySQL for database management, for instance.
'
'  - This new version (September 2005), is around 9% faster than the previous one
'    published on-line (April 2005).
'
'  - Performance tests: For my own testing procedures I have developed a full test.
'    I would like to make the test package publicly available, but as of this writing
'    I have not asked Mr.Makoto Matsumoto yet. If he agrees, you will probably
'    find it close to the place were you found this code.
'
'  - Just to give you an idea of the difference in performance between C and VBA, one
'    of the parts of my test is a loop that only calls genrand_int32() repeatedly,
'    generating 100 million (1e08) pseudorandom numbers.
'    The times in my old Pentium MMX, 120Mhz, for this part of the test are:
'         6008 seconds (1h40m) for VBA, and 56 seconds for C (a relation of 107:1).
'
'  - A simple VBA code to test the performance is given below (SimplePerformanceTest()).
'    The C code provided in the main() function by the authors of the Mersenne Twister
'    algorithm could be easily adapted to match the result of a suitable modified
'    SimplePerformanceTest():
'
'    Public Sub SimplePerformanceTest()
'    Const kMaxNr As Long = 1000000    'CHANGE THIS VALUE AS NEEDED
'    Dim ii As Long, tmp As Double, sec1 As Double, sec2 As Double
'    Open "mt19937arVBtest.txt" For Output As #1    'open the output file
'
'    sec1 = Timer
'    For ii = 1 To kMaxNr: tmp = genrand_int32(): Next 'use any of the functions
'    sec2 = Timer: tmp = sec2 - sec1
'
'    Print #1, "Elapsed time in seconds for generating "; Trim(kMaxNr); " numbers: "; _
'              Fix(tmp) & "." & Format(Fix((tmp - Fix(tmp) + 0.005) * 100), "00")
'    Close #1    'close the output file
'    End Sub 'SimplePerformanceTest
'
'
'- DIFFERENCES WITH THE ORIGINAL C FUNCTIONS AND SOURCE FILE:
'
'  - The VBA version of genrand_int32() returns a Double in the range [0, 4294967295],
'    instead of a Long, because the Long type cannot accomodate the range of unsigned long
'    values returned by the C version. But all the returned values of the VBA version are
'    integers, as it is due. (To be true, they are not, but they should be considered so
'    because they are as integer as an integer value can be represented in a Double variable
'    following the IEEE standard, which is as exact as we need for all practical uses).
'    Because of this change, I had to rename the original C function genrand_int32() as
'    genrand_int32SignedLong(), returning a Long in the range [-2147483648,2147483647].
'
'  - I added uAdd(), uMult() and uDiv() to emulate unsigned long addition, multiplication
'    and division WITHIN THE CONTEXT of the Mersenne Twister algorithm implementation in
'    Visual Basic. THEY ARE NOT INTENDED FOR GENERAL USE!.
'
'  - There are minor changes (addition and use of variable mtb) to produce the same result
'    in Visual Basic as in C, when a genrand_X() function is called without a previous
'    call to one of the init_X procedures. I apologize for using this not very elegant
'    patch, but there is no simpler way to simulate the use of the "static" word in C,
'    given that the VBA's "static" word does not behave in a similar way.
'    Another minor change, for similar reasons, is the declaration and initialization of
'    the mag01() array.
'
'  - I added many constants, for clarity in some cases, and also for speed in others,
'    because some operations could be faster if defined as a multiplication instead of
'    a division, in some processors.
'
'  - I made small changes in the main() function, in order to easily change the number
'    of output values in the listings.
'
'
'- IS THIS VBA CODE DEPENDABLE?
'
'  Well, I think so. I have tested the code by generating 101026001 pseudorandom numbers
'  using all of the functions, printed 389 of them, and compared the result with a similar
'  test I wrote in C using the original code of the Mersenne Twister algorithm. Both
'  outputs were exactly the same, except for the timings and some variable headings.
'
'  Besides, I kept the original C code commented out in this source file, in order
'  to easily check and understand the translation to Visual Basic. So, you will find
'  a block of one or a few lines of Visual Basic code following the corresponding
'  -commented out- original C block.
'  This way you can easily see that I have strictly followed the original C code, except
'  for the minor differences explained in the above section, and verify that the VBA code
'  is an almost exact "copy" of the original algorithm.
'  This fact provides another level of confidence to the end result.
'
'  No bugs or problems were reported since the publication on-line of the previous
'  version (April 2005).
'
'
'- ACKNOWLEDGEMENTS:
'
'  I want to thank Mr.MAKOTO MATSUMOTO and Mr.TAKUJI NISHIMURA for creating and
'  generously sharing their excellent algorithm.
'
'  I also want to thank my friends Alejandra Mar�a Ribichich, Mariana Francisco Mera,
'  and V�ctor Fernando Torres, for their inspiration and support.
'
'  My friend Claudio Pacciarini clarified me some of the differences between VB and VBA.
'
'  Mr.Mutsuo Saito, assistant to professor Matsumoto, patiently e-mailed with me and
'  performed the necessary tasks for the previous version (April 2005) to appear on-line.
'
'  Mr. Kenneth C. Ives (USA) and Mr. David Grundy (Hong Kong) were the first ones
'  aknowledging the use of this VBA code. Thanks for your feedback!
'
'  Mr. Kenneth C. Ives also sent me some code and the idea in which I based
'  genrand_real4b() and genrand_real5b()
'
'
'  Pablo Mariano Ronchi
'  Buenos Aires, Argentina
'
'
'
'End of comments for the Visual Basic version





'#include <stdio.h>
'
'/* Period parameters */
'#define N 624
'#define M 397
'#define MATRIX_A 0x9908b0dfUL   /* constant vector a */
'#define UPPER_MASK 0x80000000UL /* most significant w-r bits */
'#define LOWER_MASK 0x7fffffffUL /* least significant r bits */
'
'static unsigned long mt[N];     /* the array for the state vector */
'static int mti=N+1;             /* mti==N+1 means mt[N] is not initialized */
Const N As Long = 624
Const M As Long = 397
Const MATRIX_A As Long = &H9908B0DF     '/* constant vector a */
Const UPPER_MASK As Long = &H80000000   '/* most significant w-r bits */
Const LOWER_MASK As Long = &H7FFFFFFF   '/* least significant r bits */

'To avoid innecesary operations while using the Visual Basic interpreter:
Const kDiffMN As Long = M - N
Const Nuplim As Long = N - 1
Const Muplim As Long = M - 1
Const Nplus1 As Long = N + 1
Const NuplimLess1 As Long = Nuplim - 1
Const NuplimLessM As Long = Nuplim - M

'static unsigned long mt[N];  /* the array for the state vector */
'static int mti=N+1;          /* mti==N+1 means mt[N] is not initialized */
Dim mt(0 To Nuplim) As Long  '/* the array for the state vector */
Dim mti As Long

'In the C original version the following array, mag01(), is declared within
'the function genrand_int32(). In VBA I had to declare it global for performance
'considerations, and because there is no way in VBA to emulate the use of the word
'"static" in C:
'
'static unsigned long mag01[2]={0x0UL, MATRIX_A};
'/* mag01[x] = x * MATRIX_A  for x=0,1 */
Dim mag01(2) As Long

Dim mtb As Boolean   'needed in Visual Basic

'Other constants defined to be used in this Visual Basic version:

'Powers of 2: k2_X means 2^X
Const k2_8 As Long = 256
Const k2_16 As Long = 65536
Const k2_24 As Long = 16777216

Const k2_31 As Double = 2147483648#     '2^31   ==  2147483648 == 80000000
Const k2_31Neg As Double = 0# - k2_31   '-2^31  == -2147483648 == 80000000
Const k2_31b As Double = k2_31 - 1#     '2^31-1 ==  2147483647 == 7FFFFFFF
Const k2_32 As Double = 2# * k2_31      '2^32   ==  4294967296 == 0
Const k2_32b As Double = k2_32 - 1#     '2^32-1 ==  4294967295 == FFFFFFFF == -1


'Constants for shift left operation:
Const kShl7 As Long = 128          '128==2^7
Const kShl15 As Long = 32768       '32768==2^15

'Constants for shift right operation:
Const kShr1 As Long = 2            '2==2^1
Const kShr5 As Long = 32           '32==2^5
Const kShr6 As Long = 64           '64==2^6
Const kShr11 As Long = 2048        '2048==2^11
Const kShr18 As Long = 262144      '262144==2^18
Const kShr30 As Long = 1073741824  '1073741824==2^30  used in init_X() functions

'The following constant has its value defined by the authors of the
'Mersenne Twister algorithm
Const kDefaultSeed As Long = 5489


'The following constant, is used within genrand_real1(), which returns values in [0,1]
Const kMT_1 As Double = 1# / k2_32b

'The following constant, is used within genrand_real2(), which returns values in [0,1)
Const kMT_2 As Double = 1# / k2_32

'The following constant, is used within genrand_real3(), which returns values in (0,1)
Const kMT_3 As Double = kMT_2

'The following constant, used within genrand_res53(), is needed, because the Visual
'Basic interpreter cannot read real LITERALS with the the same precision as a C compiler,
'and so ends up truncating the least significant decimal digit(s), a '2' in this case.
'The original factor used in the C code is: 9007199254740992.0
Const kMT_res53 As Double = 1# / (9.00719925474099E+15 + 2#)    'add lost digit '2'


'The following constants, are used within the ADDITIONAL functions genrand_real2b() and
'genrand_real3b(), equivalent to genrand_real() and genrand_real3(), but that return
'evenly distributed values in the ranges [0, 1-kMT_Gap] and [0+kMT_Gap, 1-kMT_Gap],
'respectively. A similar statement is valid also for genrand_real2c(), genrand_real4b()
'and genrand_real5b(). See the section "Functions and procedures implemented" above,
'for more details.
'
'If you want to change the value of kMT_Gap, it is suggested to do it so that:
'   5e-15 <= kMT_Gap <= 5e-2

Const kMT_Gap As Double = 0.0000000000005       '5.0E-13
Const kMT_Gap2 As Double = 2# * kMT_Gap         '1.0E-12
Const kMT_GapInterval As Double = 1# - kMT_Gap2 '0.9999999999990

Const kMT_2b As Double = kMT_GapInterval / k2_32b
Const kMT_2c As Double = kMT_2b
Const kMT_3b As Double = kMT_2b
Const kMT_4b As Double = 2# / k2_32b
Const kMT_5b As Double = (2# * kMT_GapInterval) / k2_32b   '1.999999999998/k2_32b



'Just for source file formatting. To make a space between the line separation below
'and the above declarations:
Const EndOfConstVarSection As Byte = 0








Private Function uAdd(ByVal x As Long, ByVal y As Long) As Long
'Unsigned Add: adds the two (signed) Long parameters, treated as
'unsigned long, and returns the result as a (signed) Long result:

Dim tmp As Double

tmp = CDbl(x) + y

If tmp < k2_31Neg Then
    uAdd = CLng(k2_32 + tmp)
Else
    If tmp > k2_31b Then
        uAdd = CLng(tmp - k2_32)
    Else
        uAdd = CLng(tmp)
    End If
End If

End Function    'uAdd





Private Function uMult(ByVal x As Long, ByVal y As Long) As Long
'Unsigned Mult: multiplies the two (signed) Long parameters, treated as
'unsigned long, and returns the lowest 4 bytes of the 8 bytes result
'as a (signed) Long result:

'This function emulates the multiplication of two (unsigned long) numbers,
'and is needed because the type Double has only a 53 bits mantissa
'and the result of multiplying 2 Long variables might need 64 bits to accurately
'represent the result in some cases.

'x   == ABCD  == A000 + B00 + C0 + D
'y   == EFGH  == E000 + F00 + G0 + H

'       Note: in the following, "ae" means the 2 bytes result of A*E, "bg" of B*G, etc:
'
'x*y == ae 000 000 +  'discard, result is too high
'       af 000  00 +  'discard, result is too high
'       ag 000   0 +  'discard, result is too high
'       ah 000     +  'take lowest byte

'       be  00 000 +  'discard, result is too high
'       bf  00  00 +  'discard, result is too high
'       bg  00   0 +  'take lowest byte
'       bh  00     +  'take both bytes

'       ce   0 000 +  'discard, result is too high
'       cf   0  00 +  'take lowest byte
'       cg   0   0 +  'take both bytes
'       ch   0     +  'take both bytes

'       de     000 +  'take lowest byte
'       df      00 +  'take both bytes
'       dg       0 +  'take both bytes
'       dh            'take both bytes


'Given that "aa" and "ee" are used just once, they are replaced by their
'values: aa == (x \ k2_24) and ee == (y \ k2_24), and they are not declared:
'Dim aa As Long, ee As Long

Dim bb As Long, cc As Long, dd As Long
Dim ff As Long, gg As Long, hh As Long
Dim r3 As Long, r2 As Long, r1 As Long, r0 As Long
Dim tmp As Double


'x==ABCD, y==EFGH
bb = (x \ k2_16) Mod k2_8: cc = (x \ k2_8) Mod k2_8: dd = x Mod k2_8
ff = (y \ k2_16) Mod k2_8: gg = (y \ k2_8) Mod k2_8: hh = y Mod k2_8


'get the 1st (lowest) byte of the result, r0:
'       dh             'take both bytes
r0 = dd * hh

'get the 2nd byte of the result, r1, and add carry from r0:
'       ch   0      +  'take both bytes
'       dg        0    'take both bytes
r1 = cc * hh + dd * gg + r0 \ k2_8

'get the 3rd byte of the result, r2, and add carry from r1:
'       bh  00      +  'take both bytes
'       cg   0    0 +  'take both bytes
'       df       00    'take both bytes
r2 = bb * hh + cc * gg + dd * ff + r1 \ k2_8

'get the 4th (highest) byte of the result, r3, and add carry from r2:
'       ah 000      +  'take lowest byte
'       bg  00    0 +  'take lowest byte
'       cf   0   00 +  'take lowest byte
'       de      000    'take lowest byte
r3 = (((x \ k2_24) * hh + bb * gg + cc * ff + dd * (y \ k2_24)) Mod k2_8) + r2 \ k2_8


'tmp = CDbl(r3) * k2_24 + r2 * k2_16 + r1 * k2_8 + r0
tmp = CDbl(r3 Mod k2_8) * k2_24 + (r2 Mod k2_8) * k2_16 + (r1 Mod k2_8) * k2_8 + (r0 Mod k2_8)

'now we have a 32 bits number (tmp) that can be processed without losing precision
'using the 53 bits mantissa of the Double type

If tmp < k2_31Neg Then
    uMult = CLng(k2_32 + tmp)
Else
    If tmp > k2_31b Then
        uMult = CLng(tmp - k2_32)
    Else
        uMult = CLng(tmp)
    End If
End If

End Function    'uMult




Private Function uDiv(ByVal x As Long, ByVal y As Long) As Long
'Unsigned Divide: divides the two (signed) Long parameters, treated as
'unsigned long, and returns the result as a (signed) Long result:

'No need to check y: this function is always called with y>=2.0
'If y < 0 Then y = k2_32 + y End If

If x < 0 Then
    uDiv = CLng(Fix((k2_32 + x) / y))
Else
    uDiv = CLng(Fix(x / y))
End If

End Function    'uDiv




Private Function uDiv2(ByVal x As Double, ByVal y As Long) As Double
'Unsigned Divide, 2nd.definition: divides a Double x by a (signed) Long divisor y,
'treated as unsigned long, and returns the result as a Double of integer value:

'No need to check y: this function is always called with y>=2.0
'If y < 0 Then y = k2_32 + y End If

If x < 0 Then
    uDiv2 = Fix((k2_32 + x) / y)
Else
    uDiv2 = Fix(x / y)
End If

End Function    'uDiv2








Public Sub init_genrand(ByVal seed As Long)      'void init_genrand(unsigned long s)
'/* initializes mt[N] with a seed */
'mt[0]= s & 0xffffffffUL;
'for (mti=1; mti<N; mti++) {
'    mt[mti] =
'    (1812433253UL * (mt[mti-1] ^ (mt[mti-1] >> 30)) + mti);
'    /* See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. */
'    /* In the previous versions, MSBs of the seed affect   */
'    /* only MSBs of the array mt[].                        */
'    /* 2002/01/09 modified by Makoto Matsumoto             */
'    mt[mti] &= 0xffffffffUL;
'    /* for >32 bit machines */

Dim tt As Long

mt(0) = (seed And &HFFFFFFFF)
For mti = 1 To Nuplim
    'original expression, rearranged in one line:
    'mt[mti] = (1812433253UL * (mt[mti-1] ^ (mt[mti-1] >> 30)) + mti);

    tt = mt(mti - 1)
    mt(mti) = uAdd(uMult(1812433253, (tt Xor uDiv(tt, kShr30))), mti)
    'innecesary, due to uAdd() and uMult():
    'mt(mti) = mt(mti) And &HFFFFFFFF   '/* for >32 bit machines */
Next

'The following code is not part of the original C code. I apologize for using this not very
'elegant patch, but there is no simpler way to simulate the use of the "static" word in C,
'given that the VBA's "static" word does not behave in a similar way:
mtb = True      'means mt[N] is already initialized
mag01(0) = 0: mag01(1) = MATRIX_A
End Sub     'init_genrand






Public Sub init_by_array(ByRef init_key As Variant, ByVal key_length As Integer)
'void init_by_array(unsigned long init_key[], int key_length)

'/* initialize by an array with array-length */
'/* init_key is the array for initializing keys */
'/* key_length is its length */
'/* slight change for C++, 2004/2/26 */

'int i, j, k;
Dim i As Integer, j As Integer, k As Integer
Dim tt As Long

'init_genrand(19650218UL);
'i=1; j=0;
'k = (N>key_length ? N : key_length);
init_genrand 19650218
i = 1: j = 0
k = IIf((N > key_length), N, key_length)


'for (; k; k--) {
For k = k To 1 Step -1  'while k<>0, that is: while k>0
    'original expression, rearranged in one line:
    'mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1664525UL)) + init_key[j] + j;

    tt = mt(i - 1)
    mt(i) = uAdd(uAdd((mt(i) Xor uMult((tt Xor uDiv(tt, kShr30)), 1664525)), init_key(j)), j)

    'mt[i] &= 0xffffffffUL;          /* for WORDSIZE > 32 machines */
    'innecesary, due to uAdd() and uMult():
    'mt(i) = mt(i) And &HFFFFFFFF    '/* for WORDSIZE > 32 machines */

    'i++; j++;
    'if (i>=N) { mt[0] = mt[N-1]; i=1; }
    'if (j>=key_length) j=0;
    i = i + 1: j = j + 1
    If i >= N Then mt(0) = mt(Nuplim): i = 1
    If j >= key_length Then j = 0
Next


'for (k=N-1; k; k--) {
For k = Nuplim To 1 Step -1
    'original expression, rearranged in one line:
    'mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1566083941UL)) - i;  /* non linear */

    tt = mt(i - 1)
    mt(i) = uAdd((mt(i) Xor uMult((tt Xor uDiv(tt, kShr30)), 1566083941)), -i)

    'mt[i] &= 0xffffffffUL;          /* for WORDSIZE > 32 machines */
    'innecesary, due to uAdd() and uMult():
    'mt(i) = mt(i) And &HFFFFFFFF    '/* for WORDSIZE > 32 machines */

    'i++;
    'if (i>=N) { mt[0] = mt[N-1]; i=1; }
    i = i + 1
    If i >= N Then mt(0) = mt(Nuplim): i = 1
Next


'mt[0] = 0x80000000UL;   /* MSB is 1; assuring non-zero initial array */
mt(0) = &H80000000      '/* MSB is 1; assuring non-zero initial array */

End Sub     'init_by_array





Public Function genrand_int32SignedLong() As Long   'unsigned long genrand_int32(void)
'This is the translation to VBA of the original C code for genrand_int32(), but renamed
'as explained in the section "Differences with the original C functions and source file"
'/* generates a random number on [0,0xffffffff]-interval */
'(Yes, BUT RETURNS IT AS A (signed) Long in the range [-2^31, 2^31-1])

'unsigned long y;
Dim y As Long

'The below lines were replaced by another approach. See section "On performance" for details:
'static unsigned long mag01[2]={0x0UL, MATRIX_A};
'/* mag01[x] = x * MATRIX_A  for x=0,1 */


If Not mtb Then     'needed in Visual Basic
    'This code is not part of the original C code. It is executed ONLY ONCE in the
    'lifetime of this program. I apologize for using this not very elegant patch,
    'but there is no simpler way to simulate the use of the "static" word in C, given
    'that the VBA's "static" word does not behave in a similar way:

    mti = Nplus1    '/* mti==N+1 means mt[N] is not initialized */
End If


If (mti >= N) Then  '{ /* generate N words at one time */
    'int kk;
    Dim kk As Long

    'if (mti == N+1)   /* if sgenrand() has not been called, */
    '  init_genrand(5489UL); /* a default initial seed is used */
    If mti = Nplus1 Then init_genrand kDefaultSeed

    'for (kk=0;kk<N-M;kk++) {
    '    y = (mt[kk]&UPPER_MASK)|(mt[kk+1]&LOWER_MASK);
    '    mt[kk] = mt[kk+M] ^ (y >> 1) ^ mag01[y & 0x1UL];
    '}
    For kk = 0 To (NuplimLessM)
        y = (mt(kk) And UPPER_MASK) Or (mt(kk + 1) And LOWER_MASK)
        mt(kk) = (mt(kk + M) Xor uDiv(y, kShr1)) Xor mag01(y And &H1)
    Next

    'for (;kk<N-1;kk++) {
    '    y = (mt[kk]&UPPER_MASK)|(mt[kk+1]&LOWER_MASK);
    '    mt[kk] = mt[kk+(M-N)] ^ (y >> 1) ^ mag01[y & 0x1UL];
    '}
    For kk = kk To NuplimLess1
        y = (mt(kk) And UPPER_MASK) Or (mt(kk + 1) And LOWER_MASK)
        mt(kk) = (mt(kk + kDiffMN) Xor uDiv(y, kShr1)) Xor mag01(y And &H1)
    Next

    'y = (mt[N-1]&UPPER_MASK)|(mt[0]&LOWER_MASK);
    'mt[N-1] = mt[M-1] ^ (y >> 1) ^ mag01[y & 0x1UL];
    y = (mt(Nuplim) And UPPER_MASK) Or (mt(0) And LOWER_MASK)
    mt(Nuplim) = (mt(Muplim) Xor uDiv(y, kShr1)) Xor mag01(y And &H1)

    'mti = 0;
    mti = 0
End If


y = mt(mti): mti = mti + 1
'/* Tempering */
'y ^= (y >> 11);
y = (y Xor uDiv(y, kShr11))
'y ^= (y << 7) & 0x9d2c5680UL;
y = (y Xor uMult(y, kShl7) And &H9D2C5680)
'y ^= (y << 15) & 0xefc60000UL;
y = (y Xor uMult(y, kShl15) And &HEFC60000)
'y ^= (y >> 18);
'y = (y Xor uDiv(y, kShr18))    'this step is condensed with the next:
'return y;
genrand_int32SignedLong = (y Xor uDiv(y, kShr18))
End Function    'genrand_int32SignedLong





Public Function genrand_int32() As Double   'unsigned long genrand()
'Returns a value in the range [0, 2^32-1] (that is: [0, 4294967295] )

'WARNINGS:
'   - The return type of the function is Double, not Long, but the values returned are
'     integers.
'   - If you want Long values in the range [-2^31, 2^31-1] ([-2147483648, 2147483647]),
'     then call genrand_int32SignedLong() instead of this function.

Dim tmp As Long

tmp = genrand_int32SignedLong()

If tmp < 0 Then
    genrand_int32 = tmp + k2_32
Else
    genrand_int32 = tmp
End If

End Function    'genrand_int32





Public Function genrand_int31() As Long   'long genrand_int31(void)
'/* generates a random number on [0,0x7fffffff]-interval */
'return (long)(genrand_int32()>>1);
genrand_int31 = CLng(uDiv2(genrand_int32(), kShr1))
End Function    'genrand_int31




Public Function genrand_real1() As Double   'double genrand_real1(void)
'/* generates a random number on [0,1]-real-interval */
'return genrand_int32()*(1.0/4294967295.0);     '/* divided by 2^32-1 */
genrand_real1 = genrand_int32() * kMT_1
End Function    'genrand_real1




Public Function genrand_real2() As Double   'double genrand_real2(void)
'/* generates a random number on [0,1)-real-interval */
'return genrand_int32()*(1.0/4294967296.0);     '/* divided by 2^32 */
genrand_real2 = genrand_int32() * kMT_2
End Function    'genrand_real2




Public Function genrand_real3() As Double   'double genrand_real3(void)
'/* generates a random number on (0,1)-real-interval */
'return (((double)genrand_int32()) + 0.5)*(1.0/4294967296.0);   '/* divided by 2^32 */
genrand_real3 = (genrand_int32() + 0.5) * kMT_3
End Function    'genrand_real3





Public Function genrand_res53() As Double   'double genrand_res53(void)
'/* generates a random number on [0,1) with 53-bit resolution*/
'unsigned long a=genrand_int32()>>5, b=genrand_int32()>>6;
'return(a*67108864.0+b)*(1.0/9007199254740992.0);
genrand_res53 = kMT_res53 * (uDiv2(genrand_int32(), kShr5) * 67108864# + _
                             uDiv2(genrand_int32(), kShr6))
End Function    'genrand_res53


'/* These (PREVIOUS) real versions are due to Isaku Wada, 2002/01/09 added */





'The following functions are present only in the Visual Basic version, not in the
'C version. See more comments in the definition of the constants used as factors:


Public Function genrand_real2b() As Double
'Returns results in the range [0,1) == [0, 1-kMT_Gap2]
'Its lowest value is : 0.0
'Its highest value is: 0.9999999999990
genrand_real2b = genrand_int32() * kMT_2b
End Function    'genrand_real2b


Public Function genrand_real2c() As Double
'Returns results in the range (0,1] == [0+kMT_Gap2, 1.0]
'Its lowest value is : 0.0000000000010  (1E-12)
'Its highest value is: 1.0
genrand_real2c = kMT_Gap2 + (genrand_int32() * kMT_2c)  '==kMT_Gap2+genrand_real2b()
End Function    'genrand_real2c


Public Function genrand_real3b() As Double   'double genrand_real3(void)
'Returns results in the range (0,1) == [0+kMT_Gap, 1-kMT_Gap]
'Its lowest value is : 0.0000000000005  (5E-13)
'Its highest value is: 0.9999999999995
genrand_real3b = kMT_Gap + (genrand_int32() * kMT_3b)
End Function    'genrand_real3b



'Mr. Kenneth C. Ives sent me some code and the idea in which I based genrand_real4b() and
'genrand_real5b(). Added on 2005-Sep-12:


Public Function genrand_real4b() As Double
'Returns results in the range [-1,1] == [-1.0, 1.0]
'Its lowest value is : -1.0
'Its highest value is: 1.0
genrand_real4b = (genrand_int32() * kMT_4b) - 1#
End Function    'genrand_real4b


Public Function genrand_real5b() As Double
'Returns results in the range (-1,1) == [-kMT_GapInterval, kMT_GapInterval]
'Its lowest value is : -0.9999999999990
'Its highest value is: 0.9999999999990
genrand_real5b = kMT_Gap2 + ((genrand_int32() * kMT_5b) - 1#)
End Function    'genrand_real5b







Private Sub main()   'int main(void)
'int i;
'unsigned long init[4]={0x123, 0x234, 0x345, 0x456}, length=4;
Dim i As Integer
Dim init As Variant: init = Array(&H123, &H234, &H345, &H456)
Dim length As Long: length = 4

Const kMaxPrint As Long = 1000 - 1
Dim tmp As Double, s As String


'init_by_array(init, length);
init_by_array init, length


Open "mt19937arVBTest.txt" For Output As #1    'open the output file

'printf("1000 outputs of genrand_int32()\n");
Print #1, Trim(kMaxPrint + 1); " outputs of genrand_int32()"

'for (i=0; i<1000; i++) {
'  printf("%10lu ", genrand_int32());
'  if (i%5==4) printf("\n");
'}
For i = 0 To kMaxPrint
    tmp = genrand_int32()

    s = tmp: If Len(s) < 10 Then s = Space(10 - Len(s)) & s
    Print #1, s;: If i Mod 5 = 4 Then Print #1, " " Else Print #1, " ";
Next


'printf("\n1000 outputs of genrand_real2()\n");
Print #1, "": Print #1, Trim(kMaxPrint + 1); " outputs of genrand_real2()"

'for (i=0; i<1000; i++) {
'  printf("%10.8f ", genrand_real2());
'  if (i%5==4) printf("\n");
'}
For i = 0 To kMaxPrint
    tmp = genrand_real2()

    s = Format(tmp, "0.00000000")
    'to force decimal point instead of decimal comma (as we use in Argentina):
    If tmp < 1# And tmp > 0# Then s = "0." & Right(s, 8)
    Print #1, s;: If i Mod 5 = 4 Then Print #1, " " Else Print #1, " ";
Next
'Print #1, ""


Close #1    'close the output file

'return 0;
End Sub     'main


c0Title:
Milliseconds are rounded to the nearest second when you try to assign the VBA Date format or the Variant Date format to a cell in an Excel worksheet

c1Code:
View products that this article applies to.
Article ID : 875526 
Last Review : February 13, 2007 
Revision : 3.0 

On This Page
SYMPTOMS 
CAUSE 
WORKAROUND 
Method 1 
Method 2 
SYMPTOMS
When you make a programmatic change to the value in a cell in a Microsoft Excel worksheet, the millisecond value that you specify is rounded to the nearest second. This issue occurs when the following conditions are true: � The change that you make assigns the VBA Date format or the Variant Date format to the cell. 
� You make the programmatic change by using a Visual Basic for Applications macro or by using an external Automation client. 
This issue does not occur when the change that you make assigns the Date format or the Time format to the cell. 
Back to the top

CAUSE
This issue occurs because Excel internally formats date strings according to the date and time format that is specified on the Regional Options tab of the Regional and Language Options item in Control Panel. This value is rounded to the nearest second. Excel assigns this value to the cell and then recalculates the value to produce a new date value for the cell. 
Back to the top

WORKAROUND
Use one of the following methods to work around this issue. 
Back to the top

Method 1
You can convert the date value into a string format that contains a fraction of a second. This string value can be assigned to and calculated as a date format that retains the milliseconds. 
Back to the top

Method 2
You can use the Value2 property of the Range object to retain the milliseconds. For example, you can use the following VBA code.
Sub CopyValueUsingVBDate()
   Dim d As Date
   d = ActiveSheet.Range("A1").Value
   ActiveSheet.Range("B1").Value2 = d
End Sub

For additional information, click the following article number to view the article in the Microsoft Knowledge Base: 
182812 (http://support.microsoft.com/kb/182812/) Description of the Value2 property for the Range object 
Back to the top


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

APPLIES TO
� Microsoft Office Excel 2007 
� Microsoft Office Excel 2003 
� Microsoft Excel 2002 Standard Edition 
� Microsoft Excel 2000 Standard Edition 

Back to the top

Keywords:  kbvba kbprogramming kbautomation kbtshoot kbprb KB875526 


c0Title: Modernize Your MDI Apps
c1Code:
The MDI look seems to have gone out of favor recently, judging from the popularity of the Explorer and Outlook styles in modern apps.
Maybe that�s because of the inconvenience of all those windows cluttering up the place, when only one is required at a time.
However, you can convert an MDI app to an Explorer-style app quickly. First, add a header bar, which in effect replaces the title bar of the child form. This can have your document name and properties on it. To implement this, add a PictureBox to the MDI form, and set its Align property to 1 - AlignTop.

Next, add a navigation bar. You typically place a TreeView or similar control here to provide a more intuitive way to locate and open views or items. This is also a PictureBox, but with its Align property equal to 3 - Align Left (resize the PictureBox to an acceptable width after doing this). Then, for each of your MDI child forms, set these properties:

� Caption: "" (Empty string).
� ControlBox: False
� WindowState: 2 - Maximized

Now change your code so the forms are loaded from the navigation bar instead of through the menus. Note that when MDI child forms are loaded, they appear to fill the entire remaining client space of the MDI form. However, without the control box, minimize, restore, and close icons that would normally be just below the title bar.

�Mark Bertenshaw, Kingston upon Thames, Surrey, England


c0Title: Moon Cycles
c1Code:
These two functions, and their support functions, can be used to determine the current phase of the moon given a particular date. 
        
      Code: 
     '--------------------------------------------------------------------
' Begin: Module modMoonCycle
'
' The function MoonPhase returns one of the Moon_Types for the
'  date passed.  Useful for creation of calendars, or when
'  you need to know the cycle of the moon.
'
' MoonPhaseDetail returns a double from 0 to .99 representing
'  the phase of the moon for a given day, where 0->.99 is a the
'  new moon through to the last quater
'
' The remaining functions are support functions, and should
'  not be called directly
'
'--------------------------------------------------------------------
' Adopted from pcal, which bares this copyright notice:
'
'  Routines to accurately calculate the phase of the moon
'
'  Originally adapted from "moontool.c" by John Walker, Release 2.0.
'
'   This routine (calc_phase) and its support routines were adapted
'   from phase.c (v 1.2 88/08/26 22:29:42 jef) in the program
'   "xphoon" (v 1.9 88/08/26 22:29:47 jef) by Jef Poskanzer and
'   Craig Leres. The necessary notice follows...
'
'   Copyright (C) 1988 by Jef Poskanzer and Craig Leres.
'
'   Permission to use, copy, modify, and distribute this software
'   and its documentation for any purpose and without fee is hereby
'   granted, provided that the above copyright notice appear in all
'   copies and that both that copyright notice and this permission
'   notice appear in supporting documentation.  This software is
'   provided "as is" without express or implied warranty.
'
'   These were added to "pcal" by RLD on 19-MAR-1991
'--------------------------------------------------------------------

Option Explicit

Public Enum Moon_Types
    Moon_Other = -1
    Moon_NewMoon = 0
    Moon_1stQuarter = 1
    Moon_FullMoon = 2
    Moon_3rdQuarter = 3
End Enum

'Astronomical constants.
Private Const epoch = 2444238.5 '1980 January 0.0

'Constants defining the Sun's apparent orbit.
Private Const elonge = 278.83354 'ecliptic longitude of the Sun
                                 'at epoch 1980.0
Private Const elongp = 282.596403 'ecliptic longitude of the Sun
                                  'at perigee
Private Const eccent = 0.016718 'eccentricity of Earth's orbit

'Elements of the Moon's orbit, epoch 1980.0.
Private Const mmlong = 64.975464 'moon's mean lonigitude at the epoch
Private Const mmlongp = 349.383063 'mean longitude of the perigee
                                   'at the epoch
Private Const mlnode = 151.950429 'mean longitude of the node at
                                  'the epoch

Private Const PI = 3.14159265358979
Private Const EPSILON = 0.000001

'Returns the phase of the moon as a number from 0.00 to 0.99
Public Function MoonPhaseDetail(InDate As Date) As Double

    Dim dateTemp As Date
    dateTemp = Int(InDate)
    MoonPhaseDetail = calc_phase(DatePart("m", dateTemp), _
        DatePart("d", dateTemp), DatePart("yyyy", dateTemp))

End Function

'Returns the approximate phase of the moon, or Moon_Other
' if none apply for the selected day
Public Function MoonPhase(InDate As Date) As Moon_Types

    Dim nPrev As Double
    Dim nCurr As Double
    Dim nNext As Double
    
    Dim dateTemp As Date
    dateTemp = Int(InDate) - 1
    nPrev = calc_phase(DatePart("m", dateTemp), _
        DatePart("d", dateTemp), DatePart("yyyy", dateTemp))
    
    dateTemp = Int(InDate)
    nCurr = calc_phase(DatePart("m", dateTemp), _
        DatePart("d", dateTemp), DatePart("yyyy", dateTemp))
    
    dateTemp = Int(InDate) + 1
    nNext = calc_phase(DatePart("m", dateTemp), _
        DatePart("d", dateTemp), DatePart("yyyy", dateTemp))
    
    MoonPhase = is_quarter(nPrev, nCurr, nNext)

End Function

'Begin of support functions:
Private Function torad(d As Double) As Double 'deg->rad
    torad = ((d) * (PI / 180#))
End Function
Private Function FNITG(x As Double) As Double 'cos from deg
    FNITG = (Sgn(x) * Int(Abs(x)))
End Function
Private Function fixangle(a As Double) As Double 'fix angle
    fixangle = ((a) - 360# * (Int((a) / 360#)))
End Function
Private Function todeg(d As Double) As Double 'rad->deg
    todeg = ((d) * (180# / PI))
End Function

'   julday -- calculate the julian date from input month, day, year
'       N.B. - The Julian date is computed for noon UT.
'
'       Adopted from Peter Duffett-Smith's book `Astronomy With Your
'       Personal Computer' by Rick Dyson 18-MAR-1991
Private Function julday(month As Long, day As Long, _
    year As Long) As Double

    Dim mn1 As Long, yr1 As Long
    Dim a As Double, b As Double, c As Double, d As Double
    Dim djd As Double

    mn1 = month
    yr1 = year
    If yr1 < 0 Then
        yr1 = yr1 + 1
    End If
    If month < 3 Then
        mn1 = month + 12
        yr1 = yr1 - 1
    End If
    
    If (year < 1582) Or ((year = 1582) And (month < 10)) Or _
        ((year = 1582) And (month = 10) And (day < 15#)) Then
        b = 0
    Else
        a = Int(yr1 / 100#)
        b = 2 - a + Int(a / 4)
    End If
    
    If yr1 >= 0 Then
        c = Int(365.25 * yr1) - 694025
    Else
        c = FNITG((365.25 * yr1) - 0.75) - 694025
    End If
    
    d = Int(30.6001 * (mn1 + 1))
    djd = b + c + d + day + 2415020#
    
    julday = djd

End Function

'  kepler - solve the equation of Kepler
Private Function kepler(m As Double, ecc As Double) As Double

    Dim e As Double, delta As Double

    e = torad(m)
    m = e
    Do
        delta = e - ecc * Sin(e) - m
        e = e - (delta / (1 - ecc * Cos(e)))
    Loop While (Abs(delta) > EPSILON)
    
    kepler = e

End Function

'  calc_phase - calculate phase of moon as a fraction:
'
'  The argument is the time for which the phase is requested,
'  expressed as the month, day and year.  It returns the phase of
'  the moon (0.0 -> 0.99) with the ordering as New Moon,
'  First Quarter, Full Moon, and Last Quarter.
'
'  Converted from the subroutine phase.c used by "xphoon.c" (see
'      above disclaimer) into calc_phase() for use in "moonphas.c"
'  by Rick Dyson 18-MAR-1991
Private Function calc_phase(month As Long, inday As Long, _
    year As Long) As Double

    Dim day As Double, n As Double, m As Double, ec As Double
    Dim lambdasun As Double, ml As Double, mm As Double
    Dim mn As Double, ev As Double, ae As Double, a3 As Double
    Dim mmp As Double, mec As Double, a4 As Double, lp As Double
    Dim v As Double, lpp As Double, np As Double, y As Double
    Dim x As Double, moonage As Double, pdate As Double

    'need to convert month, day, year into a Julian pdate
    pdate = julday(month, inday, year)

    'Calculation of the Sun's position.
    day = pdate - epoch 'date within epoch
    n = fixangle((360 / 365.2422) * day) 'mean anomaly of the Sun
    m = fixangle(n + elonge - elongp) 'convert from perigee
                                      'co-ordinates to epoch 1980.0
    ec = kepler(m, eccent) 'solve equation of Kepler
    ec = Sqr((1 + eccent) / (1 - eccent)) * Tan(ec / 2)
    ec = 2 * todeg(Atn(ec)) 'true anomaly
    lambdasun = fixangle(ec + elongp) 'Sun's geocentric ecliptic
                                      'longitude
    
    'Calculation of the Moon's position.
    ml = fixangle(13.1763966 * day + mmlong) 'Moon's mean longitude.
    mm = fixangle(ml - 0.1114041 * day - mmlongp) 'Moon's mean
                                                  'anomaly.
    mn = fixangle(mlnode - 0.0529539 * day) 'Moon's ascending node
                                            'mean longitude.
    ev = 1.2739 * Sin(torad(2 * (ml - lambdasun) - mm)) 'Evection.
    ae = 0.1858 * Sin(torad(m)) 'Annual equation.
    a3 = 0.37 * Sin(torad(m)) 'Correction term.
    mmp = mm + ev - ae - a3 'Corrected anomaly.
    mec = 6.2886 * Sin(torad(mmp)) 'Correction for the equation
                                   'of the centre.
    a4 = 0.214 * Sin(torad(2 * mmp)) 'Another correction term.
    lp = ml + ev + mec - ae + a4 'Corrected longitude.
    v = 0.6583 * Sin(torad(2 * (lp - lambdasun))) 'Variation.
    lpp = lp + v 'True longitude.
    
    'Calculation of the phase of the Moon.
    moonage = lpp - lambdasun 'Age of the Moon in degrees.
    
    calc_phase = (fixangle(moonage) / 360#)
End Function

'is_quarter - if current phase of moon coincides with quarter
' moon, return non negative integer, otherwise, return -1
Private Function is_quarter(prev As Double, curr As Double, _
    mnext As Double) As Long

    Dim quarter As Long
    Dim phase As Double, diff As Double
    
    'adjust phases for 1 -> 0 wraparound
    If curr < prev Then
        curr = curr + 1
    End If
    If mnext < prev Then
        mnext = mnext + 1
    End If

    is_quarter = -1

    ' if a quarter moon has occurred between "prev" and "next",
    ' return TRUE if "curr" is closer to it than "prev" or
    ' "next" is
    For quarter = 1 To 4
        phase = quarter / 4#
        If prev < phase Then
            If mnext > phase Then
                diff = Abs(curr - phase)
                If diff < phase - prev Then
                    If diff < mnext - phase Then
                        is_quarter = quarter Mod 4
                        Exit Function
                    End If
                End If
            End If
        End If
    Next

End Function

' End: Module modMoonCycle
'--------------------------------------------------------------------

     
        
      Sample Usage: 
        
         Dim nDate As Date
    nDate = #1/1/2001#
    Do Until year(nDate) <> 2001
        Select Case MoonPhase(nDate)
            Case Moon_NewMoon
                Debug.Print Format(nDate, "mm/dd/yyyy");
                Debug.Print " [  ] New moon"
            Case Moon_1stQuarter
                Debug.Print Format(nDate, "mm/dd/yyyy");
                Debug.Print " [ *] First quarter"
            Case Moon_FullMoon
                Debug.Print Format(nDate, "mm/dd/yyyy");
                Debug.Print " [**] Full moon"
            Case Moon_3rdQuarter
                Debug.Print Format(nDate, "mm/dd/yyyy");
                Debug.Print " [* ] Third quarter"
        End Select
        nDate = DateAdd("d", 1, nDate)
    Loop

     



