Excel VBA批量處理寸照名字（類模塊加FSO版）

需求：由於處理學生學籍照片，從照相館拿回來的寸照是按班級整理好，文件名是相機編號的文件。那麼處理的話，是這麼一個思路，經過Excel表格打印出各班A4照片列表，讓學生自行填上照片對應姓名。表格收回來後Excel表格上填入對應姓名，經過VBA更改電子檔照片文件名。（這次重寫使用了類模塊和fso，並對插入的圖片類型進行了過濾，避免了插入非圖片類型文件）

大概流程以下圖：

操做界面以下圖：

 

 

vba代碼模塊以下圖，包括ThisWorkbook的open事件代碼、測試過程代碼（即插入圖片、刪除圖片、重命名圖片三個按鈕的代碼）：

一、ThisWorkbook的open事件代碼：

Private Sub Workbook_Open()
    ThisWorkbook.Sheets(1).Select
    Dim dirs As String
    Dim rngList As Range
    Dim sht As New MySheet
    
    Set rngList = Range("l1")
    rngList.ClearContents
    rngList.Validation.Delete
    
    dirs = sht.getThisWorkbookSubFolders()
    Set sht = Nothing
    If dirs <> "" Then
        rngList.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=dirs
        rngList.Value = Split(dirs, ",")(0)
    End If
End Sub

二、「測試過程」代碼：

Sub doInsertPics()
'插入圖片
    Dim arrFiles() As String
    Dim myPath As String
    Dim i, j As Integer
    i = 2: j = 1
    Dim sht1 As New MySheet
    
    
    If Range("l1").Value = "" Then Exit Sub
    myPath = ThisWorkbook.Path & "\" & Range("l1").Value & "\"
    arrFiles = sht1.getSubFolderFiles(myPath, "jpg")
    
    On Error Resume Next
    MsgBox "文件夾「" & Range("l1") & "」總共有" & UBound(arrFiles) + 1 & "張照片！"

    For Each file In arrFiles
            Call sht1.insertPic(file, Cells(i, j), 3)
            Cells(i, j).Offset(1, 0).NumberFormatLocal = "@"
            Cells(i, j).Offset(1, 0) = sht1.getFileNameFromFullName(file, False)
            j = j + 1
            If j > 9 Then
                j = 1
                i = i + 3
                If i > 20 Then Exit For
            End If
    Next
    Set sht1 = Nothing
End Sub

Sub doDeletePics()
'刪除圖片
    Dim sht1 As New MySheet
    Call sht1.deleteAllPics
    Set sht1 = Nothing
End Sub

Sub doRenamePics()
'重命名圖片
Dim i, j As Integer
Dim picPath As String

picPath = ThisWorkbook.Path & "\" & Range("l1").Value & "\"

For i = 1 To 7
    For j = 1 To 9
        If Sheets("照片處理").Range("a" & i).Offset(0, j - 1).Value = "" Or Sheets("照片處理").Range("a" & i).Offset(1, j - 1).Value = "" Then Exit Sub
        Name picPath & Sheets("照片處理").Range("a" & i).Offset(0, j - 1).Value As picPath & Sheets("照片處理").Range("a" & i).Offset(1, j - 1).Value
    Next

Next

End Sub

 

三、MySheet類模塊代碼：

Private sht As Worksheet
Private wb As Workbook

Public Sub Class_Initialize() '對象初始化函數
    Set wb = ThisWorkbook 'wb初始化爲活動工做表ThisWorkbook
    Set sht = ActiveSheet 'sht初始化爲活動工做表ActiveSheet
End Sub
'=======================================================================================================
'函數:   insertPic          在當前工做表插入圖片
'參數1： PictureFileName    圖片全名（含完整路徑）
'參數2： TargetCell         圖片插入目標單元格
'參數3： blank              圖片四周留白(可選)
'做用:  在當前工做表的目標單元格插入圖片，並能夠在圖片四周留白
'=======================================================================================================
Sub insertPic(ByVal PictureFileName As String, ByVal TargetCell As Range, Optional ByVal blank As Integer = 0)
    Application.ScreenUpdating = False '禁止屏幕刷新
    Dim p As Shape
    
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub      '「工做表」外的其餘類型表（如宏表，圖表）中不插圖片
    If Dir(PictureFileName) = "" Then Exit Sub      '文件名路徑爲空，沒有圖片，退出插入操做
    
    Dim t As Double, l As Double, w As Double, h As Double 't:top,l:left,w:with,h:height
    t = TargetCell.Top: l = TargetCell.Left: w = TargetCell.Width: h = TargetCell.Height
    
    Set p = sht.Shapes.AddPicture(PictureFileName, msoFalse, msoTrue, l + blank, t + blank, w - 2 * blank, h - 2 * blank)
    p.Placement = xlMoveAndSize
    Set p = Nothing
    Application.ScreenUpdating = True '恢復屏幕刷新
