mthreadcontrol.ctl

.不是源码读您的文件包然后写出其具体读您的文件包然后写出其具体

VERSION 5.00
Begin VB.UserControl mThreadControl 
   ClientHeight    =   240
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1965
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   240
   ScaleWidth      =   1965
   Windowless      =   -1  'True
   Begin VB.Label Label1 
      Caption         =   "amic-multiThread"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00800000&
      Height          =   255
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   2175
   End
End
Attribute VB_Name = "mThreadControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
    
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateThreadAPI Lib "kernel32" Alias "CreateThread" (ByVal lpThreadA As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function TerminateThreadAPI Lib "kernel32" Alias "TerminateThread" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function ResumeThreadAPI Lib "kernel32" Alias "ResumeThread" (ByVal hThread As Long) As Long
Private Declare Function SuspendThreadAPI Lib "kernel32" Alias "SuspendThread" (ByVal hThread As Long) As Long
Private Declare Function TlsGetValue Lib "kernel32" (ByVal dwTlsIndex As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private lTlsIndex   As Long
Private lpTlsValue  As Long
Private mEnabled    As Boolean
Private lpTPParam   As ThreadParam
Event RunThread(ByVal lpParam As Long)
Public hThread      As Long

Public Function CreateThread(ByVal lpParam As Long, lpThreadId As Long) As Long
    hThread = 0
    lpTPParam.lpParam = lpParam
    hThread = CreateThreadAPI(0, 0, AddressOf RunThread, lpTPParam, 0, lpThreadId)
    CreateThread = hThread
End Function

Public Function TerminateThread() As Long
    TerminateThread = TerminateThreadAPI(hThread, 0)
End Function

Public Function SuspendThread() As Long
    SuspendThread = SuspendThreadAPI(hThread)
End Function

Public Function ResumeThread() As Long
    ResumeThread = ResumeThreadAPI(hThread)
End Function
Public Sub about()
Attribute about.VB_MemberFlags = "40"
    Dim Msg As String
    Msg = String(50, Asc("-")) & vbCrLf & _
    "予心居" & vbCrLf & "QQ:35723195" & vbCrLf & _
    "Email:[e-mail]" & vbCrLf & _
    "版权所有(C) amicy 2004-2008" & vbCrLf & vbCrLf & _
    "2008-10-01 vb6开发,测试于win2003系统" & vbCrLf & _
    "运行于win2000系统或以上，vb6运行库" & vbCrLf & _
    String(50, Asc("-"))
    MsgBox Msg, vbMsgBoxSetForeground, "关于multiThread..."
End Sub

    
Public Sub RunThread____(ByVal lpParam As Long)
Attribute RunThread____.VB_MemberFlags = "40"
    RaiseEvent RunThread(lpParam)
    hThread = 0
End Sub
Private Function MSVBVM60TlsIndex(lpTlsValue As Long) As Long
    Dim lTlsIndex As Long, hMod As Long, lproAdr As Long
    Dim b_vbaSetSystemError(28) As Byte, ltlsAdr As Long
    hMod = LoadLibrary("MSVBVM60.DLL")
    lproAdr = GetProcAddress(hMod, "__vbaSetSystemError")
    CopyMemory b_vbaSetSystemError(0), ByVal lproAdr, UBound(b_vbaSetSystemError) + 1
    CopyMemory ltlsAdr, b_vbaSetSystemError(9), 4
    CopyMemory lTlsIndex, ByVal ltlsAdr, 4
    lpTlsValue = TlsGetValue(lTlsIndex)
    MSVBVM60TlsIndex = lTlsIndex
End Function

Private Sub UserControl_Initialize()
    lpTPParam.lTlsIndex = MSVBVM60TlsIndex(lpTPParam.lpTlsValue)
    Set lpTPParam.lpProcess = Me
End Sub

Private Sub UserControl_Resize()
    UserControl.Width = 1965
    UserControl.Height = 240
End Sub