动态坐标标注，示例，附源码

pmq

谢谢楼主分享，有没有vb.net 的，C#的看不懂
用 https://converter.telerik.com/ 转换不了。

d1742647821

pmq 发表于 2023-3-1 19:23
谢谢楼主分享，有没有vb.net 的，C#的看不懂
用 https://converter.telerik.com/ 转换不了。

没有                                       

荣sir

白佬666，顶一个

lxl217114

谢谢分享，占个楼。。。

d1742647821

cq_qg 发表于 2023-3-1 08:45
有没有编译好的？

没有，这就是个小demo

yangmz1972

pmq 发表于 2023-3-1 19:23
谢谢楼主分享，有没有vb.net 的，C#的看不懂
用 https://converter.telerik.com/ 转换不了。

我也是初学用vb.net做二开，参照楼主的思想和代码改写了一个简化的vb..net代码，但不知道怎么回事，在该对象的modified事件中，不能修改文本值，有高手知道的指点一下。
改写的这个VB.net代码实现模拟拖放mleader。但不能修改坐标值。

  Private Sub CmdCoordMark_Click(sender As Object, e As EventArgs) Handles CmdCoordDim.Click
        Dim acDoc As Autodesk.AutoCAD.ApplicationServices.Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
        Dim acCurDb As Database = acDoc.Database
        Dim acDocEd As Autodesk.AutoCAD.EditorInput.Editor = acDoc.Editor
        Dim acBlkTbl As BlockTable
        Dim acBlkTblRec As BlockTableRecord
        Using aclckdoc As DocumentLock = acDoc.LockDocument
            Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()
                acBlkTbl = CType(acTrans.GetObject(acCurDb.BlockTableId, OpenMode.ForRead), BlockTable)
                acBlkTblRec = CType(acTrans.GetObject(acBlkTbl(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)
                Dim retStPoint As PromptPointResult = acDocEd.GetPoint(vbLf & "请选择要标注坐标的点：")
                If retStPoint.Status = PromptStatus.OK Then
                Else
                    Exit Sub
                End If
                Dim pt11 As New Point3d(retStPoint.Value.X, retStPoint.Value.Y, 0)

                '得到第二个点的坐标
                '第二点的坐标在第一个坐标的基础上加上一个增量。用来实现leader的拖放，
                '如不这样做, 则需要第二个点才能进行拖放, 在选中第一个点和准备选中第二个点的的时间差，mleader是没有显示出来，影响效果。
                Dim pt22 As New Point3d(retStPoint.Value.X + 0.1, retStPoint.Value.Y + 0.1, 0)

                '设置字体
                Dim acTextStyleTblRec As TextStyleTableRecord = acTrans.GetObject(acCurDb.Textstyle, OpenMode.ForWrite)
                Dim acFont As Autodesk.AutoCAD.GraphicsInterface.FontDescriptor = acTextStyleTblRec.Font
                Dim acNewFont As Autodesk.AutoCAD.GraphicsInterface.FontDescriptor
                acNewFont = New Autodesk.AutoCAD.GraphicsInterface.FontDescriptor("仿宋", False, False, acFont.CharacterSet, acFont.PitchAndFamily)
                acTextStyleTblRec.Font = acNewFont

                '建立多文本
                Dim text As New MText
                text.Contents = GetBzStr(pt11)          '传递第一个点的坐标进行内容变换，注意，本示例代码中，在测绘领域，Cad的X坐标代表的北向。
                text.LineSpacingStyle = LineSpacingStyle.Exactly
                text.LineSpacingFactor = 0.84

                '创建多重引线
                Dim m1 As New MLeader
                m1.LeaderLineType = LeaderType.StraightLeader           '直引线
                m1.ContentType = ContentType.MTextContent
                m1.TextAttachmentType = TextAttachmentType.AttachmentBottomOfTopLine   '1连接位置：第一行加下划线
                m1.SetDatabaseDefaults()

                Dim n1 As Integer = m1.AddLeader()
                Dim n2 As Integer = m1.AddLeaderLine(n1)

                m1.AddFirstVertex(n1, pt11)
                m1.AddLastVertex(n2, pt22)
                m1.MText = text
                m1.TextHeight = 1
                m1.ColorIndex = 3
                m1.ArrowSize = 0.5
                m1.DoglegLength = 0   '基线为0
                m1.LandingGap = 1     '基线与文字的间距为1

                '' 添加新对象到模型空间和事务中   Add the new object to Model space and the transaction
                Dim entNow As List(Of Entity) = New List(Of Entity) From {m1}          '使用对象列表，本示例中只有一个对象，你也可以改写为直接使用mleader
                '调用mleader拖放类
                Dim jigentity As PubMleaderJig = New PubMleaderJig(entNow, New Point3d(retStPoint.Value.X, retStPoint.Value.Y, 0), New Point3d(pt22.X, pt22.Y, 0))
                '在确定具体位置后，把该对象放入数据库中。
                Dim prs As PromptResult = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor.Drag(jigentity)
                If prs.Status = PromptStatus.OK Then
                    If prs.Status = PromptStatus.OK Then
                        Dim enti As Entity
                        For Each enti In jigentity.ent
                            acBlkTblRec.AppendEntity(enti)
                            acTrans.AddNewlyCreatedDBObject(enti, True)
                            AddHandler enti.Modified, AddressOf entiModified           '添加该对象的修改事件
                        Next
                    End If
                End If
                acTrans.Commit()
            End Using
        End Using
    End Sub

'对象修改事件，根据楼主的代码改字的
    Private Sub entiModified(ByVal senderObj As Object, ByVal evtArgs As EventArgs)
        Dim m As MLeader = CType(senderObj, MLeader)
        Dim mt As MText = m.MText.Clone
        mt.Contents = GetBzStr(m.GetFirstVertex(0))
        m.UpgradeOpen()           '对象可写
        m.MText = mt                '这句没有运行，不知道为什么，还差什么语句
    End Sub

拖放类
Public Class PubMleaderJig
    '该类专为Mleader拖放使用
    Inherits DrawJig
    Public SecondMovePt As Point3d         '定义第二个插入点
    Public FirstMovePt As Point3d          '定义第一个插入点
    Public ent As List(Of Entity)           '定义多实体对象

    '构造函数
    Public Sub New(ByVal nents As List(Of Entity), ByVal MovePt1 As Point3d, ByVal movePt2 As Point3d)
        'MovePt2为第二个点。movePt1为第一个点,
        MyBase.New()
        SecondMovePt = movePt2
        FirstMovePt = MovePt1
        ent = nents
    End Sub

    '检测鼠标的移动量
    Protected Overrides Function Sampler(prompts As JigPrompts) As SamplerStatus
        Dim psr As PromptPointResult = prompts.AcquirePoint                 '接收当前鼠标点的坐标
        If psr.Status = PromptStatus.OK Then                                '确认用户点击了左键
            Dim MovePtNow As Point3d = psr.Value                            '当前鼠标点的坐标赋值给一个新变量
            '鼠标的坐标以第二个点为准移动。
            If (MovePtNow <> SecondMovePt) And MovePtNow.DistanceTo(SecondMovePt) > 0.000001 Then      '判断当前鼠标的坐标与原来的坐标值是否不一样，同时相差值不能小于0.000001
                Dim vector3d As Vector3d = SecondMovePt.GetVectorTo(MovePtNow)    '把原来坐标点转换为顶点值
                Dim matrix As Matrix3d = Matrix3d.Displacement(vector3d)    '
                ent.ForEach(Sub(x) x.TransformBy(matrix))                   '使用lambda转换对象的位置
                SecondMovePt = MovePtNow                                    '把当前的鼠标值赋给保存旧坐标值的变量

                '保持原来第一个点的坐标的值为选中点的坐标
                Dim initpoint As MLeader = CType(ent(0), MLeader)
                initpoint.SetFirstVertex(0, FirstMovePt)
                Return SamplerStatus.OK
            Else
                Return SamplerStatus.NoChange
            End If
            Return SamplerStatus.Cancel
        End If
    End Function

    Protected Overrides Function WorldDraw(draw As GraphicsInterface.WorldDraw) As Boolean
        For Each entt In ent
            draw.Geometry.Draw(entt)             '重绘所有图形
        Next
        Return True
    End Function
End Class

d1742647821

顶顶顶顶顶

d1742647821

cq_qg 发表于 2023-3-1 08:45
有没有编译好的？

拒绝伸手党哦