form1.frm

一种对bmp文件进行图像压缩的算法。将一幅bmp文件压缩之后再显示出来与压缩前的文件作比较。

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "ComDlg32.OCX"
Begin VB.Form Form2 
   Caption         =   "打开BMP图片"
   ClientHeight    =   7230
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   11175
   LinkTopic       =   "Form1"
   ScaleHeight     =   7230
   ScaleWidth      =   11175
   StartUpPosition =   2  '屏幕中心
   Begin MSComDlg.CommonDialog CommonDialog3 
      Left            =   6960
      Top             =   2160
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComDlg.CommonDialog CommonDialog2 
      Left            =   6000
      Top             =   2160
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command2 
      Caption         =   "2、保存压缩文件"
      Height          =   495
      Left            =   8760
      TabIndex        =   5
      Top             =   840
      Width           =   1455
   End
   Begin VB.CommandButton Command3 
      Caption         =   "3、打开压缩图片"
      Height          =   495
      Left            =   8760
      TabIndex        =   4
      Top             =   1560
      Width           =   1455
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   5040
      Top             =   2160
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.PictureBox Picture2 
      AutoRedraw      =   -1  'True
      Height          =   2175
      Left            =   8760
      ScaleHeight     =   2115
      ScaleWidth      =   2235
      TabIndex        =   0
      Top             =   2520
      Width           =   2295
   End
   Begin VB.CommandButton Command1 
      Caption         =   "1、选择原图片  "
      Height          =   495
      Left            =   8760
      TabIndex        =   2
      Top             =   240
      Width           =   1455
   End
   Begin VB.PictureBox Picture1 
      Height          =   6735
      Left            =   240
      ScaleHeight     =   6675
      ScaleWidth      =   8475
      TabIndex        =   1
      Top             =   360
      Width           =   8535
      Begin VB.PictureBox Picture3 
         Height          =   3375
         Left            =   3720
         ScaleHeight     =   3315
         ScaleWidth      =   4515
         TabIndex        =   3
         Top             =   3120
         Width           =   4575
         Begin VB.Label Label2 
            Caption         =   "压缩后的图片"
            Height          =   375
            Left            =   120
            TabIndex        =   6
            Top             =   120
            Width           =   1335
         End
      End
      Begin VB.Label Label1 
         Caption         =   "原BMP图片"
         Height          =   375
         Left            =   120
         TabIndex        =   7
         Top             =   120
         Width           =   2055
      End
   End
   Begin VB.Timer Timer1 
      Left            =   6720
      Top             =   4440
   End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Command2_Click()
On Error GoTo err1

CommonDialog2.Action = 2
Open CommonDialog2.FileName For Binary As #2
Open CommonDialog1.FileName For Binary As #1

Picture2.Cls

Dim bmpGeshi1 As Byte  '。。。。。。判断是不是BMP图片
Dim bmpGeshi2 As Byte
Get #1, 1, bmpGeshi1
Get #1, 2, bmpGeshi2
If bmpGeshi1 = 66 And bmpGeshi2 = 77 Then
   Picture2.Print "BMP"
Else
   Picture2.Print "格式错误"
   Close #1
   Exit Sub
End If

Dim geShi As Byte   '。。。。。。判断BMP图片位数
Get #1, &H1C + 1, geShi
If geShi = 24 Then
  Picture2.Print "24位"
Else
   Picture2.Print "文件是"; geShi; "位格式不支持,请打开24位格式的BMP"
   Close #1
   Exit Sub
End If
Picture3.Picture = LoadPicture()

Dim Kuan As Long   '。。。。。找到图片高、宽
Dim Gao As Long
Get #1, &H12 + 1, Kuan
Get #1, &H16 + 1, Gao
Picture2.Print "图像大小:宽"; Kuan; "高"; Gao
Dim BS As String
BS = "B8"
Put #2, 1, BS
'Put #2, 2, 8
Put #2, 3, Kuan
Put #2, 7, Gao
'put #2,11,
Picture3.Picture = LoadPicture()
Dim pos As Long  '文件中点的指针
Dim cha As Integer '行末尾填充的字节数
cha = Abs((Kuan * 3) Mod 4 - 4) Mod 4
Picture2.Print "行末尾多余的字节"; cha
pos = &H36 + 1
Dim Pos8 As Long
Pos8 = 21
Dim IX As Long '用于描出点的坐标
Dim IY As Long '用于描出点的坐标
Dim yanseRed As Byte   '存红色的值
Dim yanseGreen As Byte '存绿色的值
Dim yanseBlue As Byte  '存蓝色的值

Dim endYanse As Byte
Dim endR As Byte
Dim endG As Byte
Dim endB As Byte

Dim yanseRed8 As Byte   '存红色的值
Dim yanseGreen8 As Byte '存绿色的值
Dim yanseBlue8 As Byte  '存蓝色的值

For IY = Gao - 1 To 0 Step -1 'y行       '。。。。。。描点
For IX = 0 To Kuan - 1 'x列
  Get #1, pos, yanseBlue '得到颜色
  Get #1, pos + 1, yanseGreen '得到颜色
  Get #1, pos + 2, yanseRed '得到颜色
 ' Picture1.PSet (IX, IY), RGB(yanseRed, yanseGreen, yanseBlue)

