www.pudn.com > SuperDLL2.zip > Shared.bas

Attribute VB_Name = "Shared" 
Option Explicit 
 
Public Type POINTAPI 
    X As Long 
    Y As Long 
End Type 
 
Private Type SHITEMID 
    cb As Long 
    abID As Byte 
End Type 
 
Public Type ITEMIDLIST 
    mkid As SHITEMID 
End Type 
 
Public Const MAX_PATH = 260 
 
Private Const ERROR_SUCCESS = 0& 
Private Const REG_SZ = 1& 
Private Const REG_EXPAND_SZ = 2& 
Private Const REG_BINARY = 3& 
Private Const REG_DWORD = 4& 
Private Const REG_MULTI_SZ = 7& 
Private Const KEY_QUERY_VALUE = &H1& 
Private Const KEY_SET_VALUE = &H2& 
Private Const KEY_CREATE_SUB_KEY = &H4& 
Private Const KEY_ENUMERATE_SUB_KEYS = &H8& 
Private Const KEY_NOTIFY = &H10& 
Private Const KEY_CREATE_LINK = &H20& 
Private Const SYNCHRONIZE = &H100000 
Private Const STANDARD_RIGHTS_READ = &H20000 
Private Const STANDARD_RIGHTS_WRITE = &H20000 
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY 
Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY 
Private Const STANDARD_RIGHTS_ALL = &H1F0000 
 
Public Const zFormOrPictBoxStr As String = "Must pass in the name of either a Form or a PictureBox." 
Public Const zNumericStr As String = "Must pass in a numeric value." 
 
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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long 
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long 
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long 
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long 
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 
 
Public Function AppPath2(ByVal zPathPtr As String) As String 
  Dim zPath As String 
  zPath = Trim3(zPathPtr) 
  If Right$(zPath, 1) = "\" Then AppPath2 = zPath Else AppPath2 = zPath & "\" 
End Function 
 
Public Function FExist(ByVal strPath As String) As Boolean 
  On Local Error GoTo ErrFile 
  Open strPath For Input Access Read As #1 
  Close #1 
  FExist = True 
  Exit Function 
ErrFile: 
  FExist = False 
End Function 
 
Public Function Trim3(ByVal cString As String) As String 
  Dim t As Long, Z As Long 
  For t = 1 To Len(cString) 
    If Mid$(cString, t, 1) <> " " And Mid$(cString, t, 1) <> Chr$(0) Then Exit For 
  Next t 
  For Z = Len(cString) To 1 Step -1 
    If Mid$(cString, Z, 1) <> " " And Mid$(cString, Z, 1) <> Chr$(0) Then Exit For 
  Next Z 
  If Z < t Then 
    Trim3 = "" 
  ElseIf Z = t Then 
    Trim3 = Mid$(cString, t, 1) 
  Else 
    Trim3 = Mid$(cString, t, (Z - t) + 1) 
  End If 
End Function 
 
Private Function GetErrorMsg3(ByVal lErrorCode As Long) As String 
Select Case lErrorCode 
       Case 1, 1009, 1015 
            GetErrorMsg3 = "The Registry Database is corrupt!" 
       Case 2, 6, 1010 
            GetErrorMsg3 = "Bad Key Name" 
       Case 3, 1011 
            GetErrorMsg3 = "Can't Open Key" 
       Case 4, 1012 
            GetErrorMsg3 = "Can't Read Key" 
       Case 5, 1013 
            GetErrorMsg3 = "Can't Write Key" 
       Case 8 
            GetErrorMsg3 = "Access to this key is denied" 
       Case 14 
            GetErrorMsg3 = "Out of memory" 
       Case 7, 87 
            GetErrorMsg3 = "Invalid Parameter" 
       Case 234 
            GetErrorMsg3 = "There is more data than the buffer has been allocated to hold." 
       Case 259 
            GetErrorMsg3 = "No More Items" 
       Case Else 
            GetErrorMsg3 = "Undefined Error Code: " & Str$(lErrorCode) 
End Select 
End Function 
 
Private Function QueryValueEx2(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long 
  On Local Error GoTo QueryValueExExit 
  Dim rtn As Long 
  Dim cch As Long 
  Dim lType As Long 
  Dim lValue As Long 
  Dim sValue As String 
  Dim qwe() As String 
  Dim qaz() As String 
  Dim t As Long 
  rtn = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch) 
  If rtn <> ERROR_SUCCESS Then MsgBox GetErrorMsg3(rtn), vbExclamation, "SuperDLL - QueryValueEx2" 
  Select Case lType 
    Case REG_SZ, REG_EXPAND_SZ: 
        sValue = String(cch, 0) 
        rtn = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch) 
        If rtn = ERROR_SUCCESS Then 
          vValue = Left$(sValue, cch - 1) 
        Else 
          vValue = "ERROR" 
        End If 
    Case REG_DWORD: 
        rtn = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch) 
        If rtn = ERROR_SUCCESS Then 
          vValue = lValue 
        Else 
          vValue = "ERROR" 
        End If 
    Case REG_BINARY: 
        sValue = String(cch, 0) 
        rtn = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch) 
        If rtn = ERROR_SUCCESS Then 
          vValue = Left$(sValue, cch) 
        Else 
          vValue = "ERROR" 
        End If 
    Case REG_MULTI_SZ: 
        sValue = String(cch, 0) 
        rtn = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch) 
        If rtn = ERROR_SUCCESS Then 
          qwe = Split(Left$(sValue, cch), Chr$(0)) 
          ReDim qaz(0 To (UBound(qwe) - 2)) 
          For t = 0 To UBound(qaz) 
            qaz(t) = qwe(t) 
          Next t 
          vValue = qaz 
        Else 
          vValue = "ERROR" 
        End If 
    Case Else 
        rtn = -1 
        vValue = "ERROR" 
  End Select 
QueryValueExExit: 
  QueryValueEx2 = rtn 
End Function 
 
Public Function QueryValue2(ByVal sKeyName As String, ByVal sValueName As String) As Variant 
  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)) 
  Dim lPredefinedKey As Long 
  Dim lRetVal As Long 
  Dim hKey As Long 
  Dim vValue As Variant 
  lPredefinedKey = &H80000002 
  lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey) 
  lRetVal = QueryValueEx2(hKey, sValueName, vValue) 
  QueryValue2 = vValue 
  RegCloseKey (hKey) 
End Function 
 
Public Function KeyValueExist3(ByVal sKey As String, ByVal sKeyName As String) As Boolean 
    Dim rtn As Long 
    Dim hKey As Long 
    Dim MainKeyHandle As Long 
    Dim lActualType As Long 
    Dim lSize As Long 
    Dim sTmp As String 
    MainKeyHandle = &H80000002 
    rtn = RegOpenKeyEx(MainKeyHandle, sKey, 0, KEY_READ, hKey) 'open the key 
    If (rtn = ERROR_SUCCESS) Then 
      rtn = RegQueryValueEx(hKey, ByVal sKeyName, 0&, lActualType, sTmp, lSize) 'ByVal 0&, lSize) 
      If (rtn = ERROR_SUCCESS) Then 
        KeyValueExist3 = True 
      Else 
        KeyValueExist3 = False 
      End If 
    End If 
End Function