发布一个ObjectARX .NET AutoCAD 二次开发 添加各种实体的类

 

Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Colors
Imports DBTransMan = Autodesk.AutoCAD.DatabaseServices.TransactionManager
REM Line, Circle, Arc, Ellipse, Polyline, DBText, MText, Table, Hatch and the Dimensions
Public Class PublicClassClass PublicClass
    Enum PPColorEnum PPColor
        Red = 1
        Yellow = 2
        Green = 3
        cyan = 4 '青色
        Blue = 5
        Fuchsin = 6 '品红
        White = 7
    End Enum
    REM <summary>
    '''函数注释
    '''</summary>  
    '''<typeparam name="msg">变量参数的注释说明</typeparam>
    '''<remarks>
    '''自己的注释说明

    '''</remarks>
    Public Sub ShowMessage()Sub ShowMessage(ByVal msg As String)
        Application.DocumentManager.MdiActiveDocument.Editor.WriteMessage(Chr(10) + msg)
    End Sub
    Public Sub SendCommand()Sub SendCommand(ByVal cmd As String)
        Dim dotnetDoc As Document = Application.DocumentManager.MdiActiveDocument
        dotnetDoc.SendStringToExecute(cmd + Chr(13), True, False, False)
    End Sub


    Public Function GetPointAR()Function GetPointAR(ByVal pt1 As Point3d, ByVal angle As Double, ByVal length As Double) As Point3d
        REM angle(计算sin cos 时 是以弧度计量的角度)
        angle = angle * Math.PI / 180
        Dim pt2 As New Point3d(pt1.X + length * Math.Cos(angle), pt1.Y + length * Math.Sin(angle), pt1.Z)
        Return pt2
    End Function
    '  Public Sub ShowMessage(ByVal msg As String, ByVal ex As Autodesk.AutoCAD.Runtime.Exception)
    '      ShowMessage(Chr(10) + msg + "错误信息如下:" + Chr(10) + ex.Message)
    '  End Sub
    Public Function AddEntity()Function AddEntity(ByVal ent As Entity) As ObjectId
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Dim tm As DBTransMan = db.TransactionManager
        Dim ta As Transaction = tm.StartTransaction
        Try
            Dim bt As BlockTable = ta.GetObject(db.BlockTableId, OpenMode.ForWrite, False)
            Dim btr As BlockTableRecord = ta.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite, False)
            Dim objId As ObjectId = btr.AppendEntity(ent)
            ta.AddNewlyCreatedDBObject(ent, True)
            ta.Commit()
            ta.Dispose()
            Return objId
        Catch ex As Exception
            ShowMessage("AddEntity出错了:" + ex.Message)
        End Try
    End Function
    Public Function AddLayer()Function AddLayer(ByVal LayerName As String, ByVal newColor As PPColor, ByVal LineWeithS As LineWeight, ByVal LineTypeName As String, Optional ByVal Description As String = "没有描述")
        Dim objId As ObjectId
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Dim tm As DBTransMan = db.TransactionManager
        Dim ta As Transaction = tm.StartTransaction
        Dim lt As LayerTable = tm.GetObject(db.LayerTableId, OpenMode.ForWrite)
        If lt.Has(LayerName) Then
            objId = lt.Item(LayerName)
        Else
            Dim ltr As New LayerTableRecord
            ltr.Name = LayerName
            Dim ColorType As Type = GetType(PPColor)
            Dim color1 As Color
            color1 = Color.FromColorIndex(ColorMethod.ByAci, [Enum ]Enum].Parse(ColorType, newColor.ToString))
            ltr.Color = color1
            ltr.LineWeight = LineWeithS
            ltr.LinetypeObjectId = LineType(LineTypeName)
            ltr.Description = Description
            objId = lt.Add(ltr)
            tm.AddNewlyCreatedDBObject(ltr, True)
            ta.Commit()
        End If
        ta.Dispose()
        tm.Dispose()
        Return objId
    End Function
    Public Function AddArc()Function AddArc(ByVal centerPoint As Point3d, ByVal normal As Vector3d, ByVal radius As Double, ByVal startAngle As Double, ByVal endAngle As Double, ByVal LayerName As String) As ObjectId
        REM 此处不用设置线型,颜色等,因为这些已经在图层里设置好了
        Dim a As New Arc(centerPoint, normal, radius, startAngle, endAngle)
        a.Layer = LayerName
        REM  a.Clone() REM 复制实体
        Return AddEntity(a)
    End Function
    Public Function AddLine()Function AddLine(ByVal startPt As Point3d, ByVal endpt As Point3d, ByVal LayerName As String) As ObjectId
        Dim line As New Line(startPt, endpt)
        line.Layer = LayerName
        Return AddEntity(line)
    End Function
    Public Function AddLine()Function AddLine(ByVal startPt As Point3d, ByVal angle As Double, ByVal length As Double, ByVal LayerName As String) As ObjectId
        Dim line As New Line(startPt, GetPointAR(startPt, angle, length))
        line.Layer = LayerName
        Return AddEntity(line)
    End Function
    Public Function AddMLine()Function AddMLine(ByVal scale As Double, ByVal newVertex As Point3d, ByVal LayerName As String) As ObjectId
        REM 多样线
        Dim ml As New Mline

        Dim ms As New MlineStyle
        ms.Name = "standard"

        ml.Style = ms.ObjectId
        ml.Layer = LayerName
        ml.Scale = scale
        ml.AppendSegment(newVertex)
        ml.AppendSegment(New Point3d(20, 20, 0))

    End Function
    Public Function AddTrace()Function AddTrace(ByVal pointer1 As Point3d, ByVal pointer2 As Point3d, ByVal pinter3 As Point3d, ByVal pointer4 As Point3d, ByVal LayerName As String) As ObjectId
        REM 有问题吧
        Dim myTrace As New Trace(pointer1, pointer2, pinter3, pointer4)
        myTrace.LineWeight = LineWeight.LineWeight200
        myTrace.Layer = LayerName
        Return AddEntity(myTrace)

    End Function
    Public Function AddShape()Function AddShape(ByVal position As Point3d, ByVal size As Double, ByVal shapeName As String, ByVal rotation As Double, ByVal widthFactor As Double) As ObjectId
        REM shapeName ??? 有问题吧
        Dim sh As New Shape(position, size, shapeName, rotation, widthFactor)
        Return AddEntity(sh)
    End Function


    Public Function AddPolygon()Function AddPolygon(ByVal upperLeft As Point3d, ByVal upperRight As Point3d, ByVal lowerLeft As Point3d, ByVal lowerRight As Point3d) As ObjectId
        Dim rect As New Rectangle3d(upperLeft, upperRight, lowerLeft, lowerRight)
        Dim rect3d As Entity3d


        '   Dim m As New Plane(New Point3d(100, 100, 0), New Point3d(100, 200, 0), New Point3d(100, 200, 100))




    End Function
    '''<summary>
    '''获取或设置外部处理过程的委托
    '''</summary>
    Public Function AddCircle()Function AddCircle(ByVal center As Point3d, ByVal radius As Double) As ObjectId
        Dim myCircle = New Circle(center, Vector3d.ZAxis, radius)
        Dim circleId As ObjectId = AddEntity(myCircle)
        Return circleId
    End Function
    '''<remarks>
    '''自己的注释说明
    '''</remarks>
    Public Function AddEllipse()Function AddEllipse(ByVal centerPoint As Point3d, ByVal majorAxis As Vector3d, ByVal radiusRatio As Double, ByVal startAngle As Double, ByVal endAngle As Double)
        REM 画完整椭圆时,开始角度= 终止角度,调整角度,就可以调整方向
        REM 可能存在问题
        ' Ellipse(Ellipse = New Ellipse(center, Vector3d.ZAxis, New Vector3d(3, 0, 0), 0.5, 0, 0))
        Dim unitNormal = Vector3d.ZAxis
        Dim e As New Ellipse(centerPoint, unitNormal, majorAxis, radiusRatio, startAngle, endAngle)
        Return AddEntity(e)
    End Function
    '''<typeparam name="text">变量参数的注释说明</typeparam>
    Public Function AddDBText()Function AddDBText(ByVal text As String, ByVal Position As Point3d, ByVal LayerName As String)
        '''<typeparam name="msg">变量参数的注释说明</typeparam>
        Dim mytext As New DBText
        mytext.TextString = text   REM TextString Contents
        mytext.Position = Position REM location position
        mytext.VerticalMode = TextVerticalMode.TextVerticalMid '垂直对齐方式
        mytext.HorizontalMode = TextHorizontalMode.TextCenter '水平对齐方式
        '   mytext.AlignmentPoint = Position '文本的坐标    mytext.Position = Position  重复 ???矛盾
        mytext.Layer = LayerName
        Return AddEntity(mytext)
    End Function
    Public Function AddMText()Function AddMText(ByVal text As String, ByVal Position As Point3d, ByVal LayerName As String)
        Dim mytext As New MText
        mytext.Contents = text
        mytext.Location = Position
        mytext.Layer = LayerName
        Return AddEntity(mytext)
    End Function
    Public Function AddHatch()Function AddHatch(ByVal PointArray() As Point3d, ByVal HatchStyleType As HatchStyle, ByVal PatternScale As Double, ByVal PatternAngle As Double, ByVal LayerName As String, Optional ByVal PatternName As String = "ANSI31") As ObjectId
        REM 多点填充
        REM 圆,圆弧的填充呢??
        Dim hl As New HatchLoop  REM 少了new 时:未将对象设置引用到实例
        Dim P3d As Point3d
        Dim p As Point2d
        Dim bv As BulgeVertex
        For Each P3d In PointArray
            Try
                p = New Point2d(P3d.X, P3d.Y)
                bv = New BulgeVertex(p, 0)
                REM ShowMessage("bv.Bulge=  " + bv.Bulge.ToString)
                REM ShowMessage(" bv.Vertex.ToString" + bv.Vertex.ToString)
                hl.Add(bv)
                '  hl.LoopType = HatchLoopTypes.Default REM 改怎么选

            Catch ex As Exception
                ShowMessage("错" + ex.Message)
            End Try

        Next


        Dim ha As New Hatch REM 还有很多属性可以设置
        ha.HatchStyle = HatchStyleType
        '  ha.HatchStyle = HatchStyle.Normal   REM 三种
        ha.Layer = LayerName
        ha.PatternAngle = PatternAngle  REM 填充图案角度 0 90,270
        ha.PatternScale = PatternScale
        ' ha.HatchObjectType = HatchObjectType.HatchObject REM 2种
        ha.SetHatchPattern(HatchPatternType.PreDefined, PatternName) REM 预定义 ,自定义 ,用户定义 三种
        ' ha.SetGripStatus(GripStatus.GripsToBeDeleted)
        'ha.SetGradient(GradientPatternType.PreDefinedGradient,"")
        ' ha.IntersectWith(ent, Intersect.ExtendThis, d, 0, 0)
        ' ha.EvaluateGradientColorAt(1)
        ' ha.BoundingBoxIntersectWith(
        ' ha.AppendLoop
        ha.AppendLoop(hl)
        ha.EvaluateHatch(True)
        Return AddEntity(ha)
    End Function
    Public Function AddHatch()Function AddHatch(ByVal idC As ObjectIdCollection, ByVal HatchStyleType As HatchStyle, ByVal PatternScale As Double, ByVal PatternAngle As Double, ByVal LayerName As String, Optional ByVal PatternName As String = "ANSI31") As ObjectId
        REM 圆的填充()
        REM 多边形与圆组合的填充   ????
        Dim ha As New Hatch
        ha.HatchStyle = HatchStyleType
        '  ha.HatchStyle = HatchStyle.Normal   REM 三种
        ha.Layer = LayerName
        ha.PatternAngle = PatternAngle  REM 填充图案角度 0 90,270
        ha.PatternScale = PatternScale
        ' ha.HatchObjectType = HatchObjectType.HatchObject REM 2种
        ha.SetHatchPattern(HatchPatternType.PreDefined, PatternName) REM 预定义 ,自定义 ,用户定义 三种

        ha.AppendLoop(0, idC)
        ha.EvaluateHatch(True)
        Return AddEntity(ha)

    End Function

    Public Function AddPolyline()Function AddPolyline(ByVal ptArr As Point3dCollection, ByVal LayerName As String, Optional ByVal width As Double = 0) As ObjectId
        REM 有 Polyline Polyline2d  Polyline3d
        Dim pl As New Polyline
        pl.Layer = LayerName
        Dim i As Integer
        Dim bulge, startWidth, endWidth As Double
        bulge = 0
        startWidth = width
        endWidth = width
        For i = 0 To ptArr.Count - 1
            pl.AddVertexAt(i, New Point2d(ptArr(i).X, ptArr(i).Y), bulge, startWidth, endWidth)
        Next
        Return AddEntity(pl)


    End Function

    Public Function AddPolyline()Function AddPolyline(ByVal ptArr As Point3dCollection, ByVal closed As Boolean, ByVal LayerName As String) As ObjectId
        REM 有 Polyline Polyline2d  Polyline3d
        'closed表示闭合 只有添加多边形时才闭合
        Dim pline3d As New Polyline3d(Poly3dType.SimplePoly, ptArr, closed)
        pline3d.Layer = LayerName
        Return AddEntity(pline3d)
    End Function
    Public Function AddRectangle()Function AddRectangle(ByVal pt1 As Point3d, ByVal pt3 As Point3d, ByVal LayerName As String) As ObjectId
        Dim ptArr As New Point3dCollection
        ptArr.Add(pt1)
        ptArr.Add(New Point3d(pt1.X, pt3.Y, 0))
        ptArr.Add(pt3)
        ptArr.Add(New Point3d(pt3.X, pt1.Y, 0))
        Return AddPolyline(ptArr, True, LayerName)
    End Function
    Public Function AddPolygon()Function AddPolygon(ByVal centerPoint As Point3d, ByVal number As Integer, ByVal radius As Double, ByVal LayerName As String, Optional ByVal width As Double = 0) As ObjectId
        REM 半径指的是外接圆的半径
        Dim angle As Double
        angle = Math.PI * 2 / number
        Dim ptArr As New Point3dCollection
        Dim pt As Point3d
        Dim i As Integer
        For i = 0 To number - 1
            ' pt.X = centerPoint.X + radius * Math.Cos(i * angle)
            ' pt.Y = centerPoint.Y + radius * Math.Sin(i * angle)
            pt = New Point3d(centerPoint.X + radius * Math.Cos(i * angle), centerPoint.Y + radius * Math.Sin(i * angle), 0)
            ptArr.Add(pt)
        Next
        Return AddPolyline(ptArr, True, LayerName)

    End Function

    REM 没有成功
    Public Function AddTable()Function AddTable(ByVal Position As Point3d, ByVal row As Integer, ByVal col As Integer) As ObjectId
        Dim mytable As New Table
        mytable.NumRows = row
        mytable.NumColumns = col
        mytable.SetRowHeight(1, 3)
        mytable.SetTextHeight(3, 2, 2.5)
        mytable.Position = Position
        mytable.SetBackgroundColor(2, 2, Color.FromColorIndex(ColorMethod.ByAci, 1))
        mytable.SetTextString(0, 0, "你是SB")  REM 还有其他的
        AddEntity(mytable)
    End Function
创建组#Region "创建组"
    Public Sub AddGroup()Sub AddGroup(ByVal objIds As ObjectIdCollection, ByVal pGroupName As System.String)
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Dim tm As DBTransMan = db.TransactionManager
        'start a transaction
        Dim ta As Transaction = tm.StartTransaction()
        Try
            Dim gp As New Group(pGroupName, True)
            Dim dict As DBDictionary = tm.GetObject(db.GroupDictionaryId, OpenMode.ForWrite, True)
            dict.SetAt("ASDK_NEWNAME", gp)

            Dim thisId As ObjectId
            For Each thisId In objIds
                gp.Append(thisId)
            Next
            tm.AddNewlyCreatedDBObject(gp, True)
            ta.Commit()
        Finally
            ta.Dispose()
        End Try
    End Sub
#End Region
添加UCS#Region "添加UCS"
    Public Function AddUcs()Function AddUcs(ByVal UcsName As String) As ObjectId
        Dim objId As ObjectId
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Dim tm As DBTransMan = db.TransactionManager
        Dim ta As Transaction = tm.StartTransaction
        Dim ut As UcsTable = tm.GetObject(db.UcsTableId, OpenMode.ForWrite)
        If ut.Has(UcsName) Then
            objId = ut.Item(UcsName)
        Else
            Dim utr As New UcsTableRecord
            utr.Name = UcsName
            'utr.Origin=
            ' utr.XAxis
            objId = ut.Add(utr)
            tm.AddNewlyCreatedDBObject(utr, True)
            ta.Commit()

        End If
        ta.Dispose()
        tm.Dispose()
        Return objId
    End Function
