如何用VBA代码来提取word中的图片来获取图片的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
以下是偶封装的代码：
当然偶偷懒，没有使用GDI+，又选用了GDI，实际可以都用GDI+
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