-
Notifications
You must be signed in to change notification settings - Fork 0
/
Comp_RLE_3.bas
95 lines (89 loc) · 2.63 KB
/
Comp_RLE_3.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
Attribute VB_Name = "Comp_Rle_3"
Const CompBlockLen = 3
Option Explicit
Public Sub Compress_RLE_3(ByteArray() As Byte)
Dim CmpData As String
Dim NewData As String
CmpData = StrConv(ByteArray(), vbUnicode)
NewData = CompressRLE(CmpData)
ReDim ByteArray(Len(NewData) - 1)
ByteArray() = StrConv(NewData, vbFromUnicode)
End Sub
Public Sub DeCompress_RLE_3(ByteArray() As Byte)
Dim CmpData As String
Dim NewData As String
CmpData = StrConv(ByteArray(), vbUnicode)
NewData = UnCompressRLE(CmpData)
ReDim ByteArray(Len(NewData) - 1)
ByteArray() = StrConv(NewData, vbFromUnicode)
End Sub
Function Compress(StrData As String) As String
Compress = CompressRLE(StrData)
End Function
Function UnCompress(strCompr As String) As String
UnCompress = UnCompressRLE(strCompr)
End Function
Function CompressRLE(StrData As String) As String
Dim p As Long, p2 As Long, strCompr As String
Dim w(1 To CompBlockLen + 1) As String * 1, j As Byte
Dim matches As Byte
For p = 1 To Len(StrData)
For j = 1 To CompBlockLen + 1
w(j) = Mid(StrData, p + j - 1, 1)
Next j
matches = 0
For j = 1 To CompBlockLen
If w(j) <> w(j + 1) Then matches = j: Exit For
Next j
If matches = 0 Then
p2 = p + CompBlockLen + 1
Do While Mid(StrData, p2 - 1, 1) = Mid(StrData, p2, 1) And (p2 - (p + CompBlockLen + 1)) < 254
p2 = p2 + 1
Loop
strCompr = strCompr & Chr(255) & Chr(p2 - (p + CompBlockLen + 1)) & w(1)
p = p2 - 1
Else
strCompr = strCompr & String(matches, w(1))
If w(1) = Chr(255) Then
strCompr = strCompr & String(matches, w(1))
End If
p = p + matches - 1
End If
Next p
CompressRLE = strCompr
End Function
Function UnCompressRLE(strCompr As String) As String
Dim p As Long, j As Byte, j2 As Byte, w(1 To CompBlockLen) As String, StrData As String
For p = 1 To Len(strCompr)
For j = 1 To CompBlockLen
w(j) = Mid(strCompr, p + j - 1, 1)
Next j
For j = 1 To CompBlockLen
If w(j) = "" Then
j = j + 1
Exit For
End If
If ASC(w(j)) = 255 Then
If j = CompBlockLen Then
Exit For
Else
If ASC(w(j + 1)) = 255 Then
StrData = StrData & Chr$(255)
j = j + 1
Else
If j = CompBlockLen - 1 Then
Exit For
Else
StrData = StrData & String(ASC(w(j + 1)) + CompBlockLen + 1, w(j + 2))
j = j + 2
End If
End If
End If
Else
StrData = StrData & w(j)
End If
Next j
p = p + j - 2
Next p
UnCompressRLE = StrData
End Function