Source code for Issue Number 64

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. Source code may not be reproduced except for use in a compiled executable. All rights reserved. If you would like to reprint any or all of this code please email us at info@codeoftheweek.com

Code of the Week Home


Source Code

Just paste this code into any class and change the name of the class to cRegistryUtils.

'----------------------------------------------------------------------
'
'   Module Name:    cRegistryUtils
'   Written By:     C&D Programming Corp.
'                         Albert Perdomo
'   Create Date:    2/21/98
'   Modifications:  11/98
'   Copyright:      Copyright 1998 by C&D Programming Corp.  Source
'                   code may not be reproduced except for use in a
'                   compiled executable.  All rights reserved.  If
'                   you would like to reprint any or all of this
'                   code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
'
'   This class contains functions to retrieve the Organization
'   and Registered User in Windows 95.  It might work under
'   Windows NT, but we didn't have a Windows NT machine to test on
'   at the moment.
'
'
Option Explicit

'
'   Key where the Organization and User Registration information is stored
'
Const WINDOWS_KEY_NAME As String = "SOFTWARE\Microsoft\Windows\CurrentVersion\"

'
'   Various API declarations that need to be called to retrieve registry
'   information.
'

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const HKEY_CURRENT_CONFIG = &H80000005

Private Const KEY_ALL_ACCESS = &H3F

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
                "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
                ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
                Long) As Long

Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
                "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
                String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
                As String, lpcbData As Long) As Long

Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
                "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
                String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
                As Long, lpcbData As Long) As Long
'
'   Retrieves the registered user information from the registry.
'   If it is not found, it will return an empty string.
'
Public Function RegisteredUser() As Variant
    On Error GoTo ErrorHandler
    Dim lRetVal As Long, hKey As Long, vValue As Variant

    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, WINDOWS_KEY_NAME, 0, &H3F, hKey)
    lRetVal = GetKeyValue(hKey, "RegisteredOwner", vValue)
    RegCloseKey hKey
    RegisteredUser = vValue

ExitFunction:
    On Error GoTo 0
    Exit Function

ErrorHandler:
    RegisteredUser = Empty
    Resume ExitFunction
End Function
'
'   Retrieves the registered organization information from the
'   registry.  If it is not found, it will return an empty string.
'
Public Function Organization() As Variant
    On Error GoTo ErrorHandler
    Dim lRetVal As Long, hKey As Long, vValue As Variant

    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, WINDOWS_KEY_NAME, 0, &H3F, hKey)
    lRetVal = GetKeyValue(hKey, "RegisteredOrganization", vValue)
    RegCloseKey hKey
    Organization = vValue

ExitFunction:
    On Error GoTo 0
    Exit Function

ErrorHandler:
    Organization = Empty
    Resume ExitFunction
End Function
'
'   Some valid shell folders are:
'
'   Favorites - Location of all the Favorite shortcuts
'   Desktop - Location of the current desktop
'   Programs - Location of the Programs option on the Start Menu
'   SendTo - Location where the items that appear on the Send To menu are stored
'   Start Menu - Location of the Start Menu icons and folders
'   Cache - Location of the temporary internet files
'   Personal - Location of the My Documents folder (which doesn't really have to be
'               called My Documents
'   Recent - Shortcuts to all the recently open files
'   Startup - Location of the StartUp menu folder (typically under Programs)
'
'
Public Function ShellFolderPath(sFolderName As String) As Variant
    On Error GoTo ErrorHandler
    Const EXPLORER_KEY_NAME As String = "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"

    Dim lRetVal As Long, hKey As Long, vValue As Variant

    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, EXPLORER_KEY_NAME, 0, KEY_ALL_ACCESS, hKey)
    lRetVal = GetKeyValue(hKey, sFolderName, vValue)
    RegCloseKey hKey
    ShellFolderPath = vValue

ExitFunction:
    On Error GoTo 0
    Exit Function

ErrorHandler:
    ShellFolderPath = Empty
    Resume ExitFunction
End Function

Private Function GetKeyValue(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long, lrc As Long
    Dim lType As Long, lValue As Long
    Dim sValue As String

    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc = 0 Then
        sValue = String(cch, 0)
        lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
        If lrc = 0 Then
            vValue = Left$(sValue, cch - 1)
        Else
            vValue = Empty
        End If
        GetKeyValue = lrc
    Else
        GetKeyValue = 0
    End If
End Function