Aside 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
