VBA橫斷面法面積批次處理

發表於 2024-07-04 分類於專案開發閱讀次數：

前言

工程特性如為帶狀工程，比如:水溝、道路等等，通常會以橫斷面法作為土方計算的數量依據，此指土方計算不外乎為:挖方、填方、回填方、CLSM之類。

在繪製土方基本資料時，面積的框選便會是決定數量很重要的部分，實務上的土方計算流程為:

圖層設定:

原地面線
結構線
開挖線
填方線
開挖面積
挖方面積

繪製挖方面積時，將原地面線與開挖線隔離顯示，透過BO或HATCH生成面積
繪製填方面積時，將回填線、結構線、開挖線隔離顯示，透過BO或HATCH生成面積

封閉聚合線

CAD內建指令'BO'會出現一張介面，可以藉由點選內部點生成封閉聚合線，指令'-BO'則可以略過介面的程序直接點選，此時封閉聚合線會有'面積'屬性。

填充線

CAD內建指令'HATCH'可以點選內部點生成填充線，此時填充線會有'面積'屬性，須注意之前測試過HATCH可能會有些許的誤差，這個也不清楚原因為何...

VBA批次處理流程

正常的作業流程會將每一個樁號底下的面積逐筆紀錄作加總，算完的數據會修改到橫斷面上所記載的挖方面積數字、填方面積數字，後續再將這些數字填報到土方計算表，稍有恍神則容易出錯，也因此若這些內容都可以用CAD中對應圖元的面積屬性進行處理，並且將資料傳輸到土方計算表及回歸到圖面修訂記載數字，這會讓整個土方計算作業簡單很多。

目標為希望能夠框選一次範圍，就將所有的面積計算完畢並且放置於對應的樁號，省下作業時間!!!

要將圖面進行批次處理時，會需要進行下列步驟搭配VBA執行便能順利完成

主要介面

建立樁號外框

每一個橫斷面圖都會有它所代表的樁號名稱及橫斷面圖範圍(此處是指BORDER欄位)，將外框完成之後做適當的放大縮小，目標是讓所有與該樁號相關的土方面積'形心'都能被完整包覆在框框裡面，後續要判斷面積歸屬時可以順利執行。

點選面積

面積部分有兩種實作方式

如前言所述用不同的圖層來預先定義面積歸屬項目(挖方、填方)並且透過BO或HATCH來點擊'內部點'，但這樣還是免不了會有手動處理的部分。
用幾何數學方法來處理，原地面線是f(x)，開挖線是g(x)，開挖線先將兩端用CAD中的IntersectWith做延伸後，在用f(x)與g(x)的幾何關係計算面積，相關VBA程式碼實作如下:

'===Main Function===

Sub plotDigLine(ByVal EG As Object, ByVal EGVertices)

Dim IsIntersect As Boolean

Call CAD.GetBoundingBox(buttomCONC, MinX, MinY, MaxX, MaxY)

Dim vertices(4 * 2 - 1) As Double

vertices(0) = MinX - 300 - 30
vertices(1) = MinY + 100
vertices(2) = MinX - 300
vertices(3) = MinY
vertices(4) = MaxX + 300
vertices(5) = MinY
vertices(6) = MaxX + 300 + 30
vertices(7) = MinY + 100

Set DL = CAD.AddLWPolyLine(vertices)
Call CAD.setLayer(DL, "CAL")
'DL.Layer = "CAL" ' "橫斷面-挖方線"

retpt = myFunc.SortPTArray(CAD.IntersectWith(DL, EG, 1, IsIntersect))

If IsIntersect = False Then Exit Sub

vertices(0) = retpt(0, 0)
vertices(1) = retpt(0, 1)

vertices(6) = retpt(UBound(retpt, 1), 0) '- 3 + 1)
vertices(7) = retpt(UBound(retpt, 1), 1) '- 3 + 2)

'========以邊界為基準================

'vertices(0) = EGVertices(0)
'vertices(1) = EGVertices(1)
'vertices(6) = EGVertices(UBound(EGVertices) - 1)
'vertices(7) = EGVertices(UBound(EGVertices))

'====================================

DL.Delete

Set DL2 = CAD.AddLWPolyLine(vertices)

DL2.Layer = "CAL" '"橫斷面-挖方線"

'============匯入挖方面積==================

Dim stoneObj As New clsStone

DLArea = stoneObj.getDLArea(EG, DL2)

With Sheets("中心線")
    
    Set rng = .Columns(1).Find(loc)
    
    If Not rng Is Nothing Then
    
    r = rng.Row
    .Cells(r, 5) = DLArea
    
    End If

End With

End Sub

'====clsCAD===

Function IntersectWith(ByVal PL1, ByVal PL2, ByVal mode As Byte, ByRef IsIntersect As Boolean)

IsIntersect = False

Dim coll As New Collection

