根据相邻对象对齐文本
大家好，是否有一种根据相邻行/对象的对齐方式自动对齐文本的方法。
谢谢和问候，
普里扬卡 根据实体类型，为什么不在创建文本之前使用UCS-大卫 这是我不久前写的。请注意，这些单位是公制的。
http://mechcad-insider.blogspot.com/2009/03/get-in-align.html 寻找塔龙。非常慷慨的ASMI的lsp
http://www.asmitools.com/Files/Programs.html
^^Lisp程序 谢谢大家的帮助。。
最后，我得出了用数学公式收集线的角度，即。
轴承=tan（逆）=y2-y1/x2-x1
并将此方向角提供给textobject。
最终，我想检索长度，创建一个长度和线条旋转相同的文本
因此，结果是这样的：
‘Collects Length, Creates a text of its length at the midpoint of the line at the same rotation as line
Private Sub cmdlength_Click()
On Error Resume Next
‘Collects Length
Dim SOS As AcadSelectionSet
Dim objSS As AcadSelectionSet
Dim intCode(0) As Integer
Dim varData(0) As Variant
Dim objEnt As AcadEntity
Dim entLine As AcadLine
Dim entPoly As AcadPolyline
Dim entLWPoly As AcadLWPolyline
Dim lenstring As String
Dim coordstart As Variant
Dim basepoint(0 To 2) As Double
Dim col As New AcadAcCmColor
Call col.SetRGB(127, 0, 0)
a = 1
For Each SOS In ThisDrawing.SelectionSets
If SOS.Name = "MySS" Then
ThisDrawing.SelectionSets("MySS").Delete
Exit For
End If
Next
intCode(0) = 0: varData(0) = "LINE,POLYLINE,LWPOLYLINE"
ThisDrawing.SelectionSets.Add ("MySS")
Set objSS = ThisDrawing.SelectionSets("MySS")
objSS.SelectOnScreen intCode, varData
If objSS.Count < 1 Then
MsgBox "No lines and polylines selected!"
Exit Sub
End If
Dim endPoint As Variant
For Each objEnt In objSS
Select Case objEnt.ObjectName
Case "AcDbLine"
Set entLine = objEnt
endPoint = entLine.endPoint
' MsgBox endPoint
lenstring = Round(entLine.Length)
'MsgBox lenstring
' Case "AcDb2dPolyline"
' Set entPoly = objEnt
' coord = entPoly.Coordinate(0)
' lenstring = Round(entPoly.Length)
' MsgBox lenstring
Case "AcDbPolyline"
Set entLWPoly = objEnt
' endPoint = entLine.endPoint
coordend = entLWPoly.Coordinate(1)
coordstart = entLWPoly.Coordinate(0)
x1 = coordstart(0)
y1 = coordstart(1)
x2 = coordend(0)
y2 = coordend(1)
'MsgBox x1 & "," & y1
midpoint = (coordend(0) + coordstart(0)) / 2 & " , " & (coordend(1) + coordstart(1)) / 2
' entLWPoly.Rotate midpoint, rotationAngle
lenstring = Round(entLWPoly.Length)
x = (coordend(0) + coordstart(0)) / 2
y = (coordend(1) + coordstart(1)) / 2
‘Collects rotation angle of line
bearing = (y2 - y1) / (x2 - x1)
bearing = Atn(bearing)
End Select
Dim textobj As AcadText
Dim textString As String
Dim insertionPoint(0 To 2) As Double
Dim height As Double
' Define the text object
textString = lenstring
insertionPoint(0) = x: insertionPoint(1) = y + 15: insertionPoint(2) = 0
height = 22
' Create the text object in model space
Set textobj = ThisDrawing.ModelSpace.AddText(textString & "m", insertionPoint, height)
textobj.Rotation = bearing
' If bearing = 0 Then
' textobj.Rotation = 0
' End If
textobj.TrueColor = col
textobj.StyleName = "ArialBold"
Next
我仍然有一个问题，，，我在VB表单中创建了所有这些，在这个表单中有许多其他用于各种目的的按钮。。。为了访问它，我使用了。lsp
(vl-load-com)(defun C:APID()(vl-vbarun
"Path\\Projectdvb!initialize"))
但是，我必须硬编码这条路。。是否可以创建一个DLL或VB表单的一些可执行文件
谢谢和问候，
普里扬卡
页:
[1]