Leandro Ascierto

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.

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