www.pudn.com > ownfirewall > Registry.bas

Attribute VB_Name = "Registry" 
Option Explicit 
 
'HKeys 
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 REG_OPTION_NON_VOLATILE = 0& 
Public Const REG_OPTION_VOLATILE = &H1 
Public Const REG_CREATED_NEW_KEY = &H1 
Public Const REG_OPENED_EXISTING_KEY = &H2 
 
Public Const SPECIFIC_RIGHTS_ALL = &HFFFF 
Public Const ERROR_SUCCESS = 0& 
Public Const ERROR_ACCESS_DENIED = 5 
Public Const ERROR_INVALID_DATA = 13& 
Public Const ERROR_MORE_DATA = 234 
Public Const ERROR_NO_MORE_ITEMS = 259 
 
'DataTypes 
Public Const REG_NONE = 0 
Public Const REG_SZ = 1 
Public Const REG_EXPAND_SZ = 2 
Public Const REG_BINARY = 3 
Public Const REG_DWORD = 4 
Public Const REG_DWORD_LITTLE_ENDIAN = 4 
Public Const REG_DWORD_BIG_ENDIAN = 5 
Public Const REG_LINK = 6 
Public Const REG_MULTI_SZ = 7 
Public Const REG_RESOURCE_LIST = 8 
Public Const REG_FULL_RESOURCE_DESCRIPTOR = 9 
Public Const REG_RESOURCE_REQUIREMENTS_LIST = 10 
 
Const SYNCHRONIZE = &H100000 
Const STANDARD_RIGHTS_READ = &H20000 
Const STANDARD_RIGHTS_WRITE = &H20000 
Const STANDARD_RIGHTS_EXECUTE = &H20000 
Const STANDARD_RIGHTS_REQUIRED = &HF0000 
Const STANDARD_RIGHTS_ALL = &H1F0000 
 
'Right's for the OpenRegistry 
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 READ_CONTROL = &H20000 
Public Const KEY_WRITE = &H20006 
Public Const KEY_ALL_ACCESS = &H2003F ' &H3F 
Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) 
Public Const KEY_READ_WRITE = (KEY_READ And KEY_WRITE) 
 
' Registry location 
Public Const gREGKEYLocation = "SOFTWARE\Your Company Name\Your App Name\Your Current Version" 
Public Const gREGKEYXPos = "XPos" 
Public Const gREGKEYYPos = "YPos" 
Public Const gREGKEYWidth = "Width" 
Public Const gREGKEYHeight = "Height" 
Public Const gREGKEYWindowState = "WindowState" 
 
 
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long 
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long 
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long 
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long 
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 
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 Any, lpcbData As Long) As Long 
Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hKey As Long) As Long 
Declare Function RegLoadKey Lib "advapi32.dll" Alias "RegLoadKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpFile As String) As Long 
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 
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 
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 
 
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 
 
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 
 
Public Declare Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExA" _ 
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _ 
   ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long 
Public Declare Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExA" _ 
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _ 
   ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long 
Public Declare Function RegQueryValueExByte Lib "advapi32" Alias "RegQueryValueExA" _ 
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _ 
   ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long 
 
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 Any) As Long 
 
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 
Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long 
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 
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 
Declare Function RegUnLoadKey Lib "advapi32.dll" Alias "RegUnLoadKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long 
 
Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long 
 
Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long 
 
Type hKeys 
  Class As Long 
  Key As String 
  Name As String 
End Type 
Public hKeys(9) As hKeys 
 
Global sKeys() As String, iKeyCount As Long 
Global bkey As String, ikey As Integer 
Global dell As String, ell As String 
Global rell As String, gell As String 
Global hell As String, nell As String 
Global dill As String, fril As Integer 
Global nname As String, nkey As String 
Global nsubkey As String, npath As String 
 
Global MainKeys(50) As String 
Global SubKeys(50) As String 
Global Cretnew As Boolean 
Global classkey As String 
Global sectionkey As String 
Global Valuekey As String 
Global m_vDefault As Variant 
 
Function ExpandEnvStr(sData As String) As String 
    Dim c As Long, s As String 
    s = "" 
    c = ExpandEnvironmentStrings(sData, s, c) 
    s = String$(c - 1, 0) 
    c = ExpandEnvironmentStrings(sData, s, c) 
    ExpandEnvStr = s 
End Function 
 
Function SwapEndian(ByVal dw As Long) As Long 
  CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1 
  CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1 
  CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1 
  CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1 
End Function 
 
