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

Posted 2020-10-04 ukeedy

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

大概流程如下图：

操作界面如下图：

 

 

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

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

2、“测试过程”代码：

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

 

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

4、原文件下载