Range to PIC (bmp, jpg)

There are quite a few procedures out there dealing with how to load a graphical file inside Excel, getting it shown as cells colored. But it’s a bit harder to find the inverse procedure. I’ve managed to retrieve the PIC file from the colored cells. The file generated can be either BMP either JPG, via vba pure code. I’ve to give credit to Korejwa from PlanetSourceCode for his fantastic code to get JPG codification. Also PNG, GIF or TIFF can be achieved directly if converted through a Picture control, but the interesting part is the BMP and the JPG code. ToDo:

• BMP block for reducing size of canvas (need a bicubic interpolation function). JPG implementation in VBA from BMP data.
• For the BMP file:

Option Explicit

Private Type typHEADER
    strType As String * 2  ' Signature of file = "BM"
    lngSize As Long        ' File size
    intRes1 As Integer     ' reserved = 0
    intRes2 As Integer     ' reserved = 0
    lngOffset As Long      ' offset to the bitmap data (bits)
End Type

Private Type typINFOHEADER
    lngSize As Long        ' Size of InfoHeader
    lngWidth As Long       ' Height
    lngHeight As Long      ' Length
    intPlanes As Integer   ' Number of image planes in file
    intBits As Integer     ' Number of bits per pixel
    lngCompression As Long ' Compression type (set to zero)
    lngImageSize As Long   ' Image size (bytes, set to zero)
    lngxResolution As Long ' Device resolution (set to zero)
    lngyResolution As Long ' Device resolution (set to zero)
    lngColorCount As Long  ' Number of colors (set to zero for 24 bits)
    lngImportantColors As Long ' "Important" colors (set to zero)
End Type

Private Type typBITMAPFILE
    bmfh As typHEADER
    bmfi As typINFOHEADER
    bmbits() As Byte
End Type

Public Sub sExcelToBMP()
    fExcelToBMP "C:\Test.BMP"
End Sub

Private Function fExcelToBMP(ByVal strFullPathFile_BMP As String)
    Dim iFileOut As Integer
    Dim bmpFile As typBITMAPFILE
    Dim lngRowSize As Long
    Dim lngPixelArraySize As Long
    Dim lngFileSize As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim x As Long
    Dim bytRed As Byte, bytGreen As Byte, bytBlue As Byte
    Dim lgColor As Long
    'Dim lngRGBColor() As Long
    Dim lgPixH As Long
    Dim lgPixV As Long
    Dim lgBlockH As Long
    Dim lgBlockV As Long

    ' Get canvas min-max
    Dim rgCanvas As Excel.Range
    Dim rgCell As Excel.Range
    Dim lgRowStart As Long
    Dim lgRowEnd As Long
    Dim lgColStart As Long
    Dim lgColEnd As Long

    Set rgCanvas = Application.InputBox(Prompt:="Select range to capture", Title:="Select range", Default:=Selection.Address(True, True), Type:=8)

    With rgCanvas
        lgBlockV = 1
        lgBlockH = 1

        lgPixH = .Columns.Count
        lgPixV = .Rows.Count
        lgRowStart = .Row
        lgRowEnd = lgRowStart + lgPixV - 1
        lgColStart = .Column
        lgColEnd = lgColStart + lgPixH - 1
    End With

    With bmpFile
        With .bmfh
            .strType = "BM"
            .lngSize = 0
            .intRes1 = 0
            .intRes2 = 0
            .lngOffset = 54
        End With

        With .bmfi
            .lngSize = 40 '= len(.bmfi)
            .lngWidth = lgPixH
            .lngHeight = lgPixV
            .intPlanes = 1
            .intBits = 24
            .lngCompression = 0
            .lngImageSize = 0
            .lngxResolution = 0
            .lngyResolution = 0
            .lngColorCount = 0
            .lngImportantColors = 0
        End With
        'lngRowSize = Round(.bmfi.intBits * .bmfi.lngWidth / 32) * 4
        lngRowSize = WorksheetFunction.Ceiling(.bmfi.intBits * .bmfi.lngWidth / 32, 0.5) * 4
        lngPixelArraySize = lngRowSize * .bmfi.lngHeight

        ReDim .bmbits(lngPixelArraySize)
        ReDim lngRGBColor(1 To lgPixV, 1 To lgPixH)

        k = -1
        For j = lgPixV To 1 Step -lgBlockV
        ' For each row, starting at the bottom and working up...
            'each column starting at the left
            For x = 1 To lgPixH Step lgBlockH
                '!!!!!!!!!!!!!!!!
                ' ToDo:
                ' Blend color...
                ' when block size is not 1x1 pixels
                '!!!!!!!!!!!!!!!!

                Set rgCell = rgCanvas.Cells(j, x)
                lgColor = rgCanvas.Cells(j, x).Interior.Color
                bytRed = (lgColor And &HFF)
                bytGreen = (lgColor \ &H100 And &HFF)
                bytBlue = (lgColor \ &H10000 And &HFF)

                'Store color
                k = k + 1
                .bmbits(k) = bytBlue
                k = k + 1
                .bmbits(k) = bytGreen
                k = k + 1
                .bmbits(k) = bytRed
            Next x

            If (lgPixH * .bmfi.intBits / 8 < lngRowSize) Then   ' Add padding if required
                For l = lgPixH * .bmfi.intBits / 8 + 1 To lngRowSize
                    k = k + 1
                    .bmbits(k) = 0
                Next l
            End If
        Next j

        .bmfh.lngSize = Len(.bmfh) + Len(.bmfi) + lngPixelArraySize

        ' Output bmpFile
        iFileOut = VBA.FreeFile()
        Open strFullPathFile_BMP For Binary Access Write As #iFileOut Len = 1
            Put #iFileOut, 1, .bmfh
            Put #iFileOut, , .bmfi
            Put #iFileOut, , .bmbits
        Close #iFileOut

        ' Free memory
        Erase .bmbits()
     End With
End Function

---

For JPG, we need two Classes (cJpeg and cImage), one Module and three UserForms, I did not yet get it to work, as it was originally programmed for VB6, but code compiles Ok in the following Excel, near 10 lines left to port to VBA (marked as ‘!). I have coded inside a BMP file just to be able to upload to WordPress. Code to cypher/decypher follows: