PrivateTypeGUID Data1AsLong Data2AsInteger Data3AsInteger Data4(0To7)AsByte EndType PrivateTypeGdiplu
sstartupInput Gdiplu
sversionAsLong DebugEventCallbackAsLong SuppressBackgroundThreadAsLong SuppressExternalCodecsAsLong EndType PrivateTypeEncoderP
arameter GUIDAsGUID NumberOfValuesAsLong typeAsLong ValueAsLong EndType PrivateTypeEncoderP
arameters countAsLong P
arame
terasEncoderP
arameter EndTypePrivateDeclareFunctionGdiplu
sstartupLib"GDIPlus"(tokenAsLong,inputbufAsGdiplu
sstartupInput,OptionalByValoutputbufAsLong=0)AsLong PrivateDeclareFunctionGdiplusShutdownLib"GDIPlus"(ByValtokenAsLong)AsLong PrivateDeclareFunctionGdipCreateBitmapFromHBITMAPLib"GDIPlus"(ByValhbmAsLong,ByValhPalAsLong,BITMAPAsLong)AsLong PrivateDeclareFunctionGdip
disposeImageLib"GDIPlus"(ByValImageAsLong)AsLong PrivateDeclareFunctionGdipSaveImag
etoFileLib"GDIPlus"(ByValImageAsLong,ByValFileNameAsLong,clsidEncoderAsGUID,encoderP
aramsAsAny)AsLong PrivateDeclareFunctionCLSIDFromStringLib"ole32"(ByValStrAsLong,idAsGUID)AsLong PrivateDeclareFunction
copyMemoryLib"kernel32"Alias"RtlMoveMemory"(DestAsAny,SrcAsAny,ByValcbAsLong)AsLong '************************************************************************* '**作者:laviewpbt '**
函数名:SavePic '**输入:pic(StdPicture)-图象句柄 '**:FileName(String)-保存路径 '**:Quality(Byte)-JPG图象质量 '**:TIFF_ColorDepth(Long)-TTF格式的颜色深度 '**:TIFF_Compression(Long)-TTF格式的压缩比 '**
输出:无 '**
功能描述:把图象保存为JPG、TIFF、PNG、GIF、BMP格式 '**日期: '**
修改人:laviewpbt '**日期:2005-10-2314.43.52 '**版本:Version1.2.1 '************************************************************************* PrivateSubSavePic(ByValpictA
sstdPicture,ByValFileNameA
sstring,PicTypeA
sstring,_ OptionalByValQualityAsByte=80,_ OptionalByValTIFF_ColorDepthAsLong=24,_ OptionalByValTIFF_CompressionAsLong=6) Screen.MousePointer=vbHourglass DimtSIAsGdiplu
sstartupInput DimlResAsLong DimlGDIPAsLong DimlBitmapAsLong DimaEncP
arams()AsByte OnErrorGoToErrHandle: tSI.Gdiplu
sversion=1'初始化GDI+ lRes=Gdiplu
sstartup(lGDIP,tSI) IflRes=0Then'从句柄创建GDI+图像 lRes=GdipCreateBitmapFromHBITMAP(pict.Handle,lBitmap) IflRes=0Then DimtJpgEncoderAsGUID DimtP
aramsAsEncoderP
arameters'初始化解码器的GUID标识 SelectCasePicType Case".jpg" CLSIDFromStringStrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder tP
arams.count=1'设置解码器参数 WithtP
arams.P
arameter'Quality CLSIDFromStringStrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"),.GUID'得到Quality参数的GUID标识 .NumberOfValues=1 .type=4 .Value=VarPtr(Quality) EndWith ReDimaEncP
arams(1ToLen(tP
arams)) Call
copyMemory(aEncP
arams(1),tP
arams,Len(tP
arams)) Case".png" CLSIDFromStringStrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder ReDimaEncP
arams(1ToLen(tP
arams)) Case".gif" CLSIDFromStringStrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder ReDimaEncP
arams(1ToLen(tP
arams)) Case".tiff" CLSIDFromStringStrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder tP
arams.count=2 ReDimaEncP
arams(1ToLen(tP
arams)+Len(tP
arams.P
arameter)) WithtP
arams.P
arameter .NumberOfValues=1 .type=4 CLSIDFromStringStrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"),.GUID'得到ColorDepth参数的GUID标识 .Value=VarPtr(TIFF_Compression) EndWith Call
copyMemory(aEncP
arams(1),Len(tP
arams)) WithtP
arams.P
arameter .NumberOfValues=1 .type=4 CLSIDFromStringStrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"),.GUID'得到Compression参数的GUID标识 .Value=VarPtr(TIFF_ColorDepth) EndWith Call
copyMemory(aEncP
arams(Len(tP
arams)+1),tP
arams.P
arameter,Len(tP
arams.P
arameter)) Case".bmp"'可以提前写保存为BMP的
代码,因为并没有用GDI+ SavePicturepict,FileName Screen.MousePointer=vbDefault ExitSub EndSelect lRes=GdipSaveImag
etoFile(lBitmap,StrPtr(FileName),tJpgEncoder,aEncP
arams(1))'保存图像 Gdip
disposeImagelBitmap'销毁GDI+图像 EndIf GdiplusShutdownlGDIP'销毁GDI+ EndIf Screen.MousePointer=vbDefault EraseaEncP
arams ExitSub ErrHandle: Screen.MousePointer=vbDefault Msg
Box"在保存
图片的过程中发生
错误:"&vbCrLf&vbCrLf&"
错误号:"&err.Number&vbCrLf&"
错误描述:"&err.Description,vb
informatio
norvbOKOnly,"
错误" EndSub