Attribute VB_Name = "Misc"
Option Explicit

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableA" (ByVal Name As String, ByVal Buffer As String, ByVal Length As Long) As Long

Public Enum FileActions
    faEdit 'Launches an editor and opens the document for editing. If lpFile is not a document file, the function will fail.
    faExplore 'Explores the folder specified by lpFile.
    faFind 'Initiates a search starting from the specified directory.
    faOpen 'Opens the file specified by the lpFile parameter. The file can be an executable file, a document file, or a folder.
    faPrint 'Prints the document file specified by lpFile. If lpFile is not a document file, the function will fail.
    faDefault 'For systems prior to Microsoft Windows 2000, the default verb is used if it is valid and available in the registry. If not, the "open" verb is used.  For Windows 2000 and later systems, the default verb is used if available. If not, the "open" verb is used. If neither verb is available, the system uses the first verb listed in the registry.
End Enum
    
Public Enum FileActionResult
    faSuccess& = 33 'Success.
    faFileNotFound& = 2 'The specified file was not found.
    faPathNotFound& = 3 'The specified path was not found.
    faBadExecutable& = 11 'The .exe file is invalid (non-Microsoft Win32 .exe or error in .exe image).
    faAccessDenied& = 5 'The operating system denied access to the specified file.
    faInvalidAssociation& = 27 'The file name association is incomplete or invalid.
    faNoAssociation& = 31 'There is no application associated with the given file name extension. This error will also be returned if you attempt to print a file that is not printable.
    faDDEBusy& = 30 'The Dynamic Data Exchange (DDE) transaction could not be completed because other DDE transactions were being processed.
    faDDEFailure& = 29 'The DDE transaction failed.
    faDDETimeout& = 28 'The DDE transaction could not be completed because the request timed out.
    faDLLNotFound& = 32 'The specified dynamic-link library (DLL) was not found.
    faMemory& = 8 'There was not enough memory to complete the operation.
    faResources& = 0 'The operating system is out of memory or resources.
    faSharing& = 26 'A sharing violation occurred.
    faUnknownError& = -1
End Enum

Private Const SW_SHOWDEFAULT& = 10
Public strTest As String, lngTest As Long

Private Enum MathOperations
    moNull
    moAdd
    moSubtract
    moMultiply
    moDivide
End Enum

Private Type Expression
    Num1 As Double
    Num2 As Double
    Operand As MathOperations
End Type

Private Type OSVERSIONINFOEX
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
    wServicePackMajor As Integer
    wServicePackMinor As Integer
    wSuiteMask As Integer
    wProductType As Byte
    wReserved As Byte
End Type

Private Const SIZEOF_OSVERSIONINFO As Long = 148
Private Const SIZEOF_OSVERSIONINFOEX As Long = 156

Private Const VER_PLATFORM_WIN32s                 As Long = 0
Private Const VER_PLATFORM_WIN32_WINDOWS          As Long = 1
Private Const VER_PLATFORM_WIN32_NT               As Long = 2
Private Const VER_SERVER_NT                       As Long = &H80000000
Private Const VER_WORKSTATION_NT                  As Long = &H40000000
Private Const VER_SUITE_SMALLBUSINESS             As Long = &H1
Private Const VER_SUITE_ENTERPRISE                As Long = &H2
Private Const VER_SUITE_BACKOFFICE                As Long = &H4
Private Const VER_SUITE_COMMUNICATIONS            As Long = &H8
Private Const VER_SUITE_TERMINAL                  As Long = &H10
Private Const VER_SUITE_SMALLBUSINESS_RESTRICTED  As Long = &H20
Private Const VER_SUITE_EMBEDDEDNT                As Long = &H40
Private Const VER_SUITE_DATACENTER                As Long = &H80
Private Const VER_SUITE_SINGLEUSERTS              As Long = &H100
Private Const VER_SUITE_PERSONAL                  As Long = &H200
Private Const VER_SUITE_BLADE                     As Long = &H400
Private Const VER_NT_WORKSTATION                  As Long = &H1
Private Const VER_NT_DOMAIN_CONTROLLER            As Long = &H2
Private Const VER_NT_SERVER                       As Long = &H3

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
    (lpVersionInfo As OSVERSIONINFOEX) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal Metric As Long) As Long