Public Function getstring(hKey As Long, strPath As String, strValue As String) 
Dim keyhand As Long 
Dim datatype As Long, r As Long 
  r = RegOpenKey(hKey, strPath, keyhand) 
  getstring = RegQueryStringValue(keyhand, strValue) 
  r = RegCloseKey(keyhand) 
End Function 
 
Function StripTerminator(ByVal strString As String) As String 
Dim intZeroPos As Integer 
  intZeroPos = InStr(strString, Chr$(0)) 
  If intZeroPos > 0 Then 
    StripTerminator = Left$(strString, intZeroPos - 1) 
  Else 
    StripTerminator = strString 
  End If 
End Function 
 
Public Sub savestring(hKey As Long, strPath As String, strValue As String, strdata As String) 
Dim keyhand As Long, r As Long 
  r = RegCreateKey(hKey, strPath, keyhand) 
  r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata)) 
  r = RegCloseKey(keyhand) 
End Sub 
 
Sub Wait(Seconds As Long) 
Dim StartTime As Long 
  StartTime = Timer 
  Do While Timer < StartTime + Seconds 
    DoEvents 
  Loop 
End Sub 
 
Function Short_Name(Long_Path As String) As String 
'Returns short path of the passed long path 
Dim Short_Path As String 
Dim Answer As Long 
  Short_Path = Space(250) 
  Answer = GetShortPathName(Long_Path, Short_Path, Len(Short_Path)) 
  If Answer Then 
    Short_Name = Left$(Short_Path, Answer) 
  End If 
End Function 
 
Function DeleteKey(ByVal classkey As Long, ByVal sectionkey As String) As Boolean 
Dim e As Long 
  e = RegDeleteKey(classkey, sectionkey) 
  If e Then 
    WriteLog "Failed to delete registry Key: '" & classkey & "',Section: '" & sectionkey 
  Else 
    DeleteKey = (e = ERROR_SUCCESS) 
  End If 
End Function 
 
Function DeleteValue(ByVal classkey As Long, ByVal sectionkey As String, ByVal Valuekey As String) As Boolean 
Dim e As Long 
Dim hKey As Long 
  e = RegOpenKeyEx(classkey, sectionkey, 0, KEY_ALL_ACCESS, hKey) 
  If e Then 
    WriteLog "Failed to open key '" & classkey & "',Section: '" & sectionkey & "' for delete access" 
  Else 
    e = RegDeleteValue(hKey, Valuekey) 
    If e Then 
      WriteLog "Failed to delete registry Key: '" & classkey & "',Section: '" & sectionkey & "',Key: '" & Valuekey 
    Else 
      DeleteValue = (e = ERROR_SUCCESS) 
    End If 
  End If 
End Function 
 
Function EnumerateValues(ByRef sKeyNames() As String, ByRef iKeyCount As Long) As Boolean 
Dim lResult As Long 
Dim hKey As Long 
Dim sName As String 
Dim lNameSize As Long 
Dim sData As String 
Dim lIndex As Long 
Dim cJunk As Long 
Dim cNameMax As Long 
Dim ft As Currency 
  iKeyCount = 0 
  Erase sKeyNames() 
  lIndex = 1 
  lResult = RegOpenKeyEx(classkey, sectionkey, 0, KEY_QUERY_VALUE, hKey) 
  If (lResult = ERROR_SUCCESS) Then 
    lResult = RegQueryInfoKey(hKey, "", cJunk, 0, cJunk, cJunk, cJunk, cJunk, cNameMax, cJunk, cJunk, ft) 
    Do While lResult = ERROR_SUCCESS 
      lNameSize = cNameMax + 1 
      sName = String$(lNameSize, 0) 
      If (lNameSize = 0) Then lNameSize = 1 
      lResult = RegEnumValue(hKey, lIndex, sName, lNameSize, 0&, 0&, 0&, 0&) 
      If (lResult = ERROR_SUCCESS) Then 
        sName = Left$(sName, lNameSize) 
        iKeyCount = iKeyCount + 1 
        ReDim Preserve sKeyNames(1 To iKeyCount) As String 
        sKeyNames(iKeyCount) = sName 
      End If 
      lIndex = lIndex + 1 
    Loop 
  End If 
  If (hKey <> 0) Then 
    RegCloseKey hKey 
  End If 
  EnumerateValues = True 
  Exit Function 
EnumerateValuesError: 
  If (hKey <> 0) Then 
    RegCloseKey hKey 
  End If 
  WriteLog "Registry: " & err.Description 
  Exit Function 
End Function 
 
