Register Editor With VB

‘add 1 ListView, 1 treeview, 1 ImageList, 1 Label and 1 text

Option Explicit
Dim OsVers As OsVersionInfo

Private Sub ResizeControls()
‘—————————————————–
‘Resize controls when the user resizes the form
‘or moves the splitter bar.
‘—————————————————–
On Error GoTo ReSizeError
TreeView1.Move 5 * Screen.TwipsPerPixelX, TreeView1.Top, Picture1.Left – 5 * Screen.TwipsPerPixelX, ScaleHeight – TreeView1.Top – Text1.Height – 5 * Screen.TwipsPerPixelY
ListView1.Move Picture1.Left + Picture1.Width, TreeView1.Top, ScaleWidth – Picture1.Left – Picture1.Width – 5 * Screen.TwipsPerPixelX, TreeView1.Height
Picture1.Top = TreeView1.Top
Picture1.Height = TreeView1.Height

Label1.Left = TreeView1.Left + 60

Text1.Move TreeView1.Left, ScaleHeight – Text1.Height, ScaleWidth – 2 * TreeView1.Left
Exit Sub
ReSizeError:
Exit Sub

End Sub

Private Sub Form_DragDrop(Source As Control, x As Single, y As Single)
If Source = Picture1 Then
Picture1.Left = x
ResizeControls
End If

End Sub

Private Sub Form_Load()
Width = 600 * Screen.TwipsPerPixelX
Picture1.Width = 5 * Screen.TwipsPerPixelX
Picture1.Left = 250 * Screen.TwipsPerPixelX
Dim nodX As Node
Dim ClmHdr As ColumnHeader

‘—————————————————–
‘ add columns to listview control
‘—————————————————–
Set ClmHdr = ListView1.ColumnHeaders.Add()
ClmHdr.Text = “Name”
ClmHdr.Width = ListView1.Width / 3
Set ClmHdr = Me.ListView1.ColumnHeaders.Add()
ClmHdr.Text = “Data”
ClmHdr.Width = 3 * ListView1.Width / 2
‘—————————————————–
‘First we find out what Windows is running. There are a
‘couple of registry keys in Win95 that are not present
‘in Windows NT
‘—————————————————–
OsVers.dwVersionInfoSize = 148&
lTempLong = GetVersionEx(OsVers)
Select Case OsVers.dwPlatform
Case VER_PLATFORM_WIN32_NT
iWinVers = WinNt
Case VER_PLATFORM_WIN32_WINDOWS
iWinVers = Win32
Case Else ‘Shouldn’t happen
MsgBox “This program is intended only for use with 32-bit Windows versions.”
Unload Form1
End Select

‘—————————————————–
‘Start the TreeView with a toplevel key
‘—————————————————–

Set nodX = TreeView1.Nodes.Add(, , “main”, “My Computer”, 3)

‘—————————————————–
‘Put in Public main keys
‘—————————————————–

