Рекомендую для хранения и получения информации использовать SetXData и GetXData (Страница 1 из 2)

 'MyCADFaceContour ClassModule
Option Explicit
Public ACO As AcadLWPolyline
Public Enum EFaceContourType
    fcntUnknown = -1
    fcntOrdinary = 0
    fcntCook = 1
    fcntKoschei = 2
    fcntHunter = 3
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private mName As String
Private mCentre(0 To 2) As Double
Private mWidth As Double
Private mScaleWidth As Double
Private mHeight As Double
Private mScaleHeight As Double
Private mAngle As Double
Private mColor As acColor
Private mFaceContourType As EFaceContourType
Private mCheekHeight As Double
Private mChinWidth As Double
Private mCrownBulge As Double
Private mCheekBoneBulge As Double
Private mCheekBulge As Double
Private mChinBulge As Double
'''
Private Const mcWidth As Double = 1
Private Const mcScaleWidth As Double = 1
Private Const mcHeight As Double = 1
Private Const mcScaleHeight As Double = 1
Private Const mcAngle As Double = 0
Private Const mcColor As Integer = 2
Private Const mcFaceContourType As Integer = 0
Private mTag As String
Private mValid As Boolean
Private mLength As Double
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get Name() As String
    Name = mName
End Property
Public Property Let Name(vNewName As String)
    mName = vNewName
    'Это слишком просто!!!
    'На самом деле здесь должен быть код обеспечивающий
    'доступ к этому объекту по имени.
End Property
Public Function Init(vLWP As AcadLWPolyline) As Boolean
Dim pErrDescr As String
    Set ACO = vLWP
    GetMyXData pErrDescr
    Init = pErrDescr = ""
End Function
'*****************************************************************************
'****   Запись данных в Автокад
'*****************************************************************************
Public Function SetMyXData(Optional ClearData As Boolean = False) As Boolean
Dim pT() As Integer
Dim pD() As Variant
Dim i As Long, ii As Long
Dim pColD As New Collection
Dim pZeroPoint(2) As Double
    If ClearData Then
        ReDim pT(0)
        ReDim pD(0)
        pT(0) = 1001: pD(0) = "MyCAD"
    Else
        pColD.Add "MyCAD"
        pColD.Add TypeName(Me)
        pColD.Add Name
        If Distance3D(mCentre, pZeroPoint) <> 0 Then pColD.Add _
            "Centre=" & CStr(mCentre(0)) & " " & CStr(mCentre(1)) & " " & CStr(mCentre(2))
        If mWidth <> mcWidth Then pColD.Add _
            "Width=" & CStr(mWidth)
        If mScaleWidth <> mcScaleWidth Then pColD.Add _
            "ScaleWidth=" & CStr(mScaleWidth)
        If mHeight <> mcHeight Then pColD.Add _
            "Height=" & CStr(mHeight)
        If mScaleHeight <> mcScaleHeight Then pColD.Add _
            "ScaleHeight=" & CStr(mScaleHeight)
        If mAngle <> mcAngle Then pColD.Add _
            "Angle=" & CStr(mAngle)
        If mColor <> mcColor Then pColD.Add _
            "Color=" & CStr(mColor)
        If mFaceContourType <> mcFaceContourType Then pColD.Add _
            "FaceContourType=" & CStr(mFaceContourType)
        '''
        ii = pColD.Count - 1
        ReDim pT(0 To ii)
        ReDim pD(0 To ii)
        For i = 0 To ii
            pT(i) = 1000
            pD(i) = pColD.Item(i + 1)
        Next i
        pT(0) = 1001
    End If
    On Error Resume Next
        ACO.SetXData pT, pD
    If Err Then Err.Clear Else SetMyXData = True
