Re: screen.fonts again


"Claus Centrino" <cc58@xxxxxxxxxxxxxx> wrote in message news:glf1qu$nfh$1@xxxxxxxxxxxx

Thank you all for your answers. But how are Windows
Write and Word able to present a fontname list without
such doublets ? They can do it, but offer a different subset
of the installed fonts. As far as I know in a single font file
can be stored a single font - say xxfont bold - as well as
a couple of font belongig together, like xx normal, bold,
italic, italic bold . . . . .

Hi again Claus. In your initial post where you said . . . . .

"VB does automatically use xxx bold or xxx italic
if I select fontname xxx with attribute bold or
italic - how can **I** do that?"

.. . . . . I took it that you wanted to select the /real/ italic face of a font if it exists, rather than a software generated approximation of italic (which is usually used only where an italic face is not actually present in a suitable font file). That's why I said that you don't need to bother, because the system will automatically do it for you, whether you use VB or the CreateFontIndirect API, and so for the CreateFontIndirect API you just need to specify the normal face name of the font in the lfFaceName member and set the lfItalic member to True and the system will select the required font for you. For example, it is typical on most machines for Times New Roman to have four separate .ttf files for the various faces of the font (typically times.ttf, timesi.ttf, timesbd.ttf and times.bi.ttf) but if you specify the name Times New Roman and if you set the Italic member to True then the system will correctly assign the face of timesi.ttf for you (Times New Roman Italic). However, many font files have more than one face in a single file (and sometimes more than one font as well), for example a .ttc font file, but the system will still sort it all out for you if you just specify the required font name and set the required attribute (lfItalic for example).

However, it now appears from this most recent posting of yours that you actually want to produce a list of fonts with the "bold, italic, bold italic etc" not being shown as separate face names, regardless of whether the different faces live in separate .ttf files or not. There are probably a number of ways of doing that but the easiest might be to generate a sorted list of face names and "code out" any face names with " italic", " bold" or " bold italic" at the end, provided of course that a normal face name exists for that font. For example, if you have Arial, Arial Italic, Arial Bold and Arial Bold Italic then you would want to remove the latter three from the list you display to the user. However, if you have Brush Script MT Italic and you do not also have a Brush Script MT then you would want to leave Brush Script MT Italic in the list. Those are just examples of course. Also you would want to filter exact duplicates from the list because it is possible for a specific font face and attribute to exist in more than one font file. As an example, on my own system there are two MS Mincho (normal face) fonts, one of which lives on its own in a .ttf file and the other of which lives amongst others in a .ttc file.