Function EnumerateSections(ByRef sSect() As String, ByRef iSectCount As Long) As Boolean 
Dim lResult As Long 
Dim hKey As Long 
Dim dwReserved As Long 
Dim szBuffer As String 
Dim lBuffSize As Long 
Dim lIndex As Long 
Dim lType As Long 
Dim sCompKey As String 
Dim iPos As Long 
  On Error GoTo EnumerateSectionsError 
  iSectCount = 0 
  Erase sSect 
  lIndex = 0 
  lResult = RegOpenKeyEx(classkey, sectionkey, 0, KEY_ENUMERATE_SUB_KEYS, hKey) 
  Do While lResult = ERROR_SUCCESS 
    szBuffer = String$(255, 0) 
    lBuffSize = Len(szBuffer) 
    lResult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize) 
    If (lResult = ERROR_SUCCESS) Then 
      iSectCount = iSectCount + 1 
      ReDim Preserve sSect(1 To iSectCount) As String 
      iPos = InStr(szBuffer, Chr$(0)) 
      If (iPos > 0) Then 
        sSect(iSectCount) = Left(szBuffer, iPos - 1) 
      Else 
        sSect(iSectCount) = Left(szBuffer, lBuffSize) 
      End If 
    End If 
    lIndex = lIndex + 1 
  Loop 
  If (hKey <> 0) Then 
    RegCloseKey hKey 
  End If 
  EnumerateSections = True 
  Exit Function 
EnumerateSectionsError: 
  If (hKey <> 0) Then 
    RegCloseKey hKey 
  End If 
  WriteLog "Registry: " & err.Description 
  Exit Function 
End Function 
 
Function Value(classkey As Long, sectionkey As String) As Variant 
Dim vValue As Variant 
Dim cData As Long, sData As String, ordType As Long, e As Long 
Dim hKey As Long 
  Valuekey = "" 
  e = RegOpenKeyEx(classkey, sectionkey, 0, KEY_QUERY_VALUE, hKey) 
  e = RegQueryValueExLong(hKey, Valuekey, 0&, ordType, 0&, cData) 
  If e And e <> ERROR_MORE_DATA Then 
    Value = "m_vDefault" 
    Exit Function 
  End If 
  Select Case ordType 
  Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN 
    Dim iData As Long 
    e = RegQueryValueExLong(hKey, Valuekey, 0&, ordType, iData, cData) 
    vValue = CLng(iData) 
  Case REG_DWORD_BIG_ENDIAN 
    Dim dwData As Long 
    e = RegQueryValueExLong(hKey, Valuekey, 0&, ordType, dwData, cData) 
    vValue = SwapEndian(dwData) 
  Case REG_SZ, REG_MULTI_SZ 
    sData = String$(cData - 1, 0) 
    e = RegQueryValueExStr(hKey, Valuekey, 0&, ordType, sData, cData) 
    vValue = sData 
  Case REG_EXPAND_SZ 
    sData = String$(cData - 1, 0) 
    e = RegQueryValueExStr(hKey, Valuekey, 0&, ordType, sData, cData) 
    vValue = ExpandEnvStr(sData) 
  Case Else 
    Dim abData() As Byte 
    ReDim abData(cData) 
    e = RegQueryValueExByte(hKey, Valuekey, 0&, ordType, abData(0), cData) 
    vValue = abData 
  End Select 
  Value = vValue 
End Function 
 
 
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long 
    Dim cch As Long 
    Dim lrc As Long 
    Dim lType As Long 
    Dim lValue As Long 
    Dim sValue As String 
    On Error GoTo QueryValueExError 
    ' Determine the size and type of data to be read 
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch) 
    If lrc <> ERROR_SUCCESS Then Error 5 
    Select Case lType 
        ' For strings 
        Case REG_SZ: 
            sValue = String(cch, 0) 
            lrc = RegQueryValueExStr(lhKey, szValueName, 0&, lType, sValue, cch) 
            If lrc = ERROR_SUCCESS Then 
                vValue = Left$(sValue, cch) 
            Else 
                vValue = Empty 
            End If 
        ' For DWORDS 
        Case REG_DWORD: 
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch) 
            If lrc = ERROR_SUCCESS Then vValue = lValue 
        Case Else 
            'all other data types not supported 
            lrc = -1 
    End Select 
QueryValueExExit: 
    QueryValueEx = lrc 
    Exit Function 
QueryValueExError: 
    Resume QueryValueExExit 
