Mar 182021
 

En este caso se trata por un lado de un Módulo clase y por otro un Usercontrol para crear una interfaz de usuario moderna llamada Neumorphism o Neomorfismo, la cual comenzó a ponerse de moda a partir del 2020, si bien está pensada para aplicaciones móviles o webs no veo motivo para no implementarlo en nuestro querido vb6, al menos en aplicaciones pequeñas para no sobrecargar mucho la memoria y ralentizar nuestra app. El motor de todo esta basado en GDI+.

Con el módulo clase hay un ejemplo donde podemos jugar con las propiedades de la clase y otro formularios con algunos ejemplos graficados.
Además este permite dibujar un Path de GDI+ con el cual se utilizó un módulo extra, donde se puede crear distintas formas (Shapes) y se les puede aplicar el estilo, aprovecho para agradecer a Eduardo por tomar parte de las rutinas de su ShapeEx.

Con el Usercontrol hay tres ejemplos aplicados. No voy a detallar todas las propiedades, es cuestión de meter mano y jugar un poco, son las mismas del módulo. Con los ejemplos esta acompañando el usercontrol «LabelPlus» que es para agregar texto e iconos a las formas, (no quise volver a programar todo esto por eso utilicé dos usercontrols).

Ya más adelante voy a subir un reproductor de música en el que estoy trabajando donde puede verse todo esto aplicado.

Por último quiero aclarar que todo esto funciona más rápido cuando está compilado..

Neumorphism1.png Neumorphism2.png Neumorphism3.png Neumorphism4.png Neumorphism5.png
Abr 272010
 

Esta es una función para dibujar esferas utilizando GDI+. Existen varios diseños, yo elegí este, el cual está conformado con un color gradient central, una luz que la enfoca por encima y una sombra del mismo color que la esfera.
Es muy entretenido jugar con los métodos gráficos de GDI+ ya que nos permite utilizar transparencias, anti-alias y muchas funciones con las cuales podríamos hacer gráficos tal como en Photo Shop.

Esferas


Option Explicit
 
' ------------------------------------------------------------
' Autor:    Leandro I. Ascierto
' Fecha:    27 de Abril de 2010
' Web:      www.leandroascierto.com.ar
' ------------------------------------------------------------

Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GdipCreatePath Lib "GdiPlus.dll" (ByVal mBrushMode As Long, ByRef mPath As Long) As Long
Private Declare Function GdipDeletePath Lib "GdiPlus.dll" (ByVal mPath As Long) As Long
Private Declare Function GdipCreateLineBrushFromRectI Lib "GdiPlus.dll" (ByRef mRect As RECTL, ByVal mColor1 As Long, ByVal mColor2 As Long, ByVal mMode As LinearGradientMode, ByVal mWrapMode As WrapMode, ByRef mLineGradient As Long) As Long
Private Declare Function GdipAddPathEllipseI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mColor As Long, ByRef mCount As Long) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPolyGradient As Long) As Long
Private Declare Function GdipSetLinePresetBlend Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mBlend As Long, ByRef mPositions As Single, ByVal mCount 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 Type RECTL
    Left    As Long
    Top     As Long
    Width   As Long
    Height  As Long
End Type
 
Private Enum LinearGradientMode
    LinearGradientModeHorizontal = &H0
    LinearGradientModeVertical = &H1
    LinearGradientModeForwardDiagonal = &H2
    LinearGradientModeBackwardDiagonal = &H3
End Enum
 
Private Enum WrapMode
    WrapModeTile = &H0
    WrapModeTileFlipX = &H1
    WrapModeTileFlipy = &H2
    WrapModeTileFlipXY = &H3
    WrapModeClamp = &H4
End Enum
 
Private Type GDIPlusStartupInput
    GdiPlusVersion                      As Long
    DebugEventCallback                  As Long
    SuppressBackgroundThread            As Long
    SuppressExternalCodecs              As Long
End Type
 
Private Const SmoothingModeAntiAlias    As Long = &H4
Dim GdipToken As Long
 
 
Private Sub Form_Load()
    Call InitGDI
    Me.AutoRedraw = True
    DrawSphere Me.hdc, vbBlue, 10, 20, 150, 150
    DrawSphere Me.hdc, vbGreen, 180, 20, 150, 150
    DrawSphere Me.hdc, vbRed, 350, 20, 150, 150
    DrawSphere Me.hdc, vbYellow, 10, 210, 150, 150
    DrawSphere Me.hdc, vbBlack, 180, 210, 150, 150
    DrawSphere Me.hdc, vbMagenta, 350, 210, 150, 150
    DrawSphere Me.hdc, vbCyan, 10, 400, 150, 150
    DrawSphere Me.hdc, vbWhite, 180, 400, 150, 150
    DrawSphere Me.hdc, &H99FF&, 350, 400, 150, 150