Private Const SM_TABLETPC                         As Long = 86
Private Const SM_MEDIACENTER                      As Long = 87
Private Const SM_STARTER                          As Long = 88
Private WinVer As OSVERSIONINFOEX

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
   (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
   
'
' Created by E.Spencer - This code is public domain.
'
'Security Mask constants
Public Const READ_CONTROL = &H20000
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const STANDARD_RIGHTS_READ = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or _
   KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or _
   KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or _
   KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Public Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE _
   Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
' Possible registry data types
Public Enum InTypes
   ValNull = 0
   ValString = 1
   ValXString = 2
   ValBinary = 3
   ValDWord = 4
   ValLink = 6
   ValMultiString = 7
   ValResList = 8
End Enum
' Registry value type definitions
Public Const REG_NONE As Long = 0
Public Const REG_SZ As Long = 1
Public Const REG_EXPAND_SZ As Long = 2
Public Const REG_BINARY As Long = 3
Public Const REG_DWORD As Long = 4
Public Const REG_LINK As Long = 6
Public Const REG_MULTI_SZ As Long = 7
Public Const REG_RESOURCE_LIST As Long = 8
' Registry section definitions
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
' Codes returned by Reg API calls
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
' Registry API functions used in this module (there are more of them)
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
Private Declare Function RegQueryValueEx 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 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, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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 RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Public Function GetOSVersion() As Boolean
    WinVer.dwOSVersionInfoSize = SIZEOF_OSVERSIONINFOEX
    GetVersionEx WinVer
    If (WinVer.dwPlatformId = 0) Then
        WinVer.dwOSVersionInfoSize = SIZEOF_OSVERSIONINFO
        If (Not GetVersionEx(WinVer)) Then _
            GetOSVersion = False
    End If
    GetOSVersion = True
End Function

Public Function GetOSVersionString() As String
    If WinVer.dwOSVersionInfoSize = 0 Then
        GetOSVersionString = "[unknown version]"
        Exit Function
    End If
    
    Dim R$, NullPos&
    
    Select Case WinVer.dwPlatformId
        Case VER_PLATFORM_WIN32_NT
            If (WinVer.dwMajorVersion = 5 And WinVer.dwMinorVersion = 2) Then
                R = "Microsoft Windows Server 2003"
            ElseIf (WinVer.dwMajorVersion = 5 And WinVer.dwMinorVersion = 1) Then
                R = "Microsoft Windows XP"
            ElseIf (WinVer.dwMajorVersion = 5 And WinVer.dwMinorVersion = 0) Then
                R = "Microsoft Windows 2000"
            ElseIf (WinVer.dwMajorVersion <= 4) Then
                R = "Microsoft Windows NT"
            End If
            If WinVer.dwOSVersionInfoSize = SIZEOF_OSVERSIONINFOEX Then
                If (WinVer.wProductType = VER_NT_WORKSTATION) Then
                    If (WinVer.dwMajorVersion = 4) Then
                        R = R & " Workstation 4.0"
                    ElseIf (GetSystemMetrics(SM_TABLETPC)) Then
                        R = R & " Tablet PC Edition"
                    ElseIf (GetSystemMetrics(SM_MEDIACENTER)) Then
                        R = R & " Media Center Edition"
                    ElseIf (GetSystemMetrics(SM_STARTER)) Then
                        R = R & " Starter Edition"
                    ElseIf ((WinVer.wSuiteMask And VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL) Then
                        R = R & " Home Edition"
                    Else
                        R = R & " Professional"
                    End If
                ElseIf (WinVer.wProductType = VER_NT_SERVER Or WinVer.wProductType = VER_NT_DOMAIN_CONTROLLER) Then
                    If (WinVer.dwMajorVersion = 5 And WinVer.dwMinorVersion = 2) Then
                        If ((WinVer.wSuiteMask And VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER) Then
                            R = R & " Datacenter Edition"
                        ElseIf ((WinVer.wSuiteMask And VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE) Then
                            R = R & " Enterprise Edition"
                        ElseIf ((WinVer.wSuiteMask And VER_SUITE_BLADE) = VER_SUITE_BLADE) Then
                            R = R & " Web Edition"
                        Else
                            R = R & " Standard Edition"
                        End If
                    ElseIf (WinVer.dwMajorVersion = 5 And WinVer.dwMinorVersion = 0) Then
                        If ((WinVer.wSuiteMask And VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER) Then
                            R = R & " Datacenter Server"
                        ElseIf ((WinVer.wSuiteMask And VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE) Then
                            R = R & " Enterprise Server"
                        Else
                            R = R & " Server"
                        End If
                    Else
                        If ((WinVer.wSuiteMask And VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE) Then
                            R = R & " Server 4.0 Enterprise Edition"
                        Else
                            R = R & " Server 4.0"
                        End If
                    End If
                End If
            Else
                R = R & Space$(1) & WinVer.dwMajorVersion & "." & WinVer.dwMinorVersion
            End If
            NullPos = InStr(1, WinVer.szCSDVersion, vbNullChar)
            If (NullPos > 0) Then
                R = R & Space$(1) & Left$(WinVer.szCSDVersion, NullPos - 1)
            End If
            R = R & " (build " & (WinVer.dwBuildNumber And &HFFFF) & ")"
        Case VER_PLATFORM_WIN32_WINDOWS
            If (WinVer.dwMajorVersion = 4 And WinVer.dwMinorVersion = 0) Then
                R = "Microsoft Windows 95"
                Select Case Mid$(WinVer.szCSDVersion, 2, 1)
                    Case "B", "C": R = R & " OSR2"
                End Select
            ElseIf (WinVer.dwMajorVersion = 4 And WinVer.dwMinorVersion = 10) Then
                R = "Microsoft Windows 98"
                Select Case Mid$(WinVer.szCSDVersion, 2, 1)
                    Case "A": R = R & " Second Edition"
                End Select
            ElseIf (WinVer.dwMajorVersion = 4 And WinVer.dwMinorVersion = 90) Then
                R = "Microsoft Windows Me"
            Else
                R = "Microsoft Windows (32-bit)"
            End If
        Case VER_PLATFORM_WIN32s
            R = "Microsoft Win32 Subsystem"
    End Select
    GetOSVersionString = R
End Function


Public Function FileAction(Action As FileActions, Optional ByVal File As String = vbNullString, _
Optional ByVal Folder As String = vbNullString, Optional ByVal EXEParamaters As String = vbNullString) _
As FileActionResult
    Dim Res&, sAction$
On Error GoTo FA_Error
    FileAction = faUnknownError
    Select Case Action
        Case faOpen: sAction = "open"
        Case faExplore: sAction = "explore"
        Case faFind: sAction = "find"
        Case faEdit: sAction = "edit"
        Case faPrint: sAction = "print"
        Case faDefault: sAction = vbNullString
    End Select
    Res = ShellExecute(0&, sAction, File, EXEParamaters, Folder, SW_SHOWDEFAULT)
    If Res > 32 Then
        FileAction = faSuccess
        Exit Function
    End If
    FileAction = Res
FA_Error:
End Function

Public Function ExtractPath(Filename As String) As String
    Dim Pos&
    Pos = InStr(StrReverse(Filename), "\")
    ExtractPath = vbNullString
    If Pos = 0 Then
        Exit Function
    End If
    ExtractPath = Left$(Filename, Len(Filename) - Pos)
End Function

Public Property Get Environment(Variable As String) As String
    Dim Length As Long
    Environment = String$(512, 0)
    
    Length = GetEnvironmentVariable(Variable, Environment, 512)
    If (Length = 0) Then
        Environment = vbNullString
    Else
        Environment = Left$(Environment, Length)
    End If
End Property

Public Function ResolvePath(Path As String) As String
    Dim i As Long, j As Long, Temp As String
    
    ResolvePath = Path
    i = InStr(1, ResolvePath, "%")
    
    Do While i > 0
        j = InStr(i + 1, ResolvePath, "%")
        Temp = Environment(Mid$(ResolvePath, i + 1, (j - 2)))
        ResolvePath = Mid$(Path, 1, i - 1) & Temp & Mid$(Path, j + 1)
        i = InStr(i + Len(Temp), ResolvePath, "%")
    Loop
End Function

'Public Function LV_GetIndexByPosition(hwnd As Long, PixelsX As Long, PixelsY As Long)
'    Dim rVal&, lvhti As LVHITTESTINFO
'On Error GoTo GIBP_Error
'    LV_GetIndexByPosition = 0
'    lvhti.pt.X = PixelsX
'    lvhti.pt.Y = PixelsY
'    LV_GetIndexByPosition = SendMessage(hwnd, LVM_HITTEST, 0, lvhti) + 1
'GIBP_Error:
'End Function

Public Function SupportsBubbleTooltips() As Boolean
    SupportsBubbleTooltips = (WinVer.dwMajorVersion >= 5)
End Function

'Public Function LngToHex(ByVal Value As Long) As String
'    Dim Foo As String * 4
'    CopyMemory ByVal Foo, Value, 4
'    LngToHex = StrToHex(Foo)
'End Function

Public Function LngToHex(ByVal Long1 As Long, Optional ByVal UseSeperators As Boolean = False) As String
    Dim strOut$, C$, i&, B(3) As Byte
    CopyMemory B(0), Long1, 4
    For i = 0 To 3 Step 1
        C = Hex$(B(i))
        If Len(C) = 1 Then C = "0" & C
        If UseSeperators And i <> 4 Then
            strOut = C & Space$(1) & strOut
        Else
            strOut = C & strOut
        End If
    Next i
    LngToHex = strOut
End Function

Public Function MathExpression(Expression As String) As Double
    Dim Ops() As Expression, o&, i&, CurOp As MathOperations
    Dim Num1 As Double, Num2 As Double, IsNeg As Boolean
    Dim CurChar As String
    
    MathExpression = 0
    If LenB(Expression) = 0 Then
        Exit Function
    End If
    
    CurOp = moNull
    
    For i = 1 To Len(Expression)
        CurChar = Mid$(Expression, i, 1)
        Select Case CurChar
            Case "+": CurOp = moAdd
            Case "-"
                If i = 1 Then
                    IsNeg = True
                ElseIf CurOp = moNull Then
                    CurOp = moSubtract
                Else
                    IsNeg = True
                End If
            Case "*": CurOp = moMultiply
            Case "/": CurOp = moDivide
        End Select
    Next i
End Function


Public Function DebugOutput(ByVal sIn As String) As String
   Dim x1 As Long, y1 As Long
   Dim iLen As Long, iPos As Long
   Dim sB As String, sT As String
   Dim sOut As String
   
   'build random string to display
   'y1 = 384
   'sIn = String(y1, 0)
   'For x1 = 1 To y1
   '    Mid(sIn, x1, 1) = Chr(255 * Rnd())
   'Next x1
   
   iLen = Len(sIn)
   If iLen = 0 Then Exit Function
   sOut = ""
   For x1 = 0 To ((iLen - 1) \ 16)
       sB = String(48, " ")
       sT = "................"
       For y1 = 1 To 16
           iPos = 16 * x1 + y1
           If iPos > iLen Then Exit For
           Mid(sB, 3 * (y1 - 1) + 1, 2) = Right("00" & Hex(Asc(Mid(sIn, iPos, 1))), 2) & " "
           Select Case Asc(Mid(sIn, iPos, 1))
           Case 32 To 255
               Mid(sT, y1, 1) = Mid(sIn, iPos, 1)
           End Select
       Next y1
       If Len(sOut) > 0 Then sOut = sOut & vbCrLf
       sOut = sOut & sB & "  " & sT
   Next x1
   DebugOutput = sOut
End Function


' This routine allows you to get values from anywhere in the Registry, it currently
' only handles string, double word and binary values. Binary values are returned as
' hex strings.
'
' Example
' Text1.Text = ReadRegistry(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\", "DefaultUserName")
'
Public Function ReadRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String) As String
Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long, sValue As String, td As Double
Dim TStr1 As String, TStr2 As String
Dim i As Integer
On Error Resume Next
lResult = RegOpenKey(Group, Section, lKeyValue)
sValue = Space$(2048)
lValueLength = Len(sValue)
lResult = RegQueryValueEx(lKeyValue, Key, 0&, lDataTypeValue, sValue, lValueLength)
If (lResult = 0) And (Err.Number = 0) Then
   If lDataTypeValue = REG_DWORD Then
      td = Asc(Mid$(sValue, 1, 1)) + &H100& * Asc(Mid$(sValue, 2, 1)) + &H10000 * Asc(Mid$(sValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(sValue, 4, 1)))
      sValue = Format$(td, "000")
   End If
   If lDataTypeValue = REG_BINARY Then
       ' Return a binary field as a hex string (2 chars per byte)
       TStr2 = ""
       For i = 1 To lValueLength
          TStr1 = Hex(Asc(Mid(sValue, i, 1)))
          If Len(TStr1) = 1 Then TStr1 = "0" & TStr1
          TStr2 = TStr2 + TStr1
       Next
       sValue = TStr2
   Else
      sValue = Left$(sValue, lValueLength - 1)
   End If
Else
   sValue = "Not Found"
End If
lResult = RegCloseKey(lKeyValue)
ReadRegistry = sValue
End Function

' This routine allows you to write values into the entire Registry, it currently
' only handles string and double word values.
'
' Example
' WriteRegistry HKEY_CURRENT_USER, "SOFTWARE\My Name\My App\", "NewSubKey", ValString, "NewValueHere"
' WriteRegistry HKEY_CURRENT_USER, "SOFTWARE\My Name\My App\", "NewSubKey", ValDWord, "31"
'
Public Sub WriteRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String, ByVal ValType As InTypes, ByVal Value As Variant)
Dim lResult As Long
Dim lKeyValue As Long
Dim InLen As Long
Dim lNewVal As Long
Dim sNewVal As String
On Error Resume Next
lResult = RegCreateKey(Group, Section, lKeyValue)
If ValType = ValDWord Then
   lNewVal = CLng(Value)
   InLen = 4
   lResult = RegSetValueExLong(lKeyValue, Key, 0&, ValType, lNewVal, InLen)
Else
   ' Fixes empty string bug - spotted by Marcus Jansson
   If ValType = ValString Then Value = Value + Chr(0)
   sNewVal = Value
   InLen = Len(sNewVal)
   lResult = RegSetValueExString(lKeyValue, Key, 0&, 1&, sNewVal, InLen)
End If
lResult = RegFlushKey(lKeyValue)
lResult = RegCloseKey(lKeyValue)
End Sub

' This routine enumerates the subkeys under any given key
' Call repeatedly until "Not Found" is returned - store values in array or something
'
' Example - this example just adds all the subkeys to a string - you will probably want to
' save then into an array or something.
'
' Dim Res, NewLine As String
' Dim i As Long
' Res = ReadRegistryGetSubkey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\", i)
' NewLine = ""
' Do Until Res = "Not Found"
'   Text1.Text = Text1.Text & NewLine & Res
'   i = i + 1
'   Res = ReadRegistryGetSubkey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\", i)
'   NewLine = Chr(13) & Chr(10)
' Loop

Public Function ReadRegistryGetSubkey(ByVal Group As Long, ByVal Section As String, Idx As Long) As String
Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long, sValue As String, td As Double
On Error Resume Next
lResult = RegOpenKey(Group, Section, lKeyValue)
sValue = Space$(2048)
lValueLength = Len(sValue)
lResult = RegEnumKey(lKeyValue, Idx, sValue, lValueLength)
If (lResult = 0) And (Err.Number = 0) Then
   sValue = Left$(sValue, InStr(sValue, Chr(0)) - 1)
Else
   sValue = "Not Found"
End If
lResult = RegCloseKey(lKeyValue)
ReadRegistryGetSubkey = sValue
End Function

' This routine allows you to get all the values from anywhere in the Registry under any
' given subkey, it currently only returns string and double word values.
'
' Example - returns list of names/values to multiline text box
' Dim Res As Variant
' Dim i As Long
' Res = ReadRegistryGetAll(HKEY_CURRENT_USER, "Software\Microsoft\Notepad", i)
' Do Until Res(2) = "Not Found"
'    Text1.Text = Text1.Text & Chr(13) & Chr(10) & Res(1) & " " & Res(2)
'    i = i + 1
'    Res = ReadRegistryGetAll(HKEY_CURRENT_USER, "Software\Microsoft\Notepad", i)
' Loop
'
Public Function ReadRegistryGetAll(ByVal Group As Long, ByVal Section As String, Idx As Long) As Variant
Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long
Dim lValueLength As Long, lValueNameLength As Long
Dim sValueName As String, sValue As String
Dim td As Double
On Error Resume Next
lResult = RegOpenKey(Group, Section, lKeyValue)
sValue = Space$(2048)
sValueName = Space$(2048)
lValueLength = Len(sValue)
lValueNameLength = Len(sValueName)
lResult = RegEnumValue(lKeyValue, Idx, sValueName, lValueNameLength, 0&, lDataTypeValue, sValue, lValueLength)
If (lResult = 0) And (Err.Number = 0) Then
   If lDataTypeValue = REG_DWORD Then
      td = Asc(Mid$(sValue, 1, 1)) + &H100& * Asc(Mid$(sValue, 2, 1)) + &H10000 * Asc(Mid$(sValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(sValue, 4, 1)))
      sValue = Format$(td, "000")
   End If
   sValue = Left$(sValue, lValueLength - 1)
   sValueName = Left$(sValueName, lValueNameLength)
Else
   sValue = "Not Found"
End If
lResult = RegCloseKey(lKeyValue)
' Return the datatype, value name and value as an array
ReadRegistryGetAll = Array(lDataTypeValue, sValueName, sValue)
End Function

' This routine deletes a specified key (and all its subkeys and values if on Win95) from the registry.
' Be very careful using this function.
'
' Example
' DeleteSubkey HKEY_CURRENT_USER, "Software\My Name\My App"
'
Public Function DeleteSubkey(ByVal Group As Long, ByVal Section As String) As String
Dim lResult As Long, lKeyValue As Long
On Error Resume Next
lResult = RegOpenKeyEx(Group, vbNullChar, 0&, KEY_ALL_ACCESS, lKeyValue)
lResult = RegDeleteKey(lKeyValue, Section)
lResult = RegCloseKey(lKeyValue)
End Function

' This routine deletes a specified value from below a specified subkey.
' Be very careful using this function.
'
' Example
' DeleteValue HKEY_CURRENT_USER, "Software\My Name\My App", "NewSubKey"
'
Public Function DeleteValue(ByVal Group As Long, ByVal Section As String, ByVal Key As String) As String
Dim lResult As Long, lKeyValue As Long
On Error Resume Next
lResult = RegOpenKey(Group, Section, lKeyValue)
lResult = RegDeleteValue(lKeyValue, Key)
lResult = RegCloseKey(lKeyValue)
End Function
Public Function ParseStatus(Status As Integer) As String
Select Case Status
  Case 0: ParseStatus = "Offline"
  Case 1: ParseStatus = "Online"
End Select
End Function
Public Function ParseRank(Rank As Integer) As String
Select Case Rank
  Case 0: ParseRank = "Recruit"
  Case 1: ParseRank = "Peon"
  Case 2: ParseRank = "Grunt"
  Case 3: ParseRank = "Shaman"
  Case 4: ParseRank = "Chieftan"
End Select
End Function

