Font 2 PNG’s source code

Here’s the source code of my poor man’s Font 2 PNG.

Version: 0.561
License: Public Domain
Programming language: BlitzMax

Download BlitzMax from the link above, if you don’t already have it. You need also BAH.Volumes. I will later add link here to it, if I can still find it… Try googling it.

Source code:

' Poor Man's Font 2 PNG
' License: Public Domain
' version 0.561

Strict


Import MaxGui.Drivers
Import MaxGUI.XPManifest
Import BAH.Volumes

?win32
Extern "win32"
	Function ExtractIconA%(hWnd%,File$z,Index%)
	Function GetActiveWindow%()
	Function SendMessage:Int(hWnd:Int,MSG:Int,wParam:Int,lParam:Int) = "SendMessageA@16"
End Extern
?

AppTitle$ = "Font 2 PNG"

'Const MENU_LOAD:Int = 101
'Const MENU_SAVE:Int = 102
Const MENU_ADDGAP:Int = 201
Const MENU_MANUAL:Int = 301
Const MENU_ABOUT:Int = 302

Global window:TGadget = CreateWindow("Font 2 PNG v0.561 - Freeware",0,0,738,542,Null,WINDOW_TITLEBAR|WINDOW_MENU|WINDOW_CENTER)
Global panel1:TGadget = CreatePanel(10,4,352,325,window,PANEL_GROUP,"")
Global panel2:TGadget = CreatePanel(370,4,352,325,window,PANEL_GROUP,"")

Global btnOpenFont:TGadget = CreateButton("Read System Fonts Dir",7,3,190,23,panel2)
Global btnOpenFile:TGadget = CreateButton("Open font file",216+9,3,110,23,panel2)
Global btnConvert:TGadget = CreateButton("Convert!",314,450,90,30,window)
Global btnOk:TGadget = CreateButton("Ok",455 - 325,3,30,23,panel1,BUTTON_OK)
Global btnColor:TGadget = CreateButton("Text Color",500 - 320 + 5,3,75,23,panel1)
Global btnBGColor:TGadget = CreateButton("BG Color",600 - 339 + 5,3,70,23,panel1)
Global txtSize:TGadget = CreateTextField(422 - 370 + 5,3,36,23,panel1)
Global stepper:TGadget = CreateSlider(455 - 360,3,24,24,panel1,SLIDER_STEPPER)

Global lblSize:TGadget = CreateLabel("Font size",8,5,60,23,panel1)

'Global filemenu:TGadget = CreateMenu("&File",0,WindowMenu(window))
'CreateMenu "Load bitmap font",MENU_LOAD,filemenu
'CreateMenu "Save bitmap font",MENU_SAVE,filemenu

'Global optionsmenu:TGadget = CreateMenu("&Options",1,WindowMenu(window))
'CreateMenu "Add gap",MENU_ADDGAP,optionsmenu

Global helpmenu:TGadget = CreateMenu("&Help",2,WindowMenu(window))
CreateMenu "Info about usage (website)",MENU_MANUAL,helpmenu
CreateMenu "&About",MENU_ABOUT,helpmenu

UpdateWindowMenu window

Global font:TGuiFont
Global fontImg:TImageFont, fontImgSmooth:TImageFont

Global characters:String, fontDir:String
Global file:String
Global text:String
Global fontList:TGadget = CreateListBox(8,37,328,256,panel2,0)
Global selectedFont:String = ""

Global fntR:Int = 255,fntG:Int = 255,fntB:Int = 0, bgR:Int, bgG:Int, bgB:Int
Global fntSize:Int


Global newFontCanvas:TGadget
Global fontHeight:Int, maxCharWidth:Int

Global dir:Int, f:String
Global globalIndex:Int

Global fontDat:Int[]

newFontCanvas = CreateCanvas(8,37,328,256,panel1,0)				

For Local c:Int = 32 To 128
	characters = characters + Chr$(c)
Next

Global btnSaveBG:TGadget = CreateButton("Save background color",10,332,160,27,window,BUTTON_CHECKBOX)
SetGadgetToolTip btnSaveBG,"If unchecked, the font won't be antialised with background color"
Global saveBGcolor:Int

Global btnFixedWidth:TGadget = CreateButton("Fixed width",430,332,80,27,window,BUTTON_CHECKBOX)
SetGadgetToolTip btnFixedWidth, "If checked, the width of a character of the font will be the width of the widest character"
Global fixedWidth:Int

