调用GDI+来对图片进行处理，缩放生成缩略图、压缩、获取大小、分辨率

chenjyjustin

1、只为提供一种VBA能直接调用的压缩方法
众所周知，excel本身自带的shape里面可以载入图片，图片也可以直接插入sheet，但是有时候我们只需要很小的图，如果一张图片有20M，10M，或者3M，置入sheet后保存excel文件就会变得很大，也会造成打开文件慢。当然excel本身自带压缩图片的功能。需要手工压缩，excel本身没有提供vba调用图片压缩的接口

论坛里面也有用代码，模拟手工操作的
Selection.WholeStory
    SendKeys "^{ENTER}", False
    Word.CommandBars("Picture").Controls("压缩图片(&C)...").Execute这个方法已经很好用了，但是有缺陷，图片必须载入到excel里面来啊。

我想在插入excel表格之前就已经把图片压缩好，直接插入压缩好的图片。
参考了很多资料，都是vb的
http://blog.163.com/qu.s.z@126/b ... 693742014483365153/
vb的图形控件能提供句柄参数，excel的可不行
GdipLoadImageFromFile

chenjyjustin

普天同庆，终于发现gdi有这么一个函数：GetThumbnailImage
不用绕弯路了，关于生成说略图的效率，可以参考此处：
http://www.xuebuyuan.com/zh-tw/637233.html
里面讲了內嵌了縮略圖信息和没有内嵌缩略图信息的图片处理效率
本人测试处理一张53.5兆图片生成缩略图6.69秒，1兆左右的图片生成缩略图为0.1秒左右，基本秒成
非常满意！

chenjyjustin

Public Function GetThumb(SrcImgPath As String, TNImgpath As String, WidthMax As Long, HeightMax As Long)
    LoadGDIP
    Dim Thumb As Long
    '载入图片到内存中
    GdipLoadImageFromFile StrPtr(SrcImgPath), gdip_Image  'StrConv(SrcImgPath, vbUnicode), gdip_Image 'StrPtr
    GdipGetImageThumbnail gdip_Image, WidthMax, HeightMax, Thumb
    GdipDisposeImage gdip_Image
    SaveImageToJPG Thumb, TNImgpath, 50
    '销毁GDI+图像
    GdipDisposeImage Thumb
    DisposeGDIP
End Function

chenjyjustin

vb按照以下步骤能轻松压缩图片，显示到pict图片框，然后存储
GdipCreateFromHDC
GdipLoadImageFromFile
GdipDrawImageRect
GdipSaveImageToFile pict.handle
VBA实现不了，没有handle可以调用。
于是转而考虑直接用api调用桌面 的HDC，在桌面输出压缩后的图片，
然后用CreateCompatibleDC   CreateCompatibleBitmap截屏的方式去生成图片
这样就能得到压缩后图片的句柄
调用GdipSaveImageToFile
废话不多说，直接上源码

Public Sub CreateTNImg(SrcImgPath As String, TNImgpath As String, WidthMax As Long, HeightMax As Long)
    LoadGDIP
    Dim hDC As Long
    hDC = GetDC(0) 'GetDC(FindWindow(vbNullString, Application.ActiveWindow.Caption))  ' 选定桌面作为设备场景
    'GdipCreateFromHDC  ( hDC, graphics )
    ' hDC 设备场景的句柄 graphics 是函数创建的画板成功后的句柄 ，可用GdipDeleteGraphics函数删除画板以释放内存空间。
    If GdipCreateFromHDC(hDC, gdip_Graphics) <> 0 Then '
        MsgBox "出现错误！", vbCritical, "错误"
        GdiplusShutdown gdip_Token
        End
    End If
    '载入图片到内存中
    GdipLoadImageFromFile StrPtr(SrcImgPath), gdip_Image  'StrConv(SrcImgPath, vbUnicode), gdip_Image 'StrPtr
   
    '使用GDI+直接从内存中缩略并绘图，GDI+有很好的反锯齿能力
    'GdipDrawImageRect(Graphics As Long, Image As Long
    ' 向Graphics对象输出Image
    'Graphics对象，可调用GdipCreateFromHDC函数创建
    'image对象，可由GdipLoadImageFromFile加载的图像文件
    Dim t As GpStatus, BmpInfo As BITMAPINFO
    t = GdipDrawImageRect(gdip_Graphics, gdip_Image, 0, 0, WidthMax, HeightMax)
    If t = Ok Then
        Dim hDCdesk As Long
        Dim hDCmem As Long
        Dim hBmp As Long
        Dim hBmpPrev As Long
        hDCdesk = GetDC(0)
        hDCmem = CreateCompatibleDC(hDCdesk)
        hBmp = CreateCompatibleBitmap(hDCdesk, WidthMax, HeightMax)
        hBmpPrev = SelectObject(hDCmem, hBmp)
        BitBlt hDCmem, 0, 0, WidthMax, HeightMax, hDCdesk, 0, 0, &HCC0020   'vbSrcCopy
        SelectObject hDCmem, hBmpPrev
        DeleteDC hDCmem
        ReleaseDC 0, hDCdesk
        Dim lBitmap As Long '从句柄创建GDI+图像
        lRes = GdipCreateBitmapFromHBITMAP(hBmp, 0, lBitmap)
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            SaveImageToJPG lBitmap, TNImgpath, 80
            '销毁GDI+图像
            GdipDisposeImage lBitmap
        End If
        DeleteObject hBmp
    End If
    DisposeGDIP
End Sub


Public Sub LoadGDIP()
    Dim GpInput As GdiplusStartupInput
    GpInput.GdiplusVersion = 1
    If GdiplusStartup(gdips_Token, GpInput) <> 0 Then
        MsgBox "加载GDI+失败！", vbCritical, "加载错误"
        End
    End If
End Sub

Public Sub DisposeGDIP()
    GdipDisposeImage gdip_Image
    GdipDeleteGraphics gdip_Graphics
    GdiplusShutdown gdip_Token
End Sub

chenjyjustin

效果不是很理想， GdipDrawImageRect函数执行有时候不能正确绘制，不知道为何

xifeng116

一直在研究关于office文档里面图片的批量可调分辨率的压缩问题，但一直都没有找到解决方案，看了楼主的帖子，感觉受益颇深，非常感谢楼主的分享！

haofeng4645

学习了，不知道这个能不能用

dongdonggege

你好，我有个图像已经画在窗体了，《画在窗体的图像如何保存》，http://club.excelhome.net/thread-1544479-1-1.html。
因为得到的是gif文件图像，所以窗体同一位置，有好多个图像，用你的程序，请问这个图像如何保存？谢谢。

kmfcladidas

学习了，谢谢楼主的分享！最近也是在找寻Excel VBA的方式来压缩上传图片的大小，没有找到有效的解决办法，用楼主的方案测试学习看一下，感谢分享！

anve2008

多谢楼主分享，感谢