VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
楼主: tgy

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

  [复制链接]
发表于 2012-2-23 22:50:21 | 显示全部楼层
本帖最后由 hadky 于 2012-2-23 22:50 编辑

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
回复 支持 反对

使用道具 举报

发表于 2012-2-23 23:23:00 | 显示全部楼层
搞定了,原来是注入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

再次感谢
回复 支持 反对

使用道具 举报

发表于 2012-2-24 01:20:46 | 显示全部楼层
本帖最后由 ntaryl 于 2012-2-24 01:22 编辑

Very nice Stuff  
And work fine without problems   
Thanks   



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

回复 支持 反对

使用道具 举报

发表于 2012-2-24 18:28:19 | 显示全部楼层
我很知道比老汉发的那个多了些什么功能  还是有重复运行启动Main的bug
回复 支持 反对

使用道具 举报

 楼主| 发表于 2012-2-24 18:54:26 | 显示全部楼层
本帖最后由 tgy 于 2012-2-25 16:10 编辑
bjtiantang 发表于 2012-2-24 18:28
我很知道比老汉发的那个多了些什么功能  还是有重复运行启动Main的bug


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

使用道具 举报

发表于 2012-2-24 20:51:49 | 显示全部楼层
话说 开那么多线程有用吗? 线程多了 线程之间的切换 很有压力吧。。。
回复 支持 反对

使用道具 举报

发表于 2012-2-24 22:32:21 | 显示全部楼层
能不能用winhttp啊,不能用的话对我没什么用 啊,哎,遗憾!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2012-2-24 23:40:33 | 显示全部楼层
本帖最后由 tgy 于 2012-2-24 23:51 编辑
sexfio 发表于 2012-2-24 22:32
能不能用winhttp啊,不能用的话对我没什么用 啊,哎,遗憾!


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


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
回复 支持 反对

使用道具 举报

发表于 2012-2-25 00:26:26 | 显示全部楼层
本帖最后由 sexfio 于 2012-2-25 00:35 编辑
tgy 发表于 2012-2-24 23:40
怎么会不可以用?有这么遗憾...?


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

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

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
回复 支持 反对

使用道具 举报

发表于 2012-2-25 01:07:34 | 显示全部楼层
Watch this Subject and have to say Congratulations TGY
Thanks for the Sharing   
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-7-3 15:53

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表