ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 请大家帮忙看看下面这个文档怎么排版?

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-7-2 13:27 | 显示全部楼层 |阅读模式
要求将文件夹中的图片插入到word中,每行两张图片,每张图片下面是图片的名称。我找了一段代码如下:但是不知道如何修改将图片并列排版。
  1. Function Basename(FullPath) '取得文件名
  2.     Dim x, y
  3.     Dim tmpstring
  4.     tmpstring = FullPath
  5.     x = Len(FullPath)
  6.     For y = x To 1 Step -1
  7.         If Mid(FullPath, y, 1) = "" Or Mid(FullPath, y, 1) = ":" Or Mid(FullPath, y, 1) = "/" Then
  8.             tmpstring = Mid(FullPath, y + 1)
  9.             Exit For
  10.         End If
  11.     Next
  12.     Basename = Left(tmpstring, Len(tmpstring) - 4)
  13. End Function

  14. Sub 批量插入图片()
  15.     Dim myfile As FileDialog
  16.     Set myfile = Application.FileDialog(msoFileDialogFilePicker)
  17.     With myfile
  18.         .InitialFileName = "C:\Users\sunwg2\Desktop\照片排版word宏\常减压装置照片" '这里输入你要插入图片的目标文件夹
  19.         If .Show = -1 Then
  20.             For Each FN In .SelectedItems
  21.                 Set MyPic = Selection.InlineShapes.AddPicture(FileName:=FN, SaveWithDocument:=True)                '按比例调整相片尺寸
  22.                 WidthNum = MyPic.Width
  23.                 c = 3        '在此处修改相片宽,单位厘米
  24.                 MyPic.Width = c * 28.35
  25.                 MyPic.Height = (c * 28.35 / WidthNum) * MyPic.Height
  26.             
  27.                 If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
  28.                     Selection.TypeParagraph  '在文末添加一空段
  29.                 Else
  30.                     Selection.MoveRight
  31.                 End If
  32.                
  33.                 Selection.Text = Basename(FN)    '这两句移到这里
  34.                 Selection.EndKey
  35.                 If Selection.Start = ActiveDocument.Content.End - 1 Then  '如光标在文末
  36.                     Selection.TypeParagraph    '在文末添加一空段
  37.                 Else
  38.                     Selection.MoveRight
  39.                 End If
  40.             Next FN
  41.         Else
  42.         End If
  43.     End With
  44.    
  45.     Set myfile = Nothing
  46. End Sub
复制代码


Snap1.jpg

附件.rar

528.99 KB, 下载次数: 3

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-2 18:28 | 显示全部楼层
已解决。
  1. Sub 插入图片()
  2.     Dim myfile As FileDialog
  3.         Set myfile = Application.FileDialog(msoFileDialogFilePicker)
  4.         With myfile
  5.             .InitialFileName = ActiveDocument.Path
  6.             If .Show = -1 Then
  7.                 Dim FN As String
  8.                 For i = 1 To .SelectedItems.Count
  9.                     FN = myfile.SelectedItems.Item(i)
  10.                     Set MyPic = Selection.InlineShapes.AddPicture(FileName:=FN, SaveWithDocument:=True)
  11.                     MyPic.Width = 255
  12.                     MyPic.Height = 191
  13.                
  14.                     If i Mod 2 = 1 Then
  15.                         Selection.TypeParagraph
  16.                         Selection.Text = "                      " & Basename(FN) '此处的空格长度需要通过插入几张图片进行调整
  17.                         Selection.MoveUp unit:=wdLine, Count:=1
  18.                          Selection.MoveRight unit:=wdCharacter, Count:=1
  19.                          Selection.TypeText " "
  20.                     Else
  21.                         Selection.MoveDown unit:=wdLine, Count:=1
  22.                         Selection.Text = "                                            " & Basename(FN) '此处的空格长度需要通过插入几张图片进行调整
  23.                         Selection.EndKey
  24.                         Selection.TypeParagraph
  25.                     End If
  26.                     
  27.                     If i Mod 6 = 0 Then '要求每页只保存六张图片
  28.                         Selection.InsertBreak Type:=wdPageBreak
  29.                     End If
  30.                         
  31.                 Next
  32.             End If
  33.         End With
  34.         
  35.     Set myfile = Nothing
  36. End Function

  37. Function Basename(FullPath) '取得文件名
  38.     Dim x, y
  39.     Dim tmpstring
  40.     tmpstring = FullPath
  41.     x = Len(FullPath)
  42.     For y = x To 1 Step -1
  43.         If Mid(FullPath, y, 1) = "" Or Mid(FullPath, y, 1) = ":" Or Mid(FullPath, y, 1) = "/" Then
  44.             tmpstring = Mid(FullPath, y + 1)
  45.             Exit For
  46.         End If
  47.     Next
  48.     Basename = Left(tmpstring, Len(tmpstring) - 4)
  49. End Function



复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-3 08:06 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
  1. Sub 插入图片()
  2.        Application.ScreenUpdating = false
  3.        Dim myfile As FileDialog
  4.         Set myfile = Application.FileDialog(msoFileDialogFilePicker)
  5.         With myfile
  6.             .InitialFileName = ActiveDocument.Path
  7.             If .Show = -1 Then
  8.                 Dim FN As String
  9.                 For i = 1 To .SelectedItems.Count
  10.                     FN = myfile.SelectedItems.Item(i)
  11.                     Set MyPic = Selection.InlineShapes.AddPicture(FileName:=FN, SaveWithDocument:=True)
  12.                     MyPic.Width = 255
  13.                     MyPic.Height = 191
  14.                
  15.                     If i Mod 2 = 1 Then
  16.                         Selection.TypeParagraph
  17.                         Selection.Text = "                      " & Basename(FN) '此处的空格长度需要通过插入几张图片进行调整
  18.                         Selection.MoveUp unit:=wdLine, Count:=1
  19.                          Selection.MoveRight unit:=wdCharacter, Count:=1
  20.                          Selection.TypeText " "
  21.                     Else
  22.                         Selection.MoveDown unit:=wdLine, Count:=1
  23.                         Selection.Text = "                                            " & Basename(FN) '此处的空格长度需要通过插入几张图片进行调整
  24.                         Selection.EndKey
  25.                         Selection.TypeParagraph
  26.                     End If
  27.                     
  28.                     If i Mod 6 = 0 Then '要求每页只保存六张图片
  29.                         Selection.InsertBreak Type:=wdPageBreak
  30.                     End If
  31.                         
  32.                 Next
  33.             End If
  34.         End With
  35.         
  36.     Set myfile = Nothing
  37.     Application.ScreenUpdating = TrueEnd Sub

  38. Function Basename(FullPath) '取得文件名
  39.     Dim x, y
  40.     Dim tmpstring
  41.     tmpstring = FullPath
  42.     x = Len(FullPath)
  43.     For y = x To 1 Step -1
  44.         If Mid(FullPath, y, 1) = "" Or Mid(FullPath, y, 1) = ":" Or Mid(FullPath, y, 1) = "/" Then
  45.             tmpstring = Mid(FullPath, y + 1)
  46.             Exit For
  47.         End If
  48.     Next
  49.     Basename = Left(tmpstring, Len(tmpstring) - 4)
  50. End Function



复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-12-29 20:34 , Processed in 0.023252 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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