Global btnIndividualChrs:TGadget = CreateButton("Save each character as individual png-file",170,332,250,27,window,BUTTON_CHECKBOX)
SetGadgetToolTip btnIndividualChrs, "If checked saves each character as individual png-file: chr0.png, chr1.png..."

Global btnGap:TGadget = CreateButton("Gap: ",625,332,45,27,window,BUTTON_CHECKBOX)
SetGadgetToolTip btnGap, "Extra gap between characters"

Global txtGap:TGadget = CreateTextField(673,334,36,23,window)
SetGadgetToolTip(txtGap,"Integer value for a gap as pixels")
SetGadgetSensitivity(txtGap, EVENT_KEYUP)

Global btnCenter:TGadget = CreateButton("Center",560,332,60,27,window,BUTTON_CHECKBOX)
SetGadgetToolTip(btnCenter,"If gap is an even number, the character will be placed at the center of the space")
DisableGadget(btnCenter)

Global convertDone:Int
Global fontSelected:Int

SetButtonState(btnSaveBG,1)	' checkmark
SetButtonState(btnFixedWidth,0)

SetSliderRange(stepper,1,200)
SetSliderValue(stepper,32)

'Global lblCharacters:TGadget = CreateLabel(characters,70,365,618,34,window)
'Global btnCharacters:TGadget = CreateButton(characters,60,365,200,27,window,BUTTON_CHECKBOX)
Global chrPanel:TGadget = CreatePanel(10,360,700,80,window,PANEL_GROUP,"Characters")
Global btnCharacters:TGadget = CreateButton(characters,34,4,620,27,chrPanel,BUTTON_RADIO)
Global btnAllASCII:TGadget = CreateButton("ASCII codes 0 - 255",34,30,580,27,chrPanel,BUTTON_RADIO)

ccSetIcon("icon.ico", GetActiveWindow())

fntR = 255
fntG = 255
fntB = 0

bgR = 0
bgG = 0
bgB = 0

fntSize = 32

saveBGcolor = 1
fixedWidth = -1

SetButtonState(btnCharacters,1)

SetGadgetText txtSize,fntSize


'SetMaskColor bgR,bgG,bgB
'SetClsColor bgR,bgG,bgB
text = ""
fontSelected = False

convertDone = False

