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

ppblog

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, olyline, DBText, MText, Table, Hatch and the Dimensions
Public Class ublicClassClass ublicClass
    Enum PColorEnum PColor
        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>
    ublic Sub ShowMessage()Sub ShowMessage(ByVal msg As String)
        Application.DocumentManager.MdiActiveDocument.Editor.WriteMessage(Chr(10) + msg)
    End Sub
    ublic 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


    ublic Function GetPointAR()Function GetPointAR(ByVal pt1 As oint3d, ByVal angle As Double, ByVal length As Double) As oint3d
        REM angle(计算sin cos 时 是以弧度计量的角度)
        angle = angle * Math.PI / 180
        Dim pt2 As New oint3d(pt1.X + length * Math.Cos(angle), pt1.Y + length * Math.Sin(angle), pt1.Z)
        Return pt2
    End Function
    '  ublic Sub ShowMessage(ByVal msg As String, ByVal ex As Autodesk.AutoCAD.Runtime.Exception)
    '      ShowMessage(Chr(10) + msg + "错误信息如下:" + Chr(10) + ex.Message)
    '  End Sub
    ublic 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
    ublic Function AddLayer()Function AddLayer(ByVal LayerName As String, ByVal newColor As PColor, 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
    ublic Function AddArc()Function AddArc(ByVal centerPoint As oint3d, 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
    ublic Function AddLine()Function AddLine(ByVal startPt As oint3d, ByVal endpt As oint3d, ByVal LayerName As String) As ObjectId
        Dim line As New Line(startPt, endpt)
        line.Layer = LayerName
        Return AddEntity(line)
    End Function
    ublic Function AddLine()Function AddLine(ByVal startPt As oint3d, 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
    ublic Function AddMLine()Function AddMLine(ByVal scale As Double, ByVal newVertex As oint3d, 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 oint3d(20, 20, 0))

    End Function
    ublic Function AddTrace()Function AddTrace(ByVal pointer1 As oint3d, ByVal pointer2 As oint3d, ByVal pinter3 As oint3d, ByVal pointer4 As oint3d, 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
    ublic Function AddShape()Function AddShape(ByVal position As oint3d, 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


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


        '   Dim m As New lane(New oint3d(100, 100, 0), New oint3d(100, 200, 0), New oint3d(100, 200, 100))




    End Function
    '''<summary>
    '''获取或设置外部处理过程的委托
    '''</summary>
    ublic Function AddCircle()Function AddCircle(ByVal center As oint3d, 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>
    ublic Function AddEllipse()Function AddEllipse(ByVal centerPoint As oint3d, 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>
    ublic Function AddDBText()Function AddDBText(ByVal text As String, ByVal osition As oint3d, ByVal LayerName As String)
        '''<typeparam name="msg">变量参数的注释说明</typeparam>
        Dim mytext As New DBText
        mytext.TextString = text   REM TextString Contents
        mytext.Position = osition REM location position
        mytext.VerticalMode = TextVerticalMode.TextVerticalMid '垂直对齐方式
        mytext.HorizontalMode = TextHorizontalMode.TextCenter '水平对齐方式
        '   mytext.AlignmentPoint = osition '文本的坐标    mytext.Position = osition  重复 ???矛盾
        mytext.Layer = LayerName
        Return AddEntity(mytext)
    End Function
    ublic Function AddMText()Function AddMText(ByVal text As String, ByVal osition As oint3d, ByVal LayerName As String)
        Dim mytext As New MText
        mytext.Contents = text
        mytext.Location = osition
        mytext.Layer = LayerName
        Return AddEntity(mytext)
    End Function
    ublic Function AddHatch()Function AddHatch(ByVal ointArray() As oint3d, ByVal HatchStyleType As HatchStyle, ByVal atternScale As Double, ByVal atternAngle As Double, ByVal LayerName As String, Optional ByVal atternName As String = "ANSI31") As ObjectId
        REM 多点填充
        REM 圆,圆弧的填充呢??
        Dim hl As New HatchLoop  REM 少了new 时:未将对象设置引用到实例
        Dim 3d As oint3d
        Dim p As oint2d
        Dim bv As BulgeVertex
        For Each 3d In ointArray
            Try
                p = New oint2d(P3d.X, 3d.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 = atternAngle  REM 填充图案角度 0 90,270
        ha.PatternScale = atternScale
        ' ha.HatchObjectType = HatchObjectType.HatchObject REM 2种
        ha.SetHatchPattern(HatchPatternType.PreDefined, atternName) 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
    ublic Function AddHatch()Function AddHatch(ByVal idC As ObjectIdCollection, ByVal HatchStyleType As HatchStyle, ByVal atternScale As Double, ByVal atternAngle As Double, ByVal LayerName As String, Optional ByVal atternName 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 = atternAngle  REM 填充图案角度 0 90,270
        ha.PatternScale = atternScale
        ' ha.HatchObjectType = HatchObjectType.HatchObject REM 2种
        ha.SetHatchPattern(HatchPatternType.PreDefined, atternName) REM 预定义 ,自定义 ,用户定义 三种

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

    End Function

    ublic Function AddPolyline()Function AddPolyline(ByVal ptArr As oint3dCollection, ByVal LayerName As String, Optional ByVal width As Double = 0) As ObjectId
        REM 有 olyline olyline2d  olyline3d
        Dim pl As New olyline
        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 oint2d(ptArr(i).X, ptArr(i).Y), bulge, startWidth, endWidth)
        Next
        Return AddEntity(pl)


    End Function

    ublic Function AddPolyline()Function AddPolyline(ByVal ptArr As oint3dCollection, ByVal closed As Boolean, ByVal LayerName As String) As ObjectId
        REM 有 olyline olyline2d  olyline3d
        'closed表示闭合 只有添加多边形时才闭合
        Dim pline3d As New olyline3d(Poly3dType.SimplePoly, ptArr, closed)
        pline3d.Layer = LayerName
        Return AddEntity(pline3d)
    End Function
    ublic Function AddRectangle()Function AddRectangle(ByVal pt1 As oint3d, ByVal pt3 As oint3d, ByVal LayerName As String) As ObjectId
        Dim ptArr As New oint3dCollection
        ptArr.Add(pt1)
        ptArr.Add(New oint3d(pt1.X, pt3.Y, 0))
        ptArr.Add(pt3)
        ptArr.Add(New oint3d(pt3.X, pt1.Y, 0))
        Return AddPolyline(ptArr, True, LayerName)
    End Function
    ublic Function AddPolygon()Function AddPolygon(ByVal centerPoint As oint3d, 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 oint3dCollection
        Dim pt As oint3d
        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 oint3d(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 没有成功
    ublic Function AddTable()Function AddTable(ByVal osition As oint3d, 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 = osition
        mytable.SetBackgroundColor(2, 2, Color.FromColorIndex(ColorMethod.ByAci, 1))
        mytable.SetTextString(0, 0, "你是SB")  REM 还有其他的
        AddEntity(mytable)
    End Function
创建组#Region "创建组"
    ublic 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"
    ublic 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 "添加视口"
    ublic 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 "添加视图"
    ublic 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

tcsl9621

对不起，我试用时发现添加图层函数的，设定线型的LINETYPE函数好像不对。请楼主指点。谢谢楼主提供这么好的东东。

tcsl9621

这么好的贴子怎么没人顶起。大家都有眼无珠啊！我再来顶一下……

springtao

顶一下 ,不错,呵呵,学习!

ganok

谢谢无私精神。

tcsl9621

再顶一下。现在这个论谈里的人最少了。给楼主送花一朵。

leidiang

顶,好东西!!!

whales

顶一下，谢了！

idoo

先顶了，接下来在慢慢研究

mkhsj929

缺少一个重要的东东——制作块

另外，我个人认为直线用多义线代替就行了，因为多义线编辑比较方便