AutoCAD VBA 橫斷面繪製自動化(疏濬用)

新版本請參考 VBA @ 一般渠道疏濬圖

 前言：

因應筆者所在的灌溉給水區域為濁水系統，外加上坡度比較緩和，常需要有疏濬的工作要執行，每次在計算疏濬土方量的時候，畫一下縱橫斷面也是不可避免的。現地的狀況由該擔當區的人員最能理解土方分布情況，但又受限於繪製CAD斷面也是一門學問，因而引發我寫了一個side project將原本在CAD中設定斷面高程的部分以Excel表的形式代替，爾後再由CAD中的dvb檔去連結設定檔，達到參數化製圖的目的。



使用方法：

1. 設定該灌溉系統的起訖點、渠道形式(U型溝、內面工)及尺寸(Unit:M)。

圖一、排序必須由上到下遞增，不能有空白。

2. 點選 "斷面填寫" 後依照指示填寫。(會先偵測前次的最後樁號，填入樁號需比它後面)

圖二、Buttom位於工作表1:橫斷面繪製資料。

P.S:如左側有剩餘資料，請先點選 "刪除資料"。

3. 填寫時若是板橋、箱涵等較難疏濬的地方，請在樁號填寫上or下，代表上斷面or下斷面

4. 填寫左右環境參數後、各點高程以及是否為結束點(END?)，如已知下一個的樁號可填寫 下      一個間距，點按OK後不會再進行詢問。

圖三、Excel VBA中的userform。

P.S2:結束點代表為板橋或箱涵的上斷面，在土石方計算表中會多安插一列空白行隔開。

5.如果要更改已經填寫的最後一道樁號資料，可以透過 "上一動 " 將其引入。

6.填寫完後點按 " 結束 " 再進行檢查各項資料後即可儲存備用。

7.進入AutoCAD中，將dvb檔引入後並且將該Excel開啟中，即可繪製一連續的斷面。

8.回到Excel中，點擊 "土石報表 " ，即可得到老大們需要的土石方報表。



'
'This project is to solve the complex and boring things in dredge event
'Made by Hank Lin 2018/3/19 @ MelinStation
'This version is for AutoCAD 2016 and Excel2016
'

Public plineobj As AcadPolyline
Public lineobj As AcadLine
Public tobj As AcadText
Public arcobj As AcadArc
Public lay As AcadLayer

Const ratio = 1
Const figLength = 4000
Const lastLength = 800
Const txtLength = 2000
Const txtheight100 = 100 * 2.5
Const digWidth = 300
Const rail = 300

Sub getHorizontalFile()

Dim spt(2) As Double
Dim ept(2) As Double
Dim filename As String
Dim insertpt() As Double
Dim vertices() As Double
Dim X_center As Double, Y_center As Double
Dim crossName As String, slopeDown As Double, LeftEnv As String, RightEnv As String, bottomDepth As Double, channelType As String, DigArea As Double
Dim r As Integer, channelSelect As Integer, BD As Double, BT As Double, H As Double, t As Double, rail As Double, LW As Double, RW As Double, LeftEnvHeight As Double, RightEnvHeight As Double
Dim retlineobj1 As AcadLine
Dim retlineobj2 As AcadLine
Dim ret As Variant

Call BasicSetting(1)

On Error Resume Next

Set excelapp = CreateObject("excel.application")

If err <> "" Then

    Set excelapp = GetObject(, "excel.application")

End If

On Error GoTo 0

With excelapp

    On Error GoTo GETFILE
    
    '.Workbooks.Open ("D:\Horizontal123.xlsm")
    
    On Error GoTo 0
    
