erwinspy_addin_form.frm

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

            oSession.Close
        End If
        oApplication.Sessions.Clear
        
        ' Check if we have a window selected previously
        Dim nIdx As Integer
        For nIdx = 1 To mnModelsArray.Count - 1
            If mnModelsArray(nIdx).Checked Then
                ' Have it unchecked
                mnModelsArray(nIdx).Checked = False
            End If
        Next
        
        ' Reset UI
        ClearViews
        btProperties.Enabled = False
        
        ' Open a new session
        On Error Resume Next
        
        Set oSession = oApplication.Sessions.Add
        If oSession Is Nothing Then
            MsgBox "Failed to create a session. An error is " + Err.Description
            Exit Sub
        End If
        
        ' Attache to persistence unit. If the INdex is bigger then number of
        ' units, then we are looking for meta data
        Dim eLevel As SCAPI.SC_SessionLevel
        eLevel = SCD_SL_M0          ' Native data
        If Index <= oApplication.PersistenceUnits.Count Then
            ' This is native data level
            nIdx = Index - 1
        Else
            ' This is meta data level
            nIdx = Index - oApplication.PersistenceUnits.Count - 3
            eLevel = SCD_SL_M1
        End If
        
        Dim oUnit As SCAPI.PersistenceUnit
        If nIdx >= 0 Then
            Set oUnit = oApplication.PersistenceUnits(nIdx)
        Else
            Set oUnit = Nothing
        End If
        
        If Not oSession.Open(oUnit, eLevel) Then
            MsgBox "Failed to open a session An error is " + Err.Description
            oApplication.Sessions.Clear
            Exit Sub
        End If
        
        ' Have the open session checked
        mnModelsArray(Index).Checked = True
        
        ' Enable close open model item
        mnClose.Enabled = True
        
        ' Prepare a tree
        PrepareObjectTree
    
    End If
End Sub
' Close the open model
Private Sub mnClose_Click()

    ' Check if have a model to close
    Dim RootNode As Node
    
    If tvObjects.Nodes.Count > 0 Then
        Set RootNode = tvObjects.Nodes.Item(1)
        ' Release the session
        oSession.Close
        Set oSession = Nothing
        ' Remove the unit from available
        oApplication.PersistenceUnits.Remove KeyToObjId(RootNode.Key)
    End If

    PopulateModels
    
    ClearViews
End Sub

Private Sub ClearViews()
    ' Reset the properties listbox
    ClearPropertyView
    
    ' reset the model tree
    ClearObjectView
    
    ' Disable close open model item
    mnClose.Enabled = False

End Sub

Private Sub ClearObjectView()
    ' reset the model tree
    tvObjects.Visible = False
    With tvObjects.Nodes
        For i = 1 To tvObjects.Nodes.Count
            tvObjects.Nodes.Remove tvObjects.Nodes.Count
        Next i
    End With
    tvObjects.Visible = True
    
End Sub
Private Sub ClearPropertyView()
    ' Reset the properties listbox
    tvProperties.Visible = False
    With tvProperties.Nodes
        For i = 1 To tvProperties.Nodes.Count
            tvProperties.Nodes.Remove tvProperties.Nodes.Count
        Next i
    End With
    tvProperties.Visible = True
    
End Sub



' Forms a repository root object
' Assumes a session is open

Private Sub PrepareObjectTree()
On Error GoTo OnError

    ' Reset the control
    ClearObjectView
    
    ' Get the root object
    Dim oRoot As SCAPI.ModelObject
    
    Set oRoot = oSession.ModelObjects.Root
    If Not (oRoot Is Nothing) Then
        ' Form a root
        Dim ItemKey As String
        Dim strFlags As String
        
        ' Build a key. Prefix an object id with a number to make it unique
        ' in case if the view will have another instance of the same object
        ItemKey = "R0 " + oRoot.ObjectId
        strFlags = ObjectFlags(oRoot)
        
        tvObjects.Nodes.Add , , ItemKey, _
                    oRoot.Name + " (" + oRoot.ClassName + ")" + _
                    IIf(Len(strFlags) > 0, " { " + strFlags + " }", "")
                    
        
    End If
    Exit Sub
    
OnError:
    MsgBox "Failed to init the tree view due to " + Err.Description

End Sub

