WORD 怎么批量插入照片并在照片底部命名?

lijun511

在一个文件件内有一百多张照片，我想批量插入WORD并且使得WORD中的照片下方有文字说明（说明内容是对应的照片的文件名），我已经设置好了WORD的页面正好每页能装2张照片（含文字说明），全选照片拖入WORD后能实现批量插入，但需要单个在底部写，请教大家有没有把照片批量插入并用照片的文件名作为WORD中照片底部文字说明的办法？

ammyc

用邮件合并应该可以。

szqhb

关注，严重关注！

就用2楼的方法吧
参考http://club.excelhome.net/forum.php?mod=viewthread&tid=166226
http://www.tudou.com/programs/view/DH9DoaMIHrc/
http://313663400.qzone.qq.com/

白月清风

Sub 插入图片()
Dim myfile As FileDialog
    Set myfile = Application.FileDialog(msoFileDialogFilePicker)
    With myfile
         .InitialFileName = "C:\"
            If .Show = -1 Then
            For Each fn In .SelectedItems
            
          Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)
           mypic.Width = 400 '根据需要设置
           mypic.Height = 300
             If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
                Selection.TypeParagraph '在文末添加一空段
                Else
                Selection.MoveDown
             End If
              Selection.Text = Basename(fn) '函数取得文件名
              Selection.EndKey
              
              If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
                Selection.TypeParagraph '在文末添加一空段
                Else
                Selection.MoveDown
               End If
            Next fn
            Else
           End If
    End With
    Set myfile = Nothing
End Sub

Function Basename(FullPath) '取得文件名
Dim x, y
Dim tmpstring
tmpstring = FullPath
x = Len(FullPath)
For y = x To 1 Step -1
If Mid(FullPath, y, 1) = "\" Or _
Mid(FullPath, y, 1) = ":" Or _
Mid(FullPath, y, 1) = "/" Then
tmpstring = Mid(FullPath, y + 1)
Exit For
End If
Next
Basename = Left(tmpstring, Len(tmpstring) - 4)
End Function

以上代码打开文件夹，选择一个或多个图片插入，插入100多张图片比较慢，基本可以实现楼主想法，最好是在空白word文件中测试
函数取得文件名代码是网上找的，稍加改动

szqhb

以上代码可用，且速度很快（我的是新配置的电脑），收藏了，谢谢白月清风。
关于相片的大小，代码中用的是什么单位，可否用厘米？

另外，可否让相片保持比例？
（比如，大家交上来的相片大小不一，强制大小好多相片都变形了，我只让其宽度保持3厘米，高则按比例缩放）

szqhb

经测试   
将
        mypic.Width = 400 '根据需要设置
        mypic.Height = 300
替换成下面代码即可按比例调整
         '按比例调整相片尺寸
           WidthNum = mypic.Width
           c = 3         '在此处修改相片宽,单位厘米
           mypic.Width = c * 28.35
           mypic.Height = (c * 28.35 / WidthNum) * mypic.Height

lijun511

谢谢白月清风，我试了，用你写的宏20秒左右插图125张照片，20秒完成了我20多分钟才能完成的事情，谢谢。

secowu

代码不错，非常方便哦，

1. 
   
2. 
   
3. 
   
4. 
   
5. Sub InsertPic()
   
6.     Dim myfile As FileDialog
   
7.     Set myfile = Application.FileDialog(msoFileDialogFilePicker)
   
8.     With myfile
   
9.         .InitialFileName = "F:"
   
10.         If .Show = -1 Then
    
11.             For Each fn In .SelectedItems
    
12. 
    
13.                 Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)
    
14.                 '按比例调整相片尺寸
    
15.                 WidthNum = mypic.Width
    
16.                 c = 10         '在此处修改相片宽,单位厘米
    
17.                 mypic.Width = c * 28.35
    
18.                 mypic.Height = (c * 28.35 / WidthNum) * mypic.Height
    
19.                 If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
    
20.                     Selection.TypeParagraph    '在文末添加一空段
    
21.                 Else
    
22.                     Selection.MoveDown
    
23.                 End If
    
24.                 Selection.Text = Basename(fn)    '函数取得文件名
    
25.                 Selection.EndKey
    
26. 
    
27.                 If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
    
28.                     Selection.TypeParagraph    '在文末添加一空段
    
29.                 Else
    
30.                     Selection.MoveDown
    
31.                 End If
    
32.             Next fn
    
33.         Else
    
34.         End If
    
35.     End With
    
36.     Set myfile = Nothing
    
37. End Sub
    
38. 
    
39. Function Basename(FullPath)    '取得文件名
    
40.     Dim x, y
    
41.     Dim tmpstring
    
42.     tmpstring = FullPath
    
43.     x = Len(FullPath)
    
44.     For y = x To 1 Step -1
    
45.         If Mid(FullPath, y, 1) = "" Or _
    
46.            Mid(FullPath, y, 1) = ":" Or _
    
47.            Mid(FullPath, y, 1) = "/" Then
    
48.             tmpstring = Mid(FullPath, y + 1)
    
49.             Exit For
    
50.         End If
    
51.     Next
    
52.     Basename = Left(tmpstring, Len(tmpstring) - 4)
    
53. End Function
    

复制代码

lhwhc

可能用得到的，先标记一下，以备后用

xsoft

Mark for study