continue:
    
    .Visible = True
    
    Set sht = excelapp.ActiveWorkbook.ActiveSheet
    
    lr = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
    
    ret = ThisDrawing.Utility.GetPoint(, "請選擇第一個渠道要生成的中心點")

    For r = 3 To lr Step 2
        
        crossName = sht.Cells(r, 1)
        LeftEnv = sht.Cells(r, 2)
        LeftEnvHeight = sht.Cells(r, 3)
        RightEnv = sht.Cells(r, 4)
        RightEnvHeight = sht.Cells(r, 5)
        slopeDown = sht.Cells(r, 6)
        channelType = sht.Cells(r, 7)
        channelSelect = sht.Cells(r, 7).Font.ColorIndex
        
        X_center = ret(0) + figLength * k * 1.5
        Y_center = ret(1) + -figLength * j
        
        j = j + 1
        
        If j Mod 4 = 0 Then
        
            k = k + 1
            j = 0
            
        End If
        
        i = 3
        
        X = X_center
        Y = Y_center
        
        If channelSelect = 3 Then
        
            Call PlotTrapzoidChannel(X, Y, channelType, sht, BD, BT, retlineobj1, retlineobj2, H)
            
            Call DigLineT(X, Y, slopeDown, r, sht, BD, retlineobj1, retlineobj2, DigArea)
            
            Call DescriptionT(X, Y, LeftEnv, RightEnv, LeftEnvHeight, RightEnvHeight, BT, H)
            
        Else
        
            Call PlotChannel(X, Y, channelType, sht, BT, LW, RW, t)
        
            Call DigLineU(X, Y, slopeDown, r, sht, BT, DigArea)
            
            Call DescriptionU(X, Y, LeftEnv, RightEnv, LeftEnvHeight, RightEnvHeight, BT, LW, RW, t)
        
        End If
        
        Call AddTitle(X, Y, crossName, slopeDown, DigArea)
        
        sht.Cells(r, 8) = Round(DigArea / 1000000, 2)
        
    Next
    
err:
    '.Workbooks(1).Close SaveChanges:=True
    '.Quit

End With

ZoomAll

Exit Sub

GETFILE:

filename = excelapp.GetOpenFilename

If filename Like "False*" Then Exit Sub

excelapp.Workbooks.Open (filename)

GoTo continue

End Sub

Sub PlotTrapzoidChannel(ByVal X_center As Double, ByVal Y_center As Double, ByVal channelType As String, ByVal sht As Worksheet, ByRef BD As Double, ByRef BT As Double, _
                        ByRef retlineobj1 As AcadLine, ByRef retlineobj2 As AcadLine, ByRef H As Double)

Dim lineobj As AcadLine, lineobj2 As AcadLine, lineobj3 As AcadLine
Dim plineobj As AcadPolyline
Dim spt(2) As Double, ept(2) As Double
Dim ret1 As Variant, ret2 As Variant
Dim vertices(23) As Double

ThisDrawing.ActiveLayer = ThisDrawing.Layers("中心線")

spt(0) = X_center: spt(1) = Y_center + 800
ept(0) = X_center: ept(1) = Y_center - 300

Set lineobj = ThisDrawing.ModelSpace.AddLine(spt, ept)

ThisDrawing.ActiveLayer = ThisDrawing.Layers("原渠道(疏濬)")


'---control coefficient----

With sht

For Each rng In .UsedRange

    If rng.Value = "Type" Then
    
        c = rng.Column
        
        Exit For
        
    End If

Next

r = 3

Do Until .Cells(r, c) = ""

    If .Cells(r, c) = channelType Then
    
        BT = .Cells(r, c + 8) * 1000
        BD = .Cells(r, c + 9) * 1000
        H = .Cells(r, c + 10) * 1000
        t = .Cells(r, c + 11) * 1000
            
        Exit Do
            
    End If

    r = r + 1
Loop

m = (BT - BD) / 2 / H
'----------------------
    spt(0) = X_center: spt(1) = Y_center - t
    ept(0) = spt(0) - 10: ept(1) = Y_center - t
    Set lineobj = ThisDrawing.ModelSpace.AddLine(spt, ept)

vertices(0) = X_center
vertices(1) = Y_center

vertices(3) = X_center - BD / 2
vertices(4) = Y_center

    spt(0) = vertices(3) - t * 1 / Sqr(m * m + 1): spt(1) = vertices(4) - m * t / Sqr(m * m + 1)
    ept(0) = spt(0) - 200 * m: ept(1) = spt(1) + 200
    Set lineobj2 = ThisDrawing.ModelSpace.AddLine(spt, ept)
    ret1 = lineobj.IntersectWith(lineobj2, acExtendBoth)

