Web Page of Characters
I was sitting around playing with an app I wrote a few days ago that builds a list of fonts. Was wondering if I could make a whole web page of characters based on a font. See example at Arial font.
Sub MakeFontWeb(FontFc As String, MaxChar As LongPtr, FtSize As Integer)
Dim TRw As String
Dim TD As String
Dim Qu As String
Dim TRc As String
Dim eTD As String
Dim eTR As String
Dim pPath As String
Dim Z As Integer
Dim J As Integer
Dim F As Integer
TD = " <td>"
eTD = "</td>"
eTR = "</tr>"
Close #1
Qu = Chr(34)
pPath = "C:\Users\" & Environ("UserName") & "\"
TRw = "<tr class=" & Qu & "whtrow" & Qu & ">"
TRc = "<tr class=" & Qu & "controw" & Qu & ">"
Open pPath & Trim(FontFc) & ".htm" For Output As #1
Print #1, "<html>"
Print #1, "<head>"
Print #1, "<style type=" & Qu & "text/css" & Qu & ">"
Print #1, " .controw"
Print #1, " {"
Print #1, " background-color: #ddffff;" 'a bunch of HTML related stuff
Print #1, " border-bottom-style: ridge;"
Print #1, " border-bottom-width: thick;"
Print #1, " vertical-align: top;"
Print #1, " text-align: center;"
Print #1, " font-family:'" & FontFc & "';"
Print #1, " }"
Print #1, " .whtrow"
Print #1, " {"
Print #1, " border-bottom-style: ridge;"
Print #1, " border-bottom-width: thick;"
Print #1, " text-align: center;"
Print #1, " vertical-align: top;"
Print #1, " font-family:'" & FontFc & "';"
Print #1, " }"
Print #1, "</style>"
Print #1, "<title>" & "Font: " & FontFc & "</title>"
Print #1, "</head>" & vbCrLf & "<body>"
Print #1, "<h1>" & "Font Sample: " & FontFc & "</h1>"
Print #1, "<table width=" & Qu & "100%" & Qu & " border=" & Qu & "1" & Qu & ">"
Z = 33
If MaxChar >= 30000 Then
MaxChar = InputBox("Your upper limit is producing errors with HTML, try to limit to under 10K", "Problems", 9999)
End If
For J = 1 To MaxChar
Select Case J Mod 2
Case 1
Print #1, TRc
For F = 1 To 25
Select Case Z
Case Is <= 255
Print #1, TD & Chr(Z) & eTD
Case Is > 255
Print #1, TD & "&#" & Z & ";" & eTD
End Select
Z = Z + 1
Next F
Print #1, eTR
Case 0
Print #1, TRw
For F = 1 To 25
Select Case Z
Case Is <= 255
Print #1, TD & Chr(Z) & eTD
Case Is > 255
Print #1, TD & "&#" & Z & ";" & eTD
End Select
Z = Z + 1
Next F
Print #1, eTR
End Select
If Z >= MaxChar Then GoTo Fin
Next J
Fin:
Print #1, "</table>"
Print #1, "Created: " & Application.Text(Now(), "dd MMM YYYY, HH:mm:ss")
Print #1, "</body>"
Print #1, "</html>"
Close #1
MsgBox "HMTL is at " & pPath & "MyDocuments\" & vbCrLf & FontFc
End Sub
It is a listtle useless but a nice exercise in what can be done.
|