您好！求大神指教，您下面这宏代码，怎样修改可以实现“把多张照片输出到指定的Word文档中”？拜求！
Sub InsertPicAndSaveas()
Dim InPath As String
Dim OutPath As String
Dim Pos As Long, Fname As String, Ext As String
InPath = "C:\我的照片集\" '你的照片放在哪个文件夹下，自行修改成真实的
OutPath = "C:\Out\" 'Word插入一张照片后换名保存在哪个文件夹下，自行修改成真实的
If Dir(InPath, vbDirectory) = "" Then
MsgBox "您指定的输入目录不存在！需重新指定真实存在的。", vbCritical + vbOKOnly, "消息"
Exit Sub
End If
If Dir(OutPath, vbDirectory) = "" Then
MsgBox "您指定的输出目录不存在！需重新指定真实存在的。", vbCritical + vbOKOnly, "消息"
Exit Sub
End If
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
Fname = Dir(InPath & "\*.*")
Do While Fname <> ""
Pos = InStrRev(Fname, ".")
Ext = Mid(Fname, Pos + 1)
Fname = Left(Fname, Pos)
If InStr("jpg jpeg bmp gif png tif", LCase(Ext)) Then '不是图片文件就忽略了
Selection.InlineShapes.AddPicture FileName:=InPath & "\" & Fname & Ext, LinkToFile:=False, _
SaveWithDocument:=True
ActiveDocument.SaveAs FileName:=OutPath & "\" & Fname & "doc", FileFormat:=0, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
End If
Fname = Dir()
DoEvents
Loop
MsgBox "处理完毕！ 更多批量处理功能，请参见《文件 批量 处理 百宝箱 V10.0》", vbInformation + vbOKOnly, "消息"
ActiveDocument.Saved = True
ActiveDocument.Close
Application.Quit
End Sub
Dim InPath As String
Dim OutPath As String
Dim WrdApp as object,WrdDoc as object
Dim Pos As Long, Fname As String, Ext As String
InPath = "C:\我的照片集\" '你的照片放在哪个文件夹下，自行修改成真实的
OutPath = "C:\Out
\" 'Word插入一张照片后换名保存在哪个文件夹下，自行修改成真实的
If Dir(InPath, vbDirectory) = "" Then
MsgBox "您指定的输入目录不存在！需重新指定真实存在的。", vbCritical + vbOKOnly, "消息"
Exit Sub
End If
If Dir(OutPath, vbDirectory) = "" Then
MsgBox "您指定的输出目录不存在！需重新指定真实存在的。", vbCritical + vbOKOnly, "消息"
Exit Sub
End If
Set WrdApp=getobject(,"Word.Application")
set WrdDoc=WrdApp.Documents.open("C:\你指定的Word文档.doc")
WrdApp.Selection.WholeStory
WrdApp.Selection.Delete Unit:=wdCharacter, Count:=1
Fname = Dir(InPath & "\*.*")
Do While Fname <> ""
Pos = InStrRev(Fname, ".")
Ext = Mid(Fname, Pos + 1)
Fname = Left(Fname, Pos)
If InStr("jpg jpeg bmp gif png tif", LCase(Ext)) Then '不是图片文件就忽略了
WrdApp.Selection.InlineShapes.AddPicture FileName:=InPath & "\" & Fname & Ext, LinkToFile:=False, _
SaveWithDocument:=True
WrdDoc.SaveAs FileName:=OutPath & "\" & Fname & "doc", FileFormat:=0, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
WrdApp.Selection.WholeStory
WrdApp.Selection.Delete Unit:=wdCharacter, Count:=1
End If
Fname = Dir()
DoEvents
Loop
MsgBox "处理完毕！ 更多批量处理功能，请参见《文件 批量 处理 百宝箱 V10.0》", vbInformation + vbOKOnly, "消息"
WrdDoc.Saved = True
WrdDoc.Close
WrdApp.Quit
End Sub来自：求助得到的回答