vertices(6) = X_center - BT / 2
vertices(7) = Y_center + H
    
    spt(0) = vertices(3): spt(1) = vertices(4)
    ept(0) = vertices(6): ept(1) = vertices(7)
    Set retlineobj1 = ThisDrawing.ModelSpace.AddLine(spt, ept)

vertices(9) = X_center - BT / 2 - rail
vertices(10) = Y_center + H

vertices(12) = X_center - BT / 2 - rail
vertices(13) = Y_center + H - t

    spt(0) = vertices(9): spt(1) = vertices(10) - t
    ept(0) = spt(0) - 10: ept(1) = spt(1)
    Set lineobj3 = ThisDrawing.ModelSpace.AddLine(spt, ept)
    ret2 = lineobj2.IntersectWith(lineobj3, acExtendBoth)
    
vertices(15) = ret2(0)
vertices(16) = ret2(1)

vertices(18) = ret1(0)
vertices(19) = ret1(1)

vertices(21) = vertices(0)
vertices(22) = vertices(1) - t

Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)

spt(0) = X_center
spt(1) = Y_center - 100

ept(0) = X_center
ept(1) = Y_center

Set plineobj2 = plineobj.Mirror(spt, ept)

Set retlineobj2 = retlineobj1.Mirror(spt, ept)

lineobj.Delete
lineobj2.Delete
lineobj3.Delete

Dim hatchobj As AcadHatch
Dim outerloop(0 To 1) As AcadEntity

Set hatchobj = ThisDrawing.ModelSpace.AddHatch(0, "SOLID", True)

Set outerloop(0) = plineobj
Set outerloop(1) = plineobj2

hatchobj.AppendOuterLoop (outerloop)

End With

End Sub


Sub PlotChannel(ByVal X As Double, ByVal Y As Double, ByVal channelType As String, ByVal sht As Worksheet, ByRef BT As Double, ByRef LW As Double, ByRef RW As Double, ByRef t As Double)

'ThisDrawing.ActiveLayer = ThisDrawing.Layers("新建渠道")

With sht

Dim rng As Range
Dim vertices(14 * 3 - 1) As Double
Dim spt(2) As Double, ept(2) As Double

ThisDrawing.ActiveLayer = ThisDrawing.Layers("中心線")

spt(0) = X: spt(1) = Y + 800
ept(0) = X: ept(1) = Y - 300

Set lineobj = ThisDrawing.ModelSpace.AddLine(spt, ept)

ThisDrawing.ActiveLayer = ThisDrawing.Layers("原渠道(疏濬)")

For Each rng In .UsedRange

    If rng.Value = "Type" Then
    
        c = rng.Column
        Exit For
    
    End If

Next

lr = .Cells(1, c).End(xlDown).Row

For r = 1 To lr

    If .Cells(r, c) = channelType Then
        
        t = .Cells(r, c + 4) * 1000
        
        BT = .Cells(r, c + 3) * 1000
        LT = t
        LW = .Cells(r, c + 5) * 1000
        BW = t
        RW = .Cells(r, c + 6) * 1000
        RT = t
        b = .Cells(r, c + 7) * 1000

        Exit For
    
    End If

Next

