Zones de textes/Etiquettes/Boutons auto-extensibles [Sources]

**Arkham46** · 30/05/2006, 22h21

Redimensionne un contrôle en fonction du texte contenu.

Tiens compte de la police de caractères, des marges et des bordures.

Fonctionne pour une Zone de Texte, une Etiquette ou un Bouton (de commande ou bascule)

Utilise joyeusement les API, ne nécessite pas le passage en mode création du formulaire.

Code à placer dans un module :

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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
Option Compare Database
Option Explicit
 
' Rectangle pour API
Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
' API
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal font_height As Long, _
                                                                     ByVal font_width As Long, ByVal escapement As Long, ByVal orientation As Long, _
                                                                     ByVal weight As Long, ByVal italic As Long, ByVal underscore As Long, _
                                                                     ByVal strikeout As Long, ByVal character_set As Long, ByVal output_precision As Long, _
                                                                     ByVal clipping_precision As Long, ByVal quality As Long, ByVal pitch_and_family As Long, _
                                                                     ByVal face_name 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 Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" _
                                    (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, _
                                     lpRect As RECT, ByVal un As Long, lpDrawTextParams As Any) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
' Constantes
Private Const DT_CALCRECT = &H400
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
 
'---------------------------------------------------------------------------------------
' Renvoie la taille d'un texte en pixel
'---------------------------------------------------------------------------------------
' pControl      : Contrôle contenant le texte
' pText         : Texte à écrire
' pWidth        : Largeur du texte
' pHeight       : Hauteur du texte
'---------------------------------------------------------------------------------------
Private Function GetTextLength(pControl As Access.Control, ByVal pText As String, pWidth As Long, pHeight As Long)
    Dim lRc As RECT      ' Rectangle qui contient la taille du texte
    Dim lTextDC As Long  ' Contexte d'affichage temporaire
    Dim lTmpFont As Long    ' Police de caractères temporaire
    Dim lOldFont As Long    ' Ancienne police de caractères
    Dim lTextFlag As Long
    Dim lBorderWidth As Long
    ' Crée un contexte d'affichage de travail
    lTextDC = CreateCompatibleDC(0)
    ' Crée et sélectionne la nouvelle police de caractère en fonction des données du contrôle
    lTmpFont = CreateFont(FontSizeToHeight(pControl.FontSize), 0, 0, 0, pControl.FontWeight, pControl.FontItalic, pControl.FontUnderline, False, 0, 7, 16, 0, 0, pControl.FontName)
    lOldFont = SelectObject(lTextDC, lTmpFont)
    ' On initialise le rectangle
    lRc.right = pWidth
    ' Si le texte est vide on ajoute un caractère
    If pText = "" Then pText = "Ü"
    ' Dessine le texte et récupère la taille grâce à DT_CALCRECT
    lTextFlag = DT_CALCRECT
    DrawTextEx lTextDC, pText, Len(pText), lRc, lTextFlag, ByVal 0
    ' Supprime les objets temporaires
    SelectObject lTextDC, lOldFont
    DeleteObject lTmpFont
    DeleteDC lTextDC
    ' Ajoute la taille de la bordure
    On Error Resume Next
    If pControl.BorderStyle <> 0 Then
        lBorderWidth = pControl.BorderWidth
        If lBorderWidth = 0 Then lBorderWidth = 1
    End If
    On Error GoTo 0
    lBorderWidth = (567 * lBorderWidth) / 28
    ' Calcul de la taille du texte en twips
    pWidth = PixelToTwipsX(lRc.right - lRc.left + 4) + lBorderWidth
    pHeight = PixelToTwipsY(lRc.bottom - lRc.top) + lBorderWidth
End Function
 
'---------------------------------------------------------------------------------------
' Convertion de la taille de police pour la fonction CreateNewFont
'---------------------------------------------------------------------------------------
' pFontSize : Valeur à convertir
' Renvoie la valeur convertie pour CreateNewFont
'---------------------------------------------------------------------------------------
Private Function FontSizeToHeight(pFontSize As Long) As Long
    Static Mult As Single
    Dim hdc As Long
    If Mult = 0 Then
        hdc = GetDC(0)
        Mult = -GetDeviceCaps(hdc, LOGPIXELSY) / 72
        ReleaseDC 0, hdc
    End If
    FontSizeToHeight = CLng(pFontSize * Mult)
