CAD

开发平台：

VBA

测试代码.txt：源码内容

							Public TlsApp As New TlsApplication
Private WithEvents m_XhqReactor As TlsReactor
Public Sub TlsCadInit()
    TlsApp.Application = Application
    Set m_XhqReactor = TlsApp.Reactors("TlsXHQ")
End Sub
Private Sub m_XhqReactor_DoubleClick(ByVal pObject As IAcadObject, ByVal Value As Variant)
On Error GoTo ErrHandle
    Dim oBlock As AcadBlock
    Dim oText As AcadText
    Set oBlock = ThisDrawing.Blocks(pObject.Name)
    Set oText = oBlock(1)
    oText.TextString = InputBox("请输入序号", "TlsCad", oText.TextString)
    pObject.Update
ErrHandle:
End Sub
Private Sub m_XhqReactor_Erased(ByVal Value As Variant)
    MsgBox "Delete"
End Sub
Private Sub m_XhqReactor_Modified(ByVal pObject As IAcadObject, ByVal Value As Variant)
On Error GoTo ErrHandle
    Dim oLine As AcadLine
    Dim pStart, pEnd, pAngle, pDis
    
    Set oLine = ThisDrawing.HandleToObject(Value(0))
    pStart = oLine.StartPoint
    pEnd = pObject.InsertionPoint
    pEnd = ThisDrawing.Utility.PolarPoint(pEnd, Atn(1) * 6, 5 * pObject.XScaleFactor)
    pAngle = ThisDrawing.Utility.AngleFromXAxis(pStart, pEnd)
    pDis = ((pStart(0) - pEnd(0)) ^ 2 + (pStart(1) - pEnd(1)) ^ 2) ^ 0.5 - 5 * pObject.XScaleFactor
    oLine.EndPoint = ThisDrawing.Utility.PolarPoint(pStart, pAngle, pDis)
ErrHandle:
End Sub
Sub TlsXHQ()
On Error GoTo ErrHandle
    Dim oLine As AcadLine
    Dim oBlock As AcadBlock
    Dim oText As AcadText
    
    s = ThisDrawing.Utility.GetString(False, "输入序号:")
    p1 = ThisDrawing.Utility.getpoint(, "输入第一点:")
    p2 = ThisDrawing.Utility.getpoint(p1, "输入第二点:")
    Set oLine = ThisDrawing.ModelSpace.AddLine(p1, p2)
    
    p1 = TlsApp.Utility.CreatePoint
    Set oBlock = ThisDrawing.Blocks.Add(p1, "*U")
    p1 = ThisDrawing.Utility.PolarPoint(p1, Atn(1) * 6, 5)
    oBlock.AddCircle p1, 5
    Set oText = oBlock.AddText(s, p1, 5)
    oText.Alignment = acAlignmentMiddleCenter
    oText.TextAlignmentPoint = p1
    
    m_XhqReactor.Add ThisDrawing.ModelSpace.InsertBlock(ThisDrawing.Utility.PolarPoint(p2, Atn(1) * 2, 5), oBlock.Name, 1, 1, 1, 0), Array(oLine.Handle)
 
ErrHandle:
End Sub

						