施工照片VBA-客製化範例

發表於 分類於 閱讀次數：

前言

筆者所提供之母版施工照片VBA內容僅針對照片做資料標記、檔案名稱變更、照片報表套印，經讀者使用後，委託我將該施工照片VBA進行客製化調整以符合該公司的標準作業流程。

其作業流程有幾項特點:

  1. 資料夾之間的照片移動
  2. 自照片路徑提取標記資料
  3. 標記文字與合約內容連動
  4. 依照設備編號分組列印

資料夾之間的照片移動

flowchart TD

    A[公司名稱]

    A --> B1[聯絡單位]
    A --> B2[聯絡單位]
    A --> B3[聯絡單位]

    B1 --> C1[合約編號]
    B2 --> C2[合約編號]
    B3 --> C3[合約編號]

    C1 --> D1[設備編號]
    C2 --> D2[設備編號]
    C3 --> D3[設備編號]

    D1 --> E1[照片資料]
    D2 --> E2[照片資料]
    D3 --> E3[照片資料]

    E1 --> G1[各種施工項目]
    E1 --> H1[留存備檔]
    E1 --> F1[OK] 

    E2 --> G2[各種施工項目]
    E2 --> H2[留存備檔]
    E2 --> F2[OK]

    E3 --> G3[各種施工項目]
    E3 --> H3[留存備檔]
    E3 --> F3[OK]

移動流程

  1. 從不同管道(連結手機、GOOGLE雲端相簿、LINE下載)收集，處理後的照片會先放置於留存備檔
  2. 挑選完施工項目的分類後會移動至各種施工項目資料夾，一種施工項目會對應一個資料夾
  3. 挑選要貼報告的照片後，移動至OK

自照片路徑提取標記資料

部分自路徑中的資料夾階層進行標記資料提取，除了減少標記時間也能配合原本手動搬遷照片歸檔的操作習慣，方便找尋照片存檔位置。

  • 公司名稱
  • 聯絡單位
  • 合約編號
  • 設備編號
  • 施工項目

施工照片VBA乃針對放置於留存備檔中的照片進行後續處理，如有進行施工項目標記則移動至各施工項目資料夾，如判定為適合呈現的照片則移動至OK資料夾。

其餘照片標記資料則後續進行人工處理:

  • 施工時機
  • 項次代號(與合約內容連動)
  • 備註

標記文字與合約內容連動

合約明細放置於合約編號資料夾下，因可能會有其他同類型的檔案存在，故以合約明細當作辨識關鍵字名稱進行合約更新，每次開啟主程式時即針對歸檔根目錄項下具有關鍵字名稱進行更新時間確認，僅檔案時間有編輯過之合約內容進行載入。

Fig1. 合約檔案清單

每份合約內容依序紀錄項目項次、項目代號、品名規格，原則上每張照片對應一項品名規格，標記時由人員標記代號，後續產製報表時程式由代號與合約編號作為查找唯一值(不同合約編號可能會出現相同項目代號)。

Fig2. 品名規格清單

依照設備編號分組列印

照片報表分為施工照片記錄表及檢修照片，列印過程需要依照設備編號進行單台設備或多台設備進行列印，這部分沿用先前施工照片VBA常見問題第四點解決方案進行，將分組列印標的設定為設備編號所處欄位。

列印時針對客製化的報表如有非照片能定義的表單欄位，則於列印該表前先要求使用者進行表單欄位的填寫，如施工照片記錄表要求填寫物品單編號、檢修照片表要求填寫設備說明等等。

縮圖偏移問題及解法

執行專案過程中發現關於工作表Result縮圖畫面會隨著列數增加而產生Y軸的偏移，導致在進行欄位篩選時，縮圖未能跟著整列一起隱藏。

Fig3. 縮圖偏移狀況

經查為 clsmyFile 物件類別模組下的 PastePictures() 程序貼附照片時會直接依照該儲存格的Top屬性進行放置，然而該Top屬性是會有累積誤差，當儲存格的列放大的時候，誤差也會放大，導致Top偏離正確的位置，故要放置照片的同時，先進行第一次偏移後就能消除這些累計誤差的影響。

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
Sub PastePictures()

With shtResult
    
    .Columns("B").ColumnWidth = photo_width
    
    lr = .Cells(1, 1).End(xlDown).Row
    lc = .Cells(1, 1).End(xlToRight).Column - 1
    
    Set rng_last = .Cells(lr, lc)

    r = 2
    
    For Each photo_path In coll_photo_path
    
        If IsPaste = True Then
    
            Set objTargetCell = .Cells(r, 2)

            objTargetCell.RowHeight = photo_height

            ' ---先移動到儲存格左上角，消除累積誤差---
            .Top = objTargetCell.Top
            .Left = objTargetCell.Left
            
            Set pic = .Pictures.Insert(photo_path)

            ' ---這是之前的累計誤差來源---
            'Set pic = .Shapes.AddPicture(photo_path) ', True, True, objTargetCell.Left + 2, objTargetCell.Top + 2, objTargetCell.Width - 4, objTargetCell.Height - 4)
            'pic.LockAspectRatio = msoFalse

            With pic

                dblGap = 2#

                .Placement = xlMoveAndSize
                .ShapeRange.LockAspectRatio = msoTrue '鎖定照片長寬比

                Set ranOri = objTargetCell

                dblRatioPic = .Width / .Height
                dblRatioOri = ranOri.Width / ranOri.Height

                If dblRatioPic > dblRatioOri Then '寬度控制
                    .Width = ranOri.Width - 2 * dblGap
                    .Top = ranOri.Top + 0.5 * ranOri.Height - 0.5 * .Height
                    .Left = ranOri.Left + dblGap
                Else                                '高度控制
                    .Height = ranOri.Height - 2 * dblGap
                    .Top = ranOri.Top + dblGap
                    .Left = ranOri.Left + 0.5 * ranOri.Width - 0.5 * .Width

                End If

            End With

        End If
    
        Set objPic = Nothing
        r = r + 1
    
    Next

End With

End Sub