Tri à bulle curieux des noms de police

**DenisHen** · 25/10/2023, 05h31

Bonjour à la communauté.
Je tente de faire un document avec un exemple de toutes mes polices installées (plus de 7000).
J'ai écris un code, mais le tri à bulle ne fonctionne tout simplement pas. Et pourtant, je l'utilise souvent...
Voici ce code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Sub ListePolicesInstallées()
    Documents.Add
    Dim Compt As Integer, Lign As Integer, LstPolice() As String
    Compt = 1
    For Each PolicesCar In FontNames
        With Selection
            Compt = Compt + 1
        End With
    Next
    ReDim LstPolice(Compt)
    Lign = 1
    For Each PolicesCar In FontNames
        With Selection
            LstPolice(Lign) = PolicesCar
            Lign = Lign + 1
        End With
    Next
    'Tri à bulles **************************
    Dim i As Integer, j  As Integer, k As Integer, v As Integer
    If loBound = -1 Then loBound = LBound(LstPolice())
    If upBound = -1 Then upBound = UBound(LstPolice())
    k = upBound
    For i = loBound + 1 To upBound
        v = LstPolice(i): j = i
        While LstPolice(j - 1) > v
            LstPolice(j) = LstPolice(j - 1): j = j - 1
        Wend
        LstPolice(j) = v
    Next i
 
    For Lign = 1 To UBound(LstPolice())
        With Selection
            .Font.Name = "Arial"
            .Font.Size = 12
            .Font.Underline = 1
            .Font.Italic = False
            .ParagraphFormat.Alignment = 0
            .Font.Bold = True
            .TypeText Text:=LstPolice(Lign)
            .TypeParagraph
        End With
        With Selection
            .Font.Name = LstPolice(Lign)
            .Font.Bold = False
            .Font.Underline = 0
            .TypeText Text:="Ex : servez un whisky au juge blond qui fume la pipe" & vbLf & "0123456789&é(-è_çà)=#{[|`\^@]}/*-+.ôï$£*µù%!§:/;.,?"
            .TypeParagraph
        End With
        'If Lign > 20 Then Exit Sub
    Next
End Sub

Si quelqu'un a une astuce, un conseil, je suis preneur.
Denis.

**E KERGRESSE** · 25/10/2023, 08h49

Bonjour,

J'ai testé votre code. Celui-ci fonctionne mais il prend énormément de temps en raison des 1326 polices en stock dans FontNames chez moi et du tri réalisé.
Mon éditeur VBA étant paramétré pour déclarer obligatoirement les variables, j'ai dû déclarer celles manquantes. J'ai ajouté un Msgbox en début de code pour connaître le nombre de polices.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
 
Sub ListePolicesInstallées()
 
Dim PolicesCar, loBound, upBound
 
    MsgBox FontNames.Count
 
    Documents.Add
    Dim Compt As Integer, Lign As Integer, LstPolice() As String
    Compt = 1
    For Each PolicesCar In FontNames
        With Selection
            Compt = Compt + 1
        End With
    Next
    ReDim LstPolice(Compt)
    Lign = 1
    For Each PolicesCar In FontNames
        With Selection
            LstPolice(Lign) = PolicesCar
            Lign = Lign + 1
        End With
    Next
    'Tri à bulles **************************
    Dim i As Integer, j  As Integer, k As Integer, v As Integer
    If loBound = -1 Then loBound = LBound(LstPolice())
    If upBound = -1 Then upBound = UBound(LstPolice())
    k = upBound
    For i = loBound + 1 To upBound
        v = LstPolice(i): j = i
        While LstPolice(j - 1) > v
            LstPolice(j) = LstPolice(j - 1): j = j - 1
        Wend
        LstPolice(j) = v
    Next i
 
    For Lign = 1 To UBound(LstPolice())
        With Selection
            .Font.Name = "Arial"
            .Font.Size = 12
            .Font.Underline = 1
            .Font.Italic = False
            .ParagraphFormat.Alignment = 0
            .Font.Bold = True
            .TypeText Text:=LstPolice(Lign)
            .TypeParagraph
        End With
        With Selection
            .Font.Name = LstPolice(Lign)
            .Font.Bold = False
            .Font.Underline = 0
            .TypeText Text:="Ex : servez un whisky au juge blond qui fume la pipe" & vbLf & "0123456789&é(-è_çà)=#{[|`\^@]}/*-+.ôï$£*µù%!§:/;.,?"
            .TypeParagraph
        End With
        'If Lign > 20 Then Exit Sub
    Next
