分类 [ 学习编程 ] 下的全部文章


frmMain.frm

VERSION 5.00
Begin VB.Form frmMain
BorderStyle =
1 'Fixed Single
Caption = "Usb卸载程序"
ClientHeight = 2445
ClientLeft = 45
ClientTop = 435
ClientWidth = 4425
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2445
ScaleWidth = 4425
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdAbout
Caption =
"关于(&A)"
Height = 375
Left = 1050
TabIndex = 4
Top = 1590
Width = 1005
End
Begin VB.CommandButton cmdExit
Cancel = -
1 'True
Caption = "退出(&C)"
Height = 375
Left = 3150
TabIndex = 3
Top = 1590
Width = 1005
End
Begin VB.CommandButton cmdUnLoad
Caption =
"卸载(&U)"
Default = -1 'True
Height = 375
Left = 2100
TabIndex = 2
Top = 1590
Width = 1005
End
Begin VB.TextBox txtUsbDrive
Height =
285
Left = 1530
TabIndex = 0
Top = 750
Width = 2625
End
Begin VB.Label lblMsg
AutoSize = -
1 'True
Caption = "输入USB盘符:"
Height = 180
Left = 240
TabIndex = 1
Top = 810
Width = 1080
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub
cmdAbout_Click()
Shell
"explorer /s , http://blog.csdn.net/chenhui530/"
MsgBox "欢迎大家使用我编写的卸载USB程序,如果您在使用中发现有什么BUG或者是好的建" & vbNewLine & "议可以到我的博客上留言反映情况。地址是: http://blog.csdn.net/chenhui530/", vbInformation, "关于"
End Sub

Private Sub
cmdExit_Click()
Unload
Me
End Sub

