Excel VBA批量处理寸照名字

需求：因为处理学生学籍照片，从照相馆拿回来的寸照是按班级整理好，文件名是相机编号的文件。那么处理的话，是这么一个思路，通过Excel表格打印出各班A4照片列表，让学生自行填上照片对应姓名。表格收回来后Excel表格上填入对应姓名，通过VBA更改电子档照片文件名。

Function getSubDirectory()'获取当前文件的下层所有目录
    Dim strCurDir, strDirectoryName, strDirs As String
    Dim arrDirectoryName()
    Dim i As Integer

    strCurDir = ThisWorkbook.Path & "\"

    strDirectoryName = Dir(strCurDir, vbDirectory)
     '暂存目录的数组arrTemp下标从“0”开始
    i = 0
    Do While strDirectoryName <> ""      ' 开始循环。
        '跳过当前的目录及上层目录(一个点个两个点为名字的目录)。
        If strDirectoryName <> "." And strDirectoryName <> ".." Then
            '使用位比较来确定 MyName 代表一目录。
            If (GetAttr(strCurDir & strDirectoryName) And vbDirectory) = vbDirectory Then
                '动态增加数组元素
                ReDim Preserve arrDirectoryName(i)
                arrDirectoryName(i) = strDirectoryName
                i = i + 1
                'Debug.Print MyName
                '如果它是一个目录，将其名称显示出来。
            End If
        End If
        strDirectoryName = Dir
        If strDirectoryName = "" And i = 0 Then
            getSubDirectory = ""
            Exit Function
        End If

        '查找下一个目录。
    Loop

    If UBound(arrDirectoryName) = 0 Then
        getSubDirectory = arrDirectoryName(0)
    Else
        strDirs = Join(arrDirectoryName, ",") '把数组处理为“，”分隔字符串返回
        Erase arrDirectoryName
        getSubDirectory = strDirs
    End If
End Function

Function getSubDirFileNames(subDir1 As String) As String() '返回当前工作簿目录的指定子目录文件名数组的函数
    Dim arrFileNames() As String  '存储文件名数组
    Dim i As Integer

    If subDir1 = "" Then
        ReDim Preserve arrFileNames(0)
        arrFileNames(0) = ""
        getSubDirFileNames = arrFileNames
        Exit Function
    End If

    myPath = ThisWorkbook.Path + "\" + subDir1 + "\*.jpg" '当前工作簿目录子目录文件存放路径

    i = 0
    strName = Dir(myPath)
    Do While strName <> ""
        ReDim Preserve arrFileNames(i)
        arrFileNames(i) = strName
        i = i + 1
        strName = Dir '再次执行不带参数dir函数即显示下一文件的文件名（参照vba的dir函数执行规则）
    Loop

    If i < 1 Then
        ReDim Preserve arrFileNames(0)
        arrFileNames(0) = ""
        getSubDirFileNames = arrFileNames
        Exit Function
    End If
    getSubDirFileNames = arrFileNames
End Function

Sub deletePictures() '删除工作表所有图片函数

    Application.ScreenUpdating = False '禁止屏幕刷新
    '=====================================
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then 'shape类型包含按钮、美术字、自选图形之类，msoPicture代表图片
            shp.Delete
        End If
    Next
    '=====================================

    Application.ScreenUpdating = True '恢复屏幕刷新

End Su

Sub insertPicture(PictureFileName As String, TargetCell As Range)'插入图片函数

    Dim p As Object
    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    

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub '“工作表”外的其他类型表（如宏表，图表）中不插图片
    If Dir(PictureFileName) = "" Then Exit Sub '文件名路径为空，没有图片，退出插入操作

    TargetCell.Select
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)'Pictures.Insert()函数是老版本函数，vbe对象浏览器中隐藏了，需要查看的话按F2键
    p.Placement = xlMoveAndSize'图片随单元格缩放

    p.Width = w - 6'根据需要调整图片高宽
    p.Height = h - 2

    p.Left = l + 3'根据需要调整图片左上插入位置
    p.Top = t + 1
    'p.Left = p.Left + (TargetCell.Offset(0, 1).Left - l - p.Width) / 2
    'insertPicture = p
    Set p = Nothing

End Sub

下面是ThisWorkbook的open过程跟“插入图片”、“删除图片”、“重命名图片”的按钮代码

Private Sub Workbook_Open()
ThisWorkbook.Sheets(1).Select
Dim dirs As String
Dim rngList As Range

Set rngList = Range("l1")
rngList.ClearContents
rngList.Validation.Delete

dirs = getSubDirectory
If dirs <> "" Then
    rngList.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=dirs
    rngList.Value = Split(dirs, ",")(0)
End If

End Sub

“插入图片”按钮

Sub doInsertPictures()
Dim arrFiles() As String
Dim myPath As String
Dim i, j As Integer
i = 2: j = 1
Sheets(1).Select
myPath = ThisWorkbook.Path & "\" & Range("l1").Value & "\"
arrFiles = getSubDirFileNames(Range("l1").Value)
If arrFiles(0) <> "" Then
    For Each file In arrFiles
        Call insertPicture((myPath & file), Sheets(1).Cells(i, j))
        Sheets(1).Cells(i, j).Offset(1, 0).Value = file
        j = j + 1
        If j > 9 Then
            j = 1
            i = i + 3
            If i > 20 Then Exit For
        End If
    Next
End If
End Sub

“删除图片”按钮

Sub deletePicsNpicNames()
Call deletePictures
For i = 0 To 7
    Sheets(1).Range("a3:i3").Offset(i * 3).ClearContents
Next
End Sub

“重命名图片”按钮

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

源文件下载：照片处理xls