erwinspy_addin_form.frm

这个源程序用来读写ERWIN设计的ER1文件中的元数据信息

    nIdx = InStr(Key, "{")
    KeyToObjId = Mid(Key, nIdx)

End Function


Private Sub tvProperties_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Locate the node
    Dim oNode As ComctlLib.Node
    Set oNode = tvProperties.HitTest(x, y)
    If Not oNode Is Nothing Then
        ' We have a node
        tvProperties.ToolTipText = oNode.Key
    Else
        tvProperties.ToolTipText = ""
    End If
    
End Sub

Private Sub btProperties_Click()
    On Error GoTo OnErrors
    
    ' Check if we have a selection
    If Not tvObjects.SelectedItem Is Nothing Then
        ' Clear the property view
        ClearPropertyView
        
        ' Create a root
        Dim oSelObject As Node
        Set oSelObject = tvObjects.SelectedItem
        
        ' Select an object
        Dim oObject As SCAPI.ModelObject
        
        Set oObject = oSession.ModelObjects.Item(KeyToObjId(oSelObject.Key))
        If Not oObject Is Nothing Then
            Dim oRootNode As Node
            Set oRootNode = tvProperties.Nodes.Add(, , KeyToObjId(oObject.ClassId), _
                        "Properties of " + oSelObject.Text)
        
            ' Look in the object
            Dim oProperty As SCAPI.ModelProperty
            Dim oLastNode As Node
            Dim strFlags As String
            
            Set oLastNode = Nothing
            
            For Each oProperty In oObject.Properties
                ' This is for debug, to check if we have an item with such key
                On Error GoTo KeyError
                strFlags = PropertyFlags(oProperty)
            
                If (oLastNode Is Nothing) Then
                    ' This is the first child
                    Set oLastNode = tvProperties.Nodes.Add(oRootNode.Index, tvwChild, _
                           oProperty.ClassId, oProperty.ClassName + _
                           IIf(Len(strFlags) > 0, " { " + strFlags + " }", ""))
                    oLastNode.EnsureVisible
                Else
                    ' This is a next child
                    Set oLastNode = tvProperties.Nodes.Add(oLastNode.Index, tvwNext, _
                           oProperty.ClassId, oProperty.ClassName + _
                           IIf(Len(strFlags) > 0, " { " + strFlags + " }", ""))
                End If
                
                ' Populate values
                PopulateValues oProperty, oLastNode
                
                GoTo NextProp
KeyError:
                ' For Debug purposes, check if we have doubled key. Then ignore it
                If Err.Number <> 35602 Then GoTo OnErrors
                If mnExtraDebug.Checked Then
                    MsgBox "Object has more the one instance of property with name " + oProperty.ClassName
                End If
                Err.Clear
                Resume Next
NextProp:
            Next oProperty
        End If
    
    Else
        ClearPropertyView
        btProperties.Enabled = False
    End If
    Exit Sub
    
OnErrors:
    Me.MousePointer = vbDefault
    MsgBox "Failed to retrieve an object properties with error " + Err.Description
    ClearPropertyView
    

