The Complete Registry Module

'=================================================
'AUTHOR :  Eric O'Sullivan
' -----------------------------------------------
'DATE :   11 Januarary 2001
' -----------------------------------------------
'CONTACT:  [email protected]
' -----------------------------------------------
'TITLE :  Registry Access Module
' -----------------------------------------------
'COMMENTS :
'This was made to retrieve various information
'that is stored in the registry.
'=================================================
'all variables must be declared
Option Explicit
'this module cannot be accessed from outside this project
Option Private Module
'text comparisons are not case sensitive
Option Compare Text
'------------------------------------------------
'        API DECLARATIONS
'------------------------------------------------
'api calls to retereive the system and windows folders
Private Declare Function GetSystemDirectory _
    Lib "kernel32" _
    Alias "GetSystemDirectoryA" _
      (ByVal lpBuffer As String, _
       ByVal nSize As Long) _
       As Long
Private Declare Function GetWindowsDirectory _
    Lib "kernel32" _
    Alias "GetWindowsDirectoryA" _
      (ByVal lpBuffer As String, _
       ByVal nSize As Long) _
       As Long
'get the location of the temp directory on the system
Private Declare Function GetTempDirectory _
    Lib "kernel32" _
    Alias "GetTempPathA" _
      (ByVal lBufferLength As Long, _
       ByVal strBuffer As String) _
       As Long
'get information about the current operating system
Private Declare Function GetVersionEx _
    Lib "kernel32" _
    Alias "GetVersionExA" _
      (ByRef lpVersionInformation As OSVERSIONINFO) _
       As Long
'registry api calls
'close an open registry key
Private Declare Function RegCloseKey _
    Lib "advapi32.dll" _
      (ByVal hKey As Long) _
       As Long
       
'connect with the registry on a remote machine
Private Declare Function RegConnectRegistry _
    Lib "advapi32.dll" _
    Alias "RegConnectRegistryA" _
      (ByVal lpMachineName As String, _
       ByVal hKey As Long, _
       phkResult As Long) _
       As Long
'create a new registry key
Private Declare Function RegCreateKey _
    Lib "advapi32.dll" _
    Alias "RegCreateKeyA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       phkResult As Long) _
       As Long
'create new - entended
Private Declare Function RegCreateKeyEx _
    Lib "advapi32.dll" _
    Alias "RegCreateKeyExA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       ByVal Reserved As Long, _
       ByVal lpClass As String, _
       ByVal dwOptions As Long, _
       ByVal samDesired As Long, _
       lpSecurityAttributes As SECURITY_ATTRIBUTES, _
       phkResult As Long, _
       lpdwDisposition As Long) _
       As Long
'delete the specified registry key (also any sub keys
'for non-NT based systems)
Private Declare Function RegDeleteKey _
    Lib "advapi32.dll" _
    Alias "RegDeleteKeyA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String) _
       As Long
'delete a registry value
Private Declare Function RegDeleteValue _
    Lib "advapi32.dll" _
    Alias "RegDeleteValueA" _
      (ByVal hKey As Long, _
       ByVal lpValueName As String) _
       As Long
'return a list of registry sub keys in the specified key
Private Declare Function RegEnumKey _
    Lib "advapi32.dll" _
    Alias "RegEnumKeyA" _
      (ByVal hKey As Long, _
       ByVal dwIndex As Long, _
       ByVal lpName As String, _
       ByVal cbName As Long) _
       As Long
Private Declare Function RegEnumKeyEx _
    Lib "advapi32.dll" _
    Alias "RegEnumKeyExA" _
      (ByVal hKey As Long, _
       ByVal dwIndex As Long, _
       ByVal lpName As String, _
       lpcbName As Long, _
       ByVal lpReserved As Long, _
       ByVal lpClass As String, _
       lpcbClass As Long, _
       lpftLastWriteTime As FILETIME) _
       As Long
'get a list of registry values in a key
Private Declare Function RegEnumValue _
    Lib "advapi32.dll" _
    Alias "RegEnumValueA" _
      (ByVal hKey As Long, _
       ByVal dwIndex As Long, _
       ByVal lpValueName As String, _
       lpcbValueName As Long, _
       ByVal lpReserved As Long, _
       lpType As Long, _
       lpData As Byte, _
       lpcbData As Long) _
       As Long
'writes all the attributes of the specified open key
'into the registry
Private Declare Function RegFlushKey _
    Lib "advapi32.dll" _
      (ByVal hKey As Long) _
       As Long
'get the security attributes of the specified key
Private Declare Function RegGetKeySecurity _
    Lib "advapi32.dll" _
      (ByVal hKey As Long, _
       ByVal SecurityInformation As Long, _
       pSecurityDescriptor As SECURITY_DESCRIPTOR, _
       lpcbSecurityDescriptor As Long) _
       As Long
'creates a subkey under HKEY_USER or HKEY_LOCAL_MACHINE
'and stores registration information from a specified
'file into that subkey. This registration information
'is in the form of a hive. A hive is a discrete body of
'keys, subkeys, and values that is rooted at the top of
'the registry hierarchy. A hive is backed by a single
'file and .LOG file
Private Declare Function RegLoadKey _
    Lib "advapi32.dll" _
    Alias "RegLoadKeyA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       ByVal lpFile As String) _
       As Long
'notify a specified procedure (use the AddressOf
'operator), that a key has changed
Private Declare Function RegNotifyChangeKeyValue _
    Lib "advapi32.dll" _
      (ByVal hKey As Long, _
       ByVal bWatchSubtree As Long, _
       ByVal dwNotifyFilter As Long, _
       ByVal hEvent As Long, _
       ByVal fAsynchronus As Long) _
       As Long
'open a registry key for access
Private Declare Function RegOpenKey _
    Lib "advapi32.dll" _
    Alias "RegOpenKeyA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       phkResult As Long) _
       As Long
Private Declare Function RegOpenKeyEx _
    Lib "advapi32.dll" _
    Alias "RegOpenKeyExA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       ByVal ulOptions As Long, _
       ByVal samDesired As Long, _
       phkResult As Long) _
       As Long
'get key information
Private Declare Function RegQueryInfoKey _
    Lib "advapi32.dll" _
    Alias "RegQueryInfoKeyA" _
      (ByVal hKey As Long, _
       ByVal lpClass As String, _
       lpcbClass As Long, _
       ByVal lpReserved As Long, _
       lpcSubKeys As Long, _
       lpcbMaxSubKeyLen As Long, _
       lpcbMaxClassLen As Long, _
       lpcValues As Long, _
       lpcbMaxValueNameLen As Long, _
       lpcbMaxValueLen As Long, _
       lpcbSecurityDescriptor As Long, _
       lpftLastWriteTime As FILETIME) _
       As Long
'get value information. Note that if you declare the
'lpData parameter as String, you must pass it By Value.
Private Declare Function RegQueryValue _
    Lib "advapi32.dll" _
    Alias "RegQueryValueA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       ByVal lpValue As String, _
       lpcbValue As Long) _
       As Long
Private Declare Function RegQueryValueEx _
    Lib "advapi32.dll" _
    Alias "RegQueryValueExA" _
      (ByVal hKey As Long, _
       ByVal lpValueName As String, _
       ByVal lpReserved As Long, _
       lpType As Long, _
       lpData As Any, _
       lpcbData As Long) _
       As Long
'replace one key with another
Private Declare Function RegReplaceKey _
    Lib "advapi32.dll" _
    Alias "RegReplaceKeyA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       ByVal lpNewFile As String, _
       ByVal lpOldFile As String) _
       As Long
'reads registry information from a file and enters it
'into the registry
Private Declare Function RegRestoreKey _
    Lib "advapi32.dll" _
    Alias "RegRestoreKeyA" _
      (ByVal hKey As Long, _
       ByVal lpFile As String, _
       ByVal dwFlags As Long) _
       As Long
