[编程交流] 弧线（&P）

 
<CommandMethod("twoarcs")> _
Public Sub AddArcsOnLine()
Dim acDoc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim ed As Editor = acDoc.Editor
Dim db As Database = acDoc.Database
Dim mtx As Matrix3d = ed.CurrentUserCoordinateSystem
Dim ucs As CoordinateSystem3d = mtx.CoordinateSystem3d
Try
Using tr As Transaction = db.TransactionManager.StartTransaction
Dim peo As New PromptEntityOptions(vbLf & "Select line >>")
peo.SetRejectMessage(vbLf & "Selected is not a line>>")
peo.AddAllowedClass(GetType(Line), False)
Dim res As PromptEntityResult
res = ed.GetEntity(peo)
If res.Status <> PromptStatus.OK Then
Return
End If
Dim ent As Entity = DirectCast(tr.GetObject(res.ObjectId, OpenMode.ForRead), Entity)
If ent Is Nothing Then
Return
End If
Dim lin As Line = Nothing
If TypeOf ent Is Line Then
lin = DirectCast(ent, Line)
End If
Dim btr As BlockTableRecord = tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite) '<-- get current space
Dim plan As Plane = New Plane(Point3d.Origin, ucs.Zaxis)
Dim p1 As Point3d = lin.StartPoint
Dim p2 As Point3d = lin.EndPoint
Dim ang = lin.Angle
Dim mpt As Point3d = New Point3d((p1.X + p2.X) / 2, (p1.Y + p2.Y) / 2, (p1.Z + p2.Z) / 2)
Dim cpt1 As Point3d = New Point3d((p1.X + mpt.X) / 2, (p1.Y + mpt.Y) / 2, (p1.Z + mpt.Z) / 2)
Dim cpt2 As Point3d = New Point3d((mpt.X + p2.X) / 2, (mpt.Y + p2.Y) / 2, (mpt.Z + p2.Z) / 2)
Dim arc1 As Arc = New Arc(cpt1, lin.GetDistAtPoint(cpt1), ang, Math.PI + ang)
arc1.Normal = lin.Normal
btr.AppendEntity(arc1)
tr.AddNewlyCreatedDBObject(arc1, True)
Dim arc2 As Arc = New Arc(cpt2, lin.GetDistAtPoint(cpt1), ang, Math.PI + ang)
arc1.Normal = lin.Normal
btr.AppendEntity(arc2)
tr.AddNewlyCreatedDBObject(arc2, True)
tr.Commit()
End Using
Catch ex As System.Exception
Autodesk.AutoCAD.ApplicationServices.Application.ShowAlertDialog(String.Format( _
"ERROR: " & Environment.NewLine & "{0}" & Environment.NewLine _
& "TRACE: " + Environment.NewLine + "{1}", ex.Message, ex.StackTrace))
Finally
'do nothing
End Try
End Sub

 
Option Explicit
Public Sub AddTwoArcs()
Dim sset As AcadSelectionSet
Dim dxfCode, dxfValue
Dim ftype(0) As Integer
Dim fdata(0) As Variant
ftype(0) = 0: fdata(0) = "LINE"
dxfCode = ftype: dxfValue = fdata
Dim lineObj As Object
Dim oEnt As AcadEntity
Dim stPt As Variant
Dim endPt As Variant
Dim movePt As Variant
Dim perpAng As Double
Dim rotAng As Double
Dim PI As Double
PI = Atn(1) * 4
' Define the new selection set object
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set sset = .Add("$Lines$")
End With
sset.SelectOnScreen dxfCode, dxfValue
If sset.Count = 0 Then
MsgBox ("No lines selected")
Exit Sub
End If
For Each oEnt In sset
' get the line object
Set lineObj = oEnt
stPt = lineObj.StartPoint
endPt = lineObj.EndPoint
Dim dblAng As Double
' get line angle
dblAng = lineObj.Angle
Dim mpt(2) As Double
Dim cpt1(2) As Double
Dim cpt2(2) As Double
Dim leng As Double
leng = lineObj.Length
Dim tmp As Variant
tmp = ThisDrawing.Utility.PolarPoint(stPt, dblAng, leng / 4)
cpt1(0) = tmp(0): cpt1(1) = tmp(1): cpt1(2) = 0#
tmp = ThisDrawing.Utility.PolarPoint(stPt, dblAng, leng * 0.75)
cpt2(0) = tmp(0): cpt2(1) = tmp(1): cpt2(2) = 0#
Dim oArc1 As AcadArc
Set oArc1 = ThisDrawing.ModelSpace.AddArc(cpt1, leng / 4, dblAng, dblAng + PI)
Dim oArc2 As AcadArc
Set oArc2 = ThisDrawing.ModelSpace.AddArc(cpt2, leng / 4, dblAng, dblAng + PI)
Next
End Sub