Taille police suivant Hauteur de zoneRésolu

Question

Avé..

Je cherche une solution afin que lorsque j'imprime un texte, le logiciel change la hauteur de la police suivant une hauteur que je fixe.

Voici ma procédure d'affichage. "Elle est-ce qu'elle est.. mais bon". Merci de votre aide ou piste à suivre... :

Public Sub DrawPrint(ByRef oDest As Object, ByVal hdc As Long, ByVal Texte As String, ByVal x As Long, ByVal y As Long, _
                    ByVal FontColor As Long, ByVal Gras As Boolean, _                    Optional ByVal lWidth As Long 200, Optional ByVal lheight As Long 50, _                    Optional ByVal Gauche As Boolean True, Optional ByVal lSize As Long 13, Optional ByVal lAngle As Long, _
                    Optional ByVal bAlignLibelleLeft As Boolean = False)
                    
    '
    If Texte = vbNullString Then Exit Sub
    '
    Dim typRect      As RECT
    Dim typRectTempo   As RECT
    Dim retval    As Long
    Dim hPen      As Long
    Dim hOldPen   As Long
    Dim lColor    As Long
    Dim hFont     As Long
    Dim hOldFont  As Long
    Dim lGras     As Long
    Dim lFormat   As Long
    '
    'Type Police
    lAngle = lAngle * 10
    
    If m_IsPrinter Then
        lSize = -MulDiv(lSize, GetDeviceCaps(hdc, LOGPIXELSY), 72)
    End If
    '
    lGras = FW_NORMAL
    If Gras Then lGras = FW_BOLD


    hFont = CreateFont(lSize, 0, lAngle, 0, lGras, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_DONTCARE, "tahoma")
    hOldFont = SelectObject(hdc, hFont)
    '
    hPen = GetTextColor(hdc)
    SetTextColor hdc, FontColor
    '
    retval = SetBkMode(hdc, TRANSPARENT)
    '
    With typRect
        .Top = y
        .bottom = y + lheight
        .Left = x
        .Right = x + lWidth
    End With
    '
    If Gauche Then
        If lWidth = -1 Then
            lFormat = DT_CALCRECT Or DT_SINGLELINE
        Else
            lFormat = DT_CALCRECT Or DT_SINGLELINE Or DT_END_ELLIPSIS
        End If
        DrawText hdc, Texte, Len(Texte), typRect, lFormat
        lFormat = DT_SINGLELINE Or DT_LEFT Or DT_VCENTER Or DT_NOCLIP Or DT_NOPREFIX Or DT_END_ELLIPSIS
    Else
        lFormat = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS
    End If


    If bAlignLibelleLeft Then
        typRect.Left = x - (typRect.Right - typRect.Left)
    End If
    typRect.bottom = y + lheight
    
    DrawText hdc, Texte, Len(Texte), typRect, lFormat


    retval = SelectObject(hdc, hOldFont)
    retval = DeleteObject(hFont)
End Sub

peug · Accepted Answer

Grr.. C'est toujours pareil, c'est en posant la question que je trouve une solution. Voici le code que j'ai trouvé sur un site allemand :


Private Declare Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long


Private Sub DrawRotatedText(ByVal txt As String, _
    ByVal hgt As Long, ByVal wid As Long, _
    ByVal X As Single, ByVal Y As Single, _
    ByVal font_name As String, _
    ByVal weight As Long, ByVal escapement As Long, _
    ByVal use_italic As Boolean, ByVal use_underline As _
        Boolean, _
    ByVal use_strikethrough As Boolean)


Const CLIP_LH_ANGLES = 16   ' Needed for tilted fonts.
Const PI = 3.14159625
Const PI_180 = PI / 180#


Dim newfont As Long
Dim oldfont As Long


    newfont = CreateFont(hgt, wid, _
        escapement, escapement, weight, _
        use_italic, use_underline, _
        use_strikethrough, 0, 0, _
        CLIP_LH_ANGLES, 0, 0, font_name)
    
    ' Select the new font.
    oldfont = SelectObject(hdc, newfont)
    
    ' Display the text.
    CurrentX = X
    CurrentY = Y
    Print txt


    ' Restore the original font.
    newfont = SelectObject(hdc, oldfont)
    
    ' Free font resources (important!)
    DeleteObject newfont
End Sub




Private Sub Form_Resize()
Const PI = 3.14159625
Const FW_NORMAL = 400   ' Normal font weight.


Dim I As Long
Dim cx As Long
Dim cy As Long
Cls
    AutoRedraw = True


    DrawRotatedText "Stretched", Me.Height / 50, 10, 10, 20, _
        "Times New Roman", FW_NORMAL, 3600, False, _
        False, False
    DrawRotatedText "Stretched", 10, 20, 10, 30, _
        "Times New Roman", FW_NORMAL, 3600, False, _
        False, False
    DrawRotatedText "Stretched", 10, 30, 10, 40, _
        "Times New Roman", FW_NORMAL, 3600, False, _
        False, False
    DrawRotatedText "Squeezed", 30, 10, 10, 50, _
        "Times New Roman", FW_NORMAL, 3600, False, _
        False, False
    DrawRotatedText "Squeezed", 30, 5, 10, 70, _
        "Times New Roman", FW_NORMAL, 3600, False, _
        False, False
    DrawRotatedText "Squeezed", 30, 3, 10, 90, _
        "Times New Roman", FW_NORMAL, 3600, False, _
        False, False


    cx = ScaleWidth - 20
    cy = ScaleHeight - 20
    For I = 90 To 180 Step 20
        DrawRotatedText "     Some Rotated Text", 20, 0, _
            cx + Cos(I / 180 * PI), _
            cy + Sin(I / 180 * PI), _
            "Times New Roman", FW_NORMAL, I * 10, _
            False, False, False
    Next I
End Sub

Taille police suivant Hauteur de zone

1 réponse

Votre réponse

Discussions similaires