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

[問題]請問不規則形狀均分面積的問題

向下

[問題]請問不規則形狀均分面積的問題

發表 由 stagbeetle 于 2018-09-19, 15:20



想問問大家有什麼辦法可以畫出如圖中兩條黃線 使分割的三小塊圖形之面積相等

這是簡單地基圖的圖示 不用畫得很精準 我是用指令area慢慢土法煉鋼的畫 誤差很大 好奇有沒有辦法準確的畫出來 謝謝
avatar
stagbeetle
一般會員
一般會員

文章總數 : 64
年齡 : 33
來自 : taipei
職業 : worker
愛好 : bug
個性 : delightful
使用年資 : 1
使用版本 : 2013
經驗值 : 2478
威望值 : 12
注冊日期 : 2013-03-20
男 雙魚座 牛

回頂端 向下

回復: [問題]請問不規則形狀均分面積的問題

發表 由 Tiger&蘋果爸 于 2018-09-25, 10:30

畫出二條黃線讓面積相等
我應該也是使用土法煉鋼的畫
只能概略無法精確

____________________________________________________________________________________
avatar
Tiger&蘋果爸
系統管理員
系統管理員

文章總數 : 18093
年齡 : 42
來自 : 台北市文山區
職業 : AutoCAD顧問
愛好 : 蹓狗/戶外活動/拍照
個性 : 幽默/樂觀/善良
使用年資 : 15↑
使用版本 : AutoCAD 2016
經驗值 : 69526
威望值 : 13435
注冊日期 : 2008-04-23
2D基礎函授 2D進階函授 3D基礎函授 https://i.servimg.com/u/f11/19/71/67/71/2d3d10.png2D+3D線上 顧問外掛程式 經典問與答讀者 藍鵲1號
2009聚會勳章 2010聚會勳章 2011聚會勳章 2012聚會勳章 2013勳章-2D基礎 2014聚會勳章 2015聚會勳章 2016聚會勳章 串連貼紙成功 男 水瓶座 兔

http://mypaper.pchome.com.tw/kv1012tiger

回頂端 向下

回復: [問題]請問不規則形狀均分面積的問題

發表 由 naruto018 于 2018-09-25, 11:54

有找到2個,沒找到免費的

這個有試用版
詳細介紹
試用版下載


這個要錢
詳細介紹
avatar
naruto018
初級會員
初級會員

文章總數 : 124
年齡 : 26
來自 : 高雄
職業 : 學習中(CAD,Revit,Excel VBA)
愛好 : 當個懶熊
個性 : 內向
使用年資 : 新手
使用版本 : 2015
AutoCAD基礎篇等級 : 10星級
積分 : 3
經驗值 : 1521
威望值 : 198
注冊日期 : 2016-11-29
藍鵲726號
男 摩羯座 羊

回頂端 向下

VBA 隨便寫的, 不曉得對不對. 參考一下..........

發表 由 shackle_2005 于 2018-09-26, 01:12

Option Explicit

Public tm As AcadModelSpace
Public tu As AcadUtility
Public pi  As Double

Public Sub test()

On Error Resume Next

Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

pi = 3.141592 / 180

Dim land As AcadLWPolyline
Dim i_count As Integer
Dim min_p As Variant
Dim max_p As Variant
Dim new_area As Double
Dim p1(0 To 2) As Double
Dim p2 As Variant
Dim cut_line As AcadLine
Dim total_area As Double
Dim obj As AcadObject
Dim pick_p As Variant

total_area = 0

'Set land = ThisDrawing.HandleToObject("242")

tu.GetEntity obj, pick_p, "請選取二D 聚合線 !!"

If Err Then Exit Sub

Set land = obj

land.GetBoundingBox min_p, max_p

' 左到右 **************************************************************************************
For i_count = min_p(0) To max_p(0) Step 1

   If total_area - land.Area / 3 > 0 Then
     
      p1(0) = i_count: p1(1) = min_p(1)
     
      p2 = tu.PolarPoint(p1, 90 * pi, max_p(1) - min_p(1))
     
      Set cut_line = tm.AddLine(p1, p2): cut_line.color = 1: cut_line.Update
     
      Exit For
   End If
   
   total_area = total_area + get_area_process(land, i_count, min_p, max_p)