End Sub
 
 
Private Sub Form_Unload(Cancel As Integer)
    Call TerminateGDI
End Sub
 
 
Public Function DrawSphere(ByVal hdc As Long, _
                           ByVal lColor As Long, _
                           ByVal X As Long, _
                           ByVal Y As Long, _
                           ByVal Width As Long, _
                           ByVal Height As Long, _
                           Optional ByVal bDrawShadow As Boolean = True, _
                           Optional ByVal lAlpha As Long = 100) As Boolean
 
    Dim hGraphics As Long
    Dim hBrush As Long
    Dim mPath As Long
    Dim mRect As RECTL
    Dim col(2) As Long
    Dim pos(2) As Single
 
    'crea un grafico a partir de un hdc
    If GdipCreateFromHDC(hdc, hGraphics) = 0 Then
 
        'aplica el modo antialias
        Call GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
 
 
        ' ----------------------------- Shadow -------------------------------------
        If bDrawShadow Then
 
            Call GdipCreatePath(&H0, mPath)                                                         'Crea un Path
            GdipAddPathEllipseI mPath, X, Y + Height / 1.1, Width, Height / 4                       'Dibuja un Circulo
            GdipCreatePathGradientFromPath mPath, hBrush                                            'Crea una brocha a partir de el Path
            
            GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha / 3)                 'Asigna un color central a la brocha
            GdipSetPathGradientSurroundColorsWithCount hBrush, 0, 1                                 'Aplica un color Transparente al contorno de la brocha/circulo
    
            Call GdipFillEllipseI(hGraphics, hBrush, X, Y + Height / 1.1, Width, Height / 4)        'dibuja la sombra en el grafico
            
            Call GdipDeleteBrush(hBrush)                                                            'Descarga la brocha
            Call GdipDeletePath(mPath)                                                              'Descarga el Path
        End If
 
        '----------------------------- Sphere -------------------------------------
               
        Call GdipCreatePath(&H0, mPath)                                                              'Crea un Path
        
        GdipAddPathEllipseI mPath, X - (Width / 1.75), Y - Height / 2, Width * 2, Height * 2         'Dibuja un Circulo en el path
        GdipCreatePathGradientFromPath mPath, hBrush                                                 'Crea una brocha a partir de el Path
        GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha)                          'Asigna el color central a la brocha
        GdipSetPathGradientSurroundColorsWithCount hBrush, ConvertColor(ShiftColor(lColor, vbBlack, 100), lAlpha), 1 'Aplica un color mas opaco al gradient de la brocha
        
        Call GdipFillEllipseI(hGraphics, hBrush, X, Y, Width, Height)                                'Dibuja un circulo en el grafico
        Call GdipDeleteBrush(hBrush)                                                                 'Descarga la brocha
        Call GdipDeletePath(mPath)                                                                   'Descarga el Path
        
        '----------------------------- Light -------------------------------------
        
        mRect.Left = X + Width / 10
        mRect.Top = Y + Height / 50
        mRect.Width = Width - Width / 5
        mRect.Height = Height / 1.5
 
        GdipCreateLineBrushFromRectI mRect, 0, 0, LinearGradientModeVertical, WrapModeTileFlipy, hBrush 'crea una brocha de dos colores

        col(0) = ConvertColor(vbWhite, lAlpha / 1.25)           'Primer color
        col(1) = 0                                              'segundo color transparente
        col(2) = 0                                              'tercer color transparente

        pos(0) = 0
        pos(1) = 0.6                                            'El 60% de la brocha va a ser transparente
        pos(2) = 1
 
        Call GdipSetLinePresetBlend(hBrush, col(0), pos(0), 3)  'Asigna los valores para la brocha
        Call GdipFillEllipseI(hGraphics, hBrush, mRect.Left, mRect.Top, mRect.Width, mRect.Height - 1) 'dibuja un circulo aplastado semi transparente
        Call GdipDeleteBrush(hBrush)                            'Elimina la brocha
        
        ' ------------------------------------------------------------------------

        Call GdipDeleteGraphics(hGraphics)                       'Elimina el grafico.
    End If
 
End Function
 
' funcion para convertir un color long a un BGRA(Blue, Green, Red, Alpha)
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
 
