[討論]分享即時顯示聚合線長度LISP-VBA版本

我把線段長度移到中間並隨著聚合線角度旋轉. 參考一下!! 20161214 : 修定, 原來長度再加上整條聚合線的總長. lw_line_length_20161214.dvb. 20161215 修正 : 把長度文字旋轉轉正. pline_length_20161215

Public tm As AcadModelSpace ' 定義 tm, tu 為公共變數
Public tu As AcadUtility
Public Const pi = 3.141592 / 180 ' 直接用 pi 代表

Option Explicit

Public Sub lw_line_auto_dim()

ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr

On Error Resume Next

' 設定 tm 為這張圖面的模型空間, 設定 tu 為這張圖面的公用程式
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

Dim start_p As Variant
Dim end_p As Variant
Dim lw_line As AcadLWPolyline
Dim plineObj As AcadLWPolyline
Dim points(0 To 3) As Double
Dim text_obj As AcadText
Dim p2 As Variant
Dim p3 As Variant
Dim line_obj As AcadLine
Dim index_pline As Integer
Dim third_p As Variant

start_p = tu.GetPoint(, "輸入聚合線起點....")

If Err Then Exit Sub

end_p = tu.GetPoint(start_p, "輸入點.........")

If Err Then Exit Sub

' Define the 2D polyline points
points(0) = start_p(0): points(1) = start_p(1)
points(2) = end_p(0): points(3) = end_p(1)

' Create a lightweight Polyline object in model space
Set plineObj = tm.AddLightWeightPolyline(points)

line_text_process start_p, end_p

Do While True

index_pline = (UBound(plineObj.Coordinates) + 1) / 2

third_p = tu.GetPoint(end_p, "輸入點.........")

If Err Then Exit Sub

' Define the new vertex
Dim newVertex(0 To 1) As Double
newVertex(0) = third_p(0): newVertex(1) = third_p(1)

' Add the vertex to the polyline
plineObj.AddVertex index_pline, newVertex
plineObj.Update

line_text_process end_p, third_p

end_p = third_p

Loop

set_nothing_process ' 記憶體釋放
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

End Sub

Private Sub line_text_process(ByVal start_p As Variant, ByVal end_p As Variant)

Dim line_obj As AcadLine
Dim p2 As Variant
Dim p3 As Variant
Dim text_obj As AcadText

Set line_obj = tm.AddLine(start_p, end_p)

p2 = tu.PolarPoint(start_p, line_obj.angle, line_obj.Length / 2)
p3 = tu.PolarPoint(p2, line_obj.angle - 90 / pi, 5)

Set text_obj = tm.AddText(Int(line_obj.Length), p3, line_obj.Length / 10)

text_obj.Rotation = line_obj.angle: text_obj.Update: line_obj.Delete

End Sub


Private Sub set_nothing_process()
Set tm = Nothing: Set tu = Nothing: Set ent_set = Nothing
End Sub

這位前輩,
你真的很厲害呢!

devinchou 寫到:這位前輩,
你真的很厲害呢!

不客氣. Lisp, VBA 應該都可以. 但我的經驗 VBA 很方便, 建議大家可以試試.

感謝大大無私地分享......感恩