CAD

开发平台：
VBA

UserControl1.ctl：源码内容
							VERSION 5.00
Begin VB.UserControl UserControl1 
   ClientHeight    =   3420
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2535
   ScaleHeight     =   3420
   ScaleWidth      =   2535
   Begin VB.CommandButton Command1 
      Height          =   300
      Left            =   2115
      Picture         =   "UserControl1.ctx":0000
      Style           =   1  'Graphical
      TabIndex        =   15
      Top             =   120
      Width           =   300
   End
   Begin VB.Frame Frame2 
      Caption         =   "属性数据"
      Height          =   975
      Left            =   120
      TabIndex        =   9
      Top             =   2280
      Width           =   2295
      Begin VB.TextBox Text6 
         Height          =   300
         Left            =   1080
         TabIndex        =   11
         Top             =   600
         Width           =   1095
      End
      Begin VB.TextBox Text5 
         Height          =   300
         Left            =   1080
         TabIndex        =   10
         Top             =   240
         Width           =   1095
      End
      Begin VB.Label Label6 
         Caption         =   "地址:"
         Height          =   200
         Left            =   120
         TabIndex        =   13
         Top             =   650
         Width           =   735
      End
      Begin VB.Label Label5 
         Caption         =   "编号:"
         Height          =   200
         Left            =   120
         TabIndex        =   12
         Top             =   290
         Width           =   735
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "图形数据"
      Height          =   1695
      Left            =   120
      TabIndex        =   0
      Top             =   480
      Width           =   2295
      Begin VB.TextBox Text4 
         Height          =   300
         Left            =   1080
         TabIndex        =   8
         Top             =   1320
         Width           =   1095
      End
      Begin VB.TextBox Text1 
         Height          =   300
         Left            =   1080
         TabIndex        =   5
         Top             =   240
         Width           =   1095
      End
      Begin VB.TextBox Text3 
         Height          =   300
         Left            =   1080
         TabIndex        =   4
         Top             =   960
         Width           =   1095
      End
      Begin VB.TextBox Text2 
         Height          =   300
         Left            =   1080
         TabIndex        =   3
         Top             =   600
         Width           =   1095
      End
      Begin VB.Label Label4 
         Caption         =   "半径(&R):"
         Height          =   195
         Left            =   120
         TabIndex        =   7
         Top             =   1365
         Width           =   735
      End
      Begin VB.Label Label1 
         Caption         =   "X(&X)坐标:"
         Height          =   200
         Left            =   120
         TabIndex        =   6
         Top             =   290
         Width           =   735
      End
      Begin VB.Label Label3 
         Caption         =   "Z(&Z)坐标:"
         Height          =   200
         Left            =   120
         TabIndex        =   2
         Top             =   1010
         Width           =   735
      End
      Begin VB.Label Label2 
         Caption         =   "Y(&Y)坐标:"
         Height          =   200
         Left            =   120
         TabIndex        =   1
         Top             =   650
         Width           =   735
      End
   End
   Begin VB.Label Label7 
      Caption         =   "选择对象(&O):"
      Height          =   195
      Left            =   120
      TabIndex        =   14
      Top             =   173
      Width           =   735
   End
End
Attribute VB_Name = "UserControl1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Dim dockContainer As AcadDockableContainer
Implements IRetrieveDockableContainer
Dim AcadApp As Object
Dim EntObj As Object
Private Sub Command1_Click()
    Dim pPt As Variant
    Dim xdt As Variant
    Dim xdv As Variant
    
    On Error GoTo ErrTrap
    ' 选择对象
    AcadApp.ActiveDocument.Utility.GetEntity EntObj, pPt
    ' 判断对象的类型是否是圆
    If StrComp(EntObj.objectname, "AcDbCircle", vbTextCompare) = 0 Then
        ' 返回圆心
        pPt = EntObj.Center
        Text1.Text = Round(pPt(0), 4)
        Text2.Text = Round(pPt(1), 4)
        Text3.Text = Round(pPt(2), 4)
        ' 返回半径
        Text4.Text = Round(EntObj.Radius, 4)
        Text5.Text = ""
        Text6.Text = ""
        ' 返回扩展数据
        EntObj.GetXData "电杆", xdt, xdv
        If UBound(xdt) = 2 Then
            Text5.Text = xdv(1)
            Text6.Text = xdv(2)
        End If
    End If
    Exit Sub
