Boite de dialogue Police

**Ric500** · 11/02/2022, 18h30

Bonsoir Forum !

Je souhaiterais ouvrir une boîte de dialogue de choix de police afin de l'affecter à un contrôle voisin.

J'ai bien trouvé ce module qui fait le boulot sur les sources DVP, mais les déclarations en 64 bits s'avèrent un peu ardues.

Je bute sur la déclaration de type "Any" dans la fonction CopyMemory déclarée ainsi:

Code :

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

Declare PtrSafe Sub CopyMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As LongPtr)

avec ce message à l'exécution:
Nom : Sans titre.png
Affichages : 177
Taille : 2,5 Ko

Merci de vos lumières

Note: voici l'exemple pris ici dans les sources DVP.
et la même avec mes tentatives de déclarations 64 bits. BdPolice.rar

**User** · 11/02/2022, 20h30

Bonsoir,

Je crois qu'il te faut aussi préciser l'alias car j'ai vu dans ton lien que la procédure porte un autre nom dans la DLL :

Code :

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

Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (...

Cela dit je ne sais pas si ça résoudra ton problème

**Ric500** · 12/02/2022, 15h15

Bonjour,

Et merci User pour ta réponse.
J'avais effectivement enlevé l'alias pour tester sans plus de succès.

J'ai donc ci-joint BdPolice.rar une version accdb avec une tentative de déclaration conditionnelle.
Sur un poste en access 32 bits, pas de problème.
Sur un access 64 bits, l'appel de CHOOSEFONT dans ChoisirPolice() passe mais renvoie 0 dans resultat:

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
    '''''''''''''''''''
    'Ouvre la boite
    '''''''''''''''''''
    resultat = CHOOSEFONT(Boite)
    If resultat <> 0 Then
        CopyMemory laPolice, ByVal pMem, Len(laPolice)
        'Prepare le resultat
        Retour.Nom = Left(laPolice.lfFaceName, InStr(laPolice.lfFaceName, vbNullChar) - 1)
        Retour.Taille = Boite.iPointSize \ 10
        Retour.Couleur = Boite.rgbColors
        Retour.Gras = laPolice.lfWeight > FW_NORMAL
        Retour.Italique = laPolice.lfItalic
        Retour.Souligne = laPolice.lfUnderline
        Retour.Barre = laPolice.lfStrikeOut
     End If

Mais surtout n'ouvre pas la boîte de dialogue police.

Aurais-je une coquetterie dans ma déclaration de type CHOOSEFONT ?

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
#If VBA7 Then
    Private Type CHOOSEFONT
            lStructSize As Long
            hwndOwner As LongPtr
            hdc As LongPtr
            lpLogFont As LongPtr
            iPointSize As Long
            flags As Long
            rgbColors As Long
            lCustData As LongPtr
            lpfnHook As LongPtr
            lpTemplateName As String
            hInstance As LongPtr
            lpszStyle As String
            nFontType As Integer
            MISSING_ALIGNMENT As Integer
            nSizeMin As Long
            nSizeMax As Long
    End Type
#Else
    Private Type CHOOSEFONT
            lStructSize As Long
            hwndOwner As Long
            hdc As Long
            lpLogFont As Long
            iPointSize As Long
            flags As Long
            rgbColors As Long
            lCustData As Long
            lpfnHook As Long
            lpTemplateName As String
            hInstance As Long
            lpszStyle As String
            nFontType As Integer
            MISSING_ALIGNMENT As Integer
            nSizeMin As Long
            nSizeMax As Long
    End Type
#End If

Merci d'avance pour vos réponses

**User** · 12/02/2022, 18h33

Bonjour,

J'avoue ne pas avoir regardé tout ton code , mais concernant les déclarations conditionnelles, j'ai lu dans la doc microsoft ceci :

La constante de compilation conditionnelle VBA7 est utilisée pour déterminer si le code est en cours d’exécution dans la version 7 de Visual Basic editor (la version VBA fournie avec Office 2010).
La constante de compilation conditionnelle Win64 est utilisée pour déterminer quelle version (32 bits ou 64 bits) d’Office est en cours d’exécution.

Donc, par exemple, je suis sur Office 365 en 32 bits et ton code :

Code VBA :

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

1
2
3
4
5
6
7
8
9
10
11
#If VBA7 Then
    Public Function ChoisirPolice(Handle As LongPtr, PoliceParDefaut As Police) As Police
        Dim Boite As CHOOSEFONT, laPolice As LOGFONT, hMem As LongPtr, pMem As LongPtr
        Dim resultat As Long, Retour As Police, rep
        Debug.Print ("Office 2010 et plus")
#Else
    Public Function ChoisirPolice(Handle As Long, PoliceParDefaut As Police) As Police
        Dim Boite As CHOOSEFONT, laPolice As LOGFONT, hMem As Long, pMem As Long
        Dim resultat As Long, Retour As Police, rep
        Debug.Print ("Office 97-2007")
#End If

M'affiche logiquement : "Office 2010 et plus"

Et ce code modifié en utilisant la constante Win64 :

Code VBA :

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

1
2
3
4
5
6
7
8
9
10
11
#If Win64 Then
    Public Function ChoisirPolice(Handle As LongPtr, PoliceParDefaut As Police) As Police
        Dim Boite As CHOOSEFONT, laPolice As LOGFONT, hMem As LongPtr, pMem As LongPtr
        Dim resultat As Long, Retour As Police, rep
        Debug.Print ("64 bits")
#Else
    Public Function ChoisirPolice(Handle As Long, PoliceParDefaut As Police) As Police
        Dim Boite As CHOOSEFONT, laPolice As LOGFONT, hMem As Long, pMem As Long
        Dim resultat As Long, Retour As Police, rep
        Debug.Print ("32 bits")
#End If

M'affiche logiquement : "32 bits"

Donc, dans ton cas tu dis :

Sur un poste en access 32 bits, pas de problème.
Sur un access 64 bits, l'appel de CHOOSEFONT dans ChoisirPolice() passe mais renvoie 0 dans resultat:

Mais si on suppose que les 2 postes ont des versions 2010 ou plus, comme tu utilise la constante de compilation conditionnelle VBA7, tu devrait toujours exécuter sur les 2 postes, la 1ère partie de code, correspondant à "office 2010 et plus".

Or comme tu dis que pour le 64 bits ça ne marche pas, peut-être faudrait-il supprimer la déclaration conditionnelle avec VBA7, et utiliser la constante Win64 mais cette fois dans la fonction ChoisirPolice

Avec quelque chose comme ça :

Code VBA :

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

1
2
3
4
5
6
7
8
9
10
Public Function ChoisirPolice(Handle As LongPtr, PoliceParDefaut As Police) As Police
        Dim Boite As CHOOSEFONT, laPolice As LOGFONT, hMem As LongPtr, pMem As LongPtr
        Dim resultat As Long, Retour As Police, rep
        '...
	#If Win64 Then
    		Boite.lStructSize = LenB(Boite)
	#Else
    		Boite.lStructSize = Len(Boite)
	#End If
        '...

Comme dans ce lien que tu as peut-être déjà vu :

https://www.vba-tutorial.de/apireferenz/dialogboxen.htm

Mais il faut reconnaître que c'est vraiment pas simple de si retrouver avec toutes ses options

...

Bonne continuation..

**Ric500** · 12/02/2022, 18h50

Merci User, pour ta réponse rapide

Je testerai çà demain matin mais je crois que tu as raison.

Du coup il faudrait que je revoie toutes mes déclarations sur le modèle ?

Code :

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

1
2
3
4
5
6
7
8
9
#If Win64 then
    #If  Vba7 then
            Déclarations PtrSafe...
            #Else
            Déclarations 32 bits...
    #End If
   #Else
   Déclarations 32 bits...
#End If

Merci pour ces pistes, je reviens vers vous dès demain.

**Ric500** · 13/02/2022, 16h02

Je reviens vers vous à court d'idées pour mon pbme.

@User : J'ai modifié mon code comme suit sans plus de succès

:

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
Option Compare Database
Option Explicit
 
Public Type Police
    Nom As String
    Taille As Long
    Souligne As Boolean
    Italique As Boolean
    Gras As Boolean
    Barre As Boolean
    Couleur As Long
End Type
 
Const LOGPIXELSY = 90
Const FW_NORMAL = 400
Const FW_GRAS = 700
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const CF_NOSCRIPTSEL = &H800000
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
 
 
 
#If Win64 Then
    Private Type CHOOSEFONT
            lStructSize As Long
            hwndOwner As LongPtr
            hdc As LongPtr
            lpLogFont As LongPtr
            iPointSize As Long
            flags As Long
            rgbColors As Long
            lCustData As LongPtr
            lpfnHook As LongPtr
            lpTemplateName As String
            hInstance As LongPtr
            lpszStyle As String
            nFontType As Integer
            MISSING_ALIGNMENT As Integer
            nSizeMin As Long
            nSizeMax As Long
    End Type
#Else
    Private Type CHOOSEFONT
            lStructSize As Long
            hwndOwner As Long
            hdc As Long
            lpLogFont As Long
            iPointSize As Long
            flags As Long
            rgbColors As Long
            lCustData As Long
            lpfnHook As Long
            lpTemplateName As String
            hInstance As Long
            lpszStyle As String
            nFontType As Integer
            MISSING_ALIGNMENT As Integer
            nSizeMin As Long
            nSizeMax As Long
    End Type
#End If
Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * 31
End Type
 
#If Win64 Then
        Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
        Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
        Declare PtrSafe Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
        Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
        Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
        Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
        Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
        Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
#Else
        Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
        Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
        Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
        Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
        Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
        Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
#End If

et

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
58
59
60
61
62
63
#If Win64 Then
    Public Function ChoisirPolice(Handle As LongPtr, PoliceParDefaut As Police) As Police
        Dim Boite As CHOOSEFONT, laPolice As LOGFONT, hMem As LongPtr, pMem As LongPtr
        Dim resultat As Long, Retour As Police, rep
    #Else
    Public Function ChoisirPolice(Handle As Long, PoliceParDefaut As Police) As Police
        Dim Boite As CHOOSEFONT, laPolice As LOGFONT, hMem As Long, pMem As Long
        Dim resultat As Long, Retour As Police, rep
#End If
 
    '*****************************************
    'definit la police par defaut à afficher
    laPolice.lfStrikeOut = PoliceParDefaut.Barre
    laPolice.lfWeight = IIf(PoliceParDefaut.Gras, FW_GRAS, FW_NORMAL)
    laPolice.lfItalic = PoliceParDefaut.Italique
    laPolice.lfUnderline = PoliceParDefaut.Souligne
    laPolice.lfHeight = -PoliceParDefaut.Taille * GetDeviceCaps(GetDC(Handle), LOGPIXELSY) / 72
    If PoliceParDefaut.Nom = "" Then PoliceParDefaut.Nom = "Tahoma"
    laPolice.lfFaceName = PoliceParDefaut.Nom & vbNullChar  'Nom de la police par defaut
    '******************************************
    ' Creer une structure LOGFont en memoire.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(laPolice))
    'Verouille et recupere le pointeur vers la structure
    pMem = GlobalLock(hMem)
    'Copie la structure
    CopyMemory ByVal pMem, laPolice, Len(laPolice)
    'Initialise la boite de dialogue
    Boite.lStructSize = Len(Boite)
    Boite.hwndOwner = Handle
    'Affecte la police par defaut
    Boite.lpLogFont = pMem
    'defini la taille (10*La taille de la police)
    Boite.iPointSize = 120 'PoliceParDefaut.Taille * 10
    'Personalise la boite
    Boite.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or _
       CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE Or _
       CF_NOSCRIPTSEL
    'Fixe la couleur
    Boite.rgbColors = PoliceParDefaut.Couleur
    Boite.nFontType = REGULAR_FONTTYPE
    'Definit les tailles possibles
    Boite.nSizeMin = 6
    Boite.nSizeMax = 72
    '''''''''''''''''''
    'Ouvre la boite
    '''''''''''''''''''
    resultat = CHOOSEFONT(Boite)
    If resultat <> 0 Then
        CopyMemory laPolice, ByVal pMem, Len(laPolice)
        'Prepare le resultat
        Retour.Nom = Left(laPolice.lfFaceName, InStr(laPolice.lfFaceName, vbNullChar) - 1)
        Retour.Taille = Boite.iPointSize \ 10
        Retour.Couleur = Boite.rgbColors
        Retour.Gras = laPolice.lfWeight > FW_NORMAL
        Retour.Italique = laPolice.lfItalic
        Retour.Souligne = laPolice.lfUnderline
        Retour.Barre = laPolice.lfStrikeOut
     End If
    'libere la memoire
    resultat = GlobalUnlock(hMem)
    rep = GlobalFree(hMem)
    ChoisirPolice = Retour
End Function

J'avoue être un peu paumé là.

Boite de dialogue Police [AC-365]

VBA Access

Vue hybride

Discussions similaires

Partager

Partager