ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 1120|回复: 11
打印 上一主题 下一主题

[分享] Word页面存为图片

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2017-1-27 23:38 | 只看该作者 |只看大图 回帖奖励 |倒序浏览 |阅读模式
'Word2003的Page对象无EnhMetaFileBits方法,无法使用本方法
  • Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
  • Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
  • Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  • Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
  • Private Declare Function SetEnhMetaFileBits& Lib "gdi32.dll" (ByVal DataLen&, pData As Any)
  • Private Declare Function PlayEnhMetaFile& Lib "gdi32" (ByVal hdc&, ByVal hEMF&, pRect As Any)
  • Private Declare Function DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hEMF As Long)
  • Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
  • Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
  • Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any, ByVal hBrush As Long) As Long
  • Private Declare Function InvertRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any) As Long

  • Sub MyTest()
  • Dim aRECT(0 To 3) As Long
  • Dim hScreenDC&
  • Dim hMemDC&
  • Dim hBitmap&, hBitTemp&
  • Dim oPage As Word.Page
  • Dim arr() As Byte, hEMF&
  • Set oPage = ThisDocument.Windows(1).Panes(1).Pages(2)
  • aRECT(2) = PointsToPixels(10 * oPage.Width, False) '宽度
  • aRECT(3) = PointsToPixels(10 * oPage.Height, True)  '高度
  • arr = oPage.EnhMetaFileBits

  • hEMF = SetEnhMetaFileBits(UBound(arr) + 1, arr(0))

  • hScreenDC = GetDC(0&)
  • hMemDC = CreateCompatibleDC(hScreenDC)
  • hBitmap = CreateCompatibleBitmap(hScreenDC, aRECT(2), aRECT(3))
  • hBitTemp = SelectObject(hMemDC, hBitmap)

  • InvertRect hMemDC, aRECT(0)

  • If hEMF Then
  •     PlayEnhMetaFile hMemDC, hEMF, aRECT(0)
  •     DeleteEnhMetaFile hEMF  '销毁EMF
  • End If

  • hBitmap = SelectObject(hMemDC, hBitTemp)

  • MsgBox SavehBitmapToFile(hBitmap, "C:\2.png", png)

  • DeleteObject hBitmap
  • DeleteDC hMemDC
  • DeleteDC hScreenDC
  • End Sub
  • 复制代码

    分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
    收藏收藏4 分享分享 有用有用 无用无用
    TA的精华主题TA的得分主题
    2
     楼主| 发表于 2017-1-27 23:39 | 只看该作者 |楼主
    使用了laviewpbt的代码。
  • '**    作    者 :    laviewpbt
  • '**    函 数 名 :    SavehBitmapToFile
  • '**    输    入 :    Stdpic(StdPicture)        -   图象句柄
  • '**             :    FileName(String)       -   保存路径
  • '**             :    FileFormat(ImageFileFormat)       -   保存格式,默认jpg
  • '**             :    JpgQuality(Long)          -   JPG图象质量
  • '**             :    Resolution(Single)  -   设置分辨率
  • '**    功能描述 : 把图象保存为JPG、PNG、GIF、BMP格式
  • '**    修 改 人 :   loquat
  • '*************************************************************************
  • Option Explicit

  • Private Const UnitPixel                  As Long = 2
  • Private Const EncoderQuality             As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

  • Private Type GdiplusStartupInput
  •     GdiplusVersion           As Long
  •     DebugEventCallback       As Long
  •     SuppressBackgroundThread As Long
  •     SuppressExternalCodecs   As Long
  • End Type

  • Private Enum EncoderParameterValueType
  •     EncoderParameterValueTypeByte = 1
  •     EncoderParameterValueTypeASCII = 2
  •     EncoderParameterValueTypeShort = 3
  •     EncoderParameterValueTypeLong = 4
  •     EncoderParameterValueTypeRational = 5
  •     EncoderParameterValueTypeLongRange = 6
  •     EncoderParameterValueTypeUndefined = 7
  •     EncoderParameterValueTypeRationalRange = 8
  • End Enum

  • Private Type EncoderParameter
  •     GUID(0 To 3)        As Long
  •     NumberOfValues      As Long
  •     Type                As EncoderParameterValueType
  •     Value               As Long
  • End Type

  • Private Type EncoderParameters
  •     Count               As Long
  •     Parameter           As EncoderParameter
  • End Type

  • Private Type ImageCodecInfo
  •     ClassID(0 To 3)     As Long
  •     FormatID(0 To 3)    As Long
  •     CodecName           As Long
  •     DllName             As Long
  •     FormatDescription   As Long
  •     FilenameExtension   As Long
  •     MimeType            As Long
  •     Flags               As Long
  •     Version             As Long
  •     SigCount            As Long
  •     SigSize             As Long
  •     SigPattern          As Long
  •     SigMask             As Long
  • End Type

  • Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
  • Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
  • Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long
  • Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
  • Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
  • Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long
  • Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long

  • Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  • Private Declare Function lstrlenW Lib "KERNEL32" (ByVal psString As Any) As Long
  • Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
  • Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal BITMAP As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long


  • Public Enum ImageFileFormat
  •     bmp = 1
  •     JPG = 2
  •     png = 3
  •     gif = 4
  • End Enum

  • Public Function SavehBitmapToFile(hBitmap As Long, ByVal FileName As String, _
  •                               Optional ByVal FileFormat As ImageFileFormat = JPG, _
  •                               Optional ByVal JpgQuality As Long = 80, _
  •                               Optional Resolution As Single) As Boolean
  •     Dim clsid(3)        As Long
  •     Dim BITMAP          As Long
  •     Dim Token           As Long
  •     Dim Gsp             As GdiplusStartupInput

  •     Gsp.GdiplusVersion = 1                      'GDI+ 1.0版本
  •     GdiplusStartup Token, Gsp                   '初始化GDI+
  •     GdipCreateBitmapFromHBITMAP hBitmap, 0, BITMAP
  •     If BITMAP <> 0 Then                          '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了
  •         GdipBitmapSetResolution BITMAP, Resolution, Resolution
  •         Select Case FileFormat
  •         Case ImageFileFormat.bmp
  •             If Not GetEncoderClsid("Image/bmp", clsid) = -1 Then
  •                 SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
  •             End If
  •         Case ImageFileFormat.JPG                    'JPG格式可以设置保存的质量
  •             Dim aEncParams()        As Byte
  •             Dim uEncParams          As EncoderParameters
  •             If GetEncoderClsid("Image/jpeg", clsid) <> -1 Then
  •                 uEncParams.Count = 1                                        ' 设置自定义的编码参数,这里为1个参数
  •                 If JpgQuality < 0 Then
  •                     JpgQuality = 0
  •                 ElseIf JpgQuality > 100 Then
  •                     JpgQuality = 100
  •                 End If
  •                 ReDim aEncParams(1 To Len(uEncParams))
  •                 With uEncParams.Parameter
  •                     .NumberOfValues = 1
  •                     .Type = EncoderParameterValueTypeLong                   ' 设置参数值的数据类型为长整型
  •                     Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0))  ' 设置参数唯一标志的GUID,这里为编码品质
  •                     .Value = VarPtr(JpgQuality)                                ' 设置参数的值:品质等级,最高为100,图像文件大小与品质成正比
  •                 End With
  •                 CopyMemory aEncParams(1), uEncParams, Len(uEncParams)
  •                 SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), aEncParams(1)) = 0)
  •             End If
  •         Case ImageFileFormat.png
  •             If Not GetEncoderClsid("Image/png", clsid) = -1 Then
  •                 SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
  •             End If
  •         Case ImageFileFormat.gif
  •             If Not GetEncoderClsid("Image/gif", clsid) = -1 Then                '如果原始的图像是24位,则这个函数会调用系统的调色板来将图像转换为8位,转换的效果会不尽人意,但也有可能系统不自动转换,保存失败
  •                 SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
  •             End If
  •         End Select
  •     End If
  •     GdipDisposeImage BITMAP      '注意释放资源
  •     GdiplusShutdown Token       '关闭GDI+。
  • End Function


  • Private Function GetEncoderClsid(strMimeType As String, ClassID() As Long) As Long
  •     Dim num         As Long
  •     Dim Size        As Long
  •     Dim i           As Long
  •     Dim Info()      As ImageCodecInfo
  •     Dim Buffer()    As Byte
  •     GetEncoderClsid = -1
  •     GdipGetImageEncodersSize num, Size               '得到解码器数组的大小
  •     If Size <> 0 Then
  •        ReDim Info(1 To num) As ImageCodecInfo       '给数组动态分配内存
  •        ReDim Buffer(1 To Size) As Byte
  •        GdipGetImageEncoders num, Size, Buffer(1)            '得到数组和字符数据
  •        CopyMemory Info(1), Buffer(1), (Len(Info(1)) * num)     '复制类头
  •        For i = 1 To num             '循环检测所有解码
  •            If (StrComp(PtrToStrW(Info(i).MimeType), strMimeType, vbTextCompare) = 0) Then         '必须把指针转换成可用的字符
  •                CopyMemory ClassID(0), Info(i).ClassID(0), 16  '保存类的ID
  •                GetEncoderClsid = i      '返回成功的索引值
  •                Exit For
  •            End If
  •        Next
  •     End If
  • End Function

  • Private Function PtrToStrW(ByVal lpsz As Long) As String
  •     Dim Out         As String
  •     Dim Length      As Long
  •     Length = lstrlenW(lpsz)
  •     If Length > 0 Then
  •         Out = VBA.StrConv(VBA.String$(Length, vbNullChar), vbUnicode)
  •         CopyMemory ByVal Out, ByVal lpsz, Length * 2
  •         PtrToStrW = VBA.StrConv(Out, vbFromUnicode)
  •     End If
  • End Function
  • 复制代码
    TA的精华主题TA的得分主题
    3
     楼主| 发表于 2017-1-27 23:40 | 只看该作者 |楼主
    本方法可以用于直接将Word转为图片格式的PDF等应用,不展开
    TA的精华主题TA的得分主题
    4
    发表于 2017-2-28 00:38 | 只看该作者
    TA的精华主题TA的得分主题
    5
     楼主| 发表于 2017-2-28 12:29 | 只看该作者 |楼主
    Allen2018 发表于 2017-2-28 00:38
    怎么使用阿,尝试了,没有成功

    将1楼2楼的代码分别放到一个模块下,
    然后运行1楼的代码,会将word文档第1页的内容存成PNG图片
    aRECT(2) = PointsToPixels(10 * oPage.Width, False) '宽度
    aRECT(3) = PointsToPixels(10 * oPage.Height, True)  '高度
    这两行,可能不同的系统不一定能得到这么大的尺寸,遇到错误减少这个数字10即可。
    调整到4以上,就算是分辨率比较高了。
    TA的精华主题TA的得分主题
    6
    发表于 2017-2-28 12:59 | 只看该作者
    本帖最后由 Allen2018 于 2017-2-28 18:02 编辑
    loquat 发表于 2017-2-28 12:29
    将1楼2楼的代码分别放到一个模块下,
    然后运行1楼的代码,会将word文档第1页的内容存成PNG图片
    aRECT(2 ...




    如截图,仍未成功!
    要是能把一篇word文章导出为图片格式的pdf文件(且保持原排版),就太牛了!
    2017-02-28_125417.jpg (173.54 KB, 下载次数: 7) 文档共计一页时【添加成多页时没问题】
    文档共计一页时【添加成多页时没问题】
    2017-02-28_125405.jpg (242.93 KB, 下载次数: 5) 文档共计一页时,【添加成多页时没问题】
    文档共计一页时,【添加成多页时没问题】
    2017-02-28_125241.jpg (10.23 KB, 下载次数: 8) 7、4、1 * oPage.Width,时 【调小后还是不行】
    7、4、1 * oPage.Width,时 【调小后还是不行】
    TA的精华主题TA的得分主题
    7
     楼主| 发表于 2017-3-1 09:24 | 只看该作者 |楼主
    Allen2018 发表于 2017-2-28 12:59
    如截图,仍未成功!
    要是能把一篇word文章导出为图片格式的pdf文件(且保持原排版),就太 ...

    这确实就是转图片PDF的技术,但是我就不展开了。
    你应该是用的word2003吧,看1楼最前面说明
    TA的精华主题TA的得分主题
    8
     楼主| 发表于 2017-3-1 09:25 | 只看该作者 |楼主
    Allen2018 发表于 2017-2-28 12:59
    如截图,仍未成功!
    要是能把一篇word文章导出为图片格式的pdf文件(且保持原排版),就太 ...

    这确实就是转图片PDF的技术,但是我就不展开了。
    你应该是用的word2003吧,看1楼最前面说明
    TA的精华主题TA的得分主题
    9
    发表于 2017-3-1 12:24 | 只看该作者
    loquat 发表于 2017-3-1 09:25
    这确实就是转图片PDF的技术,但是我就不展开了。
    你应该是用的word2003吧,看1楼最前面说明

    我用的是word2013。好的,希望能学会也可以解决我的问题
    TA的精华主题TA的得分主题
    10
     楼主| 发表于 2017-3-1 13:14 | 只看该作者 |楼主
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

    最新热点上一条 /1 下一条

    关注官方微信,每天坐享新鲜教程
    手机版|关于我们|联系我们|ExcelHome    GMT+8, 2017-12-14 08:30 , Processed in 1.132137 second(s), 28 queries , Gzip On.
    Powered by Discuz! X3.3 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优