[討論]矩形，多邊形，不規則多邊形--邊長標註尺寸

最近工作的關係~~~需要算大量的數量
遇到不少多邊形跟不規則的矩形.....在標註上出現了不少問題
怎像才能夠像圖片這樣標註
把不規則矩形跟多邊形的邊長都標註出來...
希望各位大大幫幫忙

很想學VBA自己作方便的小程式
無奈不是學程式設計的~~~VBA的書也買了好幾本~~真的是有看沒有懂

kid530 寫到:

隱藏的代碼是明經通道Gu_xl寫的Lisp，如果標示的方向內外相反的話，是因為Pline的順、逆時針方向的緣故，轉個向就好了！
指令：tt
可一次選多條Pline

發生錯誤了~~~

指令: TT
字高<10.0>20
選取物件: 找到 1 個
選取物件:
; 錯誤: no function definition: VLAX-CURVE-GETENDPARAM


指令: TT
字高<10.0>20
選取物件: 找到 1 個
選取物件: 找到 1 個，共 2
選取物件: ; 錯誤: no function definition: VLAX-CURVE-GETENDPARAM

少了一句
(vl-load-com)

重新再抓一次，我重新加進去了！

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

Public Sub dim_pline()

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 lw_line As AcadLWPolyline
Dim coord As Variant
Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
Dim line_angle As Double
Dim temp_line As AcadLine
Dim line_length As Double
Dim mid_p As Variant
Dim text_obj As AcadText
Dim i_count As Integer

Do While True

tu.GetEntity lw_line, "請選擇 2D 聚合線 !! 按 Esc 鍵離開........."

If Err Then Exit Do

coord = lw_line.Coordinates ' 取得 2D 聚合線的 X, Y 座標

' 從聚合線的第一段開始標長度, 到最後一段.
For i_count = 0 To (UBound(coord) + 1) / 2 - 1 ' (Ubound(coord) + 1) / 2 -1 是在算聚合線有幾個端點
     
   p1(0) = coord(i_count * 2): p1(1) = coord(i_count * 2 + 1) ' 取得第一個點
   
   ' 取得第二個點, 假如第一個點是聚合線的尾端, 那第二點就是聚合線的首端.
   If i_count = (UBound(coord) + 1) / 2 - 1 Then
      p2(0) = coord(0): p2(1) = coord(1)
   Else
      p2(0) = coord((i_count + 1) * 2): p2(1) = coord((i_count + 1) * 2 + 1)
   End If
   
   Set temp_line = tm.AddLine(p1, p2) ' 畫一條假功能的直線取得線長及角度
   
   line_angle = temp_line.angle: line_length = Int(temp_line.Length * 10) / 10
   
   mid_p = tu.PolarPoint(p1, line_angle, line_length / 2) ' 取得線段的中點
   
   Set text_obj = tm.AddText(line_length, mid_p, 10): text_obj.Update ' 標上長度

   temp_line.Delete
Next i_count

Loop

ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

End Sub

感謝Atsai熱心分享~~~減少我很多工作的時間
測試完成~~~結果相當方便
也感謝這個論壇讓我在有問題的時候能得到解決
也感謝shackle_2005的補充教學
雖然我還是看不懂
但是對於懂的人應該有很大的幫助
感謝再感謝~~~~

謝謝shackle_2005熱心分享VBA程式~感恩

謝謝 kid530, im2016. 任何有關 VBA 的問題, 歡迎提出來大家一起討論. 3Q