Excel VBA批量处理寸照名字
Posted ukeedy
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了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
以上是关于Excel VBA批量处理寸照名字的主要内容,如果未能解决你的问题,请参考以下文章