GetMethod en VB6? y CreateObject(...) mediante API?

[EddyW]

Wenas,

Tengo una duda, programando en FreeBasic me fije que no hay CreateObject como en VB6, es decir no se pueden cargar objetos mediante código, como podría hacerse desde la API? (En VB6 o en FreeBasic)

En VB.Net es posible enumerar los métodos de una Dll, he intentando hacerlo desde VB6 pero no hallo modo, alguna idea?

SaluDOS!!!

[BlackZeroX]

.
Se maneja igual que CreateObject()

Código (Vb) [Seleccionar] Expandir



Option Explicit

'[rm_code]
'CodeId=64499
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" ( _
    ByVal adr As Long, _
    ByVal p1 As Long, _
    ByVal p2 As Long, _
    ByVal p3 As Long, _
    ByVal p4 As Long _
) As Long

Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" ( _
    ByVal szLib As String _
) As Long

Private Declare Function GetProcAddress Lib "kernel32" ( _
    ByVal hModule As Long, _
    ByVal szFnc As String _
) As Long

Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleA" ( _
    ByVal szModule As String _
) As Long

Private Declare Function LoadTypeLibEx Lib "oleaut32" ( _
    ByVal szFile As Long, _
    ByVal REGKIND As Long, _
    pptlib As Any _
) As Long

Private Declare Function StringFromGUID2 Lib "ole32" ( _
    tGuid As Any, _
    ByVal lpszString As String, _
    ByVal lMax As Long _
) As Long

Private Declare Sub CpyMem Lib "kernel32" _
Alias "RtlMoveMemory" ( _
    pDst As Any, _
    pSrc As Any, _
    ByVal dlen As Long _
)

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

Private Type IClassFactory
    IUnk                    As IUnknown
    CreateInstance          As Long
    Lock                    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 TYPEATTR
    guid(15)                As Byte
    lcid                    As Long
    dwReserved              As Long
    memidConstructor        As Long
    memidDestructor         As Long
    pstrSchema              As Long
    cbSizeInstance          As Long
    TYPEKIND                As Long
    cFuncs                  As Integer
    cVars                   As Integer
    cImplTypes              As Integer
    cbSizeVft               As Integer
    cbAlignment             As Integer
    wTypeFlags              As Integer
    wMajorVerNum            As Integer
    wMinorVerNum            As Integer
    tdescAlias              As Long
    idldescType             As Long
End Type

Private Enum TYPEKIND
    TKIND_ENUM
    TKIND_RECORD
    TKIND_MODULE
    TKIND_INTERFACE
    TKIND_DISPATCH
    TKIND_COCLASS
    TKIND_ALIAS
    TKIND_UNION
    TKIND_MAX
End Enum

Private Enum HRESULT
    S_OK = 0
End Enum

Private Type CoClass
    Name                As String
    guid()              As Byte
End Type

Private Type guid
    data1               As Long
    data2               As Integer
    data3               As Integer
    data4(7)            As Byte
End Type

Private Enum REGKIND
    REGKIND_DEFAULT
    REGKIND_REGISTER
    REGKIND_NONE
End Enum

Public Function CreateObjectFromFile( _
    ByVal strLibrary As String, _
    ByVal strClassName As String _
) As stdole.IUnknown

    Dim newobj              As stdole.IUnknown
    Dim udtCF               As IClassFactory

    Dim classid             As guid
    Dim IID_ClassFactory    As guid
    Dim IID_IUnknown        As guid
    Dim lib                 As String

    Dim obj                 As Long
    Dim vtbl                As Long

    Dim hModule             As Long
    Dim pFunc               As Long
    Dim udtCoCls()          As CoClass

    Dim i                   As Long

    With IID_ClassFactory
        .data1 = &H1
        .data4(0) = &HC0
        .data4(7) = &H46
    End With

    With IID_IUnknown
        .data4(0) = &HC0
        .data4(7) = &H46
    End With

    ' get all CoClasses from the type lib of
    ' the file, and find the GUID of the Prog ID
    If Not GetCoClasses(strLibrary, udtCoCls) Then
        Exit Function
    End If

    For i = 0 To UBound(udtCoCls)
        If StrComp(udtCoCls(i).Name, strClassName, vbTextCompare) = 0 Then
            CpyMem classid, udtCoCls(i).guid(0), Len(classid)
            Exit For
        End If
    Next

    If i = UBound(udtCoCls) + 1 Then
        Exit Function
    End If

    ' load the file, if it isn't yet
    hModule = GetModuleHandle(strLibrary)
    If hModule = 0 Then
        hModule = LoadLibrary(strLibrary)
        If hModule = 0 Then Exit Function
    End If

    pFunc = GetProcAddress(hModule, "DllGetClassObject")
    If pFunc = 0 Then Exit Function

    ' call DllGetClassObject to get a
    ' class factory for the class ID
    If 0 <> CallPointer(pFunc, _
                        VarPtr(classid), _
                        VarPtr(IID_ClassFactory), _
                        VarPtr(obj)) Then

        Exit Function
    End If

    ' IClassFactory VTable
    CpyMem vtbl, ByVal obj, 4
    CpyMem udtCF, ByVal vtbl, Len(udtCF)

    ' create an instance of the object
    If 0 <> CallPointer(udtCF.CreateInstance, _
                        obj, _
                        0, _
                        VarPtr(IID_IUnknown), _
                        VarPtr(newobj)) Then

        ' Set IClassFactory = Nothing
        CallPointer udtCF.IUnk.Release, obj
        Exit Function
    End If

    ' Set IClassFactory = Nothing
    CallPointer udtCF.IUnk.Release, obj

    Set CreateObjectFromFile = newobj
