土方計算-方格法(VBA)

發表於 分類於 閱讀次數：

🙌前言

本篇主要介紹利用 AutoCAD VBA 的物件操作+ Excel VBA 的工作表函數來簡化平坦地貌收方作業的過程。

土方計算是工程施作時有關於甲乙方針對土方數量時的重要依據，分為小型工程及大型工程來討論。

小型工程

土方金額佔比不高的情況下，通常契約數量多少就多少，甲乙雙方不太會有意見。

大型工程

土方金額佔比高的情況下，甲乙雙方會針對設計原始地貌進行收方作業並作成土方報告，並以此作為契約數量修正的依據，再根據結構體的設計高程及圖說指定的開挖方式重新計算挖填方數量。

計算方法選定

地形模型的建立會根據地貌狀況而定

  • 具有複雜地形特徵的地區，使用TIN(不規則三角網)
  • 地形變化相對平緩的地區，使用DEM(數字高程模型)

方格法便是使用DEM的概念，透過每個方格頂點計算方格平均高程後推算求得土方體積，高程頂點則利用IDW(反距離加權法)來進行高程賦值，插值過程會需要大量的基本運算。

有關不規則三角網另請參考筆者前文 CAD VBA@收方作業(不規則三角網法)

🎬影片操作

有收方作業的需求歡迎透過左方側邊欄內容聯繫E-mail或LINE進行諮詢。

👉實現邏輯

建立測量點(影片未出現)

  1. 將設計圖面所記錄的高程點放入工作表("DESIGN")
Fig1. 設計圖面高程
  1. 將收方作業所記錄的高程點放入工作表("CHECK")
Fig2.收方作業高程
欄位名稱 用途說明
Num 點名稱
X TWD97-E座標
Y TWD97-N座標
Z 高程
Length 與頂點的距離

此處的Length會由每一點去與range("F1")、range("G1")進行距離換算(IDW使用)

建立方格

  1. 取得計畫範圍之後，找出其邊界位置
  2. 方格會在邊界內依序繪製並與計畫範圍判釋兩多邊形位置關係
  3. 位置關係可分為下列三種
    • 計畫範圍外>>刪除
    • 計畫範圍內>>保留不動
    • 計畫範圍與之相交>>另外建立計畫範圍外部面積。(這裡會需要手動調整下)

方格編號及面積

  1. 框選所有方格及外部面積
  2. 方格由左上到右下依序編號
  3. 計算外部面積形心到所有方格的位置並指定其歸屬哪個方格
  4. 由指定內容進行面積扣除
Fig3.方格資料主要頁面
欄位名稱 用途說明
Num 方格編號
Grid_Handle 方格在CAD中的連接碼
Centroid_X 方格形心X座標
Centroid_Y 方格形心Y座標
DESIGN 平均頂點設計高程
CHECK 平均頂點收方高程
Volume 土方體積

方格頂點計算插值

  1. 匯出所有方格不重複頂點
  2. 針對每個頂點進行IDW插值
  3. 搜尋半徑預設為方格大小，計算點數預設為3點
  4. 如頂點因為高程點的分布關係無法滿足上述條件則插值為0
Fig4.方格頂點資料

方格土方體積計算

  1. 透過Grid_Handle連接該方格在CAD中的各頂點
  2. 將各頂點與設計高程座標比對計算該方格平均頂點設計高程
  3. 將各頂點與收方高程座標比對計算該方格平均頂點收方高程
  4. 由平均收方高程扣除平均設計高程與方格面積進行相乘求得方格土方體積

土方報告

將上述計算成果放入工作表("REPORT")

Fig5.土方計算書

可視化呈現

方格可以透過建立3D BOX的方式進行可視化呈現，因為高程的差異只有一點點，所以還是需要將高程倍數放大讓使用者可以更清楚掌握細節。

Fig6.土方高程差可視化呈現

除了以柱狀體方式呈現以外，也可以透過Hatch的顏色差異進行挖方填方的判釋，比如說挖方區域就給綠色，填方區域就給紅色。

👨‍🏫幾何圖學判釋

整體還有很多實現細節可以進去程式碼裡面看!完整的程式碼(包含操作軟體)取得請洽作者諮詢。

