VBScript version of Figlet

Any chance someone can help me with getting this to work properly on webpage? the first line appears fine, but all other lines of the figlet font appears shifted to the left. below is my code:

<%
Option Explicit
Const ForReading = 1

Dim strSignature
Dim strHardBlank
Dim intHeight
Dim intBaseline
Dim intMaxLen
Dim intOldLayout
Dim intCommentLines
Dim intPrintDirection
Dim intFullLayout
Dim intCodeTagCount
Dim fontData()

Sub LoadFont(fontFile)
    Dim fso
    Dim hFile
    Dim cntr
    Dim arrTmp
    Dim strTmp
    Dim uBnd

    Set fso = Server.CreateObject("Scripting.FileSystemObject")
    Set hFile = fso.OpenTextFile(Server.MapPath(fontFile), ForReading, False)
    cntr = 0
    ReDim fontData(4096)
    Do While Not hFile.AtEndOfStream
        fontData(cntr) = hFile.ReadLine
        cntr = cntr + 1
        If (cntr = UBound(fontData)) Then ReDim Preserve fontData(cntr + 100)
    Loop
    ReDim Preserve fontData(cntr)

    arrTmp = Split(fontData(0), " ", -1)
    uBnd = UBound(arrTmp)
    strTmp = arrTmp(0)
    strSignature = Left(strTmp, Len(strTmp) - 1)
    strHardBlank = Right(strTmp, 1)
    intHeight = CInt(arrTmp(1))
    intBaseline = CInt(arrTmp(2))
    intMaxLen = CInt(arrTmp(3))
    intOldLayout = CInt(arrTmp(4))
    intCommentLines = CInt(arrTmp(5))
    If (uBnd > 5) Then intPrintDirection = CInt(arrTmp(6))
    If (uBnd > 6) Then intFullLayout = CInt(arrTmp(7))
    If (uBnd > 7) Then intCodeTagCount = CInt(arrTmp(8))
    Erase arrTmp
    If (strSignature <> "flf2a") Then
        Err.Raise vbObjectError + 1000, "LoadFont", "Font " & fontFile & " is not a Figlet font!"
    End If
End Sub

Function GetCharacter(char, intLine)
        Dim intAscii
        Dim intStart
        Dim strTmp
        
        intAscii= Asc(char)
        intStart = intCommentLines + ((intAscii - 32) * intHeight)
        strTmp = fontData(intStart + intLine)
        strTmp = Replace(strTmp, "@", "")
        strTmp = Replace(strTmp, strHardBlank, " ")
        GetCharacter = strTmp
End Function


Sub Display(strText, strFont)
    Dim idx
    Dim cntr
    Dim char
    Dim output

    output = "<div style='font-family: consolas, monospace; font-size: 10px; line-height: 1.5;'><br>"
    LoadFont(strFont)

    For cntr = 1 To intHeight
        output =  output '& "<span style='letter-spacing: 7px;'>" ' Add a span for letter spacing
        For idx = 1 To Len(strText)
            char = Mid(strText, idx, 1)
            output = output & GetCharacter(char, cntr) & " " ' Use   for non-breaking spaces
        Next
        output = output & "</span><br>" ' Close the span
    Next

    output = output & "</div>"
    Response.Write output
End Sub

Dim strText
Dim strFont

strText = "tony"
strFont = "alligator"

Response.Write "Text: " & strText & "<br>"
Response.Write "Font: " & strFont & "<br>"

If strText <> "" And strFont <> "" Then
	Display strText, "fonts\" & strFont & ".flf"
Else
    Response.Write "Please provide both text and font."
End If
%>

Hey, does anyone have a port to VB6?

i got as far as, the following, but the output format doesn't look the same as expected.

what was expected:

                      000000000                         1111111
                    00:::::::::00                      1::::::1
                  00:::::::::::::00                   1:::::::1
                 0:::::::000:::::::0                  111:::::1
    ssssssssss   0::::::0   0::::::0uuuuuu    uuuuuu     1::::1
  ss::::::::::s  0:::::0     0:::::0u::::u    u::::u     1::::1
ss:::::::::::::s 0:::::0     0:::::0u::::u    u::::u     1::::1
s::::::ssss:::::s0:::::0 000 0:::::0u::::u    u::::u     1::::l
 s:::::s  ssssss 0:::::0 000 0:::::0u::::u    u::::u     1::::l
   s::::::s      0:::::0     0:::::0u::::u    u::::u     1::::l
      s::::::s   0:::::0     0:::::0u::::u    u::::u     1::::l
