Obviously this isn't going to get edge cases right, I don't see how it could without some way to extracts the actual family name from the font file.
I'm using an array because I couldn't get the list sorted in a way that a 'no-style' font name came first and was winding up with multiple sub-menus for the same Font Family Name. Using an Array made it much easier to do the grouping and inserting a non-styled (Plain) choice into the sub-menu if there isn't one already.
- Screen Shot 2024-08-09 at 11.47.52 AM.png (248.38 KiB) Viewed 5880 times
Code: Select all
on mouseDown pButtonNumber
put fontMenu() into me
end mouseDown
on menuPick pWhich
replace "|" with " " in pWhich
if the last word of pWhich = "(Plain)" then delete the last word of pWhich
set the label of me to pWhich
set the textFont of me to pWhich
set the textFont of fld 1 to pWhich
end menuPick
function fontMenu
lock screen
-- Define the "special-purpose" font names to ignore
put "(Default)" & cr & "(Menu)" & cr & "(Message)" & cr & "(Styled Text)" & cr & "(System)" & cr & "(Text)" & cr & "(Tooltip)" into tXTalkPsuedoFonts
--- get / sort the fonts listing
put fontNames("printer") into tFonts
-- put fontNames() into tFonts
-- sort lines of tFonts -- by word 1 to 2 of each -- ascending -- international -- by word 1 of each
sort tFonts ascending international -- by word 1 of each
-- init variables
put empty into tFontsArray["fontFamilies"]
put "" into tPreviousFontFamName
put "" into tFontStylesList
put "" into tFontNameStyleReferences
--- iterate through lines in the Fonts listing
repeat for each line tCurrentFont in tFonts
--- skip useless special IDE fonts
if tCurrentFont is among the lines of tXTalkPsuedoFonts then next repeat
-- iterate through words in current Font name, from right to left
Repeat with x = the number of words in tCurrentFont to 1 step -1
--- check for known style keywords, remove from current Font name if found while adding to style string
if word x of tCurrentFont is among the items of "Plain,Regular,Normal,Condensed,Cond,Compressed,Extended,Extra,ExtraCondensed,Extrabold,Extralight,ExtraLight"&\
"Extrabold,Book,Italic,Oblique,Med,Medium,Demi,Demibold,Semi,Semibold,SemiBold"&\
"SemiCondensed,SemiExtended,Bold,Heavy,Black,Light,Ultra,Wide,Utlra,UltraLight,UltraBold,Ultrawide"&\
"Expanded,Super,SuperLight,Thin,Narrow" then
-- if word x of tCurrentFont = "Plain" then next repeat
put word x of tCurrentFont & " " before tFontNameStyleReferences
delete word x of tCurrentFont
next repeat
--- if no more known style keywords are found assume the crrent fontname is widdled down to a valid Font family name
else
-- if tFontStylesList is empty then put "Plain" into tFontStylesList
-- remove trailing space from Style References
if the last char of tFontNameStyleReferences = " " then delete the last char of tFontNameStyleReferences
-- add any collected FontNameStyleReferences to the family font styles list
if tFontNameStyleReferences <> empty then
put tab & tFontNameStyleReferences &cr after tFontStylesList
put "" into tFontNameStyleReferences
end if
if tCurrentFont <> tPreviousFontFamName then
if tCurrentFont is not among the lines of tFontsArray["fontFamilies"] then
if tFontsArray["fontFamilies"] is empty then
put tCurrentFont after tFontsArray["fontFamilies"]
else
put cr & tCurrentFont after tFontsArray["fontFamilies"]
end if
end if
put tCurrentFont into tPreviousFontFamName
put "" into tFontNameStyleReferences
put empty into tFontStylesList
end if
end if
end Repeat
filter lines of tFontStylesList without empty
sort lines of tFontStylesList
if tCurrentFont = tPreviousFontFamName and tFontStylesList <> empty then
if tFontsArray[tCurrentFont] is empty then
put tFontStylesList after tFontsArray[tCurrentFont]
else
put cr & tFontStylesList after tFontsArray[tCurrentFont]
end if
put "" into tFontStylesList
put tCurrentFont into tPreviousFontFamName
next repeat
else if tCurrentFont <> tPreviousFontFamName and tFontStylesList = empty then
if tCurrentFont is not among the lines of tFontsArray["fontFamilies"] then put cr & tCurrentFont after tFontsArray["fontFamilies"]
put tCurrentFont into tPreviousFontFamName
else
put tCurrentFont into tPreviousFontFamName
end if
end repeat
--- generate Fontlist from tFontsArray
repeat for each line tFontFam in tFontsArray["fontFamilies"]
-- Add font Family Name to list
put cr & tFontFam & cr after tFontsList
-- if there are any fontStyles then add the fontStyles sub-menu
if tFontsArray[tFontFam] is not empty then
--- if there isn't onee we need to add a way to select the no-style version of the font to the fontStyles sub-menu
if "Plain" is in tFontsArray[tFontFam] or "Regular" is in tFontsArray[tFontFam] then
put cr & tFontsArray[tFontFam] after tFontsList
else
put cr & tab & "\(Plain\)" & cr & tFontsArray[tFontFam] after tFontsList
end if
end if
end repeat
filter lines of tFontsList without empty
return tFontsList
end fontMenu
)