Set nodX = TreeView1.Nodes.Add(“main”, tvwChild, “HKEY_CLASSES_ROOT”, “HKEY_CLASSES_ROOT”, 1)
nodX.EnsureVisible ‘Forces the tree open to this level
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False ‘Enumerate a single rgeSubKey, to put a + on the key
Set nodX = TreeView1.Nodes.Add(“main”, tvwChild, “HKEY_CURRENT_USER”, “HKEY_CURRENT_USER”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
Set nodX = TreeView1.Nodes.Add(“main”, tvwChild, “HKEY_LOCAL_MACHINE”, “HKEY_LOCAL_MACHINE”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
Set nodX = TreeView1.Nodes.Add(“main”, tvwChild, “HKEY_USERS”, “HKEY_USERS”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False

‘—————————————————–
‘Put in version-specific main keys
‘HKEY_PERFORMANCE_DATA does not respond in a normal fashion
‘to key queries.  Note it does not appear in REGEDT32.
‘If iWinVers = WinNT Then
‘treeview1.AddItem “HKEY_PERFORMANCE_DATA”
‘End If
‘—————————————————–
If iWinVers = Win32 Then
Set nodX = TreeView1.Nodes.Add(“main”, tvwChild, “HKEY_CURRENT_CONFIG”, “HKEY_CURRENT_CONFIG”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
Set nodX = TreeView1.Nodes.Add(“main”, tvwChild, “HKEY_DYN_DATA”, “HKEY_DYN_DATA”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
End If
‘—————————————————–
‘Setup hourglass cursor
‘—————————————————–
iWaitCursor = LoadCursor(0, IDC_WAIT)

End Sub

Private Sub Form_Resize()
ResizeControls
End Sub

Private Sub listview1_DblClick()
‘ if nothing selected get out
If Not (ListView1.SelectedItem Is Nothing) Then
‘———————————————————-
‘Call EditRegValue to load the value into the editor.
‘———————————————————-
EditRegValue TreeView1.Nodes(TreeView1.SelectedItem.Key), CLng(ListView1.ListItems(ListView1.SelectedItem.Index).Tag)
End If

End Sub

Private Sub ListView1_DragDrop(Source As Control, x As Single, y As Single)
If Source = Picture1 Then
Picture1.Left = x + ListView1.Left
ResizeControls
End If

End Sub

Private Sub TreeView1_Collapse(ByVal Node As ComctlLib.Node)
Text1 = truncatepath(Node.FullPath, Me, Text1)

End Sub

Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
If Source = Picture1 Then
Picture1.Left = x + TreeView1.Left
ResizeControls
End If
End Sub

Private Sub TreeView1_Expand(ByVal Node As Node)
If Node.Children > 1 Then Exit Sub
If Node.Text = “My Computer” Then Exit Sub
RegEnumKeys Node, True
Node.Sorted = True

End Sub

Private Sub TreeView1_NodeClick(ByVal Node As Node)

‘—————————————————–
‘Empty the value list.
‘—————————————————–
ListView1.ListItems.Clear

‘—————————————————–
‘Remember which line was clicked when we start
‘   moving up and down the list.
‘—————————————————–

rgeSubKey = Node.FullPath
Text1 = truncatepath(Node.FullPath, Me, Text1)
If rgeSubKey = “My Computer” Then Exit Sub
‘—————————————————–
‘Now enumerate all values belonging to this key
‘—————————————————–
ListView1.Sorted = False
RegEnumValues
ListView1.Sorted = True
End Sub

‘Now the module

Option Explicit

Type FILETIME
lLowDateTime    As Long
lHighDateTime   As Long
End Type

Type OsVersionInfo
dwVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatform As Long
szCSDVersion As String * 128
End Type

Declare Function RegOpenKeyEx& Lib “advapi32.dll” Alias “RegOpenKeyExA” (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
Declare Function RegCloseKey& Lib “advapi32.dll” (ByVal hKey&)
Declare Function RegQueryValueEx& Lib “advapi32.dll” Alias “RegQueryValueExA” (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Declare Function RegSetValueEx& Lib “advapi32.dll” Alias “RegSetValueExA” (ByVal hKey&, ByVal lpszValueName$, ByVal dwRes&, ByVal dwType&, lpDataBuff As Any, ByVal nSize&)
Declare Function RegConnectRegistry& Lib “advapi32.dll” (ByVal lpMachineName$, ByVal hKey&, phkResult&)
Declare Function RegCreateKeyEx& Lib “advapi32.dll” Alias “RegCreateKeyExA” (ByVal hKey&, ByVal lpSubKey$, ByVal Reserved&, ByVal lpClass$, ByVal dwOptions&, ByVal samDesired&, lpSecurityAttributes&, phkResult&, lpdwDisposition&)
Declare Function RegFlushKey& Lib “advapi32.dll” (ByVal hKey&)
Declare Function RegEnumKeyEx& Lib “advapi32.dll” Alias “RegEnumKeyExA” (ByVal hKey&, ByVal dwIndex&, ByVal lpname$, lpcbName&, ByVal lpReserved&, ByVal lpClass$, lpcbClass&, lpftLastWriteTime As FILETIME)

Declare Function RegEnumValue& Lib “advapi32.dll” Alias _
“RegEnumValueA” (ByVal hKey&, ByVal dwIndex&, ByVal lpname$, _
lpcbName&, ByVal lpReserved&, lpdwType&, lpValue As Any, lpcbValue&)

Declare Function RegQueryInfoKey& Lib “advapi32.dll” Alias “RegQueryInfoKeyA” (ByVal hKey&, ByVal lpClass$, lpcbClass&, ByVal lpReserved&, lpcSubKeys&, lpcbMaxSubKeyLen&, lpcbMaxClassLen&, lpcValues&, lpcbMaxValueNameLen&, lpcbMaxValueLen&, lpcbSecurityDescriptor&, lpftLastWriteTime As FILETIME)

Declare Function GetVersionEx& Lib “kernel32.dll” Alias “GetVersionExA” (lpStruct As OsVersionInfo)

Declare Function LoadCursor& Lib “User32″ Alias “LoadCursorA” (ByVal hInstance&, ByVal lpCursor&)
Declare Function SetCursor& Lib “User32″ (ByVal hCursor&)
Public Const IDC_WAIT = 32514&

Public iWaitCursor&

Public lNewKey& ‘used to generate unique Node keys

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006

Public Const LB_SETHORIZONTALEXTENT = &H400 + 21

Const REG_NONE = 0&                        ‘ No value type
Public Const REG_SZ = 1&                   ‘ Unicode nul terminated string
Const REG_EXPAND_SZ = 2&                   ‘ Unicode nul terminated string
‘ (with environment variable references)
Const REG_BINARY = 3&                      ‘ Free form binary
Public Const REG_DWORD = 4&                ‘ 32-bit number
Const REG_DWORD_LITTLE_ENDIAN = 4&         ‘ 32-bit number (same as REG_DWORD)
Const REG_DWORD_BIG_ENDIAN = 5&            ‘ 32-bit number
Const REG_LINK = 6&                        ‘ Symbolic Link (unicode)
Const REG_MULTI_SZ = 7&                    ‘ Multiple Unicode strings
Const REG_RESOURCE_LIST = 8&               ‘ Resource list in the resource map
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&    ‘ Resource list in the hardware description
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Public iWinVers%
Public Const WinNt = 1
Public Const Win32 = 2

Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2

Public lTempLong&
Public fTempDbl#
Public sTempString$
Public nodetemp As Node

Public rgeEntry$
Public rgeDataType&
Public rgeValue$
Public rgeMainKey&
Public rgeSubKey$

Public Sub rgeExtractKeys()
‘——————————————————————
‘Enter with rgeSubKey containing a full path in the
‘My Computer\HKEY_…\..\ format or HKEY_…\…\ format
‘————————————————————–
If Left$(rgeSubKey, 12) = “My Computer\” Then
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) – 12)
End If

‘—————————————————————-
‘If there is no main key we have to assume it may already have
‘been extracted.
‘—————————————————————
If Left$(rgeSubKey, 5) <> “HKEY_” Then
Exit Sub
ElseIf InStr(rgeSubKey, “\”) = 0 Then
rgeMainKey = GetMainKey(rgeSubKey)
rgeSubKey = “”
Else
rgeMainKey = GetMainKey(Left$(rgeSubKey, InStr(rgeSubKey, “\”) – 1))
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) – InStr(rgeSubKey, “\”))
End If
‘ —————————————————–
‘ Check rgeMainKey& for validity
‘ —————————————————–
If rgeMainKey < &H80000000 Or rgeMainKey > &H80000006 Then
rgeClear
End If

End Sub
Public Sub rgeClear()
rgeMainKey = 0
rgeSubKey = “”
rgeValue = “”
rgeDataType = 0
rgeEntry = “”
End Sub

Sub EditRegValue(ByVal nodX As Node, lRegIndex&)
‘ ——————————————————–
‘ Specific to the RegDemo application.
‘ ——————————————————–
rgeSubKey = nodX.FullPath
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) – 12)
If InStr(rgeSubKey, “\”) = 0 Then
rgeMainKey = GetMainKey(rgeSubKey)
rgeSubKey = “”
Else
‘————————————————-
‘This must be a SubKey.
‘————————————————-
rgeMainKey = GetMainKey(Left$(rgeSubKey, InStr(rgeSubKey, “\”) – 1))
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) – InStr(rgeSubKey, “\”))
End If

Dim lRtn&       ‘ Returned by registry functions, should be 0&
Dim hKey&       ‘ Return handle to opened key
Dim lLenValueName&
Dim lLenValue&
Dim lKeyIndx&

‘ ——————————————————–
‘ values for QueryInfoKey:
‘ ——————————————————–
Dim sClassName$
Dim lClassLen&
Dim lSubKeys&
Dim lMaxSubKey&
Dim lMaxClass&
Dim lValues&
Dim lMaxValueName&
Dim lMaxValueData&
Dim lSecurityDesc&
Dim strucLastWriteTime As FILETIME

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
If lRtn <> ERROR_SUCCESS Then
MsgBox RtnRegError(lRtn)

‘ ————————————————–
‘ No key open, so leave
‘ ————————————————–
Exit Sub
End If

‘ —————————————————–
‘ RegQueryInfoKey is used to get the size of the largest
‘   value name and data string.
‘ Other returned values are ignored.
‘ —————————————————–
sClassName = Space$(255) ‘initialize these because occasional errors otherwise
lClassLen = CLng(Len(sClassName))
lRtn = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)

‘——————————————————————-
‘If the enumeration fails due to a buffer over-run, we will loop back
‘to this point with larger buffers.
‘——————————————————————-
RetryValueHere:

‘ ————————————————–
‘ Set variables
‘ ————————————————–
rgeEntry = Space$(lMaxValueName + 1)
lLenValueName = CLng(Len(rgeEntry)) ‘+ 1
rgeValue = Space$(lMaxValueData + 1)
lLenValue = CLng(Len(rgeValue))       ‘+ 1

‘ ————————————————–
‘ Call the enumeration function to get the indexed value
‘ ————————————————–
lRtn = RegEnumValue(hKey, lRegIndex, rgeEntry, lLenValueName, 0&, rgeDataType, ByVal rgeValue, lLenValue)

‘ ————————————————–
‘ Check for success
‘ ————————————————–
If lRtn = ERROR_SUCCESS Then
If rgeDataType <> REG_SZ And rgeDataType <> REG_DWORD Then

