using VbTrickThreading-master examples without the typelibs for Callback and Marshal

Quote:

---

Originally Posted by The trick

I can’t come up with a practical situation when this can come in handy.

---

Dear Trick,

Practically in the link http://www.devx.com/vb2themax/CodeDownload/19804

In MULTITHREAD.Asm the following code is there which uses the above API and this generates MultiT.dll.This dll is in turn used for demonstrating various threading examples.

Code:

---

    .586                      ; force 32 bit code
      .model flat, stdcall      ; memory model & calling convention
      option casemap :none      ; case sensitive

include MULTITHREAD.INC

ExitProc PROTO
EnterProc PROTO :DWORD

.data



Ct dd 0
Guids dd 0,0,0,0

MSVB db "msvbvm60.dll",0
LDLIB db "EbLoadRunTime",0
CCLIB db "EbCreateContext",0
SCLIB db "EbSetContextWorkerThread",0
LDPROC dd 0,0,0

.code





;Param1=AddressToCall,Param2=StackSize,Param3=
CreateMT proc Param1:DWORD,Param2:DWORD,Param3:DWORD,Param4:DWORD,Param5:DWORD,Param6:DWORD,Param7:DWORD

assume FS: nothing

sub esp,4
push esi
push edi
push ecx
mov eax,DWORD PTR fs:[018h]
add eax,0e14h
mov Ct,eax
lea esi,[ebp+014h]
mov edi,OFFSET Guids
cld
mov ecx,4
rep movsd

invoke CreateEvent,NULL,0,0,Param6
mov DWORD PTR [ebp-4],eax
invoke CreateThread,0,Param2,EnterProc,Param1,0,Param3
push eax
invoke WaitForSingleObject,DWORD PTR [ebp-4],0FFFFFFFFh
invoke CloseHandle,DWORD PTR [EBP-4]
pop eax
pop ecx
pop edi
pop esi
ret

CreateMT endp


EnterProc proc Param1:DWORD
assume FS: nothing       

sub esp,4

push Guids+0ch
push FS:[0]
mov FS:[0],esp


mov edi,DWORD PTR fs:[018h]
add edi,0e14h
mov esi,Ct
cld
mov ecx,1
rep movsd


invoke CoInitialize,0
invoke OleInitialize,0

lea eax,[ebp-4]
;push eax
invoke CoCreateInstance,Guids,0,017h,Guids+4,eax


invoke OpenEvent,01f0003h,0,Guids+8
invoke SetEvent,eax

call Param1


invoke CoUninitialize
invoke OleUninitialize
invoke ExitThread,0



        ret

EnterProc endp

EnableEvents proc

invoke TlsGetValue,3
mov eax,DWORD PTR [eax+028h] ;GET CX
lea ebx,[eax+04ch]

push DWORD PTR [ebx]
push ebx
call LDPROC+4 ;EbCreateContext
call LDPROC+8 ;EbSetContextWorkerThread


;INIT RUNTIME!
mov eax,040003ch
mov eax,DWORD PTR [eax]
lea eax,[eax+0400000h]
mov eax,DWORD PTR [eax+028h]
lea eax,[eax+0400001h]
mov eax,DWORD PTR [eax]
add eax,030h
push DWORD PTR[eax]
push 0400000h
call LDPROC

ret
EnableEvents endp




DllEntry proc hInstance:DWORD, reason:DWORD, reserved1:DWORD
sub esp,4
invoke GetModuleHandle,addr MSVB
mov DWORD PTR [ebp-4],eax
invoke GetProcAddress,eax,addr LDLIB
mov LDPROC,eax
invoke GetProcAddress,DWORD PTR [ebp-4],addr CCLIB
mov LDPROC+4,eax
invoke GetProcAddress,DWORD PTR [ebp-4],addr SCLIB
mov LDPROC+8,eax
mov  eax,1
ret
DllEntry Endp

end DllEntry

---

regards,

JSVenu

Quote:

---

Originally Posted by jsvenu

Dear Trick,

Practically in the link http://www.devx.com/vb2themax/CodeDownload/19804

In MULTITHREAD.Asm the following code is there which uses the above API and this generates MultiT.dll.This dll is in turn used for demonstrating various threading examples.

Code:

---

    .586                      ; force 32 bit code
      .model flat, stdcall      ; memory model & calling convention
      option casemap :none      ; case sensitive

include MULTITHREAD.INC

ExitProc PROTO
EnterProc PROTO :DWORD

.data



Ct dd 0
Guids dd 0,0,0,0

MSVB db "msvbvm60.dll",0
LDLIB db "EbLoadRunTime",0
CCLIB db "EbCreateContext",0
SCLIB db "EbSetContextWorkerThread",0
LDPROC dd 0,0,0

.code





;Param1=AddressToCall,Param2=StackSize,Param3=
CreateMT proc Param1:DWORD,Param2:DWORD,Param3:DWORD,Param4:DWORD,Param5:DWORD,Param6:DWORD,Param7:DWORD

assume FS: nothing

sub esp,4
push esi
push edi
push ecx
mov eax,DWORD PTR fs:[018h]
add eax,0e14h
mov Ct,eax
lea esi,[ebp+014h]
mov edi,OFFSET Guids
cld
mov ecx,4
rep movsd

invoke CreateEvent,NULL,0,0,Param6
mov DWORD PTR [ebp-4],eax
invoke CreateThread,0,Param2,EnterProc,Param1,0,Param3
push eax
invoke WaitForSingleObject,DWORD PTR [ebp-4],0FFFFFFFFh
invoke CloseHandle,DWORD PTR [EBP-4]
pop eax
pop ecx
pop edi
pop esi
ret

CreateMT endp


EnterProc proc Param1:DWORD
assume FS: nothing       

sub esp,4

push Guids+0ch
push FS:[0]
mov FS:[0],esp


mov edi,DWORD PTR fs:[018h]
add edi,0e14h
mov esi,Ct
cld
mov ecx,1
rep movsd


invoke CoInitialize,0
invoke OleInitialize,0

lea eax,[ebp-4]
;push eax
invoke CoCreateInstance,Guids,0,017h,Guids+4,eax


invoke OpenEvent,01f0003h,0,Guids+8
invoke SetEvent,eax

call Param1


invoke CoUninitialize
invoke OleUninitialize
invoke ExitThread,0



        ret

EnterProc endp

EnableEvents proc

invoke TlsGetValue,3
mov eax,DWORD PTR [eax+028h] ;GET CX
lea ebx,[eax+04ch]

push DWORD PTR [ebx]
push ebx
call LDPROC+4 ;EbCreateContext
call LDPROC+8 ;EbSetContextWorkerThread


;INIT RUNTIME!
mov eax,040003ch
mov eax,DWORD PTR [eax]
lea eax,[eax+0400000h]
mov eax,DWORD PTR [eax+028h]
lea eax,[eax+0400001h]
mov eax,DWORD PTR [eax]
add eax,030h
push DWORD PTR[eax]
push 0400000h
call LDPROC

ret
EnableEvents endp




DllEntry proc hInstance:DWORD, reason:DWORD, reserved1:DWORD
sub esp,4
invoke GetModuleHandle,addr MSVB
mov DWORD PTR [ebp-4],eax
invoke GetProcAddress,eax,addr LDLIB
mov LDPROC,eax
invoke GetProcAddress,DWORD PTR [ebp-4],addr CCLIB
mov LDPROC+4,eax
invoke GetProcAddress,DWORD PTR [ebp-4],addr SCLIB
mov LDPROC+8,eax
mov  eax,1
ret
DllEntry Endp

end DllEntry

---

regards,

JSVenu

---

i test the project :VB6Multithread\StandardThread, it's not support vb6 form object
it's only support msgbox or some api?
It could be an example of incomplete functionality


