类模块代码请到9楼看……


自制的软件，用的是开源代码
仍然是“U盘实用工具”作者XXXXXn的作品。
软件的代码是我修改过的，呵呵……

My  神龙安全.rar 820.74KB RAR 77次下载
直接上软件，自己研究
请不要外传，谢谢！！！
如果有修改，可以直接发到Ghostdie@XXXXXXXXXXX

代码奉上：






如图：FRMMain




2.模块代码：Option Explicit
Public Declare Sub Sleep Lib _    "kernel32" (ByVal dwMilliseconds As Long)Private Declare Function SHGetSpecialFolderLocation Lib _    "shell32.dll" (ByVal hwndOwner As Long, _    ByVal nFolder As Long, _    pidl As ITEMIDLIST) As LongPrivate Declare Function SHGetPathFromIDList Lib _    "shell32" (ByVal pidList As Long, _    ByVal lpBuffer As String) As LongPrivate Declare Function GetWindowsDirectory Lib _    "kernel32.dll" Alias "GetWindowsDirectoryA" ( _    ByVal lpBuffer As String, _    ByVal nSize As Long) As LongPrivate Declare Function GetSystemDirectory Lib _    "kernel32.dll" Alias "GetSystemDirectoryA" ( _    ByVal lpBuffer As String, _    ByVal nSize As Long) As LongPrivate Declare Function SHRunDialog Lib _    "shell32" Alias "#61" ( _    ByVal hOwner As Long, _    ByVal Unknown1 As Long, _    ByVal Unknown2 As Long, _    ByVal szTitle As String, _    ByVal szPrompt As String, _    ByVal uFlags As Long) As LongPrivate Declare Function ShellExecuteEx Lib _    "shell32" Alias "ShellExecuteExA" ( _    SEI As SHELLEXECUTEINFO) As LongPrivate Declare Function ShellExecute Lib _    "shell32.dll" Alias "ShellExecuteA" ( _    ByVal hwnd As Long, _    ByVal lpOperation As String, _    ByVal lpFile As String, _    ByVal lpParameters As String, _    ByVal lpDirectory As String, _    ByVal nShowCmd As Long) As LongPrivate Declare Function SHGetFileInfo Lib _    "shell32.dll" Alias "SHGetFileInfoA" ( _    ByVal pszPath As String, _    ByVal dwFileAttributes As Long, _    psfi As SHFILEINFO, _    ByVal cbFileInfo As Long, _    ByVal uFlags As Long) As Long    Private Type SHELLEXECUTEINFO    cbSize As Long    fMask As Long    hwnd As Long    lpVerb As String    lpFile As String    lpParameters As String    lpDirectory As String    nShow As Long    hInstApp As Long    lpIDList As Long    lpClass As String    hkeyClass As Long    dwHotKey As Long    hIcon As Long    hProcess As LongEnd Type
Private Type BrowseInfo    lnghwnd As Long    pIDLRoot As Long    pszDisplayName As Long    lpszTitle As Long    ulFlags As Long    lpfnCallback As Long    lParam As Long    iImage As LongEnd Type
Private Type SHITEMID    cb As Long    abID As ByteEnd Type
Private Type ITEMIDLIST    mkid As SHITEMIDEnd Type
Public Enum SpecialFolder    CSIDL_RECENT = &H8    CSIDL_PROFILER = &H28    CSIDL_HISTORY = &H22End Enum
Private Const BIF_NEWDIALOGSTYLE As Long = &H40Private Const BIF_EDITBOX As Long = &H10Private Const MAX_PATH As Integer = 260Private Const SEE_MASK_INVOKEIDLIST = &HCPrivate Const SEE_MASK_NOCLOSEPROCESS = &H40Private Const SEE_MASK_FLAG_NO_UI = &H400Private Const OFN_OVERWRITEPROMPT = &H2Private Const OFN_PATHMUSTEXIST = &H800Private Const OFN_EXPLORER = &H80000Private Const OFN_ENABLEHOOK = &H20Private Const OFN_HIDEREADONLY = &H4Private Const SHGFI_DISPLAYNAME As Long = &H200Private Const SHGFI_TYPENAME As Long = &H400
Private Type SHFILEINFO    hIcon As Long    iIcon As Long    dwAttributes As Long    szDisplayName As String * MAX_PATH    szTypeName As String * 80End Type
Private Declare Sub CoTaskMemFree Lib _    "ole32.dll" (ByVal hMem As Long)Private Declare Function lstrcat Lib _    "kernel32" Alias "lstrcatA" _    (ByVal lpString1 As String, _    ByVal lpString2 As String) As LongPrivate Declare Function SHBrowseForFolder Lib _    "shell32" (lpBI As BrowseInfo) As Long
Public Function BrowseForFolder(lnghwnd As Long, _    strPrompt As String) As String    On Error GoTo ehBrowseForFolder    Dim intNull As Integer    Dim lngIDList As Long, lngResult As Long    Dim strPath As String    Dim udtBI As BrowseInfo    With udtBI        .lnghwnd = lnghwnd        .lpszTitle = lstrcat(strPrompt, "")        .ulFlags = BIF_NEWDIALOGSTYLE + BIF_EDITBOX    End With    lngIDList = SHBrowseForFolder(udtBI)    If lngIDList <> 0 Then        strPath = String(MAX_PATH, 0)        lngResult = SHGetPathFromIDList(lngIDList, _            strPath)        Call CoTaskMemFree(lngIDList)        intNull = InStr(strPath, vbNullChar)            If intNull > 0 Then                strPath = Left(strPath, intNull - 1)            End If    End If    BrowseForFolder = strPath    Exit FunctionehBrowseForFolder:    BrowseForFolder = EmptyEnd Function
Public Function GetSpecialFolder(FolderType As SpecialFolder) As String    Dim r As Long, sPath As String    Dim IDL As ITEMIDLIST    r = SHGetSpecialFolderLocation(100, FolderType, IDL)    sPath = Space$(512)    r = SHGetPathFromIDList(ByVal XXXXXXid.cb, ByVal sPath)    GetSpecialFolder = Left$(sPath, InStr(1, sPath, Chr$(0)) - 1)End Function
Public Function GetWindowsPath() As String    Dim lpBuffer As String * 255    Dim nSize As Long    nSize = GetWindowsDirectory(lpBuffer, 255)    GetWindowsPath = Left(lpBuffer, nSize) & "\"End Function
Public Function GetSystem32Path() As String    Dim lpBuffer As String * 255    Dim nSize As Long    nSize = GetSystemDirectory(lpBuffer, 255)    GetSystem32Path = Left(lpBuffer, nSize) & "\"End Function
Public Function OpenInFolder(lvwItemExe As ListView, ItemId As Integer) As Double    On Error Resume Next    OpenInFolder = Shell("explorer.exe /select, " & _        XXXXXXXXXXXXXlectedItem.SubItems(ItemId), vbNormalFocus)End Function
Public Function OpenDosPrompt(lvwFilePath As ListView, _    ItemExepath As Integer) As Long    On Error Resume Next    OpenDosPrompt = ShellExecute(1, vbNullString, "XXXXXXXXXXX", _        vbNullString, GetFilePath(XXXXXXXXXXXXXXlectedItem.SubItems(ItemExepath)), 1)End Function
Public Function ShowRunApp(hwnd As Long) As Long    On Error Resume Next    ShowRunApp = SHRunDialog(hwnd, 0, 0, _        StrConv("New Process", vbUnicode), _        StrConv("Type the name of a program, folder, document, or Internet Resource," _        & " and Windows will open it for you.", vbUnicode), 0)End Function
Public Function OpenXPTool(hwnd As Long, lpOperation As String) As Long    On Error Resume Next    OpenXPTool = ShellExecute(hwnd, vbNullString, lpOperation, _        vbNullString, Left(GetWindowsPath, 3), 1)End Function
Public Function OnlineHelp(hwnd As Long, strSite As String) As Long    On Error Resume Next    OnlineHelp = ShellExecute(hwnd, vbNullString, _        "http://" & strSite, vbNullString, Left(GetWindowsPath, 3), 1)End Function
Public Function ShowFileProperties(hwndOwner As Long, _    lvwFilePath As ListView, ItemExepath As Integer, _    Optional lUseSubItem As Boolean = True) _     As Long    On Error Resume Next    Dim SEI As SHELLEXECUTEINFO    Dim slpFileName As String    If lUseSubItem Then        slpFileName = XXXXXXXXXXXXXXlectedItem.SubItems(ItemExepath)    Else        slpFileName = XXXXXXXXXXXXXXlectedItem    End If    With SEI        .cbSize = Len(SEI)        .fMask = SEE_MASK_NOCLOSEPROCESS Or _            SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI        .hwnd = hwndOwner        .lpVerb = "properties"        .lpFile = slpFileName        .lpParameters = vbNullChar        .lpDirectory = vbNullChar        .nShow = 0        .hInstApp = 1        .lpIDList = 0    End With    Call ShellExecuteEx(SEI)End Function
Public Function GetFilePath(sPath As String) As String    Dim i As Integer    For i = Len(sPath) To 1 Step -1        If Mid$(sPath, i, 1) = "\" Then            GetFilePath = Mid$(sPath, 1, i)            Exit For        End If    Next iEnd Function
Public Function GetPathType(Path As String) As String    Dim FileInfo As SHFILEINFO, lngRet As Long    lngRet = SHGetFileInfo(Path, 0, FileInfo, _        Len(FileInfo), SHGFI_DISPLAYNAME Or SHGFI_TYPENAME)    If lngRet = 0 Then GetPathType = _        Trim$(GetFileExtension(Path) & " File"): Exit Function    GetPathType = Left$(XXXXXXXXXXXTypeName, _        InStr(1, XXXXXXXXXXXTypeName, vbNullChar) - 1)End Function
Public Function GetFileExtension(Path As String) As String    Dim intRet As Integer: intRet = InStrRev(Path, ".")    If intRet = 0 Then Exit Function    GetFileExtension = UCase(Mid$(Path, intRet + 1))End Function











