Windows fonts in a MaxGUI Canvas

I wanted to be able to select a font to use in a multimedia application. Using MaxGUI, I can RequestFont()... and not be able to use the resulting font (because of the way Windows names and uses fonts).

So, I needed to write my own font request function:

Type WindowsFont
	Field name:String
	Field fullPath:String
	Field size:Int
End Type

Function RequestWindowsFont:WindowsFont(x:Int,y:Int,font:WindowsFont)
	Local win:TGadget
	Local btnOk:TGadget
	Local btnCancel:TGadget
	Local lstFontNames:TGadget
	Local lstFontSizes:TGadget
	Local tbFontSize:TGadget
	Local canSample:TGadget
	Local fontPath:String
	Local fontDirHandle:Int
	Local fileName:String
	Local quit:Int
	Local iFont:TImageFont
	Local i:Int
	Local winFont:WindowsFont
	Local defaultFontSizes:Int[]=[8,10,12,14,18,24,36,48,72]
	
	Function renderSampleText(gr:TGraphics,font:TImageFont)
		Local width:Int,tWidth:Int
		Local height:Int,tHeight:Int
		Local x:Int,y:Int
		
		SetGraphics gr
		width=GraphicsWidth()
		height=GraphicsHeight()
		SetImageFont font
		
		tWidth=TextWidth("Sample")
		tHeight=TextHeight("Sample")
		x=(width-tWidth)/2
		y=(height-tHeight)/2
		Cls
		DrawText "Sample",x,y
		Flip
	End Function
	
	win=CreateWindow("Select Font",x,y,269,234,Null,WINDOW_TITLEBAR|WINDOW_CLIENTCOORDS)
	lstFontNames=CreateListBox(3,3,200,140,win)
	tbFontSize=CreateTextField(GadgetX(lstFontNames)+GadgetWidth(lstFontNames)+3,..
							   GadgetY(lstFontNames),60,22,win)
	lstFontSizes=CreateListBox(GadgetX(tbFontSize),GadgetY(tbFontSize)+26,60,..
							   GadgetHeight(lstFontNames)-25,win)
	canSample=CreateCanvas(3,146,263,60,win)
	btnOk=CreateButton("Ok",206,209,60,22,win)
	btnCancel=CreateButton("Cancel",143,209,60,22,win)
	
	fontPath=getenv_("windir")
	fontPath:+"\Fonts"
	fontDirHandle=ReadDir(fontPath)
	Repeat
		fileName=NextFile(fontDirHandle)
		Select fileName
			Case ""
			Case "."
			Case ".."
			Default
				If Right(fileName,3)="ttf" Then ..
					AddGadgetItem lstFontNames,fileName
		End Select
	Until fileName=""
	
	For i=0 To defaultFontSizes.length-1
		AddGadgetItem lstFontSizes,defaultFontSizes[i]
	Next
	SetGadgetText tbFontSize,"16"
	
	quit=False
	While Not quit
		WaitEvent
		Select EventID()
			Case EVENT_GADGETACTION
				Select EventSource()
					Case lstFontNames
						i=SelectedGadgetItem(lstFontNames)
						If i>-1
							fileName=fontPath+GadgetItemText(lstFontNames,i)
							iFont=LoadImageFont(fileName,TextFieldText(tbFontSize).ToInt())
							renderSampleText CanvasGraphics(canSample),iFont
						EndIf
					Case lstFontSizes
						i=SelectedGadgetItem(lstFontSizes)
						If i>-1
							SetGadgetText tbFontSize,GadgetItemText(lstFontSizes,i)
							iFont=LoadImageFont(fileName,TextFieldText(tbFontSize).ToInt())
							renderSampleText CanvasGraphics(canSample),iFont
						EndIf
					Case btnOk
						i=SelectedGadgetItem(lstFontNames)
						If i>-1
							winFont=New WindowsFont
							winFont.name=GadgetItemText(lstFontNames,i)
							winFont.fullPath=fontPath+GadgetItemText(lstFontNames,i)
							winFont.size=TextFieldText(tbFontSize).ToInt()
							quit=True
						EndIf
					Case btnCancel
						winFont=Null
						quit=True
				End Select
			Case EVENT_WINDOWCLOSE
				Select EventSource()
					Case win
						quit=True
						winFont=Null
				End Select
			Case EVENT_GADGETPAINT
				Select EventSource()
					Case canSample
						renderSampleText CanvasGraphics(canSample),iFont
				End Select
		End Select	
	Wend
	FreeGadget win
	Return winFont
End Function

RequestWindowsFont 40,40,Null

It should be pretty obvious how this works. It requires MaxGUI (obviously), and it will only run on Windows.

Feel free to use this any way you see fit.

Neil

Very nice!

You can possibly build a translation map with the same technique to get RequestFont results working?

Possibly... that would be the nice solution. I'll work on it (but it won't be cross-platform)

You should put this in the Code Archive.