word表格批量插入图片、文件名代码的修改

snow653124 · 发表于 2020-11-24 12:28

   自己在网络找了一个这种类型的代码，但是不太符合最终效果的要求，自己又不会修改，所以做了一个文档，把现有的代码和效果以及将来要呈现的效果都贴出来，求助帮忙修改一下。
   谢谢了
   具体请看附件，谢谢

约定的童话 · 发表于 2020-11-24 13:45

http://club.excelhome.net/thread-1564740-1-1.html参考这里

snow653124 · 发表于 2020-11-24 13:47

约定的童话发表于 2020-11-24 13:45
http://club.excelhome.net/thread-1564740-1-1.html参考这里

谢谢
我先看看

snow653124 · 发表于 2020-12-14 06:58

刷新下帖子，还没结果

413191246se · 发表于 2020-12-14 22:23

楼主，批量表格，我建议楼主自己先画出来，至少 3 个才好，我看到的只有一个示例表格，不够批量。

snow653124 · 发表于 2020-12-17 16:01

413191246se 发表于 2020-12-14 22:23
楼主，批量表格，我建议楼主自己先画出来，至少 3 个才好，我看到的只有一个示例表格，不够批量。

我贴的这段代码逆行之后，你只用选择图片，它会自动生成框和文字，这个是图1，然后我要图2和图3的效果，就是在现有的代码上修改。

不是说我自己要画框贴图，然后写上图片的名称运行批处理，它变成图2和图3的效果。而是直接运行，只管选择图片以达到这种效果。

413191246se · 发表于 2020-12-18 01:13

本帖最后由 413191246se 于 2020-12-18 10:23 编辑

* 谢谢楼主解释！请详见下楼。

413191246se · 发表于 2020-12-18 01:35

*** 楼主，上楼代码有问题！请用本楼代码试试：

Sub Word表格批量插入图片_top()
Dim D As FileDialog, a, P As InlineShape, t As Table, n$, mc$, m&, h$, w!, i&, b$, c$, j&
Documents.Add
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选择包含图片的文件夹，打开后选择所有图片！"
If .Show = -1 Then
' n = InputBox("请输入表格的列数：", "列数", 1)
' mc = InputBox("是否同时插入名称？", "名称", 1)
n = 1: mc = 1
m = .SelectedItems.Count
If mc = 1 Then
h = IIf(m / n = Int(m / n), 2 * m / n, 2 * (Int(m / n) + 1))
Else
h = IIf(m / n = Int(m / n), m / n, (Int(m / n) + 1))
End If
Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)
With t
.Borders.Enable = True
.Borders.InsideColor = wdColorLightBlue '内部线条显色'
.Borders.OutsideColor = wdColorLightBlue '外部线条显色
' .Borders.OutsideLineStyle = wdLineStyleDouble '外部线条样式
.Borders.OutsideLineWidth = wdLineWidth075pt '线条宽度
End With
For Each a In .SelectedItems
If mc = 1 Then
b = Split(a, "")(UBound(Split(a, ""))) '或修改成b.name
c = Split(b, ".")(0)
With Selection
.TypeText c '键入文件名
.Cells(1).Select
.Font.Bold = True
.Font.Size = 14
.ParagraphFormat.Alignment = wdAlignParagraphCenter '决定了首行居中
.HomeKey
.MoveDown wdLine, 1 '光标下移
End With
Else
Selection.MoveRight wdCharacter, 1 '光标右移两个单元，到右边单元格
End If
Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)
With P
w = .Width
.Width = Int(410 / n)
.Height = .Width * .Height / w
End With
i = i + 1
If i = Val(n) Then
If mc = 1 Then
With Selection
.MoveLeft wdCharacter, 1
.Cells(1).Select
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
.EndKey
.MoveDown wdLine, 1
End With
i = 0
Else
Selection.MoveRight wdCharacter, 1
i = 0
End If
End If
Next
End If
End With
'''
With ActiveDocument
With .PageSetup
.TopMargin = CentimetersToPoints(4.5) '上边距可修改
.BottomMargin = CentimetersToPoints(4.5) '下边距可修改
End With
Do
j = j + 2
.Tables(1).Rows(j).HeightRule = wdRowHeightExactly
.Tables(1).Rows(j).Height = CentimetersToPoints(9) '图片所在行高可修改
Loop Until j = 2 * m
End With
'''最后一磅
With ActiveDocument.Paragraphs
With .Last.Range
If .Text = vbCr Then .Delete
End With
With .Last.Range
If .Text = vbCr Then
With .Font
.Size = 1
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.LineSpacing = LinesToPoints(0.06)
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
End If
End With
End With
Selection.HomeKey 6
End Sub