(like

Code:

---

Public Sub Thread()
MsgBox "22New Thread Id:" & GetCurrentThreadId, , "Info"
'On Error GoTo err
Dim f As Form2
Set f = New Form2
f.Show 1 'can't support

Dim f3 As Form3
Set f3 = New Form3
f3.Show 1

Exit Sub
err:
MsgBox "err:" & err.Number & "," & err.Description
End Sub

---

Code:

---


  ' push  tlsIndex
    ' call  TLSGetValue
    ' pop  ecx
    ' push  DWORD [eax]
    ' push  ecx
    ' jmp  DWORD [eax + 4]
   
    GetMem4 &H68, ByVal ptr + &H0:          GetMem4 &HE800, ByVal ptr + &H4
    GetMem4 &HFF590000, ByVal ptr + &H8:    GetMem4 &H60FF5130, ByVal ptr + &HC
    GetMem4 &H4, ByVal ptr + &H10:  GetMem4 tlsIndex, ByVal ptr + 1\
    GetMem4 lpProc - ptr - 10, ByVal ptr + 6

PublpNewHdr = HeapAlloc(hHeap, 0, &H6A)

 TlsSetValue tlsIndex, lpParameter 'question 1:how to delete this line?

 VBDllGetClassObject VarPtrHModule, 0, PublpNewHdr, clsid, Iid, 0

---

how can't delete tls?
i don't want use tls api.
i want use :

Code:

---

Sub ThreadTest(ByVal lpParameter As Long)
    CreateIExprSrvObj 0&, 4&, 0&            'VB6运行库初始化
    CoInitializeEx ByVal 0&, ByVal COINIT_APARTMENTTHREADED
    Call VBDllGetClassObject(VarPtrHModule, 0, lpVBHeader , clsid, Iid, 0)

    msgbox "go"
    Dim frm As Form
    Set frm = New Form1 'with usercontrol (object)
    frm.Show 1
end sub

'call method:
CreateThread ByVal 0&, ByVal 0&, AddressOf ThreadTest, ByVal 321&, 0&, 0&


'it's run ok,support(msgbox ,ocx),bug not support usercontrol.
'question 2:how to fix to support usercontrol without tls api?

---

if “createthread （**） api ,no need HeapAlloc,no need TlsSetValue (no need tls api),i think It's going to be easier

Is it necessary for CreateThread to wait for the result to be returned?

In general, you pass a parameter or a structure with multiple parameters. What if you wait for the result to be returned?

What happens if you want to call a procedure with multiple parameters?

CreateThread addressof sum

Public function sum(byval a as long,byval b as long)
Sum = a + b
End the function

Can we only use assembly or add another process package for processing? Can't call directly?

CreateThread creates thread A, where thread A "creates thread B" to handle another large computation loop (with less CPU usage, such as A long wait to download A web page), and then waits for the results to be returned.

This way, whether can use CPU more fully.

Let's say you have a 6 core CPU, you have 6 threads. If you create a child thread in a thread, will the CPU automatically choose a spare core to assign to the new thread?
===\-\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

chinese:

Code:

---

CreateThread是否有必要等待返回结果？
一般情况是传递一个参数或者一个包含多个参数的结构，如果要等返回结果怎么做？
如果要调用多个参数的过程怎么处理？
CreateThread addressof sum
public function sum(byval a as long,byval b as long)
sum=a+b
end function
是不是只能用汇编或者另外加一个过程包装进行处理？没办法直接调用？

CreateThread创建了一个线程A，在线程A再“新建线程B"处理 另一个大计算循环（CPU用的不多，像是下载网页，需要等待较长时间），然后等待返回结果。
这种方式，是否可以更加充分的利用CPU。
比如6核CPU，建了6个多线程。再线程中创建子线程，CPU是否会自动选择一个比较空闲的核心分配给新线程？

---

xiaoyao, it's difficult to understand you, sorry. What do you want? Do you ask something or?

Quote:

---

Originally Posted by xiaoyao

i test the project :VB6Multithread\StandardThread, it's not support vb6 form object
it's only support msgbox or some api?
It could be an example of incomplete functionality


(like

Code:

---

Public Sub Thread()
MsgBox "22New Thread Id:" & GetCurrentThreadId, , "Info"
'On Error GoTo err
Dim f As Form2
Set f = New Form2
f.Show 1 'can't support

Dim f3 As Form3
Set f3 = New Form3
f3.Show 1

Exit Sub
err:
MsgBox "err:" & err.Number & "," & err.Description
End Sub

---

---

Dear Trick,

You stated

Quote:

---

There is ability to write a MTA ActiveX dll in VB6 but it’s such a nontrivial task (and rarely used)

---

The answer is the description in the link http://www.devx.com/vb2themax/CodeDownload/19804 which I have already sent you as follows:

VB6 does not natively support free threading(MTA ActiveX dll), but with this ActiveX library you can finally create multiple threads and make them communicate, write delegate functions (similarly to VB.NET) and use Structured Exception Handling.

The above underlined bold things can be achieved thru writing a MTA ActiveX dll in VB6 which are already being used in VB.NET or from VB7 practically.

May be as xiaoyao stated the code in http://www.devx.com/vb2themax/CodeDownload/19804 may not be stable or incomplete since it was tried in 2003
and it is glad to know that you how to do it.Please clarify how to write MTA ActiveX dll in pure vb6.

regards,
JSVenu

PublpNewHdr = HeapAlloc(hHeap, 0, &H6A)

CopyMemory ByVal PublpNewHdr, ByVal lpVBHeader, &H6A
GetMem4 1&, ByVal PublpNewHdr + &H3C '加的，支持自定义控件
why use &h6A?&H3C?
WHEN I USE THESE PublpNewHdr to other vb crearethread ptoject,Without using any of your other code. When the msgbox window pops up, the title becomes garbled, and the process is different each time it is opened, and it is the same before it is closed. .
chinese:没有使用你的任何其他代码。msgbox弹出窗口的时候标题变成乱码，每次打开进程都不一样，没有关闭之前都一样。
maybe app.title happened err,vb header Is it not copy fully?

' TlsSetValue tlsIndex, lpParameter 'question 1: I delete this line

Sub ThreadTest(ByVal lpParameter As Long)
CreateIExprSrvObj 0&, 4&, 0& 'VB6运行库初始化
CoInitializeEx ByVal 0&, ByVal COINIT_APARTMENTTHREADED
Call VBDllGetClassObject(VarPtrHModule, 0, PublpNewHdr, , clsid, Iid, 0)

msgbox "go"
Dim frm As Form
Set frm = New Form1 'with usercontrol (object)
frm.Show 1
end sub

'call method:
CreateThread ByVal 0&, ByVal 0&, AddressOf ThreadTest, ByVal 321&, 0&, 0&

Quote:

---

Originally Posted by xiaoyao

PublpNewHdr = HeapAlloc(hHeap, 0, &H6A)

CopyMemory ByVal PublpNewHdr, ByVal lpVBHeader, &H6A
GetMem4 1&, ByVal PublpNewHdr + &H3C '加的，支持自定义控件
why use &h6A?&H3C?
WHEN I USE THESE PublpNewHdr to other vb crearethread ptoject,Without using any of your other code. When the msgbox window pops up, the title becomes garbled, and the process is different each time it is opened, and it is the same before it is closed. .
chinese:没有使用你的任何其他代码。msgbox弹出窗口的时候标题变成乱码，每次打开进程都不一样，没有关闭之前都一样。
maybe app.title happened err,vb header Is it not copy fully?

' TlsSetValue tlsIndex, lpParameter 'question 1: I delete this line

Sub ThreadTest(ByVal lpParameter As Long)
CreateIExprSrvObj 0&, 4&, 0& 'VB6运行库初始化
CoInitializeEx ByVal 0&, ByVal COINIT_APARTMENTTHREADED
Call VBDllGetClassObject(VarPtrHModule, 0, lpVBHeader , clsid, Iid, 0)

msgbox "go"
Dim frm As Form
Set frm = New Form1 'with usercontrol (object)
frm.Show 1
end sub

'call method:
CreateThread ByVal 0&, ByVal 0&, AddressOf ThreadTest, ByVal 321&, 0&, 0&

---

Dear xiaoyao,

&h6A,&H3C are the offsets of the corresponding fields in vbheader structure on which Trick has worked a lot.
You can use the code by Trick as it is since creating and copying new vbheader without making the global/static variable from being cleared involves
lot of internals to be understood and it is the Trick who did all the great work for which I really appreciate him.
You can get required details of the vb6 internal structures which are linked to one another in the link https://docplayer.net/83403902-Relso...re-format.html..

regards,
JSVenu

Quote:

---

Originally Posted by jsvenu

Dear xiaoyao,

&h6A,&H3C are the offsets of the corresponding fields in vbheader structure on which Trick has worked a lot.
You can use the code by Trick as it is since creating and copying new vbheader without making the global/static variable from being cleared involves
lot of internals to be understood and it is the Trick who did all the great work for which I really appreciate him.
You can get required details of the vb6 internal structures which are linked to one another in the attachment.

regards,
JSVenu

---

The simplest VB6 multithreading, and support for custom controls, is quite perfect. I spent a lot of time on multithreading research and was laughed at or didn't understand by many Chinese developers. VB6 itself does not support multithreading, and some examples are hundreds of thousands of lines of code that are too complex to understand.

In fact, most people only need the simplest multithreading, no form, no OCX control, haha.

As Chinese, we are difficult. Now the forum of VB6 is almost dead, many people are using "E language "invented by Chinese people.

The Google website is blocked, unable to access, unable to search the source code, open your forum is also very slow, several hundred times slower than the Chinese website.

CHINESE:最简单的VB6多线程，并且支持自定义控件，那是相当完美。在多线程研究上我花了大量时间，被很多中国的程序开发员耻笑或者不理解。VB6本身不支持多线程，有的例子代码几百几千行，而且非常复杂 ，难以看懂。
其实大部分人只需要最简单的多线程，用不着窗体，也用不着OCX控件，哈哈。
作为中国人，我们很难。现在VB6的论坛几乎全死了，很多人在用中国人发明的"E语言"。
谷歌网站被封锁无法访问，无法搜索源码，打开你们的论坛也是非常慢，比中国的网站慢了几百上千倍。

---------------------------
,\H
---------------------------
PubValue=321

UsedTime Log(microseconds)：
CreateThread：99.271
CoInitializeEx：15.6444
VBDllGetClassObject：5528.4559
AllUsedTime：5643.3714microseconds

GetCurrentThreadId=16096,title=prjTest1
---------------------------
公共变量=321
以下时间单位微秒：
创建线程用时：115.1999
加载 COM用时：15.6444
vb初始化用时：5054.2876
线程准备总共用时：5185.1319微秒
GetCurrentThreadId=9308,title=prjTest1
---------------------------
确定
=======================
VBDllGetClassObject this api ,used the most times(5.1 ms)

PublpNewHdr2 = HeapAlloc(hHeap, 0, &H6A)' the msgbox window title is err.
PublpNewHdr2 = HeapAlloc(hHeap, 0, &H6A*10 ) is good

What is the best value? If you want to copy all the VB headers in, what length do you have?

Quote:

---

Originally Posted by xiaoyao

---------------------------
,\H
---------------------------
PubValue=321

UsedTime Log(microseconds)：
CreateThread：99.271
CoInitializeEx：15.6444
VBDllGetClassObject：5528.4559
AllUsedTime：5643.3714microseconds

GetCurrentThreadId=16096,title=prjTest1
---------------------------
公共变量=321
以下时间单位微秒：
创建线程用时：115.1999
加载 COM用时：15.6444
vb初始化用时：5054.2876
线程准备总共用时：5185.1319微秒
GetCurrentThreadId=9308,title=prjTest1
---------------------------
确定
=======================
VBDllGetClassObject this api ,used the most times(5.1 ms)

PublpNewHdr2 = HeapAlloc(hHeap, 0, &H6A)' the msgbox window title is err.
PublpNewHdr2 = HeapAlloc(hHeap, 0, &H6A*10 ) is good

What is the best value? If you want to copy all the VB headers in, what length do you have?

---

Dear xiaoyao,

Have you gone thru the link https://docplayer.net/83403902-Relso...re-format.html which contains 12 pages containing all vb internal format structures.Then you can understand better.

regards,
JSVenu

Quote:

---

Originally Posted by jsvenu

Dear xiaoyao,

Have you gone thru the link https://docplayer.net/83403902-Relso...re-format.html which contains 12 pages containing all vb internal format structures.Then you can understand better.

regards,
JSVenu

---

PublpNewHdr2 = HeapAlloc(hHeap, 0, &H6A * 10)

I can't read it. My English is so poor.
Now I'm just making this number 10 times bigger, how much is the best number to put in?
can you help me?thank you!!!!

chinese:我看不懂，我的英文水平太差了。
现在我只是把这个数字放大了10倍，到底应该输多少数值最佳？

JSVenu, as i already told you can't use free threading as usual. The library you showed seems has some bugs. Just i tried to execute the StandardThread example and i see it doesn't performs the context initialization. You can check it by adding an user class and then try to create an instance as follows:

Code:

---

Public Sub Thread()
    MsgBox "New Thread Id:" & GetCurrentThreadId, , "Info"

    Dim Z As Class1
   
    Set Z = New Class1
   
    Z.XXX
   
End Sub

---

Z.XXX won't be called because the context isn't initialized you don't see an error because it setups a SEH handler. Just you can see the error of access violation after the context was not found:
https://media.giphy.com/media/XBibPS...qXPD/giphy.gif

Moreover this example creates the memory leak because it creates an instance of VBFreeThreading.FreeThreadInterface but doesn't performs resource cleaning like IUnknown::Release.

To write a MTA library you need to consider many restrictions.

Quote:

---

Originally Posted by The trick

JSVenu, as i already told you can't use free threading as usual. The library you showed seems has some bugs. Just i tried to execute the StandardThread example and i see it doesn't performs the context initialization. You can check it by adding an user class and then try to create an instance as follows:

Code:

---

Public Sub Thread()
    MsgBox "New Thread Id:" & GetCurrentThreadId, , "Info"

    Dim Z As Class1
   
    Set Z = New Class1
   
    Z.XXX
   
End Sub

---

Z.XXX won't be called because the context isn't initialized you don't see an error because it setups a SEH handler. Just you can see the error of access violation after the context was not found:
http://www.vbforums.com/images/ieimages/2020/01/1.gif

Moreover this example creates the memory leak because it creates an instance of VBFreeThreading.FreeThreadInterface but doesn't performs resource cleaning like IUnknown::Release.

To write a MTA library you need to consider many restrictions.

---

Dear Trick,

First thankyou for the reply.
Sincerely I can say that I have seen link but I did not execute it since I already told I had less idea of ASM.So I was thinking that we can do free threading when I understand it in pure vb6 from some expert like you,Xiaoyao and yourself have gone thru it and have given your comments.Slowly I could understand multithreading in vb6 in a better way from you.
Can you please provide me a simple MTA library in vb6 considering the restrictions to follow as you said.

regards,
JSVenu

Quote:

---

Originally Posted by xiaoyao

PublpNewHdr2 = HeapAlloc(hHeap, 0, &H6A * 10)

I can't read it. My English is so poor.
Now I'm just making this number 10 times bigger, how much is the best number to put in?
can you help me?thank you!!!!

chinese:我看不懂，我的英文水平太差� ��。
现在我只是把这个数å*—放大了10å€ï¼Œå ˆ°åº•åº”该输多少数值最佳？

---

Dear xiaoyao,

Just put msgbox in CreateVBHeaderCopy module function as follows:

' // Create copy of VBHeader and other structures
' // The first four bytes contain thread ID. We use that ID to clean unused headers

Code:

---

Private Function CreateVBHeaderCopy() As Long
    Dim pHeader        As Long
    Dim pOldProjInfo    As Long
    Dim pProjInfo      As Long
    Dim pObjTable      As Long
    Dim pOldObjTable    As Long
    Dim lDifference    As Long
    Dim lIndex          As Long
    Dim pNames(3)      As Long
    Dim lModulesCount  As Long
    Dim pDescriptors    As Long
    Dim pOldDesc        As Long
    Dim pVarBlock      As Long
    Dim lSizeOfHeaders  As Long
   
    ' // Get size of all headers
    lSizeOfHeaders = &H6A + &H23C + &H54 + &HC + 4
   
    GetMem4 ByVal pVBHeader + &H30, pOldProjInfo
    GetMem4 ByVal pOldProjInfo + &H4, pOldObjTable
    GetMem4 ByVal pOldObjTable + &H30, pOldDesc
    GetMem2 ByVal pOldObjTable + &H2A, lModulesCount
    MsgBox "lModulesCount  " & lModulesCount
    lSizeOfHeaders = lSizeOfHeaders + &H30 * lModulesCount
    MsgBox "lSizeOfHeaders  " & lSizeOfHeaders
 ' // Allocate memory for header
    Do
       
        pHeader = HeapAlloc(hHeadersHeap, HEAP_ZERO_MEMORY, lSizeOfHeaders)

---

regards,
JSVenu

Quote:

---

Originally Posted by jsvenu

Dear xiaoyao,

Just put msgbox in CreateVBHeaderCopy module function as follows:

' // Create copy of VBHeader and other structures
' // The first four bytes contain thread ID. We use that ID to clean unused headers

Code:

---

Private Function CreateVBHeaderCopy() As Long
    Dim pHeader        As Long
    Dim pOldProjInfo    As Long
    Dim pProjInfo      As Long
    Dim pObjTable      As Long
    Dim pOldObjTable    As Long
    Dim lDifference    As Long
    Dim lIndex          As Long
    Dim pNames(3)      As Long
    Dim lModulesCount  As Long
    Dim pDescriptors    As Long
    Dim pOldDesc        As Long
    Dim pVarBlock      As Long
    Dim lSizeOfHeaders  As Long
   
    ' // Get size of all headers
    lSizeOfHeaders = &H6A + &H23C + &H54 + &HC + 4
   
    GetMem4 ByVal pVBHeader + &H30, pOldProjInfo
    GetMem4 ByVal pOldProjInfo + &H4, pOldObjTable
    GetMem4 ByVal pOldObjTable + &H30, pOldDesc
    GetMem2 ByVal pOldObjTable + &H2A, lModulesCount
    MsgBox "lModulesCount  " & lModulesCount
    lSizeOfHeaders = lSizeOfHeaders + &H30 * lModulesCount
    MsgBox "lSizeOfHeaders  " & lSizeOfHeaders
 ' // Allocate memory for header
    Do
       
        pHeader = HeapAlloc(hHeadersHeap, HEAP_ZERO_MEMORY, lSizeOfHeaders)

---

regards,
JSVenu

---

Dear xiaoyao,

The following are the values at runtime in CreateVBHeaderCopy module function for lModulesCount and lSizeOfHeaders


lModulesCount 8
lSizeOfHeaders 1162 (48A)


So we have

pHeader = HeapAlloc(hHeadersHeap, HEAP_ZERO_MEMORY, lSizeOfHeaders) as

pHeader = HeapAlloc(hHeadersHeap, HEAP_ZERO_MEMORY, &H48A)

Hope this helps you.

regards,
JSVenu

mabe it's good,I saw this piece of code earlier, but I don't know what it's for.I'll test it tomorrow.
The best method is still inseparable from the assembly code support. After all, the programming tools are upgraded, and finally they run as assembly code.
Use createthread to directly call the function address, and add vb initialization inside the function process, which is equivalent to the cdecl mode dll, which requires the user to initialize and reclaim memory and unload the com object.
vbcreatethread is a simple wrapper that handles automatically, equivalent to stdcall calls
chinese:最好的方法还是离不开汇编代码支持，毕竟编程工具升级，最后还是变成汇编代码运行。
直接用createthread调用函数地址，函数过程里面加vb初始化，相当于cdecl方式dll,需要用户初始化和回收内存，卸载com对象。
vbcreatethread 是一个简易包装，自动处理，相当于stdcall调用

Activate any event in multiple threads or in any other form or class

We can take over the COM object's ConnectionPoint connection pointer,
For example, set up two COM objects in the main form and activate events directly in any multithread.
Or call the "global variable. Object.fireevents("events2",arg1,arg2)" directly in the thread.
Example of Class1:

Code:

---

'in form1
Dim WithEvents ClassA AS Class1
Dim WithEvents ClassB AS Class1

ClassA.DoRaiseEventByName "Event3", 11, 22, 33

'in Class1 file:
Public Event Event1(msg As String)
Public Event Event2(Arg1 As String, Arg2 As String)
Public Event Event3(A As Long, B As Long, C As Long)
Public Event Event4(A As Variant, B As Variant, C As Variant, D As Variant)
Public Sub DoRaiseEventByName(EventsName As String, ParamArray Params() As Variant)
Select Case EventsName
Case "Event1"
    RaiseEvent Event1(Params(0) & "")
Case "Event2"
  RaiseEvent Event2(Params(0) & "", Params(1) & "")
Case "Event3"
  RaiseEvent Event3(Params(0) + 0, Params(1) + 0, Params(2) + 0)
Case "Event4"
  RaiseEvent Event4(Params(0), Params(1), Params(2), Params(3))
End Select
End Sub

---

----------------
chinese:
在多线程中或其他窗体或类中任意激活事件
我们可以接管COM对象的ConnectionPoint连接指针，
比如在主窗体中建立2个COM对象,直接在任何多线程中激活事件（FireEvents）
或者在线程中直接调用“全局变量.对象.
Class1的实例:
dim WithEvents ClassA AS Class1
dim WithEvents ClassB AS Class1

question 1:how to run createthread in vb6 ide,for support show form1
i run createthread in vb6 ide,it's successful,but can't show form
(how to fix?),maybe use not the same "NewVBHeader_Heap"
NewVBHeader_Heap=HeapAlloc(hHeadersHeap, HEAP_ZERO_MEMORY, lSizeOfHeaders)
we need new lSizeOfHeaders?
or need other way?

for test,it's support com object like "adodb.stream"

question2: how to debug thread in ide?
it's can suspended， how to run on?
use f5 or f8 or can't run
Quest3:if i use "end " in thread,APPCATION WILL BE collapse(ERR),WHY?

Code:

---

Dim f As Form1
Set f = New Form1
f.Show 1
VBDllGetClassObject  VarPtr(App.hInstance), 0, VBHeader, 0&, Iid, 0      '

---

VBDllGetClassObject VarPtrHModule, 0, NewVBHeader_Heap, 0&, Iid, 0 '[/CODE]
error from "VBDllGetClassObject":
Signature of question:
Problem event name: APPCRASH
Application name: vb6.exe
Application version: 6.0.97.82
Application timestamp: 403acf6c
Fault module name: msvbvm60. DLL
Fault module version: 6.0.98.15
Fault module timestamp: 49b01fc3
Exception code: c0000005
Exception offset: 000044da
OS version: 6.3.9600.2.0.0.256.4

Locale ID: 2052
Other information 1: ac05
Other information: 2 ac0507478d1c5bd693cfc4fe3987e900
Other information 3: ac05
Other information 4: ac0507478d1c5bd693cfc4fe3987e900
'===========
chinese:问题签名:
问题事件名称: APPCRASH
应用程序名: VB6.EXE
应用程序版本: 6.0.97.82
应用程序时间戳: 403acf6c
故障模块名称: MSVBVM60.DLL
故障模块版本: 6.0.98.15
故障模块时间戳: 49b01fc3
异常代码: c0000005
异常偏移: 000044da
OS 版本: 6.3.9600.2.0.0.256.4
区域设置 ID: 2052
其他信息 1: ac05
其他信息 2: ac0507478d1c5bd693cfc4fe3987e900
其他信息 3: ac05
其他信息 4: ac0507478d1c5bd693cfc4fe3987e900

Quote:

---

Originally Posted by xiaoyao

question 1:how to run createthread in vb6 ide,for support show form1
i run createthread in vb6 ide,it's successful,but can't show form
(how to fix?),maybe use not the same "NewVBHeader_Heap"
NewVBHeader_Heap=HeapAlloc(hHeadersHeap, HEAP_ZERO_MEMORY, lSizeOfHeaders)
we need new lSizeOfHeaders?
or need other way?

for test,it's support com object like "adodb.stream"

question2: how to debug thread in ide?
it's can suspended， how to run on?
use f5 or f8 or can't run
Quest3:if i use "end " in thread,APPCATION WILL BE collapse(ERR),WHY?

Code:

---

Dim f As Form1
Set f = New Form1
f.Show 1
VBDllGetClassObject  VarPtr(App.hInstance), 0, VBHeader, 0&, Iid, 0      '

---

VBDllGetClassObject VarPtrHModule, 0, NewVBHeader_Heap, 0&, Iid, 0 '[/CODE]
error from "VBDllGetClassObject":
Signature of question:
Problem event name: APPCRASH
Application name: vb6.exe
Application version: 6.0.97.82
Application timestamp: 403acf6c
Fault module name: msvbvm60. DLL
Fault module version: 6.0.98.15
Fault module timestamp: 49b01fc3
Exception code: c0000005
Exception offset: 000044da
OS version: 6.3.9600.2.0.0.256.4

Locale ID: 2052
Other information 1: ac05
Other information: 2 ac0507478d1c5bd693cfc4fe3987e900
Other information 3: ac05
Other information 4: ac0507478d1c5bd693cfc4fe3987e900
'===========
chinese:问题签名:
问题事件名称: APPCRASH
应用程序名: VB6.EXE
应用程序版本: 6.0.97.82
应用程序时间戳: 403acf6c
故障模块名称: MSVBVM60.DLL
故障模块版本: 6.0.98.15
故障模块时间戳: 49b01fc3
异常代码: c0000005
异常偏移: 000044da
OS 版本: 6.3.9600.2.0.0.256.4
区域设置 ID: 2052
其他信息 1: ac05
其他信息 2: ac0507478d1c5bd693cfc4fe3987e900
其他信息 3: ac05
其他信息 4: ac0507478d1c5bd693cfc4fe3987e900

---

Dear xiaoyao,

Displaying form also works in IDE.But it is displayed in the main Thread.
You can check this by running your 03_Edit-usercontrol_FormGood project in IDE and click on Create Thread button on the displayed form.
You can put break points and debug the project.

regards,
JSVenu

I TEST createthread in vb6 ide,need new thread,not run in main thread.(it's only for test this api,no need debug)
if can debug part,like break ,and run on again,Wouldn't that be better？

Quote:

---

Originally Posted by xiaoyao

I TEST createthread in vb6 ide,need new thread,not run in main thread.(it's only for test this api,no need debug)
if can debug part,like break ,and run on again,Wouldn't that be better？

---

Dear xiaoyao,

I understood that you require attaching to a running application at runtime debug it and then detach from it so that it runs again standalone.
This dynamic runtime attach and detach to a running application are not available in vb6 IDE.They are available in vc++ 6.0 IDE but here also while detaching the application terminates.
If you want to run perfectly you have to use .Net IDE with which you can attach debug and detach and continue run again without problems.Trick has also suggested me ollydbg.

As an alternative if you want to change control paths in vb6 IDE itself you can use set next statement while debugging using break points.
You can also use DebugBreak api in vb6.
regards,
JSVenu

Quote:

---

Originally Posted by jsvenu

Dear Trick,

First thankyou for the reply.
Sincerely I can say that I have seen link but I did not execute it since I already told I had less idea of ASM.So I was thinking that we can do free threading when I understand it in pure vb6 from some expert like you,Xiaoyao and yourself have gone thru it and have given your comments.Slowly I could understand multithreading in vb6 in a better way from you.
Can you please provide me a simple MTA library in vb6 considering the restrictions to follow as you said.

regards,
JSVenu

---

Dear Trick,

I think if we can have a module function which can tell whether a thread in which we want to do any work is initialized in terms of runtime like isRunTimeinitialized which returns true or false it can be of help in simple MTA library example.Please clarify.

regards,
JSVenu

Quote:

---

I think if we can have a module function which can tell whether a thread in which we want to do any work is initialized in terms of runtime like isRunTimeinitialized which returns true or false it can be of help in simple MTA library example.Please clarify.

---

Notice to function:

Code:

---

' // Init thread and call function
' // This function is useful for callback of WINAPI functions which can call function in arbitrary thread
Public Function InitCurrentThreadAndCallFunction( _
                ByVal pfnCallback As Long, _
                ByVal pParam As Long, _
                ByRef lReturnValue As Long) As Boolean

    .  .  .

    If lTlsSlot Then
   
        ' // Check if thread already initialized
        pThreadData = TlsGetValue(lTlsSlot)
       
        If pThreadData <> 0 Then
           
            ' // Just call by pointer
            hr = DispCallFunc(ByVal 0&, pfnCallback, CC_STDCALL, vbLong, 1, vbLong, VarPtr(CVar(pParam)), vRet)
           
            .  .  .
           
        End If
   
    End If

    .  .  .

End Function

---

ADDED:

You can't write a MTA library using this module. Moreover you can't write MTA library using any other module. To write a MTA library you need to programming only in the procedural style, considers restrictions of uninitialized runtime (like using APIs declared in a typelib). Also you need to ensure manually data synchronization (because you use MTA), manually vTable creation, manually registration, etc.
I can write such library but i don't want because it has no sense. I've already written the kernel driver to prove vb6 can do it. The same with MTA library. Maybe sometime i'll write such library :)

Quote:

---

Originally Posted by The trick

Notice to function:

Code:

---

' // Init thread and call function
' // This function is useful for callback of WINAPI functions which can call function in arbitrary thread
Public Function InitCurrentThreadAndCallFunction( _
                ByVal pfnCallback As Long, _
                ByVal pParam As Long, _
                ByRef lReturnValue As Long) As Boolean

    .  .  .

    If lTlsSlot Then
   
        ' // Check if thread already initialized
        pThreadData = TlsGetValue(lTlsSlot)
       
        If pThreadData <> 0 Then
           
            ' // Just call by pointer
            hr = DispCallFunc(ByVal 0&, pfnCallback, CC_STDCALL, vbLong, 1, vbLong, VarPtr(CVar(pParam)), vRet)
           
            .  .  .
           
        End If
   
    End If

    .  .  .

End Function

---

ADDED:

You can't write a MTA library using this module. Moreover you can't write MTA library using any other module. To write a MTA library you need to programming only in the procedural style, considers restrictions of uninitialized runtime (like using APIs declared in a typelib). Also you need to ensure manually data synchronization (because you use MTA), manually vTable creation, manually registration, etc.
I can write such library but i don't want because it has no sense. I've already written the kernel driver to prove vb6 can do it. The same with MTA library. Maybe sometime i'll write such library :)

---

Dear Trick,

First let me thankyou for the reply.
you said

Quote:

---

' // Check if thread already initialized
pThreadData = TlsGetValue(lTlsSlot)

---

but this is in InitCurrentThreadAndCallFunction module function.

I was asking in general for example in a client application which uses a MTA component which supports callbacks or events in different threads there we have to check whether the thread runtime is initialized if we want to write runtime dependant code in the callback otherwise we can proceed in a different way.The client here is using components and not calling InitCurrentThreadAndCallFunction.In order to call this InitCurrentThreadAndCallFunction first it should know initialization is required or not using the boolean module function which I asked for.

regards,
JSVenu

Quote:

---

Originally Posted by jsvenu

Dear xiaoyao,

I understood that you require attaching to a running application at runtime debug it and then detach from it so that it runs again standalone.
This dynamic runtime attach and detach to a running application are not available in vb6 IDE.They are available in vc++ 6.0 IDE but here also while detaching the application terminates.
If you want to run perfectly you have to use .Net IDE with which you can attach debug and detach and continue run again without problems.Trick has also suggested me ollydbg.

As an alternative if you want to change control paths in vb6 IDE itself you can use set next statement while debugging using break points.
You can also use DebugBreak api in vb6.
regards,
JSVenu

---

if i open 4 Foms in thread,i saved the formobject to Array "Public FormArr(1 to 4) As Form"
when "DLL_THREAD_ATTACH",i close these windows,why i close formarr(4),it's crash?
close window 1-3 is very good.

I create multiple threads in the DLL file, each with multiple forms.

Is there any way to close all form objects when the DLL exits?

How about this method? Send handle WM_CLOSE? Then loop through all window handles until they all fail.

What's a safe way to end a thread without causing a memory leak?

chinese:我在DLL文件里创建多线程，每个线程有多个窗体。
有什么办法可以在DLL要退出时，直接关闭所有窗体对象？
这个方法怎么样？发送句柄WM_CLOSE?然后循环检测所有窗口句柄，直到全部失效为止？
有什么安全的方法结束线程，又不会造成内存泄露？

xiaoyao
Please attach the example i don't understand what you tell about. If you want to use a DLL with a threading-scenario the simplest way is to just create an ActiveX DLL with the apartment threading model.

Quote:

---

I was asking in general for example in a client application which uses a MTA component which supports callbacks or events in different threads there we have to check whether the thread runtime is initialized if we want to write runtime dependant code in the callback otherwise we can proceed in a different way.The client here is using components and not calling InitCurrentThreadAndCallFunction.In order to call this InitCurrentThreadAndCallFunction first it should know initialization is required or not using the boolean module function which I asked for.

---

This function is intended for such cases. When you receive a callback you call this function which initializes the runtime and calls your callback function in the initialized thread. If the thread already initialized the function just calls method without initialization.

Dear Trick,

Quote:

---

This function is intended for such cases. When you receive a callback you call this function which initializes the runtime and calls your callback function in the initialized thread. If the thread already initialized the function just calls method without initialization.

---

Thankyou for the clarification.

Quote:

---

manually data synchronization,manually vTable creation, manually registration etc

---

I understand why manually data synchronization but why are manually vTable creation, manually registration etc required for MTA library.



In std exe project for loading user control of same project you told we have to set the new thread in which new control is loaded to apartment model.When we set we were able to access the user control thru the thread.
But here I don't understand why the main default thread not being apartment model is able to load the user control to the form in main default thread.Moreover when I try to make the main thread of the project to be apartment model as follows it crashes.Please clarify.

Code:

---

' // Get VBHeader structure
Private Function GetVBHeader() As Long
    Dim ptr    As Long
    Dim bThreading As Long
    Dim tempheader As Long
    ' // Get e_lfanew
    GetMem4 ByVal hModule + &H3C, ptr
    ' // Get AddressOfEntryPoint
    GetMem4 ByVal ptr + &H28 + hModule, ptr
    ' // Get VBHeader
    GetMem4 ByVal ptr + hModule + 1, tempheader
    GetMem1 ByVal tempheader + &H3C, bThreading
    bThreading = bThreading Or 1
 
    GetMem1 bThreading, ByVal tempheader + &H3C 'crashes
 
    GetVBHeader = tempheader
End Function

---

regards,
JSVenu

Quote:

---

Originally Posted by The trick

xiaoyao
Please attach the example i don't understand what you tell about. If you want to use a DLL with a threading-scenario the simplest way is to just create an ActiveX DLL with the apartment threading model.
This function is intended for such cases. When you receive a callback you call this function which initializes the runtime and calls your callback function in the initialized thread. If the thread already initialized the function just calls method without initialization.

---

IT'S OK ,THANK YOU.

Save the form objects created with multiple threads in the VB standard DLL in an array and close them when the main thread exits. Closing the last thread causes the form to crash.

It crashed hundreds, thousands of times, and finally it's done, just save the handle to the form, and then sendmessage wm_close so it doesn't crash. Form objects in other threads access department is not safe, will cause some unknown reasons, can only see the assembly code to find out.

Or, alternatively, enumerate all the forms in the process and list the modules for that window.
CHINESE:
把VB标准DLL里用多线程创建的窗体对象保存在数组里，在主线程退出时关闭他们。关闭最后一个线程窗体就会崩溃。
崩溃了几百上千次，终于搞定了，只是保存窗体的句柄，然后sendmessage wm_close这样就不会崩溃了。窗体对象在其他线程中访部不安全，会造成一些未知原因，只能看汇编代码才能查清楚。
或者别外的方法，把该进程中的所有窗体枚举出来，列出该窗口对应的模块如果是这个DLL，就关闭。

About what you said: my goal is to create threads and allow them to call back to any address, whether it's in bas, forms, classes, usercontrol, etc. It seems to work.

I just thought of it. You've been doing it for years.

Not only multithreading, but also asynchronous processing, which is nice
chinese:关于你说的：我的目标是创建线程，并允许它们回调到任何地址，无论它是在bas，窗体，类，usercontrol等中。这似乎起作用。
我刚刚才想起这方法，你都实现很多年了。
不仅需要多线程，还需要异步处理，真好

I use this class to capture the events.
I use the example that made me trick multithreading and works well with objects.
if you find it useful
http://www.vbforums.com/showthread.p...=1#post5445811

Code:

---

Option Explicit

' clsObjectExtender
'
' event support for Late-Bound objects
' low level COM Projekt - by [rm_code] 2005

'
' HOW IT WORKS
'
' An object, wich supports events,
' should implement IConnectionPointContainer.
' This interface let's you enumerate all
' event interfaces.
' Once you have the event interface you want,
' you can get IConnectionPoint for this interface,
' advise your event sink to it, and start
' recieving events on it.
' If the event interface has IDispatch implemented,
' all raised events will go through
' IDispatch::Invoke.
'
' And that's what we use:
' We just take the first best event interface we
' get from IEnumConnectionPoints, create a
' event sink which implements IDispatch,
' and capture all events through Invoke().
'

Private Type IUnknown
    QueryInterface              As Long
    AddRef                      As Long
    Release                    As Long
End Type

Private Type IDispatch
    IUnk                        As IUnknown
    GetTypeInfoCount            As Long
    GetTypeInfo                As Long
    GetIDsOfNames              As Long
    Invoke                      As Long
End Type

Private Type IConnectionPointContainer
    IUnk                        As IUnknown
    EnumConnectionPoints        As Long
    FindConnectionPoint        As Long
End Type

Private Type IConnectionPoint
    IUnk                        As IUnknown
    GetConnectionInterface      As Long
    GetConnectionPointContainer As Long
    Advise                      As Long
    Unadvise                    As Long
    EnumConnections            As Long
End Type

Private Type IEnumConnectionPoints
    IUnk                        As IUnknown
    Next                        As Long
    Skip                        As Long
    Reset                      As Long
    Clone                      As Long
End Type

Private Type ITypeInfo
    IUnk                        As IUnknown
    GetTypeAttr                As Long
    GetTypeComp                As Long
    GetFuncDesc                As Long
    GetVarDesc                  As Long
    GetNames                    As Long
    GetRefTypeOfImplType        As Long
    GetImplTypeFlags            As Long
    GetIDsOfNames              As Long
    Invoke                      As Long
    GetDocumentation            As Long
    GetDllEntry                As Long
    GetRefTypeInfo              As Long
    AddressOfMember            As Long
    CreateInstance              As Long
    GetMops                    As Long
    GetContainingTypeLib        As Long
    ReleaseTypeAttr            As Long
    ReleaseFuncDesc            As Long
    ReleaseVarDesc              As Long
End Type

Private Type ITypeLib
    IUnk                        As IUnknown
    GetTypeInfoCount            As Long
    GetTypeInfo                As Long
    GetTypeInfoType            As Long
    GetTypeInfoOfGuid          As Long
    GetLibAttr                  As Long
    GetTypeComp                As Long
    GetDocumentation            As Long
    IsName                      As Long
    FindName                    As Long
    ReleaseTLibAttr            As Long
End Type

Private Type DISPPARAMS
    rgPointerToVariantArray    As Long
    rgPointerToLONGNamedArgs    As Long
    cArgs                      As Long
    cNamedArgs                  As Long
End Type

Private Type SAFEARRAYBOUND
    cElements                  As Long
    lLBound                    As Long
End Type

Private Type SAFEARRAY_1D
  cDims                        As Integer
  fFeatures                    As Integer
  cbElements                  As Long
  cLocks                      As Long
  pvData                      As Long
  Bounds(0 To 0)              As SAFEARRAYBOUND
End Type

Private Enum VARENUM
    VT_EMPTY = 0
    VT_NULL = 1
    VT_I2 = 2
    VT_I4 = 3
    VT_R4 = 4
    VT_R8 = 5
    VT_CY = 6
    VT_DATE = 7
    VT_BSTR = 8
    VT_DISPATCH = 9
    VT_ERROR = 10
    VT_BOOL = 11
    VT_VARIANT = 12
    VT_UNKNOWN = 13
    VT_DECIMAL = 14
    VT_I1 = 16
    VT_UI1 = 17
    VT_UI2 = 18
    VT_UI4 = 19
    VT_I8 = 20
    VT_UI8 = 21
    VT_INT = 22
    VT_UINT = 23
    VT_VOID = 24
    VT_HRESULT = 25
    VT_PTR = 26
    VT_SAFEARRAY = 27
    VT_CARRAY = 28
    VT_USERDEFINED = 29
    VT_LPSTR = 30
    VT_LPWSTR = 31
    VT_FILETIME = 64
    VT_BLOB = 65
    VT_STREAM = 66
    VT_STORAGE = 67
    VT_STREAMED_OBJECT = 68
    VT_STORED_OBJECT = 69
    VT_BLOB_OBJECT = 70
    VT_CF = 71
    VT_CLSID = 72
    VT_STREAMED_PROPSET = 73
    VT_STORED_PROPSET = 74
    VT_BLOB_PROPSET = 75
    VT_VERBOSE_ENUM = 76
    VT_BSTR_BLOB = &HFFF
    VT_VECTOR = &H1000
    VT_ARRAY = &H2000
    VT_BYREF = &H4000
    VT_RESERVED = &H8000
    VT_ILLEGAL = &HFFFF
    VT_ILLEGALMASKED = &HFFF
    VT_TYPEMASK = &HFFF
End Enum

Public Event EventRaised(ByVal strName As String, params() As Variant)

Private oCPC        As IConnectionPointContainer
Private pCPC        As Long
Private pVTblCPC    As Long

Private oECP        As IEnumConnectionPoints
Private pECP        As Long
Private pVTblECP    As Long

Private oCP        As IConnectionPoint
Private pCP        As Long
Private pVTblCP    As Long

Private oUnk        As IUnknown
Private pUnk        As Long
Private pVTblUnk    As Long

Private oTarget    As Object
Private pTarget    As Long
Private pVTblTarget As Long

Private oSink      As Object
Private dwCookie    As Long

Private iid_event  As UUID

Private blnAttached As Boolean

' by Edanmo
Private Sub pvSetParamArray(ByVal ptr As Long, aParams() As Variant)
    Dim tDPAR      As DISPPARAMS
    Dim SafeArray  As SAFEARRAY_1D
    Dim iVarType    As Integer
    Dim lIdx        As Long
    Dim lPtr        As Long
    Dim lVarPtr    As Long

    ' DISPPARAMS structure
    CpyMem tDPAR, ByVal ptr, Len(tDPAR)
    If tDPAR.cArgs = 0 Then Exit Sub

    ' pointer to the first variant
    lVarPtr = tDPAR.rgPointerToVariantArray

    For lIdx = 0 To tDPAR.cArgs - 1

        ' get the variant's type
        CpyMem iVarType, ByVal lVarPtr + (lIdx * 16&), 2&

        If (iVarType And VT_BYREF) = VT_BYREF Then

            ' ByRef Parameter

            ' get the pointer
            CpyMem lPtr, ByVal lVarPtr + (lIdx * 16&) + 8&, 4&

            Select Case iVarType And VT_TYPEMASK
                Case vbString

                    Dim lStrPtr As Long
                    ' String Pointer
                    CpyMem lStrPtr, ByVal lPtr, 4&

                    If lStrPtr = 0 Then
                        ' new string
                        lStrPtr = SysAllocStringPtr(StrPtr(aParams(tDPAR.cArgs - lIdx)))
                    Else
                        ' reallocate the string
                        lStrPtr = SysReAllocString(lStrPtr, StrPtr(aParams(tDPAR.cArgs - lIdx)))
                    End If

                    ' copy the string pointer
                    CpyMem ByVal lPtr, lStrPtr, 4&

                Case vbInteger
                    CpyMem ByVal lPtr, CInt(aParams(tDPAR.cArgs - lIdx)), 2&

                Case vbBoolean
                    CpyMem ByVal lPtr, CBool(aParams(tDPAR.cArgs - lIdx)), 2&

                Case vbInteger
                    CpyMem ByVal lPtr, CInt(aParams(tDPAR.cArgs - lIdx)), 2&

                Case vbLong
                    CpyMem ByVal lPtr, CLng(aParams(tDPAR.cArgs - lIdx)), 4&

                Case vbSingle
                    CpyMem ByVal lPtr, CSng(aParams(tDPAR.cArgs - lIdx)), 4&

                Case vbDouble
                    CpyMem ByVal lPtr, CDbl(aParams(tDPAR.cArgs - lIdx)), 8&

                Case vbDate
                    CpyMem ByVal lPtr, CDate(aParams(tDPAR.cArgs - lIdx)), 8&

                Case vbByte
                    CpyMem ByVal lPtr, CByte(aParams(tDPAR.cArgs - lIdx)), 1&

                Case vbCurrency
                    CpyMem ByVal lPtr, CCur(aParams(tDPAR.cArgs - lIdx)), 8&

                Case vbVariant, vbDecimal
                    VariantCopyIndPtr lPtr, VarPtr(aParams(tDPAR.cArgs - lIdx))

            End Select

        End If

    Next

End Sub

' by Edanmo
Private Function pvGetParamArray(ByVal ptr As Long) As Variant()
    Dim tDPAR          As DISPPARAMS
    Dim SafeArray      As SAFEARRAY_1D
    Dim aTmpParams()    As Variant
    Dim aParams()      As Variant
    Dim lIdx            As Long

    ' DISPPARAMS structure
    CpyMem tDPAR, ByVal ptr, Len(tDPAR)
    If tDPAR.cArgs = 0 Then Exit Function

    ' array pointing to the param array
    With SafeArray
        .Bounds(0).cElements = tDPAR.cArgs
        .Bounds(0).lLBound = 0
        .cDims = 1
        .cbElements = 16
        .pvData = tDPAR.rgPointerToVariantArray
    End With
    CpyMem ByVal VarPtrArray(aTmpParams), VarPtr(SafeArray), 4&

    ' copy elements
    ReDim aParams(1 To tDPAR.cArgs)
    For lIdx = 1 To tDPAR.cArgs
        aParams(lIdx) = aTmpParams(tDPAR.cArgs - lIdx)
    Next

    ' return the parameters
    pvGetParamArray = aParams

    ' destroy the array
    CpyMem ByVal VarPtrArray(aTmpParams), 0&, 4&
End Function

Private Function GetMemberName(obj As Object, ByVal dispid As Long, iid As UUID) As String
    Dim oTypeLib    As ITypeLib
    Dim pTypeLib    As Long
    Dim pVTblTpLib  As Long

    Dim oTypeInfo  As ITypeInfo
    Dim pTypeInfo  As Long
    Dim pVTblTpInfo As Long

    Dim oDispatch  As IDispatch
    Dim hRet        As Long
    Dim dwIndex    As Long
    Dim pcNames    As Long
    Dim pVTbl      As Long

    Dim strName    As String

    ' get IDispatch from the object
    pVTbl = ObjPtr(obj)
    CpyMem pVTbl, ByVal pVTbl, 4
    CpyMem oDispatch, ByVal pVTbl, Len(oDispatch)

    ' get ITypeInfo
    hRet = CallPointer(oDispatch.GetTypeInfo, ObjPtr(obj), 0, lcid, VarPtr(pTypeInfo))
    If hRet Then Exit Function

    ' ITypeInfo VTable
    CpyMem pVTblTpInfo, ByVal pTypeInfo, 4
    CpyMem oTypeInfo, ByVal pVTblTpInfo, Len(oTypeInfo)

    ' let's first ty to get the name
    ' of the member by using the current TypeInfo
    hRet = CallPointer(oTypeInfo.GetNames, pTypeInfo, dispid, VarPtr(strName), 1, VarPtr(pcNames))
    If Len(strName) > 0 Then
        GetMemberName = strName
        Exit Function
    End If

    ' no, that didn't work.
    ' go for the whole type library

    ' GetContainingTypeLib
    hRet = CallPointer(oTypeInfo.GetContainingTypeLib, pTypeInfo, VarPtr(pTypeLib), VarPtr(dwIndex))
    If hRet Then
        GetMemberName = dispid
        Exit Function
    End If

    ' ITypeLib VTable
    CpyMem pVTblTpLib, ByVal pTypeLib, 4
    CpyMem oTypeLib, ByVal pVTblTpLib, Len(oTypeLib)

    ' GetTypeInfoOfGUID
    hRet = CallPointer(oTypeLib.GetTypeInfoOfGuid, pTypeLib, VarPtr(iid_event), VarPtr(pTypeInfo))
    If hRet Then
        GetMemberName = dispid
        Exit Function
    End If

    ' ITypeInfo VTable
    CpyMem pVTblTpInfo, ByVal pTypeInfo, 4
    CpyMem oTypeInfo, ByVal pVTblTpInfo, Len(oTypeInfo)

    ' GetNames
    hRet = CallPointer(oTypeInfo.GetNames, pTypeInfo, dispid, VarPtr(strName), 1, VarPtr(pcNames))

    If Len(strName) = 0 Then
        ' no string... :(
        ' instead return the dispip
        GetMemberName = dispid
    Else
        GetMemberName = strName
    End If
End Function

Public Sub FireEvent(ByVal dispid As Long, ByVal params As Long)
    Dim strEvent    As String
    Dim vParams()  As Variant

    ' get the name of the event
    strEvent = GetMemberName(oTarget, dispid, iid_event)

    ' param array
    vParams = pvGetParamArray(params)

    ' forward the event
    RaiseEvent EventRaised(strEvent, vParams)

    ' sync byref params
    pvSetParamArray params, vParams
End Sub

Public Sub Detach()
    Dim hRet    As Long

    If Not blnAttached Then Exit Sub

    ' clean up
    hRet = CallPointer(oCP.Unadvise, pCP, dwCookie)
    hRet = CallPointer(oCP.IUnk.Release, pCP)
    hRet = CallPointer(oECP.IUnk.Release, pECP)
    hRet = CallPointer(oCPC.IUnk.Release, pCPC)
    Set oTarget = Nothing

    blnAttached = False
End Sub

Public Function Attach(obj As Object) As Boolean
    Dim cReturned  As Long
    Dim hRet        As Long
    Dim iid_ICP    As UUID

    ' already connected to an object?
    If blnAttached Then Detach

    ' IUnknown VTable
    Set oTarget = obj
    pTarget = ObjPtr(obj)
    CpyMem pVTblTarget, ByVal pTarget, 4
    CpyMem oUnk, ByVal pVTblTarget, Len(oUnk)

    ' IID string -> GUID struct
    hRet = CLSIDFromString(StrPtr(IIDSTR_IConnectionPointContainer), iid_ICP)
    If hRet Then Exit Function

    ' get IConnectionPointContainer
    hRet = CallPointer(oUnk.QueryInterface, pTarget, VarPtr(iid_ICP), VarPtr(pCPC))
    If hRet Then Exit Function

    ' IConnectionPointContainer VTable
    CpyMem pVTblCPC, ByVal pCPC, 4
    CpyMem oCPC, ByVal pVTblCPC, Len(oCPC)

    ' get IEnumConnectionPoints
    hRet = CallPointer(oCPC.EnumConnectionPoints, pCPC, VarPtr(pECP))
    If hRet Then Exit Function

    ' IEnumConnectionPoints VTable
    CpyMem pVTblECP, ByVal pECP, 4
    CpyMem oECP, ByVal pVTblECP, Len(oECP)

    ' take the first best Connection Point
    hRet = CallPointer(oECP.Next, pECP, 1, VarPtr(pCP), VarPtr(cReturned))
    If hRet Then Exit Function

    ' IConnectionPoint VTable
    CpyMem pVTblCP, ByVal pCP, 4
    CpyMem oCP, ByVal pVTblCP, Len(oCP)

    ' IID of the event interface
    hRet = CallPointer(oCP.GetConnectionInterface, pCP, VarPtr(iid_event))
    If hRet Then Exit Function

    ' create a new event sink
    Set oSink = CreateEventSink(iid_event, Me)

    ' advise the event sink
    hRet = CallPointer(oCP.Advise, pCP, ObjPtr(oSink), VarPtr(dwCookie))
    If hRet Then Exit Function

    ' wohoo, done!
    blnAttached = True
    Attach = True
End Function

Private Sub Class_Initialize()
    InitObjExtender
End Sub

---

Code:

---

        Form2.show
        Set Form2.m = New clsObjectExtender
        If Not Form2.m.Attach(obj) Then
            MsgBox "couldn't connect to c", vbExclamation
        Else
            ' fire some events
            ' unadvise the event sink
            Form2.m.Detach
        End If

---

Form2

Code:

---

Public WithEvents m    As clsObjectExtender
Private Sub m_EventRaised(ByVal strName As String, params() As Variant)
    On Error Resume Next
    MsgBox "Event " & strName
End Sub

---

Quote:

---

Originally Posted by jsvenu

Dear xiaoyao,

Just put msgbox in CreateVBHeaderCopy module function as follows:

' // Create copy of VBHeader and other structures
' // The first four bytes contain thread ID. We use that ID to clean unused headers

Code:

---

Private Function CreateVBHeaderCopy() As Long
    Dim pHeader        As Long
    Dim pOldProjInfo    As Long
    Dim pProjInfo      As Long
    Dim pObjTable      As Long
    Dim pOldObjTable    As Long
    Dim lDifference    As Long
    Dim lIndex          As Long
    Dim pNames(3)      As Long
    Dim lModulesCount  As Long
    Dim pDescriptors    As Long
    Dim pOldDesc        As Long
    Dim pVarBlock      As Long
    Dim lSizeOfHeaders  As Long
   
    ' // Get size of all headers
    lSizeOfHeaders = &H6A + &H23C + &H54 + &HC + 4
   
    GetMem4 ByVal pVBHeader + &H30, pOldProjInfo
    GetMem4 ByVal pOldProjInfo + &H4, pOldObjTable
    GetMem4 ByVal pOldObjTable + &H30, pOldDesc
    GetMem2 ByVal pOldObjTable + &H2A, lModulesCount
    MsgBox "lModulesCount  " & lModulesCount
    lSizeOfHeaders = lSizeOfHeaders + &H30 * lModulesCount
    MsgBox "lSizeOfHeaders  " & lSizeOfHeaders
 ' // Allocate memory for header
    Do
       
        pHeader = HeapAlloc(hHeadersHeap, HEAP_ZERO_MEMORY, lSizeOfHeaders)

---

regards,
JSVenu

---

Dear Trick,

For knowing values of lModulesCount and lSizeOfHeaders
I used msgbox in CreateVBHeaderCopy for displaying the values.But I did not get the msgbox displayed but application worked fine.So to help xiaoyao I changed the msgbox to trace using outputdebugstring and could get the values thru
other debug tools when the app was running.Can you clarify me why the app works fine but msgbox is not displayed if I use them.

regards,
JSVenu

Quote:

---

Originally Posted by jsvenu

Dear Trick,

For knowing values of lModulesCount and lSizeOfHeaders
I used msgbox in CreateVBHeaderCopy for displaying the values.But I did not get the msgbox displayed but application worked fine.So to help xiaoyao I changed the msgbox to trace using outputdebugstring and could get the values thru
other debug tools when the app was running.Can you clarify me why the app works fine but msgbox is not displayed if I use them.

regards,
JSVenu

---

you can use the api "messageboxa" replace for "msgbox"
you must run "VBDllGetClassObject" ok,then you can use "msgbox"
if not load "msgvbvm60.dll" ok in thread,you can't use vb6 object like "msgbox"

Code:

---

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

Function Msg(Info As String, Optional Title As String = "MyTip")
Msg = MessageBox(0, Info, Title, 0)
End Function

---

Quote:

---

Originally Posted by jsvenu

Dear Trick,

For knowing values of lModulesCount and lSizeOfHeaders
I used msgbox in CreateVBHeaderCopy for displaying the values.But I did not get the msgbox displayed but application worked fine.So to help xiaoyao I changed the msgbox to trace using outputdebugstring and could get the values thru
other debug tools when the app was running.Can you clarify me why the app works fine but msgbox is not displayed if I use them.

regards,
JSVenu

---

you can use the api "messageboxa" replace for "msgbox"
you must run "VBDllGetClassObject" ok,then you can use "msgbox"
if not load "msgvbvm60.dll" ok in thread,you can't use vb6 object like "msgbox"

question:
vb make standad dll /EXPORT:ShowForm2
ShowForm2 is call "createthread" to show form1 in dll.
from abc.exe load this dll,call api "ShowForm2",when show more form1 windows,close all window
and close abc.exe will crash from time to time
==============

[VBCompiler]
LinkSwitches=/DLL /ENTRY:DllMain /EXPORT:Sum /EXPORT:ShowForm /EXPORT:ShowForm2
ShowForm2 is a sub

Code:

---

dll code:
sub ShowForm2()
createthread addressof NewFormInThread
end sub

sub NewFormInThread()

CreateIExprSrvObj 0, 4, 0
Call InitRuntime(lpInst_, lpUnk_, lpVBHdr_, hInstance, 1, 0)
dim f as form1
set f=new form1
f.show 1
set f=nothing
vbCoUninitialize

end sub

---

use vc++ make a standad exe(or use vb6 ) to call this api "ShowForm2"
There is an interface in the DLL that creates a new thread and displays a form in the thread.

If you call this API many times, then manually close all the Windows, and then end VC++ write the main program EXE will crash from time to time.
chinese:
dll中有个接口，他的功能是创建一个新线程，并且在线程中显示一个窗体。
如果多次调用这个API，然后手工关闭所有窗口，再结束VC++写的主程序EXE就会不时的崩溃。

Quote:

---

why are manually vTable creation, manually registration etc required for MTA library.

---

Because the runtime is STA and you can't use it to create a MTA library, particularly you can't uses classes. You need to "emulate" them through UDTs.

Quote:

---

I don't understand why the main default thread not being apartment model is able to load the user control to the form in main default thread.

---

The main thread is STA as well. VB6 can create only STA. The default model is the single-threaded one. It's like if you use such option when you create an ActiveX DLL. This option means all the objects from that library live in the main STA (even if you create them from other STA). The reason it can't load usercontrols in other project types (ActiveX EXE, Standard EXE with threading) related to the internal structure of the runtime (called Hxmod).

Quote:

---

Moreover when I try to make the main thread of the project to be apartment model as follows it crashes.

---

It occurs because you write to the non-writable page. Notice i used VirtualProtect to change attributes.

Quote:

---

About what you said: my goal is to create threads and allow them to call back to any address, whether it's in bas, forms, classes, usercontrol, etc. It seems to work.

---

What's the thread context should process the callback? If the context isn't crucial you can use marshaling for object-calls. The COM will do all the work to synchronize theads. If you need to process the callback in its own thread you can use InitCurrentThreadAndCallFunction.

Quote:

---

Can you clarify me why the app works fine but msgbox is not displayed if I use them.

---

Because MsgBox is the project-depended function. When you call this function the project isn't initialized yet and runtime doesn't know if the Unattended Execution option enabled/disabled. The runtime queries for the thread data (CThreadPool::GetThreadData) and it returns nothing. The function behaves like it returns vbAbort.

Quote:

---

you can use the api "messageboxa" replace for "msgbox"
you must run "VBDllGetClassObject" ok,then you can use "msgbox"
if not load "msgvbvm60.dll" ok in thread,you can't use vb6 object like "msgbox"

---

The built-in MsgBox function isn't only show message window it may write an entry to a log.

Quote:

---

Originally Posted by The trick

The built-in MsgBox function isn't only show message window it may write an entry to a log.

---

use createthread api in standard exe,it's very easy。
how to use createthread (for show form1)in vb6 standard dll(not activex dll),do you have a simple demo?Purpose: injection of other processes, and multi-threaded display of multiple windows, the need for multiple injection and then uninstall.In the uninstall, it is often the main program to be injected to do the crash.
chinese:用途:注入其他进程，并且用多线程显示多个窗口，需要多次注入再卸载。在卸载的时候，经常会把被注入的主程序搞崩溃。

Quote:

---

use createthread api in standard exe,it's very easy。
how to use createthread (for show form1)in vb6 standard dll(not activex dll),do you have a simple demo?Purpose: injection of other processes, and multi-threaded display of multiple windows, the need for multiple injection and then uninstall.In the uninstall, it is often the main program to be injected to do the crash.

---

Why don't you want to use ActiveX DLL? They work no worse than standard DLLs.

If you can't use an ActiveX DLL for some reason (for example if the interface is fixed) you can notice to that. If you have troubles please attach the example (a zip file) i'll fix it.

Dear Trick,


In the following attached activex exe code running standalone in modmain.bas we display fMain in modeless way

Code:

---

Sub Main()                             
    If App.TaskVisible Then fMain.Show 
End Sub

---

I add usercontrol to my activex exe standalone project thru Load User Control button as follows:

Code:

---

Private Sub Command1_Click()             
    Controls.Add("AxThreading.UserControl1", "Ctl1").Visible = True            'load usercontrol Control onto this ThreadForm
End Sub

---

When I click on the Load User Control button I get the following error in msgbox

---------------------------
AxThreading
---------------------------
Run-time error '720':

'AxThreading.UserControl1' is not a valid control type
---------------------------
OK
---------------------------





But when I make fMain to display in modal fashion as follows and click on the Load User Control button it works fine.

Sub Main()
If App.TaskVisible Then fMain.Show vbModal
End Sub

1. Please clarify how to make this activex exe application to work when fMain is displayed in modeless way.


When I click on Create and show an additional threaded Form button in the displayed form I get another instance of the same form displayed in new thread.

When I click on the Load User Control button in this new form I get the following error

---------------------------
AxThreading
---------------------------
Run-time error '339':

Component '' or one of its dependencies not correctly registered: a file is missing or invalid
---------------------------
OK
---------------------------

2. Please clarify how to make this work fine in this new form displayed in new thread.


regards,
JSVenu