If CADVer = "ICAD" Then
    
    On Error GoTo ERRORHANDLE '20210901 錯誤偵測
    Set retpt = PL1.IntersectWith(PL2, mode) 'acExtendThisEntity)
    
    For Each it In retpt
    
        coll.Add it.x
        coll.Add it.y
        coll.Add it.Z
    
    Next
    
    If coll Is Nothing Then
ERRORHANDLE:
        'intersectWith = "EMPTY"
    Else
        IntersectWith = myFunc.tranColl2Array(coll)
        IsIntersect = True
    End If
    
Else

    retpt = PL1.IntersectWith(PL2, mode) 'acExtendThisEntity)
    
    If UBound(retpt) = -1 Then
       ' IntersectWith = "EMPTY"
    Else
        IntersectWith = retpt
        IsIntersect = True
    End If

End If


End Function

'====clsStone===

'TODO:
'1.sort X coordinate
'2.define border
'3.decide X-value

Function getDLArea(ByVal EG, ByVal DL)

Set PLobj1 = RevisePL(EG)
EG.Delete

PL1_X = myFunc.tranColl2Array(getcoll(PLobj1, "X"))
PL1_Y = myFunc.tranColl2Array(getcoll(PLobj1, "Y"))

Set PLobj2 = RevisePL(DL)
DL.Delete

PL2_X = myFunc.tranColl2Array(getcoll(PLobj2, "X"))
PL2_Y = myFunc.tranColl2Array(getcoll(PLobj2, "Y"))

Call defineBorder(PL1_X, PL2_X, BL, BR)

getDLArea = calculateArea_test(PL1_X, PL1_Y, PL2_X, PL2_Y, BL, BR)

End Function

Function RevisePL(ByVal PLobj) '由左至右排序

Dim coll As New Collection

co = 3
If TypeName(PLobj) Like "*LWPolyline" Then co = 2  'IIcadLightWeightPolyline

arr = CAD.tranIPoints(PLobj.coordinates)

Debug.Print TypeName(PLobj)

X1 = arr(0)
Xn = arr(UBound(arr) - co + 1)

If X1 > Xn Then
    Set RevisePL = CAD.ReverseLine(ByVal PLobj)
Else
    Set RevisePL = PLobj
End If

For i = 0 To UBound(arr) - co Step co

    X1 = arr(i)
    X2 = arr(i + co)
    
    If X1 = X2 Then arr(i + co) = arr(i + co) + 0.001 '若為垂直則微調往右偏移

Next

Set RevisePL = CAD.AddLWPolyLine(arr)
RevisePL.Layer = PLobj.Layer

End Function

Function calculateArea_test(ByVal PL1_X, ByVal PL1_Y, ByVal PL2_X, ByVal PL2_Y, ByVal BL, ByVal BR)

X_sort = myFunc.BubbleSort_array(myFunc.combineArray(PL1_X, PL2_X))

For i = LBound(X_sort) To UBound(X_sort) - 1
    
    X1 = X_sort(i)
    X2 = X_sort(i + 1)
    
    dx = X2 - X1
    
    If X1 >= BL And X2 <= BR Then
        
        Y1f = getYbyX(X1, PL1_X, PL1_Y)
        Y2f = getYbyX(X1, PL2_X, PL2_Y)
        
        dYf = Y1f - Y2f
        
        Y1b = getYbyX(X2, PL1_X, PL1_Y)
        Y2b = getYbyX(X2, PL2_X, PL2_Y)
        
        dYb = Y1b - Y2b

        If dYf > 0 And dYb < 0 Then '與基準線交叉(正到負)
        
            X_intersect = getIntersectX(X1, X2, Y1f, Y1b, Y2f, Y2b)
            dA = dYf * (X_intersect - X1) / 2
            'Set lineObj = CAD.AddLineCO(X1, Y1f, X1, Y2f)
            
        ElseIf dYf < 0 And dYb > 0 Then '與基準線交叉(負到正)
        
            X_intersect = getIntersectX(X1, X2, Y1f, Y1b, Y2f, Y2b)
            dA = dYb * (X2 - X_intersect) / 2
            'Set lineObj = CAD.AddLineCO(X2, Y1b, X2, Y2b)
            
        ElseIf dYf >= 0 And dYb >= 0 Then '皆在基準線下方
        
            dA = (dYf + dYb) * dx / 2
            'Set lineObj = CAD.AddLineCO(X1, Y1f, X1, Y2f)
            'Set lineObj = CAD.AddLineCO(X2, Y1b, X2, Y2b)
        
        Else
            dA = 0
        
        End If
        
        'Debug.Print "dYf=" & dYf & ",dYb=" & dYb & ",dA=" & dA
        sA = sA + dA
        
    End If
    
Next

calculateArea_test = Round(sA / 1000000, 2)

End Function