End Function
'*****************************************************************************
'****   Чтение данных из Автокада '*****************************************************************************
Public Function GetMyXData(Optional vErrDescr As String) As Boolean
Dim s As String, vLen As Double
Dim pT As Variant, pD As Variant, pV As Variant
Dim pMaxInd As Long, i As Long
Dim psH As String, psT As String
    vErrDescr = ""
    mValid = False
    ACO.GetXData "MyCAD", pT, pD
    If IsArray(pD) Then
        pMaxInd = UBound(pD)
        If pMaxInd >= 2 And TypeName(Me) = pD(1) Then
            mName = pD(2)
            For i = 3 To pMaxInd
                psH = HeadTailStr(pD(i), "=", psT)
                Select Case psH
                Case "Centre"
                    pV = Strings.Split(psT, " ")
                    mCentre(0) = CDbl(pV(0))
                    mCentre(1) = CDbl(pV(1))
                    mCentre(2) = CDbl(pV(2))
                Case "Width":           mWidth = CDbl(psT)
                Case "ScaleWidth":      mScaleWidth = CDbl(psT)
                Case "Height":          mHeight = CDbl(psT)
                Case "ScaleHeight":     mScaleHeight = CDbl(psT)
                Case "Angle":           mAngle = CDbl(psT)
                Case "Color":           mColor = CInt(psT)
                Case "FaceContourType": mFaceContourType = CInt(psT)
                End Select
            Next i
            mValid = True
        Else
            vErrDescr = "Error XData or it is not " & TypeName(Me)
        End If
    Else
        vErrDescr = "Error XData"
    End If
    GetMyXData = vErrDescr = ""
End Function
Public Function IsGood(Optional vErrDescr As String) As Boolean
    Me.GetMyXData vErrDescr
    IsGood = vErrDescr = ""
End Function
Private Sub Class_Initialize()
    mWidth = mcWidth
    mScaleWidth = mcScaleWidth
    mHeight = mcHeight
    mScaleHeight = mcScaleHeight
    mAngle = mcAngle
    mColor = mcColor
    mFaceContourType = mcFaceContourType
    mCheekHeight = 0.5
    mChinWidth = 0.2
    mCrownBulge = 1
    mCheekBoneBulge = 0.1
    mCheekBulge = 0.3
    mChinBulge = 0.2
End Sub
Public Sub CreateMe(vBlock As AcadBlock, vName As String, Optional ByVal vCenter, _
        Optional ByVal vScaleWidth As Double, Optional ByVal vScaleHeight As Double, _
        Optional ByVal vFaceContourType As EFaceContourType)
