邮件合并中相片太大且不统一的问题要如何解决？

szqhb · 发表于 2011-6-18 20:21

我在Home里溜达了一下，有个“香川群子”的或许可以帮到你

cumulonimbus · 发表于 2011-6-20 22:26

不知怎么联系香川群子这个日本友人。希望她能帮助解决一二。

szqhb · 发表于 2011-6-20 22:55

原帖由 cumulonimbus 于 2011-6-20 22:26 发表
不知怎么联系香川群子这个日本友人。希望她能帮助解决一二。

发短消息给他（她）

香川群子 · 发表于 2011-6-21 09:22

请问楼主：

【邮件合并功能】是指利用word中的邮件合并功能，
把指定文件夹内的图片及Excel数据，自动导入到word标准格式中，以便快速打印处理。

按此目的，导入图片以后的尺寸应该是大小一致的。
以你提供的附件来说，图片尺寸最大值在EXCEL表中应该是相当于4列宽，12行高。请确认此条件。

因此，我的做法：
我会写代码，把你文件夹内的原始图片尺寸全部标准化统一到这么大小。

Sub PicSize()
Application.ScreenUpdating = False

Columns("G:J").ColumnWidth = 8.38
Rows("2:13").RowHeight = 14.25
Range("G2:J13").MergeCells = True
H = [g2].MergeArea.Height '171(60)
W = [g2].MergeArea.Width '216(76)
'以上为设置图片标准大小的单元格区域G2:J13为合并单元格。

myPath = ThisWorkbook.Path & "\" '设定图片所在文件夹。默认为Excel表同一文件夹。

For i = 2 To Range("E1").End(xlDown).Row '从E2位置开始遍历所有图片名称。
      PicName = Range("E1").Offset(i - 1, 0) '获取图片名称。

   '下面加入了容错代码：
         On Error Resume Next '插入图片有错误时略过
         ActiveSheet.Pictures.Insert(myPath & PicName).Select '如果无错误则在Excel表中插入图片。
         If Err.Number > 0 Then '如果有错误（原因是没有符合名称的图片被找到。）
               MsgBox "Picture not found !  " & PicName '错误提示
               Err.Clear '清除错误码
               GoTo PicErrNxt '跳至下一图片。
         End If

   With Selection '对已经插入的图片进行如下处理：
         .Name = "NewPic" ’图片临时命名
         .ShapeRange.LockAspectRatio = msoTrue '设定高宽等比例变化。
         f = IIf(.Height / H > .Width / W, .Height / H, .Width / W) '计算并选择最大高宽比。

         .Height = .Height / f ‘调整图片大小以便适合标准尺寸。即G2:J13合并单元格大小。
         .Width = .Width / f

         .Top = Range("G2").Top + (Range("G2").MergeArea.Height - .Height) / 2 '图片上下居中
         .Left = Range("G2").Left + (Range("G2").MergeArea.Width - .Width) / 2 '图片左右居中
      End With

      Range("G2:J13").Select
      Range("G2:J13").CopyPicture '复制整个合并单元格显示内容

      With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart '创建一个图片对象
         .Paste '把刚才复制好的合并单元格显示内容粘贴进去
         .Export myPath & PicName, "JPG" '输出并覆盖原图片
         .Parent.Delete ‘Excel表中临时图片对象删除
      End With

      ActiveSheet.Shapes("NewPic").Delete ‘Excel表中临时插入的图片删除
PicErrNxt: ’此处插入错误跳过语句位置。
Next

[g2:j13].UnMerge '取消合并单元格

Application.ScreenUpdating = True

ActiveWorkbook.Saved = True '不实际保存文件。(欺骗强制告诉Excel该表已经保存了)
ActiveWorkbook.Close ’关闭文件

End Sub

这样把图片处理完成以后，
在按照邮件合并的步骤去做，
就可以得到需要的结果啦。

效果请看附件。附件已经重新上传。

[ 本帖最后由香川群子于 2011-6-21 21:29 编辑 ]

cumulonimbus · 发表于 2011-6-21 13:09

谢谢，不能运行哦。提示是：不能取得pictures的insert属性。请问这到底是怎么回事呀

香川群子 · 发表于 2011-6-21 15:14

原帖由 cumulonimbus 于 2011-6-21 13:09 发表
谢谢，不能运行哦。提示是：不能取得pictures的insert属性。请问这到底是怎么回事呀

我的电脑，日文环境的。

你的中文电脑，图片名字被改变了的。不能识别啦。

宏代码已经加入了容错处理。

实际上，你把图片名称重新检查，修改为和数据内容一致就可以啦。

附件为加入了容错代码的Excel文件。

cumulonimbus · 发表于 2011-6-21 16:27

我晕，你还真是日本人呀。
谢谢日本友人大力支持，学习了。

szqhb · 发表于 2011-6-21 22:39

原帖由 香川群子 于 2011-6-21 15:14 发表

我的电脑，日文环境的。

你的中文电脑，图片名字被改变了的。不能识别啦。

宏代码已经加入了容错处理。

实际上，你把图片名称重新检查，修改为和数据内容一致就可以啦。

附件为加入了容错代码的 ...

该代码很好，不知道能否直接输入要统一的尺寸？如宽3厘米，高4.2厘米。

香川群子 · 发表于 2011-6-22 09:13

原帖由 szqhb 于 2011-6-21 22:39 发表

该代码很好，不知道能否直接输入要统一的尺寸？如宽3厘米，高4.2厘米。

可以事先设定好图片统一尺寸。

但是，厘米数值要转换为电脑中的参数，
具体的会根据你实际使用的电脑分辨率设置，Excel表基本行列参数设置有关。

最好是自己先模拟画一个方框，然后在图形格式中设定为你想要的厘米参数，
这个过程用宏代码记录以后，你就能知道实际参数设置了。

例如，录制宏并在电脑中设置高4.2cm，宽3cm的矩形框以后，得到
Selection.ShapeRange.Height = 119.25
Selection.ShapeRange.Width = 84.75

就得到这样两个参数。

这以后，在图片插入后，使用如下代码即可：
Selection.ShapeRange.LockAspectRatio = msoFalse '设定高宽变化可以不等比例改变
Selection.ShapeRange.Height = 119.25 '设定高度参数
Selection.ShapeRange.Width = 84.75 '设定宽度参数
Selection.Placement = xlMove '设置图片可以移动但不会随单元格改变尺寸。

或者：
With Selection
      .ShapeRange.LockAspectRatio = msoFalse
      .ShapeRange.Height = 119.25
      .ShapeRange.Width = 84.75
      .Placement = xlMove
End With

szqhb · 发表于 2011-6-22 10:10

虽然不是很懂，但还是很感谢你

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

[求助] 邮件合并中相片太大且不统一的问题要如何解决？

评分