Ejemplos usando el Api de windows para Visual basic

57 - Crear degradado en Formularios o controles Picturebox - Módulo de clase

Contenido:

Degradado - Utilizando un Módulo de clase
Degradado - Utilizando un control
Enlaces relacionados

1 - Módulo de clase

Este código de ejemplo lo envió Leonardo Ramos, para establecer degradados ya sea en formularios o controles Picture.

La clase tiene 3 propiedades. Una llamada Angulo para establecer el ángulo del degradado. A esta propiedad le podemos pasar un valor de 0 a 360.

Luego tiene otras 2 para establecer los colores, es decir el color inicial y el color final, estas se llaman ColorInicial y ColorFinal.

Por último el método que establece el degradado se llama DibujarDegradado. A este método se le pasa el nombre del formulario o PictureBox al cual se le va a aplicar (acepta las 2 ya que la variable está definida como de tipo Object)

Por ejemplo para usarla, colocar un control Picture1 , un Command1 y pegar esto en un formulario:

Option Explicit 'Variable para la clase Dim Degradado As Class1 Private Sub Form_Load() 'Creamos una nueva instancia de la clase Set Degradado = New Class1 End Sub Private Sub Command1_Click() 'Le establecemos el valor al ángulo Degradado.Angulo = 180 'Le establecemos el color inicial en Azul Degradado.ColorInicial = vbBlue 'Le establecemos el color Final en rojo Degradado.ColorFinal = vbRed 'Dibujamos el degradado. en este caso en un control Picture1 Degradado.DibujarDegradado Picture1 End Sub Private Sub Form_Unload(Cancel As Integer) 'Eliminamos la variable de la clase Set Degradado = Nothing End Sub

Ahora agregar un módulo de clase, por defecto dejarle el nombre Class1 y agregarle este código:

