今天遇到这样一个有趣的需求：
“照片”文件夹下有数百张图片，其名称如“000OPU-01-01-0002.jpg”状，前面的以“-”隔开的三部分另有含义，最后四位数字是按照照片生成时顺序命名的。过去是要求将图片按照其名称排序后，以给定大小插入Word文档的n行两列的表格中，每行两张图片，下一行的单元格是两张图片的名字。现在新的需求来了，要求按照图片名称的后四位数字递增的顺序排版，排版格式如下图：
Snap5.jpg
经过思考，想到两种思路。
- 第一种是将图片改名，把后四位数字放到最前面，简单地按名称排序后即可插入到word中，然后把图片重命名回原来的名称。
- 第二种是提取图片名放置在excel表格的第一列，然后提取后四位字符放置在excel表格的第二列中，以该列为关键列排序，第一列就会随之改变顺序。将排序后的第一列内容赋值给一个数组，利用VBA新建word文档并插入表格，然后读取数组内容，依次插入图片和文件名。
下文主要实现了第二种思路：
Sub 提取指定文件夹下图片名并排序()
Application.ScreenUpdating = False
On Error Resume Next
Dim MyFile As String
Dim count As Integer
Dim myPath As String
Dim myRow As Long
Dim i As Long
Dim arr
Dim arrName
Dim shp As Shape
Dim n As Long
Dim myPicWidth As Double
Dim myPicHeight As Double
myPicWidth = CDbl(InputBox("拟插入的图片宽度(cm)，一般为9cm", , 9))
myPicHeight = CDbl(InputBox("拟插入的图片高度(cm)，一般为6.7cm", , 6.7))
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
myPath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
'Debug.Print myPath
count = 1
MyFile = Dir(myPath & "*.jpg")
Columns(2).NumberFormatLocal = "@"
Do While MyFile <> ""
ActiveSheet.Cells(count, 1) = MyFile
count = count + 1
MyFile = Dir
If MyFile = "" Then
Exit Do
End If
Loop
myRow = ActiveSheet.Range("A65536").End(xlUp).Row
For i = 1 To myRow
Cells(i, 2).Value = CStr(Mid(Cells(i, 1), 14, 4))
Next
Range("a1").CurrentRegion.Sort key1:=Cells(1, 2), order1:=xlAscending, Header:=xlFalse
For i = 1 To myRow
Cells(i, 3) = myPath & Cells(i, 1)
Cells(i, 4) = Mid(Cells(i, 1).Value, 1, 17)
Next
arr = WorksheetFunction.Transpose(Range("c1:c" & myRow))
arrName = WorksheetFunction.Transpose(Range("d1:d" & myRow))
'******** 创建word文档，新建表格并插入图片********
Set wordAppl = CreateObject("Word.Application") '定义一个Word对象变量
With wordAppl
.Documents.Add '创建一个新的Word文档
.ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=myRow, NumColumns:=2 '插入6×2表格
Set myrange = .ActiveDocument.Tables(1) '创建表格对象
For i = 1 To myRow Step 2
With myrange
.Cell(i, 1).Range.InlineShapes.AddPicture Filename:=arr(i), LinkToFile:=False, SaveWithDocument:=True
.Cell(i, 2).Range.InlineShapes.AddPicture Filename:=arr(i + 1), LinkToFile:=False, SaveWithDocument:=True
.Cell(i + 1, 1).Range.InsertAfter arrName(i)
.Cell(i + 1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(i + 1, 2).Range.InsertAfter arrName(i + 1)
.Cell(i + 1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Next
For n = 1 To .ActiveDocument.InlineShapes.count 'InlineShapes 类型 图片
.ActiveDocument.InlineShapes(n).Height = myPicHeight * 28.345 '设置图片宽度
.ActiveDocument.InlineShapes(n).Width = myPicWidth * 28.345 '设置图片高度
Next n
myrange.AutoFitBehavior (wdAutoFitWindow)
.ActiveDocument.PageSetup.LeftMargin = Application.CentimetersToPoints(10.5 - myPicWidth)
.ActiveDocument.PageSetup.RightMargin = Application.CentimetersToPoints(10.5 - myPicWidth)
.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & "照片排版.doc" '保存新建Word文档与当前文件相同路径
.Documents.Close '关闭新建文档
.Quit '关闭新建文档窗口
End With
Set wordAppl = Nothing '释放存储空间
MsgBox Chr(10) & "成功创建照片排版.doc"
Sheets(1).UsedRange.Clear
Application.ScreenUpdating = True '打开屏幕刷新
End Sub
需要注意的地方有：
1、 第二列需要设置成文字格式，Columns(2).NumberFormatLocal = "@"否则后四位前面的0会消失不见。
2、 一定要关闭屏幕刷新！Application.ScreenUpdating = False，处理357张照片大概要用时40秒。否则将会带来漫长的等待。
使用软件前要求指定插入后图片的尺寸（单位是厘米），默认是9×6.7，排版后将自动设置好页面左右边距。
运行流程：
Snap1.jpg
Snap2.jpg
Snap3.jpg
Snap4.jpg
对于这个问题其实还有个更好的办法，那就是让别人去做，自己“只要结果不看过程”，当然前提是要有权力。
“客户的需求是千奇百怪的，老板的要求是经常变态的。”
常规的文件排序并插图的代码如下：
Sub 常规按名称排序并插图()
Application.ScreenUpdating = False
On Error Resume Next
Dim MyFile As String
Dim count As Integer
Dim myPath As String
Dim myRow As Long
Dim i As Long
Dim arr
Dim arrName
Dim shp As Shape
Dim n As Long
Dim myPicWidth As Double
Dim myPicHeight As Double
myPicWidth = CDbl(InputBox("拟插入的图片宽度(cm)，一般为9cm", , 9))
myPicHeight = CDbl(InputBox("拟插入的图片高度(cm)，一般为6.7cm", , 6.7))
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
myPath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
'Debug.Print myPath
count = 1
MyFile = Dir(myPath & "*.jpg")
Columns(2).NumberFormatLocal = "@"
Do While MyFile <> ""
ActiveSheet.Cells(count, 1) = MyFile
count = count + 1
MyFile = Dir
If MyFile = "" Then
Exit Do
End If
Loop
myRow = ActiveSheet.Range("A65536").End(xlUp).Row
For i = 1 To myRow
Cells(i, 3) = myPath & Cells(i, 1)
Cells(i, 4) = Mid(Cells(i, 1).Value, 1, 17)
Next
arr = WorksheetFunction.Transpose(Range("c1:c" & myRow))
arrName = WorksheetFunction.Transpose(Range("d1:d" & myRow))
'******** 创建word文档，新建表格并插入图片********
Set wordAppl = CreateObject("Word.Application") '定义一个Word对象变量
With wordAppl
.Documents.Add '创建一个新的Word文档
.ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=myRow, NumColumns:=2 '插入6×2表格
Set myrange = .ActiveDocument.Tables(1) '创建表格对象
For i = 1 To myRow Step 2
With myrange
.Cell(i, 1).Range.InlineShapes.AddPicture Filename:=arr(i), LinkToFile:=False, SaveWithDocument:=True
.Cell(i, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(i, 2).Range.InlineShapes.AddPicture Filename:=arr(i + 1), LinkToFile:=False, SaveWithDocument:=True
.Cell(i, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(i + 1, 1).Range.InsertAfter arrName(i)
.Cell(i + 1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(i + 1, 2).Range.InsertAfter arrName(i + 1)
.Cell(i + 1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Next
For n = 1 To .ActiveDocument.InlineShapes.count 'InlineShapes 类型 图片
.ActiveDocument.InlineShapes(n).Height = myPicHeight * 28.345 '设置图片宽度
.ActiveDocument.InlineShapes(n).Width = myPicWidth * 28.345 '设置图片高度
Next n
myrange.AutoFitBehavior (wdAutoFitWindow)
.ActiveDocument.PageSetup.LeftMargin = Application.CentimetersToPoints(10.5 - myPicWidth)
.ActiveDocument.PageSetup.RightMargin = Application.CentimetersToPoints(10.5 - myPicWidth)
.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & "照片排版.doc" '保存新建Word文档与当前文件相同路径
.Documents.Close '关闭新建文档
.Quit '关闭新建文档窗口
End With
Set wordAppl = Nothing '释放存储空间
MsgBox Chr(10) & "成功创建照片排版.doc！"
Sheets(1).UsedRange.Clear
Application.ScreenUpdating = True '打开屏幕刷新
End Sub
网友评论