'saves a registry key and all its values to a file
Private Declare Function RegSaveKey _
    Lib "advapi32.dll" _
    Alias "RegSaveKeyA" _
      (ByVal hKey As Long, _
       ByVal lpFile As String, _
       lpSecurityAttributes As SECURITY_ATTRIBUTES) _
       As Long
'set the security attributes of the specified registry
'key
Private Declare Function RegSetKeySecurity _
    Lib "advapi32.dll" _
      (ByVal hKey As Long, _
       ByVal SecurityInformation As Long, _
       pSecurityDescriptor As SECURITY_DESCRIPTOR) _
       As Long
'set the information of an existing value. Note that if
'you declare the lpData parameter as String, you must
'pass it By Value.
Private Declare Function RegSetValue _
    Lib "advapi32.dll" _
    Alias "RegSetValueA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String, _
       ByVal dwType As Long, _
       ByVal lpData As String, _
       ByVal cbData As Long) _
       As Long
Private Declare Function RegSetValueEx _
    Lib "advapi32.dll" _
    Alias "RegSetValueExA" _
      (ByVal hKey As Long, _
       ByVal lpValueName As String, _
       ByVal Reserved As Long, _
       ByVal dwType As Long, _
       lpData As Any, _
       ByVal cbData As Long) _
       As Long
       
'unloads a registry key and its values from the registry
Private Declare Function RegUnLoadKey _
    Lib "advapi32.dll" _
    Alias "RegUnLoadKeyA" _
      (ByVal hKey As Long, _
       ByVal lpSubKey As String) _
       As Long
'system information api calls
Private Declare Sub GlobalMemoryStatus _
    Lib "kernel32" _
      (lpBuffer As MEMORYSTATUS)
Private 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
Private Declare Function GetTickCount _
    Lib "kernel32" _
      () As Long
'------------------------------------------------
'          ENUMERATORS
'------------------------------------------------
Public Enum MemType
  CPUUsage
  MemoryUsage
  TotalPhysical
  AvailablePhysical
  TotalPageFile
  AvailablePageFile
  TotalVirtual
  AvailableVirtual
  TotalDisk
  AvailableDisk
End Enum
Public Enum AccessType
  FileInput = 0
  FileOutPut = 1
  FileRandom = 2
  FileBinary = 3
  FileAppend = 4
End Enum
'registry root directory constants
Public Enum RegistryHives
  HKEY_CLASSES_ROOT = &H80000000
  HKEY_CURRENT_CONFIG = &H80000005
  HKEY_CURRENT_USER = &H80000001
  HKEY_DYN_DATA = &H80000006
  HKEY_LOCAL_MACHINE = &H80000002
  HKEY_PERFORMANCE_DATA = &H80000004
  HKEY_USERS = &H80000003
End Enum
'registry key constants
Public Enum RegistryKeyAccess
  KEY_CREATE_LINK = &H20
  KEY_CREATE_SUB_KEY = &H4
  KEY_ENUMERATE_SUB_KEYS = &H8
  KEY_EVENT = &H1  ' Event contains key event record
  KEY_NOTIFY = &H10
  KEY_QUERY_VALUE = &H1
  KEY_SET_VALUE = &H2
  READ_CONTROL = &H20000
  STANDARD_RIGHTS_ALL = &H1F0000
  STANDARD_RIGHTS_REQUIRED = &HF0000
  SYNCHRONIZE = &H100000
  STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
  STANDARD_RIGHTS_READ = (READ_CONTROL)
  STANDARD_RIGHTS_WRITE = (READ_CONTROL)
  KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL + KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK) And (Not SYNCHRONIZE))
  KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
  KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
  KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
End Enum
'registry value attributes
Public Enum RegistryKeyValues
  REG_CREATED_NEW_KEY = &H1        ' New Registry Key created
  REG_EXPAND_SZ = 2            ' Unicode nul terminated string
  REG_FULL_RESOURCE_DESCRIPTOR = 9    ' Resource list in the hardware description
  REG_LINK = 6              ' Symbolic Link (unicode)
  REG_MULTI_SZ = 7            ' Multiple Unicode strings
  REG_NONE = 0              ' No value type
  REG_NOTIFY_CHANGE_ATTRIBUTES = &H2
  REG_NOTIFY_CHANGE_LAST_SET = &H4    ' Time stamp
  REG_NOTIFY_CHANGE_NAME = &H1      ' Create or delete (child)
  REG_NOTIFY_CHANGE_SECURITY = &H8
  REG_OPENED_EXISTING_KEY = &H2      ' Existing Key opened
  REG_OPTION_BACKUP_RESTORE = 4      ' open for backup or restore
  REG_OPTION_CREATE_LINK = 2       ' Created key is a symbolic link
  REG_OPTION_NON_VOLATILE = 0       ' Key is preserved when system is rebooted
  REG_OPTION_RESERVED = 0         ' Parameter is reserved
  REG_OPTION_VOLATILE = 1         ' Key is not preserved when system is rebooted
  REG_REFRESH_HIVE = &H2         ' Unwind changes to last flush
  REG_RESOURCE_LIST = 8          ' Resource list in the resource map
  REG_RESOURCE_REQUIREMENTS_LIST = 10
  REG_SZ = 1               ' Unicode nul terminated string
  REG_WHOLE_HIVE_VOLATILE = &H1      ' Restore whole hive volatile
  REG_LEGAL_CHANGE_FILTER = (REG_NOTIFY_CHANGE_NAME Or REG_NOTIFY_CHANGE_ATTRIBUTES Or REG_NOTIFY_CHANGE_LAST_SET Or REG_NOTIFY_CHANGE_SECURITY)
  REG_LEGAL_OPTION = (REG_OPTION_RESERVED Or REG_OPTION_NON_VOLATILE Or REG_OPTION_VOLATILE Or REG_OPTION_CREATE_LINK Or REG_OPTION_BACKUP_RESTORE)
End Enum
Public Enum RegistryDataTypes
  REG_DT_SZ = 1         ' string data
  REG_DT_BINARY = 3       ' Free form binary
  REG_DT_DWORD = 4        ' 32-bit number
  REG_DT_DWORD_BIG_ENDIAN = 5  ' 32-bit number
  REG_DT_DWORD_LITTLE_ENDIAN = 4 ' 32-bit number (same as REG_DWORD)
End Enum
Public Enum RegistryLongTypes
  REG_BINARY = 3       ' Free form binary
  REG_DWORD = 4        ' 32-bit number
  REG_DWORD_BIG_ENDIAN = 5  ' 32-bit number
  REG_DWORD_LITTLE_ENDIAN = 4 ' 32-bit number (same as REG_DWORD)
End Enum
'error codes returned
Public Enum RegistryErrorCodes
  ERROR_ACCESS_DENIED = 5&
  ERROR_INVALID_PARAMETER = 87 ' dderror
  ERROR_MORE_DATA = 234 ' dderror
  ERROR_SUCCESS = 0&
End Enum
'the shell folders like my documents, recycle bin, temp directory etc.
Public Enum ShellFoldersType
  'registry entry names
  ApplicationDataDir = 0
  TempInetFilesDir = 1
  CookiesDir = 2
  DesktopDir = 3
  FavouritesDir = 4
  FontsDir = 5
  HistoryDir = 6
  LocalAppDataDir = 7
  NetHoodDir = 8
  MyDocumentsDir = 9
  PrintHoodDir = 10
  StartProgramsDir = 11
  RecentDir = 12
  SendToDir = 13
  StartMenuDir = 14
  StartupDir = 15
  TemplatesDir = 16
  
  'these next items are not stored in the registry
  SystemDir = 17
  WindowsDir = 18
  TempDir = 19 'temperory folder is always in the Windows directory