X_ch = X
Y_ch = Y
'pt1
vertices(0) = X_ch
vertices(1) = Y_ch
'pt2
vertices(3) = X_ch - BT / 2
vertices(4) = Y_ch
'pt3
vertices(6) = X_ch - BT / 2
vertices(7) = Y_ch + LW
'pt4
vertices(9) = X_ch - BT / 2 - LT
vertices(10) = Y_ch + LW
'pt5
vertices(12) = X_ch - BT / 2 - LT
vertices(13) = Y_ch
'pt6
vertices(15) = X_ch - BT / 2 - LT - b
vertices(16) = Y_ch
'pt7
vertices(18) = X_ch - BT / 2 - LT - b
vertices(19) = Y_ch - BW - bW2
'pt8
vertices(21) = X_ch + BT / 2 + RT + b
vertices(22) = Y_ch - BW - bW2
'pt9
vertices(24) = X_ch + BT / 2 + RT + b
vertices(25) = Y_ch
'pt10
vertices(27) = X_ch + BT / 2 + RT
vertices(28) = Y_ch
'pt11
vertices(30) = X_ch + BT / 2 + RT
vertices(31) = Y_ch + RW
'pt12
vertices(33) = X_ch + BT / 2
vertices(34) = Y_ch + RW
'pt13
vertices(36) = X_ch + BT / 2
vertices(37) = Y_ch
'pt14
vertices(39) = X_ch
vertices(40) = Y_ch

Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)


End With

Dim hatchobj As AcadHatch
Dim outerloop(0 To 0) As AcadEntity

Set hatchobj = ThisDrawing.ModelSpace.AddHatch(0, "SOLID", True)

Set outerloop(0) = plineobj

hatchobj.AppendOuterLoop (outerloop)

End Sub

Sub AddTitle(ByVal X_center As Double, ByVal Y_center As Double, ByVal crossName As String, ByVal slopeDown As String, ByRef DigArea As Double)

ThisDrawing.ActiveLayer = ThisDrawing.Layers("橫斷面說明")

Dim txtpt(2) As Double
Dim spt(2) As Double
Dim ept(2) As Double

txtpt(0) = X_center
txtpt(1) = Y_center + txtLength
txtpt(2) = 0

If crossName Like "*.*" Then

crossName = Format(crossName, "0+000.0")

Else

crossName = Format(crossName, "0+000")

End If

Set tobj = ThisDrawing.ModelSpace.AddText(crossName, txtpt, txtheight100)

tobj.Alignment = acAlignmentMiddleCenter

tobj.TextAlignmentPoint = txtpt

spt(0) = txtpt(0) - 800 / ratio
spt(1) = txtpt(1) - 200 / ratio

ept(0) = txtpt(0) + 800 / ratio
ept(1) = spt(1)

Set lineobj = ThisDrawing.ModelSpace.AddLine(spt, ept)

txtpt(1) = Y_center + txtLength - 400 / ratio

slopeDown = Format(slopeDown, "0.00")

If slopeDown >= 0 Then slopeDown = "-" & slopeDown

Set tobj = ThisDrawing.ModelSpace.AddText(slopeDown, txtpt, txtheight100)

tobj.Alignment = acAlignmentMiddleCenter

tobj.TextAlignmentPoint = txtpt

txtpt(0) = txtpt(0) + 2000
txtpt(1) = txtpt(1) + 200

A = "C= " & Round(DigArea / 1000000, 2) & "m3"

Set tobj = ThisDrawing.ModelSpace.AddText(A, txtpt, txtheight100)

tobj.Alignment = acAlignmentMiddleCenter

tobj.TextAlignmentPoint = txtpt

'ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

End Sub

Sub DigLineT(ByVal X As Double, ByVal Y As Double, ByVal slopeDown As Double, ByVal r As Integer, _
             ByVal sht As Worksheet, ByVal BD As Double, ByVal retlineobj1 As AcadLine, ByVal retlineobj2 As AcadLine, ByRef DigArea As Double)

Dim vertices(8 * 3 - 1) As Double
Dim ret As Variant
Dim spt(2) As Double, ept(2) As Double

ThisDrawing.ActiveLayer = ThisDrawing.Layers("開挖線")

With sht

spt(0) = X - BD / 2: spt(1) = Y + .Cells(r + 1, 1) * 1000
ept(0) = spt(0) - 10: ept(1) = spt(1) + 2

Set lineobj = ThisDrawing.ModelSpace.AddLine(spt, ept)

ret = lineobj.IntersectWith(retlineobj1, acExtendBoth)

lineobj.Delete

vertices(0) = ret(0)
vertices(1) = ret(1)

vertices(3) = spt(0)
vertices(4) = spt(1)