End Function

Private Function GetCoClasses( _
    ByVal strFile As String, _
    udtCoClasses() As CoClass _
) As Boolean

    Dim hRes            As HRESULT

    Dim udtITypeLib     As ITypeLib
    Dim udtITypeInfo    As ITypeInfo
    Dim udtTypeAttr     As TYPEATTR

    Dim oTypeLib        As Long
    Dim oTypeInfo       As Long
    Dim pVTbl           As Long
    Dim pAttr           As Long

    Dim lngTypeInfos    As Long
    Dim lngCoCls        As Long
    Dim strTypeName     As String

    Dim i               As Long

    ' load the type lib of the file
    hRes = LoadTypeLibEx(StrPtr(strFile), REGKIND_NONE, oTypeLib)
    If hRes <> S_OK Then Exit Function

    ' ITypeLib's VTable
    CpyMem pVTbl, ByVal oTypeLib, 4
    CpyMem udtITypeLib, ByVal pVTbl, Len(udtITypeLib)

    lngTypeInfos = CallPointer(udtITypeLib.GetTypeInfoCount, oTypeLib)

    For i = 0 To lngTypeInfos - 1

        hRes = CallPointer(udtITypeLib.GetTypeInfo, _
                           oTypeLib, i, _
                           VarPtr(oTypeInfo))

        If hRes <> S_OK Then GoTo NextItem

        ' ITypeInfo's VTable
        CpyMem pVTbl, ByVal oTypeInfo, 4
        CpyMem udtITypeInfo, ByVal pVTbl, Len(udtITypeInfo)

        ' TYPEATTR struct, which describes the type
        CallPointer udtITypeInfo.GetTypeAttr, oTypeInfo, VarPtr(pAttr)
        CpyMem udtTypeAttr, ByVal pAttr, Len(udtTypeAttr)
        CallPointer udtITypeInfo.ReleaseTypeAttr, oTypeInfo, pAttr

        ' name of the type
        CallPointer udtITypeLib.GetDocumentation, _
                    oTypeLib, i, _
                    VarPtr(strTypeName), _
                    0, 0, 0

        If udtTypeAttr.TYPEKIND = TKIND_COCLASS Then
            ReDim Preserve udtCoClasses(lngCoCls) As CoClass

            With udtCoClasses(lngCoCls)
                .guid = udtTypeAttr.guid
                .Name = strTypeName
            End With

            lngCoCls = lngCoCls + 1
        End If

        ' Set ITypeInfo = Nothing
        CallPointer udtITypeInfo.IUnk.Release, oTypeInfo
        oTypeInfo = 0

NextItem:
    Next

    ' Set ITypeLib = Nothing
    CallPointer udtITypeLib.IUnk.Release, oTypeLib
    '
    GetCoClasses = True
End Function

Private Function CallPointer( _
    ByVal fnc As Long, _
    ParamArray params() _
) As Long

    Dim btASM(&HEC00& - 1)  As Byte
    Dim pASM                As Long
    Dim i                   As Integer

    pASM = VarPtr(btASM(0))

    AddByte pASM, &H58                  ' POP EAX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H50                  ' PUSH EAX

    For i = UBound(params) To 0 Step -1
        AddPush pASM, CLng(params(i))   ' PUSH dword
    Next

    AddCall pASM, fnc                   ' CALL rel addr
    AddByte pASM, &HC3                  ' RET

    CallPointer = CallWindowProc(VarPtr(btASM(0)), _
                                 0, 0, 0, 0)
End Function

Private Sub AddPush(pASM As Long, lng As Long)
    AddByte pASM, &H68
    AddLong pASM, lng
End Sub

Private Sub AddCall(pASM As Long, addr As Long)
    AddByte pASM, &HE8
    AddLong pASM, addr - pASM - 4
End Sub

Private Sub AddLong(pASM As Long, lng As Long)
    CpyMem ByVal pASM, lng, 4
    pASM = pASM + 4
End Sub

Private Sub AddByte(pASM As Long, bt As Byte)
    CpyMem ByVal pASM, bt, 1
    pASM = pASM + 1
End Sub

' http://www.aboutvb.de/khw/artikel/khwcreateguid.htm
Private Function GUID2Str( _
    GUIDBytes() As Byte _
) As String

    Dim nTemp       As String
    Dim nGUID(15)   As Byte
    Dim nLength     As Long

    nTemp = Space$(78)
    CpyMem nGUID(0), GUIDBytes(0), 16
    nLength = StringFromGUID2(nGUID(0), nTemp, Len(nTemp))
    GUID2Str = Left$(StrConv(nTemp, vbFromUnicode), nLength - 1)
End Function



[EddyW]

Wenas,

Gracias por la ayuda, me sirvió el código para encontrar lo que buscaba exactamente
Gracias!

SaluDOS!!!
PD: Solucionado (las 2 dudas )