Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: raul338 en Mayo 23, 2012, 09:41:22 pm
-
Hola!
Ando buscando códigos y no encuentro (ni en GDI) algo para hacer un Degradado circular (radial gradient) para aplicar al fondo de un formulario y un listView (hacer el efecto ListView con fondo transparente). Que sea lo más rápido posible (buscaba que sea GDI o GDI+) porque quizás lo ponga que re-dibuje ante resize del form :P
No me sirve poner una imagen estatica de fondo :P
Lo que busco es hacer algo así (atado con alambres en photoshop xD)
(http://i49.tinypic.com/9zun3n.jpg)
Como ven, si logro hacer o encuentro una función que dibuje el degradado radial sobre un hdc (un picture por ej), listo se lo aplico al formulario y luego lo corto y se lo pongo al listview
Bueno, espero que me ayuden :)
-
Bueno :P
Viendo el codigo de Esferas con GDI+ (http://leandroascierto.com/blog/esferas-con-gdi/) y la unica referencia de GDI+ (http://www.jose.it-berater.org/gdiplus/iframe/index.htm) que pude encontrar (misteriosamente el msdn dejo de funcionar :P)
Pude hacer el siguente codigo
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 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 GdipDeleteBrush Lib "gdiplus" (ByVal mBrush As Long) As Long
Private Declare Function GdipFillRectangleI Lib "gdiplus" (ByVal graphics As Long, ByVal brush As Long, ByVal x As Long, ByVal y As Long, ByVal nidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GdipCreatePath Lib "gdiplus" (ByVal mBrushMode As Long, ByRef mPath As Long) As Long
Private Declare Function GdipDeletePath Lib "gdiplus" (ByVal mPath As Long) As Long
Private Declare Function GdipAddPathEllipseI Lib "gdiplus" (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" (ByVal mBrush As Long, ByVal mColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "gdiplus" (ByVal mBrush As Long, ByRef mColor As Long, ByRef mCount As Long) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "gdiplus" (ByVal mPath As Long, ByRef mPolyGradient As Long) As Long
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Dim GdipToken As Long
Private Sub Form_Load()
Call InitGDI
Me.AutoRedraw = True
End Sub
Private Sub Form_Resize()
Call Cls
' Para obtener estos colores, usar
' Debug.Print Hex$(ConvertColor(vbGreen)), Hex$(ConvertColor(vbBlack))
' Verde, negro ya convertidos para optimizar rendimiento
Call DrawFondo(&HFF00FF00, &HFF000000)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call TerminateGDI
End Sub
Public Function DrawFondo(ByVal lColorStart As Long, ByVal lColorEnd As Long) As Boolean
Dim hGraphics As Long
Dim hBrush As Long
Dim mPath As Long
If Not GdipCreateFromHDC(hdc, hGraphics) Then
Call GdipCreatePath(&H0, mPath)
Call GdipAddPathEllipseI(mPath, ScaleWidth * -0.6, ScaleHeight * -0.5, ScaleWidth * 2, ScaleHeight * 2)
Call GdipCreatePathGradientFromPath(mPath, hBrush)
Call GdipSetPathGradientCenterColor(hBrush, lColorStart)
Call GdipSetPathGradientSurroundColorsWithCount(hBrush, lColorEnd, 1)
Call GdipFillRectangleI(hGraphics, hBrush, 0, 0, ScaleWidth, ScaleHeight)
Call GdipDeleteBrush(hBrush)
Call GdipDeletePath(mPath)
Call GdipDeleteGraphics(hGraphics)
End If
End Function
' funcion para convertir un color long a un BGRA(Blue, Green, Red, Alpha)
Private Function ConvertColor(Color As Long) As Long
Dim BGRA(0 To 3) As Byte
BGRA(3) = 255
BGRA(0) = ((Color \ &H10000) And &HFF)
BGRA(1) = ((Color \ &H100) And &HFF)
BGRA(2) = (Color And &HFF)
Call CopyMemory(ConvertColor, BGRA(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
No se como hice, pero funciona solo para todo el formulario, para pintar solo un rectangulo por coordenadas no funciona (solo dibuja un cuarto de circulo :P)
Así que bueno, si a alguien le sirve, seria como otro aporte :P
-
Hola Raul, esta bien la función, te tiro una alternativa usando una imagen ya que es un poco mas rapido, la imagen es una luz y el fondo es el back color del formulario por lo que si queres cambiar de color no necesitas otra imagen sino que solo basta cambiar el backcolor del form.
aca abajo esta la imagen que te digo descargala y cambia el path en código.
http://s8.postimage.org/xsd2yj2hd/Light.png
(http://s8.postimage.org/xsd2yj2hd/Light.png) (http://postimage.org/)
Option Explicit
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 Declare Function GdipDrawImageRectI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mImage As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight 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 PixelOffsetModeHalf As Long = 4&
Dim GdipToken As Long
Dim m_hImage As Long
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()
Me.ScaleMode = vbPixels
Me.AutoRedraw = True
Me.BackColor = &H9900& 'color de fondo
Call InitGDI
Call GdipLoadImageFromFile(StrPtr("C:\Users\Windows\Desktop\Light.png"), m_hImage) '<--cambiar el path de la imagen
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.BackColor = QBColor(14 * Rnd() + 1)
Call Form_Resize
End Sub
Private Sub Form_Resize()
Dim hGraphics As Long
Me.Cls
If GdipCreateFromHDC(Me.hdc, hGraphics) = 0 Then
Call GdipSetPixelOffsetMode(hGraphics, PixelOffsetModeHalf)
Call GdipDrawImageRectI(hGraphics, m_hImage, 0, 0, Me.ScaleWidth, Me.ScaleHeight)
GdipDeleteGraphics hGraphics
End If
End Sub
Private Sub Form_Terminate()
Call GdipDisposeImage(m_hImage)
Call TerminateGDI
End Sub
Saludos.
-
Me gusta, es más rápido y a pesar de ser una imagen chica funciona genial!
Ahora mismo no puedo probar, pero el centro me queda blanco, debe ser por a imagen :P pero me gustaría darle color al centro. Seria con la imagen o tendría que usar alguna función para "colorearlo" tipo tono/saturación?
-
Hola Raul de ser asi lo mas conveniente puede ser combinar la función de hacerlo con métodos gráficos como lo hiciste vos, pero sobre un lienzo (GdipCreateBitmapFromScan0 + GdipGetImageGraphicsContext) y luego tratarlo como una imagen, puede que se mas optimo ademas no dependerias de la imagen, igualmente te paso una forma de como colorear una imagen tal como decías ya que puede útil a alguien mas.
utilizando GdipBitmapLockBits se puede acceder al array de bits de la imagen y bueno se puden hacer ciento de cosas.
Option Explicit
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 Declare Function GdipDrawImageRectI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mImage As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipBitmapUnlockBits Lib "GdiPlus.dll" (ByVal mBitmap As Long, ByRef mLockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapLockBits Lib "GdiPlus.dll" (ByVal mBitmap As Long, ByRef mRect As RECTL, ByVal mFlags As ImageLockMode, ByVal mPixelFormat As Long, ByRef mLockedBitmapData As BitmapData) As Long
Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mHeight As Long) As Long
Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mWidth As Long) As Long
Private Type BitmapData
Width As Long
Height As Long
Stride As Long
PixelFormat As Long
Scan0Ptr As Long
ReservedPtr As Long
End Type
Private Type RECTL
Left As Long
Top As Long
Width As Long
Height As Long
End Type
Private Type RGBQUAD
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Enum ImageLockMode
ImageLockModeRead = &H1
ImageLockModeWrite = &H2
ImageLockModeUserInputBuf = &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&
Private Const PixelOffsetModeHalf As Long = 4&
Private Const PixelFormat32bppPARGB As Long = &HE200B
Dim GdipToken As Long
Dim m_hImage As Long
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()
Me.ScaleMode = vbPixels
Me.AutoRedraw = True
Me.BackColor = vbWhite
Call InitGDI
Call GdipLoadImageFromFile(StrPtr("C:\Users\Windows\Desktop\Light.png"), m_hImage) '<--cambiar el path de la imagen
BlendToColor m_hImage, vbRed, 100
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Me.BackColor = QBColor(14 * Rnd() + 1)
BlendToColor m_hImage, QBColor(14 * Rnd()), 100
Call Form_Resize
End Sub
Private Sub Form_Resize()
Dim hGraphics As Long
Me.Cls
If GdipCreateFromHDC(Me.hdc, hGraphics) = 0 Then
Call GdipSetPixelOffsetMode(hGraphics, PixelOffsetModeHalf)
Call GdipDrawImageRectI(hGraphics, m_hImage, 0, 0, Me.ScaleWidth, Me.ScaleHeight)
GdipDeleteGraphics hGraphics
End If
DoEvents
End Sub
Private Sub Form_Terminate()
Call GdipDisposeImage(m_hImage)
Call TerminateGDI
End Sub
Public Function BlendToColor(ByVal hImage As Long, ByVal BlendColor As Long, Optional ByVal BlendOpacity As Long = 33) As Boolean
Dim hStatus As Long
Dim bmpData As BitmapData
Dim Rec As RECTL
Dim Data() As RGBQUAD
Dim X As Long, Y As Long
Dim blendR As Long, blendB As Long, blendG As Long
Dim srcPct As Long
If hImage = 0& Then Exit Function
If BlendOpacity < 1 Then ' background color won't be included in calcs; don't waste time
BlendToColor = True
Exit Function
End If
' validate BlendOpacity doesn't exceed max value
If BlendOpacity > 100 Then BlendOpacity = 100
' calculate what percentage of source color will be used
srcPct = (100 - BlendOpacity)
' extract the RGB elements from the BlendColor & premultiply by BlendOpacity
blendR = (BlendColor And &HFF) * BlendOpacity
blendG = ((BlendColor \ &H100&) And &HFF) * BlendOpacity
blendB = ((BlendColor \ &H10000) And &HFF) * BlendOpacity
Call GdipGetImageWidth(hImage, Rec.Width)
Call GdipGetImageHeight(hImage, Rec.Height)
ReDim Data(Rec.Width - 1&, Rec.Height - 1&)
With bmpData
.Scan0Ptr = VarPtr(Data(0&, 0&))
.Stride = 4& * Rec.Width
End With
hStatus = GdipBitmapLockBits(hImage, Rec, ImageLockModeUserInputBuf Or ImageLockModeRead Or ImageLockModeWrite, PixelFormat32bppPARGB, bmpData)
If hStatus <> 0& Then Exit Function
For Y = 0& To Rec.Height - 1&
For X = 0& To Rec.Width - 1&
If Not Data(X, Y).Alpha = 0& Then
Data(X, Y).Red = (((Data(X, Y).Red * srcPct) + blendR) * Data(X, Y).Alpha) \ 25500
Data(X, Y).Green = (((Data(X, Y).Green * srcPct) + blendG) * Data(X, Y).Alpha) \ 25500
Data(X, Y).Blue = (((Data(X, Y).Blue * srcPct) + blendB) * Data(X, Y).Alpha) \ 25500
End If
Next
Next
hStatus = GdipBitmapUnlockBits(hImage, bmpData)
End Function