Dimensions graphiques vba (équivalents de scalex, scaley, twipsperpixelx, twipsperpixely, textwidth et textheight de vb6)

Commenter

Contenu du snippet

'Ce module contient des outils qui, présents sous VB6, sont absents sous VBA/Excel, à savoir :
'1) Les méthodes ScaleX et ScaleY, qui permettent de calculer les correspondances de valeurs en échelles graphiques
'2) les propriétés TwipsperPixelX et TwipsPerPixelY qui retournent le nombre de twips par pixel de l'écran
'3) les méthodes TextWidth et TextHeight qui permettrent d'obtenir les dimensions graphiques d'une chaîne de caractères pour les caractéristiques d'une police de caractères.
'4) j'y ai ajouté les fonctions Screen.Width et Screen.Height (dimensions de l'écran)
' Pour ne pas risquer un conflit avec une éventuelle évolution des versions Excel, j'ai ajouter "vba_" devant chacun de ces "outils".
'Nous avons ainsi les outils suivants :

'1) ================ vba_ScaleX et vba_ScaleY ====================================
' qui retournent les correspondances horizontale et verticale et dont la syntaxe d'utilisation est :

' ret = vba_ScaleX(nombre_unites, de_echelle, vers_echelle)
' ret = vba_ScaleY(nombre_unites, de_echelle, vers_echelle)

' dont chacun des paramètres est un numétique (double) et où :
' nombre_unites est le nombre d'unités à transposer
' de_echelle et vers_echelle sont des doubles à représenter par les constantes suivantes :
' vbahimetric
' vbamillimeters (échelle de millimètres)
' vbacentimeters (échelle de centimètres)
' vbapixels (échelle de pixels)
' vbainches (échelle de pouces)
' vbatwips (échelle de twips)
' vbaCharacters (échelle de caractères horizontal = 120 twips par unité et vertical = 240 twips par unité).

'Exemple:
'Dim nb As Double
' nb = 546
' ret = vba_ScaleX(nb, vbahimetric, vbapixels)

'2) ======================= vba_TwipsperPixelX et vba_TwipsPerPixelY ===================
' qui retournent respetivement, pour l'écran : le nombre de twips par pixel horizontalement et verticalement
'et dont la syntaxe d'utilisation est :
' ret = vba_TwipsperPixelX
' ret = vba_TwipsperPixelY

'3) =============================== vba_TextWidth et vba_TextHeight ========================
'retournent les dimensions graphiques en pixels d'une chaîne de caractères utilisant une police spécifiée et ses propriétés spécifiées.
' syntaxe :

'ret = vba_TextWidth(texte, la_font)
'ret = vba_TextHeight(texte, la_font)

'où:
'- texte est la chaîne de caractères dont on veut connaître la dimension
' la_font est la police de caractères appliquée à la chaine texte
'Exemple:
' vba_font.Size = 14 (ou, par exemple : vba_font.size = Textbox1.font.size)
' vba_font.Name = "Arial" (ou, par exemple : vba_font.Name = Textbox1.font.Name)
' vba_font.Bold = True (ou, par exemple : vba_font.Bold = Textbox1.font.Bold)
' vba_font.Italic = False (ou, par exemple : vba_font.Italic = Textbox1.font.Italic)
' etc ... le cas échéant
' retx = vba_TextWidth("coucou", vba_font)
' rety = vba_TextHeight("coucou", vba_font)

'4) ================================== vba_Screen.Width et vba_Screen.Height =============
'Largeur et hauteur de l'écran, en pixels. Mises ici "dans la foulée" (vraiment utiles ?? ===>> mais bon ...)
' syntaxe :
'ret = vba_Screen.Height
'ret = vba_Screen.Width

'Un dernier mot :
' Je n'ai pas voulu commenter ce code car il ne représente aucun intérêt en soi. Seuls les résultats sont utiles.
' Je me suis même demandé s'il n'aurait pas mieux valu mettre ici directement un activex. Je n'ai changé d'avis que
' pour des raisons de sécurité (un activex n'aurait pas permis aux plus prudents de vérifier l'absence d'instructions cachées et malveillantes !)
' Il suffit donc de créer un module et d'y mettre ces outils, alors utilisables, tant depuis un UserForm que depuis une feuille de calcul.
' Ceux qui le préfèreront pourront toujours, s'ils le soufhaitent, créer sur cette base ce qu'ils voudront (activex ou add-in)

Source / Exemple : 


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 Const vbahimetric As Double = (1 / 1000) / 2.54 * 1440
Public Const vbamillimeters As Double = (1 / 10) / 2.54 * 1440
Public Const vbacentimeters As Double = 1 / 2.54 * 1440
Public Const vbapoints As Integer = 20
Public Const vbapixels As Integer = 999 ' n'importe quoi sauf les autres valeurs
Public Const vbainches As Integer = 1440
Public Const vbatwips As Integer = 1
Public Const vbaCharacters As Integer = 120
Public vba_font As New StdFont
Public Type ecran
   Height As Integer
   Width As Integer
End Type

Function vba_ScaleX(nombre_unites As Double, de_echelle As Double, vers_echelle As Double) As Double
   vba_ScaleX = asy("X", nombre_unites, de_echelle, vers_echelle)
End Function

Function vba_ScaleY(nombre_unites As Double, de_echelle As Double, vers_echelle As Double) As Double
   vba_ScaleY = asy("Y", nombre_unites, de_echelle, vers_echelle)
End Function

Function vba_TwipsperPixelX() As Integer
  vba_TwipsperPixelX = tpp("X")
End Function

Function vba_TwipsperPixelY() As Integer
  vba_TwipsperPixelY = tpp("Y")
End Function

Function vba_Screen() As ecran
  vba_Screen.Height = GetSystemMetrics(1)
  vba_Screen.Width = GetSystemMetrics(0)
End Function

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 asy(s As String, Q As Double, U0 As Double, U1 As Double) As Double
   Dim vbapix As Single, k As Integer, k1 As Integer
   vbapix = tpp(s)
   k = IIf(s = "X", 1, 2)
   asy = IIf(U0 = vbapixels, Q * vbapix, Q * U0)
   If U0 = vbaCharacters Then asy = asy * k
   asy = IIf(U1 = vbapixels, asy / vbapix, asy / U1)
   If U1 = vbaCharacters Then asy = asy / k
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
Private Function tpp(s As String) As Single
  Dim axe As Long, gdc As Long
  axe = IIf(s = "X", 88, 90)
  gdc = GetDC(0): tpp = vbainches / GetDeviceCaps(gdc, axe)
  ReleaseDC 0, gdc
End Function

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 (ucfoutu)