ssssss   s:::::s 0::::::0   0::::::0u:::::uuuu:::::u     1::::l
s:::::ssss::::::s0:::::::000:::::::0u:::::::::::::::uu111::::::111
s::::::::::::::s  00:::::::::::::00  u:::::::::::::::u1::::::::::1
 s:::::::::::ss     00:::::::::00     uu::::::::uu:::u1::::::::::1
  sssssssssss         000000000         uuuuuuuu  uuuu111111111111

however, it looks like:

000000000                         1111111                       00:::::::::00                      1::::::1                     00:::::::::::::00                   1:::::::1                    0:::::::000:::::::0                  111:::::1       ssssssssss   0::::::0   0::::::0uuuuuu    uuuuuu     1::::1     ss::::::::::s  0:::::0     0:::::0u::::u    u::::u     1::::1   ss:::::::::::::s 0:::::0     0:::::0u::::u    u::::u     1::::1   s::::::ssss:::::s0:::::0 000 0:::::0u::::u    u::::u     1::::l    s:::::s  ssssss 0:::::0 000 0:::::0u::::u    u::::u     1::::l      s::::::s      0:::::0     0:::::0u::::u    u::::u     1::::l         s::::::s   0:::::0     0:::::0u::::u    u::::u     1::::l   ssssss   s:::::s 0::::::0   0::::::0u:::::uuuu:::::u     1::::l   s:::::ssss::::::s0:::::::000:::::::0u:::::::::::::::uu111::::::111s::::::::::::::s  00:::::::::::::00  u:::::::::::::::u1::::::::::1 s:::::::::::ss     00:::::::::00     uu::::::::uu:::u1::::::::::1  sssssssssss         000000000         uuuuuuuu  uuuu111111111111

here's my mod attempt to VB6:

'-------------------------------------------------------------------------------
' NAME   : Figlet.vbs
' AUTHOR : Prasad P. Khandekar
' DATE   : July 25, 2008
' VERSION: 1.0
' PURPOSE: Create ASCII art of supplied text.
'-------------------------------------------------------------------------------
'Option Explicit
Const ForReading = 1

'Class clsFiglet
    Dim strSignature
    Dim strHardBlank
    Dim intHeight
    Dim intBaseline
    Dim intMaxLen
    Dim intOldLayout
    Dim intCommentLines
    Dim intPrintDirection
    Dim intFullLayout
    Dim intCodeTagCount
    Dim fontData()

    Sub LoadFont(fontFile)
        Dim fso
        Dim hFile
        Dim cntr
        Dim arrTmp
        Dim strTmp
        Dim uBnd

        Set fso = CreateObject("Scripting.FileSystemObject")
        Set hFile = fso.OpenTextFile(fontFile, ForReading, False)
        cntr = 0
        ReDim fontData(4096)
        Do While Not hFile.AtEndOfStream
            fontData(cntr) = hFile.ReadLine
            cntr = cntr + 1
            If (cntr = UBound(fontData)) Then ReDim Preserve fontData(cntr + 100)
        Loop
        ReDim Preserve fontData(cntr)

        arrTmp = Split(fontData(0), " ", -1)
        uBnd = UBound(arrTmp)
        strTmp = arrTmp(0)
        strSignature = Left(strTmp, Len(strTmp) - 1)
        strHardBlank = Right(strTmp, 1)
        intHeight = CInt(arrTmp(1))
        intBaseline = CInt(arrTmp(2))
        intMaxLen = CInt(arrTmp(3))
        intOldLayout = CInt(arrTmp(4))
        intCommentLines = CInt(arrTmp(5))
        If (uBnd > 5) Then intPrintDirection = CInt(arrTmp(6))
        If (uBnd > 6) Then intFullLayout = CInt(arrTmp(7))
        If (uBnd > 7) Then intCodeTagCount = CInt(arrTmp(8))
        Erase arrTmp
        If (strSignature <> "flf2a") Then
            Err.Raise vbObjectError + 1000, "LoadFont", "Font " & fontFile & " is not a Figley font!"
        End If
    End Sub

    Function GetCharacter(char, intLine)
        Dim intAscii
        Dim intStart
        Dim strTmp
        
        intAscii = Asc(char)
        intStart = intCommentLines + ((intAscii - 32) * intHeight)
        strTmp = fontData(intStart + intLine)
        strTmp = Replace(strTmp, "@", "")
        strTmp = Replace(strTmp, strHardBlank, " ")
        GetCharacter = strTmp
    End Function

    Sub Display(strText, strFont)
        Dim idx
        Dim cntr
        Dim char

        Call LoadFont(strFont)
        For cntr = 1 To intHeight
            For idx = 1 To Len(strText)
                char = Mid(strText, idx, 1)
                Text1.Text = Text1.Text & GetCharacter(char, cntr)
            Next
