vb多线程操作类

Option Explicit

Private Declare Function CreateWin32Thread Lib "kernel32" Alias "CreateThread" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function SuspendThread Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
Private Declare Function WriteProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function TlsSetValue Lib "kernel32" (ByVal dwTlsIndex As Long, ByVal lpTlsValue As Long) As Long
Private Declare Function TlsGetValue Lib "kernel32" (ByVal dwTlsIndex As Long) As Long

Enum CreateOperation
  CREATE_SUSPENDED = &H4
  CREATE_ENABLED = 0&
End Enum

Enum ThreadPriority
  THREAD_PRIORITY_LOWEST = -2
  THREAD_PRIORITY_BELOW_NORMAL = -1
  THREAD_PRIORITY_NORMAL = 0
  THREAD_PRIORITY_ABOVE_NORMAL = 1
  THREAD_PRIORITY_HIGHEST = 2
End Enum

Private Type ThisClassSet
  t_ThreadHandle   As Long
  t_ThreadID       As Long
  t_ThreadPriority As Long
  c_ThdEnabled  As Boolean
  m_ThreadTlsData(1 To 64) As Long
End Type
Private PG As ThisClassSet

Private LinkProc() As Long
Event ThreadEntry(ByVal UserParam As Long, ByVal ThreadHandle As Long, ByVal ThreadID As Long)


Private Function ThreadEntryProc(ByVal Param As Long) As Long
  '********************************************************************
  '  None = ThreadEntryProc( 用户自定义参数 )
  '********************************************************************
      
    Dim i As Long
    For i = 1 To 64: TlsSetValue i, PG.m_ThreadTlsData(i): Next
    RaiseEvent ThreadEntry(Param, PG.t_ThreadHandle, PG.t_ThreadID)     '抛出多线程入口事件
    TerminateCurrentThread
'    Call ThreadEntry(Param, PG.t_ThreadHandle, PG.t_ThreadID)
End Function

Function CreateThread(ByVal lParam As Long, Optional cEnabled As CreateOperation = CREATE_ENABLED) As Long
  '********************************************************************
  '  线程句柄 = CreateThread( 用户自定义参数, [线程创建时的操作])
  '********************************************************************
  
  Dim ThreadEntryAddress  As Long
  If PG.t_ThreadID Then Exit Function
  ThreadEntryAddress = GetClassProcAddress(LinkProc, 9, 1)              '获取 ThreadEntryProc 的函数地址
  PG.t_ThreadHandle = CreateWin32Thread(0, 0, ThreadEntryAddress, lParam, cEnabled, PG.t_ThreadID)
  If PG.t_ThreadHandle Then CreateThread = PG.t_ThreadHandle: PG.c_ThdEnabled = CBool(cEnabled)

End Function

Sub TerminateCurrentThread(Optional ByVal ExitCode As Long = 1)
  '********************************************************************
  '  TerminateCurrentThread( [退出码] )
  '********************************************************************

  With PG
    If PG.t_ThreadID Then
        TerminateThread PG.t_ThreadHandle, ByVal ExitCode&
        CloseHandle .t_ThreadHandle
        .t_ThreadID = 0
        .t_ThreadHandle = 0
        .c_ThdEnabled = False
    End If
  End With
End Sub

Property Get ThreadHandle() As Long
  ThreadHandle = PG.t_ThreadHandle
End Property

Property Get ThreadID() As Long
  ThreadID = PG.t_ThreadID
End Property

Property Get Priority() As ThreadPriority
  Priority = GetThreadPriority(PG.t_ThreadPriority)
End Property

Property Let Priority(ByVal tmpValue As ThreadPriority)
  PG.t_ThreadPriority = tmpValue
  Call SetThreadPriority(PG.t_ThreadHandle, tmpValue)
End Property

Property Get Enabled() As Boolean
  Enabled = PG.c_ThdEnabled
End Property

Property Let Enabled(ByVal tmpValue As Boolean)
  PG.c_ThdEnabled = tmpValue
  If tmpValue = True Then
    ResumeThread (PG.t_ThreadHandle)
  ElseIf tmpValue = False Then
    SuspendThread (PG.t_ThreadHandle)
  End If
End Property

Private Sub Class_Initialize()
    '初始化多线程
    ThreadTlsInitial
End Sub

Private Sub Class_Terminate()
    '类销毁时强制销毁线程
   Call TerminateCurrentThread
End Sub

Private Sub ThreadTlsInitial()
    '获取新线程的运行环境数据
    Dim i As Long
    For i = 1 To 64
        PG.m_ThreadTlsData(i) = TlsGetValue(i)
    Next
    WriteProcessMemory -1&, ByVal GetProcAddress(GetModuleHandle("msvbvm60.dll"), "__vbaSetSystemError"), &HC3, 1&, 0&
End Sub

Private Function GetClassProcAddress(LinkProc() As Long, ByVal SinceCount As Long, ByVal ParamsCount As Long) As Long
    '为新线程的回调函数获取函数地址
    Dim mePtr As Long
    Dim jmpAddress As Long
    mePtr = ObjPtr(Me)
    CopyMemory jmpAddress, ByVal mePtr, 4
    CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4
    ReDim LinkProc(8)
    LinkProc(0) = &H83EC8B55: LinkProc(1) = &HFC8BFFEC: LinkProc(2) = &H3308758D: LinkProc(3) = &HFCFFB1C9
    LinkProc(4) = &HFF68A5F3: LinkProc(5) = &HB8FFFFFF: LinkProc(6) = &HFFFFFFFF: LinkProc(7) = &HC2C9D0FF: LinkProc(8) = &HFF
    CopyMemory ByVal VarPtr(LinkProc(1)) + 1, ParamsCount * 4, 1
    CopyMemory ByVal VarPtr(LinkProc(3)) + 2, ParamsCount, 1
    CopyMemory ByVal VarPtr(LinkProc(4)) + 3, mePtr, 4
    CopyMemory ByVal VarPtr(LinkProc(6)), jmpAddress, 4
    If ParamsCount = 0 Then CopyMemory ByVal (VarPtr(LinkProc(7)) + 3), &HC3, 1
    LinkProc(8) = ParamsCount * 4
    GetClassProcAddress = VarPtr(LinkProc(0))
End Function

实验了好几个类和模块，就这个类相对比较稳定，而且使用也简单。还有个dll多线程也很稳定，不想用dll就不放了。