[x]
Posted via EE Mobile

Search, ask, and monitor your questions on the go with EE Mobile. Visit Experts Exchange from your mobile device and never be out of touch again.
Question
[x]
Attachment Details
[x]
The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

  • The Grade of the Solution
  • The Zone Rank of the Expert Providing the Solution
  • The Number of Author and Expert Comments
  • The Number of Experts Contributing
  • The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!
8.0

Browse for a folder in MS-Access 97

Asked by talal in Microsoft Access Database

I have a function that gets a folder by useing the API call.
Problem is, because of MS-Access Call-Back limitation.. i can not specify the default root.

I tried many solutions.. but still unable to get it to show a default root.

any ideas?

right now i get an error in the line "<--- Errors" in the code below

'===========================================================================
'
' MCommon.EventLog
'
' Common helper functions. Taken from MCommon.Bas
'
'===========================================================================
'
' Author:             Monte Hansen [monte@killervb.com]
' Dependencies:       None.
'
'===========================================================================
'
' == Copyright  1999-2002 by Monte Hansen, All Rights Reserved Worldwide ==
'
' Monte Hansen (The Author) grants a royalty-free right to use,  modify, and
' distribute this code (The Code) in compiled form,  provided that you agree
' that The Author has no warranty,  obligations or liability  for  The Code.
' You may distribute The Code among peers but may not sell it, or distribute
' it on any electronic or physical media such  as  floppy diskettes, compact
' disks, bulletin boards, web sites,  and the like,  without first obtaining
' The Author's consent.
'
' When distributing The Code among peers,  it is respectfully requested that
' it be distributed as is,  but  at  no time shall it be distributed without
' the copyright notice hereinabove.
'
'===========================================================================
Option Explicit


'===========================================================================
' Constants
'===========================================================================
Private Const Module                As String = "MCommon"

Private Const WM_USER               As Long = &H400&
Private Const ERROR_SUCCESS         As Long = 0
Private Const INVALID_HANDLE_VALUE  As Long = -1
Private Const LOGPIXELSX            As Long = 88
Private Const LOGPIXELSY            As Long = 90

Private Const MAX_COMPUTERNAME_LENGTH As Long = 15&

Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&

'===========================================================================
' Enums
'===========================================================================
'Public enum EncodeFormats           ' Used by HexEncodeData
'    efHexBytes = 0
'    efHexWORDS = 1
'    efHexDWORDs = 2
'    efHexQWORDs = 3
'End Enum

Private Const efHexBytes = 0
Private Const efHexWORDS = 1
Private Const efHexDWORDs = 2
Private Const efHexQWORDs = 3


'Public Enum ShellVirtualFolders     ' ShellFolder Browsing
'    CSIDL_DESKTOP = &H0             ' Windows desktop - virtual folder at the root of the name space.
'    CSIDL_INTERNET = &H1            ' Virtual folder representing the Internet
'    CSIDL_PROGRAMS = &H2            ' File system directory that contains the user's program groups (which are also file system directories).
'    CSIDL_CONTROLS = &H3            ' Control Panel - virtual folder containing icons for the control panel applications.
'    CSIDL_PRINTERS = &H4            ' Printers folder - virtual folder containing installed printers.
'    CSIDL_PERSONAL = &H5            ' File system directory that serves as a common respository for documents.
'    CSIDL_FAVORITES = &H6           ' Favorite Places - file system folder that stores web (or other) links
'    CSIDL_STARTUP = &H7             ' File system directory that corresponds to the user's Startup program group.
'    CSIDL_RECENT = &H8              ' File system directory that contains the user's most recently used documents.
'    CSIDL_SENDTO = &H9              ' File system directory that contains Send To menu items.
'    CSIDL_BITBUCKET = &HA           ' Recycle bin - file system directory containing file objects in the user's recycle bin.
                                    ' The location of this directory is not in the registry; it is marked with the hidden
                                    ' and system attributes to prevent the user from moving or deleting it.