‘————————————————————–
‘Tell us what value types may be edited, along with
‘    the type of value found.
‘————————————————————–
sTempString = “This Demo only supports editing of values with types of REG_SZ and REG_DWORD.  This value is of type “
Select Case rgeDataType
Case 2
sTempString = sTempString & “REG_EXPAND_SZ.”
Case 3
sTempString = sTempString & “REG_BINARY.”
Case 5
sTempString = sTempString & “REG_DWORD_BIG_ENDIAN.”
Case 6
sTempString = sTempString & “REG_LINK.”
Case 7
sTempString = sTempString & “REG_MULTI_SZ.”
Case 8
sTempString = sTempString & “REG_RESOURCE_LIST.”
Case 9
sTempString = sTempString & “REG_FULL_RESOURCE_DESCRIPTOR.”
Case 10
sTempString = sTempString & “REG_RESOURCE_REQUIREMENTS_LIST.”
End Select
MsgBox sTempString

Else
rgeEntry = Mid$(rgeEntry, 1, lLenValueName)
If lLenValueName = 0 Then
rgeEntry = “(Default)”
End If
rgeValue = Mid$(rgeValue, 1, lLenValue)
‘ ——————————————–
‘ Convert DWORD 4 character value to 32-bit
‘   number.
‘ First character is low byte, and so on.
‘ ——————————————–
Form2.Caption = “Edit String Value”
If rgeDataType = REG_DWORD Then
fTempDbl = Asc(Mid$(rgeValue, 1, 1)) + &H100& * Asc(Mid$(rgeValue, 2, 1)) + &H10000 * Asc(Mid$(rgeValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(rgeValue, 4, 1)))
If fTempDbl > &H7FFFFFFF Then
rgeValue = Hex$(fTempDbl – 4294967296#)
Else
rgeValue = Hex$(fTempDbl)
End If
‘ —————————————–
‘ Turn on Hex/Decimal options
‘ —————————————–
Form2.Frame1.Visible = True
Form2.Caption = “Edit DWORD Value”
End If

‘ ——————————————–
‘ Place the values in the form2 text boxes
‘ ——————————————–
Form2.Text1 = rgeEntry
Form2.Text2 = rgeValue

‘ ——————————————–
‘ Pass the key variables to form2 via hidden
‘   text boxes
‘ ——————————————–
Form2.Show 1
End If

ElseIf lRtn = ERROR_MORE_DATA Then
‘ ———————————————–
‘ This error means that, despite querying the key
‘   we have not set one of the buffers large
‘   enough. If the buffer is already 20000 we are
‘   not going to be able to edit it.
‘ ———————————————–
If lMaxValueData >= 20000 Then
MsgBox (“Value is too large for this editor!”)
Else

‘ ——————————————–
‘ Increase the buffer sizes and try again
‘ ——————————————–
lMaxValueData = lMaxValueData + 5
lMaxValueName = lMaxValueName + 5
GoTo RetryValueHere
End If
Else

‘ ————————————————–
‘ Key still open, so display the error and fall
‘   thru to the close function below
‘ ————————————————–
MsgBox RtnRegError(lRtn)
End If

‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)

End Sub

Function truncatepath$(TPath$, TForm As Form, TControl As Control)
Dim FirstSlash%
On Error GoTo TPathError
TPath = Right$(TPath, Len(TPath) – InStr(TPath, “H”) + 1)
FirstSlash = InStr(3, TPath, “\”)
Do Until TForm.TextWidth(TPath) <= TControl.Width
lTempLong = InStr(FirstSlash + 5, TPath, “\”)
TPath = Left$(TPath, FirstSlash) & “…” & Mid$(TPath, lTempLong, Len(TPath) – lTempLong + 1)
Loop
TooLong:
On Error GoTo StillError
If TForm.TextWidth(TPath) > TControl.Width Then
Do Until TForm.TextWidth(TPath) <= TControl.Width
TPath = Left$(TPath, Len(TPath) – 1)
Loop
TPath = Left$(TPath, Len(TPath) – 3) & “…”
End If
FinishAnyWay:
truncatepath = TPath
Exit Function
TPathError:
Resume TooLong
StillError:
Resume FinishAnyWay
End Function

Function GetMainKey&(keyname$)

‘ —————————————————–
‘ Used to convert main key strings to their values
‘ —————————————————–

Select Case keyname
Case “HKEY_CLASSES_ROOT”
GetMainKey = HKEY_CLASSES_ROOT
Case “HKEY_CURRENT_USER”
GetMainKey = HKEY_CURRENT_USER
Case “HKEY_LOCAL_MACHINE”
GetMainKey = HKEY_LOCAL_MACHINE
Case “HKEY_USERS”
GetMainKey = HKEY_USERS
Case “HKEY_PERFORMANCE_DATA”
GetMainKey = HKEY_PERFORMANCE_DATA
Case “HKEY_CURRENT_CONFIG”
GetMainKey = HKEY_CURRENT_CONFIG
Case “HKEY_DYN_DATA”
GetMainKey = HKEY_DYN_DATA
End Select

End Function

Function RegEnumKeys&(ByVal Node As Node, bFullEnumeration As Boolean)
lTempLong = SetCursor(iWaitCursor)
Dim sRoot$, sRoot2$
rgeSubKey = Node.FullPath
If rgeSubKey = “My Computer” Then
Exit Function
End If
‘———————————————
‘If we’ve put in a fake node to set the + image,
‘remove that node to avoid duplication
‘———————————————
While Node.Children > 0
Form1.TreeView1.Nodes.Remove Node.Child.Key
Wend
Form1.TreeView1.Enabled = False
rgeExtractKeys
sRoot = Node.Key
‘ ——————————————————–
‘ This function will load all subkeys into the TreeView
‘ ——————————————————–
Dim lRtn&       ‘ Returned by registry functions, should be 0&
Dim hKey&       ‘ Return handle to opened key
Dim strucLastWriteTime    As FILETIME
Dim sSubKeyName$
Dim sClassString$
Dim lLenSubKey&
Dim lLenClass&
Dim lKeyIndx&
Dim lRet&
Dim hKey2&
Dim sSubKey2$
Dim nodX As Node
Dim sNewKey$

‘———————————————
‘values for QueryInfoKey:
‘———————————————
Dim sClassName$
Dim lClassLen&
Dim lSubKeys&
Dim lMaxSubKey&
Dim sMaxSubKey$
Dim lMaxClass&
Dim sMaxClass$
Dim lValues&
Dim lMaxValueName&
Dim lMaxValueData&
Dim lSecurityDesc&

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
If lRtn <> ERROR_SUCCESS Then
If lRtn = ERROR_ACCESS_DENIED Then
‘———————————————
‘Grey the key
‘otherwise report error condition
‘———————————————
Node.Image = 6
‘Node.Enabled = False ‘Doesn’t work?
Else
MsgBox RtnRegError(lRtn)
End If
RegEnumKeys = lRtn
Form1.TreeView1.Enabled = True
Exit Function

‘ ————————————————–
‘ No key open, so leave
‘ ————————————————–
End If

‘ —————————————————–
‘ A call to RegQueryInfoKey will tell us the maximum
‘   keyname length
‘ —————————————————–
sClassName = Space$(255)
lClassLen = CLng(Len(sClassName))
lRet = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)
sMaxSubKey = Space$(lMaxSubKey + 1)
sMaxClass = Space$(lMaxClass + 1)

‘ —————————————————–
‘ Enumerate the keys
‘ —————————————————–
lKeyIndx = 0&
Do While lRtn = ERROR_SUCCESS

