VBGood网站全文搜索 Google

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

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 56579|回复: 199

[原创]全球首创? 再次突破VB极限!VB真正稳定多线程(第二季,可以用Msgbox了)

  [复制链接]
 楼主| 发表于 2010-5-6 08:30:18 | 显示全部楼层 |阅读模式
本帖最后由 download 于 2010-5-6 17:15 编辑

贴子标题有长度限制!这里补上
原标题:  (原创)全球首创? 再次突破VB极限!VB真正稳定多线程(第二季,可以用Msgbox,类Set New,对象CreateObject,文件操作Open,Close,Get, FreeFile了)


转载者注意:此贴不完整,并且有故意设的BUG,转载后果自负!

编辑加入:经讨论支持文件操作Open,Get,...测试代码有BUG.这里就不修正了(主要是测试看看转载的是不是看都不看连BUG也转).具体的请看后面的贴子讨论.

前言:第二季在第一季的基础上,支持Msgbox,支持CreateObject,支持Class,等等...
搞这个花了老汉好多时间(时间就是生命,时间就是金钱,时间就是...)所以发出来看看能不能混个精华加点分之类的...根据大家的反应可能会继续推出第三季...



VB稳定多线程(第一季)http://www.vbgood.com/viewthread.php?tid=92847

序:
第一季发布后,老外提了一个idea,用一个dll引诱VB加载从而达到初始化VB的目的
由于带一个dll实在不爽,所以经老汉改造后取消了多余的dll. 全部由VB代码实现.不使用TLB,OCX,或其它附带的不明DLL.




此突破由izero发现:
http://www.vbgood.com/viewthread.php?tid=92847&page=10#pid523323
1. I am from Slovakia, I am not speaking Chinese ;)
2. Some sample code is attached .. I use tlb, but for this sample I mix you code (CreateIExpObject) with DLLGetClassObject code, see attachement
3. no, is not registered on mars ... see COINIT_MULTITHREADED and CoInitializeEx and then CoRegistreClassObject

... I mean, the fakeheader is one of posible way to "bypas" DLLGetClassObject, vbheader is something like IStreamed data from which is new class constructed. But this way need more investigation ;) Maybe another way (I see it in one of multithreading library) to multithreading is to using EbLoadRuntime, search on Google for some samples (FreeThreader  uses this technique, I mean). Good luck ;) izero



