Discussion :

[Al__22]

Bonjour le forum,

Je me permet d'ouvrir ce thread dans le but de créer un nouveau type de code pour une fonction qui a été demandé récemment sur le forum et auquel j'avais répondu totalement à côtés

En m'y penchant d'un peu plus prés et en faisant des recherches sur ce type de fonction je suis toujours tombé sur des codes de 3 m de long et/ou peu pratiques à comprendre et/ou à mettre en marche.
Ma question est donc :
"A-t-on un moyen (comme dans access avec TextWidth) de mesurer facilement la taille (pixel ou cm je suis pas chiant non plus ) d'un texte" (C'est à dire dans un code de moins de 50 lignes et compréhensible)

Voici mes bases (oui j'en ai deux) :
- 1er chemin : utiliser le autosize d'une colonne ou d'un Label (mais dans les deux cas il y a des espaces en plus et cela va dépendre de la résolution du moniteur de chacun )
- 2e chemin : utiliser des API (fastidieux je trouve mais surement plus juste)

Pour ce qui est des API je pensais à :
- GetMapMode32
- SetMapMode32
- CreateFont32
- GetDC32

Donc si quelqu'un à d'autres pistes à présenter ou même une microscopique idée je suis preneur

[Jean-Philippe André]

Salut,
Est-ce que la litterature suivante te donne des infos :

http://fring.developpez.com/vba/excel/zonetxt/
http://claudeleloup.developpez.com/t...ter-taille-sf/

[Al__22]

Bonjour jpcheck

En effet c'est plutôt intéressant mais ça ne m'aide pas vraiment.
Dans le premier lien je ne vois pas ou on mesure un texte (autre que le moment ou tu es obligé de mettre manuellement dans le code de quel type de police/taille/etc. il s'agit)
Dans le deuxième on ne parle que de hauteur de forme. De plus il s'agit d'access donc pas forcément transposable dans excel.

Malgré tout je vais approfondir un peu et voir ce que je peux faire avec ces infos merci

[pijaku]

Bonjour,

Ces fonctions ont été créées par UcFoutu
Tout ce dont tu as besoin y est, mais tu utiliseras surement les fonctions vba_TextWidth et vba_TextHeight...

[Al__22]

Merci pijaku

Je connaissais pas du tout et en effet ça marche du tonnerre

Par contre c'est pour moi beaucoup trop long même en enlevant ce qui ne sert à rien (juste pour ce cas ci soyons d'accord). Et en plus tu est obligé de déclarer ta police en dehors de la fonction elle même :

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
Option Explicit
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 * 32 '
End Type
Public Type hv
   X As Long
   Y As Long
End Type
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, _
  ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 ' code libre d'utilisation et/ou diffusion. Seule obligation : y ajouter la mention suivante :
 ' ******code provenant du forum VBFrance de Codes-Sources - Auteur : ucfoutu*************
Public vba_font As New StdFont
Public Function vba_TextWidth(texte As String, la_font As StdFont) As Single
    vba_TextWidth = dimt(texte, la_font).X
End Function
Public Function vba_TextHeight(texte As String, la_font As StdFont) As Single
    vba_TextHeight = dimt(texte, la_font).Y
End Function
Private Function dimt(ch As String, ByVal pol As StdFont) As hv
    Dim cdc As Long, ccb As Long, cfi As Long, lgf As LOGFONT, tch As hv
    cdc = CreateDC("DISPLAY", "", "", ByVal 0)
    ccb = CreateCompatibleBitmap(cdc, 1, 1)
    DeleteObject SelectObject(cdc, ccb)
    lgf.lfFaceName = pol.Name & Chr$(0): lgf.lfHeight = -MulDiv(pol.Size, GetDeviceCaps(GetDC(0), 90), 72)
    lgf.lfItalic = pol.Italic: lgf.lfStrikeOut = pol.Strikethrough: lgf.lfUnderline = pol.Underline
    lgf.lfWeight = 400
    If pol.Bold = True Then lgf.lfWeight = lgf.lfWeight * 2
    cfi = CreateFontIndirect(lgf)
    DeleteObject SelectObject(cdc, cfi)
    GetTextExtentPoint32 cdc, ch, Len(ch), tch
    DeleteObject cfi: DeleteObject ccb: DeleteDC cdc
    dimt = tch
End Function
 
Sub W_texte()
Dim retx As String
vba_font.Size = Range("B4").Font.Size: vba_font.Name = Range("B4").Font.Name
vba_font.Bold = Range("B4").Font.Bold: vba_font.Italic = Range("B4").Font.Italic 
retx = vba_TextWidth(Range("B4").Value, vba_font)
End Sub

Alors à moins que je soit bêtes (surement le cas) il y a surement un moyen de se dépatouiller pour faire moins long et surtout ne plus être obligé de déclarer sa police en dehors de la fonction (à la rigueur en tant que option de la fonction : T_width( ByVal Texte, NomP as String, TailleP As String, etc.) )

Je vais me pencher dessus et voir ce que je peux faire !

[pijaku]

Voici par exemple.
Difficile tout de même de faire plus court...

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
Option Explicit
'---Cette partie ne peux pas être raccourcie---
'   par contre elle peut être placée dans un module à part
'en changeant les Private par Public
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 * 32 '
End Type
Public Type hv
   X As Long
   Y As Long
End Type
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, _
  ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 ' code libre d'utilisation et/ou diffusion. Seule obligation : y ajouter la mention suivante :
 ' ******code provenant du forum VBFrance de Codes-Sources - Auteur : ucfoutu*************
 'la fonction :
Private Function dimt(ch As String, pol_Name As String, pol_Size As Long, pol_Bold As Boolean, Optional pol_Italic As Byte, Optional pol_Strikethrough As Byte, Optional pol_Underline As Byte) As hv
    Dim cdc As Long, ccb As Long, cfi As Long, lgf As LOGFONT, tch As hv
    cdc = CreateDC("DISPLAY", "", "", ByVal 0)
    ccb = CreateCompatibleBitmap(cdc, 1, 1)
    DeleteObject SelectObject(cdc, ccb)
    lgf.lfFaceName = pol_Name & Chr$(0): lgf.lfHeight = -MulDiv(pol_Size, GetDeviceCaps(GetDC(0), 90), 72)
    lgf.lfItalic = pol_Italic: lgf.lfStrikeOut = pol_Strikethrough: lgf.lfUnderline = pol_Underline
    lgf.lfWeight = 400
    If pol_Bold = True Then lgf.lfWeight = lgf.lfWeight * 2
    cfi = CreateFontIndirect(lgf)
    DeleteObject SelectObject(cdc, cfi)
    GetTextExtentPoint32 cdc, ch, Len(ch), tch
    DeleteObject cfi: DeleteObject ccb: DeleteDC cdc
    dimt = tch
End Function
'l'appel de la fonction :
Sub W_texte()
Dim retx As Long
With Range("B4")
    retx = dimt(.Value, .Font.Name, .Font.Size, .Font.Bold, .Font.Italic).X
End With
MsgBox retx
End Sub