End Sub
' Retrieves property flags and value type. Aranges them as a string to display
Private Function PropertyFlags(oProperty As SCAPI.ModelProperty) As String
    On Error GoTo OnErrors
    
    Dim Flags As SCAPI.SC_ModelPropertyFlags
    
    Dim strDatatype(23) As String
    ' Populate it
    strDatatype(0) = "SCVT_NULL;": strDatatype(1) = "SCVT_I2;": strDatatype(2) = "SCVT_I4;"
    strDatatype(3) = "SCVT_UI1;": strDatatype(4) = "SCVT_R4;": strDatatype(5) = "SCVT_R8;"
    strDatatype(6) = "SCVT_BOOLEAN;": strDatatype(7) = "SCVT_CURRENCY;": strDatatype(8) = "SCVT_IUNKNOWN;"
    strDatatype(9) = "SCVT_IDISPATCH;": strDatatype(10) = "SCVT_DATE;": strDatatype(11) = "SCVT_BSTR;"
    strDatatype(12) = "SCVT_UI2;": strDatatype(13) = "SCVT_UI4;": strDatatype(14) = "SCVT_GUID;"
    strDatatype(15) = "SCVT_OBJID;": strDatatype(16) = "SCVT_BLOB;": strDatatype(17) = "SCVT_DEFAULT;"
    strDatatype(18) = "SCVT_I1;": strDatatype(19) = "SCVT_INT;": strDatatype(20) = "SCVT_UINT;"
    strDatatype(21) = "SCVT_RECT;": strDatatype(22) = "SCVT_POINT;"
    
    ' Retrieve flags
    Flags = oProperty.Flags
    
    ' Get the value type
    Dim eType As SCAPI.SC_ValueTypes
    
    eType = oProperty.DataType(0)
    
    PropertyFlags = strDatatype(eType)
    
    ' Parse the result
    
    ' 0 -  Property has a NULL value if set
    If Flags And SCD_MPF_NULL Then PropertyFlags = PropertyFlags + "Null;"
    ' 1 -  Property is user-defined if set
    If Flags And SCD_MPF_USER_DEFINED Then PropertyFlags = PropertyFlags + "User-Defined;"
    ' 2 -  Property is scalar if set
    If (Flags And SCD_MPF_SCALAR) = 0 Then PropertyFlags = PropertyFlags + "Vector;"
    ' 3 -  Property is maintained by the tool, if set
    If Flags And SCD_MPF_TOOL Then PropertyFlags = PropertyFlags + "Tool;"
    ' 4 -  Property is read-only if set
    If Flags And SCD_MPF_READ_ONLY Then PropertyFlags = PropertyFlags + "ReadOnly;"
    ' 5 -  Property has inherited/calculated/derived value if set
    If Flags And SCD_MPF_DERIVED Then PropertyFlags = PropertyFlags + "Derived;"
    ' 6 -  Property is optional and could be removed
    If Flags And SCD_MPF_OPTIONAL Then PropertyFlags = PropertyFlags + "Optional;"
    
    Exit Function
OnErrors:
    On Error Resume Next
    Dim strName As String
    strName = "<unknown>"
    strName = oProperty.ClassName
    MsgBox "Failed to collect flags for a property of " + strName + _
        " class with error " + Err.Description
    PropertyFlags = "<Error>"
End Function

' Populate a sub-tree for a specific property in Properties ListView
Private Sub PopulateValues(oProperty As SCAPI.ModelProperty, oNode As Node)

    On Error GoTo OnErrors
    ' WHat type of a property we have
    If oProperty.Flags And SCD_MPF_SCALAR Then
        ' SCalar value
        tvProperties.Nodes.Add oNode.Index, tvwChild, , RetrieveValue(oProperty, 0)
    Else
        ' Vector value
        Dim nCount As Long
        nCount = oProperty.Count
        
        Dim nIdx As Long
        Dim oLastNode As Node
        Set oLastNode = Nothing
        If nCount > 0 Then
            For nIdx = 0 To nCount - 1
                If oLastNode Is Nothing Then
                    Set oLastNode = tvProperties.Nodes.Add(oNode.Index, tvwChild, , _
                             RetrieveValue(oProperty, nIdx))
                Else
                    Set oLastNode = tvProperties.Nodes.Add(oLastNode.Index, tvwNext, , _
                             RetrieveValue(oProperty, nIdx))
                End If
            Next nIdx
        End If
    End If
        
    oNode.Expanded = False
        
    Exit Sub
OnErrors:
    On Error Resume Next
    Dim strName As String
    strName = "<unknown>"
    strName = oProperty.ClassName
    MsgBox "Failed to populate property " + strName + _
        " with error " + Err.Description
    If Not oNode Is Nothing Then
        tvProperties.Nodes.Add oNode.Index, tvwChild, , "<Error>"
    End If
    
End Sub

