ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 8249|回复: 11

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-2-8 20:26 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
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
shuoming.jpg

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-3-9 18:00 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
普天同庆,终于发现gdi有这么一个函数:GetThumbnailImage
不用绕弯路了,关于生成说略图的效率,可以参考此处:
http://www.xuebuyuan.com/zh-tw/637233.html
里面讲了內嵌了縮略圖信息和没有内嵌缩略图信息的图片处理效率
本人测试处理一张53.5兆图片生成缩略图6.69秒,1兆左右的图片生成缩略图为0.1秒左右,基本秒成
非常满意!

使用GDI自带函数GdipGetImageThumbnail生成缩略图.rar

24.51 KB, 下载次数: 300

源码

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-3-9 18:01 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-2-8 20:36 | 显示全部楼层
本帖最后由 chenjyjustin 于 2018-2-8 20:41 编辑

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

用GDI生成缩略图.rar

247.61 KB, 下载次数: 261

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-2-23 15:55 | 显示全部楼层
效果不是很理想, GdipDrawImageRect函数执行有时候不能正确绘制,不知道为何

TA的精华主题

TA的得分主题

发表于 2018-10-13 10:18 | 显示全部楼层
一直在研究关于office文档里面图片的批量可调分辨率的压缩问题,但一直都没有找到解决方案,看了楼主的帖子,感觉受益颇深,非常感谢楼主的分享!

TA的精华主题

TA的得分主题

发表于 2019-7-18 13:11 | 显示全部楼层
学习了,不知道这个能不能用

TA的精华主题

TA的得分主题

发表于 2020-7-22 09:37 | 显示全部楼层
你好,我有个图像已经画在窗体了,《画在窗体的图像如何保存》,http://club.excelhome.net/thread-1544479-1-1.html
因为得到的是gif文件图像,所以窗体同一位置,有好多个图像,用你的程序,请问这个图像如何保存?谢谢。

TA的精华主题

TA的得分主题

发表于 2020-9-8 08:40 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
学习了,谢谢楼主的分享!最近也是在找寻Excel VBA的方式来压缩上传图片的大小,没有找到有效的解决办法,用楼主的方案测试学习看一下,感谢分享!

TA的精华主题

TA的得分主题

发表于 2021-7-22 12:15 来自手机 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
多谢楼主分享,感谢
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 01:19 , Processed in 0.062423 second(s), 13 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表