Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Access Liste des polices

Liste des polices

7 réponses
Avatar
Nicolas
Bonjour,

Dans mon formulaire d'access 2000, je souhaiterais faire=20
une liste modifiable contenant les polices de mon=20
ordinateur.

Que dois-je =E9crire dans mon code ?

Merci

Nicolas
Signaler un problème avec ce contenu

7 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Michel Walsh
Salut,


Voir la page "Enumerating Windows Fonts by Type" ou "Enumerating
Windows Fonts with Preview" ou "Enumerating Windows Fonts - Callback vs.
VB" ( dans ce dernier cas, noter que VBA6 possède AddressOf, donc OK avec
Access 2000, pas Access 97 par contre) du site http://www.mvps.org/vbnet/



Espérant être utile,
Vanderghast, Access MVP


"Nicolas" wrote in message
news:088601c3c55e$d349c250$
Bonjour,

Dans mon formulaire d'access 2000, je souhaiterais faire
une liste modifiable contenant les polices de mon
ordinateur.

Que dois-je écrire dans mon code ?

Merci

Nicolas
Avatar
Jessy SEMPERE
Bonjour

en complément, voici la fonction AddressOf pour Access 97
******************************************
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String

Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
******************************************

--
@+
Jessy Sempere - Access MVP

------------------------------------
Site @ccess : http://access.jessy.free.fr/
Pour l'efficacité de tous :
http://users.skynet.be/mpfa/
------------------------------------
"Michel Walsh" a écrit dans le message
news: #
Salut,


Voir la page "Enumerating Windows Fonts by Type" ou "Enumerating
Windows Fonts with Preview" ou "Enumerating Windows Fonts - Callback vs.
VB" ( dans ce dernier cas, noter que VBA6 possède AddressOf, donc OK avec
Access 2000, pas Access 97 par contre) du site http://www.mvps.org/vbnet/



Espérant être utile,
Vanderghast, Access MVP


"Nicolas" wrote in message
news:088601c3c55e$d349c250$
Bonjour,

Dans mon formulaire d'access 2000, je souhaiterais faire
une liste modifiable contenant les polices de mon
ordinateur.

Que dois-je écrire dans mon code ?

Merci

Nicolas




Avatar
Jessy SEMPERE
euh j'ai oublier les déclaration API :

'** Déclaration API pour reproduire fonction AddressOf
Private Declare Function GetCurrentVbaProject _
Lib "vba332.dll" Alias "EbGetExecutingProj" _
(hProject As Long) As Long

Private Declare Function GetFuncID _
Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hProject As Long, ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long

Private Declare Function GetAddr _
Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, ByVal strFunctionId As String, _
ByRef lpfn As Long) As Long


--
@+
Jessy Sempere - Access MVP

------------------------------------
Site @ccess : http://access.jessy.free.fr/
Pour l'efficacité de tous :
http://users.skynet.be/mpfa/
------------------------------------
"Jessy SEMPERE" a écrit dans le message news:
brs9ld$j8$
Bonjour

en complément, voici la fonction AddressOf pour Access 97
******************************************
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String

Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
******************************************

--
@+
Jessy Sempere - Access MVP

------------------------------------
Site @ccess : http://access.jessy.free.fr/
Pour l'efficacité de tous :
http://users.skynet.be/mpfa/
------------------------------------
"Michel Walsh" a écrit dans le
message

news: #
Salut,


Voir la page "Enumerating Windows Fonts by Type" ou "Enumerating
Windows Fonts with Preview" ou "Enumerating Windows Fonts - Callback
vs.


VB" ( dans ce dernier cas, noter que VBA6 possède AddressOf, donc OK
avec


Access 2000, pas Access 97 par contre) du site
http://www.mvps.org/vbnet/





Espérant être utile,
Vanderghast, Access MVP


"Nicolas" wrote in message
news:088601c3c55e$d349c250$
Bonjour,

Dans mon formulaire d'access 2000, je souhaiterais faire
une liste modifiable contenant les polices de mon
ordinateur.

Que dois-je écrire dans mon code ?

Merci

Nicolas








Avatar
Nicolas
Merci pour vos réponses, mais je suis sous Access 2000 et
pas vb6 or les exemples donnés sont pour vb6.

Nicolas
Avatar
Michel Walsh
Salut,


Cela ne devrait pas poser de problèmes pour le code qui ne touche pas le
formulaire... Je regarde si je ne peux pas convertir rapidement....


Vanderghast, Access MVP


"Nicolas" wrote in message
news:070e01c3c56b$541c9e00$
Merci pour vos réponses, mais je suis sous Access 2000 et
pas vb6 or les exemples donnés sont pour vb6.

Nicolas
Avatar
Nicolas
Justement ça pose en problème car Access ne connait pas le
Me.HdC, que faire ?

Nicolas
Avatar
Michel Walsh
Salut,



pas de problème, GetDC est là pour celà...


Derrière le formulaire:


============ Option Compare Database
Option Explicit
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Sub Command2_Click()
Dim hDC As Long
hDC = GetDC(Me.hwnd)
'Add system fonts using a callback
Me.List0.RowSourceType = "Value List"
Me.List0.RowSource = vbNullString

'Add the fonts using the API and callback by calling
'the EnumFontFamilies API, passing the AddressOf the
'application-defined callback procedure EnumFontFamProc
'and the list to fill
EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProc, Me.List0

End Sub
===============
et, le code légèrement modifié de Randy (une seule ligne) dans un module:

=============== Option Compare Database
Option Explicit


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2003 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Font enumeration types
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

Public 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(LF_FACESIZE) As Byte
End Type

Public Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type

'ntmFlags field flags
Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&

'tmPitchAndFamily flags
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4

Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0

'EnumFonts Masks
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4

Public Declare Function EnumFontFamilies Lib "gdi32" _
Alias "EnumFontFamiliesA" _
(ByVal hDC As Long, _
ByVal lpszFamily As String, _
ByVal lpEnumFontFamProc As Long, _
LParam As Any) As Long



Public Function EnumFontFamProc(lpNLF As LOGFONT, _
lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, _
LParam As ListBox) As Long

Dim FaceName As String

'convert the returned string from Unicode to ANSI
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)

'add the font to the list
' LParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
' ****** MODIFIÉ POUR ACCESS
LParam.RowSource = LParam.RowSource & ";" & Left$(FaceName,
InStr(FaceName, vbNullChar) - 1)

'return success to the call
EnumFontFamProc = 1

End Function
=================



Vanderghast, Access MVP

"Nicolas" wrote in message
news:086601c3c56e$356aec20$
Justement ça pose en problème car Access ne connait pas le
Me.HdC, que faire ?

Nicolas