End Enum
Public Enum StartLoginType
  RunBeforeLogin
  RunAfterLogin
End Enum
'the different nt privilages that can be set/unset
Public Enum EnumNTSettings
  'items that can be disabled on the Lock Screen
  CHANGE_PASSWORD = 0
  LOCK_WORKSTATION = 1
  REGISTRY_TOOLS = 2
  TASK_MGR = 3
  
  'the tabs on the Display Properties dialog box
  DISP_APPEARANCE_PAGE = 4
  DISP_BACKGROUND_PAGE = 5
  DISP_CPL = 6
  DISP_SCREENSAVER = 7
  DISP_SETTINGS = 8
End Enum
'------------------------------------------------
'        USER-DEFINED TYPES
'------------------------------------------------
'holds information about the current operating system that the program is
'running on
Private Type OSVERSIONINFO
  dwOSVersionInfoSize     As Long
  dwMajorVersion       As Long
  dwMinorVersion       As Long
  dwBuildNumber        As Long
  dwPlatformId        As Long
  szCSDVersion        As String * 128
End Type
'the current status of physical (ram), virtual memory and the page file.
Public Type MEMORYSTATUS
    dwLength        As Long
    dwMemoryLoad      As Long
    dwTotalPhys       As Long
    dwAvailPhys       As Long
    dwTotalPageFile     As Long
    dwAvailPageFile     As Long
    dwTotalVirtual     As Long
    dwAvailVirtual     As Long
End Type
'defined structures needed
Public Type ACL
    AclRevision       As Byte
    Sbz1          As Byte
    AclSize         As Integer
    AceCount        As Integer
    Sbz2          As Integer
End Type
Public Type FILETIME
    dwLowDateTime      As Long
    dwHighDateTime     As Long
End Type
Public Type SECURITY_ATTRIBUTES
    nLength         As Long
    lpSecurityDescriptor  As Long
    bInheritHandle     As Long
End Type
Public Type SECURITY_DESCRIPTOR
    Revision        As Byte
    Sbz1          As Byte
    Control         As Long
    gstrOwner        As Long
    Group          As Long
    Sacl          As ACL
    Dacl          As ACL
End Type
'------------------------------------------------
'       MODULE-LEVEL CONSTANTS
'------------------------------------------------
'module constants
Private Const WIN_INFO_SUBKEY    As String = "Software\Microsoft\Windows\CurrentVersion"         'HKEY_LOCAL_MACHINE
Private Const WIN_NT_INFO_SUBKEY  As String = "Software\Microsoft\Windows NT\CurrentVersion"       'HKEY_LOCAL_MACHINE
Private Const SHELL_FOLDERS_SUBKEY As String = ".Default\Software\Microsoft\Windows\" + _
                        "CurrentVersion\Explorer\Shell Folders"           'HKEY_USERS
Private Const COUNTRY_SUBKEY    As String = ".Default\Control Panel\International"           'HKEY_USERS
Private Const NT_SETTINGS      As String = WIN_INFO_SUBKEY & "\Policies\System"            'HKEY_CURRENT_USER
Private Const W2K_SETTINGS     As String = WIN_INFO_SUBKEY & "\Group Policy Objects\LocalUser\" + _
                        "Software\Microsoft\Windows\CurrentVersion\Policies\System" 'HKEY_CURRENT_USER
Private Const STARTUP_AL_SUBKEY   As String = WIN_INFO_SUBKEY & "\Run"                  'run after login screen
Private Const STARTUP_BL_SUBKEY   As String = WIN_INFO_SUBKEY & "\RunServices"              'run before login screen
'------------------------------------------------
'     PROCEDURES
'------------------------------------------------
Public Sub CreateFileAssociation(ByVal strFileType As String, _
         ByVal strTypeDescription As String, _
         Optional ByVal strExeName As String, _
         Optional ByVal strExePath As String, _
         Optional ByVal strIconPath As String)
 'This procedure will create a new association for a file. For anyone
 'who is unfamiliar with this, this means that if you were to double-
 'click on a file with the specified extention, the specified application
 'would start. eg, if you were to double click on a .txt file, notepad
 'would start and open the file.
 'Please note that if you wish to associate an icon, the icon has to be
 'a .ico file - no other file types are accepted. If you wish to use an
 'icon that is only in your exe (if your distributing you app for
 'example), then you need to save the icon as a file. This can be done
 'by using;
 '
 'Call SavePicture(MyControl.Picture, App.Path & "\MyIcon.ico")
 '
 'Although, please note that the picture must have originally been an
 'icon before you tried to save it as one.
 
 
 Dim lngResult As Long
 Dim strFullPath As String
 Dim strAppKey As String
 
 'exit procedure if the file type feild is blank
 If (strFileType = "") Then
  Exit Sub
 Else
  'if the first character is a dot, then remove it
  If Left(strFileType, 1) = "." Then
   strFileType = Right(strFileType, Len(strFileType) - 1)
  End If
  
  'check to see that the file type is only three characters long
  If Len(strFileType) > 3 Then
   strFileType = Left(strFileType, 3)
  End If
 
  'the type description should be no longer than 25 characters
  '(this is not necessary, but it keeps things neat in the registry)
  If Len(strTypeDescription) > 25 Then
   strTypeDescription = Left(strTypeDescription, 25)
  End If
 End If
 
 'set the default paths and exe name is they were not specified
 If strExeName = "" Then
  strExeName = App.ExeName
 End If
 
 If strExePath = "" Then
  strExePath = App.Path
 End If
 
 'make sure that the exename ends in ".exe"
 If LCase(Right(strExeName, 4)) <> ".exe" Then
  strExeName = strExeName & ".exe"
 End If
 
 'get the full path name of the exe
 If Right(strExePath, 1) = "\" Then
  'if the path already contains a trailing backslash (eg "d:\") then
  'don't add one when creating the path
  strFullPath = strExePath & strExeName
 Else
  'insert a backslash to seperate the name from the path
  strFullPath = strExePath & "\" & strExeName
 End If
 
 'check to make sure that the file exists
 If Dir(strFullPath) = "" Then
  'there is no file
  Exit Sub
 End If
 
 'if no icon was specified, then use the icon for the exe
 If (strIconPath = "") Or (Dir(strIconPath) = "") Then
  strIconPath = strFullPath
 End If
 
 'create the file type extention in the registry
 Call CreateSubKey(HKEY_CLASSES_ROOT, "." & strFileType)
 
 'create the registry entry in the above sub key that holds the
 'sub key with the file path
 'eg, "MyApp.Description", "Vb6.Module", "Word.Document"
 'Note that a blank entry lable name means a default value for that key,
 'if any spaces are in the type description, they are replaced with
 'a "." character.
 strAppKey = Replace(Left(strExeName, Len(strExeName) - 4) & "." & strTypeDescription, " ", ".")
 Call CreateRegString(HKEY_CLASSES_ROOT, _
       "." & strFileType, _
       "", _
       strAppKey)
 
 'create the key that will hold the applications path and type information.
 'additional commands can be put into the "Shell\Open\Command" sub key.
 'This means that when you right click on the file type, a popup menu
 'appears with the Open option. Other options can be inserted into this
 'menu by creating sub keys in the Shell key like; "Print\Command",
 '"Edit\Command", "Assemble\Command", "Split\Command" etc. where
 'the Command sub key contains a [default] entry with a command line
 'parameter to an executable file like "C:\Windows\Notepad.exe /p %1"
 Call CreateSubKey(HKEY_CLASSES_ROOT, _
      strAppKey & "\Shell\Open\Command")
 
 'create the text that describes the file type
 Call CreateRegString(HKEY_CLASSES_ROOT, _
       strAppKey, _
       "", _
       strTypeDescription)
 
 'create the command line parameter to open the file type with the
 'application specified
 Call CreateRegString(HKEY_CLASSES_ROOT, _
       strAppKey & "\Shell\Open\Command", _
       "", _
       strFullPath & " ""%1""")
 
 'create the icon sub key
 Call CreateSubKey(HKEY_CLASSES_ROOT, _
      strAppKey & "\DefaultIcon")
 
 'create the entry that points to the icon.
 If LCase(Right(strIconPath, 3)) = "exe" Then
  'get icon from .exe
  Call CreateRegString(HKEY_CLASSES_ROOT, _
        strAppKey & "\DefaultIcon", _
        "", _
        strIconPath & ",1")
 Else
  'get icon from .ico file
  Call CreateRegString(HKEY_CLASSES_ROOT, _
        strAppKey & "\DefaultIcon", _
        "", _
        strIconPath & ",0")
 End If