Select Case yanseRed
Case 0 To 41
endR = 0
Case 42 To 84
endR = 1
Case 85 To 127
endR = 2
Case 128 To 170
endR = 3
Case 171 To 213
endR = 4
Case 214 To 255
endR = 5
End Select

Select Case yanseGreen
Case 0 To 41
endG = 0
Case 42 To 84
endG = 1
Case 85 To 127
endG = 2
Case 128 To 170
endG = 3
Case 171 To 213
endG = 4
Case 214 To 255
endG = 5
End Select

Select Case yanseBlue
Case 0 To 41
endB = 0
Case 42 To 84
endB = 1
Case 85 To 127
endB = 2
Case 128 To 170
endB = 3
Case 171 To 213
endB = 4
Case 214 To 255
endB = 5
End Select

Picture3.PSet (IX, IY), RGB(endR * 42, endG * 42, endB * 42)
endYanse = endR * 6 * 6 + endG * 6 + endB
Put #2, Pos8, endYanse
  pos = pos + 3 '开始读下一个像素
  Pos8 = Pos8 + 1
Next IX
  pos = pos + cha '描到了行末尾，则跳过不要的字节
  Pos8 = Pos8 + cha
Next IY

Close #1  '正常时关闭文件
Close #2
Exit Sub

err1: '错误处理
If Err = 32755 Then Exit Sub '打开文件对话框点"取消"时，发生32755错误错误
Picture2.Print "发生错误"; "Err="; Err
Close #1 '有错误时关闭文件
Close #2
Exit Sub
End Sub

Private Sub Command1_Click()
On Error GoTo aaa
Picture2.Cls

CommonDialog1.Action = 1
Picture1.Picture = LoadPicture()

Picture1.Picture = LoadPicture(CommonDialog1.FileName)
Command2.Enabled = True
Exit Sub
aaa:
If Err = 32755 Then Exit Sub '打开文件对话框点"取消"时，发生32755错误错误
Picture2.Print "图片格式不支持"
Command2.Enabled = False
Exit Sub
End Sub

Private Sub Command3_Click()
On Error GoTo err1
Picture2.Cls

CommonDialog3.Action = 1
Open CommonDialog3.FileName For Binary As #3
Picture2.Cls


Dim bmp8Geshi1 As Byte  '。。。。。。判断是不是BMP8图片
Dim bmp8Geshi2 As Byte
Get #3, 1, bmp8Geshi1
Get #3, 2, bmp8Geshi2
If bmp8Geshi1 = &H42 And bmp8Geshi2 = &H38 Then
   Picture2.Print "BMP8"
Else
   Picture2.Print "格式错误"
   Close #1
   Exit Sub
End If

Picture3.Picture = LoadPicture()
Dim Kuan8 As Long   '。。。。。找到图片高、宽
Dim Gao8 As Long
Get #3, 3, Kuan8
Get #3, 7, Gao8
Picture2.Print "8位图像大小:宽"; Kuan8; "高"; Gao8
Dim cha As Integer
cha = Abs((Kuan8 * 3) Mod 4 - 4) Mod 4

Dim IX As Long '用于描出点的坐标
Dim IY As Long '用于描出点的坐标
Dim yanseRed8 As Byte   '存红色的值
Dim yanseGreen8 As Byte '存绿色的值
Dim yanseBlue8 As Byte  '存蓝色的值
Dim Pos8 As Long
Dim endYanse8 As Byte
Pos8 = 21

For IY = Gao8 - 1 To 0 Step -1 'y行       '。。。。。。描点
For IX = 0 To Kuan8 - 1 'x列
  Get #3, Pos8, endYanse8  '得到颜色
 yanseRed8 = Fix(endYanse8 / 6 / 6)
  yanseGreen8 = Fix((endYanse8) / 6) Mod 6
  yanseBlue8 = endYanse8 Mod 6
  Picture3.PSet (IX, IY), RGB(yanseRed8 * 42, yanseGreen8 * 42, yanseBlue8 * 42)
  Pos8 = Pos8 + 1
Next IX
  Pos8 = Pos8 + cha  '描到了行末尾，则跳过不要的字节
Next IY

Close #3  '正常时关闭文件
Exit Sub

err1: '错误处理
If Err = 32755 Then Exit Sub '打开文件对话框点"取消"时，发生32755错误错误
Picture2.Print "发生错误"; "Err="; Err
Close #3 '有错误时关闭文件
Exit Sub
End Sub


Private Sub Form_Load()  '。。。。。。初始化
Picture1.ScaleMode = vbPixels '设定坐标为像素点
Picture3.ScaleMode = vbPixels
Picture1.AutoRedraw = True
Picture2.AutoRedraw = True
Picture3.AutoRedraw = True
CommonDialog1.Filter = "文件bmp　*.bmp |*.bmp| "
CommonDialog2.Filter = "文件bmp　*.bmp8 |*.bmp8| "
CommonDialog3.Filter = "文件bmp　*.bmp8 |*.bmp8| "
Command2.Enabled = False
CommonDialog1.CancelError = True
CommonDialog2.CancelError = True
CommonDialog3.CancelError = True
CommonDialog1.InitDir = App.Path
CommonDialog2.InitDir = App.Path
CommonDialog3.InitDir = App.Path
End Sub