[size=4]Public 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
Sub informationsFontsCelluleA1()
'adapté par michelxld le 23.02.2005
'http://www.excel-downloads.com/forums/2-182-polices.htm
'testé avec Excel2002 et WinXP
Const Cible = &H14
'necessite d'activer la reference Microsoft Shell Controls and Automation
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim colItems As Shell32.FolderItems
Dim objItem As Shell32.FolderItem
Dim i As Integer
Dim laPolice As String
laPolice = Range('A1').Font.Name
Set objShell = CreateObject('Shell.Application')
Set objFolder = objShell.NameSpace(Cible)
Set colItems = objFolder.Items
For Each objItem In colItems
If GetFontName(objItem.Name) = laPolice Then
MsgBox objItem.Path
Exit For
End If
Next
End Sub
Public Function GetFontName(FileNameTTF As String) As String
Dim hFile As Integer, iPos As Integer
Dim Buffer As String, FontName As String, TempName As String
'source de la fonction :
'Crée un fichier ressources temporaire et appelle l'API
TempName = ThisWorkbook.Path & '\\~TEMP.FOT'
If CreateScalableFontResource(1, TempName, FileNameTTF, vbNullString) Then
'Dans le fichier ressources, le nom de la police est précédé de 'FONTRES:'
hFile = FreeFile
Open TempName For Binary Access Read As hFile
Buffer = Space(LOF(hFile))
Get hFile, , Buffer
iPos = InStr(Buffer, 'FONTRES:') + 8
FontName = Mid(Buffer, iPos, InStr(iPos, Buffer, vbNullChar) - iPos)
Close hFile
Kill TempName
End If
GetFontName = FontName
End Function[/size]