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