' Populate a tree view with children of the selected object
Private Sub tvObjects_DblClick()
    On Error GoTo OnErrors
    Dim bObjectFailed As Boolean
    
    ' Check if the selected has children
    If (tvObjects.SelectedItem.Children = 0) Then
        ' Try to expand
        Dim oSelectedCollection As SCAPI.ModelObjects
        Dim oLastNode As Node
        
        Me.MousePointer = vbHourglass
        
        Set oLastNode = Nothing
        
        ' Create a subcollection with the selected object as a root
        Set oSelectedCollection = oSession.ModelObjects.Collect(KeyToObjId(tvObjects.SelectedItem.Key), , 1)
        If (Not (oSelectedCollection Is Nothing)) Then
            ' Iterate through
            Dim oObject As SCAPI.ModelObject
            Dim ItemKey As String
            Dim strFlags As String
            
            For Each oObject In oSelectedCollection
                ' Test if an object is valid
                bObjectFailed = False
                If oObject.IsValid Then
                    If bObjectFailed Then GoTo next_object
                    ' Collect flags
                    strFlags = ObjectFlags(oObject)
                    
                    If (oLastNode Is Nothing) Then
                        ' This is the first child
                        
                        ' Build a key. Prefix an object id with a number to make it unique
                        ' in case if the view will have another instance of the same object
                        ItemKey = "C" + Str(tvObjects.SelectedItem.Index + 1) + " " + oObject.ObjectId
                        Set oLastNode = tvObjects.Nodes.Add(tvObjects.SelectedItem.Index, tvwChild, _
                                                                ItemKey, oObject.Name + " (" + oObject.ClassName + " )" + _
                                    IIf(Len(strFlags) > 0, " { " + strFlags + " }", ""))
                        oLastNode.EnsureVisible
                    Else
                        ' This is a next child
                        
                        ' Build a key. Prefix an object id with a number to make it unique
                        ' in case if the view will have another instance of the same object
                        ItemKey = "S" + Str(oLastNode.Index + 1) + " " + oObject.ObjectId
                        Set oLastNode = tvObjects.Nodes.Add(oLastNode.Index, tvwNext, _
                                                                  ItemKey, oObject.Name + " (" + oObject.ClassName + " )" + _
                                    IIf(Len(strFlags) > 0, " { " + strFlags + " }", ""))
                                                                  
                    End If
                Else
                    If mnExtraDebug.Checked Then
                        MsgBox "An object with id: " + oObject.ObjectId + " is not available'"
                    End If
                End If
                    
next_object:
            Next oObject
            
        End If
        
        If (oLastNode Is Nothing) Then Beep
    
        Me.MousePointer = vbDefault
        
    Else
        ' Inverse the status
        tvObjects.SelectedItem.Expanded = tvObjects.SelectedItem.Children And (Not tvObjects.SelectedItem.Child.Visible)
    
    End If
    
    
    Exit Sub

OnErrors:
    If Err.Number = SCAPI.SCAPI_ERWIN_NOOBJECT Then         ' Object was not found
        bObjectFailed = True
        If mnExtraDebug.Checked Then
            MsgBox Err.Description
        End If
        Err.Clear
        Resume Next
    End If
        
    Me.MousePointer = vbDefault
    MsgBox "Failed to retrieve an object with error " + Err.Description
    
End Sub
' Retrieves object flags. Aranges them as a string to display
Private Function ObjectFlags(oObject As SCAPI.ModelObject) As String
    On Error GoTo OnErrors
    
    Dim Flags As SCAPI.SC_ModelObjectFlags
    
    ' Retrieve flags
    Flags = oObject.Flags
    
    ' Parse the result
    If Flags = SCD_MOF_DONT_CARE Then
        ObjectFlags = ""
    Else
        
        ' 0 -  Object is a persistence unit if set
        If Flags And SCD_MOF_PERSISTENCE_UNIT Then ObjectFlags = ObjectFlags + "Persistence Unit;"
        ' 1 -  Object is user-defined if set
        If Flags And SCD_MOF_USER_DEFINED Then ObjectFlags = ObjectFlags + "User-Defined;"
        ' 2 -  Object is root if set
        If Flags And SCD_MOF_ROOT = 0 Then ObjectFlags = ObjectFlags + "Root;"
        ' 3 -  Object is maintained by the tool if set
        If Flags And SCD_MOF_TOOL Then ObjectFlags = ObjectFlags + "Tool;"
        ' 4 -  Object is the default if set
        If Flags And SCD_MOF_DEFAULT Then ObjectFlags = ObjectFlags + "Default;"
        ' 5 -  Object has been changed in the transaction and has not saved
        If Flags And SCD_MOF_TRANSACTION Then ObjectFlags = ObjectFlags + "Modified;"
        
    End If
    
    Exit Function
OnErrors:
    On Error Resume Next
    Dim strName As String
    strName = "<unknown>"
    strName = oObject.ClassName
    MsgBox "Failed to collect flags for an object of " + strName + _
        " class with error " + Err.Description
    ObjectFlags = "<Error>"
End Function

Private Sub tvObjects_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    ' Clear properties area
    ClearPropertyView
    
    ' Save state of the mouse buttons
    
    btMouseLeft = False
    If (Button And vbLeftButton) Then btMouseLeft = True
    
End Sub

Private Sub tvObjects_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Locate the node
    Dim oNode As ComctlLib.Node
    Set oNode = tvObjects.HitTest(x, y)
    If Not oNode Is Nothing Then
        ' We have a node. Extract an id
        tvObjects.ToolTipText = KeyToObjId(oNode.Key)
    Else
        tvObjects.ToolTipText = "Double click to expand"
    End If
    
End Sub

Private Sub tvObjects_NodeClick(ByVal Node As ComctlLib.Node)

    ' Make properties available
    btProperties.Enabled = True
    
    ' Locate the help
    If Not Node Is Nothing Then
        On Error Resume Next
        
        Dim oObject As SCAPI.ModelObject
        
        Set oObject = oSession.ModelObjects.Item(KeyToObjId(Node.Key))
        
    End If
    
End Sub


Private Function KeyToObjId(Key As String) As String

' Key include prefix to make it unique in case if an object exists more then
' once in the object view

    Dim nIdx As Long