Private Declare Function UserDllMain Lib "msvbvm60" (OutInstance As Long, ByVal Unused As Long, ByVal hInstDll As Long, ByVal dwReason As Long, ByVal lpReserved As Long) As Long
Private Declare Function VBDllGetClassObject Lib "msvbvm60" (lpHInstDll As Long, ByVal Reserved As Long, lpVBHeader As Any, CLSID As Any, IID As Any, lpOutObject As IUnknown) As Long
在 IDE 里面调试的话,似乎只能创建出一个线程。但这个线程是可以正常工作的。而且如果主线程先于这个线程退出,则会在这个线程退出后,直接造成 VB6 的 IDE 闪退。
代码全部整理下来,做到一个 BAS 里即可使用:
[Visual Basic] 纯文本查看复制代码
Option Explicit
Private Type VbHeader
szVbMagic As String * 4
wRuntimeBuild As Integer
szLangDll As String * 14
szSecLangDll As String * 14
wRuntimeRevision As Integer
dwLCID As Long
dwSecLCID As Long
lpSubMain As Long
lpProjectInfo As Long
fMdlIntCtls As Long
fMdlIntCtls2 As Long
dwThreadFlags As Long
dwThreadCount As Long
wFormCount As Integer
wExternalCount As Integer
dwThunkCount As Long
lpGuiTable As Long
lpExternalCompTable As Long
lpComRegisterData As Long
bszProjectDescription As Long
bszProjectExeName As Long
bszProjectHelpFile As Long
bszProjectName As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function UserDllMain Lib "msvbvm60" (OutInstance As Long, ByVal Unused As Long, ByVal hInstDll As Long, ByVal dwReason As Long, ByVal lpReserved As Long) As Long
Private Declare Function CreateIExprSrvObj Lib "msvbvm60" (Optional ByVal Reserved As Long, Optional ByVal Size As Long = 4, Optional ByVal Fail As Boolean) As IUnknown
Private Declare Function VBDllGetClassObject Lib "msvbvm60" (lpHInstDll As Long, ByVal Reserved As Long, lpVBHeader As Any, CLSID As Any, IID As Any, lpOutObject As IUnknown) As Long
Private Declare Function FuncAddr Lib "msvbvm60" Alias "VarPtr" (ByVal AddressOfSomething As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, Target As Any)
Private MTInst As Long
Private hInst As Long
Private VBHPtr As Long, NewVBH As VbHeader
Private MT_CLSID(15) As Byte
Private MT_IID_IUnknown(15) As Byte
Public Const DLL_PROCESS_ATTACH As Long = 1
Public Const DLL_THREAD_ATTACH As Long = 2
Public Const DLL_THREAD_DETACH As Long = 3
Public Const DLL_PROCESS_DETACH As Long = 0
Sub Main()
MT_Init
Load Form1
Form1.Show
End Sub
Sub MT_Init()
hInst = App.hInstance
MT_IID_IUnknown(8) = &HC0
MT_IID_IUnknown(15) = &H46
VBHPtr = GetVBHeaderPtr
If VBHPtr > 0 Then
CopyMemory NewVBH, ByVal VBHPtr, Len(NewVBH)
NewVBH.lpSubMain = FuncAddr(AddressOf DummySubMain)
End If
End Sub
Sub StartNewThread(Optional ByVal ThreadParam As Long, Optional Out_ThreadId As Long)
CloseHandle CreateThread(ByVal 0, 0, AddressOf ThreadEntry, ThreadParam, 0, Out_ThreadId)
End Sub
Sub DummySubMain()
'空过程
End Sub
Private Function GetVBHeaderPtr() As Long
Dim Ptr As Long
' Get e_lfanew
GetMem4 ByVal hInst + &H3C, Ptr
' Get AddressOfEntryPoint
GetMem4 ByVal Ptr + &H28 + hInst, Ptr
' Get VBHeader
GetMem4 ByVal Ptr + hInst + 1, GetVBHeaderPtr
End Function
Private Function ThreadEntry(ByVal ThreadParam As Long) As Long
'初始化线程
Dim ESO As IUnknown, ClassObj As IUnknown
Set ESO = CreateIExprSrvObj()
UserDllMain MTInst, 0, hInst, DLL_THREAD_ATTACH, 0
If VBHPtr > 0 Then VBDllGetClassObject MTInst, 0, NewVBH, MT_CLSID(0), MT_IID_IUnknown(0), ClassObj
'在这里写你的多线程内容
Sleep 100
MsgBox "线程函数:测试" & ThreadParam, , "测试"
'线程退出
UserDllMain MTInst, 0, hInst, DLL_THREAD_DETACH, 0
End Function
Private Type VbHeader
szVbMagic As String * 4
wRuntimeBuild As Integer
szLangDll As String * 14
szSecLangDll As String * 14
wRuntimeRevision As Integer
dwLCID As Long
dwSecLCID As Long
lpSubMain As Long
lpProjectInfo As Long
fMdlIntCtls As Long
fMdlIntCtls2 As Long
dwThreadFlags As Long
dwThreadCount As Long
wFormCount As Integer
wExternalCount As Integer
dwThunkCount As Long
lpGuiTable As Long
lpExternalCompTable As Long
lpComRegisterData As Long
bszProjectDescription As Long
bszProjectExeName As Long
bszProjectHelpFile As Long
bszProjectName As Long
End Type