RECTANGLE WITH GDI +

[cliv]

I need a function that can draw a rectangle like in "ESFERAS CON GDI +" with "glass" effect and shadow...!
Can someoane help me?

[LeandroA]

This are one example using this metod with GdipFillRectangleI


in the form1

Código: (vb) [Seleccionar]

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 Declare Function GdipAddPathRectangleI 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 GdipFillRectangleI 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 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
    DrawRectanleGlow Me.hdc, vbBlue, 10, 20, 200, 150
    DrawRectanleGlow Me.hdc, vbGreen, 280, 20, 200, 150
    DrawRectanleGlow Me.hdc, vbRed, 550, 20, 200, 150
    DrawRectanleGlow Me.hdc, vbYellow, 10, 250, 150, 150
    DrawRectanleGlow Me.hdc, vbBlack, 180, 250, 150, 150
    DrawRectanleGlow Me.hdc, vbMagenta, 350, 250, 150, 150
    DrawRectanleGlow Me.hdc, vbCyan, 10, 500, 150, 250
    DrawRectanleGlow Me.hdc, vbWhite, 180, 500, 150, 250
    DrawRectanleGlow Me.hdc, &H99FF&, 350, 500, 150, 250
End Sub
 
 
Private Sub Form_Unload(Cancel As Integer)
    Call TerminateGDI
End Sub
 
 
Public Function DrawRectanleGlow(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

            With mRect
                .Left = X
                .Top = Y + Height / 3
                .Width = Width
                .Height = Height
            End With
       
            GdipCreateLineBrushFromRectI mRect, ConvertColor(lColor, lAlpha / 2), 0, LinearGradientModeVertical, WrapModeTile, hBrush
                       
            Call GdipFillRectangleI(hGraphics, hBrush, X, Y + Height / 3, Width, Height - 1)       'dibuja la sombra en el grafico
           
            Call GdipDeleteBrush(hBrush)                                                            'Descarga la brocha

        End If
 
        '----------------------------- Rectangle -------------------------------------
               
        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 GdipFillRectangleI(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 -------------------------------------
        With mRect
            .Left = X + 2
            .Top = Y + 2
            .Width = Width - 4
            .Height = Height - 4
        End With
       
        GdipCreateLineBrushFromRectI mRect, 0, 0, LinearGradientModeForwardDiagonal, 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 GdipFillRectangleI(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

[ssccaann43]

Che leandro estas vuelto un capo con las matematicas...! XD

[LeandroA]

Que?  donde ves algo de matematicas??? ademas soy mas cuadrado que las figuras de la imagen en matematicas.

[ssccaann43]

En la funcion DrawRectanleGlow, aplicas calculos matematicos...!

Las diviciones, multiplicaciones, sumas, restas, etc...! Jaja, yo les tengo fobia...! Pero me toca aveces.....!

[cliv]

Thank you very mutch Leandro ....
I want to draw something like this :


and i want to use your function with aditional parameters:
- GradientTopColor1
- GradientTopColor2
- GradientBottomColor1
- GradientBottomColor2
- Border color
- RoundTopCorner
- RoundBottomCorner

Can somebody help...?


Thank you again Leandro

[LeandroA]

Here's an example of how to draw Tabs, not has all that you ask but can be very helpful.



In The Form1

Código: (vb) [Seleccionar]

Option Explicit
'--------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 02/06/2010
'---------------------------------
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 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 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 GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByVal mUnit As Long, ByRef mPen As Long) As Long
Private Declare Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As Long) 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 GdipDrawPath Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal mPath As Long) As Long
Private Declare Function GdipAddPathArc Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Single, ByVal mY As Single, ByVal mWidth As Single, ByVal mHeight As Single, ByVal mStartAngle As Single, ByVal mSweepAngle As Single) As Long
Private Declare Function GdipAddPathLine Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX1 As Single, ByVal mY1 As Single, ByVal mX2 As Single, ByVal mY2 As Single) As Long
Private Declare Function GdipFillPath Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mPath As Long) As Long
'Private Declare Function GdipClosePathFigure Lib "GdiPlus.dll" (ByVal mPath 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" (Destination As Any, Source As Any, ByVal Length As Long)
 
Private Type RECTL
    Left As Long
    Top As Long
    Width As Long
    Height As Long
End Type

Private Type GDIPlusStartupInput
    GdiPlusVersion                      As Long
    DebugEventCallback                  As Long
    SuppressBackgroundThread            As Long
    SuppressExternalCodecs              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 Const SmoothingModeAntiAlias    As Long = &H4

Dim GdipToken As Long


Private Sub Form_Load()
    Call InitGDI
    Me.AutoRedraw = True
   
    DrawTabs Me.hdc, 10, 10, 200, 50, ShiftColor(vbRed, vbWhite, 25), vbRed, &H999999, 16
    DrawTabs Me.hdc, 220, 10, 200, 50, ShiftColor(vbBlue, vbWhite, 75), vbBlue, &H999999, 32
    DrawTabs Me.hdc, 430, 10, 200, 50, ShiftColor(vbGreen, vbWhite, 25), vbGreen, vbGreen, 60
End Sub
 

