当前位置： > VB小程序1-99 > 将图片保存或转变为 JPG 格式
12. 将图片保存或转变为JPG格式
本人原创，转载请注明出处：hi.baidu/100bd/blog/item/18d7448addbb9519c9fc7a1a.html
虾仁饺子'函数 SavePicToFile 把图象保存为 JPG、TIFF、PNG、GIF、BMP 格式。成功返回空字符串，失败返回错误信息。
'需要在窗体放置控件：Command1，Picture1，Text1
' '以下代码在 VB6 调试通过。
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
nGUID As GUID
NumberOfValues As Long
Type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Enum PicType
p_BMP
p_JPG
p_GIF
p_PNG
p_TIFF
End Enum
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
Public Function SavePicToFile(ByVal nPic As StdPicture, ByVal FileName As String, _
Optional ByVal nType As PicType = p_JPG, Optional ByVal Quality As Byte = 80, _
Optional ByVal TIFF_ColorDepth As Long = 24, Optional ByVal TIFF_Compression As Long = 6) As String
'功能：把图象保存为 BMP、JPG、GIF、PNG、TIFF 格式。成功返回空字符串，失败返回错误信息
'如果保存的文件名无扩展名，则自动添加相应的扩展名
'StdPicture) 图象句柄
'FileName 保存文件名
'nType 文件格式：0 BMP 1 JPG 2 GIF 3 PNG 4 TIFF
'Quality JPG 图象质量
开荒保洁收费标准 'TIFF_ColorDepth TTF 格式的颜深度
宝宝起名字 'TIFF_Compression TTF 格式的压缩比
Dim dl As Long, nGDIP As Long, nBMP As Long
Dim nGSI As GdiplusStartupInput, B() As Byte
端午节祝福信息简短 On Error GoTo Cuo
nGSI.GdiplusVersion = 1 ' 初始化 GDI+
dl = GdiplusStartup(nGDIP, nGSI)
If dl <> 0 Then SavePicToFile = "无法创建 GDI 图像": Exit Function
dl = GdipCreateBitmapFromHBITMAP(nPic.Handle, 0, nBMP)
If dl <> 0 Then GdiplusShutdown nGDIP: SavePicToFile = "不支持图片格式": Exit Function
Dim mGUID As GUID, mEP As EncoderParameters '初始化解码器的 GUID 标识
Select Case nType
Case p_JPG
If LCase(Right(FileName, 4)) <> ".jpg" Then FileName = FileName & ".jpg"
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), mGUID
mEP.Count = 1 ' 设置解码器参数
With mEP.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .nGUID '得到 GUID 标识
.NumberOfValues = 1
.Type = 4
.Value = VarPtr(Quality)
End With
ReDim B(1 To Len(mEP))
Call CopyMemory(B(1), mEP, Len(mEP))
Case p_GIF
烹饪配方 If LCase(Right(FileName, 4)) <> ".gif" Then FileName = FileName & ".gif"
CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), mGUID
ReDim B(1 To Len(mEP))
Case p_PNG
If LCase(Right(FileName, 4)) <> ".png" Then FileName = FileName & ".png"
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), mGUID
ReDim B(1 To Len(mEP))
Case p_TIFF
If LCase(Right(FileName, 5)) <> ".tiff" Then FileName = FileName & ".tiff"
CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), mGUID
mEP.Count = 2
ReDim B(1 To Len(mEP) + Len(mEP.Parameter))
With mEP.Parameter
.NumberOfValues = 1
.Type = 4
CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .nGUID
.Value = VarPtr(TIFF_Compression)杨钰莹为什么叫岗岗
发布评论