寻找WORD VBA高手解决WORD批量插入图片程序的问题

Posted 2023-05-02

那位高手帮偶一下吧！！将下面的程序能在图片的上面添加文件名（此程序是在图片下面加文件名）高分感谢啊~
Sub 批量插入图片()
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "D:\111"
If .Show = -1 Then
For Each Fn In .SelectedItems
Set mypic = Selection.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
'按比例调整相片尺寸
WidthNum = mypic.Width
c = 18 '在此处修改相片宽,单位厘米
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 = 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

Selection.Text = Basename(Fn) '这两句移到这里
Selection.EndKey

这两句移一下位置，其它不变。

Sub 批量插入图片()
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "D:\111"
If .Show = -1 Then
For Each Fn In .SelectedItems
Selection.Text = Basename(Fn) '这两句移到这里
Selection.EndKey
Set mypic = Selection.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
'按比例调整相片尺寸
WidthNum = mypic.Width
c = 18 '在此处修改相片宽,单位厘米
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
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追问

谢谢老师的回答　试了一下结果文件名在图片的旁边没有换行（文件名+图片）+处是换行就对了能否请老师再帮一下　万分感谢

追答

Sub 批量插入图片()
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "D:\111"
If .Show = -1 Then
For Each Fn In .SelectedItems
Selection.Text = Basename(Fn) '这两句移到这里
Selection.EndKey
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If

Set mypic = Selection.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
'按比例调整相片尺寸
WidthNum = mypic.Width
c = 18 '在此处修改相片宽,单位厘米
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
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

参考技术A

参考技术B 这个好像很难 哦。追问

能解决吗　可追分

VBA批量导入图片到多Word文档并加标题（会飞的鱼）

感谢会飞的鱼大牛~

 1 Public fp$, obmapp As Object
 2 Sub kk()
 3 文件夹浏览器
 4 Application.ScreenUpdating = False
 5 Set fso = CreateObject("scripting.filesystemobject")
 6 If fp = "" Then Exit Sub
 7 Set ff = fso.getfolder(fp)
 8 For x = 1 To 17
 9     Documents.Add DocumentType:=wdNewBlankDocument
10     For Each fd In ff.subfolders
11         t = Int(fd.Files.Count / 17)
12         For y = 1 To t
13             Selection.InlineShapes.AddPicture FileName:=fd & "\" & x * t - t + y & ".png", LinkToFile:=False, SaveWithDocument:=True
14             Selection.TypeParagraph
15             Selection.TypeText Text:=fd.Name & "_" & Format(x * t - t + y, "00") & Chr(13)
16         Next
17     Next
18     Selection.WholeStory
19     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
20     
21     ‘替换名称中的+为/
22     Selection.Find.ClearFormatting
23     Selection.Find.Replacement.ClearFormatting
24     With Selection.Find
25         .Text = "+"
26         .Replacement.Text = "/"
27         .Forward = True
28         .Wrap = wdFindContinue
29         .Format = False
30         .MatchCase = False
31         .MatchWholeWord = False
32         .MatchByte = True
33         .MatchWildcards = False
34         .MatchSoundsLike = False
35         .MatchAllWordForms = False
36     End With
37     Selection.Find.Execute Replace:=wdReplaceAll
38     ‘上面是录制的宏
39     ActiveDocument.SaveAs2 FileName:=fp & "\" & x & ".docx"
40     ActiveWindow.Close
41 Next
42 Application.ScreenUpdating = True
43 End Sub
44 Sub 文件夹浏览器()
45     Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)
46     If Not obmapp Is Nothing Then
47         fp = obmapp.Self.Path & ""
48     Else
49         Exit Sub
50     End If
51 End Sub