AutoCAD顧問
還沒有註冊嗎...即日起免費註冊,所有最完整的AutoCAD討論、教學及資源都在論壇裡喔~

Join the forum, it's quick and easy

AutoCAD顧問
還沒有註冊嗎...即日起免費註冊,所有最完整的AutoCAD討論、教學及資源都在論壇裡喔~
AutoCAD顧問
Would you like to react to this message? Create an account in a few clicks or log in to continue.
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe1-113[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ioaoe110[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  2020-310[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oiu15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  2020-211[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ia15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aizyao10[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  BPl3tjj[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ziao1510
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oo-2-110[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Zuoiy_10[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aizyao11[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Iyb_1510[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe1-112[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15011[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe2da10[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe2da11[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe10

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

3 posters

向下

[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) 下載 11 次

____________________________________________________________________________________
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ioaoe110 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Zuoiy_10 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  2020-211 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aizyao11 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Iyb_1510
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aizyao10 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  BPl3tjj.png [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ziao1510 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oo-2-110 [VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oooa_110
shackle_2005
shackle_2005
初級會員
初級會員

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

回頂端 向下

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

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

超棒的VBA範例程式。

____________________________________________________________________________________
Welly Lin
wellylin
wellylin
初級會員
初級會員

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

回頂端 向下

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

發表 由 rickyyang 2022-01-19, 00:53

感謝大大無私地分享......感恩
rickyyang
rickyyang
專屬會員
專屬會員

文章總數 : 196
年齡 : 46
來自 : 台北
職業 : 營建暨室內裝修工程管理
愛好 : 喜愛黃金獵犬、哈士奇
個性 : 誠信、正義、穩健
使用年資 : 17
使用版本 : AutoCAD 2023
經驗值 : 4608
威望值 : 36
注冊日期 : 2014-11-11
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Acadad10 男 射手座 馬

回頂端 向下

回頂端


 
這個論壇的權限:
無法 在這個版面回復文章
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe1-113[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ioaoe110[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  2020-310[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oiu15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  2020-211[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ia15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aizyao10[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  BPl3tjj[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Ziao1510
[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe15010[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Oo-2-110[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Zuoiy_10[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aizyao11[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Iyb_1510[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe1-112[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Uos15011[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe2da10[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe2da11[VBA 基本訓練] 畫矩形(rectangle), 中間自動加一條中線.  Aoe10