[编程交流] 根据相邻对象对齐文本

[b][font=Times New Roman][/font][/b]
[font=Times New Roman][size=3][b]‘Collects Length, Creates a text of its length at the midpoint of the line at the same rotation as line[/b]
Private Sub cmdlength_Click()
                      
On Error Resume Next
[b]‘Collects Length[/b]
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
      
[b]‘Collects rotation angle of line[/b]
      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
[/size][/font]

(vl-load-com)(defun C:APID()(vl-vbarun 
"Path\\Projectdvb!initialize"))