End Sub

'=======================================================================================================
'函數:   deleteAllPics   刪除當前工做簿的全部圖片，並清除圖片下面單元格的圖片名字
'=======================================================================================================
Sub deleteAllPics()
    Application.ScreenUpdating = False '禁止屏幕刷新
    
    Dim shp As Shape
    For Each shp In sht.Shapes
        If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then shp.Delete '圖形的類型爲mosPicture（圖片）或mosLinkedPicture（連接圖片）則刪除
    Next
    For i = 0 To 7
        sht.Range("a3:i3").Offset(3 * i).ClearContents
    Next
    
    Application.ScreenUpdating = True '恢復屏幕刷新
End Sub
'=======================================================================================================
'函數:   getSubFolders   '獲取thePath路徑下的子文件名稱
'=======================================================================================================
Function getSubFolders(ByVal thePath As String) As String '獲取thePath路徑下的子文件名稱
    Dim fso As Object
    Dim fld As Object
    Dim arr() As String
    Dim i As Integer
    i = 0
    Set fso = CreateObject("scripting.filesystemobject")
    For Each fld In fso.getfolder(thePath).subfolders
        ReDim Preserve arr(i)
        arr(i) = fld.Name
        i = i + 1
    Next
    Set fso = Nothing
    If i > 0 Then
        getSubFolders = VBA.Join(arr, ",")
    Else
        getSubFolders = ""
    End If
End Function
'=======================================================================================================
'函數:   getThisWorkbookSubFolders  獲取當前工做簿路徑下的「子文件夾」名稱
'=======================================================================================================
Function getThisWorkbookSubFolders() As String '獲取當前工做簿路徑下的子文件名稱
    Dim fso As Object
    Dim fld As Object
    Dim arr() As String
    Dim i As Integer
    i = 0
    Set fso = CreateObject("scripting.filesystemobject")
    For Each fld In fso.getfolder(wb.Path).subfolders
        ReDim Preserve arr(i)
        arr(i) = fld.Name
        i = i + 1
    Next
    Set fso = Nothing
    If i > 0 Then
        getThisWorkbookSubFolders = VBA.Join(arr, ",")
    Else
        getThisWorkbookSubFolders = ""
    End If
End Function
'=======================================================================================================
'函數:   getSubFolderFiles  獲取folderPath路徑下的某類文件全名（即含路徑文件名），返回數組
'=======================================================================================================


Function getSubFolderFiles(ByVal folderPath As String, Optional ByVal ExtensionName As String = "") As String()
    Dim fso, fil As Object
    Dim arr() As String
    Dim i As Integer
'    MsgBox fso.folderexists(folderPath)

    
    i = 0
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.folderexists(folderPath) Then
        For Each fil In fso.getfolder(folderPath).Files
            If fso.getExtensionName(fil.Path) Like ExtensionName & "*" Then
                ReDim Preserve arr(i)
                arr(i) = fil.Path
    '            arr(1, i) = fil.Name
                i = i + 1
            End If
        Next
    End If
    Set fso = Nothing
    Set fil = Nothing
    If i > 0 Then
        getSubFolderFiles = arr
    End If
End Function
'=======================================================================================================
'函數:   getFileNameFromFullName   根據文件帶全路徑全名得到文件名
'參數1： strFullName  文件全名
'參數2： ifExName true 返回字符串含擴展名,默認是：False
'參數3： strSplitor  各級文件夾分隔符
'做用:  從帶路徑文件全名徑獲取返回:  文件名(true帶擴展名)
'=======================================================================================================
Public Function getFileNameFromFullName(ByVal strFullName As String, _
                               Optional ByVal ifExName As Boolean = False, _
                               Optional ByVal strSplitor As String = "\") As String
    '=======代碼開始==============================================================================
    Dim ParentPath As String
    Dim FileName As String
    ParentPath = Left$(strFullName, InStrRev(strFullName, strSplitor, , vbTextCompare)) '反向查找路徑分隔符，獲取文件父級目錄
    FileName = Replace(strFullName, ParentPath, "") '替換父級目錄爲空獲得文件名
    If ifExName = False Then
        getFileNameFromFullName = Left(FileName, InStrRev(FileName, ".") - 1) '返回不帶擴展名文件名
    Else
        getFileNameFromFullName = FileName '返回帶擴展名文件名
    End If
End Function
'=======================================================================================================


Function isEmptyArr(ByRef arr()) As Boolean   '判斷是否爲空數組
Dim tempStr As String
tempStr = Join(arr, ",")
isEmptyArr = LenB(tempStr) <= 0
End Function

四、原文件下載