Excel ASCII Art

ASCII_artAside from loading an image on a picture object, any image (supported formats “*.bmp;*.jpg;*.jpeg;*.gif”) can be represented in cells, like in ASCII art or colouring cells interior.

For ASCII art, from 16M color (long) it should be reduced to 256 gray scale color, and finally converted to a 16 text scale (using in decreasing darkness the following characters: M # @ H X $ % + / ; : = – , .).

It would be better if used a four reduced scale with Unicode symbols (9617 9618 9619 and 160 for whitest)

Following code achieves both, colouring interior functionality is deactivated in code because it’s very sloooooow.

Option Explicit

Private Type tRGB
    R As Byte
    G As Byte
    B As Byte
End Type

Private Type OPENFILENAME
    lStructSize         As Long
    hwndOwner           As Long
    hInstance           As Long
    lpstrFilter         As Long
    lpstrCustomFilter   As Long
    nMaxCustFilter      As Long
    nFilterIndex        As Long
    lpstrFile           As Long
    nMaxFile            As Long
    lpstrFileTitle      As Long
    nMaxFileTitle       As Long
    lpstrInitialDir     As Long
    lpstrTitle          As Long
    flags               As Long
    nFileOffset         As Integer
    nFileExtension      As Integer
    lpstrDefExt         As Long
    lCustData           As Long
    lpfnHook            As Long
    lpTemplateName      As Long
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, _
                                                ByVal hBitmap As Long, _
                                                ByVal nStartScan As Long, _
                                                ByVal nNumScans As Long, _
                                                lpBits As Any, _
                                                lpBI As Any, _
                                                ByVal wUsage As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
                                                 ByVal hdc As Long) As Long

Public Sub RunAsciiArt2()

End Sub

Public Sub RunAsciiArt()
    Dim fileName As String
    Dim pic     As StdPicture
    Dim lgPos   As Long
    Dim bi()    As Long
    Dim pix()   As Long
    Dim hdc     As Long
    Dim ret()   As Byte
    Dim y       As Long
    Dim x       As Long
    Dim pal()   As Byte
    Dim Unipal()    As Integer
    Dim cRGB    As tRGB
    Dim bConversion As Long
    Dim lgColor     As Long
    Dim aOutput()   As Variant
    Dim rgOutput    As Excel.Range

    'On Error GoTo ERRLABEL

    fileName = GetFile()

    If VBA.Trim$(fileName)  vbNullString Then 'Better... if FileExists
        Set pic = LoadPicture(fileName)
        hdc = GetDC(Application.hwnd)

        ReDim bi(1063): bi(0) = 40
        GetDIBits hdc, pic.Handle, 0, 0, ByVal 0&, bi(0), 0

        ReDim pix(bi(1) - 1, Abs(bi(2)) - 1)

        If bi(2) > 0 Then bi(2) = -bi(2): bi(3) = &H200001: bi(4) = 0

        GetDIBits hdc, pic.Handle, 0, Abs(bi(2)), pix(0, 0), bi(0), 0
        ReleaseDC Application.hwnd, hdc

        ReDim ret((bi(1) + 2) * Abs(bi(2)) * 2)

        ReDim pal(15)
        pal(0) = &H4D:  pal(1) = &H23:  pal(2) = &H40:  pal(3) = &H48
        pal(4) = &H58:  pal(5) = &H24:  pal(6) = &H25:  pal(7) = &H2B
        pal(8) = &H2F:  pal(9) = &H3B:  pal(10) = &H3A: pal(11) = &H3D
        pal(12) = &H2D: pal(13) = &H2C: pal(14) = &H2E: pal(15) = &H20

        ReDim Unipal(3)
        Unipal(0) = 9617: Unipal(1) = 9618: Unipal(2) = 9619: Unipal(3) = 160

        With wsCanvas
            Set rgOutput = .Range(.Cells(1, 1), .Cells(UBound(pix, 2) + 1, UBound(pix, 1) + 1))
            ReDim aOutput(1 To rgOutput.Rows.Count, 1 To rgOutput.Columns.Count)
        End With

        With Application
            .ScreenUpdating = False
            .Calculation = xlCalculationManual
        End With

        For y = 0 To UBound(pix, 2)
            For x = 0 To UBound(pix, 1)
                'https://stackoverflow.com/questions/687261/converting-rgb-to-grayscale-intensity
                'https://en.wikipedia.org/wiki/Grayscale
                bConversion = (pix(x, y) And &HFF) * 0.2989 + _
                              (pix(x, y) \ &H100 And &HFF) * 0.587 + _
                              (pix(x, y) \ &H10000 And &HFF) * 0.114

                ret(lgPos) = pal(bConversion \ &H10)

                'ASCII art output:
                'aOutput(y + 1, x + 1) = VBA.Chr(ret(lgPos))            'For ASCII palette
                aOutput(y + 1, x + 1) = CharW(Unipal(bConversion \ 64)) 'For Block Unicode palette

                'Change from Pic BGR to RGB
                'lgColor = pix(x, y)
                'cRGB.R = lgColor And &HFF&
                'cRGB.G = (lgColor \ &H100&) And &HFF&
                'cRGB.B = lgColor \ &H10000
                'rgOutput(y + 1, x + 1).Interior.Color = VBA.RGB(cRGB.B, cRGB.G, cRGB.R)

                lgPos = lgPos + 2
            Next x

            ret(lgPos) = 13
            ret(lgPos + 2) = 10
            lgPos = lgPos + 4
        Next y

        'Open fileName & ".txt" For Binary As #1
        'Put #1, , ret
        'Close #1
        Erase ret()

        'ASCII art:
        rgOutput.Value2 = aOutput()

        With Application
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
        End With

        'Fit to selection
        With rgOutput
            .Columns.ColumnWidth = 1.43
            .Rows.RowHeight = 11.25
            .Select
            ActiveWindow.Zoom = True
        End With
    End If

    Exit Sub

ERRLABEL:
    MsgBox "Error", vbCritical
End Sub

Private Function GetFile() As String
    Dim ofn As OPENFILENAME
    Dim Out As String
    Dim i As Long

    ofn.nMaxFile = 260
    Out = String(260, vbNullChar)
    ofn.hwndOwner = Application.hwnd 'Application.hwnd
    ofn.lpstrTitle = StrPtr("Open image")
    ofn.lpstrFile = StrPtr(Out)
    ofn.lStructSize = Len(ofn)
    ofn.lpstrFilter = StrPtr("Supported image format" & vbNullChar & "*.bmp;*.jpg;*.jpeg;*.gif" & vbNullChar)
    If GetOpenFileName(ofn) Then
        i = InStr(1, Out, vbNullChar, vbBinaryCompare)
        If i Then GetFile = Left$(Out, i - 1)
    End If

End Function

Public Function CharW(ByVal dec As Long) As String
'https://en.wikipedia.org/wiki/Box-drawing_character
' Box drawings chars: https://www.unicode.org/charts/PDF/U2500.pdf --> from 9472 to 9599
' Blocks chars: https://www.unicode.org/charts/PDF/U2580.pdf       --> from 9600 to 9631
' https://www.vertex42.com/ExcelTips/unicode-symbols.html

    CharW = ChrW(dec)
End Function

 

Leave a Reply

Your email address will not be published. Required fields are marked *