ErrTrap:
    ' 没有选中对象时，ACAD在系统变量ERRNO中记录。
    If AcadApp.ActiveDocument.GetVariable("ERRNO") = 7 Then
        Resume
    End If
End Sub
Private Sub IRetrieveDockableContainer_SetDockContainer(ByVal newVal As AC_CONT.IAcadDockableContainer)
    Set dockContainer = newVal
    ' 设置可停靠窗体的标题
    dockContainer.Caption = "对象数据"
    dockContainer.EnableDockPositions = acDockLeft + acDockRight
    
    ' 设置可停靠窗体的大小
    Dim rect(0 To 3) As Integer
    rect(0) = 0
    rect(1) = 0
    rect(2) = 180
    rect(3) = 240
    dockContainer.SetPreferredDockPosition acFloating, rect
End Sub
Private Sub UserControl_Initialize()
    Set AcadApp = GetObject(, "AutoCAD.Application")
    Set EntObj = Nothing
End Sub
Private Sub Text1_LostFocus()
    Dim pPt(0 To 2) As Double
    On Error Resume Next
    ' 改变圆的位置
    pPt(0) = Text1.Text
    pPt(1) = Text2.Text
    pPt(2) = Text3.Text
    EntObj.Center = pPt
    EntObj.Update
End Sub
Private Sub Text2_LostFocus()
    Dim pPt(0 To 2) As Double
    On Error Resume Next
    ' 改变圆的位置
    pPt(0) = Text1.Text
    pPt(1) = Text2.Text
    pPt(2) = Text3.Text
    EntObj.Center = pPt
    EntObj.Update
End Sub
Private Sub Text3_LostFocus()
    Dim pPt(0 To 2) As Double
    On Error Resume Next
    ' 改变圆的位置
    pPt(0) = Text1.Text
    pPt(1) = Text2.Text
    pPt(2) = Text3.Text
    EntObj.Center = pPt
    EntObj.Update
End Sub
Private Sub Text4_LostFocus()
    On Error Resume Next
    ' 改变圆的大小
    EntObj.Radius = Text4.Text
    EntObj.Update
End Sub
Private Sub Text5_LostFocus()
    Dim xdt(0 To 2) As Integer
    Dim xdv(0 To 2) As Variant
    
    On Error Resume Next
    ' 设置扩展数据
    xdt(0) = 1001
    xdv(0) = "电杆"
    xdt(1) = 1000
    xdv(1) = Text5.Text
    xdt(2) = 1000
    xdv(2) = Text6.Text
    EntObj.SetXData xdt, xdv
End Sub
Private Sub Text6_LostFocus()
    Dim xdt(0 To 2) As Integer
    Dim xdv(0 To 2) As Variant
    
    On Error Resume Next
    ' 设置扩展数据
    xdt(0) = 1001
    xdv(0) = "电杆"
    xdt(1) = 1000
    xdv(1) = Text5.Text
    xdt(2) = 1000
    xdv(2) = Text6.Text
    EntObj.SetXData xdt, xdv
End Sub
Private Sub UserControl_Resize()
    ' 调整控件大小和位置
    If UserControl.Width < 2500 Then UserControl.Width = 2500
    If UserControl.Height < 3400 Then UserControl.Height = 3400
    
    Frame1.Width = UserControl.Width - 240
    Command1.Left = Frame1.Left + Frame1.Width - Command1.Width
    Text1.Width = Frame1.Width - 1200
    Text2.Width = Frame1.Width - 1200
    Text3.Width = Frame1.Width - 1200
    Text4.Width = Frame1.Width - 1200
    Frame2.Width = UserControl.Width - 240
    Text5.Width = Frame2.Width - 1200
    Text6.Width = Frame2.Width - 1200
End Sub

						