modcom.bas

反编译vb软件,可以把vb打包的软件直接翻译成源码,非常好用,

            ReturnDataType = strReturn & vbCrLf

        End With
    End With
exitFunction:

End Function

Public Sub ProcessTypeLibrary()
    '*****************************
    'Purpose: Procces the Type Libary
    '*****************************
    'Clear lists
    frmMain.lstTypeInfos.Clear
    frmMain.lstMembers.Clear

    'Display members for type library
    tliTypeLibInfo.GetTypesDirect frmMain.lstTypeInfos.hwnd, , tliStAll
End Sub
Public Function getEventsFromFile(sFileName As String) As String
    '*****************************
    'Purpose: Get all events from file
    '*****************************
    'On Error Resume Next
    Dim srT As SearchResults
    Dim srM As SearchResults
    Dim mi As MemberInfo, mi2 As MemberInfo
    Dim lSearchData As Long
    Dim p As Long, m As Long, t As Long
    Dim LibInfoGuid As TypeLibInfo

    Dim tliTypeInfo As TypeInfo
    With tliTypeLibInfo

        .ContainingFile = sFileName

        Set srT = .GetTypes(, tliStEvents, False)
        For t = 1 To srT.count

            lSearchData = srT(t).SearchData

            Set tliTypeInfo = tliTypeLibInfo.GetTypeInfo(Replace(Replace(srT(t).Name, "<", ""), ">", ""))


            frmMain.txtCode.Text = frmMain.txtCode.Text & "'==================== " & srT(t).Name & "====================" & tliTypeLibInfo.GUID & vbCrLf & vbCrLf

            Set srM = tliTypeLibInfo.GetMembers(lSearchData)

            For m = 1 To srM.count

                DoEvents

                Set mi = .GetMemberInfo(lSearchData, srM(m).InvokeKinds, srM(m).MemberId, srM(m).Name)

                frmMain.txtCode.Text = frmMain.txtCode.Text & getEventInfo(mi, srT(t).Name, True) & vbCrLf
                '   Call getEventInfo(mi, srT(t).Name)
            Next m
        Next t
    End With

End Function
Public Function getEventInfo(mi As MemberInfo, ObjectName As String, ShowOpcode As Boolean) As String
    '*****************************
    'Purpose: Get a specific event information
    '*****************************
    Dim sOutput As String, strTypeName As String, ConstVal As String
    Dim lSearchData As Long
    Dim bIsConstant As Boolean, bDefault As Boolean, bFirstParameter As Boolean
    Dim bParamArray As Boolean, bOptional As Boolean, bByVal As Boolean
    Dim tliParameterInfo As ParameterInfo
    Dim tliTypeInfo As TypeInfo, tliResolvedTypeInfo As TypeInfo
    Dim tliTypeKinds As TypeKinds
    Dim intVarTypeCur As Integer
    With mi
        If ShowOpcode = True Then
            sOutput = sOutput & .VTableOffset

        End If
        bIsConstant = GetSearchType(lSearchData) And tliStConstants

        sOutput = sOutput & .Name
        With .Parameters
            If .count Then
                sOutput = sOutput & " ("
                bFirstParameter = True
                bParamArray = .OptionalCount = -1
                For Each tliParameterInfo In .Me
                    If Not bFirstParameter Then
                        sOutput = sOutput & ", "
                    End If
                    bFirstParameter = False
                    bDefault = tliParameterInfo.Default
                    bOptional = bDefault Or tliParameterInfo.Optional
                    If bOptional Then
                        If bParamArray Then
                            'This will be the only optional parameter
                            sOutput = sOutput & "[ParamArray "
                        Else
                            sOutput = sOutput & "["
                        End If
                    End If

                    With tliParameterInfo.VarTypeInfo
                        Set tliTypeInfo = Nothing
                        Set tliResolvedTypeInfo = Nothing
                        tliTypeKinds = TKIND_MAX
                        intVarTypeCur = .VarType
                        If (intVarTypeCur And Not (VT_ARRAY Or VT_VECTOR)) = 0 Then
                            On Error Resume Next
                            Set tliTypeInfo = .TypeInfo
                            If Not tliTypeInfo Is Nothing Then
                                Set tliResolvedTypeInfo = tliTypeInfo
                                tliTypeKinds = tliResolvedTypeInfo.TypeKind
                                Do While tliTypeKinds = TKIND_ALIAS
                                    tliTypeKinds = TKIND_MAX
                                    Set tliResolvedTypeInfo = tliResolvedTypeInfo.ResolvedType
                                    If Err Then
                                        Err.Clear
                                    Else
                                        tliTypeKinds = tliResolvedTypeInfo.TypeKind
                                    End If
                                Loop
                            End If

                            'Determine whether parameters are ByVal or ByRef
                            Select Case tliTypeKinds
                                Case TKIND_INTERFACE, TKIND_COCLASS, TKIND_DISPATCH
                                    bByVal = .PointerLevel = 1
                                Case TKIND_RECORD
                                    'Records not passed ByVal in VB
                                    bByVal = False
                                Case Else
                                    bByVal = .PointerLevel = 0
                            End Select

                            'Indicate ByVal
                            If bByVal Then
                                sOutput = sOutput & "ByVal "
                            End If

                            'Display the parameter name
                            sOutput = sOutput & tliParameterInfo.Name

                            If intVarTypeCur And (VT_ARRAY Or VT_VECTOR) Then
                                sOutput = sOutput & "()"
                            End If

                            If tliTypeInfo Is Nothing Then 'Information not available
                                sOutput = sOutput & " As ?"
                            Else
                                If .IsExternalType Then
                                    sOutput = sOutput & " As " & .TypeLibInfoExternal.Name & "." & tliTypeInfo.Name
                                Else
                                    sOutput = sOutput & " As " & tliTypeInfo.Name
                                End If
                            End If

                            'Reset error handling
                            On Error GoTo 0
                        Else
                            If .PointerLevel = 0 Then
                                sOutput = sOutput & "ByVal "
                            End If

                            sOutput = sOutput & tliParameterInfo.Name
                            If intVarTypeCur <> vbVariant Then
                                strTypeName = TypeName(.TypedVariant)
                                If intVarTypeCur And (VT_ARRAY Or VT_VECTOR) Then
                                    sOutput = sOutput & "() As " & Left$(strTypeName, Len(strTypeName) - 2)
                                Else
                                    sOutput = sOutput & " As " & strTypeName
                                End If
                            End If
                        End If

                        If bOptional Then
                            If bDefault Then
                                sOutput = sOutput & ProduceDefaultValue(tliParameterInfo.DefaultValue, tliResolvedTypeInfo)
                                'sOutput = sOutput & " = " & tliParameterInfo.DefaultValue
                            End If
                            sOutput = sOutput & "]"
                        End If
                    End With
                Next
                sOutput = sOutput & ")"
            End If
        End With
        'return type
        If bIsConstant Then
            ConstVal = .Value
            sOutput = sOutput & " = " & ConstVal
            Select Case VarType(ConstVal)
                Case vbInteger, vbLong
                    If ConstVal < 0 Or ConstVal > 15 Then
                        sOutput = sOutput & " (&H" & Hex$(ConstVal) & ")"
                    End If
            End Select
        Else
            With .ReturnType
                intVarTypeCur = .VarType
                If intVarTypeCur = 0 Or (intVarTypeCur And Not (VT_ARRAY Or VT_VECTOR)) = 0 Then
                    On Error Resume Next
                    If Not .TypeInfo Is Nothing Then
                        If Err Then                        'Information not available
                            sOutput = sOutput & " As ?"
                        Else
                            If .IsExternalType Then
                                sOutput = sOutput & " As " & .TypeLibInfoExternal.Name & "." & .TypeInfo.Name
                            Else
                                sOutput = sOutput & " As " & .TypeInfo.Name
                            End If
                        End If
                    End If

                    If intVarTypeCur And (VT_ARRAY Or VT_VECTOR) Then
                        sOutput = sOutput & "()"
                    End If
                    On Error GoTo 0
                Else
                    Select Case intVarTypeCur
                        Case VT_VARIANT, VT_VOID, VT_HRESULT
                        Case Else
                            strTypeName = TypeName(.TypedVariant)
                            If intVarTypeCur And (VT_ARRAY Or VT_VECTOR) Then
                                sOutput = sOutput & "() As " & Left$(strTypeName, Len(strTypeName) - 2)
                            Else
                                sOutput = sOutput & " As " & strTypeName
                            End If
                    End Select
                End If
            End With
        End If
    End With
    getEventInfo = sOutput