Public Function DrawTabs(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal FirstColor As Long, ByVal SecondColor As Long, ByVal BorderColor As Long, Round) As Boolean

    Dim hGraphics As Long
    Dim hPen As Long, hBrush As Long
    Dim mPath As Long
    Dim mRect As RECTL


    If GdipCreateFromHDC(hdc, hGraphics) = 0 Then
   
        Call GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)

        If GdipCreatePath(&H0, mPath) = 0 Then

            GdipAddPathArc mPath, X, Y, Round, Round, 180, 90
            GdipAddPathArc mPath, X + Width - Round, Y, Round, Round, 270, 90
            GdipAddPathLine mPath, X + Width, Y + Height, X, Y + Height
            GdipAddPathLine mPath, X, Y + Height, X, Y + Round / 2
           
            With mRect
                .Left = X
                .Top = Y
                .Width = Width
                .Height = Height / 2
            End With
           
            Call GdipCreateLineBrushFromRectI(mRect, ConvertColor(FirstColor, 100), ConvertColor(SecondColor, 100), LinearGradientModeVertical, WrapModeTileFlipX, hBrush)
                                   
            Call GdipCreatePen1(ConvertColor(BorderColor, 100), 1, &H2, hPen)
   
            GdipFillPath hGraphics, hBrush, mPath
   
            GdipDrawPath hGraphics, hPen, mPath
           
           
            Call GdipDeleteBrush(hBrush)
            Call GdipDeletePath(mPath)
            Call GdipDeletePen(hPen)
           
            DrawTabs = True
       
        End If
       
        Call GdipDeleteGraphics(hGraphics)
       
    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

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

Private Sub InitGDI()
    Dim GdipStartupInput As GDIPlusStartupInput
    GdipStartupInput.GdiPlusVersion = 1&
    Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub
 
 
Private Sub TerminateGDI()
    Call GdiplusShutdown(GdipToken)
End Sub


Private Sub Form_Unload(Cancel As Integer)
    Call TerminateGDI
End Sub

Greetings.

[cliv]

Thank you LeandroA...it is exactly what i want....

Than you again...

[YAcosta]

No se si a alguien mas le paso.
Estuve haciendo algunas pruebas con este código RECTANGLE WITH GDI +, primero, como buen neófito y para ver como anda a manera de distraccion sin meterle cerebro e ir jugando abrí un nuevo proyecto en VB6, copie todo el código de aquí y lo pegue en el form lo ejecute y corre muy bien. Detuve.

Ahora iba a jugar con poner algún control para ver "como se ve", coloco el commandbutton en el form, lo ejecuto y bien.
Detengo, voy al form para agrandarlo y se cae el VB6. Asi de plano

Pensé que mi VB tendría algo, así que vuelvo a abrir el VB el cual carga un Form1 y sin poner ningún código le agrando el form, lo achico, le hago de todo y va bien, puse un "hola mundo" y todo bien. Cargue uno de mis proyectos, jugué con el y todo bien. Vuelvo a pegar el código RECTANGLE WITH GDI +, ejecuto funciona bien, pero cuando detengo y  accedo al formulario (no al código) se cae nuevamente el VB.

Procedí a poner todo el código que esta fuera del Load y Unload en un modulo y cambie de Private a Public, ejecute y corre bien, pero lo mismo se cae el Visual Basic cuando accedo al formulario.

¿Que creen que pueda estar pasando? ¿Algo anda mal con mi VB?

Yo imagino que algo se carga en memoria que entra en conflicto con el manejo de las ventanas y me tumba el VB6, no se si sera algo asi. Para mi todavía resulta un poco complicado entender el código y quizá esta experiencia ya se dio y se sabe cual es el problema el cual agradecería me ayudasen a saberlo.
Gracias

P.D.: Se que es casi lo mismo, pero por si aca probé con el código de Leandro que tiene en su web (Esferas) y pasa exactamente lo mismo.

[LeandroA]

YvanB yo apostaria que estas parando la aplicación con el Stop de VB y esto produce la caida del vb6, tienes que cerrar el formulario desde la cruz X de cerrar para que se dispare el evento form Unload entoneces asi se llama a la funcion GdiplusShutdown

una buena practica es no utilizar nunca el Stop de vb y menos la funcion END

Estoy en lo correcto?

Saludos.

[YAcosta]

Tienes razón, yo usaba el stop de VB6, he probado cerrando en la X y ya no ocurre el problema.

Estaba en duda en sobre lo que decías acerca de que usar la X es mejor que usar el Stop, es decir, si era correcto o no. Pero creo que si tienes razón en que se debe usar la X, porque el stop corta abruptamente el código no permitiendole llegar al evento unload. Si estoy en lo correcto o hay otro motivo mas me gustaría saberlo.

Gracias por la aclaración.

[raul338]

YvanB yo apostaria que estas parando la aplicación con el Stop de VB y esto produce la caida del vb6, tienes que cerrar el formulario desde la cruz X de cerrar para que se dispare el evento form Unload entoneces asi se llama a la funcion GdiplusShutdown

una buena practica es no utilizar nunca el Stop de vb y menos la funcion END

Estoy en lo correcto?

Saludos.

Si lo estas, de hecho a mi me pasa seguido, uso vario de tus controles y a veces tengo errores de logica y tengo forzosamente detener y dejar que se caiga el ide porque no puedo continuar xDDD
Lo malo de esto es que no se puede guardar mientras estas depurando u.u