'Funcion para combinar dos colores
Private Function ShiftColor(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
 
    Dim clrFore(3)         As Byte
    Dim clrBack(3)         As Byte
 
    OleTranslateColor clrFirst, 0, VarPtr(clrFore(0))
    OleTranslateColor clrSecond, 0, VarPtr(clrBack(0))
 
    clrFore(0) = (clrFore(0) * lAlpha + clrBack(0) * (255 - lAlpha)) / 255
    clrFore(1) = (clrFore(1) * lAlpha + clrBack(1) * (255 - lAlpha)) / 255
    clrFore(2) = (clrFore(2) * lAlpha + clrBack(2) * (255 - lAlpha)) / 255
 
    CopyMemory ShiftColor, clrFore(0), 4
 
End Function
 
'Inicia GDI+
Private Sub InitGDI()
    Dim GdipStartupInput As GDIPlusStartupInput
    GdipStartupInput.GdiPlusVersion = 1&
    Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub
 
'Termina GDI+
Private Sub TerminateGDI()
    Call GdiplusShutdown(GdipToken)
End Sub
 

Abr 022010
 

Esta función la misma pero utilizando GDI Plus con más opciones, es muy útil a hora de trabajar con gráficos ya que se gana mucha velocidad.

FillRectPlus.png


Option Explicit
'------------------------------------------------------
'Autor: Leandro Ascierto
'Web:   www.leandroascierto.com.ar
'Fecha  02/04/2010
'------------------------------------------------------
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef image As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipCreateTexture Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mWrapMode As WrapMode, ByRef mTexture As Long) As Long
Private Declare Function GdipFillRectangle Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Single, ByVal mY As Single, ByVal mWidth As Single, ByVal mHeight As Single) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipScaleTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mSx As Single, ByVal mSy As Single, ByVal mOrder As Long) As Long
Private Declare Function GdipTranslateTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mDx As Single, ByVal mDy As Single, ByVal mOrder As Long) As Long
 
Private Enum WrapMode
    WrapModeTile = &H0
    WrapModeTileFlipX = &H1
    WrapModeTileFlipy = &H2
    WrapModeTileFlipXY = &H3
    WrapModeClamp = &H4
End Enum
 
Private Type GDIPlusStartupInput
    GdiPlusVersion                      As Long
    DebugEventCallback                  As Long
    SuppressBackgroundThread            As Long
    SuppressExternalCodecs              As Long
End Type
 
Private Const GdiPlusVersion            As Long = 1&
 
Dim GdipToken As Long
 
Private Function FillRectPlus(ByVal hdc As Long, _
                                ByVal hImage As Long, _
                                ByVal x As Single, _
                                ByVal y As Single, _
                                ByVal Width As Single, _
                                ByVal Height As Single, _
                                Optional ByVal nScaleX As Single = 1, _
                                Optional ByVal nScaleY As Single = 1, _
                                Optional EnuWrapMode As WrapMode) As Boolean 
 
    Dim hGraphics As Long
    Dim hBrush As Long
 
    If GdipCreateFromHDC(Me.hdc, hGraphics) = 0 Then 
        If GdipCreateTexture(hImage, EnuWrapMode, hBrush) = 0 Then 
            Call GdipTranslateTextureTransform(hBrush, x, y, 0) 
            Call GdipScaleTextureTransform(hBrush, nScaleX, nScaleY, 0) 
            FillRectPlus = GdipFillRectangle(hGraphics, hBrush, x, y, Width, Height) = 0 
            Call GdipDeleteBrush(hBrush)
        End If 
        Call GdipDeleteGraphics(hGraphics) 
    End If
 
End Function 
 
Private Sub InitGDI()
    Dim GdipStartupInput As GDIPlusStartupInput
    GdipStartupInput.GdiPlusVersion = GdiPlusVersion
    Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub 
 
Private Sub TerminateGDI()
    Call GdiplusShutdown(GdipToken)
End Sub
  
Private Sub Form_Load()
    Dim hImage As Long 
    Me.AutoRedraw = True 
    InitGDI 
    If GdipLoadImageFromFile(StrPtr(App.Path & "\Text.png"), hImage) = 0 Then 
        FillRectPlus Me.hdc, hImage, 10, 10, 200, 200 
        Call GdipDisposeImage(hImage)
    End If 
    TerminateGDI
End Sub
Oct 062009
 

Una función para tener siempre a mano, sobre todo para cuando trabajemos con hdc en memoria.