' Retrieve a property or a property element value
Private Function RetrieveValue(oProperty As SCAPI.ModelProperty, nIndex As Long) As String

    On Error GoTo OnErrors
    ' WHat type of a property we have
    Dim bScalar As Boolean
    bScalar = (oProperty.Flags And SCD_MPF_SCALAR)
        
   ' Retrieve value in native format
   
   ' We use SCAPI value types since they provide more precise info
   Dim eType As SCAPI.SC_ValueTypes
   Dim ArrayLong() As Long
   
   If bScalar Then
        ' SCalar value
        eType = oProperty.DataType
   Else
        ' Vector value
        eType = oProperty.DataType(nIndex)
   End If
   
   Dim strNative As String
   
   ' Parse the value.
   Select Case eType
   
    Case SCVT_I2, SCVT_I4, SCVT_UI1, SCVT_UI2, SCVT_UI4, SCVT_I1, SCVT_INT, SCVT_UINT
        ' This is all numeric
        If bScalar Then
            strNative = CStr(oProperty.Value)
        Else
            strNative = CStr(oProperty.Value(nIndex))
        End If
    Case SCVT_R4, SCVT_R8
        ' This is all float
        If bScalar Then
            strNative = CStr(oProperty.Value)
        Else
            strNative = CStr(oProperty.Value(nIndex))
        End If
    
    Case SCVT_BOOLEAN
        ' This is boolean
        If bScalar Then
            strNative = CStr(oProperty.Value)
        Else
            strNative = CStr(oProperty.Value(nIndex))
        End If
        
    Case SCVT_CURRENCY
        ' This is currency
        If bScalar Then
            strNative = CStr(oProperty.Value)
        Else
            strNative = CStr(oProperty.Value(nIndex))
        End If
        
    Case SCVT_DATE
        ' This is date
        If bScalar Then
            strNative = Format(oProperty.Value, "General Date")
        Else
            strNative = Format(oProperty.Value(nIndex), "General Date")
        End If
        
    Case SCVT_BSTR
        ' This is string
        If bScalar Then
            strNative = oProperty.Value
        Else
            strNative = oProperty.Value(nIndex)
        End If
        
    Case SCVT_GUID, SCVT_OBJID
        ' This is guid, objectid, class id
        If bScalar Then
            strNative = oProperty.Value
        Else
            strNative = oProperty.Value(nIndex)
        End If
        
    Case SCVT_BLOB
        ' This is unformated data
        strNative = "<blob>"
    
    Case SCVT_RECT
        ' This is a rectange
        If bScalar Then
            ArrayLong = oProperty.Value
        Else
            ArrayLong = oProperty.Value(nIndex)
        End If
        
        strNative = "(" + CStr(ArrayLong(0)) + "," + _
                        CStr(ArrayLong(1)) + "," + _
                        CStr(ArrayLong(2)) + "," + _
                        CStr(ArrayLong(3)) + ")"
    Case SCVT_POINT
        ' This is a rectange
        If bScalar Then
            ArrayLong = oProperty.Value
        Else
            ArrayLong = oProperty.Value(nIndex)
        End If
        
        strNative = "(" + CStr(ArrayLong(0)) + "," + _
                        CStr(ArrayLong(1)) + ")"
    Case Else
        ' error, format is not supported
        strNative = "<error: variant type - " + TypeName(Value) + " SCAPI type - " + Str(eType)
        
   End Select

    ' Retrieve value as a string
   Dim strValue As String
   If bScalar Then
        ' SCalar value
        strValue = oProperty.FormatAsString
   Else
        ' Vector value
        strValue = oProperty.Value(nIndex, SCVT_BSTR)
   End If

   RetrieveValue = strNative + " ( s= " + strValue + " )"
   
   Exit Function
OnErrors:
    On Error Resume Next
    Dim strName As String
    strName = "<unknown>"
    strName = oProperty.ClassName
    RetrieveValue = "Failed to populate property " + strName + _
        " with error " + Err.Description

End Function