The routine then calls subroutine CompressPixels to compress the pixel data and store it in the byte array. Note that this is lossless compression so the compressed data will generally take up more space than a lossy scheme such as JPEG. The subroutine then uses AppendChunk again to save the compressed data.

Subroutine CompressPixels copys the three-dimensional pixel byte data into a one-dimensional byte array. It then uses the Zlib function compress to compress the data. It resizes the compressed array to remove any unused space and returns the result.

Using the Zlib function compress2 allows the program to pick a specific compression level. The compress function uses a default level of 6. Raising the level to 9 may produce some improvement although it may also greatly increase time.

' Save the picture into the database as a DIB.
Private Sub SaveDibToDb(rs As ADODB.Recordset)
Dim bytes_per_scanLine As Integer
Dim wid As Long
Dim hgt As Long
Dim bitmap_info As BITMAPINFO
Dim pixels() As Byte
Dim buffer() As Byte

    ' Prepare the bitmap description.
    wid = picPerson.ScaleWidth
    hgt = picPerson.ScaleHeight
    With bitmap_info.bmiHeader
        .biSize = 40
        .biWidth = wid
        ' Use negative height to scan top-down.
        .biHeight = -hgt
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
            31) \ 32) * 4)
        .biSizeImage = bytes_per_scanLine * hgt
    End With

    ' Load the bitmap's data.
    ReDim pixels(1 To 4, 1 To wid, 1 To hgt)
    GetDIBits picPerson.hdc, picPerson.Image, _
        0, hgt, pixels(1, 1, 1), _
        bitmap_info, DIB_RGB_COLORS

    ' Save the BITMAPINFO.
    ReDim buffer(0 To Len(bitmap_info.bmiHeader) - 1)
    CopyMemory buffer(0), bitmap_info.bmiHeader, _
        Len(bitmap_info.bmiHeader)
    rs!Picture.AppendChunk buffer

    ' Save the pixels.
    buffer = CompressPixels(pixels)
    rs!Picture.AppendChunk buffer
End Sub

' Compress the pixel array into an array of bytes.
Private Function CompressPixels(pixels() As Byte) As Byte()
Dim wid As Integer
Dim hgt As Integer
Dim uncompressed_size As Long
Dim uncompressed_bytes() As Byte
Dim compressed_size As Long
Dim compressed_bytes() As Byte

    ' Copy the pixels into a one-dimensional byte array.
    wid = UBound(pixels, 2)
    hgt = UBound(pixels, 3)
    uncompressed_size = 4& * wid * hgt
    ReDim uncompressed_bytes(0 To uncompressed_size - 1)
    CopyMemory uncompressed_bytes(0), pixels(1, 1, 1), _
        uncompressed_size

    ' Compress.
    ' Allocate the smallest allowed compression
    ' buffer (1% larger than the uncompressed data
    ' plus 12 bytes).
    compressed_size = 1.01 * uncompressed_size + 12
    ReDim compressed_bytes(0 To compressed_size - 1)

    ' Compress the bytes.
    Select Case compress( _
            compressed_bytes(0), compressed_size, _
            uncompressed_bytes(0), uncompressed_size)
        Case Z_MEM_ERROR
            MsgBox "Insufficient memory", vbExclamation, _
                "Compression Error"
            Exit Function
        Case Z_BUF_ERROR
            MsgBox "Buffer too small", vbExclamation, _
                "Compression Error"
            Exit Function
        ' Else Z_OK.
    End Select

    ' Shrink the compressed buffer to fit.
    ReDim Preserve compressed_bytes(0 To compressed_size - _
        1)

    ' Return the resulting bytes.
    CompressPixels = compressed_bytes

    ' Uncomment to see how much compression you get.
'    Debug.Print "Compressed: " & uncompressed_size & " -->
' "; compressed_size
End Function

The routine calls function UncompressPixels to expand the one-dimensional byte arrary of compressed pixel data into a three-dimensional pixel data array. Finally it uses SetDIBits to display the picture.

Function UncompressPixels takes as input a bitmap's dimensions and a one-dimensional array of compressed pixel data. It allocates room for the uncompressed data and calls the Zlib function uncompress to restore the data. It finishes by copying the data into a three-dimensional pixel array.

' Load the DIB from the database.
Private Sub LoadDibFromDb(rs As ADODB.Recordset)
Dim bytes_per_scanLine As Integer
Dim wid As Long
Dim hgt As Long
Dim bitmap_info As BITMAPINFO
Dim pixels() As Byte
Dim buffer() As Byte

    ' Get the BITMAPINFO.
    buffer = rs!Picture.GetChunk(Len(bitmap_info.bmiHeader))
    CopyMemory bitmap_info.bmiHeader, buffer(0), _
        Len(bitmap_info.bmiHeader)

    ' Get the compressed pixel data.
    wid = bitmap_info.bmiHeader.biWidth
    hgt = Abs(bitmap_info.bmiHeader.biHeight)
    buffer = rs!Picture.GetChunk(4 * wid * hgt)

    ' Uncompress the pixels.
    pixels = UncompressPixels(wid, hgt, buffer)

    ' Size the PictureBox.
    picPerson.Move picPerson.Left, picPerson.Top, wid, hgt

    ' Display the results.
    SetDIBits picPerson.hdc, picPerson.Image, _
        0, hgt, pixels(1, 1, 1), _
        bitmap_info, DIB_RGB_COLORS
    picPerson.Picture = picPerson.Image
End Sub

' Uncompress the bytes into a pixel array.
Private Function UncompressPixels(ByVal wid As Integer, _
    ByVal hgt As Integer, compressed_bytes() As Byte) As _
    Byte()
Dim compressed_size As Long
Dim uncompressed_size As Long
Dim uncompressed_bytes() As Byte
Dim pixels() As Byte

    ' Get the compressed size.
    compressed_size = UBound(compressed_bytes) - _
        LBound(compressed_bytes) + 1

    ' Uncompress.
    ' Allocate room for the uncompressed file.
    ' Note that this routine needs to know
    ' the original file's uncompressed size.
    uncompressed_size = 4& * wid * hgt
    ReDim uncompressed_bytes(0 To uncompressed_size - 1)

    ' Decompress the bytes.
    Select Case uncompress( _
            uncompressed_bytes(0), uncompressed_size, _
            compressed_bytes(0), compressed_size)
        Case Z_MEM_ERROR
            MsgBox "Insufficient memory", vbExclamation, _
                "Compression Error"
            Exit Function
        Case Z_BUF_ERROR
            MsgBox "Buffer too small", vbExclamation, _
                "Compression Error"
            Exit Function
        Case Z_DATA_ERROR
            MsgBox "Input file corrupted", vbExclamation, _
                "Compression Error"
            Exit Function
        ' Else Z_OK.
    End Select

    ' Copy the bytes into a pixel array.
    ReDim pixels(1 To 4, 1 To wid, 1 To hgt)
    CopyMemory pixels(1, 1, 1), uncompressed_bytes(0), _
        uncompressed_size

    ' Return the resulting pixels.
    UncompressPixels = pixels
End Function