End Sub

**DenisHen** · 25/10/2023, 11h46

Bonjour E KERGRESSE, et merci pour votre aide.
En fait, nos codes fonctionnent, mais pas leur tri.
J'ai fais deux petites boucles (avant le tri et après) qui écrivent les valeurs de LstPolice() dans un fichier .txt.
Je m'aperçois que l'ordre des valeurs des deux fichiers sont les mêmes...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
    Open "D:\Documents\01 Polices.txt" For Output As #1
    ReDim LstPolice(Compt - 1)
    Lign = 1
    For Each PolicesCar In FontNames
        'With Selection
            LstPolice(Lign) = PolicesCar
            print #1, LstPolice(Lign)
            Lign = Lign + 1
        'End With
    Next

Résultat :

Times New Roman
Arial
Courier New
Symbol
Helvetica
Courier
Wingdings
MS Mincho
...
...

Après avoir placé des points d'arrêts (F9) un peu partout, je vois que le tri ne se fait pas.
La macro passe au-dessus du "For i = loBound + 1 To upBound" pour aller après son "Next i".
J'ai cherché, et ces "Debug.print" répondent 0 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
    If loBound = -1 Then loBound = LBound(LstPolice) 'LBound(LstPolice()) donne le même résultat
    If upBound = -1 Then upBound = UBound(LstPolice) 'UBound(LstPolice()) donne le même résultat
    Debug.Print loBound
    Debug.Print upBound

Je pense à Option Base mais j'en doute...
J'avoue que je tourne un peu en rond.
Encore merci pour votre aide.
Denis.

**jurassic pork** · 26/10/2023, 16h31

Hello,
Tu peux aussi essayer pour le tri l'objet ArrayList :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub ListePolicesInstalléesJP()
Dim Coll As Object, PolicesCar, i As Long
    Set Coll = CreateObject("System.Collections.ArrayList")
    Documents.Add
    For Each PolicesCar In FontNames
       Coll.Add PolicesCar
    Next
    Coll.Sort ' tri
    Application.ScreenUpdating = False
    For i = 0 To Coll.Count - 1
        With Selection
            .Font.Name = "Arial"
            .Font.Size = 12
            .Font.Underline = 1
            .Font.Italic = False
            .ParagraphFormat.Alignment = 0
            .Font.Bold = True
            .TypeText Text:=Coll(i)
            .TypeParagraph
        End With
        With Selection
            .Font.Name = Coll(i)
            .Font.Bold = False
            .Font.Underline = 0
            .TypeText Text:="Ex : servez un whisky au juge blond qui fume la pipe" & vbLf & "0123456789&é(-è_çà)=#{[|`\^@]}/*-+.ôï$£*µù%!§:/;.,?"
            .TypeParagraph
        End With
        'If Lign > 20 Then Exit Sub
    Next i
    Application.ScreenUpdating = True
End Sub

Par contre il ne peut rien contre le temps d'écriture du texte dans le document.

Ami calmant, J.P

**DenisHen** · 27/10/2023, 06h49

Salut jurassic pork et mille mercis pour ton aide.
Tout fonctionne super bien ! ! !
Le coup du Set Coll = CreateObject("System.Collections.ArrayList"), je ne l'avais pas vu venir ! ! !
J'avoues que j'ai du mal à utiliser les dictionnaires et les collections, mais voici un bel exemple d'utilisation.
Encore un super grand merci à toi ainsi qu'à la communauté.
Bien à vous.
Denis...

Tri à bulle curieux des noms de police [WD-365]

VBA Word

Discussions similaires

Partager

Partager