'    CSIDL_STARTMENU = &HB           ' File system directory containing Start menu items.
'    CSIDL_DESKTOPDIRECTORY = &H10   ' File system directory used to physically store file objects on the desktop (not to be confused
                                    ' with the desktop folder itself).
'    CSIDL_DRIVES = &H11             ' My Computer - virtual folder containing everything on the local computer:
                                    ' storage devices, printers, and Control Panel. The folder may also contain mapped network drives.
'    CSIDL_NETWORK = &H12            ' Network Neighborhood - virtual folder representing the top level of the network hierarchy.
'    CSIDL_NETHOOD = &H13            ' File system directory containing objects that appear in the network neighborhood.
'    CSIDL_FONTS = &H14              ' Virtual folder containing fonts.
'    CSIDL_TEMPLATES = &H15          ' File system directory that serves as a common repository for document templates.
'    CSIDL_COMMON_STARTMENU = &H16   '
'    CSIDL_COMMON_PROGRAMS = &H17    '
'    CSIDL_COMMON_STARTUP = &H18     '
'    CSIDL_COMMON_DESKTOPDIRECTORY = &H19  '
'    CSIDL_APPDATA = &H1A            '
'    CSIDL_PRINTHOOD = &H1B          '
'    CSIDL_ALTSTARTUP = &H1D         ' // DBCS
'    CSIDL_COMMON_ALTSTARTUP = &H1E  ' // DBCS
'    CSIDL_COMMON_FAVORITES = &H1F
'    CSIDL_INTERNET_CACHE = &H20
'    CSIDL_COOKIES = &H21
'    CSIDL_HISTORY = &H22
'End Enum

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

'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

'/*
' * Queue status flags for GetQueueStatus() and MsgWaitForMultipleObjects()
' */
'Public Enum QueueStatusFlags
'    QS_KEY = &H1
'    QS_MOUSEMOVE = &H2
'    QS_MOUSEBUTTON = &H4
'    QS_POSTMESSAGE = &H8
'    QS_TIMER = &H10
'    QS_PAINT = &H20
'    QS_SENDMESSAGE = &H40
'    QS_HOTKEY = &H80
'    QS_ALLPOSTMESSAGE = &H100

'    QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)

'    QS_INPUT = (QS_MOUSE Or QS_KEY)

 '   QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)

'    QS_ALLINPUT = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY Or QS_SENDMESSAGE)
'End Enum



Public Const CSIDL_DESKTOP As Long = &H0                ' Windows desktop - virtual folder at the root of the name space.
Public Const CSIDL_INTERNET As Long = &H1               ' Virtual folder representing the Internet
Public Const CSIDL_PROGRAMS As Long = &H2               ' File system directory that contains the userPublic consts program groups (which are also file system directories).
Public Const CSIDL_CONTROLS As Long = &H3               ' Control Panel - virtual folder containing icons for the control panel applications.
Public Const CSIDL_PRINTERS As Long = &H4               ' Printers folder - virtual folder containing installed printers.
Public Const CSIDL_PERSONAL As Long = &H5               ' File system directory that serves as a common respository for documents.
Public Const CSIDL_FAVORITES As Long = &H6              ' Favorite Places - file system folder that stores web (or other) links
Public Const CSIDL_STARTUP As Long = &H7                ' File system directory that corresponds to the userPublic consts Startup program group.
Public Const CSIDL_RECENT As Long = &H8                 ' File system directory that contains the userPublic consts most recently used documents.
Public Const CSIDL_SENDTO As Long = &H9                 ' File system directory that contains Send To menu items.
Public Const CSIDL_BITBUCKET As Long = &HA              ' Recycle bin - file system directory containing file objects in the userPublic consts recycle bin.
                                    ' The location of this directory is not in the registry; it is marked with the hidden
                                    ' and system attributes to prevent the user from moving or deleting it.
Public Const CSIDL_STARTMENU As Long = &HB              ' File system directory containing Start menu items.
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10      ' File system directory used to physically store file objects on the desktop (not to be confused
                                    ' with the desktop folder itself).
Public Const CSIDL_DRIVES As Long = &H11                ' My Computer - virtual folder containing everything on the local computer:
                                    ' storage devices, printers, and Control Panel. The folder may also contain mapped network drives.
Public Const CSIDL_NETWORK As Long = &H12               ' Network Neighborhood - virtual folder representing the top level of the network hierarchy.
Public Const CSIDL_NETHOOD As Long = &H13               ' File system directory containing objects that appear in the network neighborhood.
Public Const CSIDL_FONTS As Long = &H14                 ' Virtual folder containing fonts.
Public Const CSIDL_TEMPLATES As Long = &H15             ' File system directory that serves as a common repository for document templates.
Public Const CSIDL_COMMON_STARTMENU As Long = &H16      '
Public Const CSIDL_COMMON_PROGRAMS As Long = &H17       '
Public Const CSIDL_COMMON_STARTUP As Long = &H18        '
Public Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19     '
Public Const CSIDL_APPDATA As Long = &H1A               '
Public Const CSIDL_PRINTHOOD As Long = &H1B             '
Public Const CSIDL_ALTSTARTUP As Long = &H1D            ' // DBCS
Public Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E     ' // DBCS
Public Const CSIDL_COMMON_FAVORITES As Long = &H1F
Public Const CSIDL_INTERNET_CACHE As Long = &H20
Public Const CSIDL_COOKIES As Long = &H21
Public Const CSIDL_HISTORY As Long = &H22

Public Const VER_PLATFORM_WIN32s As Long = 0
Public Const VER_PLATFORM_WIN32_WINDOWS As Long = 1
Public Const VER_PLATFORM_WIN32_NT As Long = 2

Public Const VT_EMPTY As Long = 0
Public Const VT_NULL As Long = 1
Public Const VT_I2 As Long = 2
Public Const VT_I4 As Long = 3
Public Const VT_R4 As Long = 4
Public Const VT_R8 As Long = 5
Public Const VT_CY As Long = 6
Public Const VT_DATE As Long = 7
Public Const VT_BSTR As Long = 8
Public Const VT_DISPATCH As Long = 9
Public Const VT_ERROR As Long = 10
Public Const VT_BOOL As Long = 11
Public Const VT_VARIANT As Long = 12
Public Const VT_UNKNOWN As Long = 13
Public Const VT_DECIMAL As Long = 14
Public Const VT_I1 As Long = 16
Public Const VT_UI1 As Long = 17
Public Const VT_UI2 As Long = 18
Public Const VT_UI4 As Long = 19
Public Const VT_I8 As Long = 20
Public Const VT_UI8 As Long = 21
Public Const VT_INT As Long = 22
Public Const VT_UINT As Long = 23
Public Const VT_VOID As Long = 24
Public Const VT_HRESULT As Long = 25
Public Const VT_PTR As Long = 26
Public Const VT_SAFEARRAY As Long = 27
Public Const VT_CARRAY As Long = 28
Public Const VT_USERDEFINED As Long = 29
Public Const VT_LPSTR As Long = 30
Public Const VT_LPWSTR As Long = 31
Public Const VT_FILETIME As Long = 64
Public Const VT_BLOB As Long = 65
Public Const VT_STREAM As Long = 66
Public Const VT_STORAGE As Long = 67
Public Const VT_STREAMED_OBJECT As Long = 68
Public Const VT_STORED_OBJECT As Long = 69
Public Const VT_BLOB_OBJECT As Long = 70
Public Const VT_CF As Long = 71
Public Const VT_CLSID As Long = 72
Public Const VT_VECTOR As Long = &H1000&
Public Const VT_ARRAY As Long = &H2000&
Public Const VT_BYREF As Long = &H4000&
Public Const VT_RESERVED As Long = &H8000&
Public Const VT_ILLEGAL As Long = &HFFFF&
Public Const VT_ILLEGALMASKED As Long = &HFFF&
Public Const VT_TYPEMASK As Long = &HFFF&

Public Const QS_KEY As Long = &H1
Public Const QS_MOUSEMOVE As Long = &H2
Public Const QS_MOUSEBUTTON As Long = &H4
Public Const QS_POSTMESSAGE As Long = &H8
Public Const QS_TIMER As Long = &H10
Public Const QS_PAINT As Long = &H20
Public Const QS_SENDMESSAGE As Long = &H40
Public Const QS_HOTKEY As Long = &H80
Public Const QS_ALLPOSTMESSAGE As Long = &H100

Public Const QS_MOUSE As Long = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)

Public Const QS_INPUT As Long = (QS_MOUSE Or QS_KEY)

 Public Const QS_ALLEVENTS As Long = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)

