VB小程序VB代码:将图片保存或转变为JPG格式

VB小程序VB代码：将图片保存或转变为JPG格式

当前位置： > VB小程序1-99 > 将图片保存或转变为 JPG 格式

12. 将图片保存或转变为JPG格式

本人原创，转载请注明出处：/100bd/blog/item/

'函数 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

sVersion = 1 ' 初始化 GDI+

dl = GdiplusStartup(nGDIP, nGSI)

If dl <> 0 Then SavePicToFile = "无法创建 GDI 图像": Exit Function

dl = GdipCreateBitmapFromHBITMAP(, 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

= 1 ' 设置解码器参数

With ter

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

= 2

ReDim B(1 To Len(mEP) + Len(ter))

With ter

.NumberOfValues = 1

.Type = 4

CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .nGUID

.Value = VarPtr(TIFF_Compression)

End With

Call CopyMemory(B(1), mEP, Len(mEP))

With ter

.NumberOfValues = 1

.Type = 4

CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .nGUID

.Value = VarPtr(TIFF_ColorDepth)

End With

Call CopyMemory(B(Len(mEP) + 1), ter, Len(ter))

Case Else 'p_BMP 没有使用 GDI+

If LCase(Right(FileName, 4)) <> ".bmp" Then FileName = FileName

& ".bmp"

SavePicture nPic, FileName

Exit Function

End Select

dl = GdipSaveImageToFile(nBMP, StrPtr(FileName), mGUID, B(1)) '保存到文件

GdipDisposeImage nBMP '销毁 GDI+ 图像

GdiplusShutdown nGDIP '销毁 GDI+

Exit Function

Cuo:

SavePicToFile = "错误 " & & "：" & ption

End Function

Private Sub Form_Load()

n = "图片格式转换": n = "转换"

= "E:"

End Sub

Private Sub Command1_Click()

Dim nStr As String, F As String

ze = True:

F = Trim()

e = LoadPicture(F)

'默认保存为 JPG 格式，如果无扩展名，则自动添加扩展名。成功返回空字符串

F = NoKuo(F) '去掉原扩展名

nStr = SavePicToFile(e, F)

If nStr <> "" Then MsgBox nStr

End Sub

Private Function NoKuo(F As String) As String

Dim I As Long

For I = Len(F) To 1 Step -1

If Mid(F, I, 1) = "." Then NoKuo = Left(F, I - 1): Exit Function

Next

NoKuo = F

End Function

当前位置： > VB小程序1-99 > 将图片保存或转变为 JPG 格式

查看文档来源：/100bd/item/b292575f59f1edcad0e10c92