老汉之VB稳定多线程第二季核心代码(完整代码详见附件):
  1. '在FORM中---------------
  2. '初始化...
  3. Private Sub Form_Initialize()
  4.     'init Faking
  5.     Call InitFakeHeader

  6. End Sub

  7. '模块---------------------
  8. '5/5/2010 base on vb multithread dll(code by izero@Slovakia)
  9. 'vb multithread without tlb,pcode,dll,ax,and so on (v1.1) by download@vbgood
  10. Private Type mIID
  11.     data1 As Long
  12.     data2 As Integer
  13.     data3 As Integer
  14.     data4(7) As Byte
  15. End Type

  16. Private Declare Function CreateIExprSrvObj Lib "msvbvm60.dll" (ByVal p1_0 As Long, ByVal p2_4 As Long, ByVal p3_0 As Long) As Long

  17. Private m_nFakeHeader As Long
  18. Private Declare Function VBGetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModName As Long) As Long
  19. Private Declare Sub UserDllMain Lib "msvbvm60.dll" (u1 As Long, u2 As Long, ByVal u3_h As Long, ByVal u4_1 As Long, ByVal u5_0 As Long)
  20. Private Declare Function VBDllGetClassObject Lib "msvbvm60.dll" (g1 As Long, g2 As Long, ByVal g3_vbHeader As Long, REFCLSID As Long, REFIID As mIID, ppv As Long) As Long

  21. Private Declare Function CoInitialize Lib "ole32.dll" (ByVal pvReserved As Long) As Long
  22. Private Declare Sub CoUninitialize Lib "ole32.dll" ()

  23. Sub InitFakeHeader()
  24.     Dim nFF As Long
  25.     Dim sFile As String
  26.     Dim byFakeHeader() As Byte
  27.     Dim byVBID() As Byte

  28.     sFile = App.Path & "" & App.EXEName & ".exe" 'demo only. buggy. do it yourself.

  29.     nFF = FileLen(sFile)
  30.     If nFF > 0 Then
  31.         ReDim byFakeHeader(nFF - 1)
  32.         nFF = FreeFile
  33.         Open sFile For Binary As nFF
  34.             Get nFF, , byFakeHeader
  35.         Close nFF

  36.         'search our VBHeader
  37.         byVBID = StrConv("VB5!", vbFromUnicode)
  38.         m_nFakeHeader = InStrB(byFakeHeader, byVBID)
  39.         'demo only. find our VBHeader, buggy. do it yourself.
  40.         If m_nFakeHeader > 0 Then
  41.             'MsgBox "We got it!"
  42.         Else
  43.             MsgBox "Err, I can't get vbheader, you packed it,didn't you?", vbQuestion, "My God!"
  44.         End If
  45.     End If
  46.     'vb multithread without tlb,pcode,dll,ax,and so on (v1.1) by download@vbgood
  47.     'this sub should be call only once at app start.
  48. End Sub

  49. Sub InitVBdll() ' Invoke "COM initialiser" in a VB6 dll
  50.     Dim pIID As mIID
  51.     Dim pDummy As Long
  52.     ' Set pIID = IID of IClassFactory
  53.     ' = {00000001-0000-0000-C000-000000000046}
  54.     pIID.data1 = 1
  55.     pIID.data4(0) = &HC0
  56.     pIID.data4(7) = &H46
  57.     'commented by download@vbgood, we use a fakeheader to do it.
  58.     'Call DllGetClassObject(pDummy, pIID, pDummy)

  59.     Dim u1 As Long, u2 As Long, u3 As Long
  60.     Dim g3 As Long

  61.     u3 = VBGetModuleHandle(0)
  62.     Dim pVBHeader As Long

  63.     'TIP by down1oad@vbG00D: get u1,u2 for VBDllGetClassObject,u3=ModuleHandle
  64.     UserDllMain u1, u2, u3, 1, 0

  65.     If m_nFakeHeader > 0 Then
  66.         'TIP by D0WNL0AD@VBG00D: start+offset=FakeHeader in memory, -1 means we start base on ZERO,not ONE
  67.         g3 = u3 + m_nFakeHeader - 1
  68.         
  69.         'TIP:u1,u2 from UserDllMain, g3=VBHeader
  70.         VBDllGetClassObject u1, u2, g3, pDummy, pIID, pDummy
  71.         'we have inited. good luck --download.

  72.         'starting test...free for remove
  73.         MsgBox "show a Msgbox", vbInformation, "test in Init"
  74.     Else
  75.         'just buggy,nothing to talk.
  76.         MsgBox "FakeHeader not found!", vbCritical, "Error in Init" 'cant show this error without inited.
  77.     End If

  78.         'test.... but you can "set NEW" #fixed2 5.6.2010 5:08PM
  79.         Dim c As Class1
  80.         Set c = New Class1
  81.             c.Msg_VB_MultiThread
  82.         Set c = Nothing
  83.         'test....#fixed1
  84. '        Dim nFF As Long'        nFF = FreeFile'#fixed1:5.6.2010 5:08
  85. '        Open App.Path & "" & App.EXEName & ".exe" For Binary As nFF
  86. '
  87. '        Close nFF
  88. End Sub

  89. Public Sub Thread1()

  90.     Dim hr As Long
  91.    
  92.     CreateIExprSrvObj 0, 4, 0
  93.    
  94.     hr = CoInitialize(0)
  95.    
  96.     Call InitVBdll
  97.    
  98.     MsgBox "Thread OK", vbInformation, ""
  99.    
  100.     Dim strData As String
  101.    
  102.     strData = HTTPGetPage("http://www.vbgood.com")
  103.    
  104.     Form1.Text1.Text = strData
  105.    
  106.     Call CoUninitialize

  107. End Sub

  108. Public Function HTTPGetPage(ByVal strUrl As Variant) As String

  109.     'On Error Resume Next
  110.    
  111.     Dim oXML As Object
  112.    
  113.     Set oXML = CreateObject("WinHttp.WinHttpRequest.5.1")

  114.     oXML.Option(6) = True

  115.     oXML.Open "GET", strUrl, True

  116.     oXML.SetRequestHeader "Accept", "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5"
  117.     'oXML.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.1.3) Gecko/20070309 Firefox/2.0.0.3 (.NET CLR 3.5.30729)"
  118.     oXML.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV2; FDM; .NET CLR 2.0.50727)"
  119.     oXML.SetRequestHeader "Accept-Language", "sk"
  120.     oXML.SetRequestHeader "Connection", "Keep-Alive"
  121.     oXML.SetRequestHeader "Cache-Control", "no-cache"

  122.     oXML.Send
  123.    
  124.     oXML.WaitForResponse

  125.     HTTPGetPage = oXML.ResponseText

  126.     Set oXML = Nothing

  127. End Function
复制代码
老规矩! 还是未完待续...(看看能不能混个精华之类的赚点分,浪费了好多时间...)
PS:有钱的记得加钱(似乎版主才能加钱?),没钱的记得加分啊~~~ 这样才会继续公开VB内幕...这样才可能有第三季,第四季,第五季(好喝)的蛋生~~

本帖子中包含更多资源

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

x

评分