Option Explicit
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef 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 MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
 
 
Public Sub DrawLine(ByVal hdc As Long, _
                    ByVal X1 As Long, _
                    ByVal Y1 As Long, _
                    ByVal X2 As Long, _
                    ByVal Y2 As Long, _
                    Optional ByVal Color As Long = -1, _
                    Optional ByVal BorderWidth As Long = 1)
 
    Dim hPen As Long
    Dim TransColor As Long
    Dim OldPen As Long
 
    If Color <> -1 Then
        Call OleTranslateColor(Color, 0&, TransColor)
        hPen = CreatePen(0, BorderWidth, TransColor)
        OldPen = SelectObject(hdc, hPen)
    End If
 
    If X1 >= 0 Then
        MoveToEx hdc, X1, Y1, 0
    End If
 
    LineTo hdc, X2, Y2
 
    If hPen <> 0 Then
        SelectObject hdc, OldPen
        DeleteObject hPen
    End If
 
End Sub
Ago 012009
 

Igual que la función superior esta sirve para pintar una imágen de forma ampliada pero manteniendo su contorno original utilizando GDI PLUS, esto nos da como ventaja poder utilizar gráficos .PNG entre otros. Nótese que si ponemos el form con AutoRedraw = True la función trabaja más rápido.

RenderStrechtPlus

Option Explicit

' ----------------------------------------
' Autor Leandro Ascierto
' Web   www.leandroascierto.com.ar
' ----------------------------------------
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long = 0, Optional ByVal Callback As Long = 0, Optional ByVal CallbackData As Long = 0) As Long
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" (ByVal graphics As Long, ByVal InterpolationMode As Long) As Long
Private Declare Function GdipSetPixelOffsetMode Lib "gdiplus" (ByVal graphics As Long, ByVal PixelOffsetMode As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef image As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
 
Private Type GDIPlusStartupInput
    GdiPlusVersion                      As Long
    DebugEventCallback                  As Long
    SuppressBackgroundThread            As Long
    SuppressExternalCodecs              As Long
End Type
 
Private Const GdiPlusVersion                        As Long = 1&
Private Const QualityModeHigh                       As Long = 2&
Private Const InterpolationModeNearestNeighbor      As Long = QualityModeHigh + 3
Private Const PixelOffsetModeHalf                   As Long = QualityModeHigh + 2
 
Dim GdipToken As Long
Dim m_hImage As Long
  
Private Sub RenderStretchPlus(ByVal DestHdc As Long, _
                    ByVal DestX As Long, _
                    ByVal DestY As Long, _
                    ByVal DestW As Long, _
                    ByVal DestH As Long, _
                    ByVal hImage As Long, _
                    ByVal x As Long, _
                    ByVal y As Long, _
                    ByVal Width As Long, _
                    ByVal Height As Long, _
                    ByVal Size As Long)
 
 
    Dim hGraphics As Long
    Dim Sx2 As Long
 
    Sx2 = Size * 2
 
    If GdipCreateFromHDC(DestHdc, hGraphics) = 0 Then
        Call GdipSetInterpolationMode(hGraphics, InterpolationModeNearestNeighbor)
        Call GdipSetPixelOffsetMode(hGraphics, PixelOffsetModeHalf)
 
        GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY, Size, Size, x, y, Size, Size, &H2, 0&, 0&, 0& 'TOP_LEFT
        GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY, DestW - Sx2, Size, x + Size, y, Width - Sx2, Size, &H2, 0&, 0&, 0& 'TOP_CENTER
        GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW - Size, DestY, Size, Size, x + Width - Size, y, Size, Size, &H2, 0&, 0&, 0& 'TOP_RIGHT
        GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY + Size, Size, DestH - Sx2, x, y + Size, Size, Height - Sx2, &H2, 0&, 0&, 0& 'MID_LEFT
        GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY + Size, DestW - Sx2, DestH - Sx2, x + Size, y + Size, Width - Sx2, Height - Sx2, &H2, 0&, 0&, 0& 'MID_CENTER
        GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW - Size, DestY + Size, Size, DestH - Sx2, x + Width - Size, y + Size, Size, Height - Sx2, &H2, 0&, 0&, 0& 'MID_RIGHT
        GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY + DestH - Size, Size, Size, x, y + Height - Size, Size, Size, &H2, 0&, 0&, 0& 'BOTTOM_LEFT
        GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY + DestH - Size, DestW - Sx2, Size, x + Size, y + Height - Size, Width - Sx2, Size, &H2, 0&, 0&, 0& 'BOTTOM_CENTER
        GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW - Size, DestY + DestH - Size, Size, Size, x + Width - Size, y + Height - Size, Size, Size, &H2, 0&, 0&, 0& 'BOTTOM_RIGHT

        Call GdipDeleteGraphics(hGraphics)
    End If
 
End Sub
 
Private Sub RenderPlusFromFile(ByVal DestHdc As Long, _
                    ByVal DestX As Long, _
                    ByVal DestY As Long, _
                    ByVal DestW As Long, _
                    ByVal DestH As Long, _
                    ByVal FileName As String, _
                    ByVal x As Long, _
                    ByVal y As Long, _
                    ByVal Width As Long, _
                    ByVal Height As Long, _
                    ByVal Size As Long)
Dim hImg As Long
 
Call GdipLoadImageFromFile(StrPtr(FileName), hImg)
Call RenderStretchPlus(DestHdc, DestX, DestY, DestW, DestH, hImg, x, y, Width, Height, Size)
Call GdipDisposeImage(hImg)
End Sub
  
Private Sub InitGDI()
    Dim GdipStartupInput As GDIPlusStartupInput
    GdipStartupInput.GdiPlusVersion = GdiPlusVersion
    Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub
 
Private Sub TerminateGDI()
    Call GdiplusShutdown(GdipToken)
End Sub
 
Private Sub Command1_Click()
    Cls
    RenderPlusFromFile Me.hdc, 5, 5, 230, 230, App.Path & "\Image2.png", 0, 0, 158, 93, 26
End Sub
 
Private Sub Form_Load()
    Call InitGDI
    Call GdipLoadImageFromFile(StrPtr(App.Path & "\BotonesVista.png"), m_hImage)
    Me.AutoRedraw = True 'Utilizando GDIPlus + AutoRedraw = True, es mas rapido
End Sub
 
Private Sub Form_Terminate()
    Call GdipDisposeImage(m_hImage)
    Call TerminateGDI
End Sub
 
Private Sub Option1_Click(Index As Integer)
    Cls
    RenderStretchPlus Me.hdc, 10, 10, 120, 80, m_hImage, 0, 21 * Index, 11, 21, 3
End Sub 

Jul 232009
 

Esta es una función que sirve para pintar una imágen de forma ampliada pero manteniendo su contorno original, para que se entienda, cuando utilizamos PaintPicture o StretchBlt en una imágen, ésta se estira proporcionalmente y en un caso como éste (imágen) el borde del botón se deformaría, en esta función debe pasarse un parámetro en el cual debe indicarse un ancho/alto en común para los bordes.

RenderStrecht

Option Explicit

' -------------------------------------------------
' Autor: Leandro Ascierto
' Web:   www.leandroascierto.com.ar
' -------------------------------------------------

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 SetStretchBltMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (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 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 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 GdiTransparentBlt 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 crTransparent As Long) As Boolean
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
  
Private Function RenderStretchFromDC(ByVal DestDC As Long, _
                                ByVal DestX As Long, _
                                ByVal DestY As Long, _
                                ByVal DestW As Long, _
                                ByVal DestH As Long, _
                                ByVal SrcDC As Long, _
                                ByVal x As Long, _
                                ByVal y As Long, _
                                ByVal Width As Long, _
                                ByVal Height As Long, _
                                ByVal Size As Long, _
                                Optional MaskColor As Long = -1)
 
Dim Sx2 As Long
 
Sx2 = Size * 2
 
If MaskColor <> -1 Then
    Dim mDC         As Long
    Dim mX          As Long
    Dim mY          As Long
    Dim DC          As Long
    Dim hBmp        As Long
    Dim hOldBmp     As Long
 
    mDC = DestDC
    DC = GetDC(0)
    DestDC = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, DestW, DestH)
    hOldBmp = SelectObject(DestDC, hBmp) ' save the original BMP for later reselection
    mX = DestX: mY = DestY
    DestX = 0: DestY = 0