Option Explicit 'Copia locales de las propiedades, del _ ColorInicial , ColorFinal y el angulo del degradado Private m_ColorInicial As Long Private m_ColorFinal As Long Private m_Angulo As Single 'Propiedades por defecto de los colores y del angulo del degradado Private Const mlDefColor1 As Long = &HFF 'Rojo Private Const mlDefColor2 As Long = 0 'Negro Private Const mfDefAngle As Single = 90 '90 grados Private Const PI As Double = 3.14159265358979 'Constante Pi Private Const RADS As Double = PI / 180 'Radianes 'Estructura PointApi para las coordenadas Private Type PointAPI X As Long Y As Long End Type Private Type PointSng X As Single Y As Single End Type 'Estructura rect para las regiones Private Type RectAPI Left As Long Top As Long Right As Long Bottom As Long End Type 'Declaración de las funciones Api y constantes Private Const PS_SOLID As Long = 0 Private Declare Function CreatePen Lib "gdi32" ( _ ByVal nPenStyle As Long, _ ByVal nWidth As Long, _ ByVal crColor As Long) As Long Private Declare Function DeleteObject Lib "gdi32" ( _ ByVal hObject As Long) As Long Private Declare Function GetClientRect Lib "user32" ( _ ByVal hwnd As Long, _ lpRect As RectAPI) As Long Private Declare Function GetPixel Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal X As Long, _ ByVal Y As Long) As Long Private Declare Function LineTo Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal X As Long, _ ByVal Y As Long) As Long Private Declare Function LockWindowUpdate Lib "user32" ( _ ByVal hWndLock As Long) As Long Private Declare Function MoveToEx Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal X As Long, _ ByVal Y As Long, _ lpPoint As PointAPI) As Long Private Declare Function SelectObject Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal hObject As Long) As Long 'Esta función dibuja el degradado. Nota: solo en los PictureBox y Formularios '**************************************************************************** Public Function DibujarDegradado(Objeto As Object) As Boolean Dim lret As Long Dim lIdx As Long Dim lTime As Long Dim uRect As RectAPI Objeto.AutoRedraw = True On Error GoTo RutinaError If m_ColorInicial < 0 Then m_ColorInicial = TranslateSystemColor(Objeto, m_ColorInicial) End If If m_ColorFinal < 0 Then m_ColorFinal = TranslateSystemColor(Objeto, m_ColorFinal) End If lret = LockWindowUpdate(Objeto.hwnd) lret = GetClientRect(Objeto.hwnd, uRect) If lret <> 0 Then If uRect.Right > 1 And uRect.Bottom > 1 Then lIdx = DrawGradient(Objeto.hdc, uRect.Right, uRect.Bottom) DibujarDegradado = (lIdx > 0) End If End If SalidaNormal: lret = LockWindowUpdate(0) Objeto.Refresh Exit Function RutinaError: MsgBox Err.Description, vbExclamation Resume SalidaNormal End Function Private Function TranslateSystemColor(Objeto As Object, _ ByVal lSysColor As Long) As Long Dim lSavePixel As Long lSavePixel = Objeto.Point(0, 0) Objeto.PSet (0, 0), lSysColor TranslateSystemColor = GetPixel(Objeto.hdc, 0&, 0&) Objeto.PSet (0, 0), lSavePixel End Function Private Function GetColors(ByVal ColorInicial As Long, _ ByVal ColorFinal As Long, _ ByVal NbrOfSteps As Long, _ aRetColors() As Long) As Long Dim j As Long Dim iRojo(1) As Integer Dim iVerde(1) As Integer Dim iAzul(1) As Integer Dim iStepDir As Integer Dim fRedStep As Single Dim fGreenStep As Single Dim fBlueStep As Single Dim sRojo As String Dim sVerde As String Dim sAzul As String Dim sColor As String sColor = FixLen(Hex$(ColorInicial), "000000") iAzul(0) = Val("&H" & Left$(sColor, 2)) iVerde(0) = Val("&H" & Mid$(sColor, 3, 2)) iRojo(0) = Val("&H" & Right$(sColor, 2)) sColor = FixLen(Hex$(ColorFinal), "000000") iAzul(1) = Val("&H" & Left$(sColor, 2)) iVerde(1) = Val("&H" & Mid$(sColor, 3, 2)) iRojo(1) = Val("&H" & Right$(sColor, 2)) fBlueStep = Div(CSng(iAzul(1) - iAzul(0)), CSng(NbrOfSteps)) fGreenStep = Div(CSng(iVerde(1) - iVerde(0)), CSng(NbrOfSteps)) fRedStep = Div(CSng(iRojo(1) - iRojo(0)), CSng(NbrOfSteps)) ReDim aRetColors(NbrOfSteps - 1) For j = 1 To Abs(NbrOfSteps) sAzul = FixLen(Hex$(iAzul(0) + CInt(fBlueStep * CSng(j))), "00") sVerde = FixLen(Hex$(iVerde(0) + CInt(fGreenStep * CSng(j))), "00") sRojo = FixLen(Hex$(iRojo(0) + CInt(fRedStep * CSng(j))), "00") aRetColors(j - 1) = CLng("&H" & sAzul & sVerde & sRojo) Next j GetColors = NbrOfSteps End Function Private Function FixLen(ByVal sText As String, ByVal sMask As String) As String If Len(sText) < Len(sMask) Then FixLen = Left$(sMask, Len(sMask) - Len(sText)) & sText Else FixLen = Left$(sText, Len(sMask)) End If End Function Private Function DrawGradient(ByVal hdc As Long, ByVal lWidth As Long, ByVal _ lHeight As Long) As Long Dim iIncX As Integer Dim iIncY As Integer Dim lIdx As Long Dim lret As Long Dim hPen As Long Dim hOldPen As Long Dim lPointCnt As Long Dim laColors() As Long Dim fMovX As Single Dim fMovY As Single Dim fDist As Single Dim fAngle As Single Dim fLongSide As Single Dim uTmpPt As PointAPI Dim uaPts() As PointAPI Dim uaTmpPts() As PointSng On Error GoTo RutinaError ReDim uaTmpPts(2) uaTmpPts(2).X = Int(lWidth / 2) uaTmpPts(2).Y = Int(lHeight / 2) fLongSide = IIf(lWidth > lHeight, lWidth, lHeight) fDist = (Sqr((fLongSide ^ 2) + (fLongSide ^ 2)) + 2) / 2 uaTmpPts(0).X = uaTmpPts(2).X - fDist uaTmpPts(0).Y = uaTmpPts(2).Y uaTmpPts(1).X = uaTmpPts(2).X + fDist uaTmpPts(1).Y = uaTmpPts(2).Y fAngle = CDbl(m_Angulo + 90) - Int(Int(CDbl(m_Angulo + 90) / 360#) * 360#) Call RotatePoint(uaTmpPts(2), uaTmpPts(0), fAngle) Call RotatePoint(uaTmpPts(2), uaTmpPts(1), fAngle) Select Case m_Angulo Case 0 To 90 If Abs(uaTmpPts(0).X - uaTmpPts(1).X) <= Abs(uaTmpPts(0).Y - uaTmpPts(1).Y) Then fMovX = IIf(uaTmpPts(0).X > uaTmpPts(1).X, -uaTmpPts(0).X, -uaTmpPts(1).X) fMovY = 0 iIncX = 1 iIncY = 0 Else fMovX = 0 fMovY = IIf(uaTmpPts(0).Y > uaTmpPts(1).Y, lHeight - uaTmpPts(1).Y, _ lHeight - uaTmpPts(0).Y) iIncX = 0 iIncY = -1 End If Case 90 To 180 If Abs(uaTmpPts(0).X - uaTmpPts(1).X) <= Abs(uaTmpPts(0).Y - uaTmpPts(1).Y) Then 'Move line to right edge; DibujarDegradado right to left fMovX = IIf(uaTmpPts(0).X > uaTmpPts(1).X, lWidth - uaTmpPts(1).X, _ lWidth - uaTmpPts(0).X) fMovY = 0 iIncX = -1 iIncY = 0 Else fMovX = 0 fMovY = IIf(uaTmpPts(0).Y > uaTmpPts(1).Y, lHeight - uaTmpPts(1).Y, _ lHeight - uaTmpPts(0).Y) iIncX = 0 iIncY = -1 End If Case 180 To 270 If Abs(uaTmpPts(0).X - uaTmpPts(1).X) <= Abs(uaTmpPts(0).Y - uaTmpPts(1).Y) Then fMovX = IIf(uaTmpPts(0).X > uaTmpPts(1).X, lWidth - uaTmpPts(1).X, _ lWidth - uaTmpPts(0).X) fMovY = 0 iIncX = -1 iIncY = 0 Else fMovX = 0 fMovY = IIf(uaTmpPts(0).Y > uaTmpPts(1).Y, -uaTmpPts(0).Y, -uaTmpPts(1).Y) iIncX = 0 iIncY = 1 End If Case Else If Abs(uaTmpPts(0).X - uaTmpPts(1).X) <= Abs(uaTmpPts(0).Y - uaTmpPts(1).Y) Then fMovX = IIf(uaTmpPts(0).X > uaTmpPts(1).X, -uaTmpPts(0).X, -uaTmpPts(1).X) fMovY = 0 iIncX = 1 iIncY = 0 Else fMovX = 0 fMovY = IIf(uaTmpPts(0).Y > uaTmpPts(1).Y, -uaTmpPts(0).Y, -uaTmpPts(1).Y) iIncX = 0 iIncY = 1 End If End Select ReDim uaPts(999) uaPts(0).X = uaTmpPts(0).X + fMovX uaPts(0).Y = uaTmpPts(0).Y + fMovY uaPts(1).X = uaTmpPts(1).X + fMovX uaPts(1).Y = uaTmpPts(1).Y + fMovY lIdx = 2 If iIncX > 0 Then While uaPts(lIdx - 1).X < lWidth Or uaPts(lIdx - 2).X < lWidth uaPts(lIdx).X = uaPts(lIdx - 2).X + iIncX uaPts(lIdx).Y = uaPts(lIdx - 2).Y + iIncY lIdx = lIdx + 1 If (lIdx Mod 1000) = 0 Then ReDim Preserve uaPts(UBound(uaPts) + 1000) End If Wend ElseIf iIncX < 0 Then While uaPts(lIdx - 1).X > 0 Or uaPts(lIdx - 2).X > 0 uaPts(lIdx).X = uaPts(lIdx - 2).X + iIncX uaPts(lIdx).Y = uaPts(lIdx - 2).Y + iIncY lIdx = lIdx + 1 If (lIdx Mod 1000) = 0 Then ReDim Preserve uaPts(UBound(uaPts) + 1000) End If Wend ElseIf iIncY > 0 Then While uaPts(lIdx - 1).Y < lHeight Or uaPts(lIdx - 2).Y < lHeight uaPts(lIdx).X = uaPts(lIdx - 2).X + iIncX uaPts(lIdx).Y = uaPts(lIdx - 2).Y + iIncY lIdx = lIdx + 1 If (lIdx Mod 1000) = 0 Then ReDim Preserve uaPts(UBound(uaPts) + 1000) End If Wend ElseIf iIncY < 0 Then While uaPts(lIdx - 1).Y > 0 Or uaPts(lIdx - 2).Y > 0 uaPts(lIdx).X = uaPts(lIdx - 2).X + iIncX uaPts(lIdx).Y = uaPts(lIdx - 2).Y + iIncY lIdx = lIdx + 1 If (lIdx Mod 1000) = 0 Then ReDim Preserve uaPts(UBound(uaPts) + 1000) End If Wend End If ReDim Preserve uaPts(lIdx - 1) lret = GetColors(m_ColorInicial, m_ColorFinal, lIdx / 2, laColors) For lIdx = 0 To UBound(uaPts) - 1 Step 2 lret = MoveToEx(hdc, uaPts(lIdx).X, uaPts(lIdx).Y, uTmpPt) hPen = CreatePen(PS_SOLID, 1, laColors(Int(lIdx / 2))) hOldPen = SelectObject(hdc, hPen) lret = LineTo(hdc, uaPts(lIdx + 1).X, uaPts(lIdx + 1).Y) lret = SelectObject(hdc, hOldPen) lret = DeleteObject(hPen) Next lIdx DrawGradient = lIdx NormalExit: Erase laColors Erase uaPts Erase uaTmpPts Exit Function RutinaError: MsgBox Err.Description, vbExclamation, "GradientRect.cls" DrawGradient = 0 Resume NormalExit End Function Private Sub RotatePoint(uAxisPt As PointSng, uRotatePt As PointSng, _ fDegrees As Single) Dim fDX As Single Dim fDY As Single Dim fRadians As Single fRadians = fDegrees * RADS fDX = uRotatePt.X - uAxisPt.X fDY = uRotatePt.Y - uAxisPt.Y uRotatePt.X = uAxisPt.X + ((fDX * Cos(fRadians)) + (fDY * Sin(fRadians))) uRotatePt.Y = uAxisPt.Y + -((fDX * Sin(fRadians)) - (fDY * Cos(fRadians))) End Sub Private Function Div(ByVal dNumer As Double, _ ByVal dDenom As Double) As Double If dDenom <> 0 Then Div = dNumer / dDenom Else Div = 0 End If End Function 'Propiedades '************************************************************* Public Property Let ColorInicial(ByVal lData As Long) m_ColorInicial = lData End Property Public Property Get ColorInicial() As Long ColorInicial = m_ColorInicial End Property Public Property Let ColorFinal(ByVal lData As Long) m_ColorFinal = lData End Property Public Property Get ColorFinal() As Long ColorFinal = m_ColorFinal End Property Public Property Let Angulo(ByVal fData As Single) m_Angulo = CDbl(fData) - Int(Int(CDbl(fData) / 360#) * 360#) End Property Public Property Get Angulo() As Single Angulo = m_Angulo End Property Private Sub Class_Initialize() m_ColorInicial = mlDefColor1 m_ColorFinal = mlDefColor2 m_Angulo = mfDefAngle End Sub

2 - Utilizando un Control

Este Activex , al colocarlo en el form, automáticamente repinta la ventana con el degradado que le indiquemos en la propiedad EndColor y StartColor. Para indicar la orientación vertical u horizontal se debe usar la propeidad Orientation

Descargar

Enlaces relacionados

Buscar en Recursos vb