Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
'绘制矩形云线
Public Class TcYunXian
    ' 从DrawJig类继承.
    Inherits DrawJig
    ' 拖拽的对象.
    '*****************************
    Private Ent(0) As Entity
    '*****************************
    ' 拖拽指向的点.
    Private StartPt, EndPt As Point3d
    Dim H As Int16 = 90 '绘制云线 线宽
    Dim Diameter As Long = 1000 '绘制云线 半圆的直径
    '绘制矩形云线
    <CommandMethod("YunXian")> _
    Sub YunXian()
        On Error Resume Next
        '************************
        Dim Scale As Double = 1 '绘图比例
        H = 90 * Scale
        Diameter = 1000 * Scale
        If GetPoint(StartPt) = False Then
            Exit Sub
        End If
        '************************
        Dim acCurDb As Database = HostApplicationServices.WorkingDatabase
        Dim acEditor As Editor = Application.DocumentManager.MdiActiveDocument.Editor
        ' 开始拖拽.
        Dim resJig As PromptResult = acEditor.Drag(Me)
        If resJig.Status = PromptStatus.OK Then
            '确定后添加对象
            Dim N As Int16 = Ent.Length - 1
            If N = 0 Then
                AddEnt(Ent(0))
            Else
                Dim EntList(N) As ObjectId
                For i As Int16 = 0 To Ent.Length - 1
                    EntList(i) = AddEnt(Ent(i))
                Next
            End If
        End If
    End Sub
    ' Sampler函数用于检测用户的输入.
    Protected Overrides Function Sampler(ByVal Prompts As JigPrompts) As SamplerStatus
        ' 定义一个点拖动交互类.
        Dim optJigPoint As New JigPromptPointOptions(vbCrLf & "请指定下一点:")
        ' 设置拖拽光标类型.
        '*******************************
        optJigPoint.Cursor = CursorType.NotRotated
        ' 设置拖动光标基点.
        'optJigPoint.BasePoint = StartPt
        optJigPoint.UseBasePoint = False
        '*******************************
        ' 用AcquirePoint函数得到用户输入的点.
        Dim resJigPoint1 As PromptPointResult = Prompts.AcquirePoint(optJigPoint)
        If resJigPoint1.Status = PromptStatus.Cancel Then
            Exit Function
        End If
        Dim curPt As Point3d = resJigPoint1.Value
        If curPt <> EndPt Then
            '**********************************根据需要修改***************************************
            '   基点StartPt，鼠标移动点CurPt
            Dim PT1 As Point3d = StartPt
            Dim PT2 As Point3d = curPt
            Dim MinPoint As Point3d = New Point3d(System.Math.Min(PT1(0), PT2(0)), System.Math.Min(PT1(1), PT2(1)), 0)
            Dim MaxPoint As Point3d = New Point3d(System.Math.Max(PT1(0), PT2(0)), System.Math.Max(PT1(1), PT2(1)), 0)
            Dim Bulge As Double = Math.Tan(Math.PI / 4) '半圆圆心角的1/4的Tan值
            PT1 = MaxPoint
            PT2 = MinPoint
            Dim L1 As Long = PT1.X - PT2.X
            Dim N1 As Int16 = L1 \ Diameter
            Dim L2 As Long = PT1.Y - PT2.Y
            Dim N2 As Int16 = L2 \ Diameter
            '              PT3--------------L1----------------PT1
            '              |                                      |
            '              |                                      |
            '              L2                                    L2
            '              |                                      |
            '              |                                      |
            '              PT2--------------L1---------------PT4
            '

            '创建多段线对象(云线)
            Dim acPoly As Polyline = New Polyline()
            acPoly.SetDatabaseDefaults()
            If N1 > 1 Or N2 > 1 Then
                PT2 = New Point3d(PT1.X - Diameter * N1, PT1.Y - Diameter * N2, 0) '按照 Diameter的整数倍重新定位PT2的坐标，这样PT2 PT3和PT4坐标相对于PT1来讲正好都是 Diameter的整数倍。
                Dim PT3 As Point3d = New Point3d(PT1.X - diameter * N1, PT1.Y, 0)
                Dim PT4 As Point3d = New Point3d(PT1.X, PT1.Y - diameter * N2, 0)
                For i As Int16 = 0 To N1
                    acPoly.AddVertexAt(i, New Point2d(PT1.X - i * diameter, PT1.Y), Bulge, 0, H)
                Next
                For i As Int16 = 1 To N2
                    acPoly.AddVertexAt(N1 + i, New Point2d(PT3.X, PT3.Y - i * diameter), Bulge, 0, H)
                Next
                For i As Int16 = 1 To N1
                    acPoly.AddVertexAt(N1 + N2 + i, New Point2d(PT2.X + i * Diameter, PT2.Y), Bulge, 0, H)
                Next
                For i As Int16 = 1 To N2
                    acPoly.AddVertexAt(N1 + N2 + N1 + i, New Point2d(PT4.X, PT4.Y + i * Diameter), Bulge, 0, H)
                Next
            Else
                acPoly.AddVertexAt(0, New Point2d(PT1.X, PT1.Y), 0, h, h)
                acPoly.AddVertexAt(1, New Point2d(PT2.X, PT1.Y), 0, h, h)
                acPoly.AddVertexAt(2, New Point2d(PT2.X, PT2.Y), 0, h, H)
                acPoly.AddVertexAt(3, New Point2d(PT1.X, PT2.Y), 0, H, H)
                acPoly.Closed = True
            End If
            Ent(0) = acPoly
            '**********************************************************************************
            ' 保存当前点.
            EndPt = curPt
            Return SamplerStatus.OK
        Else
            Return SamplerStatus.NoChange
        End If
    End Function
    ' WorldDraw函数用于刷新屏幕上显示的图形.
    Protected Overrides Function WorldDraw(ByVal Draw As Autodesk.AutoCAD.GraphicsInterface.WorldDraw) As Boolean
        ' 刷新画面.
        For Each E As Object In Ent
            Draw.Geometry.Draw(E)
        Next
        Return True
    End Function
    '插入点
    Public Function GetPoint(ByRef PT1 As Point3d, Optional ByVal Prompt As String = "选择插入点: ") As Boolean
        Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
        Dim pPtRes As PromptPointResult
        Dim pPtOpts As PromptPointOptions = New PromptPointOptions("")
        pPtOpts.Message = vbLf & Prompt
        pPtRes = acDoc.Editor.GetPoint(pPtOpts)
        If pPtRes.Status <> PromptStatus.OK Then
            Return False
        End If
        PT1 = pPtRes.Value
        Return True
    End Function
    '添加对象
    Public Function AddEnt(ByVal E As Entity) As ObjectId
        Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
        Dim acCurDb As Database = acDoc.Database
        Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()
            Dim acBlkTbl As BlockTable
            acBlkTbl = acTrans.GetObject(acCurDb.BlockTableId, OpenMode.ForWrite)
            Dim acBlkTblRec As BlockTableRecord
            acBlkTblRec = acTrans.GetObject(acBlkTbl(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
            acBlkTblRec.AppendEntity(E)
            acTrans.AddNewlyCreatedDBObject(E, True)
            AddEnt = E.ObjectId
            acTrans.Commit()
        End Using
    End Function
End Class