Esta es una función que se encarga de dibujar un texto con un efecto espejado al estilo Windows Vista.
'-----------------------------'
'Autor: Leandro Ascierto
'Fecha: 27/11/2008
'Tercera Revision
'-----------------------------'
Option Explicit
Private Declare Function GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, ByRef lpMetrics As TEXTMETRIC) As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc 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 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 DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetBkMode Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Private Declare Function GetTextColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetBkColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Const DT_CALCRECT As Long = &H400
Private Const DT_BOTTOM As Long = &H8
Private Const DT_SINGLELINE As Long = &H20
Private Const OBJ_FONT As Long = 6
Private Const AC_SRC_OVER As Long = &H0
Public Enum tShadowDirection
sdCenter = 0
sdLeft = 1
sdRight = 2
sdInside = 3
sdOutside = 4
End Enum
Public Enum tPercent
Percent100 = 0
Percent75 = 1
Percent50 = 2
Percent25 = 3
End Enum
Public Function DrawTextReflecion(DestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
Text As String, _
Optional ByVal IgnoreTMDescent As Boolean, _
Optional ByVal WaveIntesity As Long, _
Optional ByVal ShadowDirection As tShadowDirection, _
Optional ByVal Color As OLE_COLOR = -1, _
Optional ByVal ShadowPecent As tPercent = Percent75, _
Optional ByVal BackLight As Boolean = True)
Dim ShadowLeft As Long, ShadowRight As Long
Dim Left As Long, Top As Long, Width As Long, Height As Long
Dim DC As Long, MemDC As Long, hBmp As Long, OldhBmp As Long, OldhFont As Long
Dim BF As BLENDFUNCTION, lBF As Long
Dim TM As TEXTMETRIC
Dim Rec As RECT
Dim i As Integer
Dim Percent As Single
'Calculamos el tamaño del texto
DrawText DestDC, Text, Len(Text), Rec, DT_CALCRECT
Width = Rec.Right
Height = Rec.Bottom
'Creamos un Bitmap
DC = GetDC(0)
MemDC = CreateCompatibleDC(DC)
hBmp = CreateCompatibleBitmap(DC, Width, Height)
OldhBmp = SelectObject(MemDC, hBmp)
ReleaseDC 0&, DC
'Copiamos la fuente de destino
OldhFont = SelectObject(MemDC, GetCurrentObject(DestDC, OBJ_FONT))
'Copiamos el BackMode de destino
SetBkMode MemDC, GetBkMode(DestDC)
'Copiamos el color de texto de destino
SetTextColor MemDC, IIf(Color <> -1, Color, GetTextColor(DestDC))
'Tomamos una captura del destino
StretchBlt MemDC, 0, 0, Width, Height, DestDC, x, y + Height * 2, Width, -Height, vbSrcCopy
OffsetRect Rec, 0, 0
'dibujamos el texto
DrawText MemDC, Text, Len(Text), Rec, DT_BOTTOM Or DT_SINGLELINE
'obtenemos informacion de la metrica de la fuente.
GetTextMetrics MemDC, TM
Select Case ShadowPecent
Case 0: Percent = TM.tmAscent / 1
Case 1: Percent = TM.tmAscent / 1.25
Case 2: Percent = TM.tmAscent / 1.65
Case 3: Percent = TM.tmAscent / 2
Case Else: Percent = TM.tmAscent
End Select
'pintamos el hdc utilizando AlphaBlend para provocar el espejado.
For i = TM.tmDescent To Percent
With BF
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = Abs(200 - ((20 * i) / Percent) * 10)
End With
RtlMoveMemory lBF, BF, 4
Select Case ShadowDirection
Case 1
ShadowLeft = -i + TM.tmDescent
Case 2
ShadowLeft = i - TM.tmDescent
Case 3
ShadowLeft = -i + TM.tmDescent
ShadowRight = (i - TM.tmDescent) * 2
Case 4
ShadowLeft = i - TM.tmDescent
ShadowRight = -(i - TM.tmDescent) * 2
End Select
Top = y + Height - 1
Left = x - (Rnd(i) * WaveIntesity) + ShadowLeft
AlphaBlend DestDC, Left, Top + IIf(BackLight, i, -i), Width + ShadowRight, 1, MemDC, 0, Height - i, Width, 1, lBF
Next
OffsetRect Rec, x, y + IIf(IgnoreTMDescent And BackLight, TM.tmDescent * 2, 0)
'Bibujamos el texto original
DrawText DestDC, Text, Len(Text), Rec, DT_BOTTOM Or DT_SINGLELINE
'limpiamos la memoria
SelectObject MemDC, OldhFont
SelectObject MemDC, OldhBmp
DeleteDC MemDC
DeleteObject hBmp
End Function