CAD

开发平台：
VBA

CDocument.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private m_Entitys As New Collection
Private m_oApp As AcadApplication
Private WithEvents m_oDoc As AcadDocument
Attribute m_oDoc.VB_VarHelpID = -1
Private m_sName As String
Private m_Owner As TlsReactor
Private m_dhWnd As Long
Public Property Let Owner(ByVal vNewValue As TlsReactor)
On Error Resume Next
    Set m_Owner = vNewValue
End Property
Public Property Let Application(ByVal vNewValue As AcadApplication)
On Error Resume Next
    Set m_oApp = vNewValue
    Set m_oDoc = m_oApp.ActiveDocument
    m_dhWnd = m_oDoc.hwnd
End Property
Public Property Let Name(ByVal vNewValue As String)
    m_sName = vNewValue
End Property
Public Sub Add(ByVal Entity As AcadObject, ByVal Value)
On Error Resume Next
    Dim oEnt As New CEntity
    oEnt.Entity = Entity
    oEnt.Value = Value
    oEnt.Owner = m_Owner
    m_Entitys.Add oEnt, "CEntity" & Entity.ObjectID
End Sub
Public Sub LoadData()
On Error Resume Next
    Dim Entity As AcadObject
    Dim Infos
    Dim oEnt As CEntity
    Infos = GetXRecord("TlsReactor", m_sName)
    For Each i In Infos
        Err.Clear
        Set Entity = m_oDoc.HandleToObject(LeftStr(i, ","))
        If Not Err And i <> "" Then
            Set oEnt = New CEntity
            oEnt.Owner = m_Owner
            oEnt.EntityInfo = i
            m_Entitys.Add oEnt, "CEntity" & Entity.ObjectID
        End If
    Next i
End Sub
Public Sub SaveData()
On Error Resume Next
    Dim Infos As New Collection
    Dim Info As String
    For Each i In m_Entitys
        Info = i.EntityInfo
        If Info <> "" Then Infos.Add Info
    Next i
    SetXRecord "TlsReactor", m_sName, Col2Arr(Infos)
End Sub
Private Function Col2Arr(ByVal Values As Collection)
On Error Resume Next
    Dim arr()
    ReDim arr(Values.Count - 1)
    For i = 0 To Values.Count - 1
        arr(i) = Values(i + 1)
    Next i
    Col2Arr = arr
End Function
Private Function SetXRecord(ByVal DictName As String, ByVal Keyword As String, ByVal XRecordData)
On Error Resume Next
    Dim pDict As AcadDictionary
    Dim pXRecord As AcadXRecord
    Dim XRecordType() As Integer
    Dim pLen As Integer
    Set pDict = m_oDoc.Dictionaries.Add(DictName)
    Set pXRecord = pDict.AddXRecord(Keyword)
    pLen = UBound(XRecordData)
    ReDim XRecordType(pLen) As Integer
    For i = 0 To pLen
        Select Case VarType(XRecordData(i))
            Case vbInteger, vbLong
                XRecordType(i) = 70
            Case vbSingle, vbDouble
                XRecordType(i) = 40
            Case vbString
                XRecordType(i) = 1
        End Select
    Next i
    pXRecord.SetXRecordData XRecordType, XRecordData
End Function
Private Function GetXRecord(ByVal DictName As String, ByVal Keyword As String)
On Error Resume Next
    Dim pDict As AcadDictionary
    Dim pXRecord As AcadXRecord
    Dim xt
    Set pDict = m_oDoc.Dictionaries(DictName)
    Set pXRecord = pDict.GetObject(Keyword)
    pXRecord.GetXRecordData xt, GetXRecord
End Function
Private Function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
    LeftStr = Left(String1, InStr(String1, String2) - 1)
    If InStr(String1, String2) = 0 Then LeftStr = String1
End Function
Private Sub m_oDoc_BeginClose()
On Error Resume Next
    Set m_Entitys = Nothing
    m_Owner.RemoveDoc m_dhWnd
End Sub
Private Sub m_oDoc_BeginDoubleClick(ByVal PickPoint As Variant)
On Error Resume Next
    Dim ss As New TlsSelectionSet
    Dim oEnt As CEntity
    ss.Application = m_oApp
    ss.GetPickfirstSelectionSet
    If ss.Count = m_Owner.SelCount Then
        Err.Clear
        Set oEnt = m_Entitys("CEntity" & ss(0).ObjectID)
        If Err.Number = 0 Then
            m_Owner.Change 1, oEnt.Entity, oEnt.Value
            m_Owner.Owner.DoubleClick True
            Exit Sub
        End If
    End If
    m_Owner.Owner.DoubleClick False
End Sub
Private Sub m_oDoc_ObjectErased(ByVal ObjectID As Long)
On Error Resume Next
    Dim oEnt As CEntity
    Set oEnt = m_Entitys("CEntity" & ObjectID)
    If Err.Number = 0 Then
        m_Owner.Change 2, , oEnt.Value
    End If
End Sub

						