AutoCAD顧問
還沒有註冊嗎...即日起免費註冊,所有最完整的AutoCAD討論、教學及資源都在論壇裡喔~
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oo-2-110 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ia15010 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ziao1510 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  BPl3tjj [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15010 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15011

[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.

向下

[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Empty [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.

發表 由 shackle_2005 于 2016-12-27, 11:07

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
附件
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Attachment
area_calculation_20161227.zip 您無權下載這里的附件。(11 Kb) 下載 5 次
shackle_2005
shackle_2005
初級會員
初級會員

文章總數 : 139
年齡 : 47
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 2
經驗值 : 4260
威望值 : 266
注冊日期 : 2010-09-20
男 獅子座 豬

回頂端 向下

[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Empty 回復: [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.

發表 由 wellylin 于 2017-01-05, 09:25

超棒的VBA範例程式。
wellylin
wellylin
初級會員
初級會員

文章總數 : 43
年齡 : 51
來自 : Taiwan Keelung
職業 : GIS and MIS
愛好 : Program Game
個性 : 隨和
使用年資 : 1年
使用版本 : AutoCAD Map 3D 2012
積分 : 4
經驗值 : 2830
威望值 : 62
注冊日期 : 2012-06-20
經典問與答讀者 藍鵲462號
男 處女座 羊

回頂端 向下

回頂端


 
這個論壇的權限:
無法 在這個版面回復文章
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15011 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15010 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  BPl3tjj [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ziao1510 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ia15010 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oo-2-110