spt(0) = X + BD / 2: spt(1) = Y + .Cells(r + 1, 3) * 1000
ept(0) = spt(0) + 10: ept(1) = spt(1) + 2

Set lineobj = ThisDrawing.ModelSpace.AddLine(spt, ept)

ret = lineobj.IntersectWith(retlineobj2, acExtendBoth)

vertices(6) = X
vertices(7) = Y + slopeDown * 1000

vertices(9) = spt(0)
vertices(10) = spt(1)

vertices(12) = ret(0)
vertices(13) = ret(1)

vertices(15) = X + BD / 2
vertices(16) = Y

vertices(18) = X - BD / 2
vertices(19) = Y

vertices(21) = vertices(0)
vertices(22) = vertices(1)

Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)

DigArea = plineobj.Area

lineobj.Delete
retlineobj1.Delete
retlineobj2.Delete

End With

End Sub

Sub DigLineU(ByVal X As Double, ByVal Y As Double, ByVal slopeDown As Double, ByVal r As Integer, _
            ByVal sht As Worksheet, ByVal BT As Double, ByRef DigArea As Double)

ThisDrawing.ActiveLayer = ThisDrawing.Layers("開挖線")

With sht

DigCount = .Cells(r + 1, 1).End(xlToRight).Column - 1

    distance = BT / DigCount

    Dim vertices(8 * 3 - 1) As Double
    
    vertices(0) = X - 2 * distance
    vertices(1) = Y + .Cells(r + 1, 1) * 1000
    
    vertices(3) = X - distance
    vertices(4) = Y + .Cells(r + 1, 2) * 1000
    
    vertices(6) = X
    vertices(7) = Y + .Cells(r, 6) * 1000
    
    vertices(9) = X + distance
    vertices(10) = Y + .Cells(r + 1, 4) * 1000
    
    vertices(12) = X + 2 * distance
    vertices(13) = Y + .Cells(r + 1, 5) * 1000
    
    vertices(15) = X + 2 * distance
    vertices(16) = Y
    
    vertices(18) = X - 2 * distance
    vertices(19) = Y
    
    vertices(21) = vertices(0)
    vertices(22) = vertices(1)
    
    Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)

    DigArea = plineobj.Area

End With

End Sub


Sub DescriptionT(ByVal X As Double, ByVal Y As Double, ByVal LeftEnv As String, ByVal RightEnv As String, ByVal LeftEnvHeight As Double, ByVal RightEnvHeight As Double, ByVal BT As Double, ByVal H As Double)

Dim txtpt(2) As Double
Dim cpt(2) As Double
Dim fitpt(2) As Double
Dim basept(2) As Double
Dim endpt(2) As Double
Dim vertices(3 * 3 - 1) As Double

ThisDrawing.ActiveLayer = ThisDrawing.Layers("橫斷面說明")


For i = 1 To 2
    
    Select Case i
    
    Case 1
    
        basept(0) = X - BT / 2 - rail
        basept(1) = Y + H
        
        fitpt(0) = X - BT / 2 - 2 * rail
        fitpt(1) = Y + LeftEnvHeight * 1000
    
        endpt(0) = fitpt(0) - lastLength
        endpt(1) = fitpt(1)
        
        txtpt(0) = endpt(0)
        txtpt(1) = endpt(1) + 200
    
        vertices(0) = basept(0): vertices(1) = basept(1)
        vertices(3) = fitpt(0): vertices(4) = fitpt(1)
        vertices(6) = endpt(0): vertices(7) = endpt(1)
    
        Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)
    
        Set tobj = ThisDrawing.ModelSpace.AddText(LeftEnv, txtpt, txtheight100)
    
    Case 2
    
        basept(0) = X + BT / 2 + rail
        basept(1) = Y + H
        
        fitpt(0) = X + BT / 2 + 2 * rail
        fitpt(1) = Y + RightEnvHeight * 1000
        
        endpt(0) = fitpt(0) + lastLength
        endpt(1) = fitpt(1)
        
        txtpt(0) = endpt(0)
        txtpt(1) = endpt(1) + 200
    
        vertices(0) = basept(0): vertices(1) = basept(1)
        vertices(3) = fitpt(0): vertices(4) = fitpt(1)
        vertices(6) = endpt(0): vertices(7) = endpt(1)
    
        Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)
    
        Set tobj = ThisDrawing.ModelSpace.AddText(RightEnv, txtpt, txtheight100)
    
    End Select
    
    tobj.Alignment = acAlignmentBottomCenter
    tobj.TextAlignmentPoint = txtpt
    
    Radius = 50
    
    cpt(0) = endpt(0)
    cpt(1) = endpt(1) + Radius
    
    Set arcobj = ThisDrawing.ModelSpace.AddArc(cpt, Radius, 3.14 / 2, -3.14 / 2)
    
    arcobj.Rotate endpt, -3.14 / 6
    
    cpt(0) = endpt(0)
    
    cpt(1) = endpt(1) - Radius
    
    Set arcobj = ThisDrawing.ModelSpace.AddArc(cpt, Radius, -3.14 / 2, 3.14 / 2)
    
    arcobj.Rotate endpt, -3.14 / 6

