modcom.bas

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

Attribute VB_Name = "modCOM"


'*****************************
'modCom.bas
'Purpose to Retrive the members and variable types of a control
'*****************************
Global tliTypeLibInfo As TypeLibInfo
Public Function GetSearchType(ByVal SearchData As Long) As TliSearchTypes
    'This helper function adapted from Microsoft documentation
    If SearchData And &H80000000 Then
        GetSearchType = ((SearchData And &H7FFFFFFF) \ &H1000000 And &H7F&) Or &H80
    Else
        GetSearchType = SearchData \ &H1000000 And &HFF&
    End If
End Function
Public Function PrototypeMember(ByVal SearchData As Long, _
    ByVal InvokeKinds As InvokeKinds, _
    Optional ByVal MemberName As String) As String
    'This helper function adapted from Microsoft documentation
    On Error GoTo exitFunction
    Dim tliParameterInfo As ParameterInfo
    Dim bFirstParameter As Boolean
    Dim bIsConstant As Boolean
    Dim bByVal As Boolean
    Dim strReturn As String
    Dim ConstVal As Variant
    Dim strTypeName As String
    Dim intVarTypeCur As Integer
    Dim bDefault As Boolean
    Dim bOptional As Boolean
    Dim bParamArray As Boolean
    Dim tliTypeInfo As TypeInfo
    Dim tliResolvedTypeInfo As TypeInfo
    Dim tliTypeKinds As TypeKinds

    With tliTypeLibInfo

        'First, determine the type of member we're dealing with
        bIsConstant = GetSearchType(SearchData) And tliStConstants
        With .GetMemberInfo(SearchData, InvokeKinds, , MemberName)
            Debug.Print "MemberID: 0x" & Hex(.MemberId - &H10000)
            If bIsConstant Then
                strReturn = "Const "
            ElseIf InvokeKinds = INVOKE_FUNC Or InvokeKinds = INVOKE_EVENTFUNC Then
                Select Case .ReturnType.VarType
                    Case VT_VOID, VT_HRESULT
                        strReturn = "Sub "
                    Case Else
                        strReturn = "Function "
                End Select
            Else
                strReturn = "Property "
            End If

            'Now add the name of the member
            strReturn = strReturn & .Name

            'Process the member's paramters
            With .Parameters
                If .count Then
                    strReturn = strReturn & " ("
                    bFirstParameter = True
                    bParamArray = .OptionalCount = -1
                    For Each tliParameterInfo In .Me
                        If Not bFirstParameter Then
                            strReturn = strReturn & ", "
                        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
                                strReturn = strReturn & "[ParamArray "
                            Else
                                strReturn = strReturn & "["
                            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
                                    strReturn = strReturn & "ByVal "
                                End If

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

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

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

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

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

                            If bOptional Then
                                If bDefault Then
                                    strReturn = strReturn & ProduceDefaultValue(tliParameterInfo.DefaultValue, tliResolvedTypeInfo)
                                    'strReturn = strReturn & " = " & tliParameterInfo.DefaultValue
                                End If
                                strReturn = strReturn & "]"
                            End If
                        End With
                    Next
                    strReturn = strReturn & ")"
                End If
            End With

            If bIsConstant Then
                ConstVal = .Value
                strReturn = strReturn & " = " & ConstVal
                Select Case VarType(ConstVal)
                    Case vbInteger, vbLong
                        If ConstVal < 0 Or ConstVal > 15 Then
                            strReturn = strReturn & " (&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
                                strReturn = strReturn & " As ?"
                            Else
                                If .IsExternalType Then
                                    strReturn = strReturn & " As " & .TypeLibInfoExternal.Name & "." & .TypeInfo.Name
                                Else
                                    strReturn = strReturn & " As " & .TypeInfo.Name
                                End If
                            End If
                        End If

                        If intVarTypeCur And (VT_ARRAY Or VT_VECTOR) Then
                            strReturn = strReturn & "()"
                        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
                                    strReturn = strReturn & "() As " & Left$(strTypeName, Len(strTypeName) - 2)
                                Else
                                    strReturn = strReturn & " As " & strTypeName
                                End If
                        End Select
                    End If
                End With
            End If

            PrototypeMember = strReturn & vbCrLf
            lblMemberOf = "Member of " & tliTypeLibInfo.Name & "." & tliTypeLibInfo.GetTypeInfo(SearchData And &HFFFF&).Name
            lblHelpText = .HelpString
        End With
    End With
exitFunction:
End Function
Public Function getNameFromMemberInfo(mi As MemberInfo) As String
    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
        '.VTableOffset
        sOutput = sOutput & "0x" & Hex(.VTableOffset) & ":"
        bIsConstant = GetSearchType(lSearchData) And tliStConstants
        If bIsConstant Then
            sOutput = sOutput & "Const "
        ElseIf mi.InvokeKind = INVOKE_FUNC Or mi.InvokeKind = INVOKE_EVENTFUNC Then
            Select Case .ReturnType.VarType
                Case VT_VOID, VT_HRESULT
                    sOutput = sOutput & "Sub "
                Case Else
                    sOutput = sOutput & "Function "
            End Select
        Else
            sOutput = sOutput & "Property "
        End If
        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