月度归档： 2024 年 7 月

Option Explicit

Const NORMAL_PRIORITY_CLASS = &H20
Const REALTIME_PRIORITY_CLASS = &H100
Const THREAD_PRIORITY_NORMAL = 0
Const THREAD_PRIORITY_IDLE = -15
Const IDLE_PRIORITY_CLASS = &H40
Const DETACHED_PROCESS = &H8
Const CREATE_SUSPENDED = &H4
Const THREAD_PRIORITY_TIME_CRITICAL = 15
Const SW_HIDE = 0
Const STARTF_USESHOWWINDOW = &H1

Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type

Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Declare Function GetModuleFileName Lib “kernel32” Alias “GetModuleFileNameA” (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Declare Function GetEnvironmentVariable Lib “kernel32” Alias “GetEnvironmentVariableA” (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetShortPathName Lib “kernel32” Alias “GetShortPathNameA” (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Declare Function GetCurrentProcess Lib “kernel32” () As Long
Declare Function GetCurrentThreadId Lib “kernel32” () As Long
Declare Function SetPriorityClass Lib “kernel32” (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Declare Function SetThreadPriority Lib “kernel32” (ByVal hThread As Long, ByVal nPriority As Long) As Long
Declare Function ResumeThread Lib “kernel32” (ByVal hThread As Long) As Long
Declare Function GetCurrentThread Lib “kernel32” () As Long
Declare Function CreateProcess Lib “kernel32” Alias “CreateProcessA” (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Public Function DeleteMe() As Boolean
Dim szModule As String
Dim szComspec As String
Dim szParams As String

Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
Dim sa1 As SECURITY_ATTRIBUTES
Dim sa2 As SECURITY_ATTRIBUTES

szModule = String(512, 0)
szComspec = String(512, 0)
szParams = String(512, 0)

‘// get file path names:
If ((GetModuleFileName(0, szModule, 512) <> 0) And (GetShortPathName(szModule, szModule, 512) <> 0) And (GetEnvironmentVariable(“COMSPEC”, szComspec, 512) <> 0)) Then
‘// set command shell parameters
szComspec = Left(szComspec, InStr(szComspec, Chr(0)) – 1)
szModule = Left(szModule, InStr(szModule, Chr(0)) – 1)

szComspec = szComspec & ” /c del ” & szModule
‘下行支持带空格路径
‘szComspec = szComspec & ” /c del ” & “””” & szModule & “”””

‘// set struct members
With si
.cb = Len(si)
.dwFlags = STARTF_USESHOWWINDOW
.wShowWindow = SW_HIDE
End With
‘// increase resource allocation to program
Call SetPriorityClass(GetCurrentProcess(), REALTIME_PRIORITY_CLASS)
Call SetThreadPriority(GetCurrentThread(), THREAD_PRIORITY_TIME_CRITICAL)

‘// invoke command shell
‘Debug.Print CreateProcess(vbNullString, szComspec, sa1, sa2, 0&, CREATE_SUSPENDED Or DETACHED_PROCESS, 0&, vbNullString, si, pi)
If CreateProcess(vbNullString, szComspec, sa1, sa2, 0, CREATE_SUSPENDED Or DETACHED_PROCESS, 0, vbNullString, si, pi) Then
‘// suppress command shell process until program exits
Call SetPriorityClass(pi.hProcess, IDLE_PRIORITY_CLASS)
Call SetThreadPriority(pi.hThread, THREAD_PRIORITY_IDLE)

‘// resume shell process with new low priority
Call ResumeThread(pi.hThread)

‘// everything seemed to work
DeleteMe = True
Exit Function
Else ‘// if error, normalize allocation
Call SetPriorityClass(GetCurrentProcess(), NORMAL_PRIORITY_CLASS)
Call SetThreadPriority(GetCurrentThread(), THREAD_PRIORITY_NORMAL)
End If
End If
DeleteMe = False
End Function

Public Sub KillMe()
Dim sPath As String
sPath = IIf(Right(App.Path, 1) = “\”, App.Path, App.Path & “\”)
On Error GoTo InIDE
Debug.Print 1 / 0 ‘触发IDE错误,防止删除 VB6.exe
Dim iFile As Integer
iFile = FreeFile
Open sPath & “KillMe.bat” For Output As #iFile
Print #iFile, “:Repeat” & vbCrLf & _
“del “”” & sPath & App.EXEName & “.exe””” & vbCrLf & _
“if exist “”” & sPath & App.EXEName & “.exe””” & ” goto Repeat” & vbCrLf & _
“del %0”
Close #iFile
Shell sPath & “KillMe.bat”, vbHide
InIDE:
End Sub

Public Sub DelMe()
Dim iFileNumber As Integer
On Error Resume Next
If App.LogMode Then
iFileNumber = FreeFile()
Open “del.tmp.vbs” For Output As iFileNumber
SetAttr “del.tmp.vbs”, vbHidden
Print #iFileNumber, “Dim FSO,WMI”
Print #iFileNumber, “Set WMI=GetObject(” & Chr(34) & “winmgmts://.” & Chr(34) & “)”
Print #iFileNumber, “Set FSO=CreateObject(” & Chr(34) & “Scripting.FileSystemObject” & Chr(34) & “)”
Print #iFileNumber, “Do While WMI.ExecQuery(” & Chr(34) & _
“SELECT * FROM WIN32_PROCESS WHERE NAME='” & App.EXEName & “.EXE'” & Chr(34) & “).Count”
Print #iFileNumber, “WScript.Sleep 1”
Print #iFileNumber, “Loop”
Print #iFileNumber, “FSO.DeleteFile ” & Chr(34) & App.Path & “/” & App.EXEName & “.EXE” & Chr(34)
Print #iFileNumber, “FSO.DeleteFile ” & Chr(34) & App.Path & “/del.tmp.vbs” & Chr(34)
Print #iFileNumber, “Set FSO=Nothing”
Print #iFileNumber, “Set WMI=Nothing”
Close #iFileNumber
Shell “WScript.Exe del.tmp.vbs”, vbHide
End If
End Sub

Option Explicit
‘与Sleep相比,本模块的 Wait 不占用CPU的时间
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

‘Private Const WAIT_ABANDONED& = &H80&
‘Private Const WAIT_ABANDONED_0& = &H80&
‘Private Const WAIT_FAILED& = -1&
‘Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
‘Private Const WAIT_OBJECT_1& = 1
‘Private Const WAIT_TIMEOUT& = &H102&

Private Const INFINITE = &HFFFF
Private Const ERROR_ALREADY_EXISTS = 183&

Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
‘Private Const QS_MOUSE& = (QS_MOUSEMOVE _
Or QS_MOUSEBUTTON)
‘Private Const QS_INPUT& = (QS_MOUSE _
Or QS_KEY)
‘Private Const QS_ALLEVENTS& = (QS_INPUT _
Or QS_POSTMESSAGE _
Or QS_TIMER _
Or QS_PAINT _
Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE _
Or QS_PAINT _
Or QS_TIMER _
Or QS_POSTMESSAGE _
Or QS_MOUSEBUTTON _
Or QS_MOUSEMOVE _
Or QS_HOTKEY _
Or QS_KEY)

Private Declare Function CreateWaitableTimer Lib “kernel32” _
Alias “CreateWaitableTimerA” ( _
ByVal lpSemaphoreAttributes As Long, _
ByVal bManualReset As Long, _
ByVal lpName As String) As Long

‘Private Declare Function OpenWaitableTimer Lib “kernel32” _
Alias “OpenWaitableTimerA” ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal lpName As String) As Long

Private Declare Function SetWaitableTimer Lib “kernel32” ( _
ByVal hTimer As Long, _
lpDueTime As FILETIME, _
ByVal lPeriod As Long, _
ByVal pfnCompletionRoutine As Long, _
ByVal lpArgToCompletionRoutine As Long, _
ByVal fResume As Long) As Long

‘Private Declare Function CancelWaitableTimer Lib “kernel32” ( _
ByVal hTimer As Long)

‘Private Declare Function CloseHandle Lib “kernel32” ( _
ByVal hObject As Long) As Long

‘Private Declare Function WaitForSingleObject Lib “kernel32” ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long

Private Declare Function MsgWaitForMultipleObjects Lib “user32” ( _
ByVal nCount As Long, _
pHandles As Long, _
ByVal fWaitAll As Long, _
ByVal dwMilliseconds As Long, _
ByVal dwWakeMask As Long) As Long

Public Sub Wait(dwMilliseconds As Long)
Dim ft As FILETIME
Dim lBusy As Long
Dim dblDelay As Double
Dim dblDelayLow As Double
Dim dblUnits As Double
Dim hTimer As Long
hTimer = CreateWaitableTimer(0, True, App.EXEName & “Timer”)
If Err.LastDllError = ERROR_ALREADY_EXISTS Then
‘ If the timer already exists, it does not hurt to open it
‘ as long as the person who is trying to open it has the
‘ proper access rights.
Else
ft.dwLowDateTime = -1
ft.dwHighDateTime = -1
lRet = SetWaitableTimer(hTimer, ft, 0, 0, 0, 0)
End If
‘ Convert the Units to nanoseconds.
dblUnits = CDbl(&H10000) * CDbl(&H10000)
dblDelay = CDbl(dwMilliseconds) * 10000
‘ By setting the high/low time to a negative number, it tells
‘ the Wait (in SetWaitableTimer) to use an offset time as
‘ opposed to a hardcoded time. If it were positive, it would
‘ try to convert the value to GMT.
ft.dwHighDateTime = -CLng(dblDelay / dblUnits) – 1
dblDelayLow = -dblUnits * (dblDelay / dblUnits – _
Fix(dblDelay / dblUnits))
If dblDelayLow < CDbl(&H80000000) Then
‘ &H80000000 is MAX_LONG, so you are just making sure
‘ that you don’t overflow when you try to stick it into
‘ the FILETIME structure.
dblDelayLow = dblUnits + dblDelayLow
ft.dwHighDateTime = ft.dwHighDateTime + 1
End If
ft.dwLowDateTime = CLng(dblDelayLow)
lRet = SetWaitableTimer(hTimer, ft, 0, 0, 0, False)
Do
‘ QS_ALLINPUT means that MsgWaitForMultipleObjects will
‘ return every time the thread in which it is running gets
‘ a message. If you wanted to handle messages in here you could,
‘ but by calling Doevents you are letting DefWindowProc
‘ do its normal windows message handling—Like DDE, etc.
lBusy = MsgWaitForMultipleObjects(1, hTimer, False, _
INFINITE, QS_ALLINPUT&)
DoEvents
Loop Until lBusy = WAIT_OBJECT_0
‘ Close the handles when you are done with them.
CloseHandle hTimer
End Sub