如何将图片批量导入word中并附加文件名.doc

Sub InsertPic()Dim myfile As FileDialogSet myfile = Application.FileDialog(msoFileDialogFilePicker)With myfile.InitialFileName = F:If .Show = -1 ThenFor Each fn In .SelectedItemsSet mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)按比例调整相片尺寸WidthNum = mypic.Widthc = 10在此处修改相片宽,单位厘米mypic.Width = c * 28.35mypic.Height = (c * 28.35 / WidthNum) * mypic.HeightIf Selection.Start = ActiveDocument.Content.End - 1 Then如光标在文末Selection.TypeParagraph在文末添加一空段ElseSelection.MoveDownEnd IfSelection.Text = Basename(fn)函数取得文件名Selection.EndKeyIf Selection.Start = ActiveDocument.Content.End - 1 Then如光标在文末Selection.TypeParagraph在文末添加一空段ElseSelection.MoveDownEnd IfNext fnElseEnd IfEnd WithSet myfile = NothingEnd SubFunction Basename(FullPath)取得文件名Dim x, yDim tmpstringtmpstring = FullPathx = Len(FullPath)For y = x To 1 Step -1If Mid(FullPath, y, 1) = Or _Mid(FullPath, y, 1) = : Or _Mid(FullPath, y, 1) = / Thentmpstring = Mid(FullPath, y + 1)Exit ForEnd IfNextBasename = Left(tmpstring, Len(tmpstring) - 4)End Function以上亲测可用！如何将图片批量导入word中并附加文件名(2013-12-04 10:44:35) 转载标签： word批量导入照片文件名分类： 电脑技术 新建一个空白的word文档。工具宏vb编辑器打开this document 把下面代码粘入编辑窗口保存打开这个word文档工具宏执行 下面的不用我说了，最后记得通配符批量替换照片就可以一行显示多张了。Sub InsertPic() Dim myfile As FileDialog Set myfile = Application.FileDialog(msoFileDialogFilePicker) With myfile .InitialFileName = F: If .Show = -1 Then For Each fn In .SelectedItems Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True) 按比例调整相片尺寸 WidthNum = mypic.Width c = 10 在此处修改相片宽,单位厘米 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 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 = NothingEnd SubFunction 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) = / Th