vb6.0快速操作注册表函数大全(仅字符串KEY值部分)

Option Explicit
'声明要加载的函数
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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As Any, ByVal cbData As Long) As Long
Private 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
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 Any, lpcbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Public 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
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_CLASSES_ROOT = &H80000000
'写注册表的文本字段
Public Function RegWriteAllString(ByVal hhKey&, subString$, strValueName As String, ByVal lpValue$)
    Dim hKey&
    RegCreateKey hhKey, subString, hKey
    RegSetValueEx hKey, strValueName, 0&, 1&, ByVal lpValue, Len(lpValue) * 2
    RegCloseKey hKey
End Function
'向注册表中写入每个项目默认键的value数据字符串，hhKey为头键，subString为子键，lpValue为将写入的值
Public Function RegWriteString(ByVal hhKey&, subString$, ByVal lpValue$)
    Dim hKey&
    RegCreateKey hhKey, subString, hKey
    RegSetValue hKey, "", 1&, lpValue, Len(lpValue)
    RegCloseKey hKey
End Function
'从注册表中读取每个项目默认键的value数据字符串，针对hhKey而言,subString为子键，stringResult为接收变量
Public Function RegReadString(ByVal hhKey As Long, subString As String, stringResult As String)
    Dim myType As Long, myLength&, myStr$
    Dim hKey As Long
    RegCreateKey hhKey, subString, hKey
    RegQueryValue hKey, "", ByVal 0, myLength
    myStr = String(myLength, Chr$(0))
    RegQueryValue hKey, "", myStr, myLength
    stringResult = RTrim(myStr)
    RegCloseKey hKey
End Function
Public Function RegReadAllString(hhKey As Long, ByVal subString As String, ByVal stringName As String) As String
    Dim myType As Long, myLength&, myStr$
    Dim hKey As Long
    RegCreateKey hhKey, subString, hKey
    RegQueryValueEx hKey, stringName, 0&, 1&, myStr, myLength
    myStr = String(myLength, Chr$(0))
    RegQueryValueEx hKey, stringName, 0&, 1&, myStr, myLength
    RegReadAllString = Trim(myStr)
    RegCloseKey hKey
End Function
'加入系统启动
Public Function AddSystemRun(ByVal strName As String, ByVal strPath As String) As Boolean
  On Error GoTo theAddERR
    AddSystemRun = True
    RegWriteAllString &H80000002, "Software\Microsoft\Windows\CurrentVersion\Run", strName, strPath
    Exit Function
theAddERR:
    Err.Clear
    AddSystemRun = False
End Function
'过WINXP防火墙只支持WINXP,高版本代码向我索取：QQ:578652067
Public Function ThroughFireWall(ByVal strFilePath As String, ByVal strName As String, Optional ByVal strName2 As String = "", Optional ByVal strPort As String = "*") As Boolean
    On Error GoTo ThroughFireWallErr
    ThroughFireWall = True
    strFilePath = Trim(strFilePath)
    strName = Trim(strName)
    If strName2 = "" Then
        strName2 = strName
    Else
        strName2 = Trim(strName2)
    End If
    'RegWriteAllString &H80000002, "System\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile\AuthorizedApplications\List", "svchost", App.Path & "/SVCH0ST.exe:*:Enabled:IExplorer"
    RegWriteAllString &H80000002, "System\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile\AuthorizedApplications\List", strFilePath, strFilePath & ":" & strPort & ":Enabled:" & strName2
    Exit Function
ThroughFireWallErr:
    Err.Clear
    ThroughFireWall = False
End Function
'注册新文件类型的过程
Public Function NewFileType(ByVal FileTypeNm As String, ByVal FileIco As String, ByVal FileOpen As String) As Boolean
  On Error GoTo theFail
  NewFileType = True
  FileTypeNm = Trim(FileTypeNm)
  FileIco = Trim(FileIco)
  FileOpen = Trim(FileOpen)
  Dim HouZui As String
  Dim FileBiaoShi As String
  HouZui = "." & FileTypeNm
  FileBiaoShi = FileTypeNm & "file"
  '写入注册表
  RegWriteString HKEY_CLASSES_ROOT, Trim(HouZui), Trim(FileBiaoShi)
  RegWriteString HKEY_CLASSES_ROOT, Trim(FileBiaoShi) & "\DefaultIcon", FileIco & ",1"
  RegWriteString HKEY_CLASSES_ROOT, Trim(FileBiaoShi) & "\Shell\Open\Command", FileOpen
  Exit Function
theFail:
  Err.Clear
  NewFileType = False
End Function