excelvbaascii-art

VBA & Ascii Art


I'm trying to write a text formed with Ascii Art.
For example "Hi".
It's hard for me, so I'm here asking your help.
Here is what I'm do till now:


Option Explicit
' I tried with a Type.
Private Type LetterH
    H1 As String
    H2 As String
    H3 As String
    H4 As String
    H5 As String
    H6 As String
    H7 As String
End Type

Sub BuildAsciiWrite(strTxt As String)

Dim H As LetterH
    ' Fill the Type for H letter.
    H.H1 = "HHH    HHH"
    H.H2 = "HHH    HHH"
    H.H3 = "HHH    HHH"
    H.H4 = "HHHHHHHHHH"
    H.H5 = "HHH    HHH"
    H.H6 = "HHH    HHH"
    H.H7 = "HHH    HHH"

' Then I tried with Arrays:

Dim LtH(1 To 7) As String
    ' Fill the Array for H letter.
    LtH(1) = "HHH    HHH"
    LtH(2) = "HHH    HHH"
    LtH(3) = "HHH    HHH"
    LtH(4) = "HHHHHHHHHH"
    LtH(5) = "HHH    HHH"
    LtH(6) = "HHH    HHH"
    LtH(7) = "HHH    HHH"

Dim LtI(1 To 7) As String
    ' Fill the Array for I letter.
    LtI(1) = "IIIIIIIIIII"
    LtI(2) = "    III    "
    LtI(3) = "    III    "
    LtI(4) = "    III    "
    LtI(5) = "    III    "
    LtI(6) = "    III    "
    LtI(7) = "IIIIIIIIIII"

    ' All strTxt UPPERCASE.
    strTxt = UCase(strTxt)

' Array strArrayTxt contains strTxt one letter for one of the text.
Dim strArrayTxt() As String
    ' Redim Array for the lenght of strTxt.
    ReDim strArrayTxt(1 To Len(strTxt))
' Loop all letters of strTxt.
Dim intLoop1 As Integer
    For intLoop1 = 1 To Len(strTxt)
        ' Fill Array with letters of strTxt.
        strArrayTxt(intLoop1) = Mid$(strTxt, intLoop1, 1)
    ' Next letter.
    Next intLoop1
    ' Empty Var.
    intLoop1 = 0

' Var for the complete text we'll create.
Dim strWrite As String
' Another Array for all 26 letters of the alphabeth.
Dim Letters() As String
ReDim Letters(1 To 26)
    For intLoop1 = 1 To 26
        Letters(intLoop1) = Chr$(64 + intLoop1)
    Next intLoop1

' At this point I got:
' Type LetterH (an Array) with all the 7 strings that I can retrieve with H1, H2 and so on.
' Array LtH (1 To 7) with all the 7 strings building the "H" in Ascii.
' Array LtI (1 To 7) with all the 7 strings building the "I" in Ascii.
' Array strArrayTxt(1 To Len(strTxt)) with all the letters that form my choose word.
' Array Letters(1 To 26) with all the 26 letters of the alphabeth.

' Then I tried:
Dim intLoop2 as Integer    
    For intLoop2 = 1 To intLunghScritta
        For intLoop1 = 1 To 26
            If strArrayTesto(intLoop2) = Letters(intLoop1) Then
                ' This give me error.
                'strWrite = strArrayTesto(intLoop2).strArrayTesto(intLoop2) & intLoop1

                ' I can write in Immediate when find in Array Letters() the same letter find in
                ' Array strArrayTxt().
                Debug.Print strArrayTxt(intLoop2) & " = " & Letters(intLoop1)
            End If
        Next intLoop1
    Next intLoop2


End Sub
' Test SUB.
Sub Test_BuildAsciiWrite()
Dim strTxt As String
    strTxt = "Hi"
    BuildAsciiWrite (strTxt)
End Sub

I don't know how concatenate strings because if I start with first letter forming word "HI", I can find "H" in a For...Next loop, I can extract first letter, "H" but how can I say VBA go througt all Arrays and bring the so called LetterH ?
There's no way to obtain Array name with Letter & [letter find].


Solution

  • You can do this with a 2-dimensional array. One dimension is the letter, and one is the line (where a letter is made up of multiple lines like the above) For example:

    Sub BuildAsciiWrite(strInput As String)
    Dim Ascii(1 To 26, 1 To 7) As String
    
    'Filling this array will take a lot of code, only showing H and I for demo purposes
    'Ascii(8, x) is H, because H is the 8th letter
    Ascii(8, 1) = "HHH    HHH  "
    Ascii(8, 2) = "HHH    HHH  "
    Ascii(8, 3) = "HHH    HHH  "
    Ascii(8, 4) = "HHHHHHHHHH  "
    Ascii(8, 5) = "HHH    HHH  "
    Ascii(8, 6) = "HHH    HHH  "
    Ascii(8, 7) = "HHH    HHH  "
    
    'Ascii i, 9th letter
    Ascii(9, 1) = "IIIIIIIIIII  "
    Ascii(9, 2) = "    III      "
    Ascii(9, 3) = "    III      "
    Ascii(9, 4) = "    III      "
    Ascii(9, 5) = "    III      "
    Ascii(9, 6) = "    III      "
    Ascii(9, 7) = "IIIIIIIIIII  "
    
    'etc
    'notice I added some space to keep letters a bit separate visually
    
    'Now you need some loops to put together your output string
    Dim strOutput As String, charNum As Long
    For y = 1 To 7 'height
        For x = 1 To Len(strInput)
            'Getting the 1-26 number
            charNum = InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", UCase(Mid(strInput, x, 1)))
            'Alternatively you could use the Asc() function
                'and make your input array line up with ascii character codes
                'and so have both uppercase and lowercase, plus punctuation and things
                'depends how much effort you want to put into this ;)
            strOutput = strOutput & Ascii(charNum, y)
        Next
        strOutput = strOutput & Chr(13) 'new line
    Next 'Height
    
    Debug.Print strOutput
    End Sub
    
    Sub Test()
    Dim MyInput As String
    'MyInput = Inputbox("Input HI")
    MyInput = "HI"
    
    BuildAsciiWrite MyInput
    
    End Sub