‘ —————————————————–
‘ If the enumeration fails due to a buffer over-run,
‘   we will loop back to this point with larger buffers.
‘ —————————————————–
ReTryKeyEnumeration:

‘ ————————————————–
‘ Set variables
‘ ————————————————–
sSubKeyName = sMaxSubKey
lLenSubKey = lMaxSubKey
sClassString = sMaxClass
lLenClass = lMaxClass

‘ ————————————————–
‘ Call the enumeration function
‘ ————————————————–
lRtn = RegEnumKeyEx(hKey, lKeyIndx, sSubKeyName, lLenSubKey, 0&, sClassString, lLenClass, strucLastWriteTime)
If InStr(sSubKeyName, Chr$(0)) > 1 Then
sSubKeyName = Left$(sSubKeyName, InStr(sSubKeyName, Chr$(0)) – 1)
End If

‘ ————————————————–
‘ Check for success
‘ ————————————————–
If lRtn = ERROR_SUCCESS Then
lNewKey = lNewKey + 1
sNewKey = “A” & Format$(lNewKey, “000000″)
Set nodX = Form1.TreeView1.Nodes.Add(sRoot, tvwChild, sNewKey, sSubKeyName, 1)
If bFullEnumeration = True Then
sSubKey2 = sSubKeyName
If rgeSubKey <> “” Then
sSubKey2 = Trim(rgeSubKey) & “\” & sSubKeyName
End If

‘ ———————————————–
‘ Use RegQueryInfoKey to find out if this key has
‘   subkeys
‘ ———————————————–
lRet = RegOpenKeyEx(rgeMainKey, sSubKey2, 0&, KEY_READ, hKey2)
‘——————————————————
‘We are fully enumerating a key, so set images and
‘Recurse a single SubKey to set + indicator if there are
’subkeys below this one
‘——————————————————
If lRet = ERROR_ACCESS_DENIED Then
nodX.ExpandedImage = 6
nodX.SelectedImage = 6
ElseIf lRet = ERROR_SUCCESS Then
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
lRet = RegQueryInfoKey(hKey2, vbNullString, 0&, 0&, lSubKeys, 0&, 0&, 0&, 0&, 0&, 0&, strucLastWriteTime)
‘ ————————————————–
‘ Check for success.  If lSubKeys is greater than zero
‘ there are subkeys for this key, and we will set a fake
‘ node under this one to make a + symbol.
‘ ————————————————–
If lRet = ERROR_SUCCESS And lSubKeys > 0 Then
sRoot2 = nodX.Key
lNewKey = lNewKey + 1
sNewKey = “A” & Format$(lNewKey, “000000″)
Set nodX = Form1.TreeView1.Nodes.Add(sRoot2, tvwChild, sNewKey, “PlaceHolder”, 1)
End If
lRet = RegCloseKey(hKey2)
End If
Else
Exit Do
End If
lKeyIndx = lKeyIndx + 1
ElseIf lRtn = ERROR_MORE_DATA Then
‘ ———————————————–
‘ This error means that, despite querying the key
‘   we have not set one of the buffers large
‘   enough.Increment the buffer sizes and try
‘   again
‘ ———————————————–
lMaxSubKey = lMaxSubKey + 5
lMaxClass = lMaxClass + 5
sMaxSubKey = Space$(lMaxSubKey + 1)
sMaxClass = Space$(lMaxClass + 1)
GoTo ReTryKeyEnumeration
ElseIf lRtn = ERROR_NO_MORE_ITEMS Then
‘ ———————————————–
‘ Not an error, just end of list — exit the
‘   loop
‘ ———————————————–
lRtn = ERROR_SUCCESS
Exit Do
ElseIf lRtn <> ERROR_SUCCESS Then
‘ ————————————————–
‘ Key still open, so display the error and fall
‘   thru to the close function below
‘ ————————————————–
MsgBox RtnRegError(lRtn)
Exit Do
End If
Loop

‘ —————————————————–
‘ Set the return to the last error
‘ —————————————————–
RegEnumKeys = lRtn

‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)
Form1.TreeView1.Enabled = True
End Function
Public Sub RegEnumValues()
‘ ——————————————————–
‘Enter with rgeSubKey containing a full key path, in
‘My Computer\HKEY_..\..\ fashion
‘ ——————————————————–
‘When you don’t need to enumerate all values, but just want to
‘retrive a single value, use the provided function RegGetValue
‘———————————————————
Dim lRtn&        ‘ Returned by registry functions, should be 0&
Dim hKey&       ‘ Return handle to opened key
Dim lLenValueName&
Dim lLenValue&
Dim lKeyIndx&
Dim sBinaryString$
Dim Item As ListItem
Dim iTempInt%
‘—————————
‘values for QueryInfoKey:
‘—————————
Dim sClassName$
Dim lClassLen&
Dim lSubKeys&
Dim lMaxSubKey&
Dim lMaxClass&
Dim lValues&
Dim lMaxValueName&
Dim lMaxValueData&
Dim lSecurityDesc&
Dim strucLastWriteTime As FILETIME
Dim pbytValueName() As Byte
Dim pbytValue() As Byte
Dim DataType&
Dim ValueName$
Dim ValueVal$

Dim iListWidth%  ‘Used to set listbox scrollbar

lTempLong = SetCursor(iWaitCursor)

rgeExtractKeys

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
If lRtn <> ERROR_SUCCESS Then
If lRtn <> ERROR_ACCESS_DENIED Then
‘———————————————
‘If access is denied don’t do anything
‘———————————————
MsgBox RtnRegError(lRtn)
End If
rgeClear

‘ ————————————————–
‘ No key open, so leave
‘ ————————————————–
Exit Sub
End If

‘ —————————————————–
‘ Use RegQueryInfoKey to get the maximum value data info.
‘ —————————————————–
sClassName = Space$(255)
lClassLen = CLng(Len(sClassName))
lRtn = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)

‘ —————————————————–
‘ Enumerate the keys
‘ —————————————————–
lKeyIndx = 0&
Do While lRtn = ERROR_SUCCESS And lKeyIndx < lValues
sBinaryString = “”

‘——————————————————————-
‘If the enumeration fails due to a buffer over-run, we will loop back
‘to this point with larger buffers.
‘——————————————————————-
ReTryValueEnumeration:

‘ ————————————————–
‘ Set variables
‘ ————————————————–
ValueName = Space$(lMaxValueName + 1)
lLenValueName = CLng(Len(ValueName)) ‘+ 1
ValueVal = Space$(lMaxValueData + 1)
lLenValue = CLng(Len(ValueVal))       ‘+ 1

‘ ————————————————–
‘ Call the enumeration function
‘ ————————————————–
‘lRtn = RegEnumValue(hKey, lKeyIndx, pbytValueName(0), _
‘lLenValueName, vbNull, rgeDataType, pbytValue(0), _
‘lLenValue)
lRtn = RegEnumValue(hKey, lKeyIndx, ValueName, _
lLenValueName, 0&, DataType, ByVal ValueVal, _
lLenValue)

‘ ————————————————–
‘ Check for success
‘ ————————————————–
If lRtn = ERROR_SUCCESS Then

rgeEntry = ValueName
rgeDataType = DataType
rgeValue = ValueVal
‘rgeValue = pbytValue()
‘———————————————–
‘Add an item to the list box
‘———————————————–
Set Item = Form1.ListView1.ListItems.Add()

