文件中图片太大怎么办？图片压缩的代码

香川群子 · 发表于 2010-6-11 23:46

Sub PicCopy()
      ActiveCell.Name = "PicAdd"

      Selection.Name = "MyPic"
      plv = Selection.ShapeRange.Line.Visible ' = msoTrue=-1
      If plv Then
         psc = Selection.ShapeRange.Line.ForeColor.SchemeColor '= 10(Red),64(Black)
         plw = Selection.ShapeRange.Line.Weight ' = 1.5
         pls = Selection.ShapeRange.Line.Style ' = msoLineSingle =1
         Selection.ShapeRange.Line.Visible = msoFalse '=0
      End If
      Selection.Copy

      Range("PicAdd").Select
      ActiveWorkbook.Names("PicAdd").Delete

      ActiveSheet.PasteSpecial Format:="图片 (JPEG)" '英文版为"Picture (JPEG)"
      Selection.ShapeRange.ZOrder msoSendToBack

      If plv Then
         Selection.ShapeRange.Line.Visible = msoTrue
         Selection.ShapeRange.Line.ForeColor.SchemeColor = psc
         Selection.ShapeRange.Line.Weight = plw
         Selection.ShapeRange.Line.Style = pls
      End If

      ActiveSheet.Shapes("MyPic").Delete

End Sub

==========================================

其实，关键代码就一句话。
ActiveSheet.PasteSpecial Format:="图片 (JPEG)"

可以把像素超大的图片，改为按当前显示的尺寸相应的像素。
因此，可以大大地减小文件体积。

香川群子 · 发表于 2010-7-31 12:20

Sub PicCopy()
'先选择单元格范围，
'然后选择图片
Dim r As Range
Set r = ActiveCell

Selection.Name = "MyPic"
On Error GoTo PicNotSelectErr
With Selection.ShapeRange.Line
      plv = .Visible ' = msoTrue=-1
      If plv Then
         psc = .ForeColor.SchemeColor '= 10(Red),64(Black)
         plw = .Weight ' = 1.5
         pls = .Style ' = msoLineSingle =1
         .Visible = msoFalse '=0
      End If
End With

If r.MergeArea.Count > 1 Or r = "C" Then
      With Selection
         rh = r.MergeArea.Height 'Range(r.MergeArea.Address).Height '(合并)单元高度
         rw = r.MergeArea.Width 'Range(r.MergeArea.Address).Width    '(合并)单元宽度
         ph = .Height '图片高度
         pw = .Width    '图片宽度
         tm = IIf(rh / ph < rw / pw, rh / ph, rw / pw) '求单元格与图片之间长宽差异比例的最小值
         .Height = .Height * tm '按比例调整图片高度
         .Width = .Width * tm    '按比例调整图片宽度
      End With
End If

Selection.Copy

r.Select

ActiveSheet.PasteSpecial Format:="图片 (JPEG)" '英文版为"Picture (JPEG)"
Selection.ShapeRange.ZOrder msoSendToBack
If plv Then
      With Selection.ShapeRange.Line
         .Visible = msoTrue
         .ForeColor.SchemeColor = psc
         .Weight = plw
         .Style = pls
      End With
End If

If r.MergeArea.Count > 1 Or r = "C" Then
      With Selection
         .Top = r.Top + (r.MergeArea.Height - .Height) / 2 '垂直居中:
         .Left = r.Left + (r.MergeArea.Width - .Width) / 2 '水平居中:
      End With
End If

ActiveSheet.Shapes("MyPic").Delete
Exit Sub

PicNotSelectErr:
MsgBox "Picture not selected !" & vbCrLf & "未选择图片！"
End Sub

amarantine · 发表于 2010-7-31 14:28

谢谢分享

香川群子 · 发表于 2010-7-31 18:36

原帖由 guihao123 于 2010-7-31 16:50 发表
直接对原图片复制---右键----选择性粘贴----JPG格式。就OK了

你说的没错，但也是废话。

我之所以要写成代码，肯定有我独到的功能。

你还是仔细看看再说吧。

guihao123 · 发表于 2010-7-31 16:50

直接对原图片复制---右键----选择性粘贴----JPG格式。就OK了

asus6117899 · 发表于 2010-11-25 19:42

请问那些代码怎样操作。谢谢！

yanjie · 发表于 2010-11-25 22:04

Activesheet.shapes(1).Select                   ’ 选定图片
SendKeys "%oi"                      '选择图片格式对话框
SendKeys "%m"                         ‘图片压缩

itxianfeng · 发表于 2010-11-28 10:07

谢谢楼主和版主的帖子，代码很实用，图片压缩我一直没有用过，利用宏在插入图片的同时压缩图片 将会大大降低图片的编辑速度

[ 本帖最后由 itxianfeng 于 2010-11-28 10:08 编辑 ]

bketliu · 发表于 2010-11-28 18:10

为什么我插入的图片才214KB 经过上面的代码处理后却变成4.7M了？

itxianfeng · 发表于 2010-11-29 07:29

是真的吗？？？我还没有倒出时间检验一下代码

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

[原创] 文件中图片太大怎么办？图片压缩的代码

做了改进，可以自动放在合并范围的中间。

其实你不用讲这么复杂！