Public Const QS_ALLINPUT As Long = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY Or QS_SENDMESSAGE)

Public Const BIF_RETURNONLYFSDIRS As Long = &H1
Public Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Public Const BIF_STATUSTEXT As Long = &H4
Public Const BIF_RETURNFSANCESTORS As Long = &H8
Public Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Public Const BIF_BROWSEFORPRINTER As Long = &H2000



Public Type SHITEMID                        ' Shell item identifier
     cb As Long
     abID As Byte
End Type

Public Type ITEMIDLIST                      ' Shell item identifier list
     mkid As SHITEMID
End Type

Public Type BROWSEINFO                      ' shell structure used to browse for folders
     hOwner As Long
     pidlRoot As Long
     pszDisplayName As String
     lpszTitle As String
     ulFlags As Long
     lpfn As Long
     lParam As Long
     iImage As Long
End Type

'Public Enum BrowseFolderFlags               ' flags used to browse for folders
'    BIF_RETURNONLYFSDIRS = &H1
'    BIF_DONTGOBELOWDOMAIN = &H2
'    BIF_STATUSTEXT = &H4
'    BIF_RETURNFSANCESTORS = &H8
'    BIF_BROWSEFORCOMPUTER = &H1000
'    BIF_BROWSEFORPRINTER = &H2000
'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 tagDECIMAL
  wReserved                 As Integer
  scale                     As Byte             ' // The number of decimal places for the
                                                ' // number. Valid values are from 0 to 28. So
                                                ' // 12.345 is represented as 12345 with a
                                                ' // scale of 3.
  sign                      As Byte             ' // 0 for positive numbers or DECIMAL_NEG for
                                                ' // negative numbers. So -1 is represented as
                                                ' // 1 with the DECIMAL_NEG bit set.
  Hi32                      As Long ' unsigned
  Lo32                      As Long ' unsigned
  Mid32                     As Long ' unsigned
End Type

Public Type SAFEARRAYBOUND
    cElements               As Long             ' # of elements in the array dimension
    lLbound                 As Long             ' lower bounds of the array dimension
End Type

Public Type SAFEARRAY
    cDims                   As Integer          ' // Count of dimensions in this array.
    fFeatures               As Integer          ' // Flags used by the SafeArray
                                                ' // routines documented below.
    cbElements              As Long             ' // Size of an element of the array.
                                                ' // Does not include size of
                                                ' // pointed-to data.
    cLocks                  As Long             ' // Number of times the array has been
                                                ' // locked without corresponding unlock.
    pvData                  As Long             ' // Pointer to the data.
    ' Should be sized to cDims:
    rgsabound()             As SAFEARRAYBOUND   ' // One bound for each dimension.
End Type