Next

'ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")


End Sub

Sub DescriptionU(ByVal X As Double, ByVal Y As Double, ByVal LeftEnv As String, ByVal RightEnv As String, ByVal LeftEnvHeight As Double, ByVal RightEnvHeight As Double, ByVal BT As Double, ByVal LW As Double, ByVal RW As Double, ByVal t As Double)

Dim txtpt(2) As Double
Dim cpt(2) As Double
Dim basept(2) As Double
Dim spt(2) As Double

ThisDrawing.ActiveLayer = ThisDrawing.Layers("橫斷面說明")

For i = 1 To 2
    
    Select Case i
    
    Case 1
    
        basept(0) = X - BT / 2 - t - lastLength
        basept(1) = Y + LeftEnvHeight * 1000
        
        txtpt(0) = basept(0)
        txtpt(1) = basept(1) + 200
        
        spt(0) = basept(0) + lastLength
        spt(1) = basept(1)
    
        Set tobj = ThisDrawing.ModelSpace.AddText(LeftEnv, txtpt, txtheight100)
    
    Case 2
    
        basept(0) = X + BT / 2 + t + lastLength
        basept(1) = Y + RightEnvHeight * 1000
        
        txtpt(0) = basept(0)
        txtpt(1) = basept(1) + 200
        
        spt(0) = basept(0) - lastLength
        spt(1) = basept(1)
    
        Set tobj = ThisDrawing.ModelSpace.AddText(RightEnv, txtpt, txtheight100)
    
    End Select
    
    Set lineobj = ThisDrawing.ModelSpace.AddLine(spt, basept) '地盤線
    
    tobj.Alignment = acAlignmentBottomCenter
    tobj.TextAlignmentPoint = txtpt
    
    Radius = 50
    
    cpt(0) = basept(0)
    cpt(1) = basept(1) + Radius
    
    Set arcobj = ThisDrawing.ModelSpace.AddArc(cpt, Radius, 3.14 / 2, -3.14 / 2)
    
    arcobj.Rotate basept, -3.14 / 6
    
    cpt(0) = basept(0)
    
    cpt(1) = basept(1) - Radius
    
    Set arcobj = ThisDrawing.ModelSpace.AddArc(cpt, Radius, -3.14 / 2, 3.14 / 2)
    
    arcobj.Rotate basept, -3.14 / 6

Next

'ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

End Sub

Sub BasicSetting(ByVal i As Integer)

On Error Resume Next

Dim txtStyle As AcadTextStyle
Dim txtStyles As AcadTextStyles

Set txtStyles = ThisDrawing.TextStyles

For Each txtStyle In txtStyles

    If txtStyle.Name = "工程用仿宋體" Then
    
        IsAdded = True
    
    End If

Next

If IsAdded = False Then

    Set txtStyle = txtStyles.Add("工程用仿宋體")
    txtStyle.fontFile = "c:\windows\fonts\simfang.ttf"