End Sub
Public Sub DeleteFileAssociation(ByVal strFileType As String)
 'This procedure will remove a file association. It is recommended that
 'you only remove an association that your application created, as once
 'the association is gone, it cannot be recreated without knowing the
 'file type, application involved and the icon assiciated with the file type.
 'See CreateFileAssociation for further information.
 
 Dim strSubKeyAssociation As String
 
 'validate the parameter
 
 'make sure that the parameter contains something
 If strFileType = "" Then
  Exit Sub
 End If
 
 'make sure that the first character is a dot (.)
 If Left(strFileType, 1) <> "." Then
  'insert dot
  strFileType = "." & strFileType
 End If
 
 'now we check the registry
 
 strSubKeyAssociation = ReadRegString(HKEY_CLASSES_ROOT, _
           strFileType, "")
 
 'if there was an error, then exit
 If LCase(Left(strSubKeyAssociation, 5)) = "error" Then
  Exit Sub
 End If
 
 'delete the commands and information about the selected file type
 Call DeleteSubKey(HKEY_CLASSES_ROOT, strSubKeyAssociation)
End Sub
Public Sub PutAppInStartup(ByVal strEntryLabel As String, _
       Optional ByVal strFilePath As String, _
       Optional ByVal blnStartup As StartLoginType = RunAfterLogin, _
       Optional ByVal blnOverwrite As Boolean = False)
 'This will take an applications full path name and put it into the registry
 'to start the program either before or after the login screen in normally
 'loaded. If no app path is specified, then by default, it puts the current
 'project in to startup after the login screen. Existing enteries are not
 'overwritten. You could call this procedure like;
 '
 'Call PutAppInStartup("MyCoolApp", MyAppsFilePath, RunAfterLogin, False)
 '
 'or
 '
 'Call PutAppInStartup("MyCoolApp")
 '
 'See also RemoveAppFromStartup.
 
 
 Dim strSubKey As String
 Dim strCheck As String
 
 'check to see if a file path was specified
 If strFilePath = "" Then
  'specifiy the path from the current project
  
  'if the applications path is a root directory, then don't add a
  'backslash to the path
  If Right(App.Path, 1) = "\" Then
   strFilePath = App.Path & App.ExeName & ".exe"
  Else
   strFilePath = App.Path & "\" & App.ExeName & ".exe"
  End If
 End If
 
 'check to see if the file exists
 If (Dir(strFilePath) = "") Or (strEntryLabel = "") Then
  'can't find file. There is no point in making an entry for a file
  'that doesn't exist, so exit
  Exit Sub
 End If
 
 'create the sub key based on the options
 If blnStartup = RunAfterLogin Then
  'set the app to start after the login screen
  strSubKey = STARTUP_AL_SUBKEY
 Else
  'set the app to run before the login screen
  strSubKey = STARTUP_BL_SUBKEY
 End If
 
 'if the entry already exists and we don't want to overwrite, then exit
 strCheck = ReadRegString(HKEY_LOCAL_MACHINE, _
        strSubKey, _
        strEntryLabel)
 If (Not blnOverwrite) And (Left(strCheck, 5) <> "Error") Then
  Exit Sub
 End If
 
 'write to the registry
 Call CreateRegString(HKEY_LOCAL_MACHINE, _
       strSubKey, _
       strEntryLabel, _
       strFilePath)
End Sub
Public Sub RemoveAppFromStartup(ByVal strEntryLabel As String, _
        Optional ByVal blnStartup As StartLoginType = RunAfterLogin)
 'This procedure will remove an app from the startup be specifying
 'it's label and whether or not the app startsup before or after the
 'login screen. Also see the PutInStartup procedure.
 
 Dim strSubKey As String
 Dim strCheck As String
 
 'find the sub key depending on the startup gstrMethod
 If blnStartup = RunAfterLogin Then
  'startup after the login screen [default]
  strSubKey = STARTUP_AL_SUBKEY
 Else
  'startup before the login screen
  strSubKey = STARTUP_BL_SUBKEY
 End If
 
 'check to see if the entry exists
 strCheck = ReadRegString(HKEY_LOCAL_MACHINE, _
        strSubKey, _
        strEntryLabel)
 If Left(strCheck, 5) = "Error" Then
  'there was a problem accessing the key, so exit (eg, it might not exist)
  Exit Sub
 End If
 
 'delete the entry
 Call DeleteValue(HKEY_LOCAL_MACHINE, _
      strSubKey, _
      strEntryLabel)
End Sub
Public Sub CreateSubKey(ByVal enmHive As RegistryHives, _
      ByVal strSubKey As String)
 'This procedure will create a sub key in the
 'specified header key.
 
 Dim lngResult As Long
 Dim hKey  As Long
 
 'create the key
 lngResult = RegCreateKey(enmHive, _
        strSubKey & Chr(0), _
        hKey)
 
 'close the key
 lngResult = RegCloseKey(hKey)
End Sub
Public Sub DeleteSubKey(ByVal enmHive As RegistryHives, _
      ByVal strSubKey As String)
 'This procedure will delete a key from the registry. Please note that
 'the procedure will not delete key values.
 
 Dim lngResult As Long  'holds any returned value from an api call
 Dim hKey  As Long  'holds a handle to the specified key
 
 'open the key
 lngResult = RegOpenKeyEx(enmHive, _
        strSubKey & Chr(0), _
        0&, _
        KEY_ALL_ACCESS, _
        hKey)
 
 'delete the key
 lngResult = RegDeleteKey(enmHive, hKey)
 
 'close the key
 lngResult = RegCloseKey(hKey)
End Sub
Public Sub DeleteValue(ByVal enmHive As RegistryHives, _
      ByVal strSubKey As String, _
      Optional ByVal strEntryLabel As String)
 'This will remove any registry key or entry value
 
 Dim lngResult  As Long
 Dim hKey   As Long
 Dim strTotalSubKey As String
 
 'create the full registry subkey and entry label
 strTotalSubKey = strSubKey & Chr(0)
 
 'open the subkey/entry
 lngResult = RegOpenKeyEx(enmHive, _
        strTotalSubKey, _
        0&, _
        KEY_ALL_ACCESS, _
        hKey)
 
 'delete the key/entry from the registry
 lngResult = RegDeleteValue(hKey, strEntryLabel)
 
 'close the handle
 lngResult = RegCloseKey(hKey)
