Modulo Clase para dibujar texto utilizando GDI+ tiene funciones básicas como poder asignar la fuente, color, alineación, alineación vertical, Flags del formato, Trimming, Opacity. Para los que ya utilizaron alguna vez el api DrawText de «User32» no les resultara muy difícil de implementar.
Option Explicit
'--------------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 27/12/2009
'--------------------------------------------
Private Declare Function GdipCreateFont Lib "gdiplus" (ByVal fontFamily As Long, ByVal emSize As Single, ByVal Style As GDIPLUS_FONTSTYLE, ByVal UNIT As Long, createdfont As Long) As Long
Private Declare Function GdipCreateFontFamilyFromName Lib "gdiplus" (ByVal name As String, ByVal fontCollection As Long, fontFamily As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, brush As Long) As Long
Private Declare Function GdipCreateStringFormat Lib "gdiplus" (ByVal formatAttributes As Long, ByVal language As Integer, StringFormat As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal brush As Long) As Long
Private Declare Function GdipDeleteFont Lib "gdiplus" (ByVal curFont As Long) As Long
Private Declare Function GdipDeleteFontFamily Lib "gdiplus" (ByVal fontFamily As Long) As Long
Private Declare Function GdipDeleteStringFormat Lib "gdiplus" (ByVal StringFormat As Long) As Long
Private Declare Function GdipDrawString Lib "gdiplus" (ByVal graphics As Long, ByVal str As String, ByVal Length As Long, ByVal thefont As Long, layoutRect As RECTF, ByVal StringFormat As Long, ByVal brush As Long) As Long
Private Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal Align As StringAlignment) As Long
Private Declare Function GdipSetStringFormatLineAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal Align As StringAlignment) As Long
Private Declare Function GdipSetStringFormatFlags Lib "GdiPlus.dll" (ByVal mFormat As Long, ByVal mFlags As StringFormatFlags) As Long
Private Declare Function GdipSetStringFormatTrimming Lib "GdiPlus.dll" (ByVal mFormat As Long, ByVal mTrimming As StringTrimming) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal Hdc As Long, hGraphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal Hdc As Long, ByVal nIndex 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 Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECTF
Left As Single
Top As Single
Width As Single
Height As Single
End Type
Public Enum GDIPLUS_FONTSTYLE
FontStyleRegular = 0
FontStyleBold = 1
FontStyleItalic = 2
FontStyleBoldItalic = 3
FontStyleUnderline = 4
FontStyleStrikeout = 8
End Enum
Public Enum StringAlignment
StringAlignmentNear = &H0
StringAlignmentCenter = &H1
StringAlignmentFar = &H2
End Enum
Public Enum StringTrimming
StringTrimmingNone = &H0
StringTrimmingCharacter = &H1
StringTrimmingWord = &H2
StringTrimmingEllipsisCharacter = &H3
StringTrimmingEllipsisWord = &H4
StringTrimmingEllipsisPath = &H5
End Enum
Public Enum StringFormatFlags
StringFormatFlagsNone = &H0
StringFormatFlagsDirectionRightToLeft = &H1
StringFormatFlagsDirectionVertical = &H2
StringFormatFlagsNoFitBlackBox = &H4
StringFormatFlagsDisplayFormatControl = &H20
StringFormatFlagsNoFontFallback = &H400
StringFormatFlagsMeasureTrailingSpaces = &H800
StringFormatFlagsNoWrap = &H1000
StringFormatFlagsLineLimit = &H2000
StringFormatFlagsNoClip = &H4000
End Enum
Private Const LOGPIXELSY As Long = 90
Private m_Font As StdFont
Private m_Color As OLE_COLOR
Private m_Alignment As StringAlignment
Private m_VerticalAlignment As StringAlignment
Private m_FormatFlags As StringFormatFlags
Private m_Trimming As StringTrimming
Private m_Opacity As Long
Private Sub Class_Initialize()
Set m_Font = New StdFont
m_Font.name = "Tahoma"
m_Color = vbWindowText
m_Opacity = 100
End Sub
Private Sub Class_Terminate()
Set m_Font = Nothing
End Sub
Public Property Get Font() As StdFont
Set Font = m_Font
End Property
Public Property Let Font(ByVal NewFont As StdFont)
Set m_Font = NewFont
End Property
Public Property Get Color() As OLE_COLOR
Color = m_Color
End Property
Public Property Let Color(ByVal NewColor As OLE_COLOR)
m_Color = NewColor
End Property
Public Property Get Alignment() As StringAlignment
Alignment = m_Alignment
End Property
Public Property Let Alignment(ByVal NewAlignment As StringAlignment)
m_Alignment = NewAlignment
End Property
Public Property Get VerticalAlignment() As StringAlignment
VerticalAlignment = m_VerticalAlignment
End Property
Public Property Let VerticalAlignment(ByVal NewVerticalAlignment As StringAlignment)
m_VerticalAlignment = NewVerticalAlignment
End Property
Public Property Get FormatFlags() As StringFormatFlags
FormatFlags = m_FormatFlags
End Property
Public Property Let FormatFlags(ByVal NewFormatFlags As StringFormatFlags)
m_FormatFlags = NewFormatFlags
End Property
Public Property Get Trimming() As StringTrimming
Trimming = m_Trimming
End Property
Public Property Let Trimming(ByVal NewTrimming As StringTrimming)
m_Trimming = NewTrimming
End Property
Public Property Get Opacity() As Long
Opacity = m_Opacity
End Property
Public Property Let Opacity(ByVal NewOpacity As Long)
m_Opacity = NewOpacity
If m_Opacity < 0 Then
Opacity = 0
ElseIf m_Opacity > 100 Then
m_Opacity = 100
End If
End Property
Public Function DrawString(ByVal Hdc As Long, _
ByVal Text As String, _
ByVal X As Single, _
ByVal Y As Single, _
Optional ByVal Width As Single, _
Optional ByVal Height As Single) As Boolean
On Error Resume Next
Dim hGraphic As Long
Dim lBrush As Long
Dim lFontFamily As Long
Dim lCurrentFont As Long
Dim lFontSize As Long
Dim lFontStyle As GDIPLUS_FONTSTYLE
Dim lFormat As Long
Dim RctText As RECTF
Dim GdiToken As Long
Dim GDIsi As GdiplusStartupInput
GDIsi.GdiplusVersion = 1&
If GdiplusStartup(GdiToken, GDIsi) = 0 Then
Call GdipCreateFromHDC(Hdc, hGraphic)
GdipCreateSolidFill ConvertColor(m_Color, m_Opacity), lBrush
GdipCreateFontFamilyFromName StrConv(m_Font.name, vbUnicode), 0, lFontFamily
If m_Font.Bold Then lFontStyle = lFontStyle Or FontStyleBold
If m_Font.Italic Then lFontStyle = lFontStyle Or FontStyleItalic
If m_Font.Strikethrough Then lFontStyle = lFontStyle Or FontStyleStrikeout
If m_Font.Underline Then lFontStyle = lFontStyle Or FontStyleUnderline
lFontSize = MulDiv(m_Font.Size, GetDeviceCaps(Hdc, LOGPIXELSY), 72)
GdipCreateFont lFontFamily, lFontSize, lFontStyle, 0, lCurrentFont
If GdipCreateStringFormat(0, 0, lFormat) = 0 Then
If m_FormatFlags Then GdipSetStringFormatFlags lFormat, m_FormatFlags
If m_Alignment Then GdipSetStringFormatAlign lFormat, m_Alignment
If m_Trimming Then GdipSetStringFormatTrimming lFormat, m_Trimming
If m_VerticalAlignment Then GdipSetStringFormatLineAlign lFormat, m_VerticalAlignment
End If
With RctText
.Left = X
.Top = Y
.Width = Width
.Height = Height
End With
DrawString = GdipDrawString(hGraphic, StrConv(Text, vbUnicode), -1, lCurrentFont, RctText, lFormat, lBrush) = 0
GdipDeleteStringFormat lFormat
GdipDeleteFont lCurrentFont
GdipDeleteFontFamily lFontFamily
GdipDeleteBrush lBrush
GdipDeleteGraphics hGraphic
GdiplusShutdown GdiToken
End If
End Function
Private Function ConvertColor(Color As Long, Opacity As Long) As Long
Dim BGRA(0 To 3) As Byte
BGRA(3) = CByte((Abs(Opacity) / 100) * 255)
BGRA(0) = ((Color \ &H10000) And &HFF)
BGRA(1) = ((Color \ &H100) And &HFF)
BGRA(2) = (Color And &HFF)
CopyMemory ConvertColor, BGRA(0), 4&
End Function