Option Explicit
Dim CRC32 As New clsGetCRC32
Function GetChecksum(sFile As String) As String    On Error GoTo ErrHandle    Dim cb0 As Byte    Dim cb1 As Byte    Dim cb2 As Byte    Dim cb3 As Byte    Dim cb4 As Byte    Dim cb5 As Byte    Dim cb6 As Byte    Dim cb7 As Byte    Dim cb8 As Byte    Dim cb9 As Byte    Dim cb10 As Byte    Dim cb11 As Byte    Dim cb12 As Byte    Dim cb13 As Byte    Dim cb14 As Byte    Dim cb15 As Byte    Dim cb16 As Byte    Dim cb17 As Byte    Dim cb18 As Byte    Dim cb19 As Byte    Dim cb20 As Byte    Dim cb21 As Byte    Dim cb22 As Byte    Dim cb23 As Byte    Dim buff As String    Open sFile For Binary Access Read As #1        buff = Space$(1)        Get #1, , buff    Close #1    Open sFile For Binary Access Read As #2        Get #2, 512, cb0        Get #2, 1024, cb1        Get #2, 2048, cb2        Get #2, 3000, cb3        Get #2, 4096, cb4        Get #2, 5000, cb5        Get #2, 6000, cb6        Get #2, 7000, cb7        Get #2, 8192, cb8        Get #2, 9000, cb9        Get #2, 10000, cb10        Get #2, 11000, cb11        Get #2, 12288, cb12        Get #2, 13000, cb13        Get #2, 14000, cb14        Get #2, 15000, cb15        Get #2, 16384, cb16        Get #2, 17000, cb17        Get #2, 18000, cb18        Get #2, 19000, cb19        Get #2, 20480, cb20        Get #2, 21000, cb21        Get #2, 22000, cb22        Get #2, 23000, cb23    Close #2    buff = cb0    buff = buff & cb1    buff = buff & cb2    buff = buff & cb3    buff = buff & cb4    buff = buff & cb5    buff = buff & cb6    buff = buff & cb7    buff = buff & cb8    buff = buff & cb9    buff = buff & cb10    buff = buff & cb11    buff = buff & cb12    buff = buff & cb13    buff = buff & cb14    buff = buff & cb15    buff = buff & cb16    buff = buff & cb17    buff = buff & cb18    buff = buff & cb19    buff = buff & cb20    buff = buff & cb21    buff = buff & cb22    buff = buff & cb23    GetChecksum = XXXXXXXXringChecksum(buff)    Set CRC32 = Nothing    Exit FunctionErrHandle:    Close #2End Function
Function GetFullCRC(sFile As String) As String    GetFullCRC = XXXXXXXXleChecksum(sFile)End Function


