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

香川群子

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)"

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

香川群子

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

谢谢分享

香川群子

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

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

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

你还是仔细看看再说吧。

guihao123

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

asus6117899

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

yanjie

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

itxianfeng

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

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

bketliu

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

itxianfeng

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