本程序实现了ring3下的注册表监管工作.由VB+VC实现.功能和瑞星的注册表监视非常类似。
目前只监视了启动项.
VC DLL下载地址是:https://p-blog.csdn.net/images/p_blog_csdn_net/chenhui530/RegistryInfo.bmp
代码先公布VB部分源码,等整理后再给出VC部分的源码:
frmRegMonitor.frm
VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "comctl32.ocx"
Begin VB.Form frmRegMonitor
Caption = "注册表监视"
ClientHeight = 3585
ClientLeft = 60
ClientTop = 345
ClientWidth = 5835
ControlBox = 0 'False
LinkTopic = "Form1"
LockControls = -1 'True
ScaleHeight = 3585
ScaleWidth = 5835
StartUpPosition = 2 '屏幕中心
Begin VB.CheckBox chkAllow
Caption = "不再提示，以后都这样处理"
Height = 255
Left = 3320
TabIndex = 11
Top = 2400
Width = 2535
End
Begin VB.Timer timerCheck
Enabled = 0 'False
Interval = 1000
Left = 2880
Top = 600
End
Begin ComctlLib.ProgressBar proBar
Height = 255
Left = 120
TabIndex = 10
Top = 3240
Width = 5655
_ExtentX = 9975
_ExtentY = 450
_Version = 327682
Appearance = 1
Max = 30
End
Begin VB.OptionButton optDisaccord
Caption = "不同意修改"
Height = 255
Left = 1680
TabIndex = 4
Top = 2400
Width = 1335
End
Begin VB.OptionButton optAgree
Caption = "同意修改"
Height = 255
Left = 160
TabIndex = 3
Top = 2400
Value = -1 'True
Width = 1335
End
Begin VB.Frame frameReg
Caption = "注册表监视"
Height = 2245
Left = 120
TabIndex = 6
Top = 60
Width = 5625
Begin VB.TextBox txtProcessPath
Height = 270
Left = 1320
TabIndex = 2
Top = 1760
Width = 4095
End
Begin VB.TextBox txtType
Height = 270
Left = 1320
TabIndex = 1
Top = 1290
Width = 4095
End
Begin VB.TextBox txtRegPath
Height = 775
Left = 1320
MultiLine = -1 'True
TabIndex = 0
Top = 300
Width = 4095
End
Begin VB.Label lblProcessPath
AutoSize = -1 'True
Caption = "进程信息:"
Height = 180
Left = 240
TabIndex = 9
Top = 1800
Width = 810
End
Begin VB.Label lType
AutoSize = -1 'True
Caption = "键值/类型:"
Height = 180
Left = 240
TabIndex = 8
Top = 1320
Width = 900
End
Begin VB.Label lPath
AutoSize = -1 'True
Caption = "注册表路径:"
Height = 180
Left = 240
TabIndex = 7
Top = 360
Width = 990
End
End
Begin VB.CommandButton cmdOK
Cancel = -1 'True
Caption = "确定(&O)"
Default = -1 'True
Height = 375
Left = 4740
TabIndex = 5
Top = 2760
Width = 975
End
Begin VB.Menu mnuPopMenu
Caption = ""
Visible = 0 'False
Begin VB.Menu mnuExit
Caption = "退出程序"
End
End
End
Attribute VB_Name = "frmRegMonitor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function InstallRegHook Lib "RegistryInfo.dll" (ByVal strCheck As String) As Long
Private Declare Function UninstallRegHook Lib "RegistryInfo.dll" () As Long
Private 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 Sub InitCommonControls Lib "comctl32.dll" ()
Private Const HWND_TOPMOST = -1
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private mintSum As Integer
Private Sub cmdOK_Click()
timerCheck.Enabled = False '停止记时
mintSum = 0 '计数归0
Me.proBar.Value = 0 '进度条进度归0
gblnIsShow = False '设置不显示窗体标志状态
Me.Hide '隐藏窗体
End Sub
Private Sub Form_Initialize()
If App.PrevInstance Then End '重复加载就直接退出
InitCommonControls
End Sub
Private Sub Form_Load()
strIniFilePath = App.Path & "/Config.ini" '设置设置文件路径
Me.Hide '隐藏主窗体
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE '最前端显示
StartHook Me.hwnd '消息钩子主要是获取DLL传来的消息 ,消息名是WM_COPYDATA
SendToTray '添加托盘图标
InstallRegHook "http://blog.csdn.net/chenhui530/" '安装全局API钩子
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Not gblnIsEnd Then
Cancel = 1 '如果不是真的退出就不准卸载窗体
Exit Sub
End If
gblnIsShow = False '不显示窗体，防止在退出的时候还有几个消息没显示，这样的话会再次加载主窗体对象这样当次退出就无效了
DeleteSysTray '删除托盘
Unhook Me.hwnd '卸载消息钩子
UninstallRegHook '卸载API钩子
Unload Me '退出程序
End Sub
Private Sub mnuExit_Click()
Erase gstrArray '清空消息
gblnIsEnd = True '确定退出状态
cmdOK_Click '使本次生效并且关闭记时器控件等
Unload Me '卸载窗体准备退出
End Sub
Private Sub timerCheck_Timer()
If mintSum >= 30 Then '当等于30秒时就隐藏界面
timerCheck.Enabled = False
mintSum = 0
gblnIsShow = False
Me.Hide
End If
mintSum = mintSum + 1 '增加计数当大于等于30时隐藏界面
Me.proBar.Value = mintSum '显示进度
End Sub
Private Sub txtProcessPath_KeyPress(KeyAscii As Integer)
KeyAscii = 0 '不允许输入
End Sub
Private Sub txtRegPath_KeyPress(KeyAscii As Integer)
KeyAscii = 0 '不允许输入
End Sub
Private Sub txtType_KeyPress(KeyAscii As Integer)
KeyAscii = 0 '不允许输入
End Sub
modControls.bas
Attribute VB_Name = "modControls"
Option Explicit
'获取注册表子路径
Public Function GetRegistrySubPath(ByVal strRegPath As String) As String
Dim strTmp As String, blnIsMachine As Boolean, intStart As Integer
If InStr(strRegPath, "/REGISTRY/MACHINE") > 0 Then blnIsMachine = True
intStart = InStr(strRegPath, "*value:")
If intStart > 0 Then
If blnIsMachine Then
strTmp = Mid(strRegPath, Len("/REGISTRY/MACHINE") + 2, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = Mid(strRegPath, Len("/REGISTRY/USER") + 2, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetPath(strTmp)
GetRegistrySubPath = Left(strTmp, Len(strTmp) - 1)
Exit Function
Else
intStart = InStr(strRegPath, "**")
If intStart > 0 Then
If blnIsMachine Then
strTmp = Mid(strRegPath, Len("/REGISTRY/MACHINE") + 2, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = Mid(strRegPath, Len("/REGISTRY/USER") + 2, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetPath(strTmp)
GetRegistrySubPath = Left(strTmp, Len(strTmp) - 1)
Exit Function
End If
intStart = InStr(strRegPath, "^^")
If intStart > 0 Then
If blnIsMachine Then
strTmp = Mid(strRegPath, Len("/REGISTRY/MACHINE") + 2, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = Mid(strRegPath, Len("/REGISTRY/USER") + 2, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetPath(strTmp)
GetRegistrySubPath = Left(strTmp, Len(strTmp) - 1)
Exit Function
End If
End If
End Function
'获取注册表的keyRoot
Public Function GetRoot(ByVal strRegPath As String) As keyRoot
If InStr(UCase(strRegPath), "/REGISTRY/MACHINE") > 0 Then
GetRoot = HKEY_LOCAL_MACHINE
ElseIf InStr(UCase(strRegPath), "/REGISTRY/USER") > 0 Then
GetRoot = HKEY_USERS
End If
End Function
'获取keyRoot对应的字符串
Public Function GetRootString(ByVal strRegPath As String) As String
If InStr(UCase(strRegPath), "/REGISTRY/MACHINE") > 0 Then
GetRootString = "HKEY_LOCAL_MACHINE"
ElseIf InStr(UCase(strRegPath), "/REGISTRY/USER") > 0 Then
GetRootString = "HKEY_USERS"
End If
End Function
'获取注册表路径，因为从DLL传来的是以REGISTRY开始的
Public Function GetRegistryPath(ByVal strRegPath As String) As String
Dim strTmp As String, blnIsMachine As Boolean, intStart As Integer
strTmp = GetRootString(strRegPath)
If InStr(strRegPath, "/REGISTRY/MACHINE") > 0 Then blnIsMachine = True
intStart = InStr(strRegPath, "*value:")
If intStart > 0 Then
If blnIsMachine Then
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/MACHINE") + 1, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/USER") + 1, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetPath(strTmp)
GetRegistryPath = Left(strTmp, Len(strTmp) - 1)
Exit Function
Else
intStart = InStr(strRegPath, "**")
If intStart > 0 Then
If blnIsMachine Then
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/MACHINE") + 1, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/USER") + 1, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetPath(strTmp)
GetRegistryPath = Left(strTmp, Len(strTmp) - 1)
Exit Function
End If
intStart = InStr(strRegPath, "^^")
If intStart > 0 Then
If blnIsMachine Then
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/MACHINE") + 1, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/USER") + 1, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetPath(strTmp)
GetRegistryPath = Left(strTmp, Len(strTmp) - 1)
Exit Function
End If
End If
End Function
'获取DLL传来的完整信息
Public Function GetFullPath(ByVal strPath As String)
Dim strTmp As String, intStart As Integer
intStart = InStr(strPath, ":")
If intStart > 0 Then
strTmp = Mid(strPath, intStart + 1, Len(strPath) - intStart)
End If
GetFullPath = strTmp
End Function
'获取注册表键名
Public Function GetRegValueName(ByVal strRegPath As String) As String
Dim strTmp As String, blnIsMachine As Boolean, intStart As Integer
strTmp = GetRootString(strRegPath)
If InStr(strRegPath, "/REGISTRY/MACHINE") > 0 Then blnIsMachine = True
intStart = InStr(strRegPath, "*value:")
If intStart > 0 Then
If blnIsMachine Then
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/MACHINE") + 1, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/USER") + 1, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetFileName(strTmp)
GetRegValueName = strTmp
Exit Function
Else
intStart = InStr(strRegPath, "**")
If intStart > 0 Then
If blnIsMachine Then
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/MACHINE") + 1, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/USER") + 1, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetFileName(strTmp)
GetRegValueName = strTmp
Exit Function
End If
intStart = InStr(strRegPath, "^^")
If intStart > 0 Then
If blnIsMachine Then
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/MACHINE") + 1, intStart - Len("/REGISTRY/MACHINE") - 1)
Else
strTmp = strTmp & Mid(strRegPath, Len("/REGISTRY/USER") + 1, intStart - Len("/REGISTRY/USER") - 1)
End If
strTmp = GetFileName(strTmp)
GetRegValueName = strTmp
Exit Function
End If
End If
End Function
'获取注册表键值
Public Function GetRegValue(ByVal strRegPath As String) As String
Dim strTmp As String, intStart As Integer, intStart1 As Integer
intStart = InStr(strRegPath, "*value:")
If intStart > 0 Then
intStart1 = InStr(strRegPath, "**")
If intStart1 > 0 Then
strTmp = Mid(strRegPath, intStart + Len("*value:"), intStart1 - intStart - Len("*value:"))
GetRegValue = strTmp
Else
intStart1 = InStr(strRegPath, "^^")
If intStart1 > 0 Then
strTmp = Mid(strRegPath, intStart + Len("*value:"), intStart1 - intStart - Len("*value:"))
GetRegValue = strTmp
Else
GetRegValue = ""
End If
End If
Else
GetRegValue = ""
End If
End Function
'获取操作类型
Public Function GetRegistryType(ByVal strRegPath As String) As String
Dim strTmp As String, intStart As Integer, intStart1 As Integer
intStart = InStr(strRegPath, "**")
If intStart > 0 Then
intStart1 = InStr(strRegPath, "^^")
If intStart1 > 0 Then
strTmp = Mid(strRegPath, intStart + Len("**"), intStart1 - intStart - Len("**"))
GetRegistryType = strTmp
Else
GetRegistryType = ""
End If
Else
GetRegistryType = ""
End If
GetRegistryType = GetRegType(GetRegistryType)
End Function
'把注册表类型的字符串类型转换成ValueType
Public Function GetRegType(ByVal strRegType As String) As ValueType
Select Case strRegType
Case "1"
GetRegType = REG_SZ
Case "2"
GetRegType = REG_EXPAND_SZ
Case "3"
GetRegType = REG_BINARY
Case "4"
GetRegType = REG_DWORD
Case "7"
GetRegType = REG_MULTI_SZ
Case Else
GetRegType = REG_SZ
End Select
End Function
'注册表类型的字符串型转换成LONG型
Public Function GetRegTypeLng(ByVal strRegType As String) As ValueType
Select Case strRegType
Case "1"
GetRegTypeLng = 1
Case "2"
GetRegTypeLng = 2
Case "3"
GetRegTypeLng = 3
Case "4"
GetRegTypeLng = 4
Case "7"
GetRegTypeLng = 7
Case Else
GetRegTypeLng = 1
End Select
End Function
'获取指定注册表类型对应的类型
Public Function GetRegTypeString(ByVal strRegType As String) As String
Select Case strRegType
Case "1"
GetRegTypeString = "REG_SZ"
Case "2"
GetRegTypeString = "REG_EXPAND_SZ"
Case "3"
GetRegTypeString = "REG_BINARY"
Case "4"
GetRegTypeString = "REG_DWORD"
Case "7"
GetRegTypeString = "REG_MULTI_SZ"
Case Else
GetRegTypeString = "REG_SZ"
End Select
End Function
'获取进程路径信息包括没分离的PID信息
Public Function GetRegProcessPath(ByVal strRegPath As String) As String
Dim strTmp As String, intStart As Integer
intStart = InStr(strRegPath, "^^")
If intStart > 0 Then
strTmp = Mid(strRegPath, intStart + 2, Len(strRegPath) - intStart)
End If
GetRegProcessPath = strTmp
End Function
'获取进程路径信息
Public Function GetRegProcessPathEx(ByVal strRegPath As String) As String
Dim strTmp As String, intStart As Integer
intStart = InStr(strRegPath, "^^")
If intStart > 0 Then
strTmp = Mid(strRegPath, intStart + 2, InStr(strRegPath, "进程ID<") - 2 - intStart)
End If
GetRegProcessPathEx = strTmp
End Function
'此函数从字符串中分离出路径
Public Function GetPath(ByVal strPathIn As String) As String
Dim i As Integer
For i = Len(strPathIn) To 1 Step -1
If InStr(":/", Mid$(strPathIn, i, 1)) Then Exit For
Next
GetPath = Left$(strPathIn, i)
End Function
'此函数从字符串中分离出文件名
Public Function GetFileName(ByVal strFileIn As String) As String
Dim i As Integer
For i = Len(strFileIn) To 1 Step -1
If InStr("/", Mid$(strFileIn, i, 1)) Then Exit For
Next
GetFileName = Mid$(strFileIn, i + 1, Len(strFileIn) - i)
End Function
modIni.bas
Attribute VB_Name = "modIni"
Option Explicit
'''''''''''''''''''''''''
'读写INI文件模块
'''''''''''''''''''''''''
Private Declare Function GetPrivateProfileSection Lib "KERNEL32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, lpString As Any, ByVal lpFileName As String) As Long
Public strIniFilePath As String '设置文件路径
'读取指定节点下对应名称的值
Public Function GetiniValue(ByVal lpKeyName As String, ByVal strName As String, ByVal strIniFile As String) As String
Dim strTmp As String * 32767
Call GetPrivateProfileString(lpKeyName, strName, "", strTmp, Len(strTmp), strIniFile)
GetiniValue = Left$(strTmp, InStr(strTmp, vbNullChar) - 1)
End Function
'给指定节点下对名称赋值
Public Function WriteIniStr(ByVal strSection As String, ByVal strKey As String, ByVal strData As String, ByVal strIniFile As String) As Boolean
On Error GoTo WriteIniStrErr
WriteIniStr = True
If strData = "0" Then
WritePrivateProfileString strSection, strKey, ByVal 0, strIniFile
Else
WritePrivateProfileString strSection, strKey, ByVal strData, strIniFile
End If
Exit Function
WriteIniStrErr:
err.Clear
WriteIniStr = False
End Function
'获取指定节电下的最大索引
Public Function GetMaxIndex(ByVal strSection As String, strIniFile As String) As String
Dim strReturn As String * 32767
Dim strTmp As String
Dim lngReturn As Integer, i As Integer, strTmpArray() As String, sum As Integer
lngReturn = GetPrivateProfileSection(strSection, strReturn, Len(strReturn), strIniFile)
strTmp = Left(strReturn, lngReturn)
strTmpArray = Split(strTmp, Chr(0))
For i = 0 To UBound(strTmpArray)
If strTmpArray(i) <> "" And strTmpArray(i) <> Chr(0) Then
strTmp = Left(strTmpArray(i), InStr(strTmpArray(i), "=") - 1)
If Val(strTmp) > sum Then sum = Val(strTmp)
End If
Next
GetMaxIndex = sum + 1
End Function
'判断数据是否已经添加过了
Public Function IsIniDataExist(ByVal strSection As String, ByVal strData As String, ByVal strIniFile As String) As String
Dim strReturn As String * 32767
Dim strTmp As String
Dim lngReturn As Integer, i As Integer, strTmpArray() As String, sum As Integer
lngReturn = GetPrivateProfileSection(strSection, strReturn, Len(strReturn), strIniFile)
strTmp = Left(strReturn, lngReturn)
strTmpArray = Split(strTmp, Chr(0))
For i = 0 To UBound(strTmpArray)
If strTmpArray(i) <> "" And strTmpArray(i) <> Chr(0) Then
strTmp = Trim(Mid(strTmpArray(i), InStr(strTmpArray(i), "=") + 1, Len(strTmpArray(i)) - InStr(strTmpArray(i), "=")))
If strTmp <> "" Then
If LCase(strTmp) = LCase(strData) Then
IsIniDataExist = Left(strTmpArray(i), InStr(strTmpArray(i), "=") - 1)
Exit Function
End If
End If
End If
Next
End Function
modRegistry.bas
Attribute VB_Name = "modRegistry"
Option Explicit
'---------------------------------------------------------------
'- 注册表 API 声明...
'---------------------------------------------------------------
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition 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
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, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) 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, lpData As Any, ByVal cbData As Long) As Long
Private 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 FILETIME) 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, lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
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 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 AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPriv As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long 'Used to adjust your program's security privileges, can't restore without it!
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, ByVal lpName As String, lpLuid As LUID) As Long 'Returns a valid LUID which is important when making security changes in NT.
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
'---------------------------------------------------------------
'- 注册表 Api 常数...
'---------------------------------------------------------------
' 注册表创建类型值...
Const REG_OPTION_NON_VOLATILE = 0 ' 当系统重新启动时，关键字被保留
' 注册表关键字安全选项...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' 返回值...
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0
' 有关导入/导出的常量
Const REG_FORCE_RESTORE As Long = 8&
Const TOKEN_QUERY As Long = &H8&
Const TOKEN_ADJUST_PRIVILEGES As Long = &H20&
Const SE_PRIVILEGE_ENABLED As Long = &H2
Const SE_RESTORE_NAME = "SeRestorePrivilege"
Const SE_BACKUP_NAME = "SeBackupPrivilege"
'---------------------------------------------------------------
'- 注册表类型...
'---------------------------------------------------------------
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type LUID
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges As LUID_AND_ATTRIBUTES
End Type
'---------------------------------------------------------------
'- 自定义枚举类型...
'---------------------------------------------------------------
' 注册表数据类型...
Public Enum ValueType
REG_SZ = 1 ' 字符串值
REG_EXPAND_SZ = 2 ' 可扩充字符串值
REG_BINARY = 3 ' 二进制值
REG_DWORD = 4 ' DWORD值
REG_MULTI_SZ = 7 ' 多字符串值
End Enum
' 注册表关键字根类型...
Public Enum keyRoot
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
Public strstring As String
Private hKey As Long ' 注册表打开项的句柄
Private i As Long, j As Long ' 循环变量
Private Success As Long ' API函数的返回值, 判断函数调用是否成功
'-------------------------------------------------------------------------------------------------------------
'- 新建注册表关键字并设置注册表关键字的值...
'- 如果 ValueName 和 Value 都缺省, 则只新建 KeyName 空项, 无子键...
'- 如果只缺省 ValueName 则将设置指定 KeyName 的默认值
'- 参数说明: KeyRoot--根类型, KeyName--子项名称, ValueName--值项名称, Value--值项数据, ValueType--值项类型
'-------------------------------------------------------------------------------------------------------------
Public Function SetKeyValue(keyRoot As keyRoot, KeyName As String, Optional ValueName As String, Optional Value As Variant = "", Optional ValueType As ValueType = REG_SZ) As Boolean
Dim lpAttr As SECURITY_ATTRIBUTES ' 注册表安全类型
lpAttr.nLength = 50 ' 设置安全属性为缺省值...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
' 新建注册表关键字...
Success = RegCreateKeyEx(keyRoot, KeyName, 0, ValueType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, hKey, 0)
If Success <> ERROR_SUCCESS Then SetKeyValue = False: RegCloseKey hKey: Exit Function
' 设置注册表关键字的值...
If IsMissing(ValueName) = False Then
Select Case ValueType
Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
Success = RegSetValueEx(hKey, ValueName, 0, ValueType, ByVal CStr(Value), LenB(StrConv(Value, vbFromUnicode)) + 1)
Case REG_DWORD
If CDbl(Value) <= 4294967295# And CDbl(Value) >= 0 Then
Dim sValue As String
sValue = DoubleToHex(Value)
Dim dValue(3) As Byte
dValue(0) = Format("&h" & Mid(sValue, 7, 2))
dValue(1) = Format("&h" & Mid(sValue, 5, 2))
dValue(2) = Format("&h" & Mid(sValue, 3, 2))
dValue(3) = Format("&h" & Mid(sValue, 1, 2))
Success = RegSetValueEx(hKey, ValueName, 0, ValueType, dValue(0), 4)
Else
Success = ERROR_BADKEY
End If
Case REG_BINARY
On Error Resume Next
Success = 1 ' 假设调用API不成功(成功返回0)
ReDim tmpValue(UBound(Value)) As Byte
For i = 0 To UBound(tmpValue)
tmpValue(i) = Value(i)
Next i
Success = RegSetValueEx(hKey, ValueName, 0, ValueType, tmpValue(0), UBound(Value) + 1)
End Select
End If
If Success <> ERROR_SUCCESS Then SetKeyValue = False: RegCloseKey hKey: Exit Function
' 关闭注册表关键字...
RegCloseKey hKey
SetKeyValue = True ' 返回函数值
End Function
'-------------------------------------------------------------------------------------------------------------
'- 获得已存在的注册表关键字的值...
'- 如果 ValueName="" 则返回 KeyName 项的默认值...
'- 如果指定的注册表关键字不存在, 则返回空串...
'- 参数说明: KeyRoot--根类型, KeyName--子项名称, ValueName--值项名称, ValueType--值项类型
'-------------------------------------------------------------------------------------------------------------
Public Function GetKeyValue(ByVal keyRoot As keyRoot, ByVal KeyName As String, ByVal ValueName As String, Optional ByVal ValueType As Long) As String
Dim TempValue As String ' 注册表关键字的临时值
Dim Value As String ' 注册表关键字的值
Dim ValueSize As Long ' 注册表关键字的值的实际长度
TempValue = Space(1024) ' 存储注册表关键字的临时值的缓冲区
ValueSize = 1024 ' 设置注册表关键字的值的默认长度
' 打开一个已存在的注册表关键字...
RegOpenKeyEx keyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey
If hKey = 0 Then
GetKeyValue = "^_*_*_^"
Exit Function
End If
Dim x As Integer
x = RegQueryValueEx(hKey, ValueName, 0, ValueType, ByVal TempValue, ValueSize)
' 获得已打开的注册表关键字的值...
If x <> 0 Then
If x = 2 And ValueSize = 1024 Then
GetKeyValue = "^_*_*_^"
Exit Function
End If
End If
' 返回注册表关键字的的值...
Select Case ValueType ' 通过判断关键字的类型, 进行处理
Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
If ValueSize > 0 Then TempValue = Left$(TempValue, ValueSize - 1) ' 去掉TempValue尾部空格
Value = TempValue
Case REG_DWORD
ReDim dValue(3) As Byte
RegQueryValueEx hKey, ValueName, 0, REG_DWORD, dValue(0), ValueSize
For i = 3 To 0 Step -1
Value = Value + String(2 - Len(Hex(dValue(i))), "0") + Hex(dValue(i)) ' 生成长度为8的十六进制字符串
Next i
If CDbl("&H" & Value) < 0 Then ' 将十六进制的 Value 转换为十进制
Value = 2 ^ 32 + CDbl("&H" & Value)
Else
Value = CDbl("&H" & Value)
End If
Case REG_BINARY
If ValueSize > 0 Then
ReDim bValue(ValueSize - 1) As Byte ' 存储 REG_BINARY 值的临时数组
RegQueryValueEx hKey, ValueName, 0, REG_BINARY, bValue(0), ValueSize
For i = 0 To ValueSize - 1
Value = Value + String(2 - Len(Hex(bValue(i))), "0") + Hex(bValue(i)) + " " ' 将数组转换成字符串
Next i
End If
End Select
' 关闭注册表关键字...
RegCloseKey hKey
Value = Trim(Value)
If InStr(Value, Chr(0)) Then
GetKeyValue = Left(Value, InStr(Value, Chr(0)) - 1) ' 返回函数值
Else
GetKeyValue = Value
End If
End Function
Public Function RegDeleteKeyName(mhKey As keyRoot, SubKey As String, hKeyName As String) As Boolean
'删除子键数据
'mhKey是指主键的名称，SubKey是指路径，hKeyName是指键名
Dim hKey As Long, ret As Long
ret = RegOpenKey(mhKey, SubKey, hKey)
RegDeleteKeyName = False
If ret = 0 Then
If RegDeleteValue(hKey, hKeyName) = 0 Then RegDeleteKeyName = True
End If
RegCloseKey hKey '删除打开的键值，释放内存
End Function
'-------------------------------------------------------------------------------------------------------------
'- 将 Double 型( 限制在 0--2^32-1 )的数字转换为十六进制并在前面补零
'- 参数说明: Number--要转换的 Double 型数字
'-------------------------------------------------------------------------------------------------------------
Private Function DoubleToHex(ByVal Number As Double) As String
Dim strHex As String
strHex = Space(8)
For i = 1 To 8
Select Case Number - Int(Number / 16) * 16
Case 10
Mid(strHex, 9 - i, 1) = "A"
Case 11
Mid(strHex, 9 - i, 1) = "B"
Case 12
Mid(strHex, 9 - i, 1) = "C"
Case 13
Mid(strHex, 9 - i, 1) = "D"
Case 14
Mid(strHex, 9 - i, 1) = "E"
Case 15
Mid(strHex, 9 - i, 1) = "F"
Case Else
Mid(strHex, 9 - i, 1) = CStr(Number - Int(Number / 16) * 16)
End Select
Number = Int(Number / 16)
Next i
DoubleToHex = strHex
End Function
Public Function GetKeyValueType(ByVal keyRoot As keyRoot, ByVal KeyName As String, ByVal checkValueName As String) As ValueType
Dim f As FILETIME, CountKey As Long, CountValue As Long, MaxLenKey As Long, MaxLenValue As Long
Dim l As Long, s As String, strTmp As String, intTmp As Long, ValueName() As String, ValueType() As ValueType
' 打开一个已存在的注册表关键字...
Success = RegOpenKeyEx(keyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
If Success <> ERROR_SUCCESS Then GetKeyValueType = 0: RegCloseKey hKey: Exit Function
' 获得一个已打开的注册表关键字的信息...
Success = RegQueryInfoKey(hKey, vbNullString, ByVal 0&, ByVal 0&, CountKey, MaxLenKey, ByVal 0&, CountValue, MaxLenValue, ByVal 0&, ByVal 0&, f)
If Success <> ERROR_SUCCESS Then GetKeyValueType = 0: RegCloseKey hKey: Exit Function
If CountValue <> 0 Then
ReDim ValueName(CountValue - 1) As String ' 重新定义数组, 使用数组大小与注册表关键字的子键数量匹配
ReDim ValueType(CountValue - 1) 'As Long ' 重新定义数组, 使用数组大小与注册表关键字的子键数量匹配
For i = 0 To CountValue - 1
strTmp = String(255, vbNullChar) 'Space(255)
l = 255
RegEnumValue hKey, i, ByVal strTmp, l, 0, intTmp, ByVal 0&, ByVal 0&
ValueType(i) = intTmp
ValueName(i) = Left(strTmp, l)
If InStr(ValueName(i), vbNullChar) - 1 <> -1 Then
ValueName(i) = Left$(ValueName(i), InStr(ValueName(i), vbNullChar) - 1)
End If
If ValueName(i) = checkValueName Then
GetKeyValueType = ValueType(i)
Exit Function
End If
Next i
End If
' 关闭注册表关键字...
RegCloseKey hKey
End Function
Public Function GetKeyInfo(keyRoot As keyRoot, KeyName As String, SubKeyName() As String, ValueName() As String, ValueType() As ValueType, Optional CountKey As Long, Optional CountValue As Long, Optional MaxLenKey As Long, Optional MaxLenValue As Long) As Boolean
Dim f As FILETIME
Dim l As Long, s As String, strTmp As String, intTmp As Long
' 打开一个已存在的注册表关键字...
Success = RegOpenKeyEx(keyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
If Success <> ERROR_SUCCESS Then GetKeyInfo = False: RegCloseKey hKey: Exit Function
' 获得一个已打开的注册表关键字的信息...
Success = RegQueryInfoKey(hKey, vbNullString, ByVal 0&, ByVal 0&, CountKey, MaxLenKey, ByVal 0&, CountValue, MaxLenValue, ByVal 0&, ByVal 0&, f)
If Success <> ERROR_SUCCESS Then GetKeyInfo = False: RegCloseKey hKey: Exit Function
If CountKey <> 0 Then
ReDim SubKeyName(CountKey - 1) As String ' 重新定义数组, 使用数组大小与注册表关键字的子项数量匹配
For i = 0 To CountKey - 1
strTmp = String(255, vbNullChar) 'Space(255)
l = 255
RegEnumKeyEx hKey, i, ByVal strTmp, l, 0, vbNullString, ByVal 0&, f
SubKeyName(i) = Left(strTmp, l)
If InStr(SubKeyName(i), vbNullChar) - 1 <> -1 Then
SubKeyName(i) = Left$(SubKeyName(i), InStr(SubKeyName(i), vbNullChar) - 1)
End If
Next i
' 下面的二重循环对字符串数组进行冒泡排序
For i = 0 To UBound(SubKeyName)
For j = i + 1 To UBound(SubKeyName)
If SubKeyName(i) > SubKeyName(j) Then
s = SubKeyName(i)
SubKeyName(i) = SubKeyName(j)
SubKeyName(j) = s
End If
Next j
Next i
End If
If CountValue <> 0 Then
ReDim ValueName(CountValue - 1) As String ' 重新定义数组, 使用数组大小与注册表关键字的子键数量匹配
ReDim ValueType(CountValue - 1) 'As Long ' 重新定义数组, 使用数组大小与注册表关键字的子键数量匹配
For i = 0 To CountValue - 1
strTmp = String(255, vbNullChar) 'Space(255)
l = 255
RegEnumValue hKey, i, ByVal strTmp, l, 0, intTmp, ByVal 0&, ByVal 0&
ValueType(i) = intTmp
ValueName(i) = Left(strTmp, l)
If InStr(ValueName(i), vbNullChar) - 1 <> -1 Then
ValueName(i) = Left$(ValueName(i), InStr(ValueName(i), vbNullChar) - 1)
End If
Next i
' 下面的二重循环对字符串数组进行冒泡排序
For i = 0 To UBound(ValueName)
For j = i + 1 To UBound(ValueName)
If ValueName(i) > ValueName(j) Then
s = ValueName(i)
ValueName(i) = ValueName(j)
ValueName(j) = s
End If
Next j
Next i
End If
' 关闭注册表关键字...
RegCloseKey hKey
GetKeyInfo = True ' 返回函数值
End Function
Public Function RegDeleteSubkey(hKey As keyRoot, SubKey As String) As Boolean
'删除目录
'mhKey是指主键的名称，SubKey是指路径
Dim ret As Long, Index As Long, hName As String
Dim hSubkey As Long
ret = RegOpenKey(hKey, SubKey, hSubkey)
If ret <> 0 Then
RegDeleteSubkey = False
Exit Function
End If
ret = RegDeleteKey(hSubkey, "")
If ret <> 0 Then '如果删除失败则认为是NT则用递归方法删除目录
hName = String(256, Chr(0))
While RegEnumKey(hSubkey, 0, hName, Len(hName)) = 0 And _
RegDeleteSubkey(hSubkey, hName)
Wend
ret = RegDeleteKey(hSubkey, "")
End If
RegDeleteSubkey = (ret = 0)
RegCloseKey hSubkey '删除打开的键值，释放内存
End Function
Public Sub GetRegRootPath(ByVal RegPath As String, regRoot As keyRoot)
If InStr(UCase(RegPath), "HKEY_CLASSES_ROOT") > 0 Then
regRoot = HKEY_CLASSES_ROOT
ElseIf InStr(UCase(RegPath), "HKEY_CURRENT_CONFIG") > 0 Then
regRoot = HKEY_CURRENT_CONFIG
ElseIf InStr(UCase(RegPath), "HKEY_CURRENT_USER") > 0 Then
regRoot = HKEY_CURRENT_USER
ElseIf InStr(UCase(RegPath), "HKEY_DYN_DATA") > 0 Then
regRoot = HKEY_DYN_DATA
ElseIf InStr(UCase(RegPath), "HKEY_LOCAL_MACHINE") > 0 Then
regRoot = HKEY_LOCAL_MACHINE
ElseIf InStr(UCase(RegPath), "HKEY_PERFORMANCE_DATA") > 0 Then
regRoot = HKEY_PERFORMANCE_DATA
Else
regRoot = HKEY_USERS
End If
End Sub
Public Function GetRegSubPath(ByVal RegPath As String) As String
If InStr(UCase(RegPath), "HKEY_CLASSES_ROOT") > 0 Then
GetRegSubPath = Mid(RegPath, Len("HKEY_CLASSES_ROOT") + 2, Len(RegPath) - Len("HKEY_CLASSES_ROOT") + 1)
ElseIf InStr(UCase(RegPath), "HKEY_CURRENT_CONFIG") > 0 Then
GetRegSubPath = Mid(RegPath, Len("HKEY_CURRENT_CONFIG") + 2, Len(RegPath) - Len("HKEY_CURRENT_CONFIG") + 1)
ElseIf InStr(UCase(RegPath), "HKEY_CURRENT_USER") > 0 Then
GetRegSubPath = Mid(RegPath, Len("HKEY_CURRENT_USER") + 2, Len(RegPath) - Len("HKEY_CURRENT_USER") + 1)
ElseIf InStr(UCase(RegPath), "HKEY_DYN_DATA") > 0 Then
GetRegSubPath = Mid(RegPath, Len("HKEY_DYN_DATA") + 2, Len(RegPath) - Len("HKEY_DYN_DATA") + 1)
ElseIf InStr(UCase(RegPath), "HKEY_LOCAL_MACHINE") > 0 Then
GetRegSubPath = Mid(RegPath, Len("HKEY_LOCAL_MACHINE") + 2, Len(RegPath) - Len("HKEY_LOCAL_MACHINE") + 1)
ElseIf InStr(UCase(RegPath), "HKEY_PERFORMANCE_DATA") > 0 Then
GetRegSubPath = Mid(RegPath, Len("HKEY_PERFORMANCE_DATA") + 2, Len(RegPath) - Len("HKEY_PERFORMANCE_DATA") + 1)
Else
GetRegSubPath = Mid(RegPath, Len("HKEY_USERS") + 2, Len(RegPath) - Len("HKEY_USERS") + 1)
End If
End Function
'Public Sub GetRegType(ByVal RegType As String, valueTypes As ValueType)
' Select Case RegType
' Case "1"
' valueTypes = REG_SZ
' Case "2"
' valueTypes = REG_EXPAND_SZ
' Case "3"
' valueTypes = REG_BINARY
' Case "4"
' valueTypes = REG_DWORD
' Case "7"
' valueTypes = REG_MULTI_SZ
' Case Else
' valueTypes = REG_SZ
' End Select
'End Sub
Public Function RegRootPathIsTrue(ByVal RegPath As String) As Boolean
If InStr(UCase(RegPath), "HKEY_CLASSES_ROOT") > 0 Then
RegRootPathIsTrue = True
ElseIf InStr(UCase(RegPath), "HKEY_CURRENT_CONFIG") > 0 Then
RegRootPathIsTrue = True
ElseIf InStr(UCase(RegPath), "HKEY_CURRENT_USER") > 0 Then
RegRootPathIsTrue = True
ElseIf InStr(UCase(RegPath), "HKEY_DYN_DATA") > 0 Then
RegRootPathIsTrue = True
ElseIf InStr(UCase(RegPath), "HKEY_LOCAL_MACHINE") > 0 Then
RegRootPathIsTrue = True
ElseIf InStr(UCase(RegPath), "HKEY_PERFORMANCE_DATA") > 0 Then
RegRootPathIsTrue = True
Else
RegRootPathIsTrue = False
End If
End Function
Public Function GetRegRoot(regRoot As keyRoot) As String
Select Case regRoot
Case &H80000000
GetRegRoot = "HKEY_CLASSES_ROOT"
Case &H80000001
GetRegRoot = "HKEY_CURRENT_USER"
Case &H80000002
GetRegRoot = "HKEY_LOCAL_MACHINE"
Case &H80000003
GetRegRoot = "HKEY_USERS"
Case &H80000004
GetRegRoot = "HKEY_PERFORMANCE_DATA"
Case &H80000005
GetRegRoot = "HKEY_CURRENT_CONFIG"
Case &H80000006
GetRegRoot = "HKEY_DYN_DATA"
End Select
End Function
modSubClass.bas
Attribute VB_Name = "modSubClass"
'REG_SZ = 1
'REG_BINARY = 3
'REG_DOWRD = 4
'REG_MULTI_SZ = 7
'REG_EXPAND_SZ = 2
'
'/REGISTRY/MACHINE
'/REGISTRY/USER
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MINMAXINFO
ptReserved As POINTAPI
ptMaxSize As POINTAPI
ptMaxPosition As POINTAPI
ptMinTrackSize As POINTAPI
ptMaxTrackSize As POINTAPI
End Type
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
'**************************************************************************
'获取SID相关API函数
Private Declare Function GetSidSubAuthorityCount Lib "advapi32.dll" (pSid As Any) As Long
Private Declare Function GetSidIdentifierAuthority Lib "advapi32.dll" (pSid As Any) As Long
Private Declare Function GetSidSubAuthority Lib "advapi32.dll" (pSid As Any, ByVal nSubAuthority As Long) As Long
Private Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" (ByVal IpSystemName As String, ByVal IpAccountName As String, pSid As Byte, cbSid As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Integer) As Long
Private Declare Sub CopyByValMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
'***************************************************************************
Private Declare Sub Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)
Private Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Private Const WM_COPYDATA = &H4A
Private lpPrevWndProc As Long
Private Const WM_NCDESTROY = &H82
Private Const GWL_WNDPROC = -4
Private Const WM_HOTKEY = &H312
Private Const WM_GETMINMAXINFO = &H24
Private Const WM_USER = &H400
Public Const WM_TRAYICON = WM_USER + 123 '托盘消息
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Public gblnIsEnd As Boolean '是否退出状态
Public gstrArray() As String '消息数组
Public glngCount As Long '消息数量
Public gblnIsShow As Boolean '是否显示状态
'开始执行消息过滤
Public Sub StartHook(hwnd As Long)
lpPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
'卸载消息钩子
Public Sub Unhook(hwnd As Long)
If lpPrevWndProc <> 0 Then SetWindowLong hwnd, GWL_WNDPROC, lpPrevWndProc
End Sub
'消息过滤函数
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim objCd As COPYDATASTRUCT
Dim strTmp As String, strFullRegPath As String, strType As String
Dim strValue As String, strRegType As String, strOutType As String
Dim strProcessPath As String, strCmpData As String, strRegPath As String
Dim strFindAllowData As String, strFindNotAllowData As String
Select Case uMsg
Case WM_NCDESTROY
Unhook hwnd
Case WM_HOTKEY
' Call HotKeyFunctions(wParam)
' Exit Function
Case WM_GETMINMAXINFO
' Dim MinMax As MINMAXINFO
' CopyMemory MinMax, ByVal lParam, Len(MinMax)
' MinMax.ptMinTrackSize.x = 610
' MinMax.ptMinTrackSize.y = 420
' CopyMemory ByVal lParam, MinMax, Len(MinMax)
' WindowProc = 1
' Exit Function
Case WM_COPYDATA
'获取DLL传来的消息
CopyMemory objCd, ByVal lParam, Len(objCd)
strTmp = Space(objCd.cbData)
CopyMemory ByVal strTmp, ByVal objCd.lpData, objCd.cbData
'对消息进行分离
strType = Left(strTmp, InStr(strTmp, ":"))
strFullRegPath = GetFullPath(strTmp)
strProcessPath = GetRegProcessPathEx(strFullRegPath)
strRegPath = GetRegistryPath(strFullRegPath)
strCmpData = strProcessPath & "," & GetRegistryPath(strFullRegPath)
strFindAllowData = IsIniDataExist("AllowPath", strCmpData, strIniFilePath)
strFindNotAllowData = IsIniDataExist("DisAllowPath", strCmpData, strIniFilePath)
If strFindAllowData <> "" Then
WindowProc = 1000
Exit Function
End If
If strFindNotAllowData <> "" Then
WindowProc = 0
Exit Function
End If
If gblnIsShow Then
ReDim Preserve gstrArray(0 To glngCount)
gstrArray(glngCount) = GetRegProcessPath(strFullRegPath) & "," & strProcessPath
glngCount = glngCount + 1
Do While IsArraryInitialize(gstrArray) And gblnIsShow
DoEvents
Sleep 10
Loop
End If
'对分离出来的结果进行显示和处理
If Not gblnIsEnd Then
Select Case strType
Case "设置值:"
strRegType = GetRegistryType(strFullRegPath)
strValue = GetKeyValue(GetRoot(strFullRegPath), GetRegistrySubPath(strFullRegPath), GetRegValueName(strFullRegPath), GetRegTypeLng(strRegType))
If strValue = "^_*_*_^" Then
strOutType = "新增"
Else
strOutType = "修改"
End If
frmRegMonitor.txtRegPath.Text = strRegPath
If strOutType = "新增" Then
frmRegMonitor.txtType = "新增<" & GetRegValueName(strFullRegPath) & ">" & "值类型是<" & GetRegTypeString(strRegType) & ">"
Else
frmRegMonitor.txtType = "修改<" & GetRegValueName(strFullRegPath) & ">值为<" & GetRegValue(strFullRegPath) & ">值类型是<" & GetRegTypeString(strRegType) & ">"
End If
Case "删除值:"
frmRegMonitor.txtRegPath.Text = strRegPath
frmRegMonitor.txtType = "删除值<" & GetRegValueName(strFullRegPath) & ">"
frmRegMonitor.txtProcessPath.Text = GetRegProcessPath(strFullRegPath)
Case "删除项:"
frmRegMonitor.txtRegPath.Text = strRegPath
frmRegMonitor.txtType = "删除项<" & GetRegValueName(strFullRegPath) & ">"
frmRegMonitor.txtProcessPath.Text = GetRegProcessPath(strFullRegPath)
Case "新增项:"
frmRegMonitor.txtRegPath.Text = strRegPath
frmRegMonitor.txtType = "新增项<" & GetRegValueName(strFullRegPath) & ">"
frmRegMonitor.txtProcessPath.Text = GetRegProcessPath(strFullRegPath)
End Select
frmRegMonitor.txtProcessPath.Text = GetRegProcessPath(strFullRegPath)
frmRegMonitor.timerCheck = True
gblnIsShow = True
frmRegMonitor.Show 1
'对用户选择的结果进行处理
If frmRegMonitor.optAgree.Value Then
If frmRegMonitor.chkAllow.Value = 1 Then
If strFindAllowData = "" Then
WriteIniStr "AllowPath", GetMaxIndex("AllowPath", strIniFilePath), strCmpData, strIniFilePath
End If
End If
WindowProc = 1000
Else
If frmRegMonitor.chkAllow.Value = 1 Then
If strFindNotAllowData = "" Then
WriteIniStr "DisAllowPath", GetMaxIndex("DisAllowPath", strIniFilePath), strCmpData, strIniFilePath
End If
End If
WindowProc = 0
End If
Else
WindowProc = 1000
End If
Exit Function
Case WM_TRAYICON
If lParam = WM_RBUTTONDOWN Then
SetForegroundWindow hwnd
ElseIf lParam = WM_RBUTTONUP Then
frmRegMonitor.PopupMenu frmRegMonitor.mnuPopMenu
End If
End Select
WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
End Function
'数组是否初始化
Public Function IsArraryInitialize(strArray() As String) As Boolean
On Error GoTo err
Dim i As Long
i = UBound(strArray)
IsArraryInitialize = True
Exit Function
err:
IsArraryInitialize = False
End Function
'获取指定用户对应的SID
Private Function GetSidString(ByVal strUserName) As String
Dim strBuffer As String
Dim pSia As Long
Dim pSiaByte(5) As Byte
Dim pSid(512) As Byte
Dim pSubAuthorityCount As Long
Dim bSubAuthorityCount As Byte
Dim pAuthority As Long
Dim lAuthority As Long
Dim lngReturn As Long
Dim pDomain As Long
Dim i As Integer, dAuthority As Long
lngReturn = LookupAccountName(vbNullString, strUserName, pSid(0), 512, pDomain, 512, 1)
pSia = GetSidIdentifierAuthority(pSid(0))
CopyByValMemory pSiaByte(0), pSia, 6
strBuffer = "S-" & pSid(0) & "-" & pSiaByte(5)
pSubAuthorityCount = GetSidSubAuthorityCount(pSid(0))
CopyByValMemory bSubAuthorityCount, pSubAuthorityCount, 1
For i = 0 To bSubAuthorityCount - 1
pAuthority = GetSidSubAuthority(pSid(0), i)
CopyByValMemory lAuthority, pAuthority, LenB(lAuthority)
dAuthority = lAuthority
If ((lAuthority And &H80000000) <> 0) Then
dAuthority = lAuthority And &H7FFFFFFF
dAuthority = dAuthority + 2 ^ 31
End If
strBuffer = strBuffer & "-" & dAuthority
Next
GetSidString = strBuffer
End Function
'移除某个消息
Public Sub RemoveItem(ByVal strItem As String)
Dim i As Long, strArray() As String, j As Long
For i = 0 To glngCount - 1
If gstrArray(i) <> strItem Then
ReDim Preserve strArray(0 To j)
strArray(j) = gstrArray(i)
j = j + 1
End If
Next
Erase gstrArray
glngCount = j
gstrArray = strArray
End Sub
modTray.bas
Attribute VB_Name = "modTray"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''
'操作托盘模块
'''''''''''''''''''''''''''''''''''''''''
Private Const NIF_ICON = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_TIP = &H4
Private Const NIM_ADD = &H0
Private Const NIM_DELETE = &H2
Private Const NIM_MODIFY = &H1
Private Const WM_MOUSEMOVE = &H200
Private Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private trayStructure As NOTIFYICONDATA
'Private IconObject As Object
Private Function AddIcon(ByVal obj As Object, ByVal IconID As Long, ByVal Icon As Object, ByVal ToolTip As String) '增加托盘
trayStructure.cbSize = Len(trayStructure)
trayStructure.hwnd = obj.hwnd
trayStructure.uID = IconID
trayStructure.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
trayStructure.uCallbackMessage = WM_TRAYICON
trayStructure.hIcon = Icon
trayStructure.szTip = ToolTip & Chr$(0)
'建立托盘
Call Shell_NotifyIcon(NIM_ADD, trayStructure)
End Function
Public Function DeleteSysTray() '删除托盘
' If IconObject Is Nothing Then Exit Function
trayStructure.uID = frmRegMonitor.Icon.Handle
Call Shell_NotifyIcon(NIM_DELETE, trayStructure)
End Function
Public Function SendToTray()
AddIcon frmRegMonitor, frmRegMonitor.Icon.Handle, frmRegMonitor.Icon, "注册表监控" & vbNullChar
End Function
转载自：http://blog.csdn.net/chenhui530/archive/2008/01/31/2076013.aspx
扫一扫
1548
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