Option Explicit
Private Type tagInitCommonControlsEx   lngSize As Long   lngICC As LongEnd Type
Public Declare Function InitCommonControls Lib _    "comctl32.dll" () As LongPrivate Declare Function InitCommonControlsEx Lib _    "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
Private Const ICC_USEREX_CLASSES = &H200
Sub Main()    'If Year(Now) < 2008 Then    '    MsgBox "Cannot open application: System Time is not valid.", _    '        vbCritical + vbSystemModal, "Error Opening Application"    '    End    'End If    Dim iccex As tagInitCommonControlsEx    With iccex        .lngSize = LenB(iccex)        .lngICC = ICC_USEREX_CLASSES    End With    InitCommonControlsEx iccex    On Error GoTo 0    App.TaskVisible = False    App.Title = GenerateRandomTitle(True)    XXXXXXXXXXXXXowEnd Sub
'[s:9]rivate Sub Register_Ext()'    CreateRegistryKey HKEY_CLASSES_ROOT, "evdfile"'    CreateRegistryKey HKEY_CLASSES_ROOT, "evdfile\DefaultIcon"'    CreateStringValue HKEY_CLASSES_ROOT, "evdfile", "", _'        "External Virus Database"'    CreateStringValue HKEY_CLASSES_ROOT, "evdfile\DefaultIcon", "", _'        "%SystemRoot%\System32\shell32.dll,-154"'    CreateRegistryKey HKEY_CLASSES_ROOT, ".evd"'    CreateStringValue HKEY_CLASSES_ROOT, ".evd", "", "evdfile"'End Sub
'Sub SaveAppSettings()'    Dim lReg As Long'    With frmMain'        ' Register Application'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "Register", 1'        Register_Ext'        ' Save File Extensions'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "UseExtensionList", _'            Abs(CLng(.XXXXXXXXXlue))'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "Extension", _'            CLng(.XXXXXXXXXstIndex)'        ' Save Scan Options'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "FixErrorRegistry", _'            CLng(.XXXXXXXXXXXXlue)'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "RepairData", _'            CLng(.XXXXXXXXXlue)'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "HiddenRecovery", _'            CLng(.XXXXXXXXXXXXlue)'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "ScanMemory", _'            CLng(.XXXXXXXXXXXXXlue)'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "WarningSound", _'            CLng(.XXXXXXXXXXXlue)'        ' Save Window Settings'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "AlwaysOnTop", _'            CLng(.XXXXXXXXXXXlue)'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "Transparency", _'            CLng(.XXXXXXXXXXXlue)'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "HideWindowTitle", _'            CLng(.XXXXXXXXXXXXXXXlue)'        ' Save Reporting Service'        If .XXXXXXXXXXXXlue = True Then'            lReg = 1'        ElseIf .XXXXXXXXXXXXXXXXlue = True Then'            lReg = 2'        Else'            lReg = 0'        End If'        CreateDwordValue HKEY_CURRENT_USER, SMP_KEY, "ReportingService", lReg'    End With'End Sub
'Sub LoadAppSettings()'    Dim lReg As Long'    With frmMain'        ' Load File Extensions'        lReg = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "UseExtensionList")'        If lReg = 1 Then'            .XXXXXXXXXXXXXXlue = False'            .XXXXXXXXXlue = True'            .cboExt.Enabled = True'        Else'            .XXXXXXXXXXXXXXlue = True'            .XXXXXXXXXlue = False'            .cboExt.Enabled = False'        End If'        .XXXXXXXXXstIndex = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "Extension")'        ' Load Scan Options'        .XXXXXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "FixErrorRegistry")'        .XXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "RepairData")'        .XXXXXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "HiddenRecovery")'        .XXXXXXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "ScanMemory")'        .XXXXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "WarningSound")'        ' Load Window Settings'        .XXXXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "AlwaysOnTop")'        .XXXXXXXXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "Transparency")'        .XXXXXXXXXXXlue = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "HideWindowTitle")'        ' Load Reporting Service'        lReg = GetDWORDValue(HKEY_CURRENT_USER, SMP_KEY, "ReportingService")'        If lReg = 1 Then'            .XXXXXXXXXXXXlue = True'        ElseIf lReg = 2 Then'            .XXXXXXXXXXXXXXXXlue = True'        Else'            .XXXXXXXXXXXXXXXlue = True'        End If'    End With'End Sub
'Sub DefaultAppSettings()'    With frmMain'        .XXXXXXXXXXXXXXlue = True'        .XXXXXXXXXstIndex = 4'        .XXXXXXXXXlue = vbChecked'        .XXXXXXXXXXXXXlue = vbChecked'        .XXXXXXXXXXXlue = vbChecked'        .XXXXXXXXXXXlue = vbChecked'        .XXXXXXXXXXXXXXXlue = vbChecked'        .XXXXXXXXXXXXlue = True'    End With'End Sub




Option Explicit
Private Declare Sub GlobalMemoryStatus Lib _    "kernel32" (lpBuffer As MEMORYSTATUS)
Private Type MEMORYSTATUS    dwLength        As Long    dwMemoryLoad    As Long    dwTotalPhys     As Long    dwAvailPhys     As Long    dwTotalPageFile As Long    dwAvailPageFile As Long    dwTotalVirtual  As Long    dwAvailVirtual  As LongEnd Type
Private Enum PDH_STATUS    PDH_CSTATUS_VALID_DATA = &H0    PDH_CSTATUS_NEW_DATA = &H1End Enum
Private Declare Function PdhOpenQuery Lib _    "[s:9]DH.DLL" (ByVal Reserved As Long, _    ByVal dwUserData As Long, _    ByRef hQuery As Long) As PDH_STATUSPrivate Declare Function PdhVbAddCounter Lib _    "[s:9]DH.DLL" (ByVal QueryHandle As Long, _    ByVal CounterPath As String, _    ByRef CounterHandle As Long) As PDH_STATUSPrivate Declare Function PdhCollectQueryData Lib _    "[s:9]DH.DLL" (ByVal QueryHandle As Long) As PDH_STATUSPrivate Declare Function PdhVbGetDoubleCounterValue Lib _    "[s:9]DH.DLL" (ByVal CounterHandle As Long, _    ByRef CounterStatus As Long) As Double
Private Type CounterInfo    hCounter As Long    strName As StringEnd Type
Dim pdhStatus As PDH_STATUSDim Counters(0 To 99) As CounterInfoDim hQuery As Long
Public Sub MemoryInfo(lAPageFile As Label, lAPhys As Label, _    lAVirtual As Label, lTPageFile As Label, lTPhys As Label, _    lTVirtual As Label, lMemUsage As Label)    Dim MemStat As MEMORYSTATUS    MemStat.dwLength = Len(MemStat)    GlobalMemoryStatus MemStat    With MemStat        XXXXXXXXXXXXXption = Format(.dwAvailPageFile _            / 1024, "###,###,###") & " KB"        XXXXXXXXXption = Format(.dwAvailPhys / 1024, _            "###,###,###") & " KB"        XXXXXXXXXXXXption = Format(.dwAvailVirtual / _            1024, "###,###,###") & " KB"        XXXXXXXXXXXXXption = Format(.dwTotalPageFile _            / 1024, "###,###,###") & " KB"        XXXXXXXXXption = Format(.dwTotalPhys / 1024, _            "###,###,###") & " KB"        XXXXXXXXXXXXption = Format(.dwTotalVirtual / _            1024, "###,###,###") & " KB"        XXXXXXXXXXXXption = .dwMemoryLoad & " %"    End WithEnd Sub
Public Sub UpdateValues(lblCPU As Label)    Dim dblCounterValue As Double    Dim pdhStatus As Long    Dim strInfo As String    Dim i As Long    PdhCollectQueryData (hQuery)    i = 0    dblCounterValue = PdhVbGetDoubleCounterValue( _        Counters(i).hCounter, pdhStatus)    If (pdhStatus = PDH_CSTATUS_VALID_DATA) Or (pdhStatus _        = PDH_CSTATUS_NEW_DATA) Then        XXXXXXXXXption = Abs(Fix(dblCounterValue)) & " %"    End IfEnd Sub
Private Sub AddCounter(strCounterName As String, _    hQuery As Long)    Dim pdhStatus As PDH_STATUS    Dim hCounter As Long, currentCounterIdx As Long    pdhStatus = PdhVbAddCounter(hQuery, strCounterName, _        hCounter)    Counters(currentCounterIdx).hCounter = hCounter    Counters(currentCounterIdx).strName = strCounterName    currentCounterIdx = currentCounterIdx + 1End Sub
Public Sub GetCPUInfo(lblCPU As Label)    pdhStatus = PdhOpenQuery(0, 1, hQuery)    AddCounter "\Processor(0)\% Processor Time", hQuery    UpdateValues lblCPUEnd Sub