End If
 
SetStretchBltMode DestDC, vbPaletteModeNone
 
BitBlt DestDC, DestX, DestY, Size, Size, SrcDC, x, y, vbSrcCopy  'TOP_LEFT
StretchBlt DestDC, DestX + Size, DestY, DestW - Sx2, Size, SrcDC, x + Size, y, Width - Sx2, Size, vbSrcCopy 'TOP_CENTER
BitBlt DestDC, DestX + DestW - Size, DestY, Size, Size, SrcDC, x + Width - Size, y, vbSrcCopy 'TOP_RIGHT
StretchBlt DestDC, DestX, DestY + Size, Size, DestH - Sx2, SrcDC, x, y + Size, Size, Height - Sx2, vbSrcCopy 'MID_LEFT
StretchBlt DestDC, DestX + Size, DestY + Size, DestW - Sx2, DestH - Sx2, SrcDC, x + Size, y + Size, Width - Sx2, Height - Sx2, vbSrcCopy 'MID_CENTER
StretchBlt DestDC, DestX + DestW - Size, DestY + Size, Size, DestH - Sx2, SrcDC, x + Width - Size, y + Size, Size, Height - Sx2, vbSrcCopy 'MID_RIGHT
BitBlt DestDC, DestX, DestY + DestH - Size, Size, Size, SrcDC, x, y + Height - Size, vbSrcCopy 'BOTTOM_LEFT
StretchBlt DestDC, DestX + Size, DestY + DestH - Size, DestW - Sx2, Size, SrcDC, x + Size, y + Height - Size, Width - Sx2, Size, vbSrcCopy   'BOTTOM_CENTER
BitBlt DestDC, DestX + DestW - Size, DestY + DestH - Size, Size, Size, SrcDC, x + Width - Size, y + Height - Size, vbSrcCopy 'BOTTOM_RIGHT

