改良的多线程绘图演示程序,供初学多线程者学习(含源码)

hadky

196466517

搞定了,原来是注入dll问题。。。我现在用tgy你这个加上菜鸟学飞的。。。已完美的dll注入后不抢夺宿主的焦点了，这要归功于SetTimer

'====================================================DLL、多线程通用初始化模块 1.0 BY TGY =============================================
'VB 标准DLL与多线程初始化模块(无汇编、不用TLB、不COPYMEMORY，纯API+VB实现，使用方便，
'生成标准DLL时，使用世面上流行的插件或拦截link.exe方法均可，只要能指定入口函数和输出函数就行，如果用于注入，可以只指定入口函数编译。)
'BY tgy
'日期:2011/10
'======================================================================================================================================
'以下定义的API有些可能不是必须，根据实际需要决定
Option Explicit
Public Type UUID
    data1 As Long
    data2 As Integer
    data3 As Integer
    data4(7) As Byte
End Type
Const DLL_PROCESS_ATTACH       As Long = 1
Const DLL_THREAD_ATTACH       As Long = 2
Const DLL_PROCESS_DETACH       As Long = 0
Const DLL_THREAD_DETACH       As Long = 3

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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

Public Declare Function CreateThread Lib "kernel32" (ByVal lpSecurityAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As Long) As Long
Public Declare Function GetModuleHandlet Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Public Declare Function UserDllMain Lib "msvbvm60.dll" (gloaders As Long, gvb As Long, ByVal hinstdll As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
Public Declare Function VBDllGetClassObject Lib "msvbvm60.dll" (gloaders As Long, gvb As Long, ByVal gvbtab As Long, rclsid As UUID, riid As UUID, ppv As Any) As Long
Public Declare Function CoInitialize Lib "ole32.dll" (ByVal pvReserved As Long) As Long
Public Declare Sub CoUninitialize Lib "ole32.dll" ()
Public Declare Function CreateIExprSrvObj Lib "msvbvm60.dll" (ByVal p1_0 As Long, ByVal p2_4 As Long, ByVal p3_0 As Long) As Long
Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal hprocess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public hh As Long, showbool As Boolean, n As Long

Public Function DllMain(ByVal hinstdll As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long 'VB标准DLL入口函数
    If fdwReason = 1 Then
        hh = hinstdll
        init ByVal hh
        SetTimer GetForegroundWindow, GetForegroundWindow, 1, AddressOf main1
        DllMain = 1
    End If
   
End Function
Public Sub init(ByVal hinstdll As Long)                                         '线程或DLL调用初始化VB环境函数 ,dll调用时hinstdll为DLL基地址,EXE多线程调用时为EXE基地址
    Dim fake As Long
    Dim lp As Long, lvb As Long
    Dim riid As UUID
    Dim aiid As UUID
    Dim ofac As Object
    Dim f0 As Long
    Dim fakehead As Long
    Dim ll As Long
    hh = hinstdll
    CreateIExprSrvObj 0, 4, 0
    Call CoInitialize(0)
    With riid
        .data1 = 1
        .data4(0) = &HC0
        .data4(7) = &H46
    End With
    f0 = GetFakeH(GetModuleHandle(0))
    fakehead = GetFakeH(hinstdll)
    If f0 = 0 Then
        Call VBDllGetClassObject(GetModuleHandle(0), lvb, ByVal fakehead, aiid, riid, ofac)
    Else
        Call VBDllGetClassObject(hinstdll, lvb, ByVal fakehead, aiid, riid, ofac)
    End If
    App.Title = App.Title
    hh = hinstdll
End Sub

Public Function GetFakeH(ByVal hin As Long) As Long                             '取VB头,全新的取VB头方法,速度比OPEN文件快得多
    Dim lPtr     As Long
    Dim lRet     As Long
    Dim isvb As String
    Dim ll As Long
    Dim mdat(1033) As Byte
    GetFakeH = 0
    lPtr = hin
    isvb = StrConv("VB5!", vbFromUnicode)
    Do
        If ReadProcessMemory(-1, ByVal lPtr, mdat(0), 1034, ll) = 0 Then Exit Function
        lRet = InStrB(mdat, isvb)
        If lRet <> 0 Then Exit Do
        lPtr = lPtr + 1024
    Loop
    GetFakeH = lPtr + lRet - 1
End Function
Public Sub Main()
End Sub
Public Sub main1()
If showbool = False Then
InitVB                             '这里用init byval hh 不能用。。。。估计是回调的原因
showbool = True
Dim mypid As Long
GetWindowThreadProcessId GetForegroundWindow, mypid
hh = Getdll(mypid, "starhook.dll") '自己写了个取dll地址的 用菜鸟学飞大哥的initvb后 hh会变为空值。。。....
App.TaskVisible = True
Form1.Show
End If
End Sub

Public Sub xx() '测试线程。。。任务管理器中现在正常了
init ByVal hh
App.TaskVisible = False
Do
If n > 2111111110 Then n = 0
n = n + 1
Sleep 1
DoEvents
Form1.Caption = n
Loop
End Sub

再次感谢

ntaryl

Very nice Stuff  
And work fine without problems   
Thanks   



p.s the Dll is open source  ?
Possible to use forms  and Sockets  ?

bjtiantang

我很知道比老汉发的那个多了些什么功能  还是有重复运行启动Main的bug

tgy

bjtiantang 发表于 2012-2-24 18:28
我很知道比老汉发的那个多了些什么功能  还是有重复运行启动Main的bug

功能似乎也没有多大变化 ,增加支持显示非模态窗口,增加到4个线程参数,不OPEN 文件,使用DLL中的类话,可以在窗体中定义线程函数,通过类创建线程等.
重复运行启动Main问题没有处理,只要知道有这个问题,大家自己处理了.

19900603

话说 开那么多线程有用吗？ 线程多了 线程之间的切换 很有压力吧。。。

sexfio

能不能用winhttp啊，不能用的话对我没什么用 啊，哎，遗憾！

tgy

sexfio 发表于 2012-2-24 22:32
能不能用winhttp啊，不能用的话对我没什么用 啊，哎，遗憾！

怎么会不可以用?有这么遗憾...?

sexfio

tgy 发表于 2012-2-24 23:40
怎么会不可以用?有这么遗憾...?

你这样运行一次是可以,但是看不出问题啊,实际中要大量调用,问题就会出现了
比如我改的这样,你点全部获取后,拖动几下软件标题栏,没5-6次程序就自动消失了...什么提示也没有,

而我需要多线程至少30个连续几十个小时都不出错才实用呀

测试程序要实现：
1:创立10个线程，每个线程不断的获取baidu的源码,显示出来（带上个变化的数字以便观察,最好可以设置间隔时间比如300ms）
2:连续运行至少10分钟都不会崩溃

ntaryl

Watch this Subject and have to say Congratulations TGY
Thanks for the Sharing