参与人数 71威望 +322 金钱 +16 人气 +75 收起 理由
tan133 + 1 很给力
sd1228 + 5 + 1 赞一个!
wangzhanlei + 5 + 1 很给力!
daydaynew + 5 + 1 赞一个!
海南老陈 + 10 + 2 很给力!
a6629827 + 5 + 1 很给力!
fs_leo + 5 + 1 赞一个!但是不会用呀。能不能给一些实列
bbb6135 + 1 很给力!
haizipsi + 1 很给力!
wwswwswws + 1 太好了,我以前研究了好久,最后失败了,就
dazuo0459 + 8 + 1 鼓励不断探索。。。
哈哈大侠 + 1 + 1 ~
irX26 + 6 + 1 nb
o70078 + 1 似乎很不错
x12345 + 5 + 1 继续振精中。。。。
cwfwan + 1 精品文章
天蓝逍遥 + 5 + 1 学习了,真厉害
ls645618331 + 1 怎么就能加1分。
itneste + 1 好帖~
saddemon + 1 嗷嗷好
sunfrank + 10 + 2 恶意灌水
freehack + 3 + 1 貌似不错
acmilan1984 + 8 + 1 精品文章
aq1212 + 5 + 1 太强了
h907308901 + 5 + 1 后来居上
xiaoluo18 + 2 + 1 不错!
红色狂想 + 5 + 1 精品文章
iefsfi + 5 + 1 Good
heyttt + 5 + 1 支持原创
513069906 + 5 + 1 精品文章
shilei123 + 1 + 1 2
chenli48 + 5 + 1 发布源码
sunshinebean + 5 + 1 支持
ldy + 8 + 1 爽啊,越看越爽
phoenixzcy + 1 很不错
dahual + 5 + 1 精品文章
duckytan + 5 + 1 精品文章
cheaven + 6 + 1 发布源码
snyga + 5 + 1 不错
hlm750908 + 1 + 1 good
joforn + 5 好文
ntaryl + 5 + 1 nice
zxyzxy12321 + 1 十分NB
lppop + 5 + 1 膜拜。。。。
jackierobin + 5 + 1 精品文章
KusoSoft + 3 + 1 牛人每次出现都是非同凡响。
在回忆中的记忆 + 5 + 1 精品文章
Apple_0 + 8 + 1 两个字:经典!
jilinj + 3 + 1 谢谢大牛
artless + 8 加油

查看全部评分

本帖被以下淘专辑推荐:

发表于 2010-5-6 08:33:06 | 显示全部楼层
Ooo!我坐板凳了,真是难得!
回复 支持 反对

使用道具 举报

发表于 2010-5-6 08:44:46 | 显示全部楼层
仅仅是为了个msgbox?似乎有点得不偿失了。
回复 支持 反对

使用道具 举报

发表于 2010-5-6 08:46:48 | 显示全部楼层
全部完成以后封成个OCX用起来就爽咯
回复 支持 反对

使用道具 举报

 楼主| 发表于 2010-5-6 08:49:29 | 显示全部楼层
本帖最后由 download 于 2010-5-6 16:55 编辑

编辑: 按25楼的建议加上文件支持
仅仅是为了个msgbox?似乎有点得不偿失了。
yimins 发表于 2010-5-6 08:44

不仅是Msgbox...
还可以...

1. 后期绑定 set obj=createobject("vbgood")
2. 前期绑定 set obj=new class13. 可以文件操作: Open,(顶楼中文件号是0,所以出错,漏了个nFf=1或nFF=FreeFile)
4. 一些不明的功能....

不可以....
1. (听说还不行)不知道dim a(1234) as byte 可不可以,老汉很少用静态的,所以没试.

最关键是可以用new 来创建class了,这样VB自定义的类就可以在线程中使用.也可以用Createobject创建非VB的对象,比如例子中的XML抓取网页(采集?). 这样可以在线程中用XML同时抓取不同的网站...

评分

参与人数 2威望 +17 人气 +3 收起 理由
acmilan1984 + 7 + 1 发布源码
菜鸟学飞 + 10 + 2 期待3456789N季

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2010-5-6 08:54:08 | 显示全部楼层
感谢成果的分享。
回复 支持 反对

使用道具 举报

 楼主| 发表于 2010-5-6 09:03:15 | 显示全部楼层
全部完成以后封成个OCX用起来就爽咯
仙剑魔 发表于 2010-5-6 08:46

OCX/ACTIVEX DLL,EXE,本身可以设置支持COM的多线程....
这个就是为了"绿色" 不改写注册表...
另外OCX在WIN7有点不爽,要管理员权限才能注册...

评分

参与人数 1威望 +13 人气 +3 收起 理由
19900603 + 13 + 3 以前分少 继续补上

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2010-5-6 09:23:13 | 显示全部楼层
顶了 好东西

评分

参与人数 1人气 +2 收起 理由
download + 2 只顶不加分? -_-!

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2010-5-6 09:50:40 | 显示全部楼层
没学到多线程,学习了。。
回复 支持 反对

使用道具 举报

发表于 2010-5-6 10:13:49 | 显示全部楼层
最关键是可以用new 来创建class了  ...
download 发表于 2010-5-6 08:49


恩,这个功能比较实际。研究一下。
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2019-9-17 16:55

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