Private Sub
cmdUnLoad_Click()
Dim lngLenPath As Long, blnIsUsb As Boolean, strPath As String
lngLenPath = Len(txtUsbDrive.Text)
If lngLenPath <= 3 And Dir(txtUsbDrive.Text, 1 or 2 or 4 or vbDirectory) <> "" Then
If
lngLenPath = 2 Then
If
GetDriveBusType(txtUsbDrive.Text) <> "Usb" Then
MsgBox "只能解锁USB设备分区!!", vbCritical, "错误"
txtUsbDrive.SetFocus
Exit Sub
End If
strPath = txtUsbDrive.Text & "\"
ElseIf lngLenPath = 1 Then
If
GetDriveBusType(txtUsbDrive.Text & ":") <> "Usb" Then
Msg
Box
"只能解锁USB设备分区!!", vbCritical, "错误"
txtUsbDrive.SetFocus
Exit Sub
End If
strPath = txtUsbDrive.Text & ":\"
Else
If
GetDriveBusType(Left(txtUsbDrive.Text, 2)) <> "Usb" Then
MsgBox "只能解锁USB设备分区!!", vbCritical, "错误"
txtUsbDrive.SetFocus
Exit Sub
End If
strPath = txtUsbDrive.Text
End If
blnIsUsb = True
Else
MsgBox "您输入的USB盘符不要求!!", vbCritical, "错误"
txtUsbDrive.SetFocus
Exit Sub
End If
Me.cmdUnLoad.Enabled = False
Me.cmdExit.Enabled = False
'这里只检测本进程因为在获取驱动器类型的时候会打开一个句柄但是WINDOWS没有自己关闭所以用这个来
'解除锁定,当然你也可以使用CloseLoackFiles函数来检测所有进程
If CloseLockFileHandle(Left(strPath, 2), GetCurrentProcessId) Then
If
blnIsUsb Then
If
RemoveUsbDrive("\\.\" & Left(strPath, 2), True) Then
MsgBox "卸载UBS设备成功!!", , "提示"
Else
MsgBox "但卸载UBS设备失败!!", vbCritical, "提示"
End If
End If
Else
MsgBox "发现有锁定文件还没解锁!!", vbCritical, "提示"
End If
Me.cmdUnLoad.Enabled = True
Me.cmdExit.Enabled = True
End Sub


modGetDriveType.bas

Attribute VB_Name = "modGetDriveType"
Option Explicit
'**************************************
'此模块来自于网络
'**************************************
'判断驱动器的类型

Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Const
DRIVE_UNKNOWN = 0 '驱动器类型无法确定
Private Const DRIVE_NO_ROOT_DIR = 1 '驱动器根目录不存在
Private Const DRIVE_REMOVABLE = 2 '软盘驱动器或可移动盘
Private Const DRIVE_FIXED = 3 '硬盘驱动器
Private Const DRIVE_REMOTE = 4 'Network 驱动器
Private Const DRIVE_CDROM = 5 '光盘驱动器
Private Const DRIVE_RAMDISK = 6 'RAM 存储器

'*************************************************************************************

' CreateFile获取设备句柄

'参数
'lpFileName 文件名
'dwDesiredAccess 访问方式
'dwShareMode 共享方式
'ATTRIBUTES lpSecurityAttributes 安全描述符指针
'dwCreationDisposition 创建方式
'dwFlagsAndAttributes 文件属性及标志
' hTemplateFile 模板文件的句柄

'CreateFile这个函数用处很多,这里我们用它「打开」设备驱动程序,得到设备的句柄。
'操作完成後用CloseHandle关闭设备句柄。
'与普通文件名有所不同,设备驱动的「文件名」形式固定为「\\.\DeviceName」(注意在C程序中该字符串写法为「\\\\.\\DeviceName」)
'DeviceName必须与设备驱动程序内规定的设备名称一致。
'一般地,调用CreateFile获得设备句柄时,访问方式参数设置为0或GENERIC_READ|GENERIC_WRITE
'共享方式参数设置为FILE_SHARE_READ|FILE_SHARE_WRITE,创建方式参数设置为OPEN_EXISTING,其它参数设置为0或NULL。

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function
CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const
GENERIC_READ = &H80000000 '允许对设备进行读访问
Private Const FILE_SHARE_READ = &H1 '允许读取共享
Private Const OPEN_EXISTING = 3 '文件必须已经存在。由设备提出要求
Private Const FILE_SHARE_WRITE = &H2 '允许对文件进行共享访问

'************************************************************************************

'DeviceIoControl说明

'用途 实现对设备的访问—获取信息,发送命令,交换数据等。

'参数
'hDevice 设备句柄
'dwIoControlCode 控制码
'lpInBuffer 输入数据缓冲区指针
'nInBufferSize 输入数据缓冲区长度
'lpOutBuffer 输出数据缓冲区指针
'nOutBufferSize 输出数据缓冲区长度
'lpBytesReturned 输出数据实际长度单元长度
'lpOverlapped 重叠操作结构指针
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long

Private
Type SECURITY_ATTRIBUTES
nLength
As Long '结构体的大小
lpSecurityDescriptor As Long '安全描述符(一个C-Style的字符串)。
bInheritHandle As Long '所创建出来的东西是可以被其他的子进程使用的
End Type

'查询存储设备还是适配器属性
Private Enum STORAGE_PROPERTY_ID
StorageDeviceProperty =
0 '查询设备属性
StorageAdapterProperty '查询适配器属性
End Enum

'查询存储设备属性的类型
Private Enum STORAGE_QUERY_TYPE
PropertyStandardQuery =
0 '读取描述
PropertyExistsQuery '测试是否支持
PropertyMaskQuery '读取指定的描述
PropertyQueryMaxDefined '验证数据
End Enum

'查询属性输入的数据结构
Private Type STORAGE_PROPERTY_QUERY
PropertyId
As STORAGE_PROPERTY_ID '设备/适配器
QueryType As STORAGE_QUERY_TYPE '查询类型
AdditionalParameters(0) As Byte '额外的数据(仅定义了象徵性的1个字节)
End Type

Private Type OVERLAPPED
Internal
As Long '保留给操作系统使用。用于保存系统状态,当GetOverLappedRseult的返回值中没有设置ERROR_IO_PENDING时,本域为有效。
InternalHigh As Long '成员保留给操作系统使用。用于保存异步传输数据的长度。当GetOverLappedRseult返回TRUE时,本域为有效。
offset As Long '指定开始进行异步传输的文件的一个位置。该位置是距离文件开头处的偏移值。在调用ReadFile或WriteFile之前,必须设置此分量。
OffsetHigh As Long '指定开始异步传输处的字节偏移的高位字部分。
hEvent As Long '指向一个事件的句柄,当传输完后将其设置为信号状态。
End Type

'存储设备的总线类型
Private Enum STORAGE_BUS_TYPE
BusTypeUnknown =
0
BusTypeScsi
BusTypeAtapi
BusTypeAta
BusType1394
BusTypeSsa
BusTypeFibre
BusTypeUsb
BusTypeRAID
BusTypeMaxReserved =
&H7F
End Enum

'查询属性输出的数据结构
Private Type STORAGE_DEVICE_DESCRIPTOR
Version
As Long '版本
Size As Long '结构大小
DeviceType As Byte '设备类型
DeviceTypeModifier As Byte 'SCSI-2额外的设备类型
RemovableMedia "#0000FF">As Byte '是否可移动
CommandQueueing As Byte '是否支持命令队列
VendorIdOffset As Long '厂家设定值的偏移
ProductIdOffset As Long '产品ID的偏移
ProductRevisionOffset As Long '产品版本的偏移
SerialNumberOffset As Long '序列号的偏移
BusType As STORAGE_BUS_TYPE '总线类型
RawPropertiesLength As Long '额外的属性数据长度
RawDeviceProperties(0) As Byte '额外的属性数据(仅定义了象徵性的1个字节)
End Type

'计算控制码 IOCTL_STORAGE_QUERY_PROPERTY
Private Const IOCTL_STORAGE_BASE As Long = &H2D
Private Const METHOD_BUFFERED = 0
Private Const FILE_ANY_ACCESS = 0

'获取磁盘属性
Private Function GetDisksProperty(ByVal hDevice As Long, utDevDesc As STORAGE_DEVICE_DESCRIPTOR) As Boolean
Dim
ut As OVERLAPPED
Dim utQuery As STORAGE_PROPERTY_QUERY
Dim lOutBytes As Long
With
utQuery
.PropertyId = StorageDeviceProperty
.QueryType = PropertyStandardQuery
End With
GetDisksProperty = DeviceIoControl(hDevice, IOCTL_STORAGE_QUERY_PROPERTY, utQuery, LenB(utQuery), utDevDesc, LenB(utDevDesc), lOutBytes, ut)
End Function

Private Function
CTL_CODE(ByVal lDeviceType As Long, ByVal lFunction As Long, ByVal lMethod As Long, ByVal lAccess As Long) As Long
CTL_CODE = (lDeviceType * 2 ^ 16&) or (lAccess * 2 ^ 14&) or (lFunction * 2 ^ 2) or (lMethod)
End Function

'获取设备属性信息,希望得到系统中所安装的各种固定的和可移动的硬盘、优盘和CD/DVD-ROM/R/W的接口类型、序列号、产品ID等信息。
Private Function IOCTL_STORAGE_QUERY_PROPERTY() As Long
IOCTL_STORAGE_QUERY_PROPERTY = CTL_CODE(IOCTL_STORAGE_BASE, &H500, METHOD_BUFFERED, FILE_ANY_ACCESS)
End Function

'获取驱动器总线类型
Public Function GetDriveBusType(ByVal strDriveLetter As String) As String
Dim
hDevice As Long
Dim
utDevDesc As STORAGE_DEVICE_DESCRIPTOR
hDevice = CreateFile(
"\\.\" & strDriveLetter, GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If hDevice <> -1 Then
utDevDesc.Size = LenB(utDevDesc)
Call GetDisksProperty(hDevice, utDevDesc)
Select Case utDevDesc.BusType
Case BusType1394
GetDriveBusType =
"1394"
Case BusTypeAta
GetDriveBusType =
"Ata"
Case BusTypeAtapi
GetDriveBusType =
"Atapi"
Case BusTypeFibre
GetDriveBusType =
"Fibre"
Case BusTypeRAID
GetDriveBusType =
"RAID"
Case BusTypeScsi
GetDriveBusType =
"Scsi"
Case BusTypeSsa
GetDriveBusType =
"Ssa"
Case BusTypeUsb
GetDriveBusType =
"Usb"
Case BusTypeUnknown
GetDriveBusType =
"未知"
>Case Else
End Select
Call
CloseHandle(hDevice)
End If
End Function


modLockFileInfo.bas

Attribute VB_Name = "modLockFileInfo"
Option Explicit

Private Declare Function NtQueryInformationProcess Lib "NTDLL.DLL" (ByVal ProcessHandle As Long, _
ByVal ProcessInformationClass As PROCESSINFOCLASS, _
ByVal ProcessInformation As Long, _
ByVal ProcessInformationLength As Long, _
ByRef ReturnLength As Long) As Long

Private Enum
PROCESSINFOCLASS
ProcessBasicInformation =
0
ProcessQuotaLimits
ProcessIoCounters
ProcessVmCounters
ProcessTimes
ProcessBasePriority
ProcessRaisePriority
ProcessDebugPort
ProcessExceptionPort
ProcessAccessToken
ProcessLdtInformation
ProcessLdtSize
ProcessDefaultHardErrorMode
ProcessIoPortHandlers
ProcessPooledUsageAndLimits
ProcessWorkingSetWatch
ProcessUserModeIOPL
ProcessEnableAlignmentFaultFixup
ProcessPriorityClass
ProcessWx86Information
ProcessHandleCount
ProcessAffinityMask
ProcessPriorityBoost
ProcessDeviceMap
ProcessSessionInformation
ProcessForegroundInformation
ProcessWow64Information
ProcessImageFileName
ProcessLUIDDeviceMapsEnabled
ProcessBreakOnTermination
ProcessDebugObjectHandle
ProcessDebugFlags
ProcessHandleTracing
ProcessIoPriority
ProcessExecuteFlags
ProcessResourceManagement
ProcessCookie
ProcessImageInformation
MaxProcessInfoClass
End Enum

Private
Type PROCESS_BASIC_INFORMATION
ExitStatus
As Long 'NTSTATUS
PebBaseAddress As Long 'PPEB
AffinityMask As Long 'ULONG_PTR
BasePriority As Long 'KPRIORITY
UniqueProcessId As Long 'ULONG_PTR
InheritedFromUniqueProcessId As Long 'ULONG_PTR
End Type

Private Type FILE_NAME_INFORMATION
FileNameLength
As Long
FileName(3) As Byte
End
Type

Private Type NM_INFO
Info
As FILE_NAME_INFORMATION
strName(
259) As Byte
End
Type

Private Enum FileInformationClass
FileDirectoryInformation =
1
FileFullDirectoryInformation = 2
FileBothDirectoryInformation = 3
FileBasicInformation = 4
FileStandardInformation = 5
FileInternalInformation = 6
FileEaInformation = 7
FileAccessInformation = 8
FileNameInformation = 9
FileRenameInformation = 10
FileLinkInformation = 11
FileNamesInformation = 12
FileDispositionInformation = 13
FilePositionInformation = 14
FileFullEaInformation = 15
FileModeInformation = 16
FileAlignmentInformation = 17
FileAllInformation = 18
FileAllocationInformation = 19
FileEndOfFileInformation = 20
FileAlternateNameInformation = 21
FileStreamInformation = 22
FilePipeInformation = 23
FilePipeLocalInformation = 24
FilePipeRemoteInformation = 25
FileMailslotQueryInformation = 26
FileMailslotSetInformation = 27
FileCompressionInformation = 28
FileObjectIdInformation = 29
FileCompletionInformation = 30
FileMoveClusterInformation = 31
FileQuotaInformation = 32
FileReparsePointInformation = 33
FileNetworkOpenInformation = 34
FileAttributeTagInformation = 35
FileTrackingInformation = 36
FileMaximumInformation
End Enum

Private Declare Function
NtQuerySystemInformation <
font color="#0000FF">Lib "NTDLL.DLL" (ByVal SystemInformationClass As SYSTEM_INFORMATION_CLASS, _
ByVal pSystemInformation As Long, _
ByVal SystemInformationLength As Long, _
ByRef ReturnLength As Long) As Long


Private Enum
SYSTEM_INFORMATION_CLASS
SystemBasicInformation
SystemProcessorInformation
'// obsolete...delete
SystemPerformanceInformation
SystemTimeOfDayInformation
SystemPathInformation
SystemProcessInformation
SystemCallCountInformation
SystemDeviceInformation
SystemProcessorPerformanceInformation
SystemFlagsInformation
SystemCallTimeInformation
SystemModuleInformation
SystemLocksInformation
SystemStackTraceInformation
SystemPagedPoolInformation
SystemNonPagedPoolInformation
SystemHandleInformation
SystemObjectInformation
SystemPageFileInformation
SystemVdmInstemulInformation
SystemVdmBopInformation
SystemFileCacheInformation
SystemPoolTagInformation
SystemInterruptInformation
SystemDpcBehaviorInformation
SystemFullMemoryInformation
SystemLoadGdiDriverInformation
SystemUnloadGdiDriverInformation
SystemTimeAdjustmentInformation
SystemSummaryMemoryInformation
SystemMirrorMemoryInformation
SystemPerformanceTraceInformation
SystemObsolete0
SystemExceptionInformation
SystemCrashDumpStateInformation
SystemKernelDebuggerInformation
SystemContextSwitchInformation
SystemRegistryQuotaInformation
SystemExtendServiceTableInformation
SystemPrioritySeperation
SystemVerifierAddDriverInformation
SystemVerifierRemoveDriverInformation
SystemProcessorIdleInformation
SystemLegacyDriverInformation
SystemCurrentTimeZoneInformation
SystemLookasideInformation
SystemTimeSlipNotification
SystemSessionCreate
SystemSessionDetach
SystemSessionInformation
SystemRangeStartInformation
SystemVerifierInformation
SystemVerifierThunkExtend
SystemSessionProcessInformation
SystemLoadGdiDriverInSystemSpace
SystemNumaProcessorMap
SystemPrefetcherInformation
SystemExtendedProcessInformation
SystemRecommendedSharedDataAlignment
SystemComPlusPackage
SystemNumaAvailableMemory
SystemProcessorPowerInformation
SystemEmulationBasicInformation
SystemEmulationProcessorInformation
SystemExtendedHandleInformation
SystemLostDelayedWriteInformation
SystemBigPoolInformation
SystemSessionPoolTagInformation
SystemSessionMappedViewInformation
SystemHotpatchInformation
SystemObjectSecurityMode
SystemWatchdogTimerHandler
SystemWatchdogTimerInformation
SystemLogicalProcessorInformation
SystemWow64SharedInformation
SystemRegisterFirmwareTableInformationHandler
SystemFirmwareTableInformation
SystemModuleInformationEx
SystemVerifierTriageInformation
SystemSuperfetchInformation
SystemMemoryListInformation
SystemFileCacheInformationEx
MaxSystemInfoClass
'// MaxSystemInfoClass should always be the last enum
End Enum

Private
Type SYSTEM_HANDLE
UniqueProcessId
As Integer
CreatorBackTraceIndex As Integer
ObjectTypeIndex As Byte
HandleAttributes As Byte
HandleValue As Integer
pObject As Long
GrantedAccess As Long
End
Type

Private Const STATUS_INFO_LENGTH_MISMATCH = &HC0000004

Private Enum SYSTEM_HANDLE_TYPE
OB_TYPE_UNKNOWN =
0
OB_TYPE_TYPE = 1
OB_TYPE_DIRECTORY
OB_TYPE_SYMBOLIC_LINK
OB_TYPE_TOKEN
OB_TYPE_PROCESS
OB_TYPE_THREAD
OB_TYPE_UNKNOWN_7
OB_TYPE_EVENT
OB_TYPE_EVENT_PAIR
OB_TYPE_MUTANT
OB_TYPE_UNKNOWN_11
OB_TYPE_SEMAPHORE
OB_TYPE_TIMER
OB_TYPE_PROFILE
OB_TYPE_WINDOW_STATION
OB_TYPE_DESKTOP
OB_TYPE_SECTION
OB_TYPE_KEY
OB_TYPE_PORT
OB_TYPE_WAITABLE_PORT
OB_TYPE_UNKNOWN_21
OB_TYPE_UNKNOWN_22
OB_TYPE_UNKNOWN_23
OB_TYPE_UNKNOWN_24
OB_TYPE_IO_COMPLETION
OB_TYPE_FILE
End Enum

'typedef struct _SYSTEM_HANDLE_INFORMATION
'{
' ULONG uCount;
' SYSTEM_HANDLE aSH[];
'} SYSTEM_HANDLE_INFORMATION, *PSYSTEM_HANDLE_INFORMATION;

Private Type SYSTEM_HANDLE_INFORMATION
uCount
As Long
aSH() As SYSTEM_HANDLE
End Type

Private Declare Function NtDuplicateObject Lib "NTDLL.DLL" (ByVal SourceProcessHandle As Long, _
ByVal SourceHandle As Long, _
ByVal TargetProcessHandle As Long, _
ByRef TargetHandle As Long, _
ByVal DesiredAccess As Long, _
ByVal HandleAttributes As Long, _
ByVal Options As Long) As Long

Private Const
DUPLICATE_CLOSE_SOURCE = nt color="#800080">&H1

Private Const DUPLICATE_SAME_ACCESS = &H2

Private Const DUPLICATE_SAME_ATTRIBUTES = &H4

Private Declare Function NtOpenProcess Lib "NTDLL.DLL" (ByRef ProcessHandle As Long, _
ByVal AccessMask As Long, _
ByRef ObjectAttributes As OBJECT_ATTRIBUTES, _
ByRef ClientID As CLIENT_ID) As Long

Private
Type OBJECT_ATTRIBUTES
Length
As Long
RootDirectory As Long
ObjectName As Long
Attributes As Long
SecurityDescriptor As Long
SecurityQualityOfService As Long
End
Type

Private Type CLIENT_ID
UniqueProcess
As Long
UniqueThread As Long
End
Type

Private Type IO_STATUS_BLOCK
Status
As Long
uInformation As Long
End
Type

Private Const PROCESS_Create_THREAD = &H2

Private Const PROCESS_VM_WRITE = &H20
Private Const PROCESS_VM_OPERATION = &H8

Private Const PROCESS_QUERY_INFORMATION As Long = (&H400)

Private Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000

Private Const SYNCHRONIZE As Long = &H100000

Private Const PROCESS_ALL_ACCESS As Long = (STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or &HFFF)

Private Const PROCESS_DUP_HANDLE As Long = (&H40)

Private Declare Function NtClose Lib "NTDLL.DLL" (ByVal ObjectHandle As Long) As Long

Private Declare Sub
CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long

'typedef struct _OBJECT_NAME_INFORMATION
'{
' UNICODE_STRING Name;
'} OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION;
'typedef enum _OBJECT_INFORMATION_CLASS
'{
' ObjectBasicInformation, // 0 Y N
' ObjectNameInformation, // 1 Y N
' ObjectTypeInformation, // 2 Y N
' ObjectAllTypesInformation, // 3 Y N
' ObjectHandleInformation // 4 Y Y
'} OBJECT_INFORMATION_CLASS;
Private Enum OBJECT_INFORMATION_CLASS
ObjectBasicInformation =
0
ObjectNameInformation
ObjectTypeInformation
ObjectAllTypesInformation
ObjectHandleInformation
End Enum
'
'typedef struct _UNICODE_STRING
'{
' USHORT Length;
' USHORT MaximumLength;
' PWSTR Buffer;
'} UNICODE_STRING, *PUNICODE_STRING;
Private Type UNICODE_STRING
uLength
As Integer
uMaximumLength As Integer
pBuffer(3) As Byte
End
Type

Private Type O
BJECT_NAME_INFORMATION
pName
As UNICODE_STRING
End Type
Private Const STATUS_INFO_LEN_MISMATCH = &HC0000004
Private Const HEAP_ZERO_MEMORY = &H8
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function
GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function
TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function
GetProcessHeap Lib "kernel32" () As Long
Private Declare Function
HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function
HeapReAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any, ByVal dwBytes As Long) As Long
Private Declare Function
HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
'Private Declare Function NtQueryObject Lib "NTDLL.DLL" (ByVal ObjectHandle As Long, _
' ByVal ObjectInformationClass As OBJECT_INFORMATION_CLASS, _
' ObjectInformation As Any, ByVal ObjectInformationLength As Long, _
' ReturnLength As Long) As Long
Private Declare Function NtQueryObject Lib "NTDLL.DLL" (ByVal ObjectHandle As Long, _
ByVal ObjectInformationClass As OBJECT_INFORMATION_CLASS, _
ByVal ObjectInformation As Long, ByVal ObjectInformationLength As Long, _
ReturnLength
As Long) As Long
Private Declare Function
lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function
QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Declare Function
GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function
lstrcpyW Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Public Declare Function
MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function
CreateRemoteThread lor="#0000FF">Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function
WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
'Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function
LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function
FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function
GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function
GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function
TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function
GetFileType Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function
ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long

Private Function
NT_SUCCESS(ByVal nStatus As Long) As Boolean
NT_SUCCESS = (nStatus >= 0)
End Function

Public Function
GetFileFullPath(ByVal hFile As Long) As String
Dim
hHeap As Long, dwSize As Long, objName As UNICODE_STRING, pName As Long
Dim
ntStatus As Long, i As Long, lngNameSize As Long, strDrives As String, strArray() As String
Dim
dwDriversSize As Long, strDrive As String, strTmp As String, strTemp As String
On Error GoTo
ErrHandle
hHeap = GetProcessHeap
pName = HeapAlloc(hHeap, HEAP_ZERO_MEMORY,
&H1000)
ntStatus = NtQueryObject(hFile, ObjectNameInformation, pName,
&H1000, dwSize)
If (NT_SUCCESS(ntStatus)) Then
i = 1
Do While (ntStatus = STATUS_INFO_LEN_MISMATCH)
pName = HeapReAlloc(hHeap, HEAP_ZERO_MEMORY, pName,
&H1000 * i)
ntStatus = NtQueryObject(hFile, ObjectNameInformation, pName,
&H1000, ByVal 0)
i = i +
1
Loop
End If
HeapFree hHeap, t color="#800080">0, pName
strTemp =
String(512, Chr(0))
lstrcpyW strTemp, pName + Len(objName)
strTemp = StrConv(strTemp, vbFromUnicode)
strTemp = Left(strTemp, InStr(strTemp, Chr(
0)) - 1)
strDrives =
String(512, Chr(9))
dwDriversSize = GetLogicalDriveStrings(
512, strDrives)
If dwDriversSize Then
strArray = Split(strDrives, Chr(0))
For i = 0 To UBound(strArray)
If strArray(i) <> "" Then
strDrive = Left(strArray(i), 2)
strTmp =
String(260, Chr(0))
Call QueryDosDevice(strDrive, strTmp, 256)
strTmp = Left(strTmp, InStr(strTmp, Chr(
0)) - 1)
If InStr(LCase(strTemp), LCase(strTmp)) = 1 Then
GetFileFullPath = strDrive & Mid(strTemp, Len(strTmp) + 1, Len(strTemp) - Len(strTmp))
Exit Function
End If
End If
Next
End If
ErrHandle:
End Function

Public Function
CloseLockFileHandle(ByVal strFileName As String, ByVal dwProcessId As Long) As Boolean
Dim
ntStatus As Long
Dim
objCid As CLIENT_ID
Dim objOa As OBJECT_ATTRIBUTES
Dim lngHandles As Long
Dim
i As Long
Dim
objInfo As SYSTEM_HANDLE_INFORMATION, lngType As Long
Dim
hProcess As Long, hProcessToDup As Long, hFileHandle As Long
Dim
hFile As Long
'Dim objIo As IO_STATUS_BLOCK, objFn As FILE_NAME_INFORMATION, objN As NM_INFO
Dim bytBytes() As Byte, strSubPath As String, strTmp As String
Dim
blnIsOk As Boolean
strSubPath = Mid(strFileName, 3, Len(strFileName) - 2)
hFile = CreateFile(
"NUL", &H80000000, 0, ByVal 0&, 3, 0, 0)
If hFile = -1 Then
CloseLockFileHandle = False
Exit Function
End If
objOa.Length = Len(objOa)
objCid.UniqueProcess = dwProcessId
ntStatus =
0
Dim bytBuf() As Byte
Dim
nSize As Long
nSize = 1
Do
ReDim
bytBuf(nSize)
ntStatus = NtQuerySystemInformation(SystemHandleInformation, VarPtr(bytBuf(
0)), nSize, 0&)
If (Not NT_SUCCESS(ntStatus)) Then
If
(ntStatus <> STATUS_INFO_LENGTH_MISMATCH) Then
Erase
bytBuf
Exit Function
End If
Else
Exit Do
End If
nSize = nSize * 2
ReDim bytBuf(nSize)
Loop
lngHandles = 0
CopyMemory objInfo.uCount, bytBuf(0), 4
lngHandles = objInfo.uCount
ReDim objInfo.aSH(lngHandles - 1)
Call CopyMemory(objInfo.aSH(0), bytBuf(4), Len(objInfo.aSH(0)) * lngHandles)
For i = 0 To >lngHandles - 1
If objInfo.aSH(i).HandleValue = hFile And objInfo.aSH(i).UniqueProcessId = GetCurrentProcessId Then
lngType = objInfo.aSH(i).ObjectTypeIndex
Exit For
End If
Next
NtClose hFile
blnIsOk =
True
For
i = 0 To lngHandles - 1
If objInfo.aSH(i).ObjectTypeIndex = lngType And objInfo.aSH(i).UniqueProcessId = dwProcessId Then
ntStatus = NtOpenProcess(hProcessToDup, PROCESS_DUP_HANDLE, objOa, objCid)
If hProcessToDup <> 0 Then
ntStatus = NtDuplicateObject(hProcessToDup, objInfo.aSH(i).HandleValue, GetCurrentProcess, hFileHandle, 0, 0, DUPLICATE_SAME_ATTRIBUTES)
If (NT_SUCCESS(ntStatus)) Then
'这里如果直接调用NtQueryObject可能会挂起解决方法是用线程去处理当线程处理时间超过一定时间就把它干掉
'由于VB对多线程支持很差,其实应该说是对CreateThread支持很差,什么原因不要问我,相信网上也写有不少
'文件是关于它的,这里我选择了另一个函数也可以建立线程但是它是建立远程线程的,不过它却很稳定正好解决了
'我们这里的问题它就是CreateRemoteThread,^_^还记得我说过它很强大吧~~哈哈。
ntStatus = MyGetFileType(hFileHandle)
If ntStatus Then
strTmp = GetFileFullPath(hFileHandle)
End If
NtClose hFileHandle
If InStr(LCase(strTmp), LCase(strFileName)) Then
If Not
CloseRemoteHandle(dwProcessId, objInfo.aSH(i).HandleValue, strFileName) Then
blnIsOk = False
End If
End If
End If
End If
End If
Next
CloseLockFileHandle = blnIsOk
End Function

'检测所有进程
Public Function CloseLoackFiles(ByVal strFileName As String) As Boolean
Dim
ntStatus As Long
Dim
objCid As CLIENT_ID
Dim objOa As OBJECT_ATTRIBUTES
Dim lngHandles As Long
Dim
i As Long
Dim
objInfo As SYSTEM_HANDLE_INFORMATION, lngType As Long
Dim
hProcess As Long, hProcessToDup As Long, hFileHandle As Long
Dim
hFile As Long, blnIsOk As Boolean, strProcessName As String
'Dim objIo As IO_STATUS_BLOCK, objFn As FILE_NAME_INFORMATION, objN As NM_INFO
Dim bytBytes() As Byte, strSubPath As String, strTmp As String
strSubPath = Mid(strFileName, 3, Len(strFileName) - 2)
hFile = CreateFile(
"NUL", &H80000000, 0, ByVal 0&, 3, 0, 0)
If hFile = -1 Then
CloseLoackFiles = False
Exit Function
End If
objOa.Length = Len(objOa)
ntStatus =
0
Dim bytBuf() As Byte
Dim
nSize As Long
nSize = 1
Do
ReDim
bytBuf(nSize)
ntStatus = NtQuerySystemInformation(SystemHandleInformation, VarPtr(bytBuf(
0)), nSize, 0&)
If (Not NT_SUCCESS(ntStatus)) Then
If
(ntStatus <> STATUS_INFO_LENGTH_MISMATCH) Then
Erase
bytBuf
Exit Function
End If
Else
Exit Do
End If
nSize = nSize * 2
ReDim bytBuf(nSize)
Loop
lngHandles = 0
CopyMemory objInfo.uCount, bytBuf(0), 4
lngHandles = objInfo.uCount
ReDim objInfo.aSH(lngHandles - 1)
Call CopyMemory(objInfo.aSH(0), bytBuf(4), Len(objInfo.aSH(0)) * lngHandles)
For i = 0 To lngHandles - 1
If objInfo.aSH(i).HandleValue = hFile And objInfo.aSH(i).UniqueProcessId = GetCurrentProcessId Then
lngType = objInfo.aSH(i).ObjectTypeIndex
Exit For
End If
Next
NtClose hFile
blnIsOk =
True
For
i = 0 To lngHandles - 1
If objInfo.aSH(i).ObjectTypeIndex = lngType Then
objCid.UniqueProcess = objInfo.aSH(i).UniqueProcessId
ntStatus = NtOpenProcess(hProcessToDup, PROCESS_DUP_HANDLE, objOa, objCid)
If hProcessToDup <> 0 Then
ntStatus = NtDuplicateObject(hProcessToDup, objInfo.aSH(i).HandleValue, GetCurrentProcess, hFileHandle, 0, 0, DUPLICATE_SAME_ATTRIBUTES)
If (NT_SUCCESS(ntStatus)) Then
'这里如果直接调用NtQueryObject可能会挂起解决方法是用线程去处理当线程处理时间超过一定时间就把它干掉
'由于VB对多线程支持很差,其实应该说是对CreateThread支持很差,什么原因不要问我,相信网上也写有不少
'文件是关于它的,这里我选择了另一个函数也可以建立线程但是它是建立远程线程的,不过它却很稳定正好解决了
'我们这里的问题它就是CreateRemoteThread,^_^还记得我说过它很强大吧~~哈哈。
ntStatus = MyGetFileType(hFileHandle)
If ntStatus Then
strTmp = GetFileFullPath(hFileHandle)
Else
strTmp = ""
End If
NtClose hFileHandle
If InStr(LCase(strTmp), LCase(strFileName)) Then
If Not
CloseRemoteHandle(objInfo.aSH(i).UniqueProcessId, objInfo.aSH(i).HandleValue, strTmp) Then
blnIsOk = False
End If
End If
End If
End If
End If
Next
CloseLoackFiles = blnIsOk
End Function

Private Function
GetProcessCommandLine(ByVal dwProcessId As Long) As String
Dim
objCid As CLIENT_ID
Dim objOa As OBJECT_ATTRIBUTES
Dim ntStatus As Long, hKernel As Long, strName As String
Dim
hProcess As Long, dwAddr As Long, dwRead As Long
objOa.Length = Len(objOa)
objCid.UniqueProcess = dwProcessId
ntStatus = NtOpenProcess(hProcess,
&H10, objOa, objCid)
If hProcess = 0 Then
GetProcessCommandLine = ""
Exit Function
End If
hKernel = GetModuleHandle("kernel32")
dwAddr = GetProcAddress(hKernel,
"GetCommandLineA")
CopyMemory dwAddr,
ByVal dwAddr + 1, 4
If ReadProcessMemory(hProcess, ByVal dwAddr, dwAddr, 4, dwRead) Then
strName = String(260, Chr(0))
If ReadProcessMemory(hProcess, ByVal dwAddr, ByVal strName, 260, dwRead) Then
strName = Left(strName, InStr(strName, Chr(0)) - 1)
NtClose hProcess
GetProcessCommandLine = strName
Exit Function
End If
End If
NtClose hProcess
End Function

'解锁指定进程的锁定文件
Public Function CloseRemoteHandle(ByVal dwProcessId, ByVal hHandle As Long, Optional ByVal ont color="#000000">strLockFile
As String = "") As Boolean
Dim
hMyProcess As Long, hRemProcess As Long, blnResult As Long, hMyHandle As Long
Dim
objCid As CLIENT_ID
Dim objOa As OBJECT_ATTRIBUTES
Dim ntStatus As Long, strProcessName As String, hProcess As Long, strMsg As String
objCid.UniqueProcess = dwProcessId
objOa.Length = Len(objOa)
hMyProcess = GetCurrentProcess()
ntStatus = NtOpenProcess(hRemProcess, PROCESS_DUP_HANDLE, objOa, objCid)
If hRemProcess Then
ntStatus = NtDuplicateObject(hRemProcess, hHandle, GetCurrentProcess, hMyHandle, 0, 0, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS)
If (NT_SUCCESS(ntStatus)) Then
'If DuplicateHandle(hRemProcess, hMyProcess, hHandle, hMyHandle, 0, 0, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS) Then
blnResult = NtClose(hMyHandle)
If blnResult >= 0 Then
strProcessName = GetProcessCommandLine(dwProcessId)
'If InStr(LCase(strProcessName), LCase(strLockFile)) Then
If InStr(LCase(strProcessName), "explorer.exe") = 0 And dwProcessId <> GetCurrentProcessId Then
objCid.UniqueProcess = dwProcessId
ntStatus = NtOpenProcess(hProcess,
1, objOa, objCid)
If hProcess <> 0 Then TerminateProcess hProcess, 0
End If
End If
End If
Call
NtClose(hRemProcess)
End If
CloseRemoteHandle = blnResult >= 0
End Function


'解锁指定进程的锁定文件
Public Function CloseRemoteHandleEx(ByVal dwProcessId, ByVal hHandle As Long, Optional ByVal strLockFile As String = "") As Boolean
Dim
hRemProcess As Long, hThread As Long, lngResult As Long, pfnThreadRtn As Long, hKernel As Long
Dim
objCid As CLIENT_ID
Dim objOa As OBJECT_ATTRIBUTES, strMsg As String
Dim
ntStatus As Long, strProcessName As String, hProcess As Long
objCid.UniqueProcess = dwProcessId
objOa.Length = Len(objOa)
ntStatus = NtOpenProcess(hRemProcess, PROCESS_QUERY_INFORMATION
or PROCESS_Create_THREAD or PROCESS_VM_OPERATION or PROCESS_VM_WRITE, objOa, objCid)
' hMyProcess = OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_Create_THREAD or PROCESS_VM_OPERATION or PROCESS_VM_WRITE, 0, dwProcessId)
If hRemProcess = 0 Then
CloseRemoteHandleEx = False
Exit Function
End If
hKernel = GetModuleHandle("kernel32")
If hKernel = 0 Then
CloseRemoteHandleEx = False
Exit Function
End If
pfnThreadRtn = GetProcAddress(hKernel, "CloseHandle")
If pfnThreadRtn = 0 Then
FreeLibrary hKernel
CloseRemoteHandleEx =
False
Exit Function
End If
hThread = CreateRemoteThread(hRemProcess, ByVal 0&, 0&, ByVal pfnThreadRtn, ByVal hHandle, 0, 0&)
If hThread = 0 Then
FreeLibrary hKernel
CloseRemoteHandleEx =
False
Exit Function
End If
GetExitCodeThread hThread, lngResult
CloseRemoteHandleEx =
CBool(lngResult)
strProcessName = GetP
rocessCommandLine(dwProcessId)
If InStr(strProcessName, strLockFile) Then
objCid.UniqueProcess = dwProcessId
ntStatus = NtOpenProcess(hProcess,
1, objOa, objCid)
If hProcess <> 0 Then TerminateProcess hProcess, 0
End If
NtClose hThread
NtClose hRemProcess
FreeLibrary hKernel
End Function

Private Function
MyGetFileType(ByVal hFile As Long) As Long
Dim
hRemProcess As Long, hThread As Long, lngResult As Long, pfnThreadRtn As Long, hKernel As Long
Dim
dwEax As Long, dwTimeOut As Long
hRemProcess = GetCurrentProcess
hKernel = GetModuleHandle(
"kernel32")
If hKernel = 0 Then
MyGetFileType = 0
Exit Function
End If
pfnThreadRtn = GetProcAddress(hKernel, "GetFileType")
If pfnThreadRtn = 0 Then
FreeLibrary hKernel
MyGetFileType =
0
Exit Function
End If
hThread = CreateRemoteThread(hRemProcess, ByVal 0&, 0&, ByVal pfnThreadRtn, ByVal hFile, 0, ByVal 0&)
dwEax = WaitForSingleObject(hThread,
100)
If dwEax = &H102 Then
Call
GetExitCodeThread(hThread, dwTimeOut)
Call TerminateThread(hThread, dwTimeOut)
NtClose hThread
MyGetFileType =
0
Exit Function
End If
If
hThread = 0 Then
FreeLibrary hKernel
MyGetFileType =
False
Exit Function
End If
GetExitCodeThread hThread, lngResult
MyGetFileType = lngResult
NtClose hThread
NtClose hRemProcess
FreeLibrary hKernel
End Function


modRemoveUsbDrive.bas

Attribute VB_Name = "modRemoveUsbDrive"
Option Explicit
'***********************************************************
'此模块是通过转换C++代码而来
'*********************************************************************
Private Type GUID
Data1
As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End
Type

'typedef struct _SP_DEVICE_INTERFACE_DETAIL_DATA_A {
' DWORD cbSize;
' CHAR DevicePath[ANYSIZE_ARRAY];
'} SP_DEVICE_INTERFACE_DETAIL_DATA_A, *PSP_DEVICE_INTERFACE_DETAIL_DATA_A;
Private Type SP_DEVICE_INTERFACE_DETAIL_DATA
cbSize
As Long
strDevicePath As String * 260
End Type

Private Type SP_DEVICE_INTERFACE_DATA
cbSize
As Long 'taille de la structure en octets
InterfaceClassGuid As GUID 'GUID de la classe d'interface
flags As Long 'options
Reserved As Long 'réservé
End Type

Private Type SP_DEVINFO_DATA
cbSize
As Long 'taille de la structure en octets
ClassGuid As GUID 'GUID de la classe d'installation
DevInst As Long 'handle utilisable par certaine fonction CM_xxx
Reserved As Long 'réservé
End Type
'
'typedef struct _STORAGE_DEVICE_NUMBER {
' //
' // The FILE_DEVICE_XXX type for this device.
' //
' DEVICE_TYPE DeviceType;
' //
' // The number of this device
' //
' DWORD DeviceNumber;
' //
' // If the device is partitionable, the partition number of the device.
' // Otherwise -1
' //
' DWORD PartitionNumber;
'} STORAGE_DEVICE_NUMBER, *PSTORAGE_DEVICE_NUMBER;
Private Type STORAGE_DEVICE_NUMBER
dwDeviceType
As Long
dwDeviceNumber As Long
dwPartitionNumber As Long
End
lor="#000000">Type

'typedef enum _PNP_VETO_TYPE {
' PNP_VetoTypeUnknown, // Name is unspecified
' PNP_VetoLegacyDevice, // Name is an Instance Path
' PNP_VetoPendingClose, // Name is an Instance Path
' PNP_VetoWindowsApp, // Name is a Module
' PNP_VetoWindowsService, // Name is a Service
' PNP_VetoOutstandingOpen, // Name is an Instance Path
' PNP_VetoDevice, // Name is an Instance Path
' PNP_VetoDriver, // Name is a Driver Service Name
' PNP_VetoIllegalDeviceRequest, // Name is an Instance Path
' PNP_VetoInsufficientPower, // Name is unspecified
' PNP_VetoNonDisableable, // Name is an Instance Path
' PNP_VetoLegacyDriver, // Name is a Service
' PNP_VetoInsufficientRights // Name is unspecified
'} PNP_VETO_TYPE, *PPNP_VETO_TYPE;

Private Enum PNP_VETO_TYPE
PNP_VetoTypeUnknown
PNP_VetoLegacyDevice
PNP_VetoPendingClose
PNP_VetoWindowsApp
PNP_VetoWindowsService
PNP_VetoOutstandingOpen
PNP_VetoDevice
PNP_VetoDriver
PNP_VetoIllegalDeviceRequest
PNP_VetoInsufficientPower
PNP_VetoNonDisableable
PNP_VetoLegacyDriver
PNP_VetoInsufficientRights
End Enum
'Private Const DIGCF_DEFAULT = &H1 ' only valid with DIGCF_DEVICEINTERFACE
Private Const DIGCF_PRESENT = &H2
'Private Const DIGCF_ALLCLASSES = &H4
'Private Const DIGCF_PROFILE = &H8
Private Const DIGCF_DEVICEINTERFACE = &H10
Private Const GENERIC_READ = &H80000000 '允许对设备进行读访问
Private Const FILE_SHARE_READ = &H1 '允许读取共享
Private Const OPEN_EXISTING = 3 '文件必须已经存在。由设备提出要求
Private Const FILE_SHARE_WRITE = &H2 '允许对文件进行共享访问
Private Const IOCTL_STORAGE_BASE As Long = &H2D
Private Const METHOD_BUFFERED = 0
Private Const FILE_ANY_ACCESS = 0

Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByVal ClassGuid As Long, ByVal Enumerator As Long, ByVal HwndParent As Long, ByVal flags As Long) As Long
Private Declare Function
SetupDiEnumDeviceInterfaces Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal DeviceInfoData As Long, ByRef InterfaceClassGuid As GUID, ByVal MemberIndex As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA) As Long
Private Declare Function
SetupDiGetDeviceInterfaceDetail Lib "setupapi.dll" Alias "SetupDiGetDeviceInterfaceDetailA" (ByVal DeviceInfoSet As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA, DeviceInterfaceDetailData As Any, ByVal DeviceInterfaceDetailDataSize As Long, ByRef RequiredSize As Long, DeviceInfoData As Any) As Long
Private Declare Function
SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long
Private Declare Function
CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function
CM_Get_Parent Lib "cfgmgr32.dll" (pdwDevInst As Long, B
yVal
dwDevInst As Long, ByVal ulFlags As Long) As Long
Private Declare Function
CM_Request_Device_EjectW Lib "setupapi.dll" (ByVal dwDevInst As Long, ByVal pVetoType As Long, ByVal pszVetoName As String, ByVal ulNameLength As Long, ByVal ulFlags As Long) As Long
Private Declare Function
DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long
Private Declare Function
CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function
GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function
QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Declare Sub
Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Function CTL_CODE(ByVal lDeviceType As Long, ByVal lFunction As Long, ByVal lMethod As Long, ByVal lAccess As Long) As Long
CTL_CODE = (lDeviceType * 2 ^ 16&) or (lAccess * 2 ^ 14&) or (lFunction * 2 ^ 2) or (lMethod)
End Function

