WORD批量插入照片并在照片顶部命名

Slay月幕

如题,在论坛找的代码,运行后照片命名在底部,如果让照片命名在顶部应该这样修改代码呢?第一次用Word VBA不知道怎样修改,求大神指教,谢谢

zpy2

word比较难，用html方式显示图片
也可以的。

Slay月幕

zpy2 发表于 2021-2-6 06:24
word比较难，用html方式显示图片
也可以的。

感谢回复，但是我只想知道在图片顶部显示文件名应该怎样修改

Jason_WangSS

zpy2

Slay月幕 发表于 2021-2-6 08:28
感谢回复，但是我只想知道在图片顶部显示文件名应该怎样修改

Attribute VB_Name = "模块1"
Sub InsertPic()     '批量插入图片到Word文档
Dim CL, I&, Fn, ST&, RL&, SI
Dim W As Double, WW As Double
If Selection.Information(wdWithInTable) = True Then '在表格中则退出
    MsgBox "请选择非表格区域.", vbCritical + vbOKOnly, "警告..."    '如果选择的是表格区域，则警告并退出运行
    Exit Sub
End If

CL = InputBox("请输入插入图片的列数.", "输入...", "3")  '设置插入图片的列数，默认为3列
If Not VBA.IsNumeric(CL) Then   '判断输入值是否为数字
    If CL = "" Then Exit Sub
    MsgBox "必须输入数字.", vbCritical + vbOKOnly, "警告..."
    Exit Sub
End If

If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
    Selection.TypeParagraph '在文末添加一空段
Else
    Selection.EndKey
End If

With ActiveDocument.PageSetup
    W = (.PageWidth - .LeftMargin - .RightMargin) / CL
End With

Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)    '选择文件
    .InitialView = msoFileDialogViewList
    .Filters.Add "图片文件", "*.jpg,*.png,*.bmp", 1
    .AllowMultiSelect = True
    If .Show = -1 Then
    Selection.EndKey
    ST = .SelectedItems.Count
            RL = ((ST \ CL) + Sgn(ST Mod CL)) * 2
     
        Set SI = .SelectedItems
        Dim R&, C&, K&
        With ActiveDocument.Tables.Add(Selection.Range, RL, CL, 1, 1)    '新建表格
            .Borders.Enable = True     '默认不设置框线
                For Each Fn In SI   '开始循环
                    K = K + 1
                    R = (K - 1) \ CL + 1    '现在行
                    C = (K - 1) Mod CL + 1      '现在列
                       With .Cell(R * 2 , C).Range.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
                        WW = .Width
                        .Width = W         '设置图片宽度
                        .Height = .Height * (W / WW)       '设置图片高度
                    End With
                   .Cell(R * 2-1, C).Range.Text = Basename(Fn)       '在图片下方写入图片名称
                Next Fn
        End With
    End If
End With
Selection.HomeKey   '光标回到首行
Application.ScreenUpdating = True
'MsgBox "ok", vbInformation + vbOKOnly, "提示..."
End Sub

Function Basename(FullPath) '取得文件名
Basename = Mid(FullPath, InStrRev(FullPath, "\") + 1)
Basename = Left(Basename, Len(Basename) - 4)
End Function

Slay月幕

zpy2 发表于 2021-2-6 09:10
Attribute VB_Name = "模块1"
Sub InsertPic()     '批量插入图片到Word文档
Dim CL, I&, Fn, ST&, ...

谢谢老师！

同心/ty

zpy2 发表于 2021-2-6 09:10
Attribute VB_Name = "模块1"
Sub InsertPic()     '批量插入图片到Word文档
Dim CL, I&, Fn, ST&, ...

老师，你好！我是新手，能否移步，帮我解决困绕我一个来月的问题。谢谢！ https://club.excelhome.net/threa ... tml?_dsign=1b8339ef