PrivateTypeGUID Data1AsLong Data2AsInteger Data3AsInteger Data4(0To7)AsByte EndType PrivateTypeGdiplusStartupInput GdiplusVersionAsLong DebugEventCallbackAsLong SuppressBackgroundThreadAsLong SuppressExternalCodecsAsLong EndType PrivateTypeEncoderParameter GUIDAsGUID NumberOfValuesAsLong typeAsLong ValueAsLong EndType PrivateTypeEncoderParameters countAsLong ParameterAsEncoderParameter EndTypePrivateDeclareFunctionGdiplusStartupLib"GDIPlus"(tokenAsLong,inputbufAsGdiplusStartupInput,OptionalByValoutputbufAsLong=0)AsLong PrivateDeclareFunctionGdiplusShutdownLib"GDIPlus"(ByValtokenAsLong)AsLong PrivateDeclareFunctionGdipCreateBitmapFromHBITMAPLib"GDIPlus"(ByValhbmAsLong,ByValhPalAsLong,BITMAPAsLong)AsLong PrivateDeclareFunctionGdipDisposeImageLib"GDIPlus"(ByValImageAsLong)AsLong PrivateDeclareFunctionGdipSaveImageToFileLib"GDIPlus"(ByValImageAsLong,ByValFileNameAsLong,clsidEncoderAsGUID,encoderParamsAsAny)AsLong PrivateDeclareFunctionCLSIDFromStringLib"ole32"(ByValStrAsLong,idAsGUID)AsLong PrivateDeclareFunctionCopyMemoryLib"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(ByValpictAsStdPicture,ByValFileNameAsString,PicTypeAsString,_ OptionalByValQualityAsByte=80,_ OptionalByValTIFF_ColorDepthAsLong=24,_ OptionalByValTIFF_CompressionAsLong=6) Screen.MousePointer=vbHourglass DimtSIAsGdiplusStartupInput DimlResAsLong DimlGDIPAsLong DimlBitmapAsLong DimaEncParams()AsByte OnErrorGoToErrHandle: tSI.GdiplusVersion=1'初始化GDI+ lRes=GdiplusStartup(lGDIP,tSI) IflRes=0Then'从句柄创建GDI+图像 lRes=GdipCreateBitmapFromHBITMAP(pict.Handle,lBitmap) IflRes=0Then DimtJpgEncoderAsGUID DimtParamsAsEncoderParameters'初始化解码器的GUID标识 SelectCasePicType Case".jpg" CLSIDFromStringStrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder tParams.count=1'设置解码器参数 WithtParams.Parameter'Quality CLSIDFromStringStrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"),.GUID'得到Quality参数的GUID标识 .NumberOfValues=1 .type=4 .Value=VarPtr(Quality) EndWith ReDimaEncParams(1ToLen(tParams)) CallCopyMemory(aEncParams(1),tParams,Len(tParams)) Case".png" CLSIDFromStringStrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder ReDimaEncParams(1ToLen(tParams)) Case".gif" CLSIDFromStringStrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder ReDimaEncParams(1ToLen(tParams)) Case".tiff" CLSIDFromStringStrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder tParams.count=2 ReDimaEncParams(1ToLen(tParams)+Len(tParams.Parameter)) WithtParams.Parameter .NumberOfValues=1 .type=4 CLSIDFromStringStrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"),.GUID'得到ColorDepth参数的GUID标识 .Value=VarPtr(TIFF_Compression) EndWith CallCopyMemory(aEncParams(1),Len(tParams)) WithtParams.Parameter .NumberOfValues=1 .type=4 CLSIDFromStringStrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"),.GUID'得到Compression参数的GUID标识 .Value=VarPtr(TIFF_ColorDepth) EndWith CallCopyMemory(aEncParams(Len(tParams)+1),tParams.Parameter,Len(tParams.Parameter)) Case".bmp"'可以提前写保存为BMP的代码，因为并没有用GDI+ SavePicturepict,FileName Screen.MousePointer=vbDefault ExitSub EndSelect lRes=GdipSaveImageToFile(lBitmap,StrPtr(FileName),tJpgEncoder,aEncParams(1))'保存图像 GdipDisposeImagelBitmap'销毁GDI+图像 EndIf GdiplusShutdownlGDIP'销毁GDI+ EndIf Screen.MousePointer=vbDefault EraseaEncParams ExitSub ErrHandle: Screen.MousePointer=vbDefault MsgBox"在保存图片的过程中发生错误:"&vbCrLf&vbCrLf&"错误号:"&err.Number&vbCrLf&"错误描述:"&err.Description,vbInformationOrvbOKOnly,"错误" EndSub