用 https://converter.telerik.com/ 转换不了。 pmq 发表于 2023-3-1 19:23
谢谢楼主分享，有没有vb.net 的，C#的看不懂
用 https://converter.telerik.com/ 转换不了。
没有 白佬666，顶一个 谢谢分享，占个楼。。。 cq_qg 发表于 2023-3-1 08:45
有没有编译好的？
没有，这就是个小demo 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 顶顶顶顶顶 cq_qg 发表于 2023-3-1 08:45
有没有编译好的？
拒绝伸手党哦
页:
1
[2]