Function getIntersectX(ByVal X1 As Double, ByVal X2 As Double, _
                        ByVal Y1f As Double, ByVal Y1b As Double, _
                        ByVal Y2f As Double, ByVal Y2b As Double)

dx = X2 - X1

y1_slope = (Y1b - Y1f) / dx
y2_slope = (Y2b - Y2f) / dx

slope_change = Abs(y1_slope - y2_slope)
dY_f = Abs(Y1f - Y2f)

getIntersectX = X1 + dY_f / slope_change

End Function

Function getYbyX(ByVal x As Double, ByVal PL_X, ByVal PL_Y)

For i = LBound(PL_X) To UBound(PL_X) - 1
    
    X1 = PL_X(i)
    X2 = PL_X(i + 1)
    Y1 = PL_Y(i)
    Y2 = PL_Y(i + 1)
    
    If X1 = X2 Then X2 = X2 + 0.001: Stop
    
    If x >= X1 And x <= X2 Then
        
        s1 = x - X1
        s2 = X2 - x
        getYbyX = (s1 * Y2 + s2 * Y1) / (s1 + s2)
        
        Exit For
      
    End If
    
Next

End Function

判斷面積歸屬

面積歸屬的判定方法為該封閉聚合線的形心點或填充線的形心點位於哪個樁號外框中，判定屬於哪個外框後取出面積並做挖方加總或填方加總(看取出的圖層是哪一種)，關於點與外框的位置判定關係請參考下列程式碼:

此處範例是用HATCH的面積取出其值，ssetAreas先做好Hatch的篩選才進行後續內容，有需要者可以改用polyline

Sub CalcCABA() '20210720 update

Set ssetAreas = CAD.CreateSSET("HA", "0", "Hatch")

For Each ssetArea In ssetAreas

    'TODO:
    '1.getMidPoint
    '2.searchLoc
    '3.getAreaCol
    '4.keyinArea
    
    r = getRowFromBorder(ssetArea)
    c = getColFromLayerName(ssetArea)
    
    If r <> "" And c <> "" Then shtCL.Cells(r, c) = ssetArea.area / 1000000

Next

End Sub

Function getColFromLayerName(ByVal ha)

With shtCL

    CD = ha.Layer '橫斷面-挖方
    
    targetColName = Split(CD, "-")(1)

    Set rng = .Rows(2).Find(targetColName)
    
    getColFromLayerName = rng.Column

End With

End Function

Function getRowFromBorder(ByVal ha)

    Call CAD.GetBoundingBox(ha, MinX, MinY, MaxX, MaxY)
    midX = (MinX + MaxX) / 2
    midY = (MinY + MaxY) / 2

    With shtCL

        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    
        For r = 3 To lr
        
            BorderPTs = Split(.Cells(r, 3), ",")
            
            If UBound(BorderPTs) = 3 Then
        
                Border_minX = CDbl(BorderPTs(0))
                Border_minY = CDbl(BorderPTs(1))
                Border_maxX = CDbl(BorderPTs(2))
                Border_maxY = CDbl(BorderPTs(3))
                
                If midX >= Border_minX And midX <= Border_maxX And midY >= Border_minY And midY <= Border_maxY Then
                    
                    getRowFromBorder = r
                    Exit For
                    
                End If
            
            End If
            
        Next

    End With

End Function

數據回歸圖面

我這裡是採用屬性圖塊方式處理，如果不要那麼麻煩也可以用最簡單的text判定樁號的形心位置後，做相對文字偏移並且加入挖方填方面積文字就可以了，這樣可以有效避免沒有圖塊的問題。

Sub DrawCABA_Main() '將橫斷面說明的CL、CA、BA刪除後重整

Set sset = CAD.CreateSSET("Title", "8", "TITLE")

For Each it In sset
        
    If TypeName(it) = "IAcadBlockReference" Then
    
        myAttr = it.GetAttributes
        HSecLoc = myAttr(0).TextString
        
        s = returnCABA(HSecLoc)
        
        tmp = Split(s, ",")
        
        myAttr(1).TextString = tmp(0)
        myAttr(2).TextString = "挖方=" & Round(tmp(1), 2) & " m2"
        myAttr(3).TextString = "填方=" & Round(tmp(2), 2) & " m2"
        'myAttr(4).TextString = "CLSM=" & Round(tmp(3), 2) & " m2"
        
    
    End If

ERRORHANDLE:

Next

End Sub

Private Function returnCABA(ByVal HSecLoc As String)

With shtCL

    Set rng = .Cells.Find(HSecLoc)
    
    r = rng.Row
    
    deltaH = .Cells(r, 2 + 2)
    CA = .Cells(r, 3 + 2)
    BA = .Cells(r, 4 + 2)
    RA = .Cells(r, 5 + 2)
    
    returnCABA = deltaH & "," & CA & "," & BA & "," & RA

End With

End Function

生成報告

這裡就是單純的對格子塞資料計算總數而已，僅提供成果供參。

前言