End Sub
Public Sub CreateRegString(ByVal enmHive As RegistryHives, _
       ByVal strSubKey As String, _
       ByVal strEntryLabel As String, _
       ByVal strText As String)
 'This will put some text into the specified key and entry label. This
 'data can be retrieved with the ReadRegString function
 
 Dim lngResult  As Long
 Dim hKey   As Long
 Dim strTotalSubKey As String
 
 'create a complete sub key and entry path to send to the api call
 strTotalSubKey = strSubKey & Chr(0)
 
 'try to open the key first
 lngResult = RegOpenKeyEx(enmHive, _
        strTotalSubKey, _
        0, _
        KEY_READ + KEY_WRITE, _
        hKey)
 
 'if we couldn't open the key, then try and create it
 If (hKey = 0) Then
  'now create the sub key entry if it does not exist
  lngResult = RegCreateKey(enmHive, strTotalSubKey, hKey)
  
  'if no handle was returned, then exit
  If hKey = 0 Then
   Exit Sub
  End If
 End If
 
 'write the text into the key with the specified entry name
 lngResult = RegSetValueEx(hKey, _
        strEntryLabel, _
        0&, _
        REG_SZ, _
        ByVal strText, _
        Len(strText))
 
 'close the opened key and exit
 lngResult = RegCloseKey(hKey)
End Sub
Public Function GetWinDirectories(ByVal enmDirectory As ShellFoldersType) _
         As String
 'This function will return the specfied system directory like the desktop
 'directory, windows directory, temp folder, system directory etc.
 
 'registry entry names
 Const ApplicationData As String = "AppData"
 Const TempInetFiles  As String = "Cache" 'temperory internet files
 Const Cookies   As String = "Cookies"
 Const Desktop   As String = "Desktop"
 Const Favourites  As String = "Favourites"
 Const Fonts    As String = "Fonts"
 Const History   As String = "History"
 Const LocalAppData  As String = "Local AppData"
 Const NetHood   As String = "NetHood"
 Const MyDocuments  As String = "Personal"
 Const PrintHood   As String = "PrintHood"
 Const StartPrograms  As String = "Programs"
 Const Recent   As String = "Recent"
 Const SendTo   As String = "SendTo"
 Const StartMenu   As String = "Start Menu"
 Const StartUp   As String = "Startup"
 Const Templates   As String = "Templates"
 
 
 Dim strResult As String
 Dim errResult As Long
 
 Select Case enmDirectory
  'registry entry names
  Case ApplicationDataDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, ApplicationData)
  
  Case TempInetFilesDir 'temperory internet files
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, TempInetFiles)
  
  Case CookiesDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Cookies)
  
  Case DesktopDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Desktop)
  
  Case FavouritesDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Favourites)
  
  Case FontsDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Fonts)
  
  Case HistoryDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, History)
  
  Case LocalAppDataDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, LocalAppData)
  
  Case NetHoodDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, NetHood)
  
  Case MyDocumentsDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, MyDocuments)
  
  Case PrintHoodDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, PrintHood)
  
  Case StartProgramsDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, StartPrograms)
  
  Case RecentDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Recent)
  
  Case SendToDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, SendTo)
  
  Case StartMenuDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, StartMenu)
  
  Case StartupDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, StartUp)
  
  Case TemplatesDir
   strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Templates)
  
  
  'these next items are not stored in the registry
  Case SystemDir
   strResult = Space(255)
   errResult = GetSystemDirectory(strResult, 255)
   
   'remove the null character
   If (InStr(1, strResult, vbNullChar) > 0) Then
    strResult = Left(strResult, InStr(1, strResult, vbNullChar) - 1)
   End If
   
  Case WindowsDir
   strResult = Space(255)
   errResult = GetWindowsDirectory(strResult, 255)
   
   'remove the null character
   If (InStr(1, strResult, vbNullChar) > 0) Then
    strResult = Left(strResult, InStr(1, strResult, vbNullChar) - 1)
   End If
   
  Case TempDir 'temperory folder is always in the Windows directory
   strResult = Space(255)
   errResult = GetTempDirectory(255, strResult)
   
   'remove the null character and add the name of the temperory folder
   If (InStr(1, strResult, vbNullChar) > 0) Then
    strResult = Left(strResult, InStr(1, strResult, vbNullChar) - 1)
   End If
   
 End Select
 
 'return strResult
 GetWinDirectories = strResult
End Function
Public Function GetRegisteredOwner() As String
 'This function will returned the registered
 'strOwner for the local machine.
 
 Const OwnerKeyLoc As String = "RegisteredOwner"
 
 Dim strOwner  As String
 
 'get the registered gstrOwner
 If IsWinNT Then
  strOwner = ReadRegString(HKEY_LOCAL_MACHINE, _
         WIN_NT_INFO_SUBKEY, _
         OwnerKeyLoc)
 Else
  strOwner = ReadRegString(HKEY_LOCAL_MACHINE, _
         WIN_INFO_SUBKEY, _
         OwnerKeyLoc)
 End If
 
 'return lngResult
 GetRegisteredOwner = strOwner
End Function
Public Function ReadRegString(ByVal enmHive As RegistryHives, _
        ByVal strSubKey As String, _
        Optional ByVal strEntry As String) _
        As String
 'This function will check a registery string entry and
 'return the result.
 
 Dim strText   As String
 Dim lngResult  As Long
 Dim hOpenKey  As Long
 Dim lngBufferSize As Long
 
 'open the registry key
 hOpenKey = GetSubKeyHandle(enmHive, strSubKey)
 
 'check for error
 If hOpenKey = 0 Then
  'return error message
  ReadRegString = "Error : Cannot Open Key"
  Exit Function
 End If
 
 'setup the string to hold the return value
 strText = String(255, vbNullChar)
 lngBufferSize = Len(strText)
 
 'query the information in the key
 lngResult = RegQueryValueEx(hOpenKey, _
        strEntry, _
        0, _
        REG_SZ, _
        ByVal strText, _
        lngBufferSize)
 
 'close access to the key
 lngResult = RegCloseKey(hOpenKey)
 
 'check for no values returned
 If (Left(strText, 1) = vbNullChar) Then
  'return error message
  ReadRegString = "Error : Cannot Retrieve String"
  Exit Function
 Else
  'remove the null character
  If (InStr(1, strText, vbNullChar) > 0) Then
   strText = Left(strText, InStr(1, strText, vbNullChar) - 1)
  End If
 End If
 
 'function successful, return owners name
 ReadRegString = strText
End Function
Public Function ReadRegLong(ByVal enmHive As RegistryHives, _
       ByVal strSubKey As String, _
       ByVal strEntry As String, _
       Optional ByVal enmType As RegistryLongTypes = REG_BINARY) _
       As Long
 'This function will check a registery string
 'entry and return the lngResult.
 
 Dim lngValue  As Long
 Dim lngResult  As Long
 Dim hOpenKey  As Long
 Dim lngBufferSize As Long
 
 'open the registry key
 hOpenKey = GetSubKeyHandle(enmHive, strSubKey)
 
 'check for error
 If hOpenKey = 0 Then
  'return error message
  ReadRegLong = 0
  Exit Function
 End If
 
 lngBufferSize = 4
 
 'query the information in the key
 lngResult = RegQueryValueEx(hOpenKey, _
        strEntry, _
        ByVal 0&, _
        REG_BINARY, _
        lngValue, _
        lngBufferSize)
 
 'close access to the key
 lngResult = RegCloseKey(hOpenKey)
 
 'function successful, return owners name
 ReadRegLong = lngValue
End Function
Private Function GetSubKeyHandle(ByVal enmHive As RegistryHives, _
         ByVal strSubKey As String, _
         Optional ByVal enmAccess As RegistryKeyAccess = KEY_READ) _
         As Long
 'This function returns a handle to the specified registry key
 
 Dim lngResult As Long  'holds any returned error value from an api call
 Dim hKey  As Long  'holds the handle to the specified key
 
 'open the registry key
 lngResult = RegOpenKeyEx(enmHive, strSubKey, 0, enmAccess, hKey)
 
 If lngResult <> ERROR_SUCCESS Then
  'could not create key
  hKey = 0
 End If
  
 'return value
 GetSubKeyHandle = hKey