Repeat

	WaitEvent()

	Select EventID()
			
		Case EVENT_MENUACTION
			Select EventData()
				Case MENU_MANUAL
					OpenURL("https://blue-bit-entertainment.com/font-2-png/")

				Case MENU_ABOUT
					Notify "Font 2 PNG v0.561"
			End Select

		Case EVENT_WINDOWCLOSE, EVENT_APPTERMINATE
			End			

		Case EVENT_KEYUP
			Local gap:Int
			gap = Int(GadgetText(txtGap))
			
			If gap Mod 2 = 0 Then EnableGadget(btnCenter) Else DisableGadget(btnCenter)
			
		Case EVENT_GADGETACTION

			Select EventSource()															
								
				Case stepper
					fntSize = SliderValue(stepper)
					SetGadgetText txtSize,fntSize

					If fntSize < 1 Then
						fntSize = 1
						SetGadgetText txtSize,fntSize
					EndIf
					
					If fntSize > 200 Then
						fntSize = 200
						SetGadgetText txtSize,fntSize
					EndIf

					fontImg = LoadImageFont(file,fntSize)
					fontImgSmooth = LoadImageFont(file,fntSize,SMOOTHFONT)
					If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg
					
					RedrawGadget newFontCanvas
					
				Case btnOK

					fntSize = GadgetText(txtSize).ToInt()
					If fntSize < 1 Then
						fntSize = 1
						SetGadgetText txtSize,fntSize
					EndIf
					
					If fntSize > 200 Then
						fntSize = 200
						SetGadgetText txtSize,fntSize
					EndIf

					
					fontImg = LoadImageFont(file,fntSize)
					fontImgSmooth = LoadImageFont(file,fntSize,SMOOTHFONT)
					If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg
					
					RedrawGadget newFontCanvas

				Case btnSaveBG
					saveBGcolor = -saveBGcolor

				Case btnFixedWidth
					fixedWidth = -fixedWidth
					
				Case btnBGColor
					RequestColor(bgR,bgG,bgB)
					bgR = RequestedRed()
					bgG = RequestedGreen()
					bgB = RequestedBlue()
					SetMaskColor bgR,bgG,bgB
					RedrawGadget newFontCanvas
					
				Case btnColor
					RequestColor(fntR,fntG,fntB)
					fntR = RequestedRed()
					fntG = RequestedGreen()
					fntB = RequestedBlue()
					RedrawGadget newFontCanvas
					
				Case txtSize
										
					fontImg = LoadImageFont(file$,fntSize)
					fontImgSmooth = LoadImageFont(file$,fntSize,SMOOTHFONT)

					If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg
					
					RedrawGadget newFontCanvas
					
				Case btnOpenFont

					dir=ReadDir(GetCustomDir(CSIDL_FONTS))

					If dir Then

						Repeat
							f=NextFile( dir )
							If f="" Exit
							If f="." Or f=".." Continue
							AddGadgetItem fontList, f$, False, -1, ""
						Forever

						CloseDir dir
						If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg
						
						RedrawGadget newFontCanvas
						convertDone = False
				Else
					Notify "Failed to read system fonts directory!"
				EndIf
										
				Case btnOpenFile
				
					file = RequestFile("")
					
					fontImgSmooth = LoadImageFont(file,fntSize,SMOOTHFONT)
					fontImg = LoadImageFont(file,fntSize)
					
					f$ = RealPath(file)					
					
					AddGadgetItem fontList, "* "+f$, False, -1, ""

					If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg

					RedrawGadget newFontCanvas
					
				Case btnConvert
					If fontSelected = False Then
						Notify "Please select font first!"
					Else
						RedrawGadget newFontCanvas
						convert()
					EndIf
		End Select
		
		Case EVENT_GADGETPAINT
		
			Select EventSource()
				Case newFontCanvas
					
					SetGraphics(CanvasGraphics(newFontCanvas))
					
					SetColor bgR,bgG,bgB
					DrawRect 0,0,328,256
					SetClsColor bgR,bgG,bgB
					SetColor fntR,fntG,fntB

					Flip
					
					If saveBGcolor = 1 Then
						SetMaskColor 0,0,0
						SetBlend ALPHABLEND
					Else
						SetMaskColor bgR,bgG,bgB
						SetBlend MASKBLEND
					EndIf
					
					If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg

					
					If convertDone = True Then
						SetImageFont Null
						DrawText "Ok.",0,0
						
						If ButtonState(btnIndividualChrs) = False Then
							
							DrawText "Max width: "+maxCharWidth,0,TextHeight("Ok.") + 2
							DrawText "Max height: "+fontHeight,0,TextHeight("Ok.") + TextHeight("Max width: ") + 4
							
						Else
							DrawText "Characters saved as individual png-files.",0,TextHeight("Ok.")
						EndIf
						
					Else
						If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg

						DrawText text,0,0
					EndIf

					Flip
					EndGraphics

			End Select
	
		Case EVENT_GADGETSELECT
			globalIndex = EventData()
		
			If globalIndex >-1 Then
			
				selectedFont = GadgetItemText(fontList,globalIndex)
				If selectedFont <> "" Then
					fontSelected = True
					text = "ABC"
			
			
					SetGraphics(CanvasGraphics(newFontCanvas))
			
					If Left$(selectedFont,1) <> "*" Then
						file = GetCustomDir(CSIDL_FONTS)+"\"+selectedFont
					    fontImg = LoadImageFont(file,fntSize)
						fontImgSmooth = LoadImageFont(file,fntSize,SMOOTHFONT)

					Else
						fontImgSmooth = LoadImageFont(Right$(selectedFont,Len(selectedFont)-2),fntSize,SMOOTHFONT)
						fontImg = LoadImageFont(Right$(selectedFont,Len(selectedFont)-2),fntSize)

					EndIf
			
					If saveBGcolor = 1 Then SetImageFont fontImgSmooth Else SetImageFont fontImg
					convertDone = False
					RedrawGadget newFontCanvas
					EndGraphics				
				EndIf
			EndIf
			
	End Select
	
Forever