If MaskColor <> -1 Then
    GdiTransparentBlt mDC, mX, mY, DestW, DestH, DestDC, 0, 0, DestW, DestH, MaskColor
    SelectObject DestDC, hOldBmp
    DeleteObject hBmp
    DeleteDC DC
    DeleteDC DestDC
End If
 
End Function 
 
Private Function RenderStretchFromPicture(ByVal DestDC As Long, _
                                ByVal DestX As Long, _
                                ByVal DestY As Long, _
                                ByVal DestW As Long, _
                                ByVal DestH As Long, _
                                ByVal SrcPicture As StdPicture, _
                                ByVal x As Long, _
                                ByVal y As Long, _
                                ByVal Width As Long, _
                                ByVal Height As Long, _
                                ByVal Size As Long, _
                                Optional MaskColor As Long = -1)
 
    Dim DC          As Long
    Dim hOldBmp     As Long
 
    DC = CreateCompatibleDC(0)
    hOldBmp = SelectObject(DC, SrcPicture.Handle)
 
    RenderStretchFromDC DestDC, DestX, DestY, DestW, DestH, DC, x, y, Width, Height, Size, MaskColor 

    hOldBmp = SelectObject(DC, hOldBmp)
    DeleteDC DC

End Function

May 102009
 

Esta es una Api que sirve para dibujar texto con una sombra difuminada al estilo Windows Vista, en el siguiente ejemplo he creado una pequeña función a modo de simplificarla un poco, pero esto depende del uso que se le quiera dar.
Lo malo de esta Api es que requiere que esté inicializada comctl32.dll, es decir, que tendremos que llamar a InitCommonControls y tener el archivo .manifest para que funcione, por lo tanto desde el IDE si no se tiene aplicado los temas de Windows en el VB6.EXE no se mostrará el dibujo del texto y además nos dará un error al llamar a esta Api, el cual lo podremos controlar con On Error, pero bien al compilarlo y teniendo el .manifest funcionará perfectamente.

Draw Shadow Text


Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y 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 DrawShadowText Lib "comctl32.dll" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal dwFlags As Long, ByVal crText As Long, ByVal crShadow As Long, ByVal ixOffset As Long, ByVal iyOffset As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Const DT_CALCRECT As Long = &H400

Public Function DrawTextShadow (DestDC As Long, Text As String, ByVal x As Long, ByVal y As Long, TextColor As OLE_COLOR, ShadowColor As OLE_COLOR, Optional OffsetX As Long = 1, Optional OffsetY As Long = 1) As Boolean

    On Error Resume Next     	'Si no incluye el archivo .manifest el api DrawShadowText provoca un error

    Dim Color1 As Long
    Dim Color2 As Long
    Dim Rec As RECT

    TranslateColor TextColor, 0, Color1
    TranslateColor ShadowColor, 0, Color2

    DrawText DestDC, Text, Len(Text), Rec, DT_CALCRECT
    OffsetRect Rec, x, y

    If Color1 = 0 Then Color1 = 1
    ' El quinto parámetro es la alineación, en este caso 0 = izquierda, 1 centrado, 2 derecha
    DrawTextShadow = DrawShadowText(DestDC, StrPtr(Text), Len(Text), Rec, 0, Color1, Color2, OffsetX, OffsetY)
    ' Esta función podría ser modificada en caso de el api DrawShadowText diera error, podría ser suplementada con DrawText

End Function

Private Sub Form_Initialize()
    InitCommonControls
End Sub

