word中插入照片或图片到表格

zhk19871204

word中插入照片或图片到表格，并根据照片或图片名将照片或图名插入对应的照片或图片的上方或下方，该功能是用VBA代码来实现的，具体代码如下：
一、顶部显示代码如下：

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

二、底部显示代码如下：

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-1 , C).Range.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
                        WW = .Width
                        .Width = W         '设置图片宽度
                        .Height = .Height * (W / WW)       '设置图片高度
                    End With
                   .Cell(R * 2, 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

zhlxmb

怎么用？

huangwei6

学习学习

zergk66

学习一下

qinccckencn

谢谢提供分享学习学习了

木叶飘

额，这得多大工作量啊，都上代码了。

zhk19871204

木叶飘 发表于 2023-7-6 08:32
额，这得多大工作量啊，都上代码了。

是的，在实际工作中发现需要插入的照片太多了

飞龙天

:zt:zt:zt:zt

yrxjjj@qq.com

谢谢分享

巫行雲

word中插入照片或图片到表格