VERSION 5.00 Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX" Begin VB.Form frm_compression BorderStyle = 3 'Fixed Dialog Caption = "File Compression" ClientHeight = 1425 ClientLeft = 45 ClientTop = 330 ClientWidth = 3015 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 1425 ScaleWidth = 3015 ShowInTaskbar = 0 'False StartUpPosition = 1 'CenterOwner WhatsThisHelp = -1 'True Begin MSComctlLib.ProgressBar pbr_progress Height = 495 Left = 120 TabIndex = 0 Top = 840 Width = 2775 _ExtentX = 4895 _ExtentY = 873 _Version = 393216 BorderStyle = 1 Appearance = 1 End Begin VB.Label lbl_function Alignment = 2 'Center BackStyle = 0 'Transparent BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = -1 'True Strikethrough = 0 'False EndProperty Height = 375 Left = 840 TabIndex = 4 Top = 360 Width = 1455 End Begin VB.Label lbl_filename Alignment = 2 'Center BackStyle = 0 'Transparent BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 120 TabIndex = 3 Top = 0 Width = 2775 End Begin VB.Label Label2 BackStyle = 0 'Transparent Caption = "100%" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 2520 TabIndex = 2 Top = 600 Width = 495 End Begin VB.Label Label1 BackStyle = 0 'Transparent Caption = "0%" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 120 TabIndex = 1 Top = 600 Width = 375 End End Attribute VB_Name = "frm_compression" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '****************************************************************************** 'RifLE Compression Module 'Contains code to compress files using the Run Length Encoding compression 'RifLECompressFile - Takes byte array and filename, compresses array into file 'RifLEUnCompressFile - takes filename and returns byte array 'if this module is used, please display About_App off the program's About screen. 'Christopher Niggel CS14 copyright 4-21-2000 '****************************************************************************** Private Const app_ver As String = "1.2" Const About_App As String = "RifLE Compression - " & app_ver _ & "By Christopher Niggel. 32bit RLE file compression system" Option Explicit Option Base 0 'File Compression interface Public Sub RifLECompressFile(bytFileString() As Byte, strFileName As String) Dim output() As Byte 'Me.lbl_filename = strFileName Me.Show Call RLECompress(bytFileString, output) Open strFileName For Binary As #2 Put #2, 1, output Close #2 Me.Hide End Sub 'file Uncompression interface Public Function RifLEUnCompressFile(strFileName As String) As Byte() Dim file_length As Long Dim bytes() As Byte 'Me.lbl_filename = strFileName Me.Show file_length = FileLen(strFileName) ReDim bytes(0 To (file_length - 1)) Open strFileName For Binary As #2 Get #2, 1, bytes Close #2 RifLEUnCompressFile = RLEUncompress(bytes) Me.Hide End Function '****************************************************************************** 'Compression algorithms below. It is preferable to use the file compression ' wrappers above this note. 'Remove the pbr_progress lines if porting below only to another app. 'please maintain the copyright information at the top. '****************************************************************************** '32bit compression Private Sub RLECompress(arrInput() As Byte, arrOutput() As Byte) Dim I As Double Dim ByteCnt As Double ReDim arrOutput(3) arrOutput(0) = arrInput(0) arrOutput(1) = arrInput(1) arrOutput(2) = arrInput(2) arrOutput(3) = arrInput(3) For I = 4 To (UBound(arrInput) - 4) Step 4 If (Compare(arrInput, I, (I - 4))) Then ByteCnt = I Do Until (Not (Compare(arrInput, ByteCnt, (I - 4))) Or _ (ByteCnt - (I - 4) = 254)) ByteCnt = ByteCnt + 4 If ((ByteCnt + 3) > UBound(arrInput)) Then Exit Do Loop If ((ByteCnt + 3) > UBound(arrInput)) Then ReDim Preserve arrOutput(UBound(arrOutput) + 1) arrOutput(UBound(arrOutput)) = ((ByteCnt - (I - 4)) / 4) Else ReDim Preserve arrOutput((UBound(arrOutput)) + 5) arrOutput(UBound(arrOutput) - 4) = ((ByteCnt - (I - 4)) / 4) arrOutput(UBound(arrOutput) - 3) = arrInput(ByteCnt) arrOutput(UBound(arrOutput) - 2) = arrInput(ByteCnt + 1) arrOutput(UBound(arrOutput) - 1) = arrInput(ByteCnt + 2) arrOutput(UBound(arrOutput)) = arrInput(ByteCnt + 3) End If I = ByteCnt Else ReDim Preserve arrOutput(UBound(arrOutput) + 5) arrOutput(UBound(arrOutput) - 4) = 1 arrOutput(UBound(arrOutput) - 3) = arrInput(I) arrOutput(UBound(arrOutput) - 2) = arrInput(I + 1) arrOutput(UBound(arrOutput) - 1) = arrInput(I + 2) arrOutput(UBound(arrOutput)) = arrInput(I + 3) 'I = I + 4 End If 'statusbar update code If (I / (UBound(arrInput)) * 100) > 100 Then pbr_progress.Value = 100 frm_compression.Refresh Else pbr_progress.Value = (I / (UBound(arrInput)) * 100) frm_compression.Refresh End If 'end statusbar update code Next I Dim BytesLeft As Integer Dim counter As Integer BytesLeft = ((UBound(arrInput) Mod 4) + 1) If (BytesLeft <> 4) Then ReDim Preserve arrOutput(UBound(arrOutput) + BytesLeft) For counter = 0 To ((BytesLeft) - 1) arrOutput(UBound(arrOutput) - counter) = arrInput(UBound(arrInput) - counter) Next counter End If ReDim Preserve arrOutput(UBound(arrOutput) + 1) arrOutput(UBound(arrOutput)) = BytesLeft End Sub '32bit uncompression Private Function RLEUncompress(ByteArr() As Byte) As Byte() Dim I As Double Dim counter As Double Dim output() As Byte counter = -1 For I = 4 To (UBound(ByteArr) - (ByteArr(UBound(ByteArr)))) Step 5 ReDim Preserve output(counter + (ByteArr(I) * 4)) For counter = counter To (UBound(output) - 1) Step 4 output(counter + 1) = ByteArr(I - 4) output(counter + 2) = ByteArr(I - 3) output(counter + 3) = ByteArr(I - 2) output(counter + 4) = ByteArr(I - 1) Next counter 'statusbar update start If (I / (UBound(ByteArr)) * 100) > 100 Then pbr_progress.Value = 100 frm_compression.Refresh Else pbr_progress = (I / (UBound(ByteArr)) * 100) frm_compression.Refresh End If 'statusbar update end Next I ReDim Preserve output(UBound(output) + (ByteArr(UBound(ByteArr)))) For counter = 0 To (ByteArr(UBound(ByteArr)) - 1) output(UBound(output) - counter) = ByteArr(UBound(ByteArr) - (counter + 1)) Next counter RLEUncompress = output End Function Private Function Compare(arrInput() As Byte, x As Double, y As Double) If ((arrInput(x) = arrInput(y)) _ And (arrInput(x + 1) = arrInput(y + 1)) _ And (arrInput(x + 2) = arrInput(y + 2)) _ And (arrInput(x + 3) = arrInput(y + 3))) Then Compare = vbTrue Else Compare = vbFalse End If End Function