‘ ———————————————–
‘ Start building the entry to put in the list box:
‘ ———————————————–
rgeEntry = Mid$(rgeEntry, 1, lLenValueName)

‘ ———————————————–
‘ Default values don’t have a name.
‘ ———————————————–
If lLenValueName = 0 Then
rgeEntry = “(Default)”
End If

rgeValue = Mid$(rgeValue, 1, lLenValue)
Select Case rgeDataType
Case REG_MULTI_SZ
‘ ————————————–
‘ REG_MULTI_SZ strings are a series of
‘   zero terminated strings. If we don’t
‘   strip out the zeros, only the first
‘   one will display.
‘ We will replace them with spaces.
‘ ————————————–
Item.SmallIcon = 4
Do While InStr(rgeValue, Chr$(0))
rgeValue = Left$(rgeValue, InStr(rgeValue, Chr$(0)) – 1) & ” ” & Right$(rgeValue, Len(rgeValue) – InStr(rgeValue, Chr$(0)))
Loop
Case REG_SZ
‘ ————————————–
‘ REG_SZ values are zero-terminated
‘   strings, and are the most common
‘   values.
‘ ————————————–
Item.SmallIcon = 4

‘—————————————
‘Put quotes around the string
‘—————————————
rgeValue = “”"” & Left$(rgeValue, lLenValue – 1) & “”"”

Case REG_EXPAND_SZ
‘—————————————
‘Environmental variables that are binary
‘but evaluate as strings.  Not edited by
‘this program.
‘—————————————
Item.SmallIcon = 5
Case REG_FULL_RESOURCE_DESCRIPTOR
‘ ————————————–
‘ Resource Descriptors require a special
‘   editor to properly be displayed or
‘   edited.
‘ ————————————–
Item.SmallIcon = 5
rgeValue = “REG_FULL_RESOURCE_DESCRIPTOR”

Case REG_DWORD
‘ ————————————–
‘ REG_DWORD values are 32-bit unsigned
‘   integers
‘ Tortuous manipulation to make values
‘   above 7FFFFFFF appear as positive
‘   values.
‘ VB Longs would display them as
‘   negative numbers.
‘ ————————————–
Item.SmallIcon = 5
fTempDbl = Asc(Mid$(rgeValue, 1, 1)) + &H100& * Asc(Mid$(rgeValue, 2, 1)) + &H10000 * Asc(Mid$(rgeValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(rgeValue, 4, 1)))
If fTempDbl > &H7FFFFFFF Then
rgeValue = “&H” & Hex$(fTempDbl – 4294967296#)
Else
rgeValue = “&H” & Hex$(fTempDbl)
End If
rgeValue = rgeValue & ” (” & Format$(fTempDbl) & “)”

Case REG_BINARY

‘ ————————————–
‘ Binary values may be of any length,
‘   and may represent text or other data.
‘ They require a special editor to
‘   modify them.
‘ ————————————–
Item.SmallIcon = 5
For iTempInt = 1 To Len(rgeValue)
sBinaryString = sBinaryString & Format$(Hex(Asc(Mid$(rgeValue, iTempInt, 1))), “00″) & ” “
Next iTempInt
rgeValue = sBinaryString
End Select

If Len(rgeValue) = 0 Then
rgeValue = “(value not set)”
End If

‘ ———————————————–
‘ Enter the value into the list box
‘ ———————————————–
Item.Text = rgeEntry
Item.SubItems(1) = rgeValue
Item.Tag = CStr(lKeyIndx)
‘ ———————————————–
‘ Increment the key and do it again.
‘ ———————————————–
lKeyIndx = lKeyIndx + 1

ElseIf lRtn = ERROR_MORE_DATA Then
‘ ———————————————–
‘ This error means that, despite querying the key,
‘   we have not set one of the buffers large
‘   enough.  Increment the buffer sizes and try
‘   again
‘ ———————————————–
lMaxValueData = lMaxValueData + 5
lMaxValueName = lMaxValueName + 5
GoTo ReTryValueEnumeration

ElseIf lRtn = ERROR_NO_MORE_ITEMS Then
‘ ———————————————–
‘ Not an error, just end of list — exit the
‘   loop
‘ ———————————————–
lRtn = ERROR_SUCCESS
Exit Do

Else
‘ ————————————————–
‘ Key still open, so display the error and fall
‘   thru to the close function below
‘ ————————————————–
MsgBox RtnRegError(lRtn)
Exit Do
End If
Loop

‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)

End Sub

Function RegGetValue$()
‘ This function is not used in this demo, but is a sample for
‘ retrieving a single value
‘ rgeMainKey must be one of the Publicly declared HKEY constants.
Dim sKeyType&       ‘returns the key type.  This function expects REG_SZ or REG_DWORD
Dim ret&            ‘returned by registry functions, should be 0&
Dim lpHKey&         ‘return handle to opened key
Dim lpcbData&       ‘length of data in returned string
Dim ReturnedString$ ‘returned string rgeValue
Dim fTempDbl!
If rgeMainKey >= &H80000000 And rgeMainKey <= &H80000006 Then
‘ Open key
ret = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, lpHKey)
If ret <> ERROR_SUCCESS Then
RegGetValue = “”
Exit Function     ‘No key open, so leave
End If

‘ Set up buffer for data to be returned in.
‘ Adjust next rgeValue for larger buffers.
lpcbData = 255
ReturnedString = Space$(lpcbData)

‘ Read key
ret& = RegQueryValueEx(lpHKey, rgeValue, ByVal 0&, sKeyType, ReturnedString, lpcbData)
If ret <> ERROR_SUCCESS Then
RegGetValue = “”   ‘Key still open, so finish up
Else
If sKeyType = REG_DWORD Then
fTempDbl = Asc(Mid$(ReturnedString, 1, 1)) + &H100& * Asc(Mid$(ReturnedString, 2, 1)) + &H10000 * Asc(Mid$(ReturnedString, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(ReturnedString, 4, 1)))
ReturnedString = Format$(fTempDbl, “000″)
End If
RegGetValue = Left$(ReturnedString, lpcbData – 1)
End If
‘ Always close opened keys.
ret = RegCloseKey(lpHKey)
End If
End Function

Sub RegSetValue()
‘ ——————————————————–
‘ DWORD Values must be in Hex form for this function to
‘   work.
‘ ——————————————————–
Dim lRtn&            ‘returned by registry functions, should be 0&
Dim hKey&         ‘return handle to opened key
Dim iFirstChar%
Dim iSecondChar%
Dim iThirdChar%
Dim iFourthChar%
Dim lpDisp&

If rgeDataType <> REG_SZ And rgeDataType <> REG_DWORD Then
MsgBox “This demo only supports writing keys of the types REG_SZ and REG_DWORD.  This key uses a different type.”
Exit Sub
End If

‘ —————————————————–
‘ Check rgeMainKey for validity
‘ —————————————————–
If rgeMainKey >= &H80000000 And rgeMainKey <= &H80000006 Then

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegCreateKeyEx(rgeMainKey, rgeSubKey, 0&, “”, 0&, KEY_WRITE, 0&, hKey, lpDisp)
If lRtn <> ERROR_SUCCESS Then
MsgBox RtnRegError(lRtn)
rgeClear
Exit Sub       ‘No key open, so leave
End If

