De: Laurent Longre <laurent.longre@free.fr>
Objet: Re: GetTextWidth API from Excel
Date : vendredi 22 septembre 2000 01:15


ds908@earthlink.net a &eacute;crit :
> 
> Is there a way I can have Excel 97/2000 make an API call and get the
> width of a string based on the string's contents, font, point size,
> bold, etc.? The width would be returned as pixels/twips, whatever.
> typically, calling this sort of API requires a handle to a device
> context. That can be done in VC++ or VB. But how/where, does one get a
> handle to a device context in Excel VBA?
> 
> Thanks, this is a tough one.

The following VBA function DimTexte(Texte, Police, Taille, Gras,
Italique) returns the size in pixels of the string "Texte".

Sorry, the names of the arguments are in French, and I am too lazy to
translate them in english... :-(

- Police = font name (for instance "Times New Roman")
- Taille = size in points (for instance 12)
- Gras = bold attribute (True / False - False by default)
- Italique = italic attribute (True / False - False by default)

The returned value is this structure :

Type SDimTexte
  Largeur As Long
  Hauteur As Long
End Type

Largeur = Width in pixels
Hauteur = Height in pixels

For instance :

Dim TextSize As SDimTexte
TextSize = DimTexte("Hello, world !", "Arial", 20, True, True)
MsgBox "Width = " & TextSize.Largeur & " pixels - Height = " _
  & TextSize.Hauteur & " pixels"

The Test Sub below inserts a DropDown control in a new CommandBar, fills
it with some strings, and then fits the size of the control with the
size (in pixels) of the longest string.

Hope this helps,

Laurent

MVP Excel

'====================================================================

Type SDimTexte
  Largeur As Long
  Hauteur As Long
End Type

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 CreateFontA Lib "Gdi32" _
  (ByVal H As Long, ByVal W As Long, ByVal E As Long, _
  ByVal O As Long, ByVal W As Long, ByVal I As Long, _
  ByVal u As Long, ByVal S As Long, ByVal C As Long, _
  ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
  ByVal PAF As Long, ByVal F 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 GetTextExtentPoint32A Lib "Gdi32" _
  (ByVal hDC As Long, ByVal lpsz As String, _
  ByVal cbString As Long, lpSize As SDimTexte) As Long
  
Private Declare Function GetDeviceCaps Lib "Gdi32" _
  (ByVal hDC As Long, ByVal nIndex As Long) As Long

'____________________________________________________________

Private Function DimTexte(Texte As String, Police As String, _
  Taille As Double, Optional Gras As Boolean, _
  Optional Italique As Boolean) As SDimTexte

  Dim hFont As Long, hDC As Long
  Dim PixpInch As Double

  hDC = GetDC(0)
  PixpInch = GetDeviceCaps(hDC, 90) / 72
  hFont = CreateFontA(-Taille * PixpInch, 0, 0, 0, _
    400 - 300 * Gras, -Italique, 0, 0, 1, 0, 0, 0, 0, Police)
  If hFont Then
    SelectObject hDC, hFont
    GetTextExtentPoint32A hDC, Texte, Len(Texte), DimTexte
    DeleteObject hFont
  End If
  ReleaseDC 0, hDC

End Function

'____________________________________________________________

Sub Test()

  ' Cr&eacute;ation d'un contrôle DropDown sur une barre d'outils
  ' avec ajustement automatique sur la largeur de l'&eacute;l&eacute;ment
  ' le plus long
  
  Dim Ctrl As CommandBarComboBox, Elt
  Dim TempL As Integer, LargeurMax As Integer

  ' Cr&eacute;ation d'une nouvelle barre d'outils

  On Error Resume Next
  Application.CommandBars("Zaza").Delete
  On Error GoTo 0
  Application.CommandBars.Add("Zaza").Visible = True
  
  ' Cr&eacute;ation du contrôle et recherche du texte le plus long

  set Ctrl = Application.CommandBars("Zaza") _
    .Controls.Add(msoControlDropdown)
  For Each Elt In Array("Arm", "Stram", "Gram", _
  "Pic et pic et colegram", "Bourre et bourre et ratatam")
    Ctrl.AddItem Elt
    ' Tahoma 8 = police des CommandBarControls
    TempL = DimTexte(CStr(Elt), "Tahoma", 8).Largeur
    If TempL > LargeurMax Then LargeurMax = TempL
  Next Elt

  ' Ajustement de la largeur du contrôle

  Ctrl.DropDownWidth = -1
  Ctrl.Width = LargeurMax + 20  ' (marge de 20 pixels suppl&eacute;mentaire)
  Ctrl.ListIndex = 1

End Sub

'==================================================================== 