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 GpStatus
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 GpStatus
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
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, _
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 = StrConv(String$(Length, vbNullChar), vbUnicode)
CopyMemory ByVal Out, ByVal lpsz, Length * 2
PtrToStrW = StrConv(Out, vbFromUnicode)
End If
End Function
以下是我封裝的程式碼：
當然我偷懶，沒有使用GDI+，又選用了GDI，實際可以都用GDI+
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 ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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
Function ImageExtract(obj As Object, ByVal FileName As String, _
Optional ByVal FileFormat As ImageFileFormat = jpg, _
使用Range.EnhMetaFileBits
來獲取圖片的EMF格式陣列
然後用一系列API，轉換成常規的jpg/png/gif/bmp格式
本方法不佔用剪貼簿
GDI+ 儲存圖片的函式改自這裡：
https://www.cnblogs.com/Imageshop/archive/2012/03/02/2377871.html
略作調整如下：
"*************************************************************************
"** 作 者 ： laviewpbt
"** 函 數 名 ： SavehBitmapToFile
"** 輸 入 ： Stdpic(StdPicture) - 圖象控制代碼
"** ： FileName(String) - 儲存路徑
"** ： FileFormat(ImageFileFormat) - 儲存格式，預設jpg
"** ： JpgQuality(Long) - JPG圖象質量
"** ： Resolution(Single) - 設定解析度
"** 輸 出 ： 無
"** 功能描述 ： 把圖象儲存為JPG、PNG、GIF、BMP格式
"** 修 改 人 ： laviewpbt
"** 日 期 ： 2012-03-02 22:56
"** 版 本 ： 終結版
"** 修 改 人 : loquat 20190401
"*************************************************************************
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 GpStatus
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 GpStatus
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
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+
Debug.Print GdipCreateBitmapFromHBITMAP(hBitmap, 0, bitmap)
If bitmap <> 0 Then "如果成功的將hBitmap控制代碼代表的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 = StrConv(String$(Length, vbNullChar), vbUnicode)
CopyMemory ByVal Out, ByVal lpsz, Length * 2
PtrToStrW = StrConv(Out, vbFromUnicode)
End If
End Function
以下是我封裝的程式碼：
當然我偷懶，沒有使用GDI+，又選用了GDI，實際可以都用GDI+
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 ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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
Function ImageExtract(obj As Object, ByVal FileName As String, _
Optional ByVal FileFormat As ImageFileFormat = jpg, _
Optional ByVal JpgQuality As Long = 80, _
Optional Resolution As Single) As Boolean
Dim n! "放大倍數
Dim aRECT(0 To 3) As Long
Dim hScreenDC&
Dim hMemDC&
Dim hBitmap&, hBitTemp&
Dim arr() As Byte, hEMF&
n = 4
Select Case TypeName(obj) "獲取影象陣列
Case "InlineShape"
arr = obj.Range.EnhMetaFileBits
aRECT(2) = PointsToPixels(obj.Width, False) "寬度
aRECT(3) = PointsToPixels(obj.Height, True) "高度
Case "Shape"
arr = obj.Anchor.EnhMetaFileBits
aRECT(2) = PointsToPixels(obj.Width, False) "寬度
aRECT(3) = PointsToPixels(obj.Height, True) "高度
End Select
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)
ImageExtract = SavehBitmapToFile(hBitmap, FileName, FileFormat, JpgQuality, Resolution)
DeleteObject hBitmap
DeleteDC hMemDC
DeleteDC hScreenDC
End Function
呼叫示例：
Dim oInlineShape As InlineShapeDim oShape As ShapeSet oInlineShape = oDocument.InlineShapes(1)Set oShape = oDocument.Shapes(2)If ImageExtract(oInlineShape, "c:\1.jpg",jpg, 100,600) thenmsgbox "儲存成功"End IfIf ImageExtract(oShape, "c:\2.jpg",jpg, 100,600) thenmsgbox "儲存成功"End If