'获取设备属性信息,希望得到系统中所安装的各种固定的和可移动的硬盘、优盘和CD/DVD-ROM/R/W的接口类型、序列号、产品ID等信息。
Private Function IOCTL_STORAGE_GET_DEVICE_NUMBER() As Long '2953344
IOCTL_STORAGE_GET_DEVICE_NUMBER = CTL_CODE(IOCTL_STORAGE_BASE, &H420, METHOD_BUFFERED, FILE_ANY_ACCESS)
End Function

Private Function
GetDrivesDevInstByDeviceNumber(ByVal lngDeviceNumber As Long, ByVal uDriveType As Long, ByVal szDosDeviceName As String) As Long
Dim
objGuid As GUID, hDevInfo As Long, dwIndex As Long, lngRes As Long, dwSize As Long
Dim
objSpdid As SP_DEVICE_INTERFACE_DATA, objSpdd As SP_DEVINFO_DATA, objPspdidd As SP_DEVICE_INTERFACE_DETAIL_DATA
Dim hDrive As Long, objSdn As STORAGE_DEVICE_NUMBER, dwBytesReturned As Long
Dim
dwReturn As Long
'处理GUID
With objGuid
.Data2 =
&HB6BF
.Data3 = &H11D0&
.Data4(
0) = &H94&
.Data4(
1) = &HF2&
.Data4(
2) = &H0&
.Data4(
3) = &HA0&
.Data4(
4) = &HC9&
.Data4(
5) = &H1E&
.Data4(
6) = &HFB&
.Data4(
7) = &H8B&
Select Case uDriveType
Case 2
If InStr(szDosDeviceName, "\Floppy") Then
.Data1 = &H53F56311
Else
.Data1 = &H53F56307
End If
Case
3
.Data1 = &H53F56307
Case 5
.Data1 = &H53F56308
End Select
End With
'Get device interface info set handle for all devices attached to system
hDevInfo = SetupDiGetClassDevs(VarPtr(objGuid), 0, 0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE)
If hDevInfo = -1 Then
GetDrivesDevInstByDeviceNumber = 0
Exit Function
End If
objSpdid.cbSize = Len(objSpdid)
Do While 1
lngRes = SetupDiEnumDeviceInterfaces(hDevInfo, 0, objGuid, dwIndex, objSpdid)
If lngRes = 0 Then Exit Do
dwSize = 0
Call SetupDiGetDeviceInterfaceDetail(hDevInfo, objSpdid, ByVal 0&, 0, dwSize, ByVal 0&)
If dwSize <> 0 And dwSize <= 1024 Then
objPspdidd.cbSize = 5 'Len(objPspdidd) '这里十分注意这里必须是5不能用'Len(objPspdidd)
objSpdd.cbSize = Len(objSpdd)
lngRes = SetupDiGetDeviceInterfaceDetail(hDevInfo, objSpdid, objPspdidd,
ByVal dwSize, dwReturn, objSpdd)
If lngRes > 0 Then
'打开设备
hDrive = CreateFile(objPspdidd.strDevicePath, 0, FILE_SHARE_READ or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If hDrive <> -1 Then
'获取设备号
lngRes = DeviceIoControl(hDrive, IOCTL_STORAGE_GET_DEVICE_NUMBER, ByVal 0&, 0, objSdn, Len(objSdn), dwBytesReturned, ByVal 0&)
If lngRes Then
'match the given device number with the one of the current device
If lngDeviceNumber = objSdn.dwDeviceNumber Then
Call
CloseHandle(hDrive)
SetupDiDestroyDeviceInfoList hDevInfo
GetDrivesDevInstByDeviceNumber = objSpdd.DevInst
Exit Function
End If
End If
Call
CloseHandle(hDrive)
End If
End If
End If
dwIndex = dwIndex + 1
Loop
Call
SetupDiDestroyDeviceInfoList(hDevInfo)
End Function

'************************************************************************************************
'参数为szDosDeviceName为USB的路径格式为"\\.\" & drive & ":"形式,blnIsShowNote参数是是否显示
'消息窗体的着用,这里需要注意的是在9X下只能把blnIsShowNote参数设置为FALSE
'************************************************************************************************
<
/font>Public Function RemoveUsbDrive(ByVal szDosDeviceName As String, ByVal blnIsShowNote As Boolean) As Boolean
Dim
strDrive As String, dwDeviceNumber As Long, hVolume As Long, objSdn As STORAGE_DEVICE_NUMBER, dwBytesReturned As Long
Dim
lngRes As Long, uDriveType As Long, strDosDriveName As String, hDevInst As Long, uType As PNP_VETO_TYPE
Dim strVetoName As String, blnSuccess As Boolean, dwDevInstParent As Long, i As Integer, pVetoType As Long
'获取USB所在盘符
strDrive = Right(szDosDeviceName, 2)
dwDeviceNumber = -
1
'打开设备
hVolume = CreateFile(szDosDeviceName, 0, FILE_SHARE_READ or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If hVolume = -1 Then
RemoveUsbDrive = False
Exit Function
End If
'获取设备号
lngRes = DeviceIoControl(hVolume, IOCTL_STORAGE_GET_DEVICE_NUMBER, ByVal 0&, 0, objSdn, Len(objSdn), dwBytesReturned, ByVal 0&)
If lngRes Then
dwDeviceNumber = objSdn.dwDeviceNumber
End If
'关闭设备
Call CloseHandle(hVolume)
If dwDeviceNumber = -1 Then
RemoveUsbDrive = False
Exit Function
End If
'获取驱动器类型
uDriveType = GetDriveType(strDrive)
strDosDriveName =
String(280, Chr(0))
'get the dos device name (like \device\floppy0) to decide if it's a floppy or not - who knows a better way?
lngRes = QueryDosDevice(strDrive, strDosDriveName, 280)
strDosDriveName = Left(strDosDriveName, InStr(strDosDriveName, Chr(
0)) - 1)
If lngRes = 0 Then
RemoveUsbDrive = False
Exit Function
End If
'get the device instance handle of the storage volume by means of a SetupDi enum and matching the device number
hDevInst = GetDrivesDevInstByDeviceNumber(dwDeviceNumber, uDriveType, strDosDriveName)
If hDevInst = 0 Then
RemoveUsbDrive = False
Exit Function
End If
strVetoName = String(260, Chr(0))
'get drives's parent, e.g. the USB bridge, the SATA port, an IDE channel with two drives!
lngRes = CM_Get_Parent(dwDevInstParent, hDevInst, 0)
For i = 0 To 3
'卸载UB设备
If blnIsShowNote Then
lngRes = CM_Request_Device_EjectW(dwDevInstParent, ByVal VarPtr(pVetoType), vbNullString, 0, 0)
Else
lngRes = CM_Request_Device_EjectW(dwDevInstParent, uType, strVetoName, 260, 0)
End If
If
lngRes = 0 And uType = PNP_VetoTypeUnknown Then
blnSuccess = True
Exit For
End If
Sleep 300
Next
RemoveUsbDrive = blnSuccess
End Function



Private Const WTS_CURRENT_SERVER_HANDLE = 0&
Private Declare Function WTSEnumerateProcesses _
Lib "wtsapi32.dll" Alias "WTSEnumerateProcessesA" _
(
ByVal hServer As Long, ByVal Reserved As Long, _
ByVal Version As Long, ByRef ppProcessInfo As Long, _
ByRef pCount As Long) As Long

Private Declare Function
LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" (ByVal lpSystemName As String, ByVal SID As Long, ByVal name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Sub
WTSFreeMemory Lib "wtsapi32.dll" (pMemory As Any)
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)

Public Function GetProcessUserNameByProcessId(ByVal dwProcessId As Long) As String
Dim
objWtsProcessInfo As WTS_PROCESS_INFO, i As Integer, lngRet As Long, lngCount As Long
Dim
lngInfo As Long, lngAddr As Long, strUserName As String, strDomain As String, lngTmp As Long
lngRet = WTSEnumerateProcesses(WTS_CURRENT_SERVER_HANDLE, 0, 1, lngInfo, lngCount)
If lngRet Then
lngAddr = lngInfo
For i = 1 To lngCount
CopyMemory objWtsProcessInfo,
ByVal lngAddr, LenB(objWtsProcessInfo)
If objWtsProcessInfo.ProcessID = dwProcessId Then
strUserName = String(255, Chr(0))
strDomain =
String(255, Chr(0))
lngRet = LookupAccountSid(vbNullString, objWtsProcessInfo.pUserSid, strUserName,
255, strDomain, 255, lngTmp)
GetProcessUserNameByProcessId = Left(strUserName, InStr(strUserName, Chr(
0)) - 1)
WTSFreeMemory objWtsProcessInfo
Exit Function
End If
WTSFreeMemory objWtsProcessInfo
lngAddr = lngAddr + LenB(objWtsProcessInfo)
Next
End If
End Function



VERSION 5.00
Begin VB.Form frmMain
Caption =
"Form1"
ClientHeight = 3090
ClientLeft = 60
ClientTop = 450
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3090
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Private Sub
Form_Load()
EnumWindows
AddressOf EnumWindowsProc, ByVal 0&
End Sub

modGetListViewText.bas

Attribute VB_Name =
"modGetListViewText"
Option Explicit

Private Const MEM_RELEASE = &H8000

Private Const LVM_FIRST = &H1000
Private Const LVM_GETHEADER = LVM_FIRST + 31
Private Const LVM_GETITEMCOUNT = (LVM_FIRST + 4)

Private Const LVM_GETITEM = (LVM_FIRST + 5)
Private Const LVM_GETSTRINGWIDTH = (LVM_FIRST + 17)
Private Const LVM_GETCOLUMN = (LVM_FIRST + 25)
Private Const LVM_GETITEMTEXT = (LVM_FIRST + 45)
Private Const HDM_FIRST = &H1200
Private Const HDM_GETITEMCOUNT = (HDM_FIRST + 0)
Private Const HDM_ORDERTOINDEX = (HDM_FIRST + 15)

Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const MAX_LVMSTRING As Long = 255
Private Const MEM_COMMIT = &H1000
Private Const PAGE_READWRITE = &H4
Private Const LVIF_TEXT As Long = &H1

Private Const LVM_GETCOLUMNCOUNT = &HF11B

Private Type LV_ITEMA
mask
As Long
iItem As Long
iSubItem As Long
state As Long
stateMask As Long
pszText As Long
cchTextMax As Long
iImage As Long
lParam As Long
iIndent As Long
End
Type

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function
VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function
VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function
WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function
ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long

Private Declare Function
SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long

Private Declare Function
CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Function
GetListViewTextArray(ByVal hWindow As Long, ByVal ProcessID As Long) As String()
Dim result As Long
Dim
myItem() As LV_ITEMA
Dim pHandle As Long
Dim
pStrBufferMemory As Long
Dim
pMyItemMemory As Long
Dim
strBuffer() As Byte
Dim
index As Long
Dim
tmpString As String
Dim
strLength As Long
Dim
i As Integer, sum As Integer, j As Integer, hCount As Long
Dim
strArr() As String, itemString As String
hCount = SendMessage(hWindow, LVM_GETHEADER, 0, 0)
If hCount > 0 Then
hCount = SendMessage(hCount, HDM_GETITEMCOUNT, 0, 0)
Else
hCount = 0
End If
ReDim
strBuffer(MAX_LVMSTRING)
pHandle = OpenProcess(PROCESS_VM_OPERATION
Or PROCESS_VM_READ Or PROCESS_VM_WRITE, False, ProcessID)
ReDim myItem(hCount)
For j = 0 To SendMessage(hWindow, LVM_GETITEMCOUNT, 0, 0) - 1
For i = 0 To hCount
pStrBufferMemory = VirtualAllocEx(pHandle,
0, MAX_LVMSTRING, MEM_COMMIT, PAGE_READWRITE)
myItem(i).mask = LVIF_TEXT
myItem(i).iSubItem = i
myItem(i).pszText = pStrBufferMemory
myItem(i).cchTextMax = MAX_LVMSTRING
pMyItemMemory = VirtualAllocEx(pHandle,
0, Len(myItem(i)), MEM_COMMIT, PAGE_READWRITE)
result = WriteProcessMemory(pHandle, pMyItemMemory, myItem(i), Len(myItem(i)),
0)
result = SendMessage(hWindow, LVM_GETITEMTEXT, j,
ByVal pMyItemMemory)
If result = 0 Then
result = VirtualFreeEx(pHandle, pStrBufferMemory, 0, MEM_RELEASE)
result = VirtualFreeEx(pHandle, pMyItemMemory,
0, MEM_RELEASE)
Exit For
End If
result = ReadProcessMemory(pHandle, pStrBufferMemory, strBuffer(0), MAX_LVMSTRING, 0)
result = ReadProcessMemory(pHandle, pMyItemMemory, myItem(i), Len(myItem(i)),
0)
tmpString = StrConv(strBuffer, vbUnicode)
tmpString = Left(tmpString, InStr(tmpString, vbNullChar) -
1)
itemString = itemString & tmpString &
","
result = VirtualFreeEx(pHandle, pStrBufferMemory, 0, MEM_RELEASE)
result = VirtualFreeEx(pHandle, pMyItemMemory,
0, MEM_RELEASE)
Next
ReDim Preserve
strArr(0 To sum)
strArr(j) = Left(itemString, Len(itemString) -
1)
sum = sum +
1
itemString = ""
Next
result = CloseHandle(pHandle)
GetListViewTextArray = strArr
End Function

modPublic.bas

Attribute VB_Name =
"modPublic"
Option Explicit
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Private Declare Function
GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function
GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Public Declare Function
FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function
GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function
GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function
GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Public Function
EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Boolean
Dim
h As Long, strArr() As String, pid As Long, i As Integer
If
InStr(GetWindowCaption(hwnd), "辉煌在线管理团队 - 群") Then
FindControlHwndByClsName hwnd, "SysListView32", h
GetWindowThreadProcessId hwnd, pid
If h <> 0 Then
strArr = GetListViewTextArray(h, pid)
For i = 0 To UBound(strArr)
MsgBox strArr(i)
Next
End If
End If
EnumWindowsProc = True
End Function

Private Function
GetWindowCaption(ByVal hwnd As Long) As String
Dim
strText As String, ret As Long
ret = GetWindowTextLength(hwnd)
If ret > t>0 Then
strText = Space(ret)
GetWindowText hwnd, strText, ret +
1
strText = Left(strText, ret)
GetWindowCaption = strText
Else
GetWindowCaption = ""
End If
End Function

Private Function
FindControlHwndByCaption(ByVal nHwnd As Long, ByVal findStr As String, outHwnd As Long)
Dim fHwnd As Long, myStr As String, sHwnd As Long
fHwnd = GetWindow(nHwnd, GW_CHILD)
If fHwnd = 0 Then Exit Function
Do While
fHwnd > 0
myStr = String(100, Chr$(0))
GetWindowText fHwnd, myStr,
100

If Left(myStr, InStr(myStr, Chr$(0)) - 1) = findStr Then
outHwnd = fHwnd
Exit Function
End If
sHwnd = GetWindow(fHwnd, GW_CHILD)
If sHwnd > 0 Then
FindControlHwndByCaption fHwnd, findStr, outHwnd
End If
fHwnd = GetWindow(fHwnd, GW_HWNDNEXT)
Loop
End Function

Private Function
FindControlHwndByClsName(ByVal nHwnd As Long, ByVal clsName As String, outHwnd As Long)
Dim fHwnd As Long, myStr As String, sHwnd As Long, ret As Long, iss As Boolean
fHwnd = GetWindow(nHwnd, GW_CHILD)
If fHwnd = 0 Then Exit Function
Do While
fHwnd > 0
myStr = String(100, Chr$(0))
GetClassName fHwnd, myStr,
100
If Left(myStr, InStr(myStr, Chr$(0)) - 1) = clsName Then
outHwnd = fHwnd
Exit Function
End If
sHwnd = GetWindow(fHwnd, GW_CHILD)
If sHwnd > 0 Then
FindControlHwndByClsName fHwnd, clsName, outHwnd
End If
fHwnd = GetWindow(fHwnd, GW_HWNDNEXT)
Loop
End Function



Attribute VB_Name = "mTestStrArrays"
Option Explicit

Private Declare Sub CopyMemByV Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSrc As Long, ByVal lByteLen As Long)
Private Declare Sub ZeroMemByV Lib "kernel32" Alias "RtlZeroMemory" (ByVal lpDest As Long, ByVal lLenB As Long)

