contrôle avant lancement macro que la police Wingdings 2 existe bien

[bertgrav]

bonjour,

je voudrais contrôler avant de lancer une macro de remplacement de type de caractére que la police Wingdings 2 existe bien sur le poste de travail.

pour un bien, faire un contrôle des polices existantes et mettre un message au cas où cette police n'est pas installée.

bien sur en VBA!

merci de votre aide

chantal

 

[pierrejean]

Re : contrôle avant lancement macro que la police Wingdings 2 existe bien

bonjour Chantal

une macro qui devrait faire l'affaire (non testée puisque je ne souhaite pas retirer la police Windings de mon PC)

tu nous diras

Sub Macro2()
On Error GoTo fin
    With Selection.Font
        .Name = "Wingdings"
    End With
On Error GoTo 0
Exit Sub
fin:
MsgBox ("la police Wingdings n'est pas installée")
On Error GoTo 0
End Sub

 

[Hervé]

Re : contrôle avant lancement macro que la police Wingdings 2 existe bien

bonjour chantal, salut pierrejean

Une autre solution possible :

Sub Bouton1_QuandClic()
'd'apres une code de L Longre, mpfe

Dim present As Boolean
Dim i As Integer

 With Application.CommandBars.FindControl(ID:=1728)
     For i = 1 To .ListCount
         If .List(i) = "Wingdings 2" Then present = True
     Next i
 End With

 If present Then
     MsgBox "La police existe sur ce poste."
 Else
     MsgBox "La police n'existe pas sur ce poste."
 End If
End Sub

salut

 

[bertgrav]

Re : contrôle avant lancement macro que la police Wingdings 2 existe bien

bonjour pierrejean

désolé, mais ça ne marche pas, essaie avec une police nommée par exemple aaaa.

la macro t'impose la police aaaa, mais rien ne se passe.

par contre dans ce que je recherche, je ne veux pas imposer la police 'wingding" dans une cellule, mais seulement contrôler que celle ci existe ou pas dans ma liste de police.

j'ai trouvé ce genre de code qui fonctionne trés bien si la police ne contient pas dans son nom un espace mais elle ne marche pas pour Wingding 2 !!!!
alors qu'elle est présente sur mon poste !

Sub TestPolice()


Dim fichier As String

Set fso = CreateObject("Scripting.FileSystemObject")
fichier = fso.GetSpecialFolder(0).Path & "/fonts/Wingding 2.ttf"

If fso.FileExists(fichier) Then
MsgBox "La police est présente sur ce poste."
Else

MsgBox "La police n'est pas présente sur ce poste."

End If
End Sub


chantal

 

[bertgrav]

Re : contrôle avant lancement macro que la police Wingdings 2 existe bien

excuse Hervé, nous nous sommes croisés

ta macro fonctionne, je viens de tester avec une police fantome: elle me renvoie qu'elle n'est pas présente.
alors qu'avec WINGDING 2 c'est ok

merci encore

chantal

 

[bertgrav]

Re : contrôle avant lancement macro que la police Wingdings 2 existe bien

ouf, j'ai trouvé pourquoi ça ne marchait pas avec Wingding 2 dans ma macro:

car le format WINGDING 2.TTF ne correspond pas au format TTF de la police Wingding 2

celle ci s'appelle en réalité : WINGDNG2.TTF

Amicalement

chantal

 

[pierrejean]

Re : contrôle avant lancement macro que la police Wingdings 2 existe bien

bravo a Hervé (pas une surprise)

quant a moi le rouge de la honte m'envahit pour ne pas avoir pensé a tester avec une police "bidon"

satanés fils de Bill qui acceptent n'importe quoi !!!!

 

[MichelXld]

Re : contrôle avant lancement macro que la police Wingdings 2 existe bien

bonsoir Chantal, Pierre-Jean et hervé ... ;o)

j'ai trouvé pourquoi ça ne marchait pas avec Wingding 2 dans ma macro:
car le format WINGDING 2.TTF ne correspond pas au format TTF de la police Wingding 2
celle ci s'appelle en réalité : WINGDNG2.TTF

En complément, juste pour info, si tu cherches la correspondance entre "Wingdings 2" et "WINGDNG2.TTF"

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 informationsFonts()
    '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 = "Wingdings 2"
    
    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:
    'http://perso.wanadoo.fr/stephane.glondu/prog/vb/a_ttf.htm
    '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 soirée
MichelXld