Private Sub Form_Load()

    Me.AutoRedraw = True
    Me.Font.Size = 8

    If DrawTextShadow(Me.hdc, "Hola Mundo", 10, 10, vbBlack, vbRed) = False Then
        MsgBox "Para probar este ejemplo debe compilar este proyecto y agregar un archivo Proyecto1.exe.manifest", vbInformation
    End If

    Me.Font.Size = 12
    DrawTextShadow Me.hdc, "Hola Mundo", 10, 30, vbBlue, vbRed
    Me.Font.Size = 32
    Me.Font.Name = "Times New Roman"
    DrawTextShadow Me.hdc, "Hola Mundo", 10, 50, vbGreen, vbMagenta
    DrawTextShadow Me.hdc, "Hola Mundo", 10, 90, Me.BackColor, vbBlue
    Me.FontBold = True
    DrawTextShadow Me.hdc, "Hola" & vbCrLf & "Mundo", 10, 130, vbWhite, vbBlack, 3, 3
End Sub

Private Sub Timer1_Timer()
    Picture1.Cls
    DrawTextShadow Picture1.hdc, Now, 5, 0, &H333333, &H80000005
End Sub

 Posted by at 23:51
May 012009
 

Esta es una función simple para dibujar puntos sobre un Formulario, Picture Box o hdc, la función es rápida.

Draw Grip

Option Explicit

'=========GDI32 Api========
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 GetDCBrushColor 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 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 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 CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiTransparentBlt 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 crTransparent As Long) As Boolean

'============User32 Api===========
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long

'============Estructura Rect========
Private Type RECT
    Left                        As Long
    Top                         As Long
    Right                       As Long
    Bottom                      As Long
End Type

Public Function ShiftColor(ByVal clr As Long, ByVal d As Long) As Long
  Dim R As Long, B As Long, G As Long
    R = (clr And &HFF) + d
    G = ((clr \ &H100) Mod &H100) + d
    B = ((clr \ &H10000) Mod &H100) + d
    
    If (d > 0) Then
        If (R > &HFF) Then R = &HFF
        If (G > &HFF) Then G = &HFF
        If (B > &HFF) Then B = &HFF
    ElseIf (d < 0) Then
        If (R < 0) Then R = 0
        If (G < 0) Then G = 0
        If (B < 0) Then B = 0
    End If
    ShiftColor = R + &H100& * G + &H10000 * B
End Function

Public Sub DrawGrip(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long)
    Dim DC                      As Long
    Dim hDCMemory               As Long
    Dim hBmp                    As Long
    Dim hOldBmp                 As Long
    Dim hBrush                  As Long
    Dim Rec                     As RECT
    Dim lOriginalColor          As Long
    Dim clrHighLight            As Long
    Dim clrShadow               As Long

    lOriginalColor = GetBkColor(DestDC)
    clrHighLight = ShiftColor(lOriginalColor, &H40)
    clrShadow = ShiftColor(lOriginalColor, -&H40)
    
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, 6, 6)
    hOldBmp = SelectObject(hDCMemory, hBmp)
          
    hBrush = CreateSolidBrush(lOriginalColor)
    SetRect Rec, 0, 0, 6, 6
    FillRect hDCMemory, Rec, hBrush
    DeleteObject hBrush
    
    SetPixelV hDCMemory, 2, 1, clrShadow
    SetPixelV hDCMemory, 1, 2, clrShadow
    SetPixelV hDCMemory, 2, 2, clrShadow
    
    SetPixelV hDCMemory, 0, 0, clrHighLight
    SetPixelV hDCMemory, 1, 0, clrHighLight
    SetPixelV hDCMemory, 0, 1, clrHighLight
    SetPixelV hDCMemory, 1, 1, clrHighLight
    
    SetPixelV hDCMemory, 5, 4, clrShadow
    SetPixelV hDCMemory, 4, 5, clrShadow
    SetPixelV hDCMemory, 5, 5, clrShadow
    
    SetPixelV hDCMemory, 3, 3, clrHighLight
    SetPixelV hDCMemory, 4, 3, clrHighLight
    SetPixelV hDCMemory, 3, 4, clrHighLight
    SetPixelV hDCMemory, 4, 4, clrHighLight
    
    hBrush = CreatePatternBrush(hBmp)
    SelectObject hDCMemory, hOldBmp
    DeleteObject hBmp
    hBmp = CreateCompatibleBitmap(DC, DestWidth, DestHeight)
    hOldBmp = SelectObject(hDCMemory, hBmp)
    SetRect Rec, 0, 0, DestWidth, DestHeight
    FillRect hDCMemory, Rec, hBrush
    
    GdiTransparentBlt DestDC, DestX, DestY, DestWidth, DestHeight, hDCMemory, 0, 0, DestWidth, DestHeight, lOriginalColor

    DeleteObject hBrush
    SelectObject hDCMemory, hOldBmp
    DeleteObject hBmp
    DeleteDC DC
    DeleteDC hDCMemory    
End Sub