End Function

Public Function ReturnHelpString(ByVal SearchData As Long, ByVal InvokeKinds As InvokeKinds, Optional ByVal MemberName As String) As String
    '*****************************
    'Purpose: To return the help string used on textbox in form editor to describe function
    '*****************************
    With tliTypeLibInfo
        'First, determine the type of member we're dealing with
        With .GetMemberInfo(SearchData, InvokeKinds, , MemberName)
            ReturnHelpString = .HelpString
        End With
    End With

End Function
Public Function getEventComplete(sFileName As String, strGuid As String, EventNum As Integer) As String
    '*****************************
    'Purpose: To return all the events from a filename by COM
    '*****************************
    'On Error Resume Next
    Dim srT As SearchResults
    Dim srM As SearchResults
    Dim mi As MemberInfo, mi2 As MemberInfo
    Dim lSearchData As Long
    Dim p As Long, m As Long, t As Long
    Dim LibInfoGuid As TypeLibInfo

    Dim tliTypeInfo As TypeInfo
    With tliTypeLibInfo

        .ContainingFile = sFileName

        Set srT = .GetTypes(, tliStEvents, False)
        For t = 1 To srT.count

            lSearchData = srT(t).SearchData

            Set tliTypeInfo = tliTypeLibInfo.GetTypeInfo(Replace(Replace(srT(t).Name, "<", ""), ">", ""))

            'frmMain.txtCode.Text = frmMain.txtCode.Text & "'==================== " & srT(t).Name & "====================" & tliTypeLibInfo.GUID & vbCrLf & vbCrLf
            If tliTypeInfo.GUID = strGuid Then
                MsgBox "GuidFound " & srT(t).Name
                Set srM = tliTypeLibInfo.GetMembers(lSearchData)

                For m = 1 To srM.count

                    DoEvents
                    If m = EventNum Then
                        Set mi = .GetMemberInfo(lSearchData, srM(m).InvokeKinds, srM(m).MemberId, srM(m).Name)

                        'frmMain.txtCode.Text = frmMain.txtCode.Text & getEventInfo(mi, srT(t).Name, False) & vbCrLf
                        getEventComplete = getEventInfo(mi, srT(t).Name, False)

                        Exit Function
                    End If
                Next m
            End If
            '
        Next t
    End With

End Function