End Function 
 
Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String) 
Dim lRetVal As Long         'result of the API functions 
Dim hKey As Long         'handle of opened key 
Dim vValue As Variant      'setting of queried value 
  lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey) 
  lRetVal = QueryValueEx(hKey, sValueName, vValue) 
  'MsgBox vValue 
  QueryValue = vValue 
  RegCloseKey (hKey) 
End Function 
  
Function GetKey(Class As Long, Section As String, Keys() As String) As Long 
Dim lngKeyHandle As Long 
Dim lngResult As Long 
Dim lngCurIdx As Long 
Dim strValue As String 
Dim lngValueLen As Long 
Dim lngData As Long 
Dim lngDataLen As Long 
Dim strResult As String 
Dim Str1 As String 
  lngResult = RegOpenKeyEx(Class, Section, 0&, KEY_READ, lngKeyHandle) 
  If lngResult <> ERROR_SUCCESS Then 
    'MsgBox "Cannot open key" 
    Exit Function 
  End If 
  lngCurIdx = 0 
  Do 
    lngValueLen = 2000 
    strValue = String(lngValueLen, 0) 
    lngDataLen = 2000 
    lngResult = RegEnumValue(lngKeyHandle, lngCurIdx, ByVal strValue, lngValueLen, 0&, REG_DWORD, ByVal lngData, lngDataLen) 
    lngCurIdx = lngCurIdx + 1 
    If lngResult = ERROR_SUCCESS Then 
      strResult = Left(strValue, lngValueLen) 
      Keys(lngCurIdx) = strResult 
    Else 
      Keys(lngCurIdx) = "" 
    End If 
  Loop While lngResult = ERROR_SUCCESS 
  Call RegCloseKey(lngKeyHandle) 
  GetKey = lngCurIdx - 1 
End Function 
 
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String 
Dim lResult As Long 
Dim lValueType As Long 
Dim strBuf As String 
Dim lDataBufSize As Long 
Dim ERROR_SUCCESS 
  On Error GoTo 0 
  lResult = RegQueryValueEx(hKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufSize) 
  If lResult = ERROR_SUCCESS Then 
    If lValueType = REG_SZ Then 
      strBuf = String(lDataBufSize, " ") 
      lResult = RegQueryValueEx(hKey, strValueName, 0&, 0&, ByVal strBuf, lDataBufSize) 
      If lResult = ERROR_SUCCESS Then 
        RegQueryStringValue = strBuf 
      End If 
    End If 
  End If 
End Function 
 
Sub LoadKeys() 
  hKeys(1).Class = HKEY_LOCAL_MACHINE 
  hKeys(1).Key = "Software\Microsoft\Windows\CurrentVersion\Run" 
  hKeys(1).Name = "Machine Run" 
  hKeys(2).Class = HKEY_LOCAL_MACHINE 
  hKeys(2).Key = "Software\Microsoft\Windows\CurrentVersion\RunOnce" 
  hKeys(2).Name = "Machine RunOnce" 
  hKeys(3).Class = HKEY_LOCAL_MACHINE 
  hKeys(3).Key = "Software\Microsoft\Windows\CurrentVersion\RunOnceEx" 
  hKeys(3).Name = "Machine RunOnceEx" 
  hKeys(4).Class = HKEY_LOCAL_MACHINE 
  hKeys(4).Key = "Software\Microsoft\Windows\CurrentVersion\RunServices" 
  hKeys(4).Name = "Machine RunServices" 
  hKeys(5).Class = HKEY_LOCAL_MACHINE 
  hKeys(5).Key = "Software\Microsoft\Windows\CurrentVersion\RunServicesOnce" 
  hKeys(5).Name = "Machine RunServicesOnce" 
  hKeys(6).Class = HKEY_CURRENT_USER 
  hKeys(6).Key = "Software\Microsoft\Windows\CurrentVersion\Run" 
  hKeys(6).Name = "Per User Run" 
  hKeys(7).Class = HKEY_CURRENT_USER 
  hKeys(7).Key = "Software\Microsoft\Windows\CurrentVersion\RunOnce" 
  hKeys(7).Name = "Per User RunOnce" 
  hKeys(8).Class = HKEY_CURRENT_USER 
  hKeys(8).Key = "Software\Microsoft\Windows\CurrentVersion\RunServices" 
  hKeys(8).Name = "Per User RunServices" 
  hKeys(9).Class = HKEY_CURRENT_USER 
  hKeys(9).Key = "Software\Mirabilis\ICQ\Agent\Apps;Path" 
  hKeys(9).Name = "ICQ AutoStart" 
End Sub