[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.
3 posters
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第1頁(共1頁)
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.
Public Const pi = 3.141592 / 180
Option Explicit
Public Sub rect_line()
ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr
On Error Resume Next
Dim tm As AcadModelSpace
Dim tu As AcadUtility
Dim insert_p As Variant
Dim p2 As Variant
Dim first_angle As Double
Dim second_angle As Double
Dim p3 As Variant
Dim p4 As Variant
Dim rect_heigth As Double
Dim rect_width As Double
Dim cir As AcadCircle
Dim line_obj As AcadLine
Dim insert_str As String
Dim p2_str As String
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
' input 2 corners of rectangle
insert_p = tu.GetPoint(, "first corner !!....... ")
If Err Then Exit Sub
p2 = tu.GetCorner(insert_p, "second corner !!.....")
If Err Then Exit Sub
' get the height and width of rectangle
rect_heigth = Abs(p2(1) - insert_p(1)): rect_width = Abs(p2(0) - insert_p(0))
' turn coordinate number to string for sendcommand to draw rectangle
insert_str = Trim(Str(insert_p(0))) & "," & Trim(Str(insert_p(1)))
p2_str = Trim(Str(p2(0))) & "," & Trim(Str(p2(1)))
ThisDrawing.SendCommand "rectangle" & vbCr & insert_str & vbCr & p2_str & vbCr
' judge second corner on which corner, right-up, right-down, left-up, left-down
If p2(0) > insert_p(0) And p2(1) > insert_p(1) Then first_angle = 90 * pi: second_angle = 0
If p2(0) < insert_p(0) And p2(1) > insert_p(1) Then first_angle = 90 * pi: second_angle = 180 * pi
If p2(0) < insert_p(0) And p2(1) < insert_p(1) Then first_angle = 270 * pi: second_angle = 180 * pi
If p2(0) > insert_p(0) And p2(1) < insert_p(1) Then first_angle = 270 * pi: second_angle = 0
' get line startpoint and endpoint
p3 = tu.PolarPoint(insert_p, first_angle, rect_heigth / 2)
p4 = tu.PolarPoint(p3, second_angle, rect_width)
Set line_obj = tm.AddLine(p3, p4): line_obj.Update
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr
End Sub
Option Explicit
Public Sub rect_line()
ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr
On Error Resume Next
Dim tm As AcadModelSpace
Dim tu As AcadUtility
Dim insert_p As Variant
Dim p2 As Variant
Dim first_angle As Double
Dim second_angle As Double
Dim p3 As Variant
Dim p4 As Variant
Dim rect_heigth As Double
Dim rect_width As Double
Dim cir As AcadCircle
Dim line_obj As AcadLine
Dim insert_str As String
Dim p2_str As String
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
' input 2 corners of rectangle
insert_p = tu.GetPoint(, "first corner !!....... ")
If Err Then Exit Sub
p2 = tu.GetCorner(insert_p, "second corner !!.....")
If Err Then Exit Sub
' get the height and width of rectangle
rect_heigth = Abs(p2(1) - insert_p(1)): rect_width = Abs(p2(0) - insert_p(0))
' turn coordinate number to string for sendcommand to draw rectangle
insert_str = Trim(Str(insert_p(0))) & "," & Trim(Str(insert_p(1)))
p2_str = Trim(Str(p2(0))) & "," & Trim(Str(p2(1)))
ThisDrawing.SendCommand "rectangle" & vbCr & insert_str & vbCr & p2_str & vbCr
' judge second corner on which corner, right-up, right-down, left-up, left-down
If p2(0) > insert_p(0) And p2(1) > insert_p(1) Then first_angle = 90 * pi: second_angle = 0
If p2(0) < insert_p(0) And p2(1) > insert_p(1) Then first_angle = 90 * pi: second_angle = 180 * pi
If p2(0) < insert_p(0) And p2(1) < insert_p(1) Then first_angle = 270 * pi: second_angle = 180 * pi
If p2(0) > insert_p(0) And p2(1) < insert_p(1) Then first_angle = 270 * pi: second_angle = 0
' get line startpoint and endpoint
p3 = tu.PolarPoint(insert_p, first_angle, rect_heigth / 2)
p4 = tu.PolarPoint(p3, second_angle, rect_width)
Set line_obj = tm.AddLine(p3, p4): line_obj.Update
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr
End Sub
- 附件
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6775
威望值 : 361
注冊日期 : 2010-09-20
回復: [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.
超棒的VBA範例程式。
____________________________________________________________________________________
Welly Lin
wellylin- 初級會員
- 文章總數 : 43
年齡 : 57
來自 : Taiwan Keelung
職業 : GIS and MIS
愛好 : Program Game
個性 : 隨和
使用年資 : 1年
使用版本 : AutoCAD Map 3D 2012
積分 : 4
經驗值 : 4797
威望值 : 62
注冊日期 : 2012-06-20
回復: [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.
感謝大大無私地分享......感恩
rickyyang- 專屬會員
- 文章總數 : 196
年齡 : 46
來自 : 台北
職業 : 營建暨室內裝修工程管理
愛好 : 喜愛黃金獵犬、哈士奇
個性 : 誠信、正義、穩健
使用年資 : 17
使用版本 : AutoCAD 2023
經驗值 : 4608
威望值 : 36
注冊日期 : 2014-11-11
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第1頁(共1頁)
這個論壇的權限:
您 無法 在這個版面回復文章