Dimensions graphiques vba (équivalents de scalex, scaley, twipsperpixelx, twipsperpixely, textwidth et textheight de vb6)
Soyez le premier à donner votre avis sur cette source.
Snippet vu 7 347 fois - Téléchargée 21 fois
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)
'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
- Dimensions graphiques vba (équivalents de scalex, scaley, twipsperpixelx, twipsperpixely, textwidth et textheight de vb6)
- Vba tableau 2 dimensions ✓ - Forum Visual Basic
- Byval vba - Conseils pratiques -Visual Basic / VB.NET
- Malloc tableau 2 dimensions ✓ - Forum C
- Vba doevents - Conseils pratiques -Visual Basic / VB.NET
- Redim Preserve avec tableau 2 dimensions ✓ - Forum VBA Office (Excel, Word ...)
10 avril 2012 à 11:32
Pour ne rien te cacher : c'est le seul intérêt réel que j'y trouve également, car pour le reste ... J'estime que Excel, dont la vocation est celle d'un tableur, n'a pas à "faire mumuse" avec d'autres "choses".
Mais pendant qu'on y était et puisque certains paraissaient être intéressés (discussion récente), voilà qui est maintenant fait.
10 avril 2012 à 10:36
Perso, vba_TextWidth me sera d'une grande utilité.
Cool
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.