在word中批量插入图片的宏脚本

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

Sub InsertPics()
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2.54) '上页边距
.BottomMargin = CentimetersToPoints(2.54) '下页边距
.LeftMargin = CentimetersToPoints(1) '左页边距
.RightMargin = CentimetersToPoints(1) '右页边距
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.5) '页眉
.FooterDistance = CentimetersToPoints(1.75) '页脚
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7) '纸张大小
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
.LayoutMode = wdLayoutModeLineGrid
End With
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type <> wdPrintView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
With ActiveDocument.PageSetup.TextColumns
.SetCount NumColumns:=2 '分为两栏
.EvenlySpaced = True
.LineBetween = False
.Width = CentimetersToPoints(9.12)
.Spacing = CentimetersToPoints(0.75)
End With
Dim myfile As FileDialog
Dim n
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 = "Plot" + Trim(Str(n)) + " " + Basename(fn) '函数取得

文件名
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.EndKey
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If
n = n + 1
Next fn
Else
End If
End With
Set myfile = Nothing
End Sub