Private sTestArray() As String
Private
lAbuf() As Long

' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
' This is intended as a sort testing aid, and though it may be
' a handy technique to use elsewhere, care should be taken to
' ensure no memory violations occur.
'
' Distinctive usage:
'
' - This is intended to be used where the string items and
' the number of string items in the array are not changing.
'
' - This caches the string pointers only, not the strings,
' and is intended for use when re-ordering but not altering
' the string array, so care must be taken to reset the cached
' pointers whenever array items are added, removed, or modified.
'
' - When caching with CacheArrayPtrs the passed string array
' must contain at least one item or errors will occur.
'
' - When resetting with ResetArrayPtrs the passed string array
' size must match the cached size or errors will occur.
'
' - This uses RtlZeroMemory to nullify string pointers but only
' when calling ResetArrayPtrs with bNullify set to True; see
' SaveOriginal below. An un-confirmed mis-trust hangs over the
' use of RtlZeroMemory on some OS's?
'
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub ResetArrayPtrs(sArr() As String, Optional ByVal bNullify As Boolean)

Dim lpStr As Long, lpBuf As Long
Dim
LBd As Long, UBd As Long

LBd = LBound(sArr)
UBd = UBound(sArr)

lpStr = VarPtr(sArr(LBd))
' Cache string array pointer

