使用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-0222:56
'**版本：終結版
'**修改人:loquat20190401
'*************************************************************************
OptionExplicit
PrivateConstUnitPixelAsLong=2
PrivateConstEncoderQualityAsString="{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
PrivateTypeGdiplusStartupInput
GdiplusVersionAsLong
DebugEventCallbackAsLong
SuppressBackgroundThreadAsLong
SuppressExternalCodecsAsLong
EndType
PrivateEnumEncoderParameterValueType
EncoderParameterValueTypeByte=1
EncoderParameterValueTypeASCII=2
EncoderParameterValueTypeShort=3
EncoderParameterValueTypeLong=4
EncoderParameterValueTypeRational=5
EncoderParameterValueTypeLongRange=6
EncoderParameterValueTypeUndefined=7
EncoderParameterValueTypeRationalRange=8
EndEnum
PrivateTypeEncoderParameter
GUID(0To3)AsLong
NumberOfValuesAsLong
typeAsEncoderParameterValueType
ValueAsLong
EndType
PrivateTypeEncoderParameters
countAsLong
ParameterAsEncoderParameter
EndType
PrivateTypeImageCodecInfo
ClassID(0To3)AsLong
FormatID(0To3)AsLong
CodecNameAsLong
DllNameAsLong
FormatDescriptionAsLong
FilenameExtensionAsLong
MimeTypeAsLong
FlagsAsLong
VersionAsLong
SigCountAsLong
SigSizeAsLong
SigPatternAsLong
SigMaskAsLong
EndType
PrivateDeclareFunctionGdiplusStartupLib"gdiplus"(tokenAsLong,inputbufAsGdiplusStartupInput,OptionalByValoutputbufAsLong=0)AsLong
PrivateDeclareSubGdiplusShutdownLib"gdiplus"(ByValtokenAsLong)
PrivateDeclareFunctionGdipSaveImageToFileLib"gdiplus"(ByValhImageAsLong,ByValsFilenameAsLong,clsidEncoderAsAny,encoderParamsAsAny)AsLong
PrivateDeclareFunctionGdipDisposeImageLib"gdiplus"(ByValImageAsLong)AsLong
PrivateDeclareFunctionGdipCreateBitmapFromHBITMAPLib"gdiplus"(ByValhbmAsLong,ByValhPalAsLong,bitmapAsLong)AsGpStatus
PrivateDeclareFunctionGdipGetImageEncodersSizeLib"gdiplus"(numEncodersAsLong,SizeAsLong)AsLong
PrivateDeclareFunctionGdipGetImageEncodersLib"gdiplus"(ByValnumEncodersAsLong,ByValSizeAsLong,EncodersAsAny)AsLong
PrivateDeclareSubCopyMemoryLib"kernel32"Alias"RtlMoveMemory"(DestinationAsAny,SourceAsAny,ByValLengthAsLong)
PrivateDeclareFunctionlstrlenWLib"kernel32"(ByValpsStringAsAny)AsLong
PrivateDeclareFunctionCLSIDFromStringLib"ole32"(ByVallpszProgIDAsLong,pclsidAsAny)AsLong
PrivateDeclareFunctionGdipBitmapSetResolutionLib"gdiplus"(ByValbitmapAsLong,ByValxdpiAsSingle,ByValydpiAsSingle)AsLong
PublicEnumGpStatus
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
EndEnum
PublicEnumImageFileFormat
bmp=1
jpg=2
png=3
gif=4
EndEnum
PublicFunctionSavehBitmapToFile(hBitmapAsLong,ByValFileNameAsString,_
OptionalByValFileFormatAsImageFileFormat=jpg,_
OptionalByValJpgQualityAsLong=80,_
OptionalResolutionAsSingle)AsBoolean
DimCLSID(3)AsLong
DimbitmapAsLong
DimtokenAsLong
DimGspAsGdiplusStartupInput
Gsp.GdiplusVersion=1'GDI+1.0版本
GdiplusStartuptoken,Gsp'初始化GDI+
Debug.PrintGdipCreateBitmapFromHBITMAP(hBitmap,0,bitmap)
Ifbitmap<>0Then'如果成功的將hBitmap句柄代表的stdPic對象轉換為GDI+的Bitmap對象了
GdipBitmapSetResolutionbitmap,Resolution,Resolution
SelectCaseFileFormat
CaseImageFileFormat.bmp
IfNotGetEncoderCLSID("Image/bmp",CLSID)=-1Then
SavehBitmapToFile=(GdipSaveImageToFile(bitmap,StrPtr(FileName),CLSID(0),ByVal0)=0)
EndIf
CaseImageFileFormat.jpg'JPG格式可以設置保存的質量
DimaEncParams()AsByte
DimuEncParamsAsEncoderParameters
IfGetEncoderCLSID("Image/jpeg",CLSID)<>-1Then
uEncParams.count=1'設置自定義的編碼參數，這里為1個參數
IfJpgQuality<0Then
JpgQuality=0
ElseIfJpgQuality>100Then
JpgQuality=100
EndIf
ReDimaEncParams(1ToLen(uEncParams))
WithuEncParams.Parameter
.NumberOfValues=1
.type=EncoderParameterValueTypeLong'設置參數值的數據類型為長整型
CallCLSIDFromString(StrPtr(EncoderQuality),.GUID(0))'設置參數唯一標志的GUID，這里為編碼品質
.Value=VarPtr(JpgQuality)'設置參數的值：品質等級，最高為100，圖像文件大小與品質成正比
EndWith
CopyMemoryaEncParams(1),uEncParams,Len(uEncParams)
SavehBitmapToFile=(GdipSaveImageToFile(bitmap,StrPtr(FileName),CLSID(0),aEncParams(1))=0)
EndIf
CaseImageFileFormat.png
IfNotGetEncoderCLSID("Image/png",CLSID)=-1Then
SavehBitmapToFile=(GdipSaveImageToFile(bitmap,StrPtr(FileName),CLSID(0),ByVal0)=0)
EndIf
CaseImageFileFormat.gif
IfNotGetEncoderCLSID("Image/gif",CLSID)=-1Then'如果原始的圖像是24位，則這個函數會調用系統的調色板來將圖像轉換為8位，轉換的效果會不盡人意,但也有可能系統不自動轉換，保存失敗
SavehBitmapToFile=(GdipSaveImageToFile(bitmap,StrPtr(FileName),CLSID(0),ByVal0)=0)
EndIf
EndSelect
EndIf
GdipDisposeImagebitmap'注意釋放資源
GdiplusShutdowntoken'關閉GDI+。
EndFunction
PrivateFunctionGetEncoderCLSID(strMimeTypeAsString,ClassID()AsLong)AsLong
DimnumAsLong
DimSizeAsLong
DimiAsLong
DimInfo()AsImageCodecInfo
DimBuffer()AsByte
GetEncoderCLSID=-1
GdipGetImageEncodersSizenum,Size'得到解碼器數組的大小
IfSize<>0Then
ReDimInfo(1Tonum)AsImageCodecInfo'給數組動態分配內存
ReDimBuffer(1ToSize)AsByte
GdipGetImageEncodersnum,Size,Buffer(1)'得到數組和字符數據
CopyMemoryInfo(1),Buffer(1),(Len(Info(1))*num)'復制類頭
Fori=1Tonum'循環檢測所有解碼
If(StrComp(PtrToStrW(Info(i).MimeType),strMimeType,vbTextCompare)=0)Then'必須把指針轉換成可用的字符
CopyMemoryClassID(0),Info(i).ClassID(0),16'保存類的ID
GetEncoderCLSID=i'返回成功的索引值
ExitFor
EndIf
Next
EndIf
EndFunction
PrivateFunctionPtrToStrW(ByVallpszAsLong)AsString
DimOutAsString
DimLengthAsLong
Length=lstrlenW(lpsz)
IfLength>0Then
Out=StrConv(String$(Length,vbNullChar),vbUnicode)
CopyMemoryByValOut,ByVallpsz,Length*2
PtrToStrW=StrConv(Out,vbFromUnicode)
EndIf
EndFunction
PrivateDeclareFunctionGetDCLib"user32.dll"(ByValhWndAsLong)AsLong
PrivateDeclareFunctionCreateCompatibleDCLib"gdi32.dll"(ByValhdcAsLong)AsLong
PrivateDeclareFunctionCreateCompatibleBitmapLib"gdi32.dll"(ByValhdcAsLong,ByValnWidthAsLong,ByValnHeightAsLong)AsLong
PrivateDeclareFunctionSelectObjectLib"gdi32.dll"(ByValhdcAsLong,ByValhObjectAsLong)AsLong
PrivateDeclareFunctionSetEnhMetaFileBits&Lib"gdi32.dll"(ByValDataLen&,pDataAsAny)
PrivateDeclareFunctionPlayEnhMetaFile&Lib"gdi32"(ByValhdc&,ByValhEMF&,pRectAsAny)
PrivateDeclareFunctionDeleteEnhMetaFile&Lib"gdi32.dll"(ByValhEMFAsLong)
PrivateDeclareFunctionDeleteObjectLib"gdi32.dll"(ByValhObjectAsLong)AsLong
PrivateDeclareFunctionDeleteDCLib"gdi32.dll"(ByValhdcAsLong)AsLong
PrivateDeclareFunctionReleaseDCLib"user32"(ByValhWndAsLong,ByValhdcAsLong)AsLong
PrivateDeclareFunctionBitBltLib"gdi32"(ByValhDestDCAsLong,ByValxAsLong,ByValyAsLong,ByValnWidthAsLong,ByValnHeightAsLong,ByValhSrcDCAsLong,ByValxSrcAsLong,ByValySrcAsLong,ByValdwRopAsLong)AsLong
PrivateDeclareFunctionFillRectLib"user32.dll"(ByValhdcAsLong,ByReflpRectAsAny,ByValhBrushAsLong)AsLong
PrivateDeclareFunctionInvertRectLib"user32.dll"(ByValhdcAsLong,ByReflpRectAsAny)AsLong
FunctionImageExtract(objAsObject,ByValFileNameAsString,_
OptionalByValFileFormatAsImageFileFormat=jpg,_
OptionalByValJpgQualityAsLong=80,_
OptionalResolutionAsSingle)AsBoolean
Dimn!'放大倍數
DimaRECT(0To3)AsLong
DimhScreenDC&
DimhMemDC&
DimhBitmap&,hBitTemp&
Dimarr()AsByte,hEMF&
n=4
SelectCaseTypeName(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)'高度
EndSelect
hEMF=SetEnhMetaFileBits(UBound(arr)+1,arr(0))
hScreenDC=GetDC(0&)
hMemDC=CreateCompatibleDC(hScreenDC)
hBitmap=CreateCompatibleBitmap(hScreenDC,aRECT(2),aRECT(3))
hBitTemp=SelectObject(hMemDC,hBitmap)
InvertRecthMemDC,aRECT(0)
IfhEMFThen
PlayEnhMetaFilehMemDC,hEMF,aRECT(0)
DeleteEnhMetaFilehEMF'銷毀EMF
EndIf
hBitmap=SelectObject(hMemDC,hBitTemp)
ImageExtract=SavehBitmapToFile(hBitmap,FileName,FileFormat,JpgQuality,Resolution)
DeleteObjecthBitmap
DeleteDChMemDC
DeleteDChScreenDC
EndFunction
DimoInlineShapeAsInlineShape
DimoShapeAsShape
SetoInlineShape=oDocument.InlineShapes(1)
SetoShape=oDocument.Shapes(2)
IfImageExtract(oInlineShape,"c:\1.jpg",jpg,100,600)then
msgbox"保存成功"
EndIf
IfImageExtract(oShape,"c:\2.jpg",jpg,100,600)thenmsgbox"保存成功"EndIf