判斷點跟多邊形的關係

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Function IsPointInPolygon(X, Y, poly() As Double) As Boolean
    ' Check if a point is inside a polygon.
    ' Args:
    '   x: X coordinate of the point.
    '   y: Y coordinate of the point.
    '   poly: An array representing the vertices of the polygon.
    ' Returns:
    '   True if the point is inside the polygon, False otherwise.

    Dim i As Integer, j As Integer
    Dim numVertices As Integer
    Dim oddNodes As Boolean

    numVertices = UBound(poly) \ 2 + 1

    ' Check if the point is inside the polygon using the ray-casting algorithm
    j = numVertices - 1
    oddNodes = False
    For i = 0 To numVertices - 1
        If (poly(2 * i + 1) > Y) <> (poly(2 * j + 1) > Y) Then
            If (poly(2 * j + 1) - poly(2 * i + 1)) <> 0 Then
                If X < (poly(2 * j) - poly(2 * i)) * (Y - poly(2 * i + 1)) / (poly(2 * j + 1) - poly(2 * i + 1)) + poly(2 * i) Then
                    oddNodes = Not oddNodes
                End If
            End If
        End If
        j = i
    Next i

    ' Check if the point is exactly on a vertex or an edge
    For i = 0 To numVertices - 1
        j = (i + 1) Mod numVertices
        ' Check if the point is on a vertex
        If X = poly(2 * i) And Y = poly(2 * i + 1) Then
            IsPointInPolygon = True
            Exit Function
        End If
        ' Check if the point is on an edge
        If ((poly(2 * i + 1) <= Y And Y <= poly(2 * j + 1)) Or (poly(2 * j + 1) <= Y And Y <= poly(2 * i + 1))) And _
           (X <= myMax(poly(2 * i), poly(2 * j))) And (poly(2 * j + 1) - poly(2 * i + 1) <> 0) Then
            If X = (poly(2 * j) - poly(2 * i)) * (Y - poly(2 * i + 1)) / (poly(2 * j + 1) - poly(2 * i + 1)) + poly(2 * i) Then
                IsPointInPolygon = True
                Exit Function
            End If
        End If
    Next i

    IsPointInPolygon = oddNodes
End Function

判斷多邊形的位置關係

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Function PolygonsRelation(poly1() As Double, poly2() As Double) As String
    ' Check relation between two closed polygons.
    ' Args:
    '   poly1: An array representing the vertices of the first closed polygon.
    '   poly2: An array representing the vertices of the second closed polygon.
    ' Returns:
    '   String indicating the relation between two polygons:
    '     - "Disjoint": If polygons are disjoint.
    '     - "Contains": If poly1 contains poly2.
    '     - "Contained By": If poly2 contains poly1.
    '     - "Overlap": If polygons overlap.
    
    Dim i As Integer, j As Integer
    Dim numVertices1 As Integer, numVertices2 As Integer
    Dim containsPoly1 As Boolean, containsPoly2 As Boolean
    Dim intersects As Boolean
    Dim X As Double
    Dim Y As Double
    numVertices1 = UBound(poly1) \ 2 + 1
    numVertices2 = UBound(poly2) \ 2 + 1
    
    ' Check if one polygon is completely contained in the other
    containsPoly1 = False
    containsPoly2 = False
    For i = 0 To numVertices1 - 1 '檢查點資料是否在poly2裡面

        If IsPointInPolygon(poly1(2 * i), poly1(2 * i + 1), poly2) Then
            containsPoly1 = True
            Exit For
        End If
        
    Next i
    
    For j = 0 To numVertices2 - 1 '檢查點資料是否在poly1裡面

        If IsPointInPolygon(poly2(2 * j), poly2(2 * j + 1), poly1) Then
            containsPoly2 = True
            Exit For
        End If
    Next j
    
    ' Check if polygons are disjoint
    If Not containsPoly1 And Not containsPoly2 Then
        intersects = False
        For i = 0 To numVertices1 - 1
            For j = 0 To numVertices2 - 1
                If DoIntersect(poly1(2 * i), poly1(2 * i + 1), poly1((2 * ((i + 1) Mod numVertices1))), poly1((2 * ((i + 1) Mod numVertices1)) + 1), _
                               poly2(2 * j), poly2(2 * j + 1), poly2((2 * ((j + 1) Mod numVertices2))), poly2((2 * ((j + 1) Mod numVertices2)) + 1)) Then
                    intersects = True
                    Exit For
                End If
            Next j
            If intersects Then Exit For
        Next i
        If Not intersects Then
            PolygonsRelation = "Disjoint"
            Exit Function
        End If
    End If
    
    ' Check for containment
    If containsPoly1 And containsPoly2 Then
        PolygonsRelation = "Overlap"
    ElseIf containsPoly1 Then
        PolygonsRelation = "Contains"
    ElseIf containsPoly2 Then
        PolygonsRelation = "Contained By"
    Else
        PolygonsRelation = "Overlap"
    End If
End Function

🎯開發小結

  • 進行IDW會需要計算距離，建議透過內建函數去執行，不要從VBA算完Length之後再填儲存格，效能差很多。

  • 判定多邊形幾何關係時，需要額外考量四個頂點都在計畫範圍外但是計畫範圍有凸多邊形插在方格中的情形。

  • 電腦計算能力很強的可以將計畫範圍切成5*5的方格，但是還是要考量點資料的密度是否足夠，密度不足會導致很多頂點都是不合理的，程式會自動判釋為0

  • IDW計算時可以透過Cross Validation的方式判斷目前模型的合理程度，影響IDW有搜尋半徑、計算最少點數、距離倒數的幕次。