Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Public Class 非矩形视口
    <CommandMethod("NRVPS")> _
    Public Sub CreateNonRectangularViewports()
        Dim doc As Document = Application.DocumentManager.MdiActiveDocument()
        Dim db As Database = doc.Database
        Dim ed As Editor = doc.Editor
        Using tr As Transaction = db.TransactionManager.StartTransaction()
            ' 取得图纸空间的块表记录
            Dim bt As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForWrite)
            Dim Ps As BlockTableRecord = tr.GetObject(bt(BlockTableRecord.PaperSpace), OpenMode.ForWrite)
            Dim objs As DBObjectCollection = New DBObjectCollection
            '椭圆
            Dim El As Ellipse = New Ellipse(New Point3d(3.5, 4.7, 0), _
                                            Vector3d.ZAxis, _
                                            New Vector3d(1.4, 0.03, 0), _
                                            0.35, 0, 0)
            objs.Add(El)
            ' 圆
            Dim cir As Circle = New Circle(New Point3d(3.4, 1.9, 0), _
                                            Vector3d.ZAxis, _
                                            0.9)
            objs.Add(cir)
            '闭合多段线
            Dim Pl As Polyline = New Polyline(6)
            Pl.AddVertexAt(0, New Point2d(4.92, 5.29), 0, 0, 0)
            Pl.AddVertexAt(1, New Point2d(5.16, 6.02), 0, 0, 0)
            Pl.AddVertexAt(2, New Point2d(6.12, 6.49), 0, 0, 0)
            Pl.AddVertexAt(3, New Point2d(7.29, 6.26), -0.27, 0, 0)
            Pl.AddVertexAt(4, New Point2d(8.11, 5.53), -0.47, 0, 0)
            Pl.AddVertexAt(5, New Point2d(7.75, 5.41), 0, 0, 0)
            Pl.Closed = True
            objs.Add(Pl)
            ' 闭合样条曲线
            Dim PTS As Point3dCollection = New Point3dCollection()
            PTS.Add(New Point3d(5.5, 2.06, 0))
            PTS.Add(New Point3d(5.26, 2.62, 0))
            PTS.Add(New Point3d(5.66, 4.16, 0))
            PTS.Add(New Point3d(8.56, 4.21, 0))
            PTS.Add(New Point3d(7.2, 0.86, 0))
            PTS.Add(New Point3d(6.44, 2.85, 0))
            PTS.Add(New Point3d(5.62, 1.8, 0))
            PTS.Add(New Point3d(5.5, 2.06, 0))
            Dim sp As Spline = New Spline(PTS, 2, 0.5)
            objs.Add(sp)
            ' 把每个对象都添加的图纸空间块表记录
            ' 并且创建一个与之关联的视口
            For Each obj As DBObject In objs
                Dim ent As Entity = obj
                If ent <> Nothing Then
                    ' 添加边界到图纸空间
                    Dim id As ObjectId = Ps.AppendEntity(ent)
                    tr.AddNewlyCreatedDBObject(ent, True)
                    '创建视口
                    Dim vp As Viewport = New Viewport()
                    Ps.AppendEntity(vp)
                    tr.AddNewlyCreatedDBObject(vp, True)
                    '设置视口边界对应的对象,
                    ' 设置视口开关
                    vp.NonRectClipEntityId = id
                    vp.NonRectClipOn = True
                    vp.On = True
                End If
            Next
            tr.Commit()
            '设为图纸空间显示
        End Using
        db.TileMode = False
    End Sub
End Class