End Function
Public Function GetSpace(enmSpaceType As MemType, _
       Optional ByVal strDrive As String = "C:\") _
       As Long
 'This function returns the amount of specified memory, either in total
 'or available depending on what was passed.
 'Keep in mind that the information returned is volitile - if you call
 'the function twice, there is no guarentee that the values returned
 'will be the same.
 'Note also, that physical memory is ram memory and memory usage is
 'the amount of ram used.
 
 Const CpuSubKey As String = "PerfStats\StatData"
 Const CpuName As String = "KERNEL\CPUUsage"
 
 Dim enmMemStruc   As MEMORYSTATUS
 Dim lngResult   As Long
 Dim SecPerCluster  As Long
 Dim lngBytPerSector  As Long
 Dim lngFreeClusters  As Long
 Dim lngTotalClusters As Long
 
 'Before calling GlobalMemoryStatus, we have to tell it the length
 'of the structure we are passing it - this is required by the procedure.
 enmMemStruc.dwLength = Len(enmMemStruc)
 Call GlobalMemoryStatus(enmMemStruc)
 
 'get the disk space. The function must be passed the root directory of
 'a drive like "C:\" or "D:\" and must end with a Null character (chr(0) )
 If Len(strDrive) >= 3 Then
  lngResult = GetDiskFreeSpace((Left(strDrive, 3) & Chr(0)), _
          SecPerCluster, _
          lngBytPerSector, _
          lngFreeClusters, _
          lngTotalClusters)
 End If
 
 'save the selected lngResult
 Select Case enmSpaceType
 
 Case CPUUsage 'cpu usage
  lngResult = ReadRegLong(HKEY_DYN_DATA, CpuSubKey, CpuName)
 
 Case MemoryUsage 'ram usage
  lngResult = enmMemStruc.dwMemoryLoad
 
 Case TotalPhysical 'total ram
  lngResult = enmMemStruc.dwTotalPhys
 
 Case AvailablePhysical 'available ram
  lngResult = enmMemStruc.dwAvailPhys
 
 Case TotalPageFile 'total page file
  lngResult = enmMemStruc.dwTotalPageFile
 
 Case AvailablePageFile 'available page file
  lngResult = enmMemStruc.dwAvailPageFile
 
 Case TotalVirtual 'total virtual (swap file)
  lngResult = enmMemStruc.dwTotalVirtual
 
 Case AvailableVirtual 'available virtual
  lngResult = enmMemStruc.dwAvailVirtual
 
 Case TotalDisk 'hard drive space
  lngResult = lngTotalClusters * (lngBytPerSector * SecPerCluster)
 
 Case AvailableDisk 'available hard drive space
  lngResult = lngFreeClusters * (lngBytPerSector * SecPerCluster)
 
 Case Else
  'return -1 as an error code
  lngResult = -1
 End Select
 
 GetSpace = lngResult
End Function
Public Function GetCountry() As String
 'This will return the country from
 'the computers' regional settings
 
 Const CountryKey  As String = "sCountry" 'the registry entry that holds the country name
 Const DEFAULT_COUNTRY As String = "Ireland" 'the default country to return if unable to retrieve from the registry
 
 Dim strCountry   As String  'holds the value of the registry entry
 
 strCountry = ReadRegString(HKEY_USERS, _
        COUNTRY_SUBKEY, _
        CountryKey)
 
 'if it could not get the country, then default to
 'the programmers country
 If UCase(Left(strCountry, 5)) = "ERROR" Then
  strCountry = DEFAULT_COUNTRY
 End If
 
 'return the country
 GetCountry = strCountry
End Function
Public Function ShellFile(ByVal strFilePath As String, _
       Optional enmFocus As VbAppWinStyle = vbNormalFocus)
 'This will open any file with the appropiate program
 'as long as it is registered in the registry and
 'if the function is successful, it will return the
 'applications ID.
 
 Dim strExtention As String  'holds the file extention
 Dim lngDotPos  As Long   'the position of the last . character found in the string
 Dim lngAppId  As Long   'the process id for the started application
 Dim strWindowsDir As String  'the location of the windows directory
 Dim strSubKeyLoc As String  'the location of the registry sub key to open the file type
 Dim strOpenWith  As String  'the program to open the file with
 Dim strMulti()  As String  'the individual files if more than one is passed (multiple parameters)
 Dim intCounter  As Integer  'used to cycle through the file list
 
 'get the windows directory
 strWindowsDir = GetWinDirectories(WindowsDir)
 
 'strip qutoation marks from the file path
 strFilePath = Replace(strFilePath, """", "")
 
 'see if the file is a directory, if so open in
 'explorer
 If HasFileAttrib(strFilePath, vbDirectory) Then
  'open the directory
  lngAppId = Shell(AddFile(strWindowsDir, _
         "Explorer.exe /n,/e," _
         & strFilePath), _
       enmFocus)
  
  ShellFile = lngAppId
  Exit Function
 End If
 
 'get the file extention if any exists (after the last
 'position of the backslash)
 lngDotPos = InStrRev(strFilePath, ".")
 If (lngDotPos > 0) Then
  If (InStr(lngDotPos, strFilePath, "\") = 0) Then
   'file extention exists
   strExtention = Right(strFilePath, _
         Len(strFilePath) - _
         lngDotPos + 1)
  End If
 End If
 
 'if the extention marks any executable file, then
 'simple run it
 Select Case LCase(strExtention)
 Case ".exe", ".com", ".bat", ""
 
  'make sure the file exists
  If (Dir(strFilePath) <> "") And (Trim(strFilePath) <> "") Then
   lngAppId = Shell(strFilePath, enmFocus)
   
   'return a pointer to the application instance
   ShellFile = lngAppId
  End If
  Exit Function
 End Select
 
 'we need to check the executable file types that
 'can run on their own
 strSubKeyLoc = ReadRegString(HKEY_CLASSES_ROOT, _
         strExtention)
 strOpenWith = ReadRegString(HKEY_CLASSES_ROOT, _
        AddFile(strSubKeyLoc, _
          "shell\open\command"))
 
 'make sure no error was returned
 If UCase(Left(strOpenWith, 5)) = "ERROR" Then
  'couldn't open file
  ShellFile = 0
  Exit Function
 End If
 
 'process the string returned so that we can send
 'it to the Shell function
 If InStr(strOpenWith, "%1") > 0 Then
  'replace the parameters with the appropiate
  'file names
  If InStr(strOpenWith, ",") = 0 Then
   'process one file
   strOpenWith = Replace(strOpenWith, _
         "%1", _
         strFilePath)
  Else
   'process multiple files
   strMulti = Split(strFilePath, ",")
   
   For intCounter = LBound(strMulti) To UBound(strMulti)
    'replace each parameter string with the
    'corresponding number of elements found
    strOpenWith = Replace(strOpenWith, _
          "%" & intCounter, _
          strMulti(intCounter))
   Next intCounter
  End If
 Else
  'insert the file name(s) at the end of the
  'name of the program. Please note, that this
  'might not actually work for some programs as
  'the extra parameter may produce an error or be
  'ignored altogether. However this is unlikley
  'as this program path was found in the "Open"
  'section of the program commands.
  strOpenWith = strOpenWith & " " & _
      Chr(34) & strFilePath & Chr(34) 'chr(34) is a double quote character (")
 End If
 
 'replace system path codes with the actual paths (typically on an NT
 'based machine) --NOT case sensitive with vbTextCompare--
 strOpenWith = Replace(strOpenWith, _
       "%SystemDrive%", _
       Left(GetWinDirectories(WindowsDir), 3), _
       Compare:=vbTextCompare)
 strOpenWith = Replace(strOpenWith, _
       "%SystemRoot%", _
       GetWinDirectories(WindowsDir), _
       Compare:=vbTextCompare)
 
 'open the file
 lngAppId = Shell(strOpenWith, enmFocus)
 ShellFile = lngAppId
End Function
Private Function AddFile(ByVal strPath As String, _
       ByVal strFileName As String) _
       As String
 
 'This function takes a file name and a path and will
 'put the two together to form a filepath. This is useful
 'for when the applications' path happens to be the root
 'directory.
 
 If (strPath = "") Then
  'no path was passed
  AddFile = strFileName
  Exit Function
 End If
 
 'check the last character for a backslash
 If Left(strPath, 1) = "\" Then
  'don't insert a backslash
  AddFile = strPath & strFileName
 Else
  'insert a backslash
  AddFile = strPath & "\" & strFileName
 End If
End Function
Private Function FileExists(ByVal strFilePath As String, _
       Optional ByVal enmFlags As VbFileAttribute = vbNormal) _
       As Boolean
 'returns True if the file exists
 
 If ((strFilePath = "") Or _
  (Dir(strFilePath, enmFlags) = "")) Then
  'invalid path/filename
  FileExists = False
 Else
  FileExists = True
 End If
End Function
Private Function HasFileAttrib(ByVal strFilePath As String, _
        Optional ByVal enmFlags As VbFileAttribute) _
        As Boolean
 'returns True if the file specified has the
 'appropiate type signiture, eg, a directory or is
 'read-only. If testing multiple attributes, then
 'the file MUST have all attributes to return True
 
 Dim lngErrNum As Long 'holds any error that occurred trying to access the file
 
 'make sure the file exists without upsetting any
 'stored values when the Dir function is being used
 'externally by another procedure/function
 On Error Resume Next
  'test file access
  GetAttr strFilePath
  lngErrNum = Err
 On Error GoTo 0
 
 'exit if an error occured ("#53 - File Not Found"
 'usually occurs)
 If lngErrNum > 0 Then
  HasFileAttrib = False
  Exit Function
 End If
 
 'test the file for attributes
 If ((GetAttr(strFilePath) And enmFlags) = enmFlags) Then
  HasFileAttrib = True
 Else
  HasFileAttrib = False
 End If
End Function
Private Function IsWinNT() As Boolean
 'Detect if the program is running under an NT based system (NT, 2000, XP)
 
 Const VER_PLATFORM_WIN32_NT  As Long = 2
 
 Dim osiInfo As OSVERSIONINFO 'holds the operating system information
 Dim lngResult As Long    'returned error value from the api call
 
 'get version information
 osiInfo.dwOSVersionInfoSize = Len(osiInfo)
 lngResult = GetVersionEx(osiInfo)
 
 'return True if the test of windows NT is positive
 IsWinNT = (osiInfo.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function
Public Sub NTMenus(ByVal enmPrivilage As EnumNTSettings, _
     ByVal blnEnable As Boolean)
 'This will enable or disable the windows task manager. Please note that
 'this procedure does not work on any Non-NT based system (win 9x)
 
 Const CHANGE_PASS As String = "DisableChangePassword"
 Const LOCK_WORK_ST As String = "DisableLockWorkStation"
 Const REG_TOOLS  As String = "DisableRegistryTools"
 Const TASK_MANAGER As String = "DisableTaskMgr"
 'disable parts of the Display dialog box
 Const DISPLAY_PAGE As String = "NoDispAppearancePage"
 Const DISPLAY_BPAGE As String = "NoDispBackgroundPage"
 Const DISPLAY_CPL As String = "NoDispCPL"
 Const DISPLAY_SCRSV As String = "NoDispScrSavPage"
 Const DISPLAY_SETT As String = "NoDispSettingsPage"
 
 Dim strValueName As String 'holds the Value to open
 Dim lngFlag   As Long  'holds the value to set the setting
 
 If Not IsWinNT Then
  'cannot change settings unless this is a winnt system
  Exit Sub
 End If
 
 'get the text to for the registry value for the selected setting
 Select Case enmPrivilage
  'items that can be disabled on the Lock Screen
 Case CHANGE_PASSWORD
  strValueName = CHANGE_PASS
  
 Case LOCK_WORKSTATION
   strValueName = LOCK_WORK_ST
   
 Case REGISTRY_TOOLS
  strValueName = REG_TOOLS
  
 Case TASK_MGR
  strValueName = TASK_MANAGER
 
  'the tabs on the Display Properties dialog box
 Case DISP_APPEARANCE_PAGE
  strValueName = DISPLAY_PAGE
  
 Case DISP_BACKGROUND_PAGE
  strValueName = DISPLAY_BPAGE
  
 Case DISP_CPL
  strValueName = DISPLAY_CPL
  
 Case DISP_SCREENSAVER
  strValueName = DISPLAY_SCRSV
  
 Case DISP_SETTINGS
  strValueName = DISPLAY_SETT
  
 Case Else
  'invalid selection
  Exit Sub
 End Select
 
 'get the value settings
 If Not blnEnable Then
  'disable option
  lngFlag = 1
 Else
  'enable option
  lngFlag = 0
 End If
 
 If IsWinNT Then
  'NT registry location
  Call CreateRegLong(HKEY_CURRENT_USER, _
       NT_SETTINGS, _
       strValueName, _
       lngFlag)
  
  If IsW2000 Then
   'windows 2000 needs an additional entry
   Call CreateRegLong(HKEY_CURRENT_USER, _
        W2K_SETTINGS, _
        strValueName, _
        lngFlag)
  End If
 End If
End Sub
Public Sub AutoRestartShell(ByVal blnEnable As Boolean)
 'This will turn on/off whether or not the windows shell restarts if it is
 'shutdown or not. This only works on NT based systems
 
 'in registry hive HKEY_LOCAL_MACHINE
 Const AUTO_RESTART_SUBKEY As String = "Software\Microsoft\Windows NT\" + _
           "CurrentVersion\WinLogon"
 
 Dim lngResult As Long   'holds any returned error value from an api call
 Dim hKey  As Long   'holds a handle to the opened key
 Dim lngData  As Long   'holds the data going into the registry key
 
 'if this is not an NT machine, this won't work
 If Not IsWinNT Then
  Exit Sub
 End If
 
 'get the value of the data going into the registry key
 lngData = Abs(blnEnable)
 
 'set the value to enable or disable the specified setting
 Call CreateRegLong(HKEY_LOCAL_MACHINE, _
      AUTO_RESTART_SUBKEY, _
      "AutoRestartShell", _
      lngData)
End Sub
Public Function IsW2000() As Boolean
 'This will only return True if the version returned by the registry
 'value CurrentVersion is 5
 
 Dim strVersion  As String  'holds the verion number of the operating system
 
 'the the machine NT based (NT, 2000, XP)
 If Not IsWinNT Then
  IsW2000 = False
  Exit Function
 End If
 
 'check the version
 strVersion = ReadRegString(HKEY_LOCAL_MACHINE, _
        WIN_NT_INFO_SUBKEY, _
        "CurrentVersion")
 
 'could we read the registry entry
 If Len(strVersion) < 0 Then
  IsW2000 = False
  Exit Function
 End If
 
 'check the version
 If (strVersion = "") Then
  IsW2000 = False
 
 Else
  If Left(strVersion, 1) = "5" Then
   IsW2000 = True
  Else
   IsW2000 = False
  End If
 End If
End Function
Public Sub OppLocking(ByVal blnEnable As Boolean)
 'This will enable or disable oppertunistic locking on an NT based machine
 
 'in HKEY_LOCAL_MACHINE registry hive
 Const LOCK_OP_SUBKEY As String = "System\CurrentControlSet\Services"
 Const W2K_lOCK_LOCAL As String = LOCK_OP_SUBKEY + "\LanManServer\Parameters"
 Const W2K_LOCK_REMOTE As String = LOCK_OP_SUBKEY + "\MrxSmb\Parameters"
 Const WNT_LOCK_LOCAL As String = LOCK_OP_SUBKEY + "\LanManWorkStation\Parameters"
 Const WNT_LOCK_REMOTE As String = LOCK_OP_SUBKEY + "\LanManServer\Parameters"
 
 Dim lngData    As Long  'holds the numeric value to set to
 
 'make sure we are running on an NT based system
 If Not IsWinNT Then
  Exit Sub
 End If
 
 'what kind of NT based system are we running on
 If IsW2000 Then
  'enable/disable opportunistic locking on windows 2000
  lngData = Abs(blnEnable)
  
  'local locking
  Call CreateRegLong(HKEY_LOCAL_MACHINE, _
       W2K_lOCK_LOCAL, _
       "EnableOpLocks", _
       lngData)
  
  'remote locking
  lngData = Abs(Not blnEnable)
  
  Call CreateRegLong(HKEY_LOCAL_MACHINE, _
       W2K_LOCK_REMOTE, _
       "OplocksDisabled", _
       lngData)
 
 Else
  'enable/disable opportunistic locking on windows NT
  
  lngData = Abs(blnEnable)
  
  'local locking
  Call CreateRegLong(HKEY_LOCAL_MACHINE, _
       WNT_LOCK_LOCAL, _
       "UseOpportunisticLocking", _
       lngData)
  
  'remote locking
  Call CreateRegLong(HKEY_LOCAL_MACHINE, _
       WNT_LOCK_REMOTE, _
       "EnableOpLocks", _
       lngData)
 End If
End Sub
Public Sub CreateRegLong(ByVal enmHive As RegistryHives, _
       ByVal strSubKey As String, _
       ByVal strValueName As String, _
       ByVal lngData As Long, _
       Optional ByVal enmType As RegistryLongTypes = REG_DWORD_LITTLE_ENDIAN)
 'This will create a value in the registry of the specified type
 'and value data
 
 Dim hKey  As Long  'holds a pointer to an open registry key
 Dim lngResult As Long  'holds any returned error value from an api call
 
 'make sure the registry value exists
 Call CreateSubKey(enmHive, strSubKey)
 
 'open the subkey
 hKey = GetSubKeyHandle(enmHive, strSubKey, KEY_SET_VALUE)
 
 'create the registry value
 lngResult = RegSetValueEx(hKey, _
        strValueName, _
        0, _
        enmType, _
        lngData, _
        4)
 
 'close the registry key
 lngResult = RegCloseKey(hKey)
End Sub
Public Sub OpenVbIdeMaximized(ByVal blnEnable As Boolean)
 'This will set the vb ide to open projects maximized by default
 
 'HKEY_CURRENT_USER
 Const VB_IDE_SUB_KEY As String = "\Software\Microsoft\Visual Basic\6.0"
 
 Call CreateRegString(HKEY_CURRENT_USER, _
       VB_IDE_SUB_KEY, _
       "MDIMaximized", _
       Trim(Str(Abs(blnEnable))))
End Sub
Public Sub SaveArray(ByRef varArray() As Variant, _
      ByVal enmHive As RegistryHives, _
      ByVal strSubKey As String, _
      Optional ByVal strArrayName As String = "VB6_Array", _
      Optional ByVal enmDataType As RegistryDataTypes = REG_DT_SZ)
 'This will save an array of the specified data type to the specified
 'registry sub key. The array must be initialised and valid for the
 'data type specified as there is no checking done to validate the data.
 
 Dim lngCounter  As Long   'used to cycle through the array specified
 Dim lngMin   As Long   'holds the lower bound of the array
 Dim lngMax   As Long   'holds the upper bound of the array
 
 'make sure that a valid subkey was passed
 If (Trim(strSubKey) = "") Then
  Exit Sub
 End If
 
 'make sure that the sub key exists in the registry
 Call CreateSubKey(enmHive, strSubKey)
 
 'get the size of the array
 lngMin = LBound(varArray)
 lngMax = UBound(varArray)
 
 'save the bounds in the specified key
 Call CreateRegLong(enmHive, _
      strSubKey, _
      (strArrayName + "LBound"), _
      lngMin, _
      REG_BINARY)
 Call CreateRegLong(enmHive, _
      strSubKey, _
      (strArrayName + "UBound"), _
      lngMax, _
      REG_BINARY)
 
 'save the elements of the array to the registry
 For lngCounter = lngMin To lngMax
  If (enmDataType = REG_DT_SZ) Then
   'save as string
   Call CreateRegString(enmHive, _
         strSubKey, _
         (strArrayName & lngCounter), _
         varArray(lngCounter))
   
  Else
   'save as numeric
   Call CreateRegLong(enmHive, _
        strSubKey, _
        (strArrayName & lngCounter), _
        varArray(lngCounter), _
        enmDataType)
  End If
 Next lngCounter
End Sub
Public Sub LoadArray(ByRef varArray() As Variant, _
      ByVal enmHive As RegistryHives, _
      ByVal strSubKey As String, _
      Optional ByVal strArrayName As String = "VB6_Array", _
      Optional ByVal enmDataType As RegistryDataTypes = REG_DT_SZ)
 'This will load an array saved with the SaveArray procedure above. The
 'data must have been saved using the correct data and datatypes. The array
 'passed to this procedure will be wiped, resized and loaded with whatever
 'information can be retrieved from the registry. It is up to the programmer
 'to ensure that the correct data types are passed to the procedure or the
 'information returned may be corrupt if any information is returned at all.
 
 Dim lngCounter  As Long   'used to cycle through the array specified
 Dim lngMin   As Long   'holds the lower bound of the array
 Dim lngMax   As Long   'holds the upper bound of the array
 
 'make sure that the correct sub key was passed
 If (Trim(strSubKey) = "") Then
  Exit Sub
 End If
 
 'get the size of the array
 lngMin = ReadRegLong(enmHive, _
       strSubKey, _
       (strArrayName + "LBound"), _
       REG_BINARY)
 lngMax = ReadRegLong(enmHive, _
       strSubKey, _
       (strArrayName + "UBound"), _
       REG_BINARY)
 
 'resize the array to accomidate the data
 ReDim varArray(lngMin To lngMax)
 
 For lngCounter = lngMin To lngMax
  If (enmDataType = REG_DT_SZ) Then
   'read string data into the array
   varArray(lngCounter) = ReadRegString(enmHive, _
             strSubKey, _
             (strArrayName & lngCounter))
  
  Else
   'read numeric data into the array
   varArray(lngCounter) = ReadRegLong(enmHive, _
            strSubKey, _
            (strArrayName & lngCounter), _
            enmDataType)
  End If
 Next lngCounter
End Sub
Public Sub SetNumLock(Optional ByVal blnTurnOn As Boolean = True)
 'This will turn the numlock on or off when logging in to Nt/2000/XP
 
 Const NUMLOCK_SUBKEY As String = "Control Panel\Keyboard" 'HKEY_CURRENT_USER
 Const NUMLOCK_VALUE  As String = "InitialKeyboardIndicators"
 
 Dim strOnText As String 'holds the actual string value that turns the numlock on or off
 
 If Not IsWinNT Then
  'this won't work on a non-nt based system
  Exit Sub
 End If
 
 If blnTurnOn Then
  strOnText = "2" 'on
 Else
  strOnText = "0" 'off
 End If
 
 Call CreateRegString(HKEY_CURRENT_USER, _
       NUMLOCK_SUBKEY, _
       NUMLOCK_VALUE, _
       strOnText)
End Sub