Function convert()
	Local charactersToConvert:String
	Local saveFontName:String
	Local outStream:TStream
	Local t:Int
	Local ch:String
	Local charWidth:Int, xpos:Int
	Local charEnd:Int
	Local chars:String = ""
	Local gap:Int
	Local gfxFontti:TImage
	
	If saveBGcolor = 1 Then
		SetBlend ALPHABLEND
		'SetMaskColor 1,255,1
	Else
		SetBlend MASKBLEND
	EndIf

	If ButtonState(btnGap) = True Then
		gap = Int(GadgetText(txtGap))
	Else
		gap = 0
	EndIf
	
	If ButtonState(btnCharacters) <> False Then charactersToConvert = characters

	If ButtonState(btnAllASCII) <> False Then
		charactersToConvert = ""
		For t = 0 To 255
			charactersToConvert = charactersToConvert + Chr$(t)
		Next
	EndIf

	charEnd = Len(charactersToConvert)

	If ButtonState(btnIndividualChrs) = False Then

		saveFontName = RequestFile("","Image Files:png;",True)
	
		If saveFontName = "" Then Return
	
		saveFontName = Left$(saveFontName,Instr(saveFontName,".")-1)
	
		If fixedWidth = -1 Then
			outStream:TStream = WriteStream(saveFontName+".dat")
			If Not outStream Then
				Notify "dat-file couldn't be written"
				Return
			EndIf
		EndIf
	
		fontHeight = TextHeight(characters)
					
		xpos = 0
	
	Else
		saveFontName = RequestDir("Select folder",CurrentDir())
		If saveFontName = "" Then Return
	EndIf
										
	Local destPixmap:TPixmap
	
	Local gfxFont:TImage[charEnd]
	
	If ButtonState(btnIndividualChrs) = False Then
	

		Select fixedWidth
		Case -1

			For t = 1 To charEnd
				ch = Mid$(charactersToConvert,t,1)
				If TextWidth(ch) + gap = gap Then chars = chars + " " Else chars = chars + Mid$(charactersToConvert,t,1)
			Next
					
			maxCharWidth = 0
			destPixmap = CreatePixmap(TextWidth(chars) + Len(charactersToConvert) * gap,TextHeight(chars),PF_RGBA8888,4)
 
			For t = 1 To charEnd
				'Cls
				SetColor bgR,bgG,bgB
				DrawRect 0,0,328,256
				
				SetColor fntR,fntG,fntB
				ch = Mid$(chars,t,1)
				charWidth = TextWidth(ch) + gap		
				If maxCharWidth < charWidth Then maxCharWidth = charWidth
	
				text = Mid$(chars,t,1)

				If ButtonState(btnCenter) = 1 And gap Mod 2 = 0 Then DrawText text,gap / 2, 0 Else DrawText text,0,0
				
				gfxFont[t-1] = CreateImage(charWidth,fontHeight)
				GrabImage gfxFont[t-1],0,0
						
				Flip

				Local sourcePixmap:TPixmap = LockImage(gfxFont[t-1])
				destpixmap.paste(sourcepixmap,xpos,0)
				UnlockImage(gfxFont[t-1])
						
				WriteInt (outStream,xpos)
				WriteInt (outStream,charWidth)

				xpos = xpos + charWidth
		
			Next

			CloseStream outStream
			
		Case 1
		
			For t = 1 To charEnd
				ch = Mid$(charactersToConvert,t,1)
				If TextWidth(ch) = 0 Then chars = chars + " " Else chars = chars + Mid$(charactersToConvert,t,1)
			Next

			maxCharWidth = 0
			' Determine the width of widest character
			For t = 1 To charEnd
				ch = Mid$(chars,t,1)
				charWidth = TextWidth(ch) + gap
				
				If charWidth > maxCharWidth Then maxCharWidth = charWidth
			Next
			
			destPixmap = CreatePixmap(charEnd*maxCharWidth,TextHeight(chars),PF_RGBA8888,4)			
			
			For t = 1 To charEnd
				'Cls
				SetColor bgR,bgG,bgB
				DrawRect 0,0,328,256
				SetColor fntR,fntG,fntB
				
				If charWidth > 0 Then
					text = Mid$(chars,t,1)
		
					If ButtonState(btnCenter) = 1 And gap Mod 2 = 0 Then DrawText text,gap / 2+ (maxCharWidth + gap - (TextWidth(text) + gap)) / 2 , 0 Else DrawText text,0,0


					gfxFont[t-1] = CreateImage(maxCharWidth,fontHeight)
					GrabImage gfxFont[t-1],0,0
				
				
					Flip

					Local sourcePixmap:TPixmap = LockImage(gfxFont[t-1])
					destpixmap.paste(sourcepixmap,xpos,0)
					UnlockImage(gfxFont[t-1])

					xpos = xpos + maxCharWidth
				EndIf
				
			Next

		End Select

	Else
		
		If fixedWidth = 1 Then
			For t = 1 To charEnd
				ch = Mid$(charactersToConvert,t,1)
				If TextWidth(ch) + gap  = gap Then chars = chars + " " Else chars = chars + Mid$(charactersToConvert,t,1)
			Next

			maxCharWidth = 0
			' Määritetään leveimmän merkin leveys
			For t = 1 To charEnd
				ch = Mid$(chars,t,1)
				charWidth = TextWidth(ch) + gap
				
				If charWidth > maxCharWidth Then maxCharWidth = charWidth
			Next

		EndIf
			
				For t = 1 To charEnd

					'Cls
					SetColor bgR,bgG,bgB
					DrawRect 0,0,328,256
					
					SetColor fntR,fntG,fntB
					ch = Mid$(charactersToConvert,t,1)

					If TextWidth(ch) = 0 Then
						ch = Chr$(32)									
					Else

						If fixedwidth = -1 Then
							If ButtonState(btnCenter) = 1 And gap Mod 2 = 0 Then DrawText ch,gap / 2, 0 Else DrawText ch,0,0
						Else
							If ButtonState(btnCenter) = 1 And gap Mod 2 = 0 Then DrawText ch,gap / 2 + (maxcharwidth - (TextWidth(ch)))/2, 0 Else DrawText ch,0,0
						EndIf
						
						
						If fixedWidth = -1 Then
							gfxFontti = CreateImage(TextWidth(ch)+gap,TextHeight(ch))
						Else
							gfxFontti = CreateImage(maxCharWidth+gap,TextHeight(ch))
						EndIf
						
						GrabImage gfxFontti,0,0
						
						Flip
	
						Local sourcePixmap:TPixmap = LockImage(gfxFontti)
					
						If fixedWidth = -1 Then
							destPixmap = CreatePixmap(TextWidth(ch)+gap,TextHeight(ch),PF_RGBA8888,4)		
						Else
							destPixmap = CreatePixmap(maxCharWidth+gap,TextHeight(ch),PF_RGBA8888,4)
						EndIf
						
						destpixmap.paste(sourcepixmap,0,0)
						UnlockImage(gfxFontti)
					
						SavePixmapPNG(destpixmap, savefontname+"\chr"+(t-1)+".png",9)
						'ResizePixmap(destPixmap,0,0)
					EndIf
					
				Next
		
	EndIf
	
	convertDone = True
	text = "ABC"
	
	DeselectGadgetItem (fontList,globalIndex)
	fontSelected = False

	' Jos työskentelee Monkey X:llä, niin funktio palauttaa True, vaikka fonttia ei kirjoiteta
	If ButtonState(btnIndividualChrs) = False Then
		If SavePixmapPNG (destPixmap,saveFontName+".png",9) = False Then Notify "Font couldn't be written!"
	EndIf
	
	RedrawGadget newFontCanvas
	
