Abr 192009
Este es una función para dibujar una selección al estilo Windows Vista o MSN, útil para hacer controles de usuarios o según la necesidad de cada uno. creo que si bien es hay unas cuantas Apis, la función es muy rápida en dibujar.
Option Explicit
' ---------------------------------------------------
' Autor: Leandro Ascierto
' ----------------------------------------------------
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function SetPixelV Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function RoundRect Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type
Private Sub DrawSelectionEx(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long, oColorStar As Long, oColorEnd As Long)
Dim DC As Long, hDCMemory As Long, hBmp As Long
Dim hPen1 As Long, hPen2 As Long, hBrush As Long
Dim OldhBmp As Long, OldhPen As Long, OldhBrush As Long
Dim DivValue As Double
Dim i As Long
' Creamos una Pluma oscura para el borde
hPen1 = CreatePen(0, 1, pvAlphaBlend(vbBlack, oColorEnd, 10))
' Creamos un Pluma para un pequeño borde interior, bien claro
hPen2 = CreatePen(0, 1, pvAlphaBlend(oColorStar, vbWhite, 10))
' Creamos un HDC temporal
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, 1, DestHeight)
OldhBmp = SelectObject(hDCMemory, hBmp)
' Creamos un bucle haciendo un degradado
For i = 1 To DestHeight
DivValue = ((i * 255) / DestHeight)
SetPixelV hDCMemory, 0, i, pvAlphaBlend(oColorEnd, oColorStar, DivValue)
Next
' Creamos una brocha con el bmp
hBrush = CreatePatternBrush(hBmp)
' Creamos un buffer temporal
DeleteObject hBmp
hBmp = CreateCompatibleBitmap(DC, DestWidth, DestHeight)
Call SelectObject(hDCMemory, hBmp)
' Pintamos el destino en el buffer
BitBlt hDCMemory, 0, 0, DestWidth, DestHeight, DestDC, DestX, DestY, vbSrcCopy
' Le asignamos la pluma al hdc de destino
OldhPen = SelectObject(hDCMemory, hPen1)
' Pintamos un borde oscuro alrededor sin relleno
RoundRect hDCMemory, 0, 0, DestWidth, DestHeight, 9, 9
' Asignamos la segunda pluma más clara
Call SelectObject(hDCMemory, hPen2)
' Creamos y asignamos una brocha con el bmp de nuestro degradado
OldhBrush = SelectObject(hDCMemory, hBrush)
' Pintamos un rectángulo redondeado con la pluma y la brocha
RoundRect hDCMemory, 1, 1, DestWidth - 1, DestHeight - 1, 8, 8
' Pintamos el buffer en el destino
BitBlt DestDC, DestX, DestY, DestWidth, DestHeight, hDCMemory, 0, 0, vbSrcCopy
' Descargamos todo
SelectObject hDCMemory, OldhPen
SelectObject hDCMemory, OldhBrush
SelectObject hDCMemory, OldhBmp
DeleteObject hPen1
DeleteObject hPen2
DeleteObject hBrush
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory
End Sub
' Función para trasladar un color a otro en porcentaje lAlpha(0 A 255)
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad
OleTranslateColor clrFirst, 0, VarPtr(clrFore)
OleTranslateColor clrSecond, 0, VarPtr(clrBack)
With clrFore
.R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
.G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
.B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
End With
CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
End Function
Private Sub Form_Load()
Me.ScaleMode = vbPixels
Me.FontName = "Calibri"
Me.FontSize = 12
Me.BackColor = vbWhite
Me.Width = 8500
Me.Height = 8700
HScroll1.Max = 255
HScroll1.Value = 70
HScroll1.Move 320, 210, 230, 30
End Sub
' Ejemplo de uso
Private Sub Form_Paint()
Dim i As Integer
' Colores empleados en Windows Vista, y MSN
DrawSelectionEx Me.hdc, 320, 10, 100, 100, RGB(249, 253, 255), RGB(234, 247, 255)
DrawSelectionEx Me.hdc, 440, 10, 100, 100, RGB(251, 251, 251), RGB(231, 231, 231)
' Con quince colores diferentes
For i = 0 To 15
DrawSelectionEx Me.hdc, 10, 10 + (i * 35), 300, 30, Me.BackColor, pvAlphaBlend(QBColor(i), Me.BackColor, HScroll1.Value)
Next
' Utilizando el color resalte del sistema
DrawSelectionEx Me.hdc, 320, 120, 220, 70, Me.BackColor, pvAlphaBlend(vbHighlight, Me.BackColor, 50)
Me.CurrentX = 330
Me.CurrentY = 145
Me.Print "Color de selección del Sistema"
End Sub
Private Sub HScroll1_Change()
Form_Paint
End Sub