批量插入图片

candyafteryou

想找excel批量插入的，这个word的也很方便，收藏了

書時

受教了，这个不错啊！赞

wzh11

厉害啊，学习啊！

ai饭团8

楼主真厉害，先收藏了，万一以后用到了呢！！！

2805712057

我是新手，有两个问题请教，请不要见笑：
1、Sub setpicsize()
'
' setpicsize 宏
'
'
Dim iSha As InlineShape
For Each iSha In ActiveDocument.InlineShapes
If iSha.Type = wdInlineShapePicture Then
    iSha.LockAspectRatio = msoFalse    '不锁定纵横比
      iSha.Width = CentimetersToPoints(9#)  '宽5CM
        iSha.Height = CentimetersToPoints(9.2) '高5CM
          End If
          Next

End Sub
这个代码只能对嵌入格式的照片进行操作,其他格式的如"衬于文字下方"就没操作,有没有对为种格式操作的方法。
2、想将4张照片复制到文档后，运行代码就能上下两排，排列整齐。请帮忙写下代码。谢谢！

2805712057

补充一下，每张照片大小高：6.8CM、宽：10CM；页面是横向的。谢谢！

lujkhua

鼠标点选文件夹才比较方便

458863601

如何自定义设置图片的大小尺寸？

458863601

如何自定义设置图片的大小尺寸？

MCXY

tangqingfu 发表于 2011-12-6 08:35
能否将文件夹的地址改为可选取，而非输入的方式？

1. Sub 图片批插() Rem ************************************************************ Rem 作 者： 张斌 Rem 功 能： 将扫描业绩图片文件批量插入word文件中 Rem 备 注： 需要改进 Rem 反馈邮箱:gogozb@163.com Rem 业务联系QQ：1065886598 Rem 帖子：http://club.excelhome.net/forum.php?mod=guide&view=my Rem ************************************************************ Rem VBA知识点： Application.ScreenUpdating = False Dim ph$, d As Object, d1 As Object With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then ph = .SelectedItems(1) Else Exit Sub End If End With ThisDocument.Content.Delete With CreateObject("scripting.filesystemobject") Fn = .GetFileName(ph) With Application.Selection .InsertAfter Fn .Style = ActiveDocument.Styles("标题 1") .EndKey Unit:=wdStory '光标定位至文末 .TypeParagraph '插入一个新的空段落 End With For Each d In .getfolder(ph).subfolders Fs = .GetFileName(d) With Application.Selection .InsertAfter Fs .Style = ActiveDocument.Styles("标题 2") .EndKey Unit:=wdStory '光标定位至文末 .TypeParagraph '插入一个新的空段落 End With For Each d1 In d.Files If .GetExtensionName(d1) = "JPG" Or .GetExtensionName(d1) = "png" Or .GetExtensionName(d1) = "jpg" Or .GetExtensionName(d1) = "bmp" Then With Application.Selection .EndKey Unit:=wdStory '光标定位至文末 .InlineShapes.AddPicture FileName:=d1.Path .Style = ActiveDocument.Styles("正文") End With End If Next d1 Selection.TypeParagraph Next d End With Application.ScreenUpdating = True MsgBox "插入完毕！", 48, "提示！" End Sub

复制代码