复制代码

413191246se · 发表于 2020-12-18 15:09

Sub Word表格批量插入图片_Right()
Dim D As FileDialog, a, P As InlineShape, t As Table, n$, mc$, m&, h$, w!, i&, b$, c$, j&
Documents.Add
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选择包含图片的文件夹，打开后选择所有图片！"
If .Show = -1 Then
' n = InputBox("请输入表格的列数：", "列数", 1)
' mc = InputBox("是否同时插入名称？", "名称", 1)
n = 2: mc = 1
m = .SelectedItems.Count
If mc = 1 Then
h = IIf(m / n = Int(m / n), 2 * m / n, 2 * (Int(m / n) + 1))
Else
h = IIf(m / n = Int(m / n), m / n, (Int(m / n) + 1))
End If
Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)
With t
.Borders.Enable = True
.Borders.InsideColor = wdColorLightBlue '内部线条显色'
.Borders.OutsideColor = wdColorLightBlue '外部线条显色
' .Borders.OutsideLineStyle = wdLineStyleDouble '外部线条样式
.Borders.OutsideLineWidth = wdLineWidth075pt '线条宽度
End With
For Each a In .SelectedItems
If mc = 1 Then
b = Split(a, "")(UBound(Split(a, ""))) '或修改成b.name
c = Split(b, ".")(0)
With Selection
If c Like "*:*" Then c = Mid(c, InStrRev(c, "") + 1, Len(c) - InStrRev(c, ""))
.TypeText c '键入文件名
.Cells(1).Select
.Font.Bold = True
.Font.Size = 14
.ParagraphFormat.Alignment = wdAlignParagraphCenter '决定了首行居中
.MoveRight Unit:=wdCell
End With
Else
Selection.MoveRight Unit:=wdCell '光标右移两个单元，到右边单元格
End If
Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)
With P
w = .Width
.Width = Int(820 / n) '410
.Height = .Width * .Height / w
End With
i = i + 1
If i = Val(n) Then
If mc = 1 Then
i = 0
Else
i = 0
End If
End If
Selection.MoveRight Unit:=wdCell
Next
End If
End With
'''
With ActiveDocument
.Tables(1).Rows.Last.Delete
With .PageSetup
.TopMargin = CentimetersToPoints(5) '上边距可修改
.BottomMargin = CentimetersToPoints(6) '下边距可修改
End With
Do
j = j + 1
With .Tables(1)
.Rows(j).HeightRule = wdRowHeightExactly
.Rows(j).Height = CentimetersToPoints(9) '图片所在行高可修改
.Columns(1).Width = CentimetersToPoints(2.4)
.Columns(2).Width = CentimetersToPoints(12.6)
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
Loop Until j = m
End With
'''最后一磅
With ActiveDocument.Paragraphs
With .Last.Range
If .Text = vbCr Then .Delete
End With
With .Last.Range
If .Text = vbCr Then
With .Font
.Size = 1
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.LineSpacing = LinesToPoints(0.06)
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
End If
End With
End With
Selection.HomeKey 6
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] word表格批量插入图片、文件名代码的修改