End Function
 
'---------------------------------------------------------------------------------------
' Converti les Pixels en Twips sur l'axe horizontal
'---------------------------------------------------------------------------------------
' pPixelsX : Valeur à convertir en Pixels
' Renvoie la valeur convertie en Twips
'---------------------------------------------------------------------------------------
Private Function PixelToTwipsX(pPixelsX As Long) As Long
    Static Mult As Long
    Dim hdc As Long
    If Mult = 0 Then
        hdc = GetDC(0)
        Mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSX)
        ReleaseDC 0, hdc
    End If
    PixelToTwipsX = pPixelsX * Mult
End Function
 
'---------------------------------------------------------------------------------------
' Converti les Pixels en Twips sur l'axe vertical
'---------------------------------------------------------------------------------------
' pPixelsY : Valeur à convertir en Pixels
' Renvoie la valeur convertie en Twips
'---------------------------------------------------------------------------------------
Private Function PixelToTwipsY(pPixelsY As Long) As Long
    Static Mult As Single
    Dim hdc As Long
    If Mult = 0 Then
        hdc = GetDC(0)
        Mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If
    PixelToTwipsY = pPixelsY * Mult
End Function
 
'---------------------------------------------------------------------------------------
' Calcul la taille du texte et redimensionne le contrôle
'---------------------------------------------------------------------------------------
' pCtrl : Contrôle à redimensionner
' pSize : Redimensionne le contrôle si Vrai
' pX    : Largeur du texte
' pY    : Hauteur du texte
'---------------------------------------------------------------------------------------
Public Function CtrlAutoSize(pCtrl As Access.Control, Optional pSize As Boolean = True, Optional pX As Long, Optional pY As Long)
    Dim lWidth As Long, lHeight As Long
    Dim lTexte As String
    On Error Resume Next
    Select Case pCtrl.ControlType
    Case acTextBox    'Zone de texte
        lTexte = Nz(pCtrl.Text)
        If Err.Number = 2185 Then
            On Error Resume Next
            lTexte = Nz(pCtrl.Value)
        End If
    Case acLabel, acCommandButton, acToggleButton  ' Etiquette ou Bouton
        lTexte = Nz(pCtrl.Caption)
    End Select
    ' Taille du texte
    On Error GoTo Gestion_Erreurs
    GetTextLength pCtrl, lTexte, lWidth, lHeight
    ' Ajoute les marges
    If pCtrl.ControlType = acTextBox Or pCtrl.ControlType = acLabel Then
        lWidth = lWidth + pCtrl.LeftMargin + pCtrl.RightMargin
        lHeight = lHeight + pCtrl.BottomMargin + pCtrl.TopMargin
    End If
    ' Ajoute 5% autour du texte pour les boutons (les 5% sont empiriques)
    If pCtrl.ControlType = acCommandButton Or pCtrl.ControlType = acToggleButton Then
        lWidth = lWidth + lWidth * 0.05
        lHeight = lHeight + lHeight * 0.05
    End If
    ' Renvoit la largeur et la hauteur dans les paramètres
    pX = lWidth
    pY = lHeight
    ' Redimensionne le contrôle
    If pSize Then
        pCtrl.Width = lWidth
        pCtrl.Height = lHeight
    End If
Gestion_Erreurs:
    If Err.Number <> 0 Then MsgBox Err.Number & ":" & Err.Description
End Function
'

Exemple dans l'événement Sur activation

Code :

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

1
2
3
Private Sub Form_Current()
CtrlAutoSize Me.MaZoneDeTexte
End Sub

Pour récupérer la taille sans redimensionner :

Code :

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

1
2
3
4
5
 
Dim lWidth as Long
Dim lHeight as Long
CtrlAutoSize Me.MaZoneDeTexte,False,lWidth,lHeight
MsgBox lWidth & " : " & lHeight

**Tofalu** · 31/05/2006, 11h31

C'est vraiment sympa comme code source

Zones de textes/Etiquettes/Boutons auto-extensibles [Sources]

Contribuez

Discussions similaires

Partager

Partager