VBA橫斷面法面積批次處理

前言

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

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

圖層設定:

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

封閉聚合線

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

填充線

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

VBA批次處理流程

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

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

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

主要介面

橫斷面圖範例
資料庫介面

建立樁號外框

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

點選面積

面積部分有兩種實作方式

  1. 如前言所述用不同的圖層來預先定義面積歸屬項目(挖方、填方)並且透過BO或HATCH來點擊'內部點',但這樣還是免不了會有手動處理的部分。

  2. 用幾何數學方法來處理,原地面線是f(x),開挖線是g(x),開挖線先將兩端用CAD中的IntersectWith做延伸後,在用f(x)與g(x)的幾何關係計算面積,相關VBA程式碼實作如下:

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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
'===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

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
72
73
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判定樁號的形心位置後,做相對文字偏移並且加入挖方填方面積文字就可以了,這樣可以有效避免沒有圖塊的問題。

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
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

生成報告

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

土方報告成果

更多細節

有需要更多技術細節內容再請來信討論或LINE進行聯繫。