Option Explicit
Private Const TH32CS_SNAPHEAPLIST = &H1Private Const TH32CS_SNAPPROCESS = &H2Private Const TH32CS_SNAPTHREAD = &H4Private Const TH32CS_SNAPMODULE = &H8Private Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or _    TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)Private Const MAX_PATH = 260Private Const PROCESS_QUERY_INFORMATION = 1024Private Const PROCESS_VM_READ = 16Private Const PROCESS_ALL_ACCESS = &H1F0FFFPrivate Const THREAD_SUSPEND_RESUME = &H2Private Const REGISTER_SERVICE = 1Private Const UNREGISTER_SERVICE = 0
Private Type PROCESSENTRY32    dwSize As Long    cntUsage As Long    th32ProcessID As Long    th32DefaultHeapID As Long    th32ModuleID As Long    cntThreads As Long    th32ParentProcessID As Long    pcPriClassBase As Long    dwFlags As Long    szExeFile As String * MAX_PATHEnd Type
Private Type MODULEENTRY32    dwSize As Long    th32ModuleID As Long    th32ProcessID As Long    GlblcntUsage As Long    ProccntUsage As Long    modBaseAddr As Long    modBaseSize As Long    hModule As Long    szModule As String * 256    szExePath As String * 260End Type
Private Type THREADENTRY32    dwSize As Long    cntUsage As Long    th32ThreadID As Long    th32OwnerProcessID As Long    tpBasePri As Long    tpDeltaPri As Long    dwFlags As LongEnd Type
Private Type PROCESS_MEMORY_COUNTERS    cb As Long    PageFaultCount As Long    PeakWorkingSetSize As Long    WorkingSetSize As Long    QuotaPeakPagedPoolUsage As Long    QuotaPagedPoolUsage As Long    QuotaPeakNonPagedPoolUsage As Long    QuotaNonPagedPoolUsage As Long    PagefileUsage As Long    PeakPagefileUsage As LongEnd Type
Private Type OFSTRUCT    cBytes As Byte    fFixedDisk As Byte    nErrCode As Integer    Reserved1 As Integer    Reserved2 As Integer    szPathName(256) As ByteEnd Type
Public Type VERHEADER    CompanyName As String    FileDescription As String    FileVersion As String    InternalName As String    LegalCopyright As String    OrigionalFileName As String    ProductName As String    ProductVersion As String    Comments As String    LegalTradeMarks As String    PrivateBuild As String    SpecialBuild As StringEnd Type
Private Declare Function RegisterServiceProcess Lib _    "kernel32" (ByVal dwProcessId As Long, _    ByVal dwType As Long) As LongPublic Declare Function GetCurrentProcessId Lib _    "kernel32" () As LongPrivate Declare Function CreateToolhelp32Snapshot Lib _    "kernel32" (ByVal lFlags As Long, _    ByVal lProcessID As Long) As LongPrivate Declare Function Process32First Lib _    "kernel32" (ByVal hSnapShot As Long, _    uProcess As PROCESSENTRY32) As LongPrivate Declare Function Process32Next Lib _    "kernel32" (ByVal hSnapShot As Long, _    uProcess As PROCESSENTRY32) As LongPrivate Declare Function CloseHandle Lib _    "kernel32" (ByVal hObject As Long) As LongPrivate Declare Function Module32First Lib _    "kernel32" (ByVal hSnapShot As Long, _    uProcess As MODULEENTRY32) As LongPrivate Declare Function Module32Next Lib _    "kernel32" (ByVal hSnapShot As Long, _    uProcess As MODULEENTRY32) As LongPrivate Declare Function OpenProcess Lib _    "kernel32" (ByVal dwDesiredAccess As Long, _    ByVal bInheritHandle As Long, _    ByVal dwProcessId As Long) As LongPrivate Declare Function TerminateProcess Lib _    "kernel32" (ByVal hProcess As Long, _    ByVal uExitCode As Long) As LongPrivate Declare Function GetPriorityClass Lib _    "kernel32" (ByVal hProcess As Long) As LongPrivate Declare Function SetPriorityClass Lib _    "kernel32" (ByVal hProcess As Long, _    ByVal dwPriorityClass As Long) As LongPrivate Declare Function OpenThread Lib _    "kernel32.dll" (ByVal dwDesiredAccess As Long, _    ByVal bInheritHandle As Boolean, _    ByVal dwThreadId As Long) As LongPrivate Declare Function ResumeThread Lib _    "kernel32.dll" (ByVal hThread As Long) As LongPrivate Declare Function SuspendThread Lib _    "kernel32.dll" (ByVal hThread As Long) As LongPrivate Declare Function Thread32First Lib _    "kernel32.dll" (ByVal hSnapShot As Long, _    ByRef lpte As THREADENTRY32) As BooleanPrivate Declare Function Thread32Next Lib _    "kernel32.dll" (ByVal hSnapShot As Long, _    ByRef lpte As THREADENTRY32) As BooleanPrivate Declare Function lstrlen Lib _    "kernel32" Alias "lstrlenA" ( _    ByVal lpString As String) As LongPublic Declare Function GetFileAttributes Lib _    "kernel32" Alias "GetFileAttributesA" ( _    ByVal lpFileName As String) As LongPrivate Declare Function GetFileTitle Lib _    "comdlg32.dll" Alias "GetFileTitleA" ( _    ByVal lpszFile As String, _    ByVal lpszTitle As String, _    ByVal cbBuf As Integer) As IntegerPrivate Declare Function OpenFile Lib _    "kernel32.dll" (ByVal lpFileName As String, _    ByRef lpReOpenBuff As OFSTRUCT, _    ByVal wStyle As Long) As LongPrivate Declare Function GetFileSize Lib _    "kernel32" (ByVal hFile As Long, _    lpFileSizeHigh As Long) As LongPrivate Declare Function GetProcessMemoryInfo Lib _    "psapi.dll" (ByVal Process As Long, _    ByRef ppsmemCounters As PROCESS_MEMORY_COUNTERS, _    ByVal cb As Long) As LongPrivate Declare Function GetLongPathName Lib _    "kernel32.dll" Alias "GetLongPathNameA" ( _    ByVal lpszShortPath As String, _    ByVal lpszLongPath As String, _    ByVal cchBuffer As Long) As LongPrivate Declare Function GetShortPathNameA Lib _    "kernel32" (ByVal lpszLongPath As String, _    ByVal lpszShortPath As String, _    ByVal cchBuffer As Long) As LongPrivate Declare Function GetFileVersionInfo Lib _    "Version.dll" Alias "GetFileVersionInfoA" ( _    ByVal lptstrFilename As String, _    ByVal dwhandle As Long, _    ByVal dwlen As Long, _    lpData As Any) As LongPrivate Declare Function GetFileVersionInfoSize Lib _    "Version.dll" Alias "GetFileVersionInfoSizeA" ( _    ByVal lptstrFilename As String, _    lpdwHandle As Long) As LongPrivate Declare Function VerQueryValue Lib _    "Version.dll" Alias "VerQueryValueA" ( _    pBlock As Any, _    ByVal lpSubBlock As String, _    lplpBuffer As Any, _    puLen As Long) As LongPrivate Declare Sub MoveMemory Lib _    "kernel32" Alias "RtlMoveMemory" ( _    dest As Any, _    ByVal Source As Long, _    ByVal Length As Long)Private Declare Function lstrcpy Lib _    "kernel32" Alias "lstrcpyA" ( _    ByVal lpString1 As String, _    ByVal lpString2 As Long) As Long
Public Enum PriorityClass   REALTIME_PRIORITY_CLASS = &H100   HIGH_PRIORITY_CLASS = &H80   NORMAL_PRIORITY_CLASS = &H20   IDLE_PRIORITY_CLASS = &H40End Enum
Dim GetIco As New clsGetIconFile
Function StripNulls(ByVal sStr As String) As String    StripNulls = Left$(sStr, lstrlen(sStr))End Function
Public Function NTProcessList(lvwProc As ListView, _    ilsProc As ImageList) As Long    On Error Resume Next    XXXXXXXXXusePointer = vbHourglass    Dim Filename As String, ExePath As String    Dim hProcSnap As Long, hModuleSnap As Long, _        lProc As Long    Dim uProcess As PROCESSENTRY32, _        uModule As MODULEENTRY32    Dim lvwProcItem As ListItem    Dim intLVW As Integer    Dim hVer As VERHEADER    ExePath = String$(128, Chr$(0))    hProcSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)    uProcess.dwSize = Len(uProcess)    lProc = Process32First(hProcSnap, uProcess)    XXXXXXXXXXXXXXXXXXXXXear    XXXXXXXXXXXXXXXXXXXXear    XXXXXXXXXXsible = False    Do While lProc        If XXXXXXXXXXX32ProcessID <> 0 Then            hModuleSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, _                XXXXXXXXXXX32ProcessID)            uModule.dwSize = Len(uModule)            Module32First hModuleSnap, uModule            If hModuleSnap > 0 Then                ExePath = StripNulls(XXXXXXXXXXExePath)                Filename = GetFileName(ExePath)                GetVerHeader ExePath, hVer                XXXXXXXXXXXXXXXXXXXXXd , "[s:9]ID" & XXXXXXXXXXX32ProcessID, _                    GetIco.Icon(ExePath, SmallIcon)                Set lvwProcItem = XXXXXXXXXXXXXXXXXXXXd(, , Filename, , _                    "[s:9]ID" & XXXXXXXXXXX32ProcessID)                With lvwProcItem                    .SubItems(1) = GetLongPath(ExePath)                    .SubItems(2) = Format(GetSizeOfFile(ExePath) / 1024, _                        "###,###") & " KB"                    .SubItems(3) = GetAttribute(ExePath)                    .SubItems(4) = XXXXXXXleDescription                    .SubItems(5) = XXXXXXXXXXX32ProcessID                    .SubItems(6) = XXXXXXXXXXXtThreads                    .SubItems(7) = Format(GetMemory(XXXXXXXXXXX32ProcessID) / 1024, _                        "###,####") & " KB"                    .SubItems(8) = GetBasePriority(XXXXXXXXXXX32ProcessID)                End With            End If        End If        lProc = Process32Next(hProcSnap, uProcess)    Loop    Call CloseHandle(hProcSnap)    For intLVW = 1 To XXXXXXXXXXXXXXXXXXXXXXXXunt        LV_AutoSizeColumn lvwProc, XXXXXXXXXXXXXXXXXXXXXXXXem(intLVW)    Next intLVW    With lvwProc        With .ColumnHeaders            .Item(4).Width = 900            .Item(6).Width = 950            .Item(7).Width = 800            .Item(8).Width = 1250            .Item(9).Width = 800        End With        .Refresh        .Visible = True        .SetFocus    End With    XXXXXXXXXusePointer = vbNormalEnd Function
Public Function GetBasePriority(ReadPID As Long) As String    Dim hPID As Long    hPID = OpenProcess(PROCESS_QUERY_INFORMATION, 0, ReadPID)    Select Case GetPriorityClass(hPID)        Case 32: GetBasePriority = "Normal"        Case 64: GetBasePriority = "Idle"        Case 128: GetBasePriority = "High"        Case 256: GetBasePriority = "Realtime"        Case Else: GetBasePriority = "N/A"    End Select    Call CloseHandle(hPID)End Function
Public Function SetBasePriority(lvwProc As ListView, _    ItemProcessID As Integer, BasePriority As PriorityClass) As Long    Dim hPID As Long    hPID = OpenProcess(PROCESS_ALL_ACCESS, 0, XXXXXXXXXXlectedItem.SubItems( _        ItemProcessID))    SetBasePriority = SetPriorityClass(hPID, BasePriority)    Call CloseHandle(hPID)End Function
Private Function Thread32Enum(ByRef Thread() As THREADENTRY32, _    ByVal lProcessID As Long) As Long    On Error Resume Next    ReDim Thread(0)    Dim THREADENTRY32 As THREADENTRY32    Dim hThreadSnap As Long    Dim lThread As Long    hThreadSnap = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, lProcessID)    THREADENTRY32.dwSize = Len(THREADENTRY32)    If Thread32First(hThreadSnap, THREADENTRY32) = False Then        Thread32Enum = -1        Exit Function    Else        ReDim Thread(lThread)        Thread(lThread) = THREADENTRY32    End If    Do        If Thread32Next(hThreadSnap, THREADENTRY32) = False Then            Exit Do        Else            lThread = lThread + 1            ReDim Preserve Thread(lThread)            Thread(lThread) = THREADENTRY32        End If    Loop    Thread32Enum = lThread    Call CloseHandle(hThreadSnap)End Function
Public Function SetSuspendResumeThread(lvwProc As ListView, _    ItemProcessID As Integer, SuspendNow As Boolean) As Long    Dim Thread() As THREADENTRY32, hPID As Long, hThread As Long, i As Long    hPID = XXXXXXXXXXlectedItem.SubItems(ItemProcessID)    Thread32Enum Thread(), hPID    For i = 0 To UBound(Thread)        If Thread(i).th32OwnerProcessID = hPID Then            hThread = OpenThread(THREAD_SUSPEND_RESUME, False, (Thread(i).th32ThreadID))            If SuspendNow Then                SetSuspendResumeThread = SuspendThread(hThread)            Else                SetSuspendResumeThread = ResumeThread(hThread)            End If            Call CloseHandle(hThread)        End If    Next iEnd Function
Public Function TerminateProcessID(lvwProc As ListView, _    ItemProcessID As Integer) As Long    Dim hPID As Long    hPID = OpenProcess(PROCESS_ALL_ACCESS, 0, XXXXXXXXXXlectedItem.SubItems( _        ItemProcessID))    TerminateProcessID = TerminateProcess(hPID, 0)    Call CloseHandle(hPID)End Function
Public Function GetAttribute(ByVal sFilePath As String) As String    Select Case GetFileAttributes(sFilePath)        Case 1: GetAttribute = "R": Case 2: GetAttribute _            = "H": Case 3: GetAttribute = "RH": Case 4: _            GetAttribute = "S": Case 5: GetAttribute = _            "RS": Case 6: GetAttribute = "HS": Case 7: _            GetAttribute = "RHS"        Case 32: GetAttribute = "A": Case 33: GetAttribute _            = "RA": Case 34: GetAttribute = "HA": Case 35: _            GetAttribute = "RHA": Case 36: GetAttribute = _            "SA": Case 37: GetAttribute = "RSA": Case 38: _            GetAttribute = "HSA": Case 39: GetAttribute = _            "RHSA"        Case 128: GetAttribute = "Normal"        Case 2048: GetAttribute = "C": Case 2049: _            GetAttribute = "RC": Case 2050: GetAttribute = _            "HC": Case 2051: GetAttribute = "RHC": Case _            2052: GetAttribute = "SC": Case 2053: _            GetAttribute = "RSC": Case 2054: GetAttribute _            = "HSC": Case 2055: GetAttribute = "RHSC": Case _            2080: GetAttribute = "AC": Case 2081: _            GetAttribute = "RAC": Case 2082: GetAttribute _            = "HAC": Case 2083: GetAttribute = "RHAC": Case _            2084: GetAttribute = "SAC": Case 2085: _            GetAttribute = "RSAC": Case 2086: GetAttribute _            = "HSAC": Case 2087: GetAttribute = "RHSAC"        Case Else: GetAttribute = "N/A"    End SelectEnd Function
Public Function GetFileName(ByVal sFileName As String) As String    Dim buffer As String    buffer = String(255, 0)    GetFileTitle sFileName, buffer, Len(buffer)    buffer = StripNulls(buffer)    GetFileName = bufferEnd Function
Public Function GetSizeOfFile(ByVal PathFile As String) As Long    Dim hFile As Long, OFS As OFSTRUCT    hFile = OpenFile(PathFile, OFS, 0)    GetSizeOfFile = GetFileSize(hFile, 0)    Call CloseHandle(hFile)End Function
Public Function GetMemory(ProcessID As Long) As String    On Error Resume Next    Dim byteSize As Double, hProcess As Long, ProcMem As PROCESS_MEMORY_COUNTERS    ProcMem.cb = LenB(ProcMem)    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, ProcessID)    If hProcess <= 0 Then GetMemory = "N/A": Exit Function    GetProcessMemoryInfo hProcess, ProcMem, ProcMem.cb    byteSize = ProcMem.WorkingSetSize    GetMemory = byteSize    Call CloseHandle(hProcess)End Function
Private Function GetLongPath(ByVal ShortPath As String) As String    Dim lngRet As Long    GetLongPath = String$(MAX_PATH, vbNullChar)    lngRet = GetLongPathName(ShortPath, GetLongPath, Len(GetLongPath))    If lngRet > Len(GetLongPath) Then        GetLongPath = String$(lngRet, vbNullChar)        lngRet = GetLongPathName(ShortPath, GetLongPath, lngRet)    End If    If Not lngRet = 0 Then GetLongPath = Left$(GetLongPath, lngRet)End Function
Public Function GetVerHeader(ByVal fPN$, ByRef oFP As VERHEADER)    Dim lngBufferlen&, lngDummy&, lngRc&, lngVerPointer&, lngHexNumber&, i%    Dim bytBuffer() As Byte, bytBuff(255) As Byte, strBuffer$, strLangCharset$, _        strVersionInfo(11) As String, strTemp[    wind_phpcode_6    ]nbsp;   If Dir(fPN$, vbHidden + vbArchive + vbNormal + vbReadOnly + vbSystem) = "" Then        With oFP            .CompanyName = "The file """ & GetShortPath(fPN) & """ N/A"            .FileDescription = "The file """ & GetShortPath(fPN) & """ N/A"            .FileVersion = "The file """ & GetShortPath(fPN) & """ N/A"            .InternalName = "The file """ & GetShortPath(fPN) & """ N/A"            .LegalCopyright = "The file """ & GetShortPath(fPN) & """ N/A"            .OrigionalFileName = "The file """ & GetShortPath(fPN) & """ N/A"            .ProductName = "The file """ & GetShortPath(fPN) & """ N/A"            .ProductVersion = "The file """ & GetShortPath(fPN) & """ N/A"            .Comments = "The file """ & GetShortPath(fPN) & """ N/A"            .LegalTradeMarks = "The file """ & GetShortPath(fPN) & """ N/A"            .PrivateBuild = "The file """ & GetShortPath(fPN) & """ N/A"            .SpecialBuild = "The file """ & GetShortPath(fPN) & """ N/A"        End With        Exit Function    End If    lngBufferlen = GetFileVersionInfoSize(fPN$, 0)    If lngBufferlen > 0 Then        ReDim bytBuffer(lngBufferlen)        lngRc = GetFileVersionInfo(fPN$, 0&, lngBufferlen, bytBuffer(0))        If lngRc <> 0 Then            lngRc = VerQueryValue(bytBuffer(0), "\VarFileInfo\Translation", _                lngVerPointer, lngBufferlen)            If lngRc <> 0 Then                MoveMemory bytBuff(0), lngVerPointer, lngBufferlen                lngHexNumber = bytBuff(2) + bytBuff(3) * &H100 + bytBuff(0) * _                    &H10000 + bytBuff(1) * &H1000000                strLangCharset = Hex(lngHexNumber)                Do While Len(strLangCharset) < 8                    strLangCharset = "0" & strLangCharset                Loop                strVersionInfo(0) = "CompanyName"                strVersionInfo(1) = "FileDescription"                strVersionInfo(2) = "FileVersion"                strVersionInfo(3) = "InternalName"                strVersionInfo(4) = "LegalCopyright"                strVersionInfo(5) = "OriginalFileName"                strVersionInfo(6) = "[s:9]roductName"                strVersionInfo(7) = "[s:9]roductVersion"                strVersionInfo(8) = "Comments"                strVersionInfo(9) = "LegalTrademarks"                strVersionInfo(10) = "[s:9]rivateBuild"                strVersionInfo(11) = "SpecialBuild"                For i = 0 To 11                    strBuffer = String$(255, 0)                    strTemp = "\StringFileInfo\" & strLangCharset & "\" & _                        strVersionInfo(i)                    lngRc = VerQueryValue(bytBuffer(0), strTemp, lngVerPointer, _                        lngBufferlen)                    If lngRc <> 0 Then                        lstrcpy strBuffer, lngVerPointer                        strBuffer = Mid$(strBuffer, 1, InStr(strBuffer, Chr(0)) - 1)                        strVersionInfo(i) = strBuffer                    Else                        strVersionInfo(i) = ""                    End If                Next i            End If        End If    End If    For i = 0 To 11        If Trim(strVersionInfo(i)) = "" Then strVersionInfo(i) = ""    Next i    With oFP        .CompanyName = strVersionInfo(0)        .FileDescription = strVersionInfo(1)        .FileVersion = strVersionInfo(2)        .InternalName = strVersionInfo(3)        .LegalCopyright = strVersionInfo(4)        .OrigionalFileName = strVersionInfo(5)        .ProductName = strVersionInfo(6)        .ProductVersion = strVersionInfo(7)        .Comments = strVersionInfo(8)        .LegalTradeMarks = strVersionInfo(9)        .PrivateBuild = strVersionInfo(10)        .SpecialBuild = strVersionInfo(11)    End WithEnd Function
Private Function GetShortPath(ByVal strFileName As String) As String    Dim lngRet As Long    GetShortPath = String$(MAX_PATH, vbNullChar)    lngRet = GetShortPathNameA(strFileName, GetShortPath, MAX_PATH)    If Not lngRet = 0 Then GetShortPath = Left$(GetShortPath, lngRet)End Function
Public Function GetModuleProcessID(lvwProc As ListView, _    ItemProcID As Integer, lvwModule As ListView, ilsModule As ImageList) As Long    On Error Resume Next    Dim ExePath As String    Dim uProcess As MODULEENTRY32    Dim hSnapShot As Long    Dim hPID As Long    Dim lMod As Long    Dim intLVW As Integer    Dim i As Integer    Dim lvwItem As ListItem    Dim hVer As VERHEADER    hPID = XXXXXXXXXXlectedItem.SubItems(ItemProcID)    hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, hPID)    uProcess.dwSize = Len(uProcess)    lMod = Module32First(hSnapShot, uProcess)    XXXXXXXXXXXXXXXXXXXXXXear    XXXXXXXXXXXXXXXXXXXXXXXear    i = 0    Do While lMod        i = i + 1        ExePath = StripNulls(XXXXXXXXXXXExePath)        GetVerHeader ExePath, hVer        XXXXXXXXXXXXXXXXXXXXXXXd i, , GetIco.Icon(ExePath, SmallIcon)        Set lvwItem = XXXXXXXXXXXXXXXXXXXXXXd(, , GetLongPath(ExePath), , i)        With lvwItem            .SubItems(1) = XXXXXXXleDescription            .SubItems(2) = GetPathType(ExePath)            .SubItems(3) = XXXXXXXleVersion        End With        lMod = Module32Next(hSnapShot, uProcess)    Loop    Call CloseHandle(hSnapShot)    For intLVW = 1 To XXXXXXXXXXXXXXXXXXXXXXXXXXunt        LV_AutoSizeColumn lvwModule, XXXXXXXXXXXXXXXXXXXXXXXXXXem(intLVW)    Next intLVWEnd Function
Sub ScanProcess(showMode As Boolean)    On Error Resume Next    Dim ExePath As String    Dim hProcSnap As Long, hModuleSnap As Long, _        lProc As Long    Dim uProcess As PROCESSENTRY32, _        uModule As MODULEENTRY32    Dim hPID As Long, hExitCode As Long    ExePath = String$(128, Chr$(0))    hProcSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)    uProcess.dwSize = Len(uProcess)    lProc = Process32First(hProcSnap, uProcess)    Do While lProc        If XXXXXXXXXXX32ProcessID <> 0 Then            hModuleSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, _                XXXXXXXXXXX32ProcessID)            uModule.dwSize = Len(uModule)            Module32First hModuleSnap, uModule            If hModuleSnap > 0 Then                DoEvents                Sleep 10                ExePath = StripNulls(XXXXXXXXXXExePath)                If showMode = True Then                    XXXXXXXXXXXXXXXXXXption = GetLongPath(ExePath)                    nMemory = nMemory + 1                End If                If IsVirus(ExePath) Then                    hPID = OpenProcess(1&, -1&, XXXXXXXXXXX32ProcessID)                    hExitCode = TerminateProcess(hPID, 0&)                    Call CloseHandle(hPID)                End If            End If        End If        lProc = Process32Next(hProcSnap, uProcess)    Loop    Call CloseHandle(hProcSnap)End Sub
Public Function GetAppID() As Long    GetAppID = GetCurrentProcessIdEnd Function
Public Sub TerminateVirusProcess(strFileName As String)    On Error Resume Next    Dim ExePath As String    Dim hProcSnap As Long, hModuleSnap As Long, _        lProc As Long    Dim uProcess As PROCESSENTRY32, _        uModule As MODULEENTRY32    Dim hPID As Long, hExitCode As Long    ExePath = String$(128, Chr$(0))    hProcSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)    uProcess.dwSize = Len(uProcess)    lProc = Process32First(hProcSnap, uProcess)    Do While lProc        If XXXXXXXXXXX32ProcessID <> 0 Then            hModuleSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, _                XXXXXXXXXXX32ProcessID)            uModule.dwSize = Len(uModule)            Module32First hModuleSnap, uModule            If hModuleSnap > 0 Then                ExePath = StripNulls(XXXXXXXXXXExePath)                If ExePath = strFileName Then                    hPID = OpenProcess(1&, -1&, XXXXXXXXXXX32ProcessID)                    hExitCode = TerminateProcess(hPID, 0&)                    Call CloseHandle(hPID)                End If            End If        End If        lProc = Process32Next(hProcSnap, uProcess)    Loop    Call CloseHandle(hProcSnap)End Sub





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 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 LongPrivate Declare Function RegOpenKey Lib _    "advapi32.dll" Alias "RegOpenKeyA" ( _    ByVal hKey As Long, _    ByVal lpSubKey As String, _    phkResult As Long) As LongPrivate Declare Function RegDeleteValue Lib _    "advapi32.dll" Alias "RegDeleteValueA" ( _    ByVal hKey As Long, _    ByVal lpValueName As String) As LongPrivate 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 LongPrivate Declare Function RegCloseKey Lib _    "advapi32.dll" ( _    ByVal hKey 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 String, _    lpcbData As Long) As LongPrivate Declare Function RegQueryValueExA Lib _    "advapi32.dll" ( _    ByVal hKey As Long, _    ByVal lpValueName As String, _    ByVal lpReserved As Long, _    lpType As Long, _    ByRef lpData As Long, _    lpcbData As Long) As Long
Private Const ERROR_SUCCESS = 0&[s:9]rivate Const REG_SZ = 1&[s:9]rivate Const REG_DWORD = 4&[s:9]rivate Const KEY_QUERY_VALUE = &H1&[s:9]rivate Const KEY_SET_VALUE = &H2&[s:9]rivate Const KEY_ENUMERATE_SUB_KEYS = &H8&[s:9]rivate Const KEY_NOTIFY = &H10&[s:9]rivate Const READ_CONTROL = &H20000Private Const STANDARD_RIGHTS_READ = READ_CONTROLPrivate Const KEY_READ = STANDARD_RIGHTS_READ Or _    KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Dim MainKeyHandle As REGDim rtn As Long, lBuffer As Long, sBuffer As StringDim lBufferSize As LongDim lDataSize As LongDim lKey As Long
Public Enum REG    HKEY_CURRENT_USER = &H80000001    HKEY_CLASSES_ROOT = &H80000000    HKEY_CURRENT_CONFIG = &H80000005    HKEY_LOCAL_MACHINE = &H80000002    HKEY_USERS = &H80000003End Enum
Public Const SMP_KEY As String = "Software\Simple Machine Protect"
Public Function CreateRegistryKey(hKey As REG, sSubKey As String)    Dim lReg As Long    RegCreateKey hKey, sSubKey, lReg    RegCloseKey lRegEnd Function
Public Function GetDWORDValue(hKey As REG, SubKey As String, Entry As String)    Dim ret As Long    rtn = RegOpenKeyEx(hKey, SubKey, 0, KEY_READ, ret)    If rtn = ERROR_SUCCESS Then        rtn = RegQueryValueExA(ret, Entry, 0, REG_DWORD, lBuffer, 4)        If rtn = ERROR_SUCCESS Then            rtn = RegCloseKey(ret)            GetDWORDValue = lBuffer        Else            GetDWORDValue = "Error"        End If    Else        GetDWORDValue = "Error"    End IfEnd Function
Public Function GetSTRINGValue(hKey As REG, SubKey As String, Entry As String)    Dim ret As Long    rtn = RegOpenKeyEx(hKey, SubKey, 0, KEY_READ, ret)    If rtn = ERROR_SUCCESS Then        sBuffer = Space(255)        lBufferSize = Len(sBuffer)        rtn = RegQueryValueEx(ret, Entry, 0, REG_SZ, sBuffer, lBufferSize)        If rtn = ERROR_SUCCESS Then            rtn = RegCloseKey(ret)            sBuffer = Trim(sBuffer)            GetSTRINGValue = Left(sBuffer, Len(sBuffer) - 1)        Else            GetSTRINGValue = "Error"        End If    Else        GetSTRINGValue = "Error"    End IfEnd Function
Public Function CreateDwordValue(hKey As REG, SubKey As String, _    strValueName As String, dwordData As Long) As Long    Dim ret As Long    RegCreateKey hKey, SubKey, ret    CreateDwordValue = RegSetValueEx(ret, strValueName, 0, REG_DWORD, dwordData, 4)    RegCloseKey retEnd Function
Public Function CreateStringValue(hKey As REG, SubKey As String, _    strValueName As String, strdata As String) As Long    Dim ret As Long    RegCreateKey hKey, SubKey, ret    CreateStringValue = RegSetValueEx(ret, strValueName, 0, _        REG_SZ, ByVal strdata, Len(strdata))    RegCloseKey retEnd Function
Public Function DeleteValue(hKey As REG, SubKey As String, lpValName As String) As Long    Dim ret As Long    RegOpenKey hKey, SubKey, ret    DeleteValue = RegDeleteValue(ret, lpValName)    RegCloseKey retEnd Function


















Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPublic Enum ShowStyle    vbHide    vbMaximizedFocus    vbMinimizedFocus    vbMinimizedNoFocus    vbNormalFocus    vbNormalNoFocusEnd Enum
Public Function OpenFile(ByVal OpenName As String, Optional ByVal InitDir As String = vbNullString, Optional ByVal msgStyle As ShowStyle = vbNormalFocus)    ShellExecute 0&, vbNullString, OpenName, vbNullString, InitDir, msgStyleEnd Function









类模块代码下次送上