If bNullify Then
If
(UBd - LBd) Then
ZeroMemByV lpStr, ((UBd - LBd) + 1&) * 4&
End If
Else
lpBuf = VarPtr(lAbuf(LBd)) ' Cache buffer array pointer

If (UBd - LBd) Then
CopyMemByV lpStr, lpBuf, ((UBd - LBd) + 1&) * 4&
End If
End If
End Sub

Public Sub
CacheArrayPtrs(sArr() As String)

Dim lpStr As Long, lpBuf As Long
Dim
LBd As Long, UBd As Long

LBd = LBound(sArr)
UBd = UBound(sArr)

ReDim lAbuf(LBd To UBd) As Long

lpStr = VarPtr(sArr(LBd)) ' Cache string array pointer
lpBuf = VarPtr(lAbuf(LBd)) ' Cache buffer array pointer

If (UBd - LBd) Then
CopyMemByV lpBuf, lpStr, ((UBd - LBd) + 1&) * 4&
End If
End Sub

' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' Demo code only follows:

Sub LoadArray()

' Code to load test strings into array
'...

' Whenever the array is re-loaded cache the
' pointers in their original order
CacheArrayPtrs sTestArray

End Sub

Sub
SortTest()

' Reset the array items back to their original
' positions just before each new sorting test
ResetArrayPtrs sTestArray

' Do the sorting
strSort sTestArray

' I leave the array sorted to access the sorted data
' and don't reset until starting a new sort test

End Sub

Sub
CommitChanges()

' I cache the array pointers when one of the following occurs:

' Load the array with new items
' Add item(s) to the array
' Delete item(s) from the array
' Modify item(s) the strings themselves in any way
' Alter the array order and wish to test or save the resulting order

CacheArrayPtrs sA
End Sub

Sub
SaveOriginal()

' I use the temp array when I don't wish to alter
' the current sort state of the test array

Dim sTmp() As String

' This array must be erased or uninitialised
' (must contain only null string pointers)

ReDim sTmp(lb To ub) As String

' This makes an illegal copy
ResetArrayPtrs sTmp

' Code
'...

' Must nullify before going out of scope
ResetArrayPtrs sTmp, True
End Sub



Option Explicit

Sub SendMail(Optional ByVal sSubject As String, Optional ByVal sBody As String, Optional ByVal sFileName As String)

Dim Jmail
Set Jmail = CreateObject( "jmail.Message ")
If sFileName < > " " Then Jmail.AddAttachment sFileName '附件

Jmail.Charset = "gb2312 "
Jmail.Silent = False
Jmail.Priority = 1 '邮件状态,1-5 1为最高
Jmail.MailServerUserName = "2688i " 'Email帐号
Jmail.MailServerPassWord = "******* " 'Email密码

Jmail.FromName = "邮件 " '发信人姓名
Jmail.From = "2688i@163.com " '发邮件地址地址

Jmail.Subject = sSubject '主题
Jmail.AddRecipient "2688i@163.com " '收信人地址
Jmail.Body = sBody '信件正文

Jmail.Send ( "smtp.163.com ") 'SMTP服务器,如smtp.sohu.com

Set Jmail = Nothing

End Sub

Sub
Command1_Click()
SendMail
"测试 ", "我爱你 ", "这里填附件地址 "
MsgBox "OK "
End Sub


(1)Body(信件正文) : 字符串
如:JMail.Body = "这里可以是用户填写的表单内容,可以取自From。"

(2)Charset(字符集,缺省为"US-ASCII") : 字符串
如:JMail.Charset = "US-ASCII"

(3)ContentTransferEncoding : 字符串
指定内容传送时的编码方式,缺省是"Quoted-Printable"
如:JMail.ContentTransferEncoding = "base64"

(4)ContentType(信件的contentype. 缺省是"text/plain") : 字符串
如果你以HTML格式发送邮件, 改为"text/html"即可。
如:JMail.ContentType = "text/html"