End If

Set txtStyle = txtStyles("工程用仿宋體")

If ThisDrawing.ActiveTextStyle.Name <> "工程用仿宋體" Then

    ThisDrawing.ActiveTextStyle = txtStyle

End If

If ThisDrawing.ActiveLayer.Name <> "0" Then

    ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

End If

ThisDrawing.Linetypes.Load "DASHDOT", "acad.lin"
ThisDrawing.Linetypes.Load "CENTER", "acad.lin"

Set lays = ThisDrawing.Layers

Set lay = lays.Add("原渠道(疏濬)")

    lay.color = acWhite

Set lay = lays.Add("中心線")

    lay.color = acRed
    lay.Linetype = "CENTER"

Set lay = lays.Add("開挖線")

    lay.color = acGreen

Set lay = lays.Add("橫斷面說明")

    lay.color = acWhite

ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

End Sub

留言

張貼留言

Popular Posts

Excel VBA @ 監造日報表、查驗表 -2

圖片
***如需施工日誌請參考 這裡 *** 新版本20111214 已經更新!! 前言： 在經歷多次改版，發現使用的步驟還是有點多餘而且不夠自動化，此次將用物件類別模組的方式來修改Ver1.0留下尚可使用的程式碼，打造嶄新的監造日報表Ver2.0，輸出模式改為PDF，請搭配 PDFBinder 進行使用會比較方便。 準備文件： 以PCCES所編制並匯出成Excel之預算書報表 工程預算書中的數量計算表、土方計算表 監造日報表VBA使用手冊( 下載點我 ) 請開啟巨集並於login頁註冊後登入即可使用 圖一、Login頁面中點選註冊後跳至Google表單，填寫後即可以登入使用 參考文章： 專文1-PCCES處理到預算書 專文2-基本資料填寫 專文3-整個報表的靈魂 專文4-預定進度湊不到100%的解法  (20221204更新) 使用過程簡介： 1.  於工作表("Main")中填寫有關 工程名稱、 試體名稱(P.S.1) 、施工渠道名稱、進度資料等。 2.  於工作表("Budget")中點選"取得預算書"，修正為圖二所展示的內容。 圖二、取得預算書結果，如果需要整理準則，請參考設定準則的註解進行設定，並點選"重整準則" 3.  整理完成後並且更改為契約單價後，點選"匯出至報表"，資料會傳送至工作表("Main")，如下圖三所展示。 圖三、工作表("Main")中的報表資料，A~E欄為放置Step1 中的基本資料。 4.  於工作表("Records")中點選"填寫表單"，如圖四，即可進行一系列的資料紀錄，      為供應Diary及Check的基底資料。 圖四、施作項目來源是Main中的試體名稱與報表資料，如填寫資料有需要進行查驗，可以直接勾選(可複選) 5. 填寫完之後點選"傳送至Check"，再至工作表("Check")中點選"列印查驗"，     成果將輸出到該目錄下的查驗表Output中，名稱為查驗表代碼-頁碼.PDF
Read more »

ExcelVBA@施工照片整理的應用範例

