［問題］請問不規則形狀均分面積的問題

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

這是簡單地基圖的圖示 不用畫得很精準　我是用指令ａｒｅａ慢慢土法煉鋼的畫　誤差很大　好奇有沒有辦法準確的畫出來　謝謝

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

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

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


這個要錢
詳細介紹

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

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

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


這個要錢
詳細介紹

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

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

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

好像不能輸入任意數量

\

Option Explicit

Public tm As AcadModelSpace ' 設 tm 簡化名稱圖紙空間
Public tu As AcadUtility
Public pi As Double

Public Sub area_cutting()

On Error Resume Next

ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr
ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
pi = 3.141592 / 180

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

Dim area_obj As AcadLWPolyline ' 定義 area_obj 變數為一條 2D 輕量聚合線
Dim cutting_num As Integer
Dim min_p As Variant
Dim max_p As Variant
Dim cutting_area As Double
Dim i_count As Integer
Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
Dim line_obj As AcadLine
Dim area_number As Double
Dim int_p As Variant
Dim cutting_times As Integer
Dim pick_p As Variant
Dim int_p1(0 To 2) As Double
Dim int_p2(0 To 2) As Double

area_number = 0: cutting_times = 0

tu.GetEntity area_obj, pick_p, "請選取 2D 聚合線 ! ............... "

If Err Then Exit Sub

area_obj.GetBoundingBox min_p, max_p ' 取得面積本體左下角及右上角座標

ZoomWindow min_p, max_p

cutting_num = tu.GetInteger("請輸入切割份數 ! ............ ")

If Err Then Exit Sub

cutting_area = Int(area_obj.Area / cutting_num)

For i_count = 1 To max_p(0) - min_p(0) ' 從左下角掃描到右上角

   p1(0) = min_p(0) + i_count: p1(1) = min_p(1): p2(0) = min_p(0) + i_count: p2(1) = max_p(1) ' 畫一條垂直線
   
   Set line_obj = tm.AddLine(p1, p2): line_obj.Color = 2: line_obj.Update
   
   int_p = line_obj.IntersectWith(area_obj, acExtendNone): line_obj.Delete ' 跟面積本體聚合線求兩個交點
   
   If UBound(int_p) = 5 Then
     
      area_number = area_number + Abs(int_p(1) - int_p(4)) ' 把線長一條一條加起來就是面積

      If area_number > cutting_area Then ' 如果總和大於分割的單獨面積就停止
     
         int_p1(0) = int_p(0): int_p1(1) = int_p(1): int_p2(0) = int_p(3): int_p2(1) = int_p(4)
     
         Set line_obj = tm.AddLine(int_p1, int_p2): line_obj.Color = 1: line_obj.Update
     
         area_number = 0: cutting_times = cutting_times + 1 ' 總和面積歸零準備下一個分割
      End If
   End If
   
   If cutting_times = cutting_num - 1 Then Exit For
Next i_count

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

End Sub

太棒了 可分任意
等分 等分的面積稍稍不同但很棒了感謝!!