ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 701|回复: 8

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-11-24 12:28 | 显示全部楼层 |阅读模式
       自己在网络找了一个这种类型的代码,但是不太符合最终效果的要求,自己又不会修改,所以做了一个文档,把现有的代码和效果以及将来要呈现的效果都贴出来,求助帮忙修改一下。
       谢谢了
       具体请看附件,谢谢




image.jpg



求助批量表格插入图片实例.rar

20.89 KB, 下载次数: 37

TA的精华主题

TA的得分主题

发表于 2020-11-24 13:45 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-11-24 13:47 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
约定的童话 发表于 2020-11-24 13:45
http://club.excelhome.net/thread-1564740-1-1.html参考这里

谢谢
我先看看

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-12-14 06:58 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
刷新下帖子 ,还没结果

TA的精华主题

TA的得分主题

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-12-17 16:01 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
413191246se 发表于 2020-12-14 22:23
楼主,批量表格,我建议 楼主 自己 先画出来,至少 3 个才好,我看到的只有一个示例表格,不够批量。

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

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

TA的精华主题

TA的得分主题

发表于 2020-12-18 01:13 | 显示全部楼层
本帖最后由 413191246se 于 2020-12-18 10:23 编辑

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

TA的精华主题

TA的得分主题

发表于 2020-12-18 01:35 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
*** 楼主,上楼代码有问题!请用本楼代码试试:
  1. Sub Word表格批量插入图片_top()
  2.     Dim D As FileDialog, a, P As InlineShape, t As Table, n$, mc$, m&, h$, w!, i&, b$, c$, j&
  3.     Documents.Add
  4.     With Application.FileDialog(msoFileDialogFilePicker)
  5.         .Title = "请选择包含图片的文件夹,打开后选择所有图片!"
  6.         If .Show = -1 Then
  7. '            n = InputBox("请输入表格的列数:", "列数", 1)
  8. '            mc = InputBox("是否同时插入名称?", "名称", 1)
  9.             n = 1: mc = 1
  10.             
  11.             m = .SelectedItems.Count
  12.             If mc = 1 Then
  13.                 h = IIf(m / n = Int(m / n), 2 * m / n, 2 * (Int(m / n) + 1))
  14.             Else
  15.                 h = IIf(m / n = Int(m / n), m / n, (Int(m / n) + 1))
  16.             End If
  17.             Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)
  18.             With t
  19.                 .Borders.Enable = True
  20.                 .Borders.InsideColor = wdColorLightBlue    '内部线条显色'
  21.                 .Borders.OutsideColor = wdColorLightBlue   '外部线条显色
  22. '                .Borders.OutsideLineStyle = wdLineStyleDouble '外部线条样式
  23.                 .Borders.OutsideLineWidth = wdLineWidth075pt '线条宽度
  24.             End With
  25.             
  26.             For Each a In .SelectedItems
  27.                 If mc = 1 Then
  28.                     b = Split(a, "")(UBound(Split(a, "")))    '或修改成b.name
  29.                     c = Split(b, ".")(0)
  30.                     With Selection
  31.                         .TypeText c '键入文件名
  32.                         .Cells(1).Select
  33.                         .Font.Bold = True
  34.                         .Font.Size = 14
  35.                         .ParagraphFormat.Alignment = wdAlignParagraphCenter    '决定了首行居中
  36.                         .HomeKey
  37.                         .MoveDown wdLine, 1 '光标下移
  38.                     End With
  39.                 Else
  40.                     Selection.MoveRight wdCharacter, 1 '光标右移两个单元,到右边单元格
  41.                 End If

  42.                 Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)
  43.                 With P
  44.                     w = .Width
  45.                     .Width = Int(410 / n)
  46.                     .Height = .Width * .Height / w
  47.                 End With
  48.                 i = i + 1
  49.                
  50.                  If i = Val(n) Then
  51.                     If mc = 1 Then
  52.                         With Selection
  53.                             .MoveLeft wdCharacter, 1
  54.                             .Cells(1).Select
  55.                             .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
  56.                             .EndKey
  57.                             .MoveDown wdLine, 1
  58.                             End With
  59.                         i = 0
  60.                     Else
  61.                          Selection.MoveRight wdCharacter, 1
  62.                          i = 0
  63.                     End If
  64.                 End If
  65.             Next
  66.         End If
  67.     End With
  68.    
  69. '''
  70.     With ActiveDocument
  71.         With .PageSetup
  72.             .TopMargin = CentimetersToPoints(4.5) '上边距可修改
  73.             .BottomMargin = CentimetersToPoints(4.5) '下边距可修改
  74.         End With
  75.         Do
  76.             j = j + 2
  77.             .Tables(1).Rows(j).HeightRule = wdRowHeightExactly
  78.             .Tables(1).Rows(j).Height = CentimetersToPoints(9) '图片所在行高可修改
  79.         Loop Until j = 2 * m
  80.     End With
  81.    
  82. '''最后一磅
  83.     With ActiveDocument.Paragraphs
  84.         With .Last.Range
  85.             If .Text = vbCr Then .Delete
  86.         End With
  87.         With .Last.Range
  88.             If .Text = vbCr Then
  89.                 With .Font
  90.                     .Size = 1
  91.                     .Kerning = 0
  92.                     .DisableCharacterSpaceGrid = True
  93.                 End With
  94.                 With .ParagraphFormat
  95.                     .LineSpacing = LinesToPoints(0.06)
  96.                     .AutoAdjustRightIndent = False
  97.                     .DisableLineHeightGrid = True
  98.                 End With
  99.             End If
  100.         End With
  101.     End With
  102.     Selection.HomeKey 6
  103. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2020-12-18 15:09 | 显示全部楼层
  1. Sub Word表格批量插入图片_Right()
  2.     Dim D As FileDialog, a, P As InlineShape, t As Table, n$, mc$, m&, h$, w!, i&, b$, c$, j&
  3.     Documents.Add
  4.     With Application.FileDialog(msoFileDialogFilePicker)
  5.         .Title = "请选择包含图片的文件夹,打开后选择所有图片!"
  6.         If .Show = -1 Then
  7. '            n = InputBox("请输入表格的列数:", "列数", 1)
  8. '            mc = InputBox("是否同时插入名称?", "名称", 1)
  9.             n = 2: mc = 1
  10.             
  11.             m = .SelectedItems.Count
  12.             If mc = 1 Then
  13.                 h = IIf(m / n = Int(m / n), 2 * m / n, 2 * (Int(m / n) + 1))
  14.             Else
  15.                 h = IIf(m / n = Int(m / n), m / n, (Int(m / n) + 1))
  16.             End If
  17.             Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)
  18.             With t
  19.                 .Borders.Enable = True
  20.                 .Borders.InsideColor = wdColorLightBlue    '内部线条显色'
  21.                 .Borders.OutsideColor = wdColorLightBlue   '外部线条显色
  22. '                .Borders.OutsideLineStyle = wdLineStyleDouble '外部线条样式
  23.                 .Borders.OutsideLineWidth = wdLineWidth075pt '线条宽度
  24.             End With
  25.             
  26.             For Each a In .SelectedItems
  27.                 If mc = 1 Then
  28.                     b = Split(a, "")(UBound(Split(a, "")))    '或修改成b.name
  29.                     c = Split(b, ".")(0)
  30.                     With Selection
  31.                         If c Like "*:*" Then c = Mid(c, InStrRev(c, "") + 1, Len(c) - InStrRev(c, ""))
  32.                         .TypeText c '键入文件名
  33.                         .Cells(1).Select
  34.                         .Font.Bold = True
  35.                         .Font.Size = 14
  36.                         .ParagraphFormat.Alignment = wdAlignParagraphCenter    '决定了首行居中
  37.                         .MoveRight Unit:=wdCell
  38.                     End With
  39.                 Else
  40.                     Selection.MoveRight Unit:=wdCell '光标右移两个单元,到右边单元格
  41.                 End If

  42.                 Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)
  43.                 With P
  44.                     w = .Width
  45.                     .Width = Int(820 / n) '410
  46.                     .Height = .Width * .Height / w
  47.                 End With
  48.                 i = i + 1
  49.                
  50.                 If i = Val(n) Then
  51.                     If mc = 1 Then
  52.                         i = 0
  53.                     Else
  54.                          i = 0
  55.                     End If
  56.                 End If
  57.                 Selection.MoveRight Unit:=wdCell
  58.             Next
  59.         End If
  60.     End With
  61.    
  62. '''
  63.     With ActiveDocument
  64.         .Tables(1).Rows.Last.Delete
  65.         With .PageSetup
  66.             .TopMargin = CentimetersToPoints(5) '上边距可修改
  67.             .BottomMargin = CentimetersToPoints(6) '下边距可修改
  68.         End With
  69.         Do
  70.             j = j + 1
  71.             With .Tables(1)
  72.                 .Rows(j).HeightRule = wdRowHeightExactly
  73.                 .Rows(j).Height = CentimetersToPoints(9) '图片所在行高可修改
  74.                 .Columns(1).Width = CentimetersToPoints(2.4)
  75.                 .Columns(2).Width = CentimetersToPoints(12.6)
  76.                 .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
  77.             End With
  78.         Loop Until j = m
  79.     End With
  80.    
  81. '''最后一磅
  82.     With ActiveDocument.Paragraphs
  83.         With .Last.Range
  84.             If .Text = vbCr Then .Delete
  85.         End With
  86.         With .Last.Range
  87.             If .Text = vbCr Then
  88.                 With .Font
  89.                     .Size = 1
  90.                     .Kerning = 0
  91.                     .DisableCharacterSpaceGrid = True
  92.                 End With
  93.                 With .ParagraphFormat
  94.                     .LineSpacing = LinesToPoints(0.06)
  95.                     .AutoAdjustRightIndent = False
  96.                     .DisableLineHeightGrid = True
  97.                 End With
  98.             End If
  99.         End With
  100.     End With
  101.     Selection.HomeKey 6
  102. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 17:41 , Processed in 0.097648 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表