'            Text1.Text =  vbCrLf
        Next
    End Sub
'End Class

Private Sub Command1_Click()
Dim objArgs, strText, strFont, gstrRootDir, gstrScript, objFiglet

'Set objArgs = WScript.Arguments
'If (objArgs.Length < 2) Then
    'ShowHelp()
    'WScript.Quit (1001)
'End If

strText = "s0u1"
strFont = "doh"
'gstrScript = WScript.ScriptName
'gstrRootDir = WScript.ScriptFullName
'gstrRootDir = Left(gstrRootDir, InStr(gstrRootDir, gstrScript) - 1)

'Set objFiglet = New clsFiglet
Call Display(strText, "C:\Users\s0u1\Downloads\FIGLET\fonts\" & strFont & ".flf")

End Sub

Kindly anyone assist and/or guide where I'm mistaking.

modified 27-Sep-20 11:33am.

You are missing some end of line characters.

Thanks Richard, I've modified the DISPLAY SUB to include the missing string;

    Sub Display(strText, strFont)
        Dim idx
        Dim cntr
        Dim char

        Call LoadFont(strFont)
        For cntr = 1 To intHeight
            For idx = 1 To Len(strText)
                char = Mid(strText, idx, 1)
                Text1.Text = Text1.Text & GetCharacter(char, cntr)
            Next
'Richard MacCutchan's suggestion
                Text1.Text = Text1.Text & vbCrLf
        Next
    End Sub

I've also changed my TEXTBOX font to CONSOLAS and the format looks identical to what I was expecting.

modified 4-Oct-20 23:38pm.

I did a port to VBA (Excel) - it produces one of each style in a seperate cell, using a monospaced font to keep the shape. I'll dig it out.

VB

Public Class Figlet

    '   _____   _           _          _   
    '  |  ___| (_)   __ _  | |   ___  | |_ 
    '  | |_    | |  / _` | | |  / _ \ | __|
    '  |  _|   | | | (_| | | | |  __/ | |_ 
    '  |_|     |_|  \__, | |_|  \___|  \__|
    '               |___/                  

    'Purpose:   draw banner text using Figlet font information
    'written:   cf 16.08.2014 (Charles Finn)
    'rights:    public domain, adapted from http://www.codeproject.com/KB/vbscript/FigletVBS/FIGLET.zip by Prasad Khandekar, 26 Nov 2008

    Private _HardBlank As String
    Private _Height As Integer
    Private _Baseline As Integer
    Private _MaxLen As Integer
    Private _OldLayout As Integer
    Private _CommentLines As Integer
    Private _PrintDirection As Integer
    Private _FullLayout As Integer
    Private _CodeTagCount As Integer
    Private _fontData() As String

    'Characters to insert ahead of line
    Private m_Prefix As String = String.Empty

    Public Sub New(ByVal FigletFontFilename As String)

        LoadFont(FigletFontFilename)

    End Sub

    Public Function Convert(ByVal theText As String) As String()
        'given string, return a set of lines

        Dim result = New List(Of String)

        For cntr As Integer = 1 To _Height
            Dim oneline = New System.Text.StringBuilder(200)
            oneline.Append(m_Prefix)

            For idx As Integer = 1 To theText.Length
                Dim oneChar As Char = CChar(Mid(theText, idx, 1))
                oneline.Append(GetCharacter(oneChar, cntr))
            Next

            result.Add(oneline.ToString)

        Next


        Return result.ToArray

    End Function


    Public Property Prefix() As String
        Get
            Return m_Prefix
        End Get
        Set(ByVal value As String)
            m_Prefix = value
        End Set
    End Property


    Private Sub LoadFont(ByVal fontFile As String)

        Using rdr As IO.StreamReader = New IO.StreamReader(fontFile)
            Dim lines = New List(Of String)

            Do While rdr.Peek <> -1
                lines.Add(rdr.ReadLine)
            Loop

            _fontData = lines.ToArray
        End Using


        Dim arrTmp As String() = Split(_fontData(0), " ", -1)
        Dim uBnd As Integer = UBound(arrTmp)

        Dim strTmp As String = arrTmp(0)
        Dim Signature As String = Left(strTmp, Len(strTmp) - 1)
        _HardBlank = Right(strTmp, 1)
        _Height = CInt(arrTmp(1))
        _Baseline = CInt(arrTmp(2))
        _MaxLen = CInt(arrTmp(3))
        _OldLayout = CInt(arrTmp(4))
        _CommentLines = CInt(arrTmp(5))


        If (uBnd > 5) Then _PrintDirection = CInt(arrTmp(6))
        If (uBnd > 6) Then _FullLayout = CInt(arrTmp(7))
        If (uBnd > 7) Then _CodeTagCount = CInt(arrTmp(8))

        If (Signature <> "flf2a") Then
            Err.Raise(vbObjectError + 1000, "LoadFont", "Font " & fontFile & " is not a Figley font!")
        End If

    End Sub

    Private Function GetCharacter(ByVal oneChar As Char, ByVal intLine As Integer) As String

        Dim ascii As Integer = Asc(oneChar)
        Dim start As Integer = _CommentLines + (ascii - 32) * _Height

        Dim temp As String = _fontData(start + intLine)
        temp = temp.Replace("@", "")
        temp = temp.Replace(_HardBlank, " ")

        Return temp

    End Function

End Class

Thank's a lot, Glad to know that you found it useful.

Regards,

Prasad P. Khandekar
Knowledge exists, man only discovers it.

The security team have disabled vbscript at my place of work, the only thing to do was to rewrite it in Powerhsell

C#

<#
'-------------------------------------------------------------------------------
' NAME   : Figlet.vbs
' AUTHOR : Prasad P. Khandekar
' DATE   : July 25, 2008
' VERSION: 1.0
' PURPOSE: Create ASCII art of supplied text.
'-------------------------------------------------------------------------------
Modified 30/11/2016 gpl conversion to powershell
#>
function figlet ([string]$strFont, [string]$strText) {

    Function GetCharacter($char, $intLine) {      
        $intAscii= [byte][char]$char
        $intStart = $intCommentLines + (($intAscii - 32) * $intHeight)
        $strTmp = (($fontData[($intStart + $intLine)]) -replace "@", "") -replace "$strHardBlank", " "
				$strTmp
	}

	$fontFile = "$($pwd)\fonts\$strFont.flf"

	$fontData=(get-content $fontFile) -split "`n"

	# add on a few extra elements to ensure zeroes will exist
	$arrTmp = ($fontData[0] -split " ") + @(0,0,0)
	$strSignature = $arrTmp[0] -replace ".$"
	If ($strSignature -ne "flf2a") {
		throw "Font $fontFile is not a Figlet font!"
	}
			
	$strHardBlank = ($arrTmp[0]).substring(($arrTmp[0]).length - 1, 1)  
	if ($strHardBlank -eq "$")	{$strHardBlank = "\$"}
	$intHeight = 			[int32]$arrTmp[1]   
	$intBaseLine = 			[int32]$arrTmp[2] 
	$intMaxLen = 			[int32]$arrTmp[3] 
	$intOldLayout = 		[int32]$arrTmp[4] 
	$intCommentLines = 		[int32]$arrTmp[5]
	$intPrintDirection = 	[int32]$arrTmp[6]
	$intFullLayout = 		[int32]$arrTmp[7]
	$intCodeTagCount = 		[int32]$arrTmp[8]
		
	Foreach ($cntr in 1..$intHeight) {
	$outstr=""
		Foreach ($Char in ([char[]]$strText)) {
			$outstr += (GetCharacter $char $cntr) 
		}
		$outstr
	}
}

Hi, I'm sure you must have spend lot of time on this. This is the first artical that I have seen to do Figlet with the text and the font name given.

Good work. Keep it up.

VBScript version of Figlet

Introduction

Background

Figlet Illustrations

DOOM

LARRY3D

Usage

Notes

Limitations

References

History

License

Comments and Discussions