动态坐标标注

pmq

原文

用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

pmq

潘成祥2015 发表于 2023-5-21 00:08
可以做一个单点坐标标注的程序吗？选择某一点为基点，选择标注方向，依次点击标注，当重新输入命令后，则继 ...

http://bbs.mjtd.com/thread-176759-1-1.html
这里有

linzenghuo

学习一下

nsh935

新人逛逛 学习路过

潘成祥2015

可以做一个单点坐标标注的程序吗？选择某一点为基点，选择标注方向，依次点击标注，当重新输入命令后，则继续选择基准点。。。从而标注对应的x y向的坐标

hzyhzjjzh

感谢楼主分享