Private Sub Form_Paint()
    DrawGrip Me.hdc, 0, 50, Me.ScaleWidth / Screen.TwipsPerPixelX, 9
    DrawGrip Me.hdc, 100, 59, 16, Me.ScaleHeight / Screen.TwipsPerPixelY - 59
End Sub								
May 012009
 

Esta es una función para dibujar una selección al estilo Windows XP.

Draw Alpha Selection


Option Explicit
 
'=========Gdi32 Api========
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 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 GdiAlphaBlend Lib "gdi32.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 CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
'=========user32 Api========
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 
'=========Oleaut32 Api========
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
 
'=========Kernel32 Api========
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
 
Private Type UcsRgbQuad
    R                       As Byte
    G                       As Byte
    B                       As Byte
    a                       As Byte
End Type
 
Private Type BLENDFUNCTION
    BlendOp                 As Byte
    BlendFlags              As Byte
    SourceConstantAlpha     As Byte
    AlphaFormat             As Byte
End Type
 
Private Sub DrawAlphaSelection(hdc As Long, ByVal X As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As OLE_COLOR)
 
    Dim BF                  As BLENDFUNCTION
    Dim hDCMemory           As Long
    Dim hBmp                As Long
    Dim hOldBmp             As Long
    Dim DC                  As Long
    Dim lColor              As Long
    Dim hPen                As Long
    Dim hBrush              As Long
    Dim lBF                 As Long
 
    BF.SourceConstantAlpha = 128
 
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, Width, Height)
    hOldBmp = SelectObject(hDCMemory, hBmp)
 
    hPen = CreatePen(0, 1, Color)
    hBrush = CreateSolidBrush(pvAlphaBlend(Color, vbWhite, 120))
    DeleteObject SelectObject(hDCMemory, hBrush)
    DeleteObject SelectObject(hDCMemory, hPen)
    Rectangle hDCMemory, 0, 0, Width, Height
 
    CopyMemory VarPtr(lBF), VarPtr(BF), 4
    GdiAlphaBlend hdc, X, y, Width, Height, hDCMemory, 0, 0, Width, Height, lBF
 
    SelectObject hDCMemory, hOldBmp
    DeleteObject hBmp
    ReleaseDC 0&, DC
    DeleteDC hDCMemory
    DeleteObject hPen
    DeleteObject hBrush
 
End Sub
 
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_Paint()
    Cls
    DrawAlphaSelection Me.hdc, 10, 50, 100, 200, vbRed
    DrawAlphaSelection Me.hdc, 50, 30, 200, 100, vbBlue
    DrawAlphaSelection Me.hdc, 200, 80, 100, 100, vbGreen
    DrawAlphaSelection Me.hdc, 80, 200, 200, 30, vbYellow
    DrawAlphaSelection Me.hdc, 130, 70, 50, 200, vbMagenta
End Sub

Abr 192009
 

Esta es una función que se encarga de dibujar un texto con un efecto espejado al estilo Windows Vista.

Texto Espejado

'-----------------------------'
'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

Abr 192009
 

Función para rellenar un rectángulo en un hdc con parte o el total de otro hdc, la función es muy rápida en dibujar.

Fill Rect Ex


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 FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 SetBrushOrgEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, ByRef lppt As POINTAPI) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

' Función que rellena un hdc con el contenido de otro en forma repetitiva
Private Sub FillRectEx(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long, SrcDC As Long, SrcX As Long, SrcY As Long, SrcWidth As Long, SrcHeight As Long)

    Dim DC As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim OldhBmp As Long
    Dim hBrush As Long
    Dim Rec As RECT
    Dim PT As POINTAPI

    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, SrcWidth, SrcHeight)
    ReleaseDC 0&, DC
    OldhBmp = SelectObject(hDCMemory, hBmp)
    BitBlt hDCMemory, 0, 0, SrcWidth, SrcHeight, SrcDC, SrcX, SrcY, vbSrcCopy
    hBrush = CreatePatternBrush(hBmp)
    SetRect Rec, DestX, DestY, DestWidth + DestX, DestHeight + DestY

    SetBrushOrgEx hdc, DestX, DestY, PT
    FillRect DestDC, Rec, hBrush
    SetBrushOrgEx hdc, PT.x, PT.y, PT

    DeleteObject hBrush
    DeleteObject SelectObject(hDCMemory, OldhBmp)
    DeleteDC hDCMemory
 End Sub

Private Sub Form_Load()
    With Picture1
        .Visible = False
        .AutoSize = True
        .ScaleMode = vbPixels
        .AutoRedraw = True
        .Picture = Me.Icon
    End With
End Sub

Private Sub Form_Paint()
    FillRectEx Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight
End Sub
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.

Draw Selection Ex


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