#End Region
添加视口#Region "添加视口"
    Public Function AddViewport()Function AddViewport(ByVal ViewPortName As String) As ObjectId
        Dim objId As ObjectId
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Dim tm As DBTransMan = db.TransactionManager
        Dim ta As Transaction = tm.StartTransaction
        Dim vpt As ViewportTable = tm.GetObject(db.ViewportTableId, OpenMode.ForWrite)
        If vpt.Has(ViewPortName) Then
            objId = vpt.Item(ViewPortName)
        Else
            Dim vptr As New ViewportTableRecord
            vptr.Name = ViewPortName
            '  Autodesk.AutoCAD.Geometry.CoordinateSystem3d()
            'vptr.Ucs()

            objId = vpt.Add(vptr)
            tm.AddNewlyCreatedDBObject(vptr, True)
            ta.Commit()
        End If
        ta.Dispose()
        tm.Dispose()
        Return objId
    End Function
#End Region
添加视图#Region "添加视图"
    Public Function AddView()Function AddView(ByVal ViewName As String, ByVal render As RenderMode, ByVal ucsId As ObjectId) As ObjectId
        REM 添加视图() 这个和添加图层是相同的
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Dim tm As DBTransMan = db.TransactionManager
        Dim ta As Transaction = tm.StartTransaction
        Dim vt As ViewTable = ta.GetObject(db.ViewTableId, OpenMode.ForWrite)
        Dim objId As ObjectId
        If vt.Has(ViewName) Then
            objId = vt.Item(ViewName)
        Else
            Dim vtr As New ViewTableRecord
            vtr.Name = ViewName
            vtr.RenderMode = render
            vtr.SetUcs(ucsId)
            REM vtr.SetUcs(
            objId = vt.Add(vtr)
            tm.AddNewlyCreatedDBObject(vtr, True)
            ta.Commit()
        End If
        Return objId
    End Function
#End Region



End Class

转载于:https://www.cnblogs.com/ObjectARX/archive/2005/10/10/251605.html