1、1 插入图片自动放在表格中并获取图片的名字 （宏 VBA 代码） 如下格式 ： 风景 -01 风景 -02 风景 -03 风景 -04 风景 -05 风景 -06 2 实现上述格式的宏代码程序如下： Sub 每行插入表格 n 个图 () On Error Resume Next Application.ScreenUpdating = False Dim D As FileDialog, a, P As InlineShape, t As Table If Selection.Information(wdWithInTable) = True Then MsgBox “请将光标置于表格之外！
2、“: Exit Sub With Application.FileDialog(msoFileDialogFilePicker) .Title = “请选择 .“ If .Show = -1 Then n = InputBox(“请输入表格的列数： “, “列数 “, 3) M = .SelectedItems.Count Debug.Print “共有 “ M h = IIf(M / n = Int(M / n), 2 * M / n, 2 * (Int(M / n) + 1) Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)
3、t.Borders.Enable = True t.Borders.OutsideLineStyle = wdLineStyleSingle 设置表格的外边框的类型 For Each a In .SelectedItems B = Split(a, “)(UBound(Split(a, “) C = Split(B, “.“)(0) Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True) With P 设置图片的大小 w = .Width .Width = Int(410 / n) .Heig
4、ht = .Width * .Height / w End With 设置图片大小结束 i = i + 1 Selection.MoveLeft wdCharacter, 1 Selection.MoveDown wdLine, 1 Selection.TypeText C Selection.Cells(1).Select Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 决定了首行居中 Selection.HomeKey Selection.MoveDown wdLine, -1 Selection.MoveRight
5、 wdCharacter, 2 Debug.Print i, n If i = Val(n) Then Selection.MoveRight wdCharacter, 1 Selection.Cells(1).Select Selection.EndKey Selection.MoveDown wdLine, 1 i = 0 End If 3 Next End If End With Application.ScreenUpdating = True End Sub 4 如下格式： 风景 -16 风景 -01 5 实现上述格式的宏代码程序如下： Sub 简单无表格式 1 列插图 () Dim
6、 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 在此处修改相片宽
7、 ,单位厘米 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 = ActiveDocume
8、nt.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) 6 Exit For End If Next Basename = Left(tmpstring, Len(tmpstring) - 4) End Function