Dim pAV(0 To 5, 0 To 4) As Double
    mName = vName
    If Not IsMissing(vCenter) Then mCentre(0) = vCenter(0): mCentre(1) = vCenter(1): mCentre(2) = vCenter(2)
    If Not IsMissing(vScaleWidth) Then mScaleWidth = vScaleWidth
    If Not IsMissing(vScaleHeight) Then mScaleHeight = vScaleHeight
    If Not IsMissing(vFaceContourType) Then mFaceContourType = vFaceContourType
    Select Case mFaceContourType
    Case fcntCook: mCheekHeight = 0.7: mCrownBulge = 0.4: mCheekBulge = 1
    Case fcntHunter: mCheekHeight = 0.4: mCrownBulge = 0.6: mCheekBulge = 0.15: mChinWidth = 0.4
    Case fcntKoschei: mCheekHeight = 0.6: mCrownBulge = 1: mCheekBulge = -0.05
    End Select
    '''
    pAV(0, 0) = mCentre(0) - mWidth * mScaleWidth / 2
    pAV(0, 1) = mCentre(1) + mHeight * mScaleHeight
    pAV(0, 4) = mCheekBoneBulge
    pAV(1, 0) = pAV(0, 0)
    pAV(1, 1) = mCentre(1) + mCheekHeight * mScaleHeight
    pAV(1, 4) = mCheekBulge
    pAV(2, 0) = mCentre(0) - mChinWidth * mScaleWidth / 2
    pAV(2, 1) = mCentre(1)
    pAV(2, 4) = mChinBulge
    pAV(3, 0) = mCentre(0) + mChinWidth * mScaleWidth / 2
    pAV(3, 1) = pAV(2, 1)
    pAV(3, 4) = mCheekBulge
    pAV(4, 0) = mCentre(0) + mWidth * mScaleWidth / 2
    pAV(4, 1) = pAV(1, 1)
    pAV(4, 4) = mCheekBoneBulge
    pAV(5, 0) = pAV(4, 0)
    pAV(5, 1) = pAV(0, 1)
    pAV(5, 4) = mCrownBulge
    If Not ACO Is Nothing Then ACO.Delete
    Set ACO = Create.LWPolyFromAV(vBlock, pAV)
    ACO.Closed = True
    ACO.Color = mColor
    SetMyXData
End Sub 

Function Distance3D(t0 As Variant, t1 As Variant) As Double
    Distance3D = Sqr((t1(0) - t0(0)) ^ 2 + (t1(1) - t0(1)) ^ 2 + (t1(2) - t0(2)) ^ 2)
End Function
Public Function HeadTailStr( _
        ByVal InpStr As String, CtrlStr As String, _
        Optional TailStr As String) As String
Dim p1 As Long, p2 As Long, pL As Long
    If InpStr = "" Or CtrlStr = "" Then
        HeadTailStr = ""
        Exit Function
    End If
    pL = Strings.Len(CtrlStr)
    p1 = Strings.InStr(1, InpStr, CtrlStr, vbBinaryCompare)
    If p1 = 0 Then
        TailStr = ""
        HeadTailStr = InpStr
    Else
        TailStr = Strings.Right(InpStr, Strings.Len(InpStr) - p1 - pL + 1)
        HeadTailStr = Strings.Left(InpStr, p1 - 1)
    End If
End Function

 Sub aa()
Dim pNM As New MyCadMouth, pOM As MyCadMouth
Dim pNFC As New MyCADFaceContour, pOFC As MyCADFaceContour
Dim pC(2) As Double
Dim pACD As AcadDocument
Dim pObj As Object
    On Error Resume Next
    Set pACD = ThisDrawing
    For Each pObj In ColAA
        pObj.ACO.Delete
    Next pObj
    Set ColAA = Nothing
    If Err Then Err.Clear
    '''
    pC(0) = 0: pC(1) = 0
    pNFC.CreateMe pACD.ModelSpace, "CookFaceContour", pC, 120, 150, fcntCook
    ColAA.Add pNFC, pNFC.Name
    Set pNFC = Nothing
    pC(0) = 0: pC(1) = 50
    pNM.CreateMe pACD.ModelSpace, "CookMouth", pC, 60, "Glad"
    ColAA.Add pNM, pNM.Name
    Set pNM = Nothing
    '''
    pC(0) = 200: pC(1) = 0
    pNFC.CreateMe pACD.ModelSpace, "HunterFaceContour", pC, 120, 150, fcntHunter
    ColAA.Add pNFC, pNFC.Name
    Set pNFC = Nothing
    pC(0) = 200: pC(1) = 50
    pNM.CreateMe pACD.ModelSpace, "HunterMouth", pC, 60
    ColAA.Add pNM, pNM.Name
    Set pNM = Nothing
    '''
    pC(0) = 400: pC(1) = 0
    pNFC.CreateMe pACD.ModelSpace, "KoscheiFaceContour", pC, 120, 150, fcntKoschei
    ColAA.Add pNFC, pNFC.Name
    Set pNFC = Nothing
    pC(0) = 400: pC(1) = 50
    pNM.CreateMe pACD.ModelSpace, "KoscheiMouth", pC, 50, "Angry"
    ColAA.Add pNM, pNM.Name
    Set pNM = Nothing
    '''
End Sub
Sub aaa()
Dim pE As AcadEntity, pObj As Object
Dim pNM As New MyCadMouth, pOM As MyCadMouth
Dim pNFC As New MyCADFaceContour, pOFC As MyCADFaceContour
Dim pACD As AcadDocument
    Set ColAA = Nothing
    Set pACD = ThisDrawing
    For Each pE In pACD.ModelSpace
        Select Case XTypeName("MyCAD", pE)
        Case "MyCadMouth"
            If pNM.Init(pE) Then
                ColAA.Add pNM, pNM.Name
                Set pNM = Nothing
            End If
        Case "MyCADFaceContour"
            If pNFC.Init(pE) Then
                ColAA.Add pNFC, pNFC.Name
                Set pNFC = Nothing
            End If
        Case Else
        End Select
    Next pE
    PrintMessage vbCrLf & vbCrLf & "В чертеже есть:"
    For Each pObj In ColAA
        PrintMessage vbCrLf & "    >" & pObj.Name
    Next pObj
    PrintMessage vbCrLf & "Конец инициализации." & vbCrLf
End Sub