EndFunction

Function loadFont()
		' vielä luettava itse grafiikka
		
		Local filename:String = RequestFile("","Image files:png;",False)
		Local datfilename:String
		Local fdat:TStream
		Local size:Int = 0
		
		If filename <> "" Then
			datfilename = Replace(filename, ".png", ".dat")
		EndIf
		
		fdat = ReadFile(datfilename)
		
		If Not fdat Then
			Notify (".dat-file for the bitmap font not found!")
			Return
		EndIf
		
		While Not Eof(fdat)
			size = size + 1
			fontdat[size] = ReadInt(fdat)
			fontdat = fontdat[..size]
			size = size + 1
			fontdat = fontdat[..size]
			fontdat[size] = ReadInt(fdat)
		Wend
		
		CloseFile fdat
		
EndFunction

Function ccSetIcon(iconname$, TheWindow%)	
	?Win32
	Local icon=ExtractIconA(TheWindow,iconname,0)
	Local WM_SETICON = $80
	Local ICON_SMALL = 0
	Local ICON_BIG = 1
'	sendmessage(TheWindow, WM_SETICON, ICON_SMALL, icon) 'don't need this
	sendmessage(TheWindow, WM_SETICON, ICON_BIG, icon)
'	SetClassLongA(TheWindow,-14,icon)'obsolete as it doesn't work with Windows XP Theme!
	?
End Function
Function SetIcon(iconname$, TheWindow%)	
	?Win32
	Local icon=ExtractIconA(TheWindow,iconname,0)
	Local WM_SETICON = $80
	Local ICON_SMALL = 0
	Local ICON_BIG = 1
	sendmessage(TheWindow, WM_SETICON, ICON_BIG, icon)
	?
End Function

This seems to work somehow.. It seems that I haven’t commented the source almost at all…

%d bloggers like this: