利用VBA向Word中批量添加图片以及整理成Excel数据的图片名

今天女朋友工作上出了点麻烦，就是要向Word中批量添加图片以及整理成Excel数据的图片名。其中图片名需要设置段落和文字格式，有些图片还是共享一个图片名。这可是个繁琐而枯燥的工作。我一直相信重复劳动是对人这种智慧生物的侮辱（手动狗头，所以决定解放一下她。下面整理下需求：

1. 从文件夹中向Word里批量添加整理好的图片，并设置图片格式。
2. 为图片设置整理成Excel数据的图片名，其中有个难点是图片名是给好的，独特的，无法通过程序批量生成，只能通过程序引入。
3. 有些图片共用一个图片名，只需在最后一个图片下写入图片名，前面图片下面并不需要。

解决思路：

1. 因为Word、Excel都是微软的office产品，所以最佳方式还是利用VBA在Word中写宏来解决。
2. 有两个素材，一个是包含图片的文件夹和包含图片名数据的Excel表格。必须通过手选图片，选好图片后然后程序会根据图片数顺序选取相对应的数据写入图片名，并在其过程中，设置好图片和图片名格式。
3. 解决图片共用图片名问题 。好在她的问题中大多数共用图片名的图片个数为两个，可以通过选取图片数个数来做判断，不过这个个数也可以修改。

因为VBA使用的VB语言好久没用了，花时间搜集了点资料，粗略写出了这段程序，虽然还有很大优化空间，但是问题解决了，就暂时先用着，等以后有空再说。

下面是Word中写入的宏：

Sub InsertPic()
    Dim xlApp As Excel.Application    '从外部文件中读取和修改所用Excel数据的个数
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim anotherFileName As String
    Dim number As Integer    'Excel中被选用的数据的个数

    anotherFileName = "C:\Users\Feng\Desktop\111.xlsx"
    Set xlApp = New Excel.Application
    Set xlBook = xlApp.Workbooks.Open(anotherFileName)
    Set xlSheet = xlBook.Worksheets(1)

    Dim myfile As FileDialog
    Dim i As Integer '代表行号
    Dim j As Integer '代表列号
    Dim samePic As Integer '代表其实是一整张图的图数
    Dim countNum As Integer '设定如果是几个图为一个整图，前面图就跳过
    Dim r As String
    Dim c As String
    
    number = xlSheet.Cells(3, 5).Value   '这个位置是记录Excel中所用数据的个数的变量，就不设置主函数和功能函数了，代码不多，同时也利于检测是否共用了图片名
    i = number + 1 '设置开始行数
    j = 1   '设置开始列
    
    countNum = 0 '如果是整个图，就前面图跳过，从最后一个图开始写标题
    samePic = 2   '几张图是整图，就把这个数设置为几，例如两张图是整数，就把这个数设置为2
    
    
    Set myfile = Application.FileDialog(msoFileDialogFilePicker)
    With myfile
        .InitialFileName = "\"
        If .Show = -1 Then
            For Each fn In .SelectedItems
                countNum = countNum + 1
                Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)
                '按比例调整相片尺寸
                WidthNum = mypic.Width
                c = 20         '在此处修改相片宽,单位厘米
                mypic.Width = c * 28.35
                mypic.Height = (c * 28.35 / WidthNum) * mypic.Height
                If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
                    Selection.TypeParagraph    '在文末添加一空段
                Else
                    Selection.MoveDown
                End If
                
                If (myfile.SelectedItems.Count = samePic And countNum < samePic) Then    '如果选定的是两张图，那直接跳过第一张图，命名第二张
                    GoTo NextLoop
                Else
                     'Selection.Text = Basename(fn)    '函数取得文件名
                
                    chan = DDEInitiate(app:="Excel", topic:="system") '打开一个DDE通道
                    DDEExecute channel:=chan, Command:="[open(" & Chr(34) & "C:\Users\Feng\Desktop\111.xlsx" & Chr(34) & ")]"
                    '在一个应用程序中执行打开.xls文件命令，需要指出的是，文件所放位置需要修改为自己的文件位置。
                    DDETerminate channel:=chan '关闭DDE通道
                    chan = DDEInitiate(app:="Excel", topic:="111.xlsx") '打开一个DDE通道
                    dse = "r" + CStr(i) + "c" + CStr(j) '确定单元格位置
                    a = DDERequest(channel:=chan, Item:=dse)  '获取单元格数据
                     Selection.InsertAfter (a) '在鼠标停留位置插入获得数据
                    With Selection.ParagraphFormat             '设置文字段落格式
                    .Alignment = wdAlignParagraphCenter         '文字居中
                    With Selection.Font                 '设置文字字体格式
                    .Name = "宋体"
                    .Size = "14"
                    End With
                    End With
                    i = i + 1
                    number = number + 1
                    Selection.EndKey
                    
                    If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
                        Selection.TypeParagraph    '在文末添加一空段
                    Else
                        Selection.MoveDown
                    End If
                    
                End If
NextLoop:       Next fn '结束此次循环，继续下一个循环

        Else
        End If
    DDETerminateAll '关闭所有以及打开的DDE通道
    xlSheet.Cells(1, 5) = number
    xlApp.ActiveWorkbook.Close Savechanges:=True     '保存该工作表
    
    End With
    Set myfile = Nothing
    xlApp.Workbooks.Close '关闭此工作表

End Sub

注意要点：

1. 要引用Microsoft Excel Object Library。方式是“工具->引用->Microsoft Excel Object Library”。
2. 存放图片名的Excel数据表在宏运行前要关闭，不然会无法写入变量。造成图片名和图片不匹配。
3. 程序是通过识别选取图片数量来判断是否是公用图片名的，但是这个数量是可以修改的，通过修改程序中‘samePic’变量值来实现，如果无公用图片名可以将值设置为0。
4. 注意Excel表格中数据是自动选取的，所以Excel表格中数据要是排序好的，而且和你选取的图片要一一对应，否则会图片和图片名不吻合。数据开始的行和列也是可以修改的。
5. 关于图片的格式和图片名的格式都是可以根据需求修改的。
6. Word文档完全处理好之后，可以将Excel数据表第3行第5列设置的变量删除，但是程序运行过程中不要删除，否则会导致图片名又会从头开始读入。

因为程序临时写的，本身结构散乱并且有很多冗余瑕疵。欢迎随时提出其中问题，如果对您有用我会再次优化，另外遇到任何问题都可以在评论中提出来，我看到会及时回复的。