Project Title: Multi Threading using Visual Basic.
Project Type: Visual Basic 6.0 Moudle.
Project Level: Intermediate / Advanced.
Description: Calling API's in New Threads.
Submit Date: Thursday - 15/09/2005.

This module lets you Dynamically Load APIs and Call them in their own Thread.
The advantage of this is you can call APIs which take a long time to process and still have a responding form.
Am using here a Visual Basic moudle file with sub_main to test this kind of code but you can create new main loadable form with one button on it and copy the moudle sub main code to the button sub code and make your test on the form.
And you can use any API's call you want just remeber to free the Loaded Library.
Enjoy it and am watting for your response and feedback.

Option Explicit

Public Declare Function FreeLibrary Lib "kernel32" ( _
    ByVal hLibModule As Long _
) As Long

Public Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" ( _
    ByVal lpLibFileName As String _
) As Long

Public Declare Function GetProcAddress Lib "kernel32" ( _
    ByVal hModule As Long, _
    ByVal lpProcName As String _
) As Long

Private Declare Function GetExitCodeThread Lib "kernel32" ( _
    ByVal hThread As Long, _
    lpExitCode As Long _
) As Long

Private Declare Function CreateThread Lib "kernel32" ( _
    ByVal lpThreadAttributes As Long, _
    ByVal dwStackSize As Long, _
    ByVal lpStartAddress As Long, _
    ByVal lpParameter As Long, _
    ByVal dwCreationFlags As Long, _
    lpThreadId As Long _
) As Long

Private Declare Function GlobalAlloc Lib "kernel32" ( _
    ByVal Flags As Long, _
    ByVal Size As Long _
) As Long

Private Declare Function GlobalFree Lib "kernel32" ( _
    ByVal Mem As Long _
) As Long

Private Declare Function MoveMemory Lib "kernel32" _
Alias "RtlMoveMemory" ( _
    ByRef Dest As Any, _
    ByRef Src As Any, _
    ByVal Size As Long _
) As Long

Private Const GMEM_FIXED As Long = 0&

Public Function CallFuncPtr( _
    FuncPtr As Long, _
    ParamArray Params() As Variant _
) As Long
    Const MAX_CODESIZE  As Long = 65536

    Dim I               As Long
    Dim pCodeData       As Long
    Dim pParamData()    As Long
    Dim PC              As Long
    Dim Operand         As Long
    Dim RetValue        As Long
    Dim StrValue        As String
    Dim LongValue       As Long
    Dim dwThreadID      As Long
    Dim hThread         As Long
    Dim dwExit          As Long

    ReDim pParamData(UBound(Params)) As Long
    pCodeData = GlobalAlloc(GMEM_FIXED, MAX_CODESIZE)
    PC = pCodeData

    AddByte PC, &H55

    For I = UBound(Params) To 0 Step -1
        If VarType(Params(I)) = vbString Then

            pParamData(I) = GlobalAlloc(GMEM_FIXED, _
                                LenB(Params(I)))

            StrValue = Params(I)
            MoveMemory ByVal pParamData(I), _
                       ByVal StrValue, LenB(StrValue)

            Operand = pParamData(I)

        Else
            Operand = Params(I)
        End If

        AddByte PC, &H68
        AddLong PC, Operand
    Next

    AddByte PC, &HB8
    AddLong PC, FuncPtr
    AddInt PC, &HD0FF

    AddByte PC, &HBA
    AddLong PC, VarPtr(RetValue)

    AddInt PC, &H289
    AddByte PC, &H5D
    AddInt PC, &HC033
    AddByte PC, &HC2
    AddInt PC, &H8

    hThread = CreateThread(0, 0, pCodeData, _
                           0, 0, dwThreadID)

    Do
        ' if exit code is 256 the thread is
        ' still running
        GetExitCodeThread hThread, dwExit
        If dwExit <> 259 Then Exit Do
        DoEvents
    Loop

    GlobalFree pCodeData
    For I = 0 To UBound(Params)
        If pParamData(I) <> 0 Then
            GlobalFree pParamData(I)
        End If
    Next

    CallFuncPtr = RetValue
End Function

Private Sub AddByte(ByRef PC As Long, ByVal ByteValue As Byte)
    MoveMemory ByVal PC, ByteValue, 1
    PC = PC + 1
End Sub

Private Sub AddInt(ByRef PC As Long, ByVal IntValue As Integer)
    MoveMemory ByVal PC, IntValue, 2
    PC = PC + 2
End Sub

Private Sub AddLong(ByRef PC As Long, ByVal LongValue As Long)
    MoveMemory ByVal PC, LongValue, 4
    PC = PC + 4
End Sub

Public Sub Main()
    Dim hDll    As Long
    Dim pMessageBox As Long

    ' get the address of MessageBoxA()
    '
    ' user32 should already be loaded but
    ' we need its module handle

    hDll = LoadLibrary("user32.dll")    ' Loading User32.dll Library
    pMessageBox = GetProcAddress(hDll, "MessageBoxA") ' Getting API Handle

    ' Calling our Function and running it in New Thread.
    If CallFuncPtr(pMessageBox, 0, "MessageBoxA Test", "Test", 1) = 1 Then
        MsgBox "You pressed Ok"
    Else
        MsgBox "You pressed Cance"
    End If

    ' Free the Loaded Library User32.dll
    FreeLibrary hDll
End Sub

هذا أول موضوع لي وأنا حاليا أقوم بتجربة المنتدى وأتمنى له التوفيق ولكن عندي تعليق أطلب من إدارة المنتدى السماح بتحميل الملفات كالمشاريع البرمجية وذلك لصعوبة تنسيق المشروع من ذوي الخبرة القليلة في لغة البرمجة المستخدمة واتمنى اخذ طلبي بالحسبان ومنقاشته وذلك لضرورته وشكرا لكم والله الموفق

موضوع مهم...
و لكني يبدو أنك نسيت الإعلان على الـ FreeLibrary Function مما يسبب خطأ :(
لا مشكلة, الإعلان عن هذه الـ Function يكون هكذا :

Private Declare Function FreeLibrary Lib "kernel32" ( _
ByVal hLibModule As Long _
) As Long

شكراً,
مؤيد مارديني

آسف على هذا الخطأ ولكن ليس لدي فيجوال بيسك على الجهاز الذي أرسلت منه الموضوع وقمت بإضافة هذه الدالة بعد إنتهائي من كتابته حيث قمت بتبسيط الدالة الأساسية على أسطر منفردة وبعد ذلك أضفت هذه الدالة.
شكرا لك لتنبيهي لذلك وقد تم تصحيح الموضوع وإضافة الدالة إليه.
أعذروني على الخطأ ( جل من لا يخطأ ).

NONE