VB 如何压缩一张.bmp图片?

发布网友 发布时间：2022-09-09 00:02

我来回答

共5个回答

热心网友 时间：2024-11-22 19:23

好象很难的样子,我不会,学习!

热心网友 时间：2024-11-22 19:23

需要在窗体上画以下控件：
Picture1
Picture2
Picture3
CommonDialog1
CommonDialog2
CommonDialog3
command1
Command2
command3

问题提供的条件不够充分，首先是否允许更换图片尺寸，另外是可以保存成其他格式。

如果不允许改变尺寸也不允许更改类型，那么只有降低bmp的位数来降低尺寸，但同时会导致图片的质量下降。

百度吧里有一篇文章是一段源码，你可以看一下：http://tieba.baidu.com/f?kz=88393068

同时如果需要更多关于图片类型转换的操作，可以去csdn上找一些，十分的多。

热心网友 时间：2024-11-22 19:24

要实现压缩功能，只有用第3方控件，或者调用压缩程序命令行

热心网友 时间：2024-11-22 19:25

位图可以采用RLE算法压缩，RLE是一种无损压缩算法，不过压缩比不会有JPEG高
你去找一下相关的RLE压缩位图的算法吧

热心网友 时间：2024-11-22 19:25

Option Explicit
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
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type

Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) 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 GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long

Private Sub Command1_Click()
Dim ret As Boolean

Picture1.Picture = LoadPicture("C:\a.bmp") '打开要压缩的图片

ret = PictureBoxSaveJPG(Picture1, "C:\b.jpg") '保存压缩后的图片
If ret = False Then
MsgBox "保存失败"
End If
End Sub

Private Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long

'初始化 GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)

If lRes = 0 Then
'从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)

If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters

'初始化解码器的GUID标识
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

'设置解码器参数
tParams.Count = 1
With tParams.Parameter ' Quality
'得到Quality参数的GUID标识
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(quality)
End With

'保存图像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)

'销毁GDI+图像
GdipDisposeImage lBitmap
End If

'销毁 GDI+
GdiplusShutdown lGDIP
End If

If lRes Then
PictureBoxSaveJPG = False
Else
PictureBoxSaveJPG = True
End If
End Function