'===========================================================================
'   Private members
'===========================================================================
Private OSVersion           As OSVERSIONINFO    ' private structure for various Public functions
Private Success             As Boolean          ' general return code [boolean]
Private ReturnVal           As Long             ' general return code [various]
Private ErrCode             As Long             ' general return code [error]

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

Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal Pidl As Long, ByVal pszPath As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, Pidl As ITEMIDLIST) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLIST
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

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

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 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 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 GetModuleFileNameA Lib "kernel32" (ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As Long
Private Declare Function GetModuleFileNameW Lib "kernel32" (ByVal hModule As Long, ByVal lpFilename As Long, ByVal nSize 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

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)

Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (ByVal lpSource As Long, ByVal nBytes 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 lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long

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

' LastDllErrorMsg related functions
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
     
Private Declare Function SafeArrayGetDim Lib "oleaut32" (psa As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function WaitForMultipleObjects Lib "kernel32" (ByVal nCount As Long, lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function WaitForMultipleObjectsEx Lib "kernel32" (ByVal nCount As Long, lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long
Private Declare Function MsgWaitForMultipleObjectsEx Lib "user32" ( _
  ByVal nCount As Long, pHandles As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long, ByVal dwFlags As Long) As Long
Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As Any, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

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

Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function timeGetTime Lib "winmm.dll" () As Long


Public Function BrowseForFolder( _
  ByVal hwnd As Long, _
  Optional ByVal TopFolder As Long = CSIDL_DESKTOP, _
  Optional ByVal Title As String = "Select folder", _
  Optional ByVal Flags As Long = BIF_RETURNONLYFSDIRS, _
  Optional ByVal DefaultFolder As String) As String
'===========================================================================
'   BrowseForFolder - Allows the user to browse for a folder using
'   the shell namespace.
'
'   TopFolder       Identifies the root folder.
'   Title           Attaches a description above the TreeView.
'   Flags           Misc flags defining behavior.
'   DefaultFolder   Reserved.
'===========================================================================
 
  Dim bi      As BROWSEINFO   ' input structure used by Shell API
  Dim idl     As ITEMIDLIST   ' input structure used by Shell API
  Dim Result  As Long         ' return code
  Dim Pidl    As Long         ' pointer to an Item ID List
  Dim Path    As String       ' resulting path returned
  Dim Pos     As Integer      ' parsing index

  ' Return default value if canceled
  BrowseForFolder = DefaultFolder

  With bi
   
    .hOwner = hwnd
   
    ' Convert virtual folder to pidl
    Result = SHGetSpecialFolderLocation(hwnd, TopFolder, idl)
    .pidlRoot = idl.mkid.cb
   
    ' set the dialog title
    .lpszTitle = Title
    ' input options
    .ulFlags = Flags
   
    ' Give callback info about default folder
    If Len(DefaultFolder) > 0 Then
   
      ' Set address of callback function
      .lpfn = ProcAddress(AddrOf(BrowseCallbackProc)) ' <-- ERRORS
   
      ' Convert to Ansi if not on NT
      If Not IsWinNt Then
        DefaultFolder = StrConv(DefaultFolder, vbFromUnicode)
      End If
     
      ' Store pointer to default folder
      .lParam = StrPtr(DefaultFolder)
   
    End If
   
  End With
 
  ' display browse dialog
  Pidl = SHBrowseForFolder(bi)
 
  ' Make sure Cancel not clicked
  If Pidl <> 0 Then
 
    ' size of the buffer to fit & pad with nulls
    Path = Space$(519) & vbNullChar
   
    ' copy the path to local buffer
    If CBool(SHGetPathFromIDList(Pidl, Path)) Then
      ' strip off null terminators
      Pos = InStr(Path, Chr$(0))
      BrowseForFolder = Left$(Path, Pos - 1)
    End If

    ' Release the pidl!
    CoTaskMemFree Pidl

  End If
   
End Function

Public Function BrowseCallbackProc( _
  ByVal hwnd As Long, _
  ByVal uMsg As Long, _
  ByVal lParam As Long, _
  ByVal lpData As Long) As Long

  Const WM_USER             As Long = &H400
  Const BFFM_INITIALIZED    As Long = 1
  ' // messages to browser
  Const BFFM_SETSELECTIONA  As Long = (WM_USER + 102)
  Const BFFM_SETSELECTIONW  As Long = (WM_USER + 103)

  Static ExitProc           As Boolean
 
  If ExitProc Then Exit Function
 
  Select Case uMsg
  Case BFFM_INITIALIZED
 
    ' Avoid reentry resulting from dialog
    ' another firing a BFFM_INITIALIZED when
    ' it receives a BFFM_SETSELECTION.
    ExitProc = True
   
    ' Tell tree browser to select the path
    ' pointed to at lpData.
    If IsWinNt() Then
      SendMessageA hwnd, BFFM_SETSELECTIONW, Abs(True), ByVal lpData
    Else
      SendMessageW hwnd, BFFM_SETSELECTIONA, Abs(True), ByVal lpData
    End If
 
    ' Allow reentry
    ExitProc = False
   
  End Select
 
End Function


Public Function LoBite(ByVal wParam As Integer) As Byte
    LoBite = wParam And &HFF
End Function

Public Function LoByte(ByVal wParam As Integer) As Byte
    LoByte = wParam And &HFF
End Function

Public Function HiByte(ByVal wParam As Integer) As Byte
    HiByte = (wParam And &HFF00&) \ 256
End Function

Public Function HiWord(ByVal lParam As Long) As Long
'===========================================================================
'   HiWord - Returns Hi Word part of the supplied dual long value which is often needed
'   when working with long values returned by API calls.
'
'   lParam      Input. Dual value returned by API call.
'
'   RETURNS     the high order word of the supplied long value
'===========================================================================
    HiWord = (lParam And &HFFFF0000) \ &H10000

End Function
   

Public Function LoWord(ByVal lParam As Long) As Long
'===========================================================================
'   LoWord - Returns Lo Word part of the supplied dual long value which is often needed
'   when working with long values returned by API calls.
'
'   lParam      Input. Dual value returned by API call.
'
'   RETURNS     the low order word of the supplied long value
'===========================================================================
    If (lParam And &H8000&) <> 0 Then
       LoWord = lParam Or &HFFFF0000
    Else
       LoWord = lParam And &HFFFF&
    End If
     
End Function

Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As Integer
'===========================================================================
'   MakeWord - Packs 2 8-bit integers into a 16-bit integer.
'===========================================================================

    If (HiByte And &H80) <> 0 Then
        MakeWord = ((HiByte * 256&) + LoByte) Or &HFFFF0000
    Else
        MakeWord = (HiByte * 256) + LoByte
    End If
   
End Function

Public Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
'===========================================================================
'   MakeDWord - Packs 2 16-bit integers into a 32-bit Long.
'
'   HiWord          The most significant 16 bits.
'
'   LoWord          The least significant 16 bits.
'
'   RETURNS:        A Long holding the full 32-bit value.
'===========================================================================
   
    MakeDWord = (HiWord * 65536) + (LoWord And &HFFFF&)

End Function

Public Function HexBytes(ByteArray) As String
'===========================================================================
'   HexByte - Returns a hex string representation of the supplied bite.
'===========================================================================

    Dim i As Long
   
    ' Sanity check input array
    If VarType(ByteArray) <> vbByte + vbArray Then
        Err.Raise 13, Module
    End If
   
    For i = LBound(ByteArray) To UBound(ByteArray)
        If Len(Hex$(ByteArray(i))) = 1 Then
            HexBytes = HexBytes & "0" & LCase$(Hex$(ByteArray(i))) & " "
        Else
            HexBytes = HexBytes & LCase$(Hex$(ByteArray(i))) & " "
        End If
    Next i
   
End Function


Public Function HexWORD(ByVal WORD As Long, Optional ByVal Prefix As String) As String
'===========================================================================
'   HexDWORD - Returns a hex string representation of a WORD.
'
'   WORD            The 2 byte value to convert to a hex string.
'   Prefix          A value such as "0x" or "&H".
'
'   NOTE:  It's up to the caller to ensure the subject value is a 16-bit number.
'===========================================================================

    Dim Bytes(1 To 2)   As Byte
    Dim i               As Long
   
    CopyMemory ByVal VarPtr(Bytes(1)), ByVal VarPtr(WORD), 4

    HexWORD = Prefix
    For i = UBound(Bytes) To LBound(Bytes) Step -1
        If Len(Hex$(Bytes(i))) = 1 Then
            HexWORD = HexWORD & "0" & LCase$(Hex$(Bytes(i)))
        Else
            HexWORD = HexWORD & LCase$(Hex$(Bytes(i)))
        End If
    Next i
   
End Function


Public Function HexDWORD(ByVal DWORD As Long, Optional ByVal Prefix As String) As String
'===========================================================================
'   HexDWORD - Returns a hex string representation of a DWORD.
'
'   DWORD           The 4 byte value to convert to a hex string.
'   Prefix          A value such as "0x" or "&H".
'===========================================================================

    Dim Bytes(1 To 4)   As Byte
    Dim i               As Long
   
    CopyMemory ByVal VarPtr(Bytes(1)), ByVal VarPtr(DWORD), 4

    HexDWORD = Prefix
    For i = UBound(Bytes) To LBound(Bytes) Step -1
        If Len(Hex$(Bytes(i))) = 1 Then
            HexDWORD = HexDWORD & "0" & LCase$(Hex$(Bytes(i)))
        Else
            HexDWORD = HexDWORD & LCase$(Hex$(Bytes(i)))
        End If
    Next i
   
End Function

Public Function HexQUAD(QWORD, Optional ByVal Prefix As String) As String
'===========================================================================
'   HexQUAD - Returns a hex string representation of a QWORD/QWORD.
'
'   QWORD           The decimal value to convert to a hex string.
'   Prefix          A value such as "0x" or "&H".
'===========================================================================

    Dim Bytes(1 To 8)   As Byte
    Dim i               As Long

    ' Sanity check input array
    If VarType(QWORD) <> vbDecimal Then
        Err.Raise 13, Module
    End If

    ' We only copy the first 8 bytes of the decimal value.
    CopyMemory ByVal VarPtr(Bytes(1)), ByVal VarPtr(LoDWord(QWORD)), 4
    CopyMemory ByVal VarPtr(Bytes(1)) + 4, ByVal VarPtr(HiDWord(QWORD)), 4

    HexQUAD = Prefix
    For i = UBound(Bytes) To LBound(Bytes) Step -1
        If Len(Hex$(Bytes(i))) = 1 Then
            HexQUAD = HexQUAD & "0" & LCase$(Hex$(Bytes(i)))
        Else
            HexQUAD = HexQUAD & LCase$(Hex$(Bytes(i)))
        End If
    Next i
   
End Function

Public Function HexEncodeData(Data, DisplayFormat As Long, Optional Prefix As String) As String
'===========================================================================
'   HexEncodeData - Returns a hex string representation of the supplied binary data.
'===========================================================================

    Dim Bytes()     As Byte         ' "String" varsion of "Data" converted to this
    Dim iStep       As Long         ' iterator step
    Dim Value       As Variant      ' Integer, Lond or Decimal data
    Dim lValue      As Long
    Dim lValueHi    As Long
    Dim cbValue     As Long
    Dim nElements   As Long         ' # of elements in the byte array
    Dim EncodedStr  As String       ' Encoded string like "0x00000000"
    Dim lpValue     As Long
    Dim ccValue     As Long         ' # of characters
    Dim i           As Long
    Dim j           As Long
   
    ' Sanity check input array
    Select Case VarType(Data)
    Case vbByte + vbArray
        ' default data type to encode
    Case vbString
        Bytes = Data
        ' NOTE: Caller should consider converting the string to ANSI
        HexEncodeData = HexEncodeData(Bytes, DisplayFormat)
        Exit Function
    Case Else
        Err.Raise 13, Module
    End Select
   
    Select Case DisplayFormat
    Case efHexBytes
        ' Don't loop if returning "byte" encoded values, just
        ' hand off the entire processing to another function.
        HexEncodeData = HexBytes(Data)
        Exit Function
    Case efHexWORDS
        iStep = 2
    Case efHexDWORDs
        iStep = 4
    Case efHexQWORDs
        iStep = 8
    Case Else
        Err.Raise 5, Module
    End Select
   
    ' Count # of elements in the array and ensure
    ' the array is fixed to the size of the output
    ' format.
    nElements = Abs((LBound(Data)) - (UBound(Data))) + 1
    If nElements Mod iStep <> 0 Then
        Err.Raise 5, Module, "Size of input data does not match output format."
    End If
   
    ' Size the output buffer to fit what will be returned.
    ' We do this because we don't want to perform any string
    ' concatenation which will kill our performance.
    ccValue = iStep + Len(Prefix) + 1   ' the "+ 1" is the (space) delimiter
    HexEncodeData = String((ccValue * nElements) - 1, " ")
   
    ' Loop thru entire array in 2, 4, or 8 byte increments.
    For i = LBound(Data) To UBound(Data) Step iStep
       
        ' Track # of actual conversions
        j = j + 1
        lpValue = VarPtr(Data(i))
       
        Select Case DisplayFormat
        Case efHexWORDS
           
            cbValue = nElements Mod 2
            If cbValue = 0 Then cbValue = 2
           
            CopyMemory ByVal VarPtr(lValue), ByVal lpValue, cbValue
            EncodedStr = HexWORD(lValue, Prefix)
           
        Case efHexDWORDs
           
            cbValue = nElements Mod 4
            If cbValue = 0 Then cbValue = 4
           
            CopyMemory ByVal VarPtr(lValue), ByVal lpValue, ByVal cbValue
            EncodedStr = HexDWORD(lValue, Prefix)
       
        Case efHexQWORDs
           
            cbValue = nElements Mod 8
            If cbValue = 0 Then cbValue = 8
           
            CopyMemory ByVal VarPtr(lValue), ByVal lpValue, cbValue
            CopyMemory ByVal VarPtr(lValueHi), ByVal lpValue + 4, cbValue
            EncodedStr = HexQUAD(MakeDecimal(lValueHi, lValue), Prefix)
       
        End Select
       
        ' Copy ONLY the bytes that represent the encoded value.
        ' The "* 2" is to account for Unicode.
        CopyMemory ByVal StrPtr(HexEncodeData) + (ccValue * 2) * (j - 1), _
            ByVal StrPtr(EncodedStr), Len(EncodedStr) * 2
       
    Next i

End Function

Public Function ProcAddress(ByVal lpFunction As Long) As Long
'===========================================================================
'   ProcAddress - Returns the address of the supplied function.
'
'   lpFunction      Function name. Passed "AddressOf <name>"
'
'   RETURNS         The 32 bit address of the function.
'===========================================================================
    ProcAddress = lpFunction
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

Public Function WinMajor() As Long

    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

    WinMajor = OSVersion.dwMajorVersion                     ' return the result

End Function

Public Function IsWin98OrLater() As Boolean

    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

    If OSVersion.dwMajorVersion > 4 Then
      IsWin98OrLater = True
    ElseIf OSVersion.dwMajorVersion = 4 _
    And OSVersion.dwMinorVersion > 0 Then
      IsWin98OrLater = True
    End If
   
End Function

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 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 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 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 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 InvalidHandleValue(ByVal Handle As Long) As Boolean

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

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 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 PtrToData(ByVal lpData As Long, ByVal DataType As Long, _
                           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.
   
    ' 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 Sub Pause(ByVal Milliseconds As Long, _
                 Optional ByVal WakeMask As QueueStatusFlags = QS_ALLINPUT, _
                 Optional lpAbort As Long
'===========================================================================
'   Pause - CPU Friendly way to pause a Task.
'===========================================================================

    Dim hEvent      As Long

    ' Sanity check.
    If Milliseconds <= 0 Then Exit Function

    ' Create a bogus event to wait on. It will never be siganaled.
    hEvent = CreateEvent(ByVal 0&, 1, 0, vbNullString)
    If IsValidHandle(hEvent) Then
        ' Wait until timeout expires
        WaitOnEvent hEvent, Milliseconds, WakeMask, lpAbort:=lpAbort
        ' Destroy the event
        CloseHandle hEvent
    Else
        ApiRaise Err.LastDllError, Module, "Could not create event."
    End If
   
End Function

Public Function WaitOnEvent( _
  ByVal hEvent As Long, _
  Optional ByVal TimeoutValue As Long = 15000, _
  Optional ByVal WakeMask As Long = QS_ALLINPUT, _
  Optional ByVal Alertable As Boolean, _
  Optional ByRef WaitValue As Long, _
  Optional ByVal lpAbort As Long) As Long

  ' Wait on the single event
  WaitOnEvent = WaitOnEvents( _
      VarPtr(hEvent), _
      1, _
      TimeoutValue, _
      WakeMask, _
      False, _
      Alertable, _
      WaitValue, _
      lpAbort)

End Function

Public Function WaitOnEvents( _
  ByVal lpEvents As Long, _
  Optional ByVal nEvents As Long = 1, _
  Optional ByVal TimeoutValue As Long = 15000, _
  Optional ByVal WakeMask As Long = QS_ALLINPUT, _
  Optional ByVal WaitOnAll As Boolean, _
  Optional ByVal Alertable As Boolean, _
  Optional ByRef WaitValue As Long, _
  Optional ByVal lpAbort As Long) As Long
   
  Const INFINITE = &HFFFFFFFF         ' Infinite timeout
  Const WAIT_FAILED = -1&
  Const WAIT_TIMEOUT = 258&           ' Wait timed out
  Const WAIT_ABANDONED_0 = &H80&
  Const WAIT_OBJECT_0 = 0
  Const WAIT_IO_COMPLETION = &HC0&    ' MsgWaitForMultipleObjectsEx
  Const MWMO_WAITALL = &H1
  Const MWMO_ALERTABLE = &H2
  Const MWMO_INPUTAVAILABLE = &H4

  Dim EndTime         As Long
  Dim TimeoutTicks    As Long
  Dim AbortVal        As Long
  Dim Flags           As Long
 
  ' Calculate time out value, if any supplied
  If TimeoutValue > 0 Then
      EndTime = timeGetTime() + TimeoutValue
  Else
      TimeoutTicks = INFINITE
  End If

  ' Or in flags
  If Alertable Then Flags = Flags Or MWMO_ALERTABLE
  If WaitOnAll Then Flags = Flags Or MWMO_WAITALL
 
  Do

    ' If an abort variable supplied...
    If lpAbort <> 0 Then
      ' Copy contents of abort variable to local variable
      CopyMemory ByVal VarPtr(AbortVal), ByVal lpAbort, 2
      ' Exit if the abort variable is set.
      If AbortVal <> 0 Then Exit Do
    End If

    ' Calculate # of milliseconds left before we must time out.
    If TimeoutValue > 0 Then
      TimeoutTicks = TickDiff(timeGetTime(), EndTime)
    End If

    ' Wait on the supplied event
    WaitValue = MsgWaitForMultipleObjectsEx _
      (nEvents, ByVal lpEvents, TimeoutTicks, WakeMask, Flags)

    ' Process the result
    Select Case WaitValue
    Case WAIT_IO_COMPLETION

      ' Exit a success, point to first item since we
      ' don't know which element completed.
      WaitOnEvents = 1
      Exit Do

    Case WAIT_OBJECT_0 To (WAIT_OBJECT_0 + nEvents - 1), _
         WAIT_ABANDONED_0 To (WAIT_ABANDONED_0 + nEvents - 1)
       
      ' Return a one-based index identifying the event that signaled
      WaitOnEvents = WaitValue + 1
      Exit Do
   
    Case WAIT_TIMEOUT
       
      ' We've timed out. Exit function.
      Exit Do
   
    Case WAIT_FAILED
       
      ' There was an error. Handle probably invalid.
      ApiRaise Err.LastDllError, , "Wait event(s) failed."
   
    Case (WAIT_OBJECT_0 + nEvents)
       
    Case Else
               
      Debug.Assert 0

    End Select

   DoEvents

  Loop

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 MakeDecimal( _
  ByVal HighDword As Long, _
  ByVal LowDword As Long, _
  Optional ByVal HighestDWord As Long, _
  Optional ByVal DecimalPlaces As Byte, _
  Optional ByVal Signed As Boolean) As Variant
'===========================================================================
' MakeDecimal - Convert up to three 32 bit integers into a 64 bit value.
'===========================================================================

  Const DECIMAL_NEG = &H80&
  Dim dec As tagDECIMAL

  ' NOTE: The Decimal data type uses all of the VARIANT
  ' structure except the 2 lead VARTYPE bytes. The Decimal
  ' data type is a 12 byte/96-bit value.

  ' Fill the decimal structure
  With dec
    .wReserved = VT_DECIMAL
    .Lo32 = LowDword
    .Mid32 = HighDword
    .Hi32 = HighestDWord
    Select Case DecimalPlaces
    Case 0 To 28
      .scale = DecimalPlaces
    Case Else
      Err.Raise 5
    End Select
   
    If Signed Then
      .sign = DECIMAL_NEG
    End If
  End With
 
  ' Copy the data into return value
  CopyMemory ByVal VarPtr(MakeDecimal), _
    ByVal VarPtr(dec.wReserved), LenB(dec

End Function

Public Function HiDWord(ByVal vDecimal As Variant) As Long
'===========================================================================
'   HiDWord - Returns the middle 32 bits of a 64 bit value [expressed as a
'   Decimal or Currency within a Variant].
'
'   NOTE: This function is often called when working with file system based API
'   calls. For that reason we force the "value" as a Decimal/Variant. This is to
'   avoid the hassle and confusion of scaling when using a Currency data type.
'   The technique of using the Currency data type in place of structures like
'   FILETIME and LARGE_INTEGER, et al., can be very tricky and is sometimes hard
'   to tell when and why they need to be scaled and de-scaled.
'
'   vDecimal       The 64 bit value.
'
'   RETURNS     The high order DWORD of the supplied 64 bit value.
'===========================================================================

  Dim dec As tagDECIMAL
 
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' File the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec

  HiDWord = dec.Mid32

End Function

Public Function LoDWord(ByVal vDecimal As Variant) As Long
'===========================================================================
'   LoDWord - Returns the lower 32 bits of a 64 bit value [expressed as a
'   Decimal or Currency within a Variant].
'
'   NOTE: This function is often called when working with file system based API
'   calls. For that reason we force the "value" as a Decimal/Variant. This is to
'   avoid the hassle and confusion of scaling when using a Currency data type.
'   The technique of using the Currency data type in place of structures like
'   FILETIME and LARGE_INTEGER, et al., can be very tricky and is sometimes hard
'   to tell when and why they need to be scaled and de-scaled.
'
'   vDecimal       The 64 bit value.
'
'   RETURNS     The low order DWORD of the supplied 64 bit value.
'===========================================================================
   
  Dim dec As tagDECIMAL
 
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' Fill the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec

  LoDWord = dec.Lo32

End Function


Public Function HighestDWord(ByVal vDecimal As Variant) As Long
'===========================================================================
'   HighestDWord - Returns the Highest 32 bits of a 64 bit value [expressed
'   as a Decimal or Currency within a Variant].
'
'   NOTE: This function is often called when working with file system based API
'   calls. For that reason we force the "value" as a Decimal/Variant. This is to
'   avoid the hassle and confusion of scaling when using a Currency data type.
'   The technique of using the Currency data type in place of structures like
'   FILETIME and LARGE_INTEGER, et al., can be very tricky and is sometimes hard
'   to tell when and why they need to be scaled and de-scaled.
'
'   vDecimal      The 64 bit value.
'
'   RETURNS       The low order DWORD of the supplied 64 bit value.
'===========================================================================
   
  Dim dec As tagDECIMAL
 
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' Fill the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec

  HighestDWord = dec.Hi32

End Function

Public Sub SplitDecimal( _
  ByVal vDecimal As Variant, _
  ByRef LowDword As Long, _
  ByRef HighDword As Long, _
  Optional ByRef HighestDWord As Long

  Dim dec As tagDECIMAL
 
  ' Ensure it's of the Decimal data type
  Select Case VarType(vDecimal)
  Case vbDecimal
      ' correct data type
  Case vbCurrency, vbLong, vbInteger
      ' a valid 64 bit integer
      vDecimal = CDec(vDecimal)
  Case Else
      ' anything else would be uncivilized
      Err.Raise 5
  End Select

  ' Fill the DECIMAL structure
  CopyMemory ByVal VarPtr(dec.wReserved), ByVal VarPtr(vDecimal), LenB(dec

  ' Return each part of the decimal value
  LowDword = dec.Lo32
  HighDword = dec.Mid32
  HighestDWord = dec.Hi32

End Sub


Public Function GetSafeArrayInfo(TheArray As Variant, ArrayInfo As SAFEARRAY) As Boolean
'===========================================================================
'   GetSafeArrayInfo - Fills a SAFEARRAY structure for the supplied array. The
'   information contained in the SAFEARRAY structure allows the caller to
'   identify the number of dimensions and the number of elements for each
'   dimension (among other things). Element information for each dimension is
'   stored in a one-based sub-array of SAFEARRAYBOUND structures (rgsabound).
'
'   TheArray        The array to get information on.
'   ArrayInfo       The output SAFEARRAY structure.
'
'   RETURNS         True if the array is instantiated.
'===========================================================================

    Dim lpData      As Long         ' Pointer to the variants data item
    Dim VType       As Integer      ' the VARTYPE member of the VARIANT structure

    ' Exit if no array supplied
    If Not IsArray(TheArray) Then Exit Function
   
    With ArrayInfo
   
        ' Get the VARTYPE value from the first 2 bytes of the VARIANT structure
        CopyMemory ByVal VarPtr(VType), ByVal VarPtr(TheArray), 2
       
        ' Get the pointer to the array descriptor (SAFEARRAY structure)
        ' NOTE: A Variant's descriptor, padding & union take up 8 bytes.
        CopyMemory ByVal VarPtr(lpData), ByVal (VarPtr(TheArray) + 8), 4

        ' Test if lpData is a pointer or a pointer to a pointer.
        If (VType And VT_BYREF) <> 0 Then

            ' Get real pointer to the array descriptor (SAFEARRAY structure)
            CopyMemory ByVal VarPtr(lpData), ByVal lpData, 4
           
            ' This will be zero if array not dimensioned yet
            If lpData = 0 Then Exit Function
           
        End If

        ' Fill the SAFEARRAY structure with the array info
        ' NOTE: The fixed part of the SAFEARRAY structure is 16 bytes.
        CopyMemory ByVal VarPtr(ArrayInfo.cDims), ByVal lpData, 16

        ' Ensure the array has been dimensioned before getting SAFEARRAYBOUND information
        If ArrayInfo.cDims > 0 Then

            ' Size the array to fit the # of bounds
            ReDim .rgsabound(1 To .cDims)

            ' Fill the SAFEARRAYBOUND structure with the array info
            CopyMemory ByVal VarPtr(.rgsabound(1)), ByVal lpData + 16, ArrayInfo.cDims * Len(.rgsabound(1))

            ' So caller knows there is information available for the array in output SAFEARRAY
            GetSafeArrayInfo = True
           
        End If

    End With

End Function

Public Function IsSomething(ByVal Object As Object) As Boolean

  IsSomething = Not (Object Is Nothing

End Function

Public Sub SetControlState( _
  ByVal Control As Control, _
  ByVal IsEnabled As Boolean, _
  Optional ByVal LockInputOnly As Boolean = True
'===========================================================================
' SetControlState - Changes the input state and appearance of a control to
' "Enabled" or "Disabled".
'===========================================================================
   
  ' Sanity check
  If Control Is Nothing Then Exit Sub
   
  Select Case TypeName(Control)
  Case "Label"

    ' For a Label, just change the forecolor
    SetControlColor Control, _
      IsEnabled Or LockInputOnly
   
  Case "TextBox", "ComboBox"
   
    ' Change Locked state & background color to match
    Control.Locked = Not IsEnabled
    SetControlColor Control, IsEnabled
   
  Case "ListBox"

    ' Listbox doesn't have a "Locked" property.
    Control.Enabled = IsEnabled Or LockInputOnly
    SetControlColor Control, IsEnabled
 
  Case "Frame", "PictureBox", "CheckBox", _
       "OptionButton", "CommandButton"
 
    ' Change state of known non-input controls.
    ' Ignore error if "Enabled" not exported.
    On Error Resume Next
    Control.Enabled = IsEnabled Or LockInputOnly
   
  Case Else
 
    ' Change state of other non-input controls
    ' Ignore error if "Enabled" not exported.
    On Error Resume Next
    Control.Enabled = IsEnabled Or LockInputOnly
 
  End Select

End Sub

Public Sub SetControlColor(Control As Control, IsEnabled As Boolean
'===========================================================================
' SetControlColor - Changes the appearance of a control to appear
' "Enabled" or "Disabled".
'===========================================================================

  Dim BackColor   As OLE_COLOR
  Dim ForeColor   As OLE_COLOR

  ' Sanity check
  If Control Is Nothing Then Exit Sub
 
  Select Case TypeName(Control)
  Case "Label", "Frame", "PictureBox", "CheckBox", _
       "OptionButton", "CommandButton"

    If IsEnabled Then
      Control.ForeColor = vbWindowText
    Else
      Control.ForeColor = vbGrayText 'vbInactiveCaptionText
    End If
   
  Case "TextBox", "ComboBox", "ListBox"
   
    If IsEnabled Then
      Control.BackColor = vbWindowBackground
    Else
      Control.BackColor = vbButtonFace
    End If

  Case Else

    If IsEnabled Then
      Control.BackColor = vbWindowBackground
    Else
      Control.BackColor = vbButtonFace
    End If
 
  End Select

End Sub

Public Sub SetControlChildState( _
  ByVal Control As Control, _
  IsEnabled As Boolean, _
  Optional UnNest As Boolean = True, _
  Optional LockInputOnly As Boolean = True
'===========================================================================
' SetControlChildState - Changes the state of a group of controls contained
' within supplied container.
'===========================================================================
 
  Dim Container   As Object
  Dim Ctl         As Control
  Dim hwnd        As Long

  ' Sanity check
  If Control Is Nothing Then Exit Sub
 
  ' Changes the Enabled or Locked property according to the current state.
  ' Also changes the Background color.
 
  ' Handle errors inline
  On Error Resume Next
 
  ' loop thru each control
  For Each Ctl In Control.Parent.Controls
   
    Set Container = Ctl.Container             ' save container reference
    ' NOTE: An error may have raised if it was a menu control,
    ' or some other control that doesn't export "Container" property.
   
    If Not Container Is Nothing Then          ' control has a container
     
      ' Get window handle for container
      hwnd = Ctl.Container.hwnd
     
      If hwnd = Control.hwnd Then
        ' it's a match
       
        Select Case TypeName(Ctl)
       
        Case "Frame", "PictureBox"
          ' These are known control containers

          If UnNest Then
            SetControlChildState Ctl, IsEnabled, UnNest, LockInputOnly
          End If
       
        Case Else

          ' If it's a child, set the state
          SetControlState Ctl, IsEnabled, LockInputOnly

        End Select

      End If
   
    End If
 
    ' Cleanup
    Set Container = Nothing
    hwnd = 0
 
  Next Ctl
 
End Sub


Public Function TickDiff(ByVal TickStart As Currency, ByVal TickEnd As Currency) As Long
'===========================================================================
'   TickDiff - Compares the result of two GetTickCount/timeGetTime calls and
'   returns the difference. Refer to the VBA.StrComp function for implementation.
'
'   This function handles such things as VB's two's complement as well as
'   wrapping by the GetTickCount function.
'===========================================================================

    ' Handle two's complement for values larger than 2147483647&
    If TickStart < 0 Then
        TickStart = TickStart + CCur(2 ^ 32)
    End If

    ' Handle two's complement AND the case where
    ' timeGetTime/GetTickCount wraps at (2 ^ 32 or ~49.7 days):
    If TickEnd < 0 _
    Or TickEnd < TickStart Then
        TickEnd = TickEnd + CCur(2 ^ 32)
    End If

    ' Return the result
    TickDiff = TickEnd - TickStart

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 SendMessage(hwnd As Long, wMsg As Long, wParam As Long, lParam As Long) As Long
'===========================================================================
'   SendMessage - ANSI/WIDE wrapper around API function.
'===========================================================================

    If IsWinNt Then                                             ' on NT, use WIDE calls
        SendMessage = SendMessageW(hwnd, wMsg, wParam, ByVal lParam)  ' make the call
    Else                                                        ' on Windows, use ANSI calls
        SendMessage = SendMessageA(hwnd, wMsg, wParam, ByVal lParam)
    End If
   
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 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

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 SHGetPathFromIDList(ByVal Pidl As Long, ByRef pszPath As String) As Long
'===========================================================================
'   SHGetPathFromIDList - ANSI/WIDE wrapper. Refer to the SDK.
'===========================================================================

    If Len(pszPath) = 0 Then pszPath = vbNullString     ' ensure blanks made NULL
   
    If IsWinNt Then                                     ' running in NT, use WIDE calls
        SHGetPathFromIDList = SHGetPathFromIDListW(Pidl, StrPtr(pszPath))
    Else                                                ' running on Win9X, use ANSI calls
        SHGetPathFromIDList = SHGetPathFromIDListA(Pidl, pszPath)
    End If

End Function

[+][-]08/13/05 12:10 AM, ID: 14666808Accepted Solution

View this solution now by starting your 30-day free trial. Setting up your free trial is quick, easy, and secure. We will return you to this solution, unlocked, when you're done.

About this solution

Zone: Microsoft Access Database
Sign Up Now!
Solution Provided By: modulo
Participating Experts: 2
Solution Grade: A
 
[+][-]01/14/05 02:56 PM, ID: 13049927Expert Comment

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 30-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]01/14/05 03:43 PM, ID: 13050254Author Comment

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]01/17/05 08:54 AM, ID: 13064807Author Comment

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]01/17/05 03:11 PM, ID: 13068066Author Comment

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]08/09/05 09:17 AM, ID: 14634131Administrative Comment

Experts Exchange has a courteous staff of administrators who help members get the most out of the website by means of administrative comments like this one.

Start your 30-day free trial to view this Administrative Comment or ask the Experts your question.

 
 
Loading Advertisement...
20091118-EE-VQP-93