This code should go in a module.
I've tested it and it is fully functional. It compresses an array of pixels (represented as Long values, in the order RGBA as used by VB6, though Point and PSet ignore the A channel) and saves it to a file. The decompress loads a file that's saved in the format that's written by the compressor, and reads its header and compressed image data and reconstructs the image. It is a lossy compression when ThresholdForCopy > 0. The farther above 0 the threshold is, the more lossy the compression is. It's lossless compression when ThresholdForCopy = 0. It uses no compression (just writes raw pixel values) when ThresholdForCopy < 0. It doesn't matter what the value of the negative number is (it can be -1 or -872346). It just needs to be negative to write raw pixel values.
Code:
Public Sub CompressImage(ByRef PixIn() As Long, ByVal Width As Long, ByVal Height As Long, ByVal OutputFileName As String, ByVal ThresholdForCopy As Long)
Dim Selectors() As Byte
Dim PackedSelectors() As Byte
Dim PSelByteCount As Long
Dim Pix() As Long
Dim NewColors() As Long
Dim x As Long
Dim y As Long
Dim n As Long
Dim NewColorCount As Long
ReDim Selectors(Width - 1, Height - 1)
ReDim Pix(Width - 1, Height - 1)
ReDim NewColors(Width * Height - 1)
For y = 0 To Height - 1
For x = 0 To Width - 1
If (x > 0) And (y > 0) Then Selectors(x, y) = GetSelector(PixIn(x, y), Pix(x - 1, y), Pix(x, y - 1), Pix(x - 1, y - 1), ThresholdForCopy)
Select Case Selectors(x, y)
Case 0
NewColors(n) = PixIn(x, y)
Pix(x, y) = NewColors(n)
n = n + 1
Case 1
Pix(x, y) = Pix(x - 1, y)
Case 2
Pix(x, y) = Pix(x, y - 1)
Case 3
Pix(x, y) = Pix(x - 1, y - 1)
End Select
Next x
Next y
NewColorCount = n
ReDim Preserve NewColors(NewColorCount - 1)
PSelByteCount = Ceil(Width * Height / 4)
ReDim PackedSelectors(PSelByteCount - 1)
n = 0
For y = 0 To Height - 1
For x = 0 To Width - 1
PackedSelectors(n \ 4) = PackedSelectors(n \ 4) + Selectors(x, y) * 4 ^ (n And 3)
n = n + 1
Next x
Next y
Open OutputFileName For Output As #1
Close #1
Open OutputFileName For Binary As #1
Put #1, 1, Width
Put #1, , Height
Put #1, , PSelByteCount
Put #1, , NewColorCount
Put #1, , PackedSelectors()
Put #1, , NewColors()
Close #1
End Sub
Public Sub DecompressImage(ByVal InputFilename As String, ByRef Width As Long, ByRef Height As Long, ByRef PixOut() As Long)
Dim PackedSelectors() As Byte
Dim PSelByteCount As Long
Dim Pix() As Long
Dim NewColors() As Long
Dim x As Long
Dim y As Long
Dim n As Long
Dim n2 As Long
Dim NewColorCount As Long
Open InputFilename For Binary Access Read As #1
Get #1, 1, Width
Get #1, , Height
Get #1, , PSelByteCount
Get #1, , NewColorCount
ReDim PackedSelectors(PSelByteCount - 1)
ReDim NewColors(NewColorCount)
Get #1, , PackedSelectors()
Get #1, , NewColors()
Close #1
ReDim PixOut(Width - 1, Height - 1)
For y = 0 To Height - 1
For x = 0 To Width - 1
Select Case (PackedSelectors(n \ 4) \ (4 ^ (n And 3))) And 3
Case 0
PixOut(x, y) = NewColors(n2)
n2 = n2 + 1
Case 1
PixOut(x, y) = PixOut(x - 1, y)
Case 2
PixOut(x, y) = PixOut(x, y - 1)
Case 3
PixOut(x, y) = PixOut(x - 1, y - 1)
End Select
n = n + 1
Next x
Next y
End Sub
Private Function GetSelector(ByVal PixCurrent As Long, ByVal PixLeft As Long, ByVal PixUp As Long, ByVal PixUpLeft As Long, ByVal Threshold As Long) As Byte
Dim MinDiff As Long
Dim DiffLeft As Long
Dim DiffUp As Long
Dim DiffUpLeft As Long
DiffLeft = GetPixDiff(PixCurrent, PixLeft)
DiffUp = GetPixDiff(PixCurrent, PixUp)
DiffUpLeft = GetPixDiff(PixCurrent, PixUpLeft)
MinDiff = 255 * 3
If DiffLeft < MinDiff Then MinDiff = DiffLeft
If DiffUp < MinDiff Then MinDiff = DiffUp
If DiffUpLeft < MinDiff Then MinDiff = DiffUpLeft
Select Case MinDiff
Case Is > Threshold
'do nothing
Case Is = DiffLeft
GetSelector = 1
Case Is = DiffUp
GetSelector = 2
Case Is = DiffUpLeft
GetSelector = 3
End Select
End Function
Private Function GetPixDiff(ByVal Pix1 As Long, ByVal Pix2 As Long) As Long
Dim R1 As Long
Dim G1 As Long
Dim B1 As Long
Dim R2 As Long
Dim G2 As Long
Dim B2 As Long
R1 = (Pix1 \ &H1) And &HFF
G1 = (Pix1 \ &H100) And &HFF
B1 = (Pix1 \ &H10000) And &HFF
R2 = (Pix2 \ &H1) And &HFF
G2 = (Pix2 \ &H100) And &HFF
B2 = (Pix2 \ &H10000) And &HFF
GetPixDiff = Abs(R1 - R2) + Abs(G1 - G2) + Abs(B1 - B2)
End Function
Private Function Ceil(ByVal Value As Double) As Long
Ceil = -Int(-Value)
End Function