Here is some code that performs at least some of what you want to do, especially since you have shown an interest in determining exactly what files (.ttf, .ttc, etc) the various fonts live in. I'm in a bit of a rush at the moment because I've got to start getting ready for a forthcoming holiday in Scotland quite soon (gonna' be cold there, but still a really nice place) so the example below includes various things that you don't need. I wrote it ages ago for a friend who wanted to have some fonts in his VB app's folder (Vista be damned!) and install them on the target machine if they did not already exist and then uninstall then again when the program ends, so you can remove those parts as you won't want them. The code gets the font names by examining the registry (because we wanted to also know the path and filename of each .ttf, .ttc, etc font file for various reasons and it is not always in the Windows Fonts folder). It then dumps the font names into an array and the type (True Type or not) into another array and the path and filename into a third array (that's just the way he wanted it) and it sorts the three arrays as a linked group (the names are not in sorted order in the registry, although they are partially sorted). It also removes any exact duplicates it finds (the MS Mincho that I mentioned above, for example). It does not remove the Italic, Bold, Bold Italic etc because at that time we did not have a requirement for doing that (in fact we specifically wanted them all shown so that we could see the details of the path and file name for each of them) so you will need to add some code yourself to remove those if you wish. Anyway, the reason I'm mentioning all this is that I don't at the moment have time to produce a modified version of the code to suit your own exact purposes, so I'm just posting it "as is".

There are probably other ways of tackling this job, and actually I think that much of this information can be obtained by other means (the various GDI font attribute functions for example) as well, but this method seems okay for your purposes, and it certainly does show you the font file names in which you have shown an interest against each specific font and face. I do of course expect Bill McCarthy to immediately start Googling and "Ctrl C"ing like mad until he finds something better and then to present it as though it was his own and as though it came from within his own brain as he usually does, so you will no doubt end up with some other options quite soon.

By the way, the Windows registry is not at all straight forward regarding fonts and I think there are other registry entries that I might also wish to take into account if I were producing such code as a finished product, but it seems to work reasonably well as it stands, and I haven't got time at the moment to follow McCarthy into the Google empire. The example below, which I've taken straight from one of my own programs, doesn't currently do exactly what you want and also does some things you don't want, but it should be fairly easy to modify to suit your needs. Paste the example into a VB Form containing a ListBox:

Mike

Option Explicit
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" (ByVal hKey As Long, _
ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function SHGetSpecialFolderLocation _
Lib "Shell32.dll" (ByVal hwndOwner As Long, _
ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList _
Lib "Shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function AddFontResource Lib "gdi32" _
Alias "AddFontResourceA" (ByVal lpFileName As String) _
As Long
Private Declare Function RemoveFontResource Lib "gdi32" _
Alias "RemoveFontResourceA" (ByVal lpFileName _
As String) As Long
Private Declare Function CreateScalableFontResource _
Lib "gdi32" Alias "CreateScalableFontResourceA" _
(ByVal fHidden As Long, ByVal lpszResourceFile As _
String, ByVal lpszFontFile As String, _
ByVal lpszCurrentPath As String) As Long
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const ERROR_NO_MORE_ITEMS As Long = 259&
Private Const LB_SETTABSTOPS As Long = &H192
Private Const CSIDL_FONTS As Long = 20
Private Const MAX_PATH As Integer = 260
Private Type SH_ITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SH_ITEMID
End Type
Dim newFontsInstalled() As String
Private nInstalled As Long
Private fontNames() As String
Private fontFiles() As String
Private TrueType() As Boolean

Private Function GetFontName(FileName As String) As String
Dim Buffer As String, FontName As String
Dim TempName As String, hFile As Long, iPos As Long
TempName = App.Path & "\sillyname2863.fot"
If CreateScalableFontResource(1, TempName, _
FileName, vbNullString) Then
hFile = FreeFile
Open TempName For Binary As hFile
Buffer = Space(LOF(hFile))
Get hFile, 1, Buffer
iPos = InStr(1, Buffer, "FONTRES:", vbTextCompare) + 8
FontName = Mid(Buffer, iPos, InStr _
(iPos, Buffer, vbNullChar) - iPos)
Close hFile
Kill TempName
End If
GetFontName = FontName
End Function

Private Function GetSpecialFolder(CSIDL As Long) As String
Dim sPath As String, IDL As ITEMIDLIST
GetSpecialFolder = ""
If SHGetSpecialFolderLocation _
(Form1.hwnd, CSIDL, IDL) = 0 Then
sPath = Space$(MAX_PATH)
If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then
GetSpecialFolder = Left$(sPath, InStr _
(sPath, vbNullChar) - 1) & "\"
End If
End If
End Function

Private Sub AddMoreElements()
ReDim Preserve fontNames(LBound(fontNames) _
To UBound(fontNames) + 100)
ReDim Preserve fontFiles(LBound(fontFiles) _
To UBound(fontFiles) + 100)
ReDim Preserve TrueType(LBound(TrueType) _
To UBound(TrueType) + 100)
End Sub

Private Sub CustomShellSort _
(A() As String, B() As String, C() As Boolean, _
ByVal Lb As Long, ByVal Ub As Long, ByVal cmp As Integer)
' NOTE: sorting each of the three linked arrays in this
' way is slow when compared to the alternative of a
' ShellIndex sort (where we just sort a separate array of
' Long indices and leave the actual array data in its
' original unsorted order) but this method gives us the
' result we want (three matched sorted arrays) and it is
' very fast anyway on the small arrays we are dealing
' with (up to about 1000 elements each) taking just a
' couple of milliseconds to perform the sort
Dim n As Long, h As Long, j As Long, k As Long
Dim tA As String, tB As String, tC As Boolean
Dim r As Integer
If cmp <> vbBinaryCompare Then cmp = vbTextCompare
n = Ub - Lb + 1: h = 1
Do While h < n
h = 3 * h + 1
Loop
h = h \ 3
Do While h > 0
For k = Lb + h To Ub
tA = A(k)
tB = B(k)
tC = C(k)
For j = k - h To Lb Step -h
r = StrComp(A(j), tA, cmp) ' compare only first array
If r < 1 Then Exit For
A(j + h) = A(j)
B(j + h) = B(j)
C(j + h) = C(j)
Next j
A(j + h) = tA
B(j + h) = tB
C(j + h) = tC
Next k
h = h \ 3
Loop
End Sub

Private Function CustomremoveDups(p1() As String, _
p2() As String, p3() As Boolean, Ub As Long, _
cmp As Long) As Long
Dim lastElement As Long, n As Long, z As Long
lastElement = LBound(p1) - 1
n = LBound(p1) - 1
If cmp <> vbBinaryCompare Then
cmp = vbTextCompare
End If
Do
lastElement = lastElement + 1
n = n + 1: z = n
p1(lastElement) = p1(n)
p2(lastElement) = p2(n)
p3(lastElement) = p3(n)
If n >= Ub Then
Exit Do
End If
While StrComp(p1(n + 1), p1(z), cmp) = 0
n = n + 1
If n >= Ub Then
Exit Do
End If
Wend
Loop Until n >= Ub
CustomremoveDups = lastElement
End Function

Private Sub Form_Load()
ReDim fontNames(0 To 500)
ReDim fontFiles(0 To 500)
ReDim TrueType(0 To 500)
Me.Show
Me.Width = 9000: Me.Height = 7000
List1.Move 100, 100, Me.ScaleWidth - 200, Me.ScaleHeight - 200
List1.Visible = False
Dim hKey As Long, Cnt As Long, sName As String
Dim sData As String, Ret As Long, RetData As Long
Dim sFontFolder As String, p1 As Long
Dim faceName As String, FileName As String
Dim sFaces() As String, s1 As String, n As Long
Dim faceIndex As Long, faceCount As Long
Dim TrueTypeFonts As Long, bitmapFonts As Long
Dim Name As String, Folder As String
Dim pathApp As String, sExt As String
Dim fontOK As Long, fName As String
Dim tempFont As Font, sTemp As String
Const BUFFER_SIZE As Long = 255
' first add any fonts found in the app.path
' folder to the three arrays.
List1.Clear
faceIndex = 0
Set tempFont = Me.Font ' save exisiting Form font to
' restore later so we can use
' Me.Font for test purposes
pathApp = App.Path
If Right$(pathApp, 1) <> "\" Then pathApp = pathApp & "\"
ReDim newFontsInstalled(1 To 10)
Name = Dir(Folder & "*.tt?", vbDirectory)
Do While Len(Name) > 0
If Not (GetAttr(Folder & Name) And vbDirectory) Then
sExt = LCase(Right$(Name, 4))
If sExt = ".ttf" Or sExt = ".ttc" Then
fName = GetFontName(pathApp & Name)
' Windows historically does not like font names longer
' than 31 characters (although some such names do
' actually exist are are used okay) but VB will throw
' an error if you try to set a font to such a
' font name (although the CreateFontIndirect API
' accepts it). However, both the API and VB will
' happily accept just the first 31 characters of
' such a font name and will happily set the font to
' the desired face even thougb you have specified
' only the first 31 characters of its name.
If Len(fName) > 31 Then
fName = Left$(fName, 31)
End If
If fName <> "" Then
' check to see if it's already installed on the system
Me.Font.Name = fName
If Me.Font.Name <> fName Then
' the new font is not already installed
' so install it
fontOK = AddFontResource(pathApp & Name)
If fontOK > 0 Then
SendMessage HWND_BROADCAST, _
WM_FONTCHANGE, 0, ByVal 0&
' . . . and add it to the arrays
fontNames(faceIndex) = fName
fontFiles(faceIndex) = pathApp & Name
TrueType(faceIndex) = True
'
faceIndex = faceIndex + 1
nInstalled = nInstalled + 1
newFontsInstalled(nInstalled) = pathApp & Name
If nInstalled > UBound(newFontsInstalled) Then
ReDim Preserve newFontsInstalled _
(LBound(newFontsInstalled) To _
UBound(newFontsInstalled) + 10)
End If
End If
' end of block which installed the new font
End If
End If
End If
End If
Name = Dir()
Loop
Set Me.Font = tempFont
' now add all fonts from the Windows Registry to the arrays
sFontFolder = GetSpecialFolder(CSIDL_FONTS)
If RegOpenKey(HKEY_LOCAL_MACHINE, _
"Software\Microsoft\Windows NT\CurrentVersion\Fonts", _
hKey) = 0 Then
sName = Space(BUFFER_SIZE)
sData = Space(BUFFER_SIZE)
Ret = BUFFER_SIZE
RetData = BUFFER_SIZE
faceIndex = faceIndex - 1 ' initialise to 1 below the
' first available element
While RegEnumValue(hKey, Cnt, sName, Ret, _
0, ByVal 0&, ByVal sData, RetData) _
<> ERROR_NO_MORE_ITEMS
If RetData > 0 Then
faceName = Left$(sName, Ret)
' check and remove True Type stuff
p1 = InStr(1, faceName, " (TrueType)", vbTextCompare)
If p1 = 0 Then
p1 = InStr(1, faceName, " (True Type)", vbTextCompare)
End If
If p1 <> 0 Then
' True Type font
faceName = Left$(faceName, p1 - 1)
FileName = Left$(sData, RetData - 1)
If InStr(FileName, ":") = 0 Then
FileName = sFontFolder & FileName
End If
If InStr(faceName, " & ") = 0 Then
' only one face in this file
faceIndex = faceIndex + 1
If faceIndex > UBound(fontNames) Then
AddMoreElements
End If
If Len(faceName) > 31 Then
faceName = Left$(faceName, 31)
End If
fontNames(faceIndex) = faceName
fontFiles(faceIndex) = FileName
TrueType(faceIndex) = True
TrueTypeFonts = TrueTypeFonts + 1
Else
' multiple faces in this file
' so split them up
sFaces = Split(faceName, " & ")
For n = LBound(sFaces) To UBound(sFaces)
faceIndex = faceIndex + 1
If faceIndex > UBound(fontNames) Then
AddMoreElements
End If
If Len(faceName) > 31 Then
faceName = Left$(faceName, 31)
End If
fontNames(faceIndex) = sFaces(n)
fontFiles(faceIndex) = FileName
TrueType(faceIndex) = True
TrueTypeFonts = TrueTypeFonts + 1
Next n
End If
Else
' Not a True Type font (probably a bitmap font)
' So first check for stuff in brackets at the end
p1 = InStrRev(faceName, "(")
If p1 <> 0 Then
' remove anything in brackets at right side
' for example, remove "(All res)" but do
' not remove the space before the bracket
faceName = RTrim(Left$(faceName, p1 - 1))
Else
' nothing in brackets found so check for any
' list of numbers that may be following the actual
' name. This is best achieved by first looking
' backwards for a comma . . .
p1 = InStrRev(faceName, ",")
If p1 <> 0 Then
' comma found, so presume list of numbers is
' present and look for rightmost space
p1 = InStrRev(faceName, " ")
If p1 <> 0 Then
' space also found, so remove list of numbers
faceName = Left$(faceName, p1 - 1)
End If
End If
End If
FileName = Left$(sData, RetData - 1)
If InStr(FileName, ":") = 0 Then
FileName = sFontFolder & FileName
End If
faceIndex = faceIndex + 1
If faceIndex > UBound(fontNames) Then
AddMoreElements
End If
If Len(faceName) > 31 Then
faceName = Left$(faceName, 31)
End If
fontNames(faceIndex) = faceName
fontFiles(faceIndex) = FileName
TrueType(faceIndex) = False
bitmapFonts = bitmapFonts + 1
End If
End If
Cnt = Cnt + 1
sName = Space(BUFFER_SIZE)
sData = Space(BUFFER_SIZE)
Ret = BUFFER_SIZE
RetData = BUFFER_SIZE
Wend
RegCloseKey hKey
Else
Me.Print " Error while calling RegOpenKey"
End If
CustomShellSort fontNames(), fontFiles(), TrueType(), _
LBound(fontNames), faceIndex, vbTextCompare
faceIndex = CustomremoveDups(fontNames(), fontFiles(), _
TrueType(), faceIndex, vbTextCompare)
ReDim Preserve fontNames(LBound(fontNames) To faceIndex)
ReDim Preserve fontFiles(LBound(fontFiles) To faceIndex)
ReDim Preserve TrueType(LBound(TrueType) To faceIndex)
List1.Clear
For n = 0 To UBound(fontNames)
sTemp = fontNames(n) & Space$(2)
If TrueType(n) = True Then
sTemp = sTemp & "[TrueType / OpenType]"
End If
List1.AddItem sTemp & vbTab & vbTab & fontFiles(n)
Next n
faceCount = faceIndex + 1 ' because count is zero based
Caption = faceCount & " font face names found"
List1.Visible = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim n As Long, s1 As String
If nInstalled > 0 Then
For n = 1 To nInstalled
RemoveFontResource newFontsInstalled(n)
SendMessage HWND_BROADCAST, _
WM_FONTCHANGE, 0, ByVal 0&
Next n
End If
End Sub




.

Relevant Pages

  • Re: Alpha search to load a list box
    ... Dim strTemp As String ... Private Declare Function apiSelectObject Lib "gdi32" Alias ... Dim newfont As Long ' Handle to our Font Object we created. ...
    (microsoft.public.access.formscoding)
  • RE: Alpha search to load a list box
    ... Private Sub LblAlpha_MouseDown(Button As Integer, Shift As Integer, X As ... ByVal F As String) As Long ... Private Declare Function apiDeleteObject Lib "gdi32" _ ... ' Control's Font attributes to build our own font in whatever ...
    (microsoft.public.access.formscoding)
  • Re: autotextbox enhancement
    ... ' Control is placed in a different Section. ... Dim sRect As RECT ... Private Declare Function apiSelectObject Lib "gdi32" Alias ... ' Handle to our Font Object we created. ...
    (microsoft.public.access.formscoding)
  • RE: Alpha search to load a list box
    ... Private Sub LblAlpha_MouseDown(Button As Integer, Shift As Integer, X As ... ByVal F As String) As Long ... Private Declare Function apiDeleteObject Lib "gdi32" _ ... ' Control's Font attributes to build our own font in whatever ...
    (microsoft.public.access.formscoding)
  • RE: "embedding" fonts in Excel
    ... does copy the font into the font folder, ... Private strPath As String ... Private Declare Function CreateScalableFontResource Lib "gdi32" _ ... Private Sub Workbook_Open ...
    (microsoft.public.excel.programming)
Quantcast