Comdlg32.dll -> chosefont - avec saisie de params par défault

Commenter

Contenu du snippet

J'en ait chié pour trouver comment lire les paramétres séléctionés et pour les mettre aussi par défault ... car je n'ait pas trouvé d'exemples précis vu que le type font de vb ne correspond pas du tout au type LOGFONT (surtout pour le Size ...) donc voilà maintenant que je viens de trouver le tout je vous file le code , une grosse partie n'est pas de moi , mais bon , vous ne trouverez pas sur le net un truc fait exprés pour vb , donc je trouvais interessant de la mettre car common dialog trippe chez moi , il me met un message d'erreur , mais je crois maintenant savoir d'où ça vient ... Donc petite astuce pour ceux chez qui l'ocx buggue , changez les flag de l'ocx , et mettez ceux que j'ai mis à la variable cf ... et ça devrais marcher :) .

Alors mettez ce code dans un module , puis appellez-le comme ça :

Set NewFont = ShowFont(OldFont)

Exemple de code :

Faite un form , puis dans form_load mettez :
Dim OldFont as Font
Dim NewFont as Font
OldFont.Bold = False
OldFont.Italic = True
OldFont.Name = "Arial"
OldFont.Size = 12
Set NewFont = ShowFont(OldFont)
Print NewFont.Name
Print NewFont.Size
Print NewFont.Bold
Print NewFont.Italic
etc ...

Source / Exemple : 


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
Const FW_NORMAL = 400
Const FW_BOLD = 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 REGULAR_FONTTYPE = &H400
Const BOLD_FONTTYPE = &H100
Const ITALIC_FONTTYPE = &H200
Const LF_FACESIZE = 32
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const DM_DUPLEX = &H1000&
Const DM_ORIENTATION = &H1&
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
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

' Show Font Dialogs
Private Function ShowFont(Buff as Font) As Font
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim fontname As String, retval As Long
    lfont.lfHeight = (Buff.Size / 3) * 4 ' determine default height
    lfont.lfEscapement = 0   ' angle between baseline and escapement vector
    lfont.lfOrientation = 0  ' angle between baseline and orientation vector
    ' BOLD
    If Buff.Bold = True Then
    lfont.lfWeight = FW_BOLD
    Else
    lfont.lfWeight = FW_NORMAL
    End If
    lfont.lfItalic = Buff.Italic
    lfont.lfUnderline = Buff.Underline
    lfont.lfStrikeOut = Buff.Strikethrough
    lfont.lfOutPrecision = OUT_DEFAULT_PRECIS    ' default precision mapping
    lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
    lfont.lfQuality = DEFAULT_QUALITY            ' default quality setting
    lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
    lfont.lfFaceName = Buff.Name & Chr(0)               ' string must be null-terminated
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)
    CopyMemory ByVal pMem, lfont, Len(lfont)
    cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.hwndOwner = 0
    cf.lpLogFont = pMem           ' pointer to LOGFONT memory block buffer
    cf.rgbColors = RGB(0, 0, 0)   ' black
    cf.iPointSize = 1
    cf.nSizeMin = 8   ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    cf.lStructSize = Len(cf)
    retval = CHOOSEFONT(cf)  ' open the dialog box
    If retval <> 0 Then  ' success
      CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
      fontname = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
      Buff.Name = fontname
      Buff.Size = cf.iPointSize / 10   ' in units of 1/10 point!
      If lfont.lfWeight >= FW_BOLD Then
        Buff.Bold = True
      Else
        Buff.Bold = False
      End If
      If lfont.lfItalic <> 0 Then
        Buff.Italic = True
      Else
        Buff.Italic = False
      End If
      If lfont.lfUnderline <> 0 Then
        Buff.Underline = True
      Else
        Buff.Underline = False
      End If
      If lfont.lfStrikeOut <> 0 Then
        Buff.Strikethrough = True
      Else
        Buff.Strikethrough = False
      End If
    End If
        Set ShowFont = Buff
    ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    retval = GlobalFree(hMem)  ' free the allocated memory
End Function

Conclusion :


Pas de bug connus .

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (akhenathon)