Polices

[Pedro]

Salut à tous,

Tout d'abord je tenais à féliciter les admin. pour cette nouvelle interface fort agréable.

Je souhaiterais savoir ce qu'il va advenir des anciens post qui sont une énorme source de recherche...

Enfin je repose ma question envoyer peu de temps avant le changement...

Je cherche à obtenir le nom des polices utilisées dans une cellule.
Mais pas 'Times new Roman' mais 'Times.ttf' trop simpl autrement...
Pour info font.name me renvoie 'Times new Roman'

A+

 

[MichelXld]

bonsoir Pedro

l'exemple ci-dessous permet d'afficher le nom de la police pour la cellule A1

necessite d'activer la reference Microsoft Shell Controls and Automation
la fonction GetFontName est de Stephane Glondu

[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]

testé avec WinXP et Excel2002


bonne soirée
MichelXld

 

[MichelXld]

rebonsoir

bon pour la mise en forme ce n'est pas encore ça ... je reprends ...

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

bonne soiree
MichelXld

 

[Pedro]

Salut

Ouahhhhhhh........... :woohoo:

Un grand merci....
Je vais pouvoir finaliser ma plateforme Excel-Autocad...
Par contre il ne fonctionne pas systématiquement... à voir....
Je ne sais pas ou il vont chercher tout cela...
Au fait comment on peut avoir connaissances des informations renvoyer par une dll...

Encore merci...

A+

 

[MichelXld]

bonjour Pedro

la macro boucle sur le dossier spécial de Windows 'Fonts' , ou sont normalement stockées toutes les polices

il se peut que certaines polices soient stockées ailleurs que dans ce repertoire spécifique , et dans ce cas la procedure ne fonctionnera pas
( comme par exemple chez moi 'WST_Swed'…)

bonne journée
MichelXld