Word页面存为图片

loquat · 发表于 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

复制代码

loquat · 发表于 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

复制代码

loquat · 发表于 2017-1-27 23:40

本方法可以用于直接将Word转为图片格式的PDF等应用，不展开

Allen2018 · 发表于 2017-2-28 00:38

怎么使用阿，尝试了，没有成功

loquat · 发表于 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以上，就算是分辨率比较高了。

Allen2018 · 发表于 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 ...

如截图，仍未成功！
要是能把一篇ｗｏｒｄ文章导出为图片格式的ｐｄｆ文件（且保持原排版），就太牛了！

loquat · 发表于 2017-3-1 09:24

Allen2018 发表于 2017-2-28 12:59
如截图，仍未成功！
要是能把一篇ｗｏｒｄ文章导出为图片格式的ｐｄｆ文件（且保持原排版），就太 ...

这确实就是转图片PDF的技术，但是我就不展开了。
你应该是用的word2003吧，看1楼最前面说明

loquat · 发表于 2017-3-1 09:25

Allen2018 发表于 2017-2-28 12:59
如截图，仍未成功！
要是能把一篇ｗｏｒｄ文章导出为图片格式的ｐｄｆ文件（且保持原排版），就太 ...

这确实就是转图片PDF的技术，但是我就不展开了。
你应该是用的word2003吧，看1楼最前面说明

Allen2018 · 发表于 2017-3-1 12:24

loquat 发表于 2017-3-1 09:25
这确实就是转图片PDF的技术，但是我就不展开了。
你应该是用的word2003吧，看1楼最前面说明

我用的是word2013。好的，希望能学会也可以解决我的问题

loquat · 发表于 2017-3-1 13:14

pages(2)表示第2页

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

[分享] Word页面存为图片