动态坐标标注
本帖最后由 pmq 于 2023-5-20 11:41 编辑原文
用objectARX实现了一个复杂实体的Jig_flyfun2000的博客-CSDN博客
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Class BZ
Inherits DrawJig
Dim Heigh As Double
Private mLocation As Point3d
Private FirstPoint As Point3d
Private strZbx As String = ""
Private strZby As String = ""
Private mText As DBText
Private mTextY As DBText
Private mPline As Polyline
Private Len As Double
Public Sub Zbbz()
Do While 1
Dim ed As Editor = Core.Application.DocumentManager.MdiActiveDocument.Editor
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim opt As New PromptPointOptions(vbLf & "选择标注点:") With {
.AllowNone = True '右键退出
}
Dim res As PromptPointResult = ed.GetPoint(opt)
If res.Status = PromptStatus.OK Then
FirstPoint = res.Value
Else
Exit Do
End If
Heigh = 1
Dim Xsw = "f3" '小数位
strZbx = "X=" & FirstPoint.Y.ToString(Xsw)
strZby = "Y=" & FirstPoint.X.ToString(Xsw)
Dim textSX As Double
Dim textSY As Double
mText = New DBText With {
.Position = FirstPoint,
.TextString = strZbx,
.Height = Heigh,
.WidthFactor = 1,'宽度因子
.Rotation = 0.00
}
textSX = mText.GeometricExtents.MaxPoint.X - mText.GeometricExtents.MinPoint.X '范围最大点'范围最小点
mTextY = New DBText With {
.Position = FirstPoint,
.TextString = strZby,
.Height = Heigh
}
textSY = mTextY.GeometricExtents.MaxPoint.X - mTextY.GeometricExtents.MinPoint.X '范围最大点'范围最小点
If textSY > textSX Then
Len = textSY
Else
Len = textSX
End If
mPline = New Polyline()
mPline.AddVertexAt(0, New Point2d(FirstPoint.X, FirstPoint.Y), 0, 0, 0)
mPline.AddVertexAt(1, New Point2d(FirstPoint.X, FirstPoint.Y), 0, 0, 0)
mPline.AddVertexAt(2, New Point2d(FirstPoint.X + Len, FirstPoint.Y), 0, 0, 0)
Dim res2 As PromptResult = ed.Drag(Me)
If res2.Status = PromptStatus.OK Then
AppendEntity()
End If
Loop
End Sub
Protected Overrides Function Sampler(prompts As JigPrompts) As SamplerStatus
Dim jigOpts As New JigPromptPointOptions With {
.UserInputControls = UserInputControls.Accept3dCoordinates Or UserInputControls.NoZeroResponseAccepted Or UserInputControls.NoNegativeResponseAccepted,
.Message = vbLf & "标注位置:"
}
Dim res As PromptPointResult = prompts.AcquirePoint(jigOpts)
Dim positionTemp As New Point3d(res.Value.X, res.Value.Y, 0)
If positionTemp <> mLocation Then
mLocation = positionTemp
Else
Return SamplerStatus.NoChange
End If
If res.Status = PromptStatus.Cancel Then
Return SamplerStatus.Cancel
Else
Return SamplerStatus.OK
End If
End Function
Protected Overrides Function WorldDraw(draw As Autodesk.AutoCAD.GraphicsInterface.WorldDraw) As Boolean
Try
Update()
draw.Geometry.Draw(mPline)
'--------------------------------------
draw.Geometry.Draw(mText)
draw.Geometry.Draw(mTextY)
'--------------------------------------
Catch __unusedException1__ As Exception
Return False
End Try
Return True
End Function
Private Sub Update()
mPline.SetPointAt(1, New Point2d(mLocation.X, mLocation.Y))
'方位角
Dim TR As Double
Dim dx As Double = mLocation.Y - FirstPoint.Y
Dim dy As Double = mLocation.X - FirstPoint.X
If dx = 0 Then
TR = Math.Sign(dy) * PI / 2
Else
TR = Math.Atan(dy / dx)
If dx < 0 Then TR += PI
End If
If dx >= 0 And dy < 0 Then TR += 2 * PI
'方位角
If TR > PI Then
mPline.SetPointAt(2, New Point2d(mLocation.X - Len, mLocation.Y))
mText.Position = New Point3d(mLocation.X - Len, mLocation.Y + 0.1, 0)
mTextY.Position = New Point3d(mLocation.X - Len, mLocation.Y - Heigh * 1.1, 0)
Else
mPline.SetPointAt(2, New Point2d(mLocation.X + Len, mLocation.Y))
mText.Position = New Point3d(mLocation.X, mLocation.Y + Heigh * 0.1, 0)
mTextY.Position = New Point3d(mLocation.X, mLocation.Y - Heigh * 1.1, 0)
End If
End Sub
Private Sub AppendEntity()
Dim db As Database = HostApplicationServices.WorkingDatabase
Using tr As Transaction = db.TransactionManager.StartTransaction()
Dim btr As BlockTableRecord = CType(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite, False), BlockTableRecord)
Update()
btr.AppendEntity(mText)
tr.AddNewlyCreatedDBObject(mText, True)
btr.AppendEntity(mTextY)
tr.AddNewlyCreatedDBObject(mTextY, True)
btr.AppendEntity(mPline)
tr.AddNewlyCreatedDBObject(mPline, True)
tr.Commit()
End Using
End Sub
End Class
潘成祥2015 发表于 2023-5-21 00:08
可以做一个单点坐标标注的程序吗？选择某一点为基点，选择标注方向，依次点击标注，当重新输入命令后，则继 ...
http://bbs.mjtd.com/thread-176759-1-1.html
这里有 本帖最后由 linzenghuo 于 2023-5-20 22:09 编辑
http://www.mjtd.com/?fromuid=7301948学习一下 新人逛逛 学习路过 可以做一个单点坐标标注的程序吗？选择某一点为基点，选择标注方向，依次点击标注，当重新输入命令后，则继续选择基准点。。。从而标注对应的x y向的坐标 感谢楼主分享{:1_1:}
页:
[1]