Excel VBA 将图片按名称后四位排序并插入Word文档中

今天遇到这样一个有趣的需求：
“照片”文件夹下有数百张图片，其名称如“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