圖片
前言： 施工照片或者查驗照片對於許多工程人員來說，是個繁瑣的麻煩事。畢竟照片只是一張圖片，需要用人眼去判讀才有辦法了解內容是什麼，因為通常會有一張白板與工地現場進行合照，然而當撰寫白板的人寫字醜到不行時，會使人瘋狂。因此在施工照片的整理上，只要能解決 照片的資訊標示 與 報表位置自動貼附並調整大小 ，想必會讓各位有此類需求的工程人員節省許多時間。 相片的收集來源有以下方式 從相機的SD卡或手機連接USB直接進行下載，其檔案名稱通常為IMG_XXXX 或 DCIM_XXXX 。 透過LINE社群中建立相簿，並將同類屬性的照片丟進同一個相簿中，爾後再透過LINE電腦版將整本相簿進行下載，其檔案名稱通常為 LINE_ALBUM_相簿名稱_XXXX 。 上述兩種方式為筆者曾經使用過的方法，於資料夾檢視情況下僅有縮圖及沒有資訊標示的檔案名稱，需要雙擊展開大圖後才有辦法判讀該相片的用途，雖然上面有一張小白板的合照，但還是需要點開之後才有辦法了解內容是什麼，而【點開】並做【資訊標示】， 本身就是一件很麻煩的事 。 解決方案： 筆者的作法是將照片先整理至一個資料夾的底下，並透過LINE相簿在進行批次下載時指定其子資料夾名稱。之後便透過我所撰寫的【施工照片瀏覽及更名】的VBA小程式進行照片的資訊標示與報表輸出，詳細操作流程如下 點擊【取得資料夾】按鈕，選取已整理好的根資料夾位置。 點擊【貼上結果】按鈕，選取是否要在工作表上顯示縮圖及大小。 移動至工作表(Result)，若於工作表(Main)中有設定顯示大圖，則進入工作表(Result)中便會根據滑鼠選取的欄位顯示相對應的大圖資訊，並留有資訊標示欄位供使用者輸入做修改。 圖一、施工照片大圖資訊 有關施工照片資訊標示均輸入完畢之後，移動至工作表(Main)點擊【更換檔名】按鈕，以VBA可判讀的資訊標示的格式進行檔案名稱儲存，未來若有相對應的格式，系統會自動判讀並做預先設定，不用再輸入一次。 點擊【列印報表】按鈕，將會依照排序方法(時間或者項目)，依序將照片自動貼上於報表中並轉換成XLS或PDF， 製作成PDF才有辦法將檔案發布給其他人使用 ，如為XLS則會在自身電腦中並帶有照片原始檔的狀況下才能看到圖片。 圖三、施工照片報表輸出PDF模式。 圖三、施工照片報表輸出XLS。 若有施工照片需要的朋友們 施工照片VBA買斷版連結 *0313更
Read more »

Excel VBA@ 監造日報表、查驗表

圖片
新版本請參考:  監造日報表Ver2.0 前言： 工程線流程：測量→設計→發包→監造→驗收→移交。 其中，監造有相當多的文件及注意事項，比如施作數量、成本監控、品質管制(查驗表)、重大期程(工程督導、說明會、變更(修正)設計、展延工期...等等)，在文件上的處理可說是相當的繁瑣。 光是品質管制的查驗表就分為： 開挖(放樣)工程查驗表 土方工程施工查驗表 鋼筋施工組立查驗表 模版施工組立查驗表 混凝土施工作業查驗表 模版及混凝土施工完成作業查驗表 職業安全衛生暨環境保護措施查驗表 在查驗表的表頭須註明工程名稱、工程位置、施作內容、施作日期...等， 已經在監造日報表中出現過 的部分，配合監造日報表的數量、單價、預定進度可以輕易的找到累積數量、累積成本、累積進度，去判斷是否有落後。 主要構想： 以往都是以複製的方式去拉出一連串的日報，只要連結錯誤，就是整批的更改連結，相當麻煩。因此寫了一個Side Project 用ExcelVBA去執行監造日報表的填寫過程，將工作表分為： 監造日報表     (輸出的樣版長相) 日報基本資料 (單價、數量、是否變更、基本工程綱要、試體、渠道數等重要資料) 數量及計算     (進度、天氣狀況、施作單價、施作數量) 施工日誌         (工程位置、施作內容、查驗項目、重大期程) 查驗總表         (與查驗有關的項目及查驗後內容都在此) 經基本資料填寫後，取得預算書(將PCCES的資料丟入，會依照主體工程、雜項工程、職業安全衛生、環境保護措施...等主要項目匯入到日報基本資料的工作表中，日後 僅需要進行填寫數量 ，就會將所有相關資料導入至數量及計算、施工日誌、查驗總表...等工作表，減少重複的資料一直出現，再透過主介面的"監造日報表"、"查驗表"，選擇列印模式即可批次列印。 圖一、程式主要介面 圖二、填寫數量介面 圖三、監造日報表樣版產出 圖四、某一查驗表產出
Read more »