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
'''函数注释
'''
'''
'''
'''自己的注释说明
'''
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
'''
'''获取或设置外部处理过程的委托
'''
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
'''
'''自己的注释说明
'''
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
'''
Public Function AddDBText()Function AddDBText(ByVal text As String, ByVal Position As Point3d, ByVal LayerName As String)
'''
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