Next i_count

second:

total_area = 0

' 右到左 *************************************************************************************
For i_count = max_p(0) To min_p(0) Step -1

   If total_area - land.Area / 3 > 0 Then
     
      p1(0) = i_count: p1(1) = min_p(1)
     
      p2 = tu.PolarPoint(p1, 90 * pi, max_p(1) - min_p(1))
     
      Set cut_line = tm.AddLine(p1, p2): cut_line.color = 1: cut_line.Update
           
      End
   End If
   
   total_area = total_area + get_area_process(land, i_count, min_p, max_p)
   
Next i_count

End Sub

Private Function get_area_process(land, i_count, min_p, max_p) As Double

On Error Resume Next

Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
Dim cut_line As AcadLine
Dim int_p1 As Variant
Dim int_p2 As Variant
Dim int_points As Variant
Dim p3(0 To 2) As Double
Dim p4(0 To 2) As Double
Dim mid_line As AcadLine
Dim mid_p(0 To 2) As Double
Dim p5 As Variant
Dim cir As AcadCircle
Dim insert_p_str As String
Dim new_land As AcadLWPolyline

p1(0) = i_count: p1(1) = min_p(1)
p2(0) = p1(0): p2(1) = max_p(1)

Set cut_line = tm.AddLine(p1, p2): cut_line.color = 1: cut_line.Update

int_points = land.IntersectWith(cut_line, acExtendNone)

If UBound(int_points) = 5 Then
 
  p3(0) = int_points(0): p3(1) = int_points(1)
  p4(0) = int_points(3): p4(1) = int_points(4)
 
  Set mid_line = tm.AddLine(p3, p4): mid_line.color = 2: mid_line.Update
 
  get_area_process = mid_line.Length
 
  mid_line.Delete
     
End If

cut_line.Delete

End Function
附件
area_cutting_process.zip 您無權下載這里的附件。(11 Kb) 下載 1 次
avatar
shackle_2005
初級會員
初級會員

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

回頂端 向下

回復: [問題]請問不規則形狀均分面積的問題

發表 由 stagbeetle 于 2018-09-26, 15:28

naruto018 寫到:有找到2個,沒找到免費的

這個有試用版
詳細介紹
試用版下載


這個要錢
詳細介紹

太感謝了 下載來玩看看 上面隨便丟了個問題給我 要我大概畫一下 浪費了很多時間土法煉鋼 嘆氣
avatar
stagbeetle
一般會員
一般會員

文章總數 : 64
年齡 : 33
來自 : taipei
職業 : worker
愛好 : bug
個性 : delightful
使用年資 : 1
使用版本 : 2013
經驗值 : 2478
威望值 : 12
注冊日期 : 2013-03-20
男 雙魚座 牛

回頂端 向下

回復: [問題]請問不規則形狀均分面積的問題

發表 由 stagbeetle 于 2018-09-26, 15:32

to shackle大大
我目前的程度看這些算是無字天書 太厲害了 有時間研究看看 感謝您的分享 竊喜
avatar
stagbeetle
一般會員
一般會員

文章總數 : 64
年齡 : 33
來自 : taipei
職業 : worker
愛好 : bug
個性 : delightful
使用年資 : 1
使用版本 : 2013
經驗值 : 2478
威望值 : 12
注冊日期 : 2013-03-20
男 雙魚座 牛

回頂端 向下

回復: [問題]請問不規則形狀均分面積的問題

發表 由 shackle_2005 于 2018-09-26, 16:14

不用看程式碼, 下載附件程式檔案 area_cutting_process.dvb ---> 管理 ----> 執行 VBA 程式. 就可以了, 參考一下.........
avatar
shackle_2005
初級會員
初級會員

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

回頂端 向下

回頂端


 
這個論壇的權限:
無法 在這個版面回復文章