‘ —————————————————–
‘ Write new rgeValue to key
‘ —————————————————–
If rgeDataType = REG_DWORD Then
rgeValue = Left(Trim(rgeValue),
If Left$(rgeValue, 2) <> “&H” Then
rgeValue = “&H” & Left(Trim(rgeValue),
End If
If Len(rgeValue) <= 6 Then
rgeValue = rgeValue & “&”
End If

‘ —————————————————–
‘Convert number string to 32-bit DWORD and save:
‘ —————————————————–
lRtn = RegSetValueEx(hKey, rgeEntry, 0&, rgeDataType, CLng(Val(rgeValue)), 4&)
Else

‘ —————————————————–
‘Save type REG_SZ (strings)
‘ —————————————————–
lRtn = RegSetValueEx(hKey, rgeEntry, 0&, rgeDataType, ByVal rgeValue, CLng(Len(rgeValue)))
End If
If lRtn <> ERROR_SUCCESS Then
MsgBox RtnRegError(lRtn) ‘Key still open, so finish up
End If
‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)
End If
End Sub

Private Function RtnRegError$(errorcode&)
Select Case errorcode
Case 1009, 1015
‘ —————————————————–
‘We’re in trouble now
‘ —————————————————–
RtnRegError = “The Registry Database is corrupt!”
Case 2, 1010
RtnRegError = “Bad Key Name!”
Case 1011
RtnRegError = “Can’t Open Key”
Case 4, 1012
RtnRegError = “Can’t Read Key”
Case 5
RtnRegError = “Access to this key is denied.”
Case 1013
RtnRegError = “Can’t Write Key”
Case 8, 14
RtnRegError = “Out of memory”
Case 87
RtnRegError = “Invalid Parameter”
Case 234
RtnRegError = “Error – There is more data than the buffer can handle!”
Case Else
RtnRegError = “Undefined Key Error Code” & Str$(errorcode) & “!”
End Select
End Function

Function WordLo(lLongIn&) As Integer
If (lLongIn And &HFFFF&) > &H7FFF Then
WordLo = (lLongIn And &HFFFF&) – &H10000
Else
WordLo = lLongIn And &HFFFF&
End If
End Function

Add horizontal scrool bar to a list box

‘declaration
Private Declare Function SendMessageByNum Lib “user32″ Alias “SendMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const LB_SETHORIZONTALEXTENT = &H194

‘form code

Dim s As String
Static x As Long
s = InputBox(“Please enter any text”, “List scroll”, “this is a simple scrollbar sample for demonstration purposes”)
List1.AddItem s
If x < TextWidth(s & “  “) Then
x = TextWidth(s & “  “)
End If
If ScaleMode = vbTwips Then
x = x / Screen.TwipsPerPixelX      ‘ if twips change to pixels
SendMessageByNum List1.hwnd, LB_SETHORIZONTALEXTENT, x, 0
End If

VB IDEAdd code to a Module

Determine if an application is running in the VB IDEAdd this code to a Module:

Option Explicit

Declare Function GetModuleFileName Lib “KERNEL32″ Alias _
“GetModuleFileNameA” (ByVal hModule As Long, ByVal lpFileName As String, _
ByVal nSize As Long) As Long

Public Function DebugMode() As Boolean
Dim strFileName As String
Dim lngCount As Long
strFileName = String(255, 0)
lngCount = GetModuleFileName(App.hInstance, strFileName, 255)
strFileName = Left(strFileName, lngCount)
If UCase(Right(strFileName, 7)) <> “VB6.EXE” Then
DebugMode = False
Else
DebugMode = True
End If
End Function

‘– End –’

To use the function just add the following code in code:

If DebugMode Then
‘ Running in the VB IDE
Else
‘ Run

Detect User With VB

‘Add 1 Form and 1 Class Module
Option Explicit
‘
‘ Win32 APIs to determine OS information.
‘
Private Declare Function GetVersionEx Lib “kernel32″ Alias “GetVersionExA” (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
‘
‘ Win32 NetAPIs.
‘
Private Declare Function NetUserChangePassword Lib “netapi32″ (Domain As Any, User As Any, OldPass As Byte, NewPass As Byte) As Long
Private Declare Function NetUserGetInfo Lib “netapi32″ (lpServer As Any, UserName As Byte, ByVal Level As Long, lpBuffer As Long) As Long
Private Declare Function NetUserGetGroups Lib “netapi32″ (lpServer As Any, UserName As Byte, ByVal Level As Long, lpBuffer As Long, ByVal PrefMaxLen As Long, lpEntriesRead As Long, lpTotalEntries As Long) As Long
Private Declare Function NetUserGetLocalGroups Lib “netapi32″ (lpServer As Any, UserName As Byte, ByVal Level As Long, ByVal Flags As Long, lpBuffer As Long, ByVal MaxLen As Long, lpEntriesRead As Long, lpTotalEntries As Long) As Long
Private Declare Function NetApiBufferFree Lib “netapi32″ (ByVal pBuffer As Long) As Long
Private Declare Function NetRemoteTOD Lib “NETAPI32.DLL” (yServer As Any, pBuffer As Long) As Long
Private Declare Function GetUserName Lib “advapi32.dll” Alias “GetUserNameA” (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserNameW Lib “advapi32.dll” (lpBuffer As Byte, nSize As Long) As Long
Private Declare Function GetComputerName Lib “kernel32″ Alias “GetComputerNameA” (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerNameW Lib “kernel32″ (lpBuffer As Any, nSize As Long) As Long

Private Declare Sub CopyMem Lib “kernel32″ Alias “RtlMoveMemory” (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenW Lib “kernel32″ (ByVal lpString As Long) As Long
Private Declare Function lstrcpyW Lib “kernel32″ (lpString1 As Byte, ByVal lpString2 As Long) As Long

Private Type USER_INFO_3_API
‘ Level 0 starts here
Name As Long
‘ Level 1 starts here
Password As Long
PasswordAge As Long
Privilege As Long
HomeDir As Long
Comment As Long
Flags As Long
ScriptPath As Long
‘ Level 2 starts here
AuthFlags As Long
FullName As Long
UserComment As Long
Parms As Long
Workstations As Long
LastLogon As Long
LastLogoff As Long
AcctExpires As Long
MaxStorage As Long
UnitsPerWeek As Long
LogonHours As Long
BadPwCount As Long
NumLogons As Long
LogonServer As Long
CountryCode As Long
CodePage As Long
‘ Level 3 starts here
UserID As Long
PrimaryGroupID As Long
Profile As Long
HomeDirDrive As Long
PasswordExpired As Long
End Type

Private Type USER_INFO_3
‘ Level 0 starts here
Name As String
‘ Level 1 starts here
Password As String
PasswordAge As Long
Privilege As Long
HomeDir As String
Comment As String
Flags As Long
ScriptPath As String
‘ Level 2 starts here
AuthFlags As Long
FullName As String
UserComment As String
Parms As String
Workstations As String
LastLogon As Long
LastLogoff As Long
AcctExpires As Long
MaxStorage As Long
UnitsPerWeek As Long
LogonHours(0 To 20) As Byte
BadPwCount As Long
NumLogons As Long
LogonServer As String
CountryCode As Long
CodePage As Long
‘ Level 3 starts here
UserID As Long
PrimaryGroupID As Long
Profile As String
HomeDirDrive As String
PasswordExpired As Boolean
End Type

Private Type GROUP_INFO_2_API
Name As Long
Comment As Long
GroupID As Long
Attributes As Long
End Type

Private Type GROUP_INFO_2
Name As String
Comment As String
GroupID As Long
Attributes As Long
End Type

Private Const FILTER_TEMP_DUPLICATE_ACCOUNT As Long = &H1&
Private Const FILTER_NORMAL_ACCOUNT As Long = &H2&
Private Const FILTER_PROXY_ACCOUNT As Long = &H4&
Private Const FILTER_INTERDOMAIN_TRUST_ACCOUNT As Long = &H8&
Private Const FILTER_WORKSTATION_TRUST_ACCOUNT As Long = &H10&
Private Const FILTER_SERVER_TRUST_ACCOUNT As Long = &H20&

Private Const NERR_Success As Long = 0&
Private Const ERROR_MORE_DATA As Long = 234&

Private Const TIMEQ_FOREVER = -1&             ‘((unsigned long) -1L)
Private Const USER_MAXSTORAGE_UNLIMITED = -1& ‘((unsigned long) -1L)
Private Const USER_NO_LOGOFF = -1&            ‘((unsigned long) -1L)
Private Const UNITS_PER_DAY = 24
Private Const UNITS_PER_WEEK = UNITS_PER_DAY * 7

Private Const USER_PRIV_MASK = 3
Private Const USER_PRIV_GUEST = 0
Private Const USER_PRIV_USER = 1
Private Const USER_PRIV_ADMIN = 2

Private Const UNLEN = 256         ‘ Maximum username length
Private Const GNLEN = UNLEN       ‘ Maximum groupname length
Private Const CNLEN = 15          ‘ Maximum computer name length
Private Const MAXCOMMENTSZ = 256  ‘ Multipurpose comment length
Private Const LG_INCLUDE_INDIRECT As Long = &H1&

Private m_UserInfo As USER_INFO_3
Private m_UserName As String
Private m_Server As String
Private m_Groups() As String
Private m_LocalGroups() As String
Private m_IsWinNT As Boolean

‘ *********************************************************
‘  Initialization
‘ *********************************************************
Private Sub Class_Initialize()
Dim os As OSVERSIONINFO
os.dwOSVersionInfoSize = Len(os)
Call GetVersionEx(os)

If os.dwPlatformId = VER_PLATFORM_WIN32_NT Then
m_IsWinNT = True
Server = CurrentMachineName()
UserName = CurrentUserName()
End If
End Sub

‘ *********************************************************
‘  Public Properties
‘ *********************************************************
Public Property Get UserName() As String
UserName = m_UserInfo.Name
End Property

Public Property Let UserName(NewVal As String)
m_UserName = NewVal
Me.Refresh
End Property

Public Property Get Server() As String
Server = m_Server
End Property

Public Property Let Server(NewVal As String)
m_Server = NewVal
End Property

Public Property Get GroupCount() As Long
GroupCount = UBound(m_Groups) + 1
End Property

Public Property Get Group(ByVal Index As Long) As String
If Index >= LBound(m_Groups) And Index <= UBound(m_Groups) Then
Group = m_Groups(Index)
End If
End Property

Public Property Get LocalGroupCount() As Long
LocalGroupCount = UBound(m_LocalGroups) + 1
End Property

Public Property Get LocalGroup(ByVal Index As Long) As String
If Index >= LBound(m_LocalGroups) And Index <= UBound(m_LocalGroups) Then
LocalGroup = m_LocalGroups(Index)
End If
End Property

Public Property Get Password()
Err.Raise Number:=vbObjectError + 1, _
Source:=”CNetUser.Password”, _
Description:=”Password property is write-only for security.”
End Property

Public Property Get PasswordAge() As Long
PasswordAge = m_UserInfo.PasswordAge
End Property

Public Property Get Privilege() As Long
Privilege = m_UserInfo.Privilege
End Property

Public Property Get HomeDir() As String
HomeDir = m_UserInfo.HomeDir
End Property

Public Property Get Comment() As String
Comment = m_UserInfo.Comment
End Property

Public Property Get Flags() As Long
Flags = m_UserInfo.Flags
End Property

Public Property Get ScriptPath() As String
ScriptPath = m_UserInfo.ScriptPath
End Property

Public Property Get AuthFlags() As Long
AuthFlags = m_UserInfo.AuthFlags
End Property

Public Property Get FullName() As String
FullName = m_UserInfo.FullName
End Property

Public Property Get UserComment() As String
UserComment = m_UserInfo.UserComment
End Property

Public Property Get Parms() As String
Parms = m_UserInfo.Parms
End Property

Public Property Get Workstations() As String
Workstations = m_UserInfo.Workstations
End Property

Public Property Get LastLogon() As Long
LastLogon = m_UserInfo.LastLogon
End Property

Public Property Get LastLogoff() As Long
LastLogoff = m_UserInfo.LastLogoff
End Property

Public Property Get LastLogonDate() As Double
LastLogonDate = NetTimeToVbTime(m_UserInfo.LastLogon)
End Property

Public Property Get LastLogoffDate() As Double
LastLogoffDate = NetTimeToVbTime(m_UserInfo.LastLogoff)
End Property

Public Property Get AcctExpires() As Long
AcctExpires = m_UserInfo.AcctExpires
End Property

Public Property Get AcctExpiresDate() As Long
AcctExpiresDate = NetTimeToVbTime(m_UserInfo.AcctExpires)
End Property

Public Property Get MaxStorage() As Long
MaxStorage = m_UserInfo.MaxStorage
End Property

Public Property Get UnitsPerWeek() As Long
UnitsPerWeek = m_UserInfo.UnitsPerWeek
End Property

Public Property Get LogonHours(ByVal Index As Long) As Byte
If Index >= 0 And Index <= 20 Then
LogonHours = m_UserInfo.LogonHours(Index)
End If
End Property

Public Property Get BadPasswordCount() As Long
BadPasswordCount = m_UserInfo.BadPwCount
End Property

Public Property Get NumLogons() As Long
NumLogons = m_UserInfo.NumLogons
End Property

Public Property Get LogonServer() As String
LogonServer = m_UserInfo.LogonServer
End Property

Public Property Get CountryCode() As Long
CountryCode = m_UserInfo.CountryCode
End Property

Public Property Get CodePage() As Long
CodePage = m_UserInfo.CodePage
End Property

Public Property Get UserID() As Long
UserID = m_UserInfo.UserID
End Property

Public Property Get PrimaryGroupID() As Long
PrimaryGroupID = m_UserInfo.PrimaryGroupID
End Property

Public Property Get Profile() As String
Profile = m_UserInfo.Profile
End Property

Public Property Get HomeDirDrive() As String
HomeDirDrive = m_UserInfo.HomeDirDrive
End Property

Public Property Get PasswordExpired() As Boolean
PasswordExpired = m_UserInfo.PasswordExpired
End Property

‘ *********************************************************
‘  Public Methods
‘ *********************************************************
Public Function Refresh() As Boolean
Dim lpBuffer As Long
Dim yUserName() As Byte
Dim yServer() As Byte
Dim uUserApi As USER_INFO_3_API
Dim nRet As Long

yUserName = m_UserName & vbNullChar
If m_Server = “” Then
nRet = NetUserGetInfo(ByVal 0&, yUserName(0), 3, lpBuffer)
Else
If InStr(m_Server, “\\”) = 1 Then
yServer = m_Server & vbNullChar
Else
yServer = “\\” & m_Server & vbNullChar
End If
nRet = NetUserGetInfo(yServer(0), yUserName(0), 3, lpBuffer)
End If

If nRet = NERR_Success Then
CopyMem uUserApi, ByVal lpBuffer, Len(uUserApi)
‘
‘ Transfer data to VB structure
‘
m_UserInfo.Name = PointerToStringW(uUserApi.Name)
m_UserInfo.Password = PointerToStringW(uUserApi.Password)
m_UserInfo.PasswordAge = uUserApi.PasswordAge
m_UserInfo.Privilege = uUserApi.Privilege
m_UserInfo.HomeDir = PointerToStringW(uUserApi.HomeDir)
m_UserInfo.Comment = PointerToStringW(uUserApi.Comment)
m_UserInfo.Flags = uUserApi.Flags
m_UserInfo.ScriptPath = PointerToStringW(uUserApi.ScriptPath)
m_UserInfo.AuthFlags = uUserApi.AuthFlags
m_UserInfo.FullName = PointerToStringW(uUserApi.FullName)
m_UserInfo.UserComment = PointerToStringW(uUserApi.UserComment)
m_UserInfo.Parms = PointerToStringW(uUserApi.Parms)
m_UserInfo.Workstations = PointerToStringW(uUserApi.Workstations)
m_UserInfo.LastLogon = uUserApi.LastLogon
m_UserInfo.LastLogoff = uUserApi.LastLogoff
m_UserInfo.AcctExpires = uUserApi.AcctExpires
m_UserInfo.MaxStorage = uUserApi.MaxStorage
m_UserInfo.UnitsPerWeek = uUserApi.UnitsPerWeek
CopyMem m_UserInfo.LogonHours(0), ByVal uUserApi.LogonHours, 21
m_UserInfo.BadPwCount = uUserApi.BadPwCount
m_UserInfo.NumLogons = uUserApi.NumLogons
m_UserInfo.LogonServer = PointerToStringW(uUserApi.LogonServer)
m_UserInfo.CountryCode = uUserApi.CountryCode
m_UserInfo.CodePage = uUserApi.CodePage
m_UserInfo.UserID = uUserApi.UserID
m_UserInfo.PrimaryGroupID = uUserApi.PrimaryGroupID
m_UserInfo.Profile = PointerToStringW(uUserApi.Profile)
m_UserInfo.HomeDirDrive = PointerToStringW(uUserApi.HomeDirDrive)
m_UserInfo.PasswordExpired = CBool(uUserApi.PasswordExpired)
‘
‘ Return success
‘
Refresh = True
End If
‘
‘ Clean up
‘
If lpBuffer Then
Call NetApiBufferFree(lpBuffer)
RefreshGroups
RefreshLocalGroups
End If
End Function

Public Function NetTimeToVbTime(NetDate As Long) As Double
Const BaseDate# = 25569   ‘DateSerial(1970, 1, 1)
Const SecsPerDay# = 86400
NetTimeToVbTime = BaseDate + (CDbl(NetDate) / SecsPerDay)
End Function

‘ *********************************************************
‘  Private Methods
‘ *********************************************************
Private Sub RefreshLocalGroups()
Dim lpBuffer As Long
Dim yUserName() As Byte
Dim yServer() As Byte
Dim lpGroups() As Long
Dim nRead As Long
Dim nTotal As Long
Dim nRet As Long
Dim i As Long
‘Const Flags& = LG_INCLUDE_INDIRECT ‘To get domain groups as well
Const Flags& = 0

yUserName = m_UserName & vbNullChar
If m_Server = “” Then
nRet = NetUserGetLocalGroups(ByVal 0&, yUserName(0), 0, Flags, lpBuffer, &H4000, nRead, nTotal)
Else
If InStr(m_Server, “\\”) = 1 Then
yServer = m_Server & vbNullChar
Else
yServer = “\\” & m_Server & vbNullChar
End If
nRet = NetUserGetLocalGroups(yServer(0), yUserName(0), 0, Flags, lpBuffer, &H400, nRead, nTotal)
End If

If nRet = NERR_Success Then
ReDim lpGroups(0 To nRead – 1) As Long
ReDim m_LocalGroups(0 To nRead – 1) As String
CopyMem lpGroups(0), ByVal lpBuffer, nRead * 4
For i = 0 To nRead – 1
m_LocalGroups(i) = PointerToStringW(lpGroups(i))
Next i
End If
‘
‘ Clean up
‘
If lpBuffer Then
Call NetApiBufferFree(lpBuffer)
End If
End Sub

Private Sub RefreshGroups()
Dim lpBuffer As Long
Dim yUserName() As Byte
Dim yServer() As Byte
Dim lpGroups() As Long
Dim nRead As Long
Dim nTotal As Long
Dim nRet As Long
Dim i As Long

yUserName = m_UserName & vbNullChar
If m_Server = “” Then
nRet = NetUserGetGroups(ByVal 0&, yUserName(0), 0, lpBuffer, &H4000, nRead, nTotal)
Else
If InStr(m_Server, “\\”) = 1 Then
yServer = m_Server & vbNullChar
Else
yServer = “\\” & m_Server & vbNullChar
End If
nRet = NetUserGetGroups(yServer(0), yUserName(0), 0, lpBuffer, &H400, nRead, nTotal)
End If

If nRet = NERR_Success Then
ReDim lpGroups(0 To nRead – 1) As Long
ReDim m_Groups(0 To nRead – 1) As String
CopyMem lpGroups(0), ByVal lpBuffer, nRead * 4
For i = 0 To nRead – 1
m_Groups(i) = PointerToStringW(lpGroups(i))
Next i
End If
‘
‘ Clean up
‘
If lpBuffer Then
Call NetApiBufferFree(lpBuffer)
End If
End Sub

Private Function PointerToStringW(lpStringW As Long) As String
Dim Buffer() As Byte
Dim nLen As Long

If lpStringW Then
nLen = lstrlenW(lpStringW) * 2
If nLen Then
ReDim Buffer(0 To (nLen – 1)) As Byte
CopyMem Buffer(0), ByVal lpStringW, nLen
PointerToStringW = Buffer
End If
End If
End Function

Private Function PointerToDWord(lpDWord As Long) As Long
Dim nRet As Long
If lpDWord Then
CopyMem nRet, ByVal lpDWord, 4
PointerToDWord = nRet
End If
End Function

Private Function CurrentUserName() As String
Dim Buffer As String
Dim yBuffer() As Byte
Dim nRet As Long
Dim nLen As Long
Const NameLength = UNLEN + 1

nLen = NameLength * 2
ReDim yBuffer(0 To nLen – 1) As Byte
If GetUserNameW(yBuffer(0), nLen) Then
Buffer = yBuffer
CurrentUserName = Left(Buffer, nLen – 1)
End If
End Function

Private Function CurrentMachineName() As String
Dim Buffer As String
Dim yBuffer() As Byte
Dim nRet As Long
Dim nLen As Long
Const NameLength = CNLEN + 1

nLen = NameLength * 2
ReDim yBuffer(0 To nLen – 1) As Byte
If GetComputerNameW(yBuffer(0), nLen) Then
Buffer = yBuffer
CurrentMachineName = Left(Buffer, nLen)
End If
End Function