Excel VBA批量处理寸照名字（类模块加FSO版）

需求：因为处理学生学籍照片，从照相馆拿回来的寸照是按班级整理好，文件名是相机编号的文件。那么处理的话，是这么一个思路，通过Excel表格打印出各班A4照片列表，让学生自行填上照片对应姓名。表格收回来后Excel表格上填入对应姓名，通过VBA更改电子档照片文件名。（此次重写使用了类模块和fso，并对插入的图片类型进行了过滤，避免了插入非图片类型文件）

大概流程如下图：

操作界面如下图：

vba代码模块如下图，包括ThisWorkbook的open事件代码、测试过程代码（即插入图片、删除图片、重命名图片三个按钮的代码）：

1、ThisWorkbook的open事件代码：

Private Sub Workbook_Open()
    ThisWorkbook.Sheets().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, ",")()
    End If
End Sub

2、“测试过程”代码：

Sub doInsertPics()
'插入图片
    Dim arrFiles() As String
    Dim myPath As String
    Dim i, j As Integer
    i = : j =
    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) +  & "张照片！"

    For Each file In arrFiles
            Call sht1.insertPic(file, Cells(i, j), )
            Cells(i, j).Offset(, ).NumberFormatLocal = "@"
            Cells(i, j).Offset(, ) = sht1.getFileNameFromFullName(file, False)
            j = j +
            If j >  Then
                j =
                i = i +
                If i >  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 =  To
    For j =  To
        If Sheets("照片处理").Range("a" & i).Offset(, j - ).Value = "" Or Sheets("照片处理").Range("a" & i).Offset(, j - ).Value = "" Then Exit Sub
        Name picPath & Sheets("照片处理").Range("a" & i).Offset(, j - ).Value As picPath & Sheets("照片处理").Range("a" & i).Offset(, j - ).Value
    Next

Next

End Sub

3、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 = )
    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 -  * blank, h -  * 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 =  To
        sht.Range("a3:i3").Offset( * 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 =
    Set fso = CreateObject("scripting.filesystemobject")
    For Each fld In fso.getfolder(thePath).subfolders
        ReDim Preserve arr(i)
        arr(i) = fld.Name
        i = i +
    Next
    Set fso = Nothing
    If i >  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 =
    Set fso = CreateObject("scripting.filesystemobject")
    For Each fld In fso.getfolder(wb.Path).subfolders
        ReDim Preserve arr(i)
        arr(i) = fld.Name
        i = i +
    Next
    Set fso = Nothing
    If i >  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 =
    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 +
            End If
        Next
    End If
    Set fso = Nothing
    Set fil = Nothing
    If i >  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, ".") - ) '返回不带扩展名文件名
    Else
        getFileNameFromFullName = FileName '返回带扩展名文件名
    End If
End Function
'=======================================================================================================

Function isEmptyArr(ByRef arr()) As Boolean   '判断是否为空数组
Dim tempStr As String
tempStr = Join(arr, ",")
isEmptyArr = LenB(tempStr) <=
End Function

4、原文件下载