?? modcom.bas
字號(hào):
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
getNameFromMemberInfo = sOutput
End Function
Public Function ProduceDefaultValue(DefVal As Variant, ByVal tliTypeInfo As TypeInfo) As String
'This helper function adapted from Microsoft documentation
Dim lngTrackVal As Long
Dim mi As MemberInfo
Dim tliTypeKinds As TypeKinds
If tliTypeInfo Is Nothing Then
Select Case VarType(DefVal)
Case vbString
If Len(DefVal) Then
ProduceDefaultValue = """" & DefVal & """"
End If
Case vbBoolean 'Always show for Boolean
ProduceDefaultValue = DefVal
Case vbDate
If DefVal Then
ProduceDefaultValue = "#" & DefVal & "#"
End If
Case Else 'Numeric Values
If DefVal <> 0 Then
ProduceDefaultValue = DefVal
End If
End Select
Else
'Resolve constants to their enums
tliTypeKinds = tliTypeInfo.TypeKind
Do While tliTypeKinds = TKIND_ALIAS
tliTypeKinds = TKIND_MAX
On Error Resume Next
Set tliTypeInfo = tliTypeInfo.ResolvedType
If Err = 0 Then
tliTypeKinds = tliTypeInfo.TypeKind
End If
On Error GoTo 0
Loop
If tliTypeInfo.TypeKind = TKIND_ENUM Then
lngTrackVal = DefVal
For Each mi In tliTypeInfo.Members
If mi.Value = lngTrackVal Then
ProduceDefaultValue = " = " & mi.Name
Exit For
End If
Next
End If
End If
End Function
Public Function getFunctionsFromFile(sFileName As String) As String
'*****************************
'Purpose: Get all functions from a COM 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 bIsConstant As Boolean
Dim strReturn As String
Dim p As Long, m As Long, t As Long
Dim bFirstParameter As Boolean
Dim bParamArray As Boolean
Dim tliParameterInfo As ParameterInfo
Dim bDefault As Boolean
Dim bOptional As Boolean
Dim tliTypeInfo As TypeInfo
Dim tliResolvedTypeInfo As TypeInfo
Dim tliTypeKinds As TypeKinds
Dim intVarTypeCur As Integer
Dim bByVal As Boolean
Dim strTypeName As String
Dim ConstVal As Variant
'txtEntityPrototype = PrototypeMember(lstTypeInfos.ItemData(lstTypeInfos.ListIndex), tliInvokeKinds, lstMembers.[_Default])
frmMain.txtFunctions.Text = ""
With tliTypeLibInfo
.ContainingFile = sFileName
Set srT = .GetTypes(, tliStAll, False)
For t = 1 To srT.count
lSearchData = srT(t).SearchData
frmMain.txtFunctions.Text = frmMain.txtFunctions.Text & "'==================== " & srT(t).Name & "====================" & vbCrLf & vbCrLf
Set srM = tliTypeLibInfo.GetMembers(lSearchData)
For m = 1 To srM.count
'Text1.Text = Text1.Text & "guid:" & srM(m).Guid & vbCrLf
DoEvents
Set mi = tliTypeLibInfo.GetMemberInfo(lSearchData, srM(m).InvokeKinds, srM(m).MemberId, srM(m).Name)
frmMain.txtFunctions.Text = frmMain.txtFunctions.Text & getNameFromMemberInfo(mi) & vbCrLf
Next m
Next t
End With
MsgBox "all done"
End Function
Public Function ReturnGuiOpcode(ByVal SearchData As Long, _
ByVal InvokeKinds As InvokeKinds, _
Optional ByVal MemberName As String) As Integer
'*****************************
'Purpose: To return the opcode of a property used in form decompiling
'*****************************
On Error GoTo exitFunction
Dim tliTypeInfo As TypeInfo
Dim num As Integer
With tliTypeLibInfo
With .GetMemberInfo(SearchData, InvokeKinds, , MemberName)
'Debug.Print "MemberID: 0x" & Hex(.MemberId - &H10000)
num = (.MemberId - 65536)
End With
End With
If num > 255 Then
num = -1
End If
ReturnGuiOpcode = num
Exit Function
exitFunction:
ReturnGuiOpcode = -1
Exit Function
End Function
Public Function ReturnDataType(ByVal SearchData As Long, _
ByVal InvokeKinds As InvokeKinds, _
Optional ByVal MemberName As String) As String
'*****************************
'Purpose: To return the data type of a property
'*****************************
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)
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 & .TypeLibInfoExternal.Name & "." & .TypeInfo.Name
Else
strReturn = strReturn & .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 & strTypeName
End If
End Select
End If
End With
End If
ReturnDataType = strReturn & vbCrLf
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號(hào)
Ctrl + =
減小字號(hào)
Ctrl + -