(5)Encoding : 字符串
设置附件编码方式(缺省是"base64)。 可以选择使用的是"base64", "uuencode" or "quoted-printable"
如:JMail.Encoding = "base64"

(6)Log(Jmail创建的日志,前提loging属性设置为true,见下面) : 字符串
如:使用Response.Write( JMail.Log )语句列出日志信息。

(7)Logging(是否使用日志) : 布尔型
如:JMail.Logging = true

(8)Recipients : 字符串
只读属性,返回所有收件人
如:Response.Write( "" + JMail.Recipients + "" );

(9)ReplyTo(指定别的回信地址) : 字符串
如:JMail.ReplyTo = "anyother@mailhost.com"

(10)Sender( 发件人的邮件地址) : 字符串
如:JMail.Sender = "sender@mailhost.com"

(11)SenderName(发件人的姓名) : 字符串
如:JMail.SenderName = "一克"

(12)ServerAddress(邮件服务器的地址) : 字符串
你可以指定多个服务器,用分号点开。可以指定端口号。
如果serverAddress保持空白,JMail会尝试远程邮件服务器,然后直接发送到服务器上去。
如:JMail.ServerAddress = "mail.263.net.cn"

(13)Subject(设定邮件的标题,可以取自From。):字符串
如:JMail.Subject = "客户反馈表单"

(14)添加文件附件到邮件
 如:JMail.AddAttachment( "c:anyfile.zip" )

(15)AddCustomAttachment( FileName, Data )
添加自定义附件.
如:JMail.AddCustomAttachment( "anyfile.txt", "Contents of file" );

(16)AddHeader( Header, Value )
添加用户定义的信件标头。
如:JMail.AddHeader( "Originating-IP","192.168.10.10" );

(17)AddRecipient(收件人):字符串
如:JMail.AddRecipient( "info@dimac.net" );

(18)AddRecipientBCC( Email ),密件收件人:
如:JMail.AddRecipientBCC( "anyone@mailhost.com" );

(19)AddRecipientCC( Email ) ,抄送收件人:
如:JMail.AddRecipientCC( "anyone@mailhost.com" )

(20)AddURLAttachment( URL, 文档名)
下载并添加一个来自url的附件. 第二个参数"文档名", 用来指定信件收到后的文件名。
如:JMail.AddURLAttachment( "http://java2000.wol.com.cn/perl/files/jmail.zip", "jmail" )

(21)AppendBodyFromFile( 文件名) ,将文件作为信件正文:
如:JMail.AppendBodyFromFile( "c:anyfile.txt" )

(22)AppendText( Text )
追加信件的正文内容,比如增加问候语或者其它信息。
如:JMail.AppendText( "欢迎访问本站!" )

(23)Close() ,强制JMail关闭缓冲的与邮件服务器的连接:
如:JMail.Close()

(24)Execute() ,执行邮件的发送
如:JMail.Execute()


Private Sub SendMail()

Dim jmail As New SMTPMail

Dim Conn As New ADODB.Connection

Dim Rst As New ADODB.Recordset, Rst1 As New ADODB.Recordset

Dim strRec As String, strRecCC As String

'On Error GoTo Err:

Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Password=dir941421;User ID=kiss;Data Source=" & App.Path & "\OAData\OAData.mdb;Persist Security Info=True;Jet OLEDB:System database=" & App.Path & "\OAData\Secured.mdw"

'检测是否有要发送的



多收件人

frmMain.mapMess.Compose
frmMain.mapMess.AddressResolveUI =
False

frmMain.mapMess.MsgSubject = "This is a subject."
frmMain.mapMess.MsgNoteText = "This is a body."

frmMain.mapMess.RecipIndex = 0
frmMain.mapMess.RecipType = 1
frmMain.mapMess.RecipAddress = "me@here.com"
frmMain.mapMess.ResolveName '每个收件人地址后面一定要调用 ResolveName

frmMain.mapMess.RecipIndex = 1
frmMain.mapMess.RecipType = 1
frmMain.mapMess.RecipAddress = "you@there.com"
frmMain.mapMess.ResolveName '每个收件人地址后面一定要调用 ResolveName

frmMain.mapMess.Send False


多附件

For I = 0 To List.ListCount - 1
MAPIMessages.AttachmentIndex = Acnt 'Index
MAPIMessages.AttachmentName = "附件名称" 'Name
MAPIMessages.AttachmentPathName = "附件路径" 'Path

DoEvents
Next I




因为MAPI没有导出参数支持HTML格式邮件,所以我们只能用附件带HTML文件来实现了。
然而在HTML文件中怎么附带图片呢?(编辑HTML使用DHTMLEdit控件,支持即…既…)
经过研究得知,发送HTML邮件的原理是用BASE64编码,那么很容易想到……
那就是在HTML文件中可以直接镶入图片,也是用BASE64编码的方法,在FireFox浏览器中“img对象可以直接使用data协议”,也就是说可以直接解析BASE64编码为图片,但是我在IE7上却调试不成功。
不过经过长时间人肉搜索发现,可以自定义解析,方法如下:

A modified "data" URL for DeleGate which is prefixed with "/-/" to the original URL:
SRC="/-/data:image/gif;base64,R0lGODdhMAAwAPAAAAAAAP///ywAAAAAMAAw AAAC8IyPqcvt3wCcDkiLc7C0qwyGHhSWpjQu5yqmCYsapyuvUUlvONmOZtfzgFz ByTB10QgxOR0TqBQejhRNzOfkVJ+5YiUqrXF5Y5lKh/DeuNcP5yLWGsEbtLiOSp a/TPg7JpJHxyendzWTBfX0cxOnKPjgBzi4diinWGdkF8kjdfnycQZXZeYGejmJl ZeGl9i2icVqaNVailT6F5iJ90m6mvuTS4OK05M0vDk0Q4XUtwvKOzrcd3iq9uis F81M1OIcR7lEewwcLp7tuNNkM3uNna3F2JQFo97Vriy/Xl4/f1cf5VWzXyym7PH hhx4dbgYKAAA7" ALT="Larry">



在火狐浏览器中可以直接使用下面的代码,IE不行(网上说的保存为MHT也不行)。
SRC="data:image/gif;base64,R0lGODdhMAAwAPAAAAAAAP///ywAAAAAMAAw AAAC8IyPqcvt3wCcDkiLc7C0qwyGHhSWpjQu5yqmCYsapyuvUUlvONmOZtfzgFz ByTB10QgxOR0TqBQejhRNzOfkVJ+5YiUqrXF5Y5lKh/DeuNcP5yLWGsEbtLiOSp a/TPg7JpJHxyendzWTBfX0cxOnKPjgBzi4diinWGdkF8kjdfnycQZXZeYGejmJl ZeGl9i2icVqaNVailT6F5iJ90m6mvuTS4OK05M0vDk0Q4XUtwvKOzrcd3iq9uis F81M1OIcR7lEewwcLp7tuNNkM3uNna3F2JQFo97Vriy/Xl4/f1cf5VWzXyym7PH hhx4dbgYKAAA7" ALT="Larry">


这里提供自己解析的一个工具:
http://www.delegate.org/delegate/
http://www.delegate.org/delegate/download/
http://www.delegate.org/delegate/sample/data-url.html

#########################################################################################


Option Explicit

'需要引用Microsoft XML, v3.0
Private Function Encode(iArray() As Byte) As String
Dim
iXml As New MSXML2.DOMDocument30
With iXml.createElement("Encoder")
.dataType =
"bin.base64"
.nodeTypedValue = iArray()
Encode = .Text
End With
End Function


Private Function
Decode(ByVal iStrbase64 As String) As Byte()
Dim strXML As String
strXML = "& Chr(34) & "urn:schemas-microsoft-com:datatypes" & Chr(34) & " dt:dt=" & Chr(34) & "bin.base64" & Chr(34) & ">" & iStrbase64 & ""
With New MSXML2.DOMDocument30
.loadXML strXML
Decode = .selectSingleNode(
"DECODER").nodeTypedValue
End With
End Function



Public Function EncodeBase64(ByVal vsFullPathname As String) As String
'For Encoding BASE64
Dim b As Integer
Dim
Base64Tab As Variant
Dim
bin(3) As Byte
Dim
s As String
Dim
l As Long
Dim
i As Long
Dim
FileIn As Long
Dim
sResult As String
Dim
n As Long

'Base64Tab=>tabla de tabulaci髇
Base64Tab = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "a
"
, "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "+", "/")

Erase bin
l =
0: i = 0: FileIn = 0: b = 0:
s =
""

'Gets the next free filenumber
FileIn = FreeFile

'Open Base64 Input File
Open vsFullPathname For Binary As FileIn

sResult = s & vbCrLf
s =
""

l = LOF(FileIn) - (LOF(FileIn) Mod 3)

For i = 1 To l Step 3

'Read three bytes
Get FileIn, , bin(0)
Get FileIn, , bin(1)
Get FileIn, , bin(2)

'Always wait until there're more then 64 characters
If Len(s) > 64 Then

s = s & vbCrLf
sResult = sResult & s
s =
""

End If

'Calc Base64-encoded char
b = (bin(n) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & Base64Tab(b) 'the character s holds the encoded chars

b = ((bin(n) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
s = s & Base64Tab(b)

b = ((bin(n +
1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
s = s & Base64Tab(b)

b = bin(n +
2) And &H3F
s = s & Base64Tab(b)

Next i

'Now, you need to check if there is something left
If Not (LOF(FileIn) Mod 3 = 0) Then

'Reads the number of bytes left
For i = 1 To (LOF(FileIn) Mod 3)
Get FileIn, , bin(i - 1)
Next i

'If there are only 2 chars left
If (LOF(FileIn) Mod 3) = 2 Then
b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & Base64Tab(b)


b = ((bin(
0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
s = s & Base64Tab(b)

b = ((bin(
1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
s = s & Base64Tab(b)

s = s &
"="

Else 'If there is only one char left
b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & Base64Tab(b)

b = ((bin(
0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
s = s & Base64Tab(b)

s = s &
"=="
End If
End If

'Send the characters left
If s <> "" Then
s = s & vbCrLf
sResult = sResult & s
End If

'Send the last part of the MIME Body
s = ""

Close FileIn
EncodeBase64 = sResult

End Function




这个东西难度不大,调用了QQ自带的timwp.exe程序,实现起来就很容易了,下面是代码部分,建立一个模块:

Option Explicit
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Const WM_CLOSE = &H10

'注册表操作
Private Const HKEY_LOCAL_MACHINE = &H80000002
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
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
RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'-------------------------------------------------
Declare Function SendMessageA Lib "user32" (ByVal Hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Declare Function
PostMessage Lib "user32" Alias "PostMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function
FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function
GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function
GetWindow Lib "user32" (ByVal Hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function
GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function
SendMessage Lib "user32" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const
GW_HWNDFIRST = 0 '第一个
Public Const GW_HWNDNEXT = 2 '下一个
Publi
c Const
DVASPECT_CONTENT = 1
Public Const WM_USER = &H400
Public Const EM_PASTESPECIAL = WM_USER + 64
Public Const CF_TEXT = 1
Const EM_REPLACESEL = &HC2
Const BM_CLICK = &HF5

Public Type QQWindowHwnd
WindowHwnd
As Long
TxtHwnd As Long
SendButtonHwnd As Long
CloseButtonHwnd As Long
End
Type

Public Type repastespecial
dwAspect
As Long
dwParam As Long
End
Type

Private QQpath As String
Public
QQExePath As String

Public Sub
main()
QQpath = getQqPath
If QQpath = "" Then
QQpath = InputBox("请填写QQ的安装路径", "QQ路径", "N")
End If
If
QQpath = "N" Then End
QQExePath = QQpath & "timwp.exe " + "Tencent://Message/?Menu=YES&Exe=&Uin="
FrmMain.Show
End Sub

Private Function
getQqPath() As String '获取QQ注册表路径
Dim ret, lenData, hKey As Long
Dim
sValue As String
Dim
name As String

sValue = Space(255)
Const REG_SZ = 1&

lenData =
255
name = "Install"
ret = 1
ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Tencent\QQ", hKey)
If ret = 0 Then '正确返回0,不正确返回错误编号
ret = RegQueryValueEx(hKey, name, 0, REG_SZ, ByVal sValue, lenData)
ret = InStr(
1, sValue, "QQ\")
getQqPath = Left(sValue, ret +
2)
End If
ret = RegCloseKey(hKey)
End Function

Public Function
FindQQ(ByVal Hwnd As Long) As Long
Dim
strName As String * 255
Dim className As String * 255
Dim Q_hwnd As Long
Q_hwnd = GetWindow(Hwnd, GW_HWNDFIRST)
Do While Q_hwnd <> 0
GetWindowText Q_hwnd, strName, 255
GetClassName Q_hwnd, className, 255
If ((InStr(strName, "聊天中") > 0) or (InStr(strName, "会话中") > 0)) And (InStr(className, "#32770") > 0) Then
FindQQ = Q_hwnd
Exit Function
End If
Q_hwnd = GetWindow(Q_hwnd, GW_HWNDNEXT)
Loop
End Function

Public Function
getQQHwnd(ByVal Hwnd As Long) As QQWindowHwnd
Dim tmphwnd As Long
getQQHwnd.WindowHwnd = FindWindowEx(Hwnd, 0, "#32770", vbNullString)
tmphwnd = FindWindowEx(getQQHwnd.WindowHwnd,
0, "Afxwnd42", vbNullString)
tmphwnd = FindWindowEx(getQQHwnd.WindowHwnd, tmphwnd,
"afxwnd42", "")
getQQHwnd.TxtHwnd = FindWindowEx(tmphwnd,
0, "richedit20A", vbNullString)
getQQHwnd.SendButtonHwnd = FindWindowEx(getQQHwnd.WindowHwnd,
0, "button", "发送(&S)")
getQQHwnd.CloseButtonHwnd = FindWindowEx(getQQHwnd.WindowHwnd,
0 ="#000000">, "button", "关闭(&C)")
End Function

Public Sub
SendQQMessage(ByRef QQhwnd As QQWindowHwnd, ByVal sTText As String)
SendMessageA QQhwnd.TxtHwnd, EM_REPLACESEL,
0, ByVal sTText
SendMessageA QQhwnd.SendButtonHwnd, BM_CLICK,
0, ByVal 0
SendMessageA QQhwnd.CloseButtonHwnd, BM_CLICK, 0, ByVal 0
End Sub


再建立一个窗体,窗体上放2个文本框,text1和text2,再放一个按钮,text1用于填写QQ号码,text2用于填写想要发送的内容

Option Explicit
Private delayNum As Long

Private Sub
Command1_Click()
Shell QQExePath & Text1.Text
Call delay(10)
Dim QQhwnd As Long
QQhwnd = FindQQ(Me.Hwnd)
Dim x As QQWindowHwnd
x = ModConst.getQQHwnd(QQhwnd)
SendQQMessage x, Text2.Text
End Sub

Private Sub
delay(ByVal sTime As Long)
delayNum = sTime
Timer1.Enabled =
True
Do
DoEvents
Loop While Timer1.Enabled = True
End Sub

Private Sub
Timer1_Timer()
Static I As Integer
I = I + 1
If I > delayNum Then
I = 0
Timer1.Enabled = False
End If
End Sub


好了,运行试试



使用此类不需要任何第三方软件支持,并且开源~~~
内带两个实例,一个是网游诛仙CALL的注入,还有一个是演示如何操作汇编指令
汇编基础类里基本包含了常用的汇编指令,如果用户觉得不够可以使用OD等有汇编
功能的软件提取机械吗添加类内..

对于那个 clsASM, 我只能说: 很好, 很强大~

使用示例:

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Function Float2Int(Ans As Single) As Long '浮点转整形
CopyMemory Float2Int, Ans, 4
End Function

Sub
Call_RunTO(dx As Single, dy As Single, dz As Single, dm As Long)
Dim asm As New clsASM '自动寻路
With asm ' asm
.Pushad ' pushad
.Mov_EAX_DWORD_Ptr &H90664C ' mov eax,[&H90664C]
.Mov_EAX_DWORD_Ptr_EAX_Add &H8 ' mov eax,[eax+&H8]
.Mov_EAX_DWORD_Ptr_EAX_Add &H88 ' mov eax,[eax+&H88]
.Push dm ' mov eax,[base]
.Mov_EAX Float2Int(dx) ' mov eax, x
.Mov_DWORD_Ptr_EAX &H908A88 ' mov [&H908a88], eax
.Mov_EAX Float2Int(dz) ' mov eax, z
.Mov_DWORD_Ptr_EAX &H908A8C ' mov [&H908a8c], eax
.Mov_EAX Float2Int(dy) ' mov eax, y
.Mov_DWORD_Ptr_EAX &H908A90 ' mov [&H908a90], eax
.Mov_EAX_DWORD_Ptr &H90664C ' mov eax, dword ptr [&H90664C]
.Mov_EAX_DWORD_Ptr_EAX_Add &H28 ' mov eax, dword ptr [eax+&H28]
.Lea_EAX_DWORD_EAX_Add &H3C ' lea eax, dword ptr [eax+&H3c]
.Push &H908A88 ' push &H908a88
.Push_EAX ' PUSH eax
.Mov_ECX &H902AF0 ' mov ecx, &H90664C
.Mov_EAX &H42ABF0 ' mov eax, &H42abf0
.Call_EAX ' Call eax
.Popad ' popad
.ret ' ret
End With ' end
asm.Run_ASM h
End Sub

Sub
Call_TAB()
Dim asm As New clsASM 'TAB
With asm ' asm
.Pushad ' pushad
.Mov_EAX_DWORD_Ptr &H902B3C ' mov eax,dword ptr ds:[&H902b3c]
.Mov_EAX_DWORD_Ptr_EAX_Add &H1C ' mov eax,dword ptr ds:[eax+&H1c]
.Mov_EAX_DWORD_Ptr_EAX_Add &H28 ' mov eax,dword ptr ds:[eax+&H28]
.Mov_ECX_EAX ' mov ecx, eax;
.Push 0 ' push 0
.Mov_EBX &H45F590 ' mov ebx,&H45F59
.Call_EBX ' call EBX
.Popad ' popad
.Ret
End With ' end
asm.Run_ASM h
End Sub

Sub
Call_Attack()
Dim asm As New clsASM '普通攻击
With asm ' asm
.Pushad ' pushad
.Mov_EAX &H5A1F70 ' Mov EAX,&H5A2170
.Call_EAX ' call pointer(eax)
.Popad ' popad
.Ret
End With ' end
asm.Run_ASM h
End Sub


以下为 clsASM.cls 内容:

Option Explicit
Private Decla
re Function
CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function
WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function
CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function
VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function
VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) 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
Private Declare Function
OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Const
PAGE_EXECUTE_READWRITE = &H40
Const MEM_COMMIT = &H1000
Const MEM_RELEASE = &H8000
Const MEM_DECOMMIT = &H4000
Const PROCESS_ALL_ACCESS = &H1F0FFF
Dim OPcode As String

Function
Get_Result() As String
Dim
i As Long
ReDim
AsmCode(Len(OPcode) / 2 - 1) As Byte
For
i = 0 To UBound(AsmCode)
AsmCode(i) =
CByte("&H" & Mid(OPcode, i * 2 + 1, 2))
Next
Get_Result = CallWindowProc(VarPtr(AsmCode(0)), 0, 0, 0, 0)
End Function

Function
Get_Code() As String
Get_Code = OPcode
End Function

Function
Run_ASM(pid As Long) As Long
Dim
i As Long, tmp_Addr As Long, RThwnd As Long, h As Long
ReDim
AsmCode(Len(OPcode) / 2 - 1) As Byte
For
i = 0 To UBound(AsmCode)
AsmCode(i) =
CByte("&H" & Mid(OPcode, i * 2 + 1, 2))
Next
h = OpenProcess(PROCESS_ALL_ACCESS, False, pid)
tmp_Addr = VirtualAllocEx(h,
ByVal 0&, UBound(AsmCode) + 1, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
WriteProcessMemory h,
ByVal tmp_Addr, ByVal VarPtr(AsmCode(0)), UBound(AsmCode) + 1, ByVal 0&
RThwnd = CreateRemoteThread(h,
ByVal 0&, 0, ByVal tmp_Addr, ByVal 0&, ByVal 0&, ByVal 0&)
VirtualFreeEx h, tmp_Addr, UBound(AsmCode) +
1, MEM_RELEASE
CloseHandle RThwnd
CloseHandle h

OPcode =
""
End Function

Function
Int2Hex(Value As Long, n As Long) As String '高地位互换
Dim tmp1 As String, tmp2 As String, i As Long
tmp1 = Right("0000000" + Hex(Value), n)
For i = 0 To Len(tmp1) / 2 - 1
tmp2 = tmp2 + Mid(tmp1, Len(tmp1) - 1 - 2 * i, 2)
Next i
Int2Hex = tmp2
End Function

Function
Leave() As Long
OPcode = OPcode + "C9"
End Function

Function
Pushad() As Long
OPcode = OPcode + "60"
End Function

Function
Popad() As Long
OPcode = OPcode + "61"
End Function

Function
Nop() As Long
OPcode = OPcode + "90"
End Function

Function
Ret() As Long
OPcode = OPcode + "C3"
End Function

Function
RetA(i As Long) As Long
OPcode = OPcode + Int2Hex(i, 4)
End Function

Function
IN_AL_DX() As Long
OPcode = OPcode + "EC"
End Function

Function
TEST_EAX_EAX() As Long
OPcode = OPcode + "85C0"
End Function

'Add
'+++++++++++++++++++++++++++++++++++
Function Add_EAX_EDX() As Long
OPcode = OPcode + "03C2"
End Function

Function
Add_EBX_EAX() As Long
OPcode = OPcode + "03D8"
End Function

Function
Add_EAX_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "0305" + Int2Hex(i, 8)
End Function

Function
Add_EBX_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "031D" + Int2Hex(i, 8)
End Function

Function
Add_EBP_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "032D" + Int2Hex(i, 8)
End Function

Function
Add_EAX(i As Long) As Long
OPcode = OPcode + "05" + Int2Hex(i, 8)
End Function

Function
Add_EBX(i As Long) As Long
OPcode = OPcode + "83C3" + Int2Hex(i, 8)
End Function

Function
Add_ECX(i As Long) As Long
OPcode = OPcode + "83C1" + Int2Hex(i, 8)
End Function

Function
Add_EDX(i As Long) As Long
OPcode = OPcode + "83C2" + Int2Hex(i, 8)
End Function

Function
Add_ESI(i As Long) As Long
OPcode = OPcode + "83C6" + Int2Hex(i, 8)
End Function

Function
Add_ESP(i As Long) As Long
OPcode = OPcode + "83C4" + Int2Hex(i, 8)
End Function

'Call
'+++++++++++++++++++++++++++++++++++
Function Call_EAX() As Long
OPcode = OPcode + "FFD0"
End Function

Function
Call_EBX() As Long
OPcode = OPcode + "FFD3"
End Function

Function
Call_ECX() As Long
OPcode = OPcode + "FFD1"
End Function

Function
Call_EDX() As Long
OPcode = OPcode + "FFD2"
End Function

Function
Call_ESI() As Long
OPcode = OPcode + "FFD2"
End Function

Function
Call_ESP() As Long
OPcode = OPcode + "FFD4"
End Function

Function
Call_EBP() As Long
OPcode = OPcode + "FFD5"
End Function

Function
Call_EDI() As Long
OPcode = OPcode + "FFD7"
End Function

Function
Call_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "FF15" + Int2Hex(i, 8)
End Function

Function
Call_DWORD_Ptr_EAX() As Long
OPcode = OPcode + "FF10"
End Function

Function
Call_DWORD_Ptr_EBX() As Long
OPcode = OPcode + "FF13"
End Function

'Cmp
'+++++++++++++++++++++++++++++++++++
Function Cmp_EAX(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "83F8" + Int2Hex(i, 2)
Else
OPcode = OPcode + "3D" + Int2Hex(i, 8)
End If
End Function

Function
Cmp_EAX_EDX() As Long
OPcode = OPcode + "3BC2"
End Function

Function
Cmp_EAX_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "3B05" + Int2Hex(i, 8)
End Function

Function
Cmp_DWORD_Ptr_EAX(i As Long) As Long
OPcode = OPcode + "3905" + Int2Hex(i, 8)
End Function

'DEC
'+++++++++++++++++++++++++++++++++++
Function Dec_EAX() As Long
OPcode = OPcode + "48"
End Function

Function
Dec_EBX() As Long
OPcode = OPcode + "4B"
End Function

Function
Dec_ECX() As Long
OPcode = OPcode + "49"
End Function

Function
Dec_EDX() As Long
OPcode = OPcode + "4A"
End Function

'Idiv
'+++++++++++++++++++++++++++++++++++
Function Idiv_EAX() As Long
OPcode = OPcode + "F7F8"
End Function

Function
Idiv_EBX() As Long
OPcode = OPcode + "F7FB"
End Function

Function
Idiv_ECX() As Long
OPcode = OPcode + "F7F9"
End Function

Function
Idiv_EDX() As Long
OPcode = OPcode + "F7FA"
End Function

'Imul
'+++++++
++++++++++++++++++++++++++++
Function Imul_EAX_EDX() As Long
OPcode = OPcode + "0FAFC2"
End Function

Function
Imul_EAX(i As Long) As Long
OPcode = OPcode + "6BC0" + Int2Hex(i, 2)
End Function

Function
ImulB_EAX(i As Long) As Long
OPcode = OPcode + "69C0" + Int2Hex(i, 8)
End Function

'INC
'+++++++++++++++++++++++++++++++++++
Function Inc_EAX() As Long
OPcode = OPcode + "40"
End Function

Function
Inc_EBX() As Long
OPcode = OPcode + "43"
End Function

Function
Inc_ECX() As Long
OPcode = OPcode + "41"
End Function

Function
Inc_EDX() As Long
OPcode = OPcode + "42"
End Function

Function
Inc_EDI() As Long
OPcode = OPcode + "47"
End Function

Function
Inc_ESI() As Long
OPcode = OPcode + "46"
End Function

Function
Inc_DWORD_Ptr_EAX() As Long
OPcode = OPcode + "FF00"
End Function

Function
Inc_DWORD_Ptr_EBX() As Long
OPcode = OPcode + "FF03"
End Function

Function
Inc_DWORD_Ptr_ECX() As Long
OPcode = OPcode + "FF01"
End Function

Function
Inc_DWORD_Ptr_EDX() As Long
OPcode = OPcode + "FF02"
End Function

'JMP/JE/JNE
'+++++++++++++++++++++++++++++++++++
Function JMP_EAX() As Long
OPcode = OPcode + "FFE0"
End Function

'Mov
Function Mov_DWORD_Ptr_EAX(i As Long) As Long
OPcode = OPcode + "A3" + Int2Hex(i, 8)
End Function

Function
Mov_EAX(i As Long) As Long
OPcode = OPcode + "B8" + Int2Hex(i, 8)
End Function

Function
Mov_EBX(i As Long) As Long
OPcode = OPcode + "BB" + Int2Hex(i, 8)
End Function

Function
Mov_ECX(i As Long) As Long
OPcode = OPcode + "B9" + Int2Hex(i, 8)
End Function

Function
Mov_EDX(i As Long) As Long
OPcode = OPcode + "BA" + Int2Hex(i, 8)
End Function

Function
Mov_ESI(i As Long) As Long
OPcode = OPcode + "BE" + Int2Hex(i, 8)
End Function

Function
Mov_ESP(i As Long) As Long
OPcode = OPcode + "BC" + Int2Hex(i, 8)
End Function

Function
Mov_EBP(i As Long) As Long
OPcode = OPcode + "BD" + Int2Hex(i, 8)
End Function

Function
Mov_EDI(i As Long) As Long
OPcode = OPcode + "BF" + Int2Hex(i, 8)
End Function

Function
Mov_EBX_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "8B1D" + Int2Hex(i, 8)
End Function

Function
Mov_ECX_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "8B0D" + Int2Hex(i, 8)
End Function

Function
Mov_EAX_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "A1" + Int2Hex(i, 8)
End Function

Function
Mov_EDX_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "8B15" + Int2Hex(i, 8)
End Function

Function
Mov_ESI_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "8B35" + Int2Hex(i, 8)
End Function

Function
Mov_ESP_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "8B25" + Int2Hex(i, 8)
End Function

Function
Mov_EBP_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "8B2D" + Int2Hex(i, 8)
End Function

Function
Mov_EAX_DWORD_Ptr_EAX() As Long
OPcode = OPcode + "8B00"
End Function

Function
Mov_EAX_DWORD_Ptr_EBP() As Long
OPcode = OPcode + "8B4500"
End Function

Function
Mov_EAX_DWORD_Ptr_EBX() As Long
OPcode = OPcode + "8B03"
End Function

Function
Mov_EAX_DWORD_Ptr_ECX() As Long
OPcode = OPcode + "8B01"
End Function

Function
Mov_EAX_DWORD_Ptr_EDX() As Long
OPcode = OPcode + "8B02"
End Function

Function
Mov_EAX_DWORD_Ptr_EDI() As Long
OPcode = OPcode + "8B07"
End Function

Function
Mov_EAX_DWORD_Ptr_ESP() As Long
OPcode = OPcode + "8B0424"
End Function

Function
Mov_EAX_DWORD_Ptr_ESI() As Long
OPcode = OPcode + "8B06"
End Function

Function
Mov_EAX_DWORD_Ptr_EAX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B40" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B80" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EAX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B4424" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B8424" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EAX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B43" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B83" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EAX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B41" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B81" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EAX_DWORD_Ptr_EDX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B42" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B82" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EAX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcod
e = OPcode +
"8B47" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B87" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EAX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B45" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B85" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EAX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B46" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B86" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_EAX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B58" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B98" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B5C24" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B9C24" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B5B" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B9B" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B59" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B99" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_EDX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B5A" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B9A" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B5F" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B9F" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B5D" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B9D" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B5E" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B9E" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_EAX_Add(i As Long "#000000">) As Long
If
i <= 255 Then
OPcode = OPcode + "8B48" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B88" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B4C24" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B8C24" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B4B" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B8B" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B49" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B89" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_EDX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B4A" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B8A" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B4F" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B8F" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B4D" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B8D" + Int2Hex(i, 8)
End If
End Function

Function
Mov_ECX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B4E" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B8E" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_EAX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B50" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B90" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B5424" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B9424" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B53" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B93" + Int2Hex(i, 8 "#000000">)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B51" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B91" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_EDX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B52" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B92" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B57" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B97" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B55" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B95" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EDX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8B56" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8B96" + Int2Hex(i, 8)
End If
End Function

Function
Mov_EBX_DWORD_Ptr_EAX() As Long
OPcode = OPcode + "8B18"
End Function

Function
Mov_EBX_DWORD_Ptr_EBP() As Long
OPcode = OPcode + "8B5D00"
End Function

Function
Mov_EBX_DWORD_Ptr_EBX() As Long
OPcode = OPcode + "8B1B"
End Function

Function
Mov_EBX_DWORD_Ptr_ECX() As Long
OPcode = OPcode + "8B19"
End Function

Function
Mov_EBX_DWORD_Ptr_EDX() As Long
OPcode = OPcode + "8B1A"
End Function

Function
Mov_EBX_DWORD_Ptr_EDI() As Long
OPcode = OPcode + "8B1F"
End Function

Function
Mov_EBX_DWORD_Ptr_ESP() As Long
OPcode = OPcode + "8B1C24"
End Function

Function
Mov_EBX_DWORD_Ptr_ESI() As Long
OPcode = OPcode + "8B1E"
End Function
Function
Mov_ECX_DWORD_Ptr_EAX() As Long
OPcode = OPcode + "8B08"
End Function

Function
Mov_ECX_DWORD_Ptr_EBP() As Long
OPcode = OPcode + "8B4D00"
End Function

Function
Mov_ECX_DWORD_Ptr_EBX() As Long
OPcode = OPcode + "8B0B"
End Function

Function
Mov_ECX_DWORD_Ptr_ECX() As Long
OPcode = OPcode + "8B09"
End Function

Function
Mov_ECX_DWORD_Ptr_EDX() As Long
OPcode = OPcode + "8B0A"
End Function

Function
Mov_ECX_DWORD_Ptr_EDI() As Long
OPcode = OPcode + "8B0F"
End Function

Function
Mov_ECX_DWORD_Ptr_ESP() As Long
OPcode = OPcode + "8B0C24"
End Function

Function
Mov_ECX_DWORD_Ptr_ESI() As Long
OPcode = OPcode + "8B0E"
End Function

Function
Mov_EDX_DWORD_Ptr_EAX() As Long
OPcode = OPcode + "8B10"
End Function

Function
Mov_EDX_DWORD_Ptr_EBP() As Long
OPcode = OPcode + "8B5500"
t color="#0000FF">End Function

Function
Mov_EDX_DWORD_Ptr_EBX() As Long
OPcode = OPcode + "8B13"
End Function

Function
Mov_EDX_DWORD_Ptr_ECX() As Long
OPcode = OPcode + "8B11"
End Function

Function
Mov_EDX_DWORD_Ptr_EDX() As Long
OPcode = OPcode + "8B12"
End Function

Function
Mov_EDX_DWORD_Ptr_EDI() As Long
OPcode = OPcode + "8B17"
End Function

Function
Mov_EDX_DWORD_Ptr_ESI() As Long
OPcode = OPcode + "8B16"
End Function

Function
Mov_EDX_DWORD_Ptr_ESP() As Long
OPcode = OPcode + "8B1424"
End Function

Function
Mov_EAX_EBP() As Long
OPcode = OPcode + "8BC5"
End Function

Function
Mov_EAX_EBX() As Long
OPcode = OPcode + "8BC3"
End Function

Function
Mov_EAX_ECX() As Long
OPcode = OPcode + "8BC1"
End Function

Function
Mov_EAX_EDI() As Long
OPcode = OPcode + "8BC7"
End Function

Function
Mov_EAX_EDX() As Long
OPcode = OPcode + "8BC2"
End Function

Function
Mov_EAX_ESI() As Long
OPcode = OPcode + "8BC6"
End Function

Function
Mov_EAX_ESP() As Long
OPcode = OPcode + "8BC4"
End Function

Function
Mov_EBX_EBP() As Long
OPcode = OPcode + "8BDD"
End Function

Function
Mov_EBX_EAX() As Long
OPcode = OPcode + "8BD8"
End Function

Function
Mov_EBX_ECX() As Long
OPcode = OPcode + "8BD9"
End Function

Function
Mov_EBX_EDI() As Long
OPcode = OPcode + "8BDF"
End Function

Function
Mov_EBX_EDX() As Long
OPcode = OPcode + "8BDA"
End Function

Function
Mov_EBX_ESI() As Long
OPcode = OPcode + "8BDE"
End Function

Function
Mov_EBX_ESP() As Long
OPcode = OPcode + "8BDC"
End Function

Function
Mov_ECX_EBP() As Long
OPcode = OPcode + "8BCD"
End Function

Function
Mov_ECX_EAX() As Long
OPcode = OPcode + "8BC8"
End Function

Function
Mov_ECX_EBX() As Long
OPcode = OPcode + "8BCB"
End Function

Function
Mov_ECX_EDI() As Long
OPcode = OPcode + "8BCF"
End Function

Function
Mov_ECX_EDX() As Long
OPcode = OPcode + "8BCA"
End Function

Function
Mov_ECX_ESI() As Long
OPcode = OPcode + "8BCE"
End Function

Function
Mov_ECX_ESP() As Long
OPcode = OPcode + "8BCC"
End Function

Function
Mov_EDX_EBP() As Long
OPcode = OPcode + "8BD5"
End Function

Function
Mov_EDX_EBX() As Long
OPcode = OPcode + "8BD3"
End Function

Function
Mov_EDX_ECX() As Long
OPcode = OPcode + "8BD1"
End Function

Function
Mov_EDX_EDI() As Long
OPcode = OPcode + "8BD7"
End Function

Function
Mov_EDX_EAX() As Long
OPcode = OPcode + "8BD0"
End Function

Function
Mov_EDX_ESI() As Long
OPcode = OPcode + "8BD6"
End Function

Function
Mov_EDX_ESP() As Long
OPcode = OPcode + "8BD4"
End Function

Function
Mov_ESI_EBP() As Long
OPcode = OPcode + "8BF5"
End Function

Func
tion
Mov_ESI_EBX() As Long
OPcode = OPcode + "8BF3"
End Function

Function
Mov_ESI_ECX() As Long
OPcode = OPcode + "8BF1"
End Function

Function
Mov_ESI_EDI() As Long
OPcode = OPcode + "8BF7"
End Function

Function
Mov_ESI_EAX() As Long
OPcode = OPcode + "8BF0"
End Function

Function
Mov_ESI_EDX() As Long
OPcode = OPcode + "8BF2"
End Function

Function
Mov_ESI_ESP() As Long
OPcode = OPcode + "8BF4"
End Function

Function
Mov_ESP_EBP() As Long
OPcode = OPcode + "8BE5"
End Function

Function
Mov_ESP_EBX() As Long
OPcode = OPcode + "8BE3"
End Function

Function
Mov_ESP_ECX() As Long
OPcode = OPcode + "8BE1"
End Function

Function
Mov_ESP_EDI() As Long
OPcode = OPcode + "8BE7"
End Function

Function
Mov_ESP_EAX() As Long
OPcode = OPcode + "8BE0"
End Function

Function
Mov_ESP_EDX() As Long
OPcode = OPcode + "8BE2"
End Function

Function
Mov_ESP_ESI() As Long
OPcode = OPcode + "8BE6"
End Function

Function
Mov_EDI_EBP() As Long
OPcode = OPcode + "8BFD"
End Function

Function
Mov_EDI_EAX() As Long
OPcode = OPcode + "8BF8"
End Function

Function
Mov_EDI_EBX() As Long
OPcode = OPcode + "8BFB"
End Function

Function
Mov_EDI_ECX() As Long
OPcode = OPcode + "8BF9"
End Function

Function
Mov_EDI_EDX() As Long
OPcode = OPcode + "8BFA"
End Function

Function
Mov_EDI_ESI() As Long
OPcode = OPcode + "8BFE"
End Function

Function
Mov_EDI_ESP() As Long
OPcode = OPcode + "8BFC"
End Function
Function
Mov_EBP_EDI() As Long
OPcode = OPcode + "8BDF"
End Function

Function
Mov_EBP_EAX() As Long
OPcode = OPcode + "8BE8"
End Function

Function
Mov_EBP_EBX() As Long
OPcode = OPcode + "8BEB"
End Function

Function
Mov_EBP_ECX() As Long
OPcode = OPcode + "8BE9"
End Function

Function
Mov_EBP_EDX() As Long
OPcode = OPcode + "8BEA"
End Function

Function
Mov_EBP_ESI() As Long
OPcode = OPcode + "8BEE"
End Function

Function
Mov_EBP_ESP() As Long
OPcode = OPcode + "8BEC"
End Function
'Push
'+++++++++++++++++++++++++++++++++++
Function Push(i As Long) As Long
'If i <= 255 Then
'OPcode = OPcode + "6A" + Int2Hex(i, 2)
'Else
OPcode = OPcode + "68" + Int2Hex(i, 8)
'End If
End Function

Function
Push_DWORD_Ptr(i As Long) As Long
OPcode = OPcode + "FF35" + Int2Hex(i, 8)
End Function

Function
Push_EAX() As Long
OPcode = OPcode + "50"
End Function

Function
Push_ECX() As Long
OPcode = OPcode + "51"
End Function

Function
Push_EDX() As Long
OPcode = OPcode + "52"
End Function

Function
Push_EBX() As Long
OPcode = OPcode + "53"
End Function
Function
ont color="#000000">Push_ESP()
As Long
OPcode = OPcode + "54"
End Function

Function
Push_EBP() As Long
OPcode = OPcode + "55"
End Function

Function
Push_ESI() As Long
OPcode = OPcode + "56"
End Function

Function
Push_EDI() As Long
OPcode = OPcode + "57"
End Function
'LEA
Function Lea_EAX_DWORD_Ptr_EAX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D40" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D80" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EAX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D43" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D83" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EAX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D41" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D81" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EAX_DWORD_Ptr_EDX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D42" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D82" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EAX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D46" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D86" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EAX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D40" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D80" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EAX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D4424" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D8424" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EAX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D47" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D87" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_EAX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D58" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D98" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D5C24" olor="#000000">+ Int2Hex(i, 2)
Else
OPcode = OPcode + "8D9C24" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D5B" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D9B" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D59" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D99" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_EDX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D5A" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D9A" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D5F" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D9F" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D5D" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D9D" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EBX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D5E" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D9E" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_EAX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D48" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D88" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D4C24" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D8C24" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D4B" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D8B" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D49" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D89" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_EDX_Add(i As Long) As Long
If t>i <= 255 Then
OPcode = OPcode + "8D4A" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D8A" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D4F" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D8F" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D4D" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D8D" + Int2Hex(i, 8)
End If
End Function

Function
Lea_ECX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D4E" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D8E" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EDX_DWORD_Ptr_EAX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D50" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D90" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EDX_DWORD_Ptr_ESP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D5424" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D9424" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EDX_DWORD_Ptr_EBX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D53" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D93" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EDX_DWORD_Ptr_ECX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D51" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D91" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EDX_DWORD_Ptr_EDX_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D52" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D92" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EDX_DWORD_Ptr_EDI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D57" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D97" + Int2Hex(i, 8)
End If
End Function

Function
Lea_EDX_DWORD_Ptr_EBP_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D55" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D95" + Int2Hex(i, 8)
End If
End Funct
ion

Function
Lea_EDX_DWORD_Ptr_ESI_Add(i As Long) As Long
If
i <= 255 Then
OPcode = OPcode + "8D56" + Int2Hex(i, 2)
Else
OPcode = OPcode + "8D96" + Int2Hex(i, 8)
End If
End Function

'POP
Function Pop_EAX() As Long
OPcode = OPcode + "58"
End Function

Function
Pop_EBX() As Long
OPcode = OPcode + "5B"
End Function

Function
Pop_ECX() As Long
OPcode = OPcode + "59"
End Function

Function
Pop_EDX() As Long
OPcode = OPcode + "5A"
End Function

Function
Pop_ESI() As Long
OPcode = OPcode + "5E"
End Function

Function
Pop_ESP() As Long
OPcode = OPcode + "5C"
End Function

Function
Pop_EDI() As Long
OPcode = OPcode + "5F"
End Function

Function
Pop_EBP() As Long
OPcode = OPcode + "5D"
End Function



Option Explicit

Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Public Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Public Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Public Const MOUSEEVENTF_MIDDLEDOWN = &H20 ' middle button down
Public Const MOUSEEVENTF_MIDDLEUP = &H40 ' middle button up
Public Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Public Const MOUSEEVENTF_RIGHTDOWN = &H8 ' right button down
Public Const MOUSEEVENTF_RIGHTUP = &H10 ' right button up
Public Const MOUSEEVENTF_WHEEL = &H800

Private Sub Command1_Click()
Timer1.Interval =
5000
Timer1.Enabled = True
End Sub

Private Sub
Timer1_Timer()
Dim i As Integer
For
i = 0 To 100
DoEvents
mouse_event MOUSEEVENTF_WHEEL,
0, 0, 10, 0
Next
For
i = 0 To 100
DoEvents
mouse_event MOUSEEVENTF_WHEEL,
0, 0, -10, 0
Next
End Sub