VBA Tips - Como fazer Gradientes - How to Make Gradients

Termo de Responsabilidade

O efeito gradiente é muito bonito quando utilizado com moderação em alguns objetos. O código abaixo vai evocar um gradiente em cada formulário ou picturebox ou, eventualmente, qualquer objeto que tenha uma propriedade hDC.

Basta executar a SUB DrawGradient, passando os seguintes valores:

lDestHDC - O hDC do objeto que você deseja desenhar a

lDestWidth - A largura da Gradiente

lDestHeight - A altura da Gradiente

lStartColor - A cor do gradiente começa com

lEndColor - A cor do gradiente termina com

iStyle - 0 para a esquerda para a direita ou gradiente de 1 para cima para baixo gradiente.

Crie um novo módulo e insira este código:

Type RECT

   Left As Long

   Top As Long

   Right As Long

   Bottom As Long

End Type

Declare Function CreateSolidBrush Lib "gdi32" _

  (ByVal crColor As Long) As Long

Declare Function DeleteObject Lib "gdi32" _

  (ByVal hObject As Long) As Long

Declare Function FillRect Lib "user32" _

  (ByVal hDC As Long, lpRect As RECT, _

  ByVal hBrush As Long) As Long

Public Sub DrawGradient (lDestHDC As Long, _

  lDestWidth As Long, lDestHeight As Long, _

  lStartColor As Long, lEndColor As Long, _

  iStyle As Integer)

   Dim udtRect As RECT

   Dim iBlueStart As Integer

   Dim iBlueEnd As Integer

   Dim iRedStart As Integer

   Dim iRedEnd As Integer

   Dim iGreenStart As Integer

   Dim iGreenEnd As Integer

   Dim hBrush As Long

   On Error Resume Next

   'Calculate the beginning colors

   Let iBlueStart = Int(lStartColor / &H10000)

   Let iGreenStart = Int(lStartColor - (iBlueStart * &H10000)) \ CLng(&H100)

   Let iRedStart = lStartColor - (iBlueStart * &H10000) - CLng(iGreenStart * CLng(&H100))

   'Calculate the End colors

   Let iBlueEnd = Int(lEndColor / &H10000)

   Let iGreenEnd = Int(lEndColor - (iBlueEnd * &H10000)) \ CLng(&H100)

   Let iRedEnd = lEndColor - (iBlueEnd * &H10000) - CLng(iGreenEnd * CLng(&H100))

   Const intBANDWIDTH = 1

   Dim sngBlueCur As Single

   Dim sngBlueStep As Single

   Dim sngGreenCur As Single

   Dim sngGreenStep As Single

   Dim sngRedCur As Single

   Dim sngRedStep As Single

   Dim iHeight As Integer

   Dim iWidth As Integer

   Dim intY As Integer

   Dim iDrawEnd As Integer

   Dim lReturn As Long

   Let iHeight = lDestHeight

   Let iWidth = lDestWidth

   Let sngBlueCur = iBlueStart

   Let sngGreenCur = iGreenStart

   Let sngRedCur = iRedStart

   'Calculate the size of the color bars

   If iStyle = 0 Then

      sngBlueStep = intBANDWIDTH * _

         (iBlueEnd - iBlueStart) / (iWidth - 60) * 15

      sngGreenStep = intBANDWIDTH * _

         (iGreenEnd - iGreenStart) / (iWidth - 60) * 15

      sngRedStep = intBANDWIDTH * _

         (iRedEnd - iRedStart) / (iWidth - 60) * 15

      With udtRect

         Let .Left = 0

         Let .Top = 0

         Let .Right = intBANDWIDTH + 2

         Let .Bottom = iHeight / 15 - 2

      End With

      Let iDrawEnd = iWidth

   ElseIf iStyle = 1 Then

      Let sngBlueStep = intBANDWIDTH * _

         (iBlueEnd - iBlueStart) / (iHeight - 60) * 15

      Let sngGreenStep = intBANDWIDTH * _

         (iGreenEnd - iGreenStart) / (iHeight - 60) * 15

      Let sngRedStep = intBANDWIDTH * _

         (iRedEnd - iRedStart) / (iHeight - 60) * 15

      With udtRect

         Let .Left = 0

         Let .Top = 0

         Let .Right = iWidth / 15 - 2

         Let .Bottom = intBANDWIDTH + 2

      End With

      Let iDrawEnd = iHeight

   End If

   'Draw the Gradient

   For intY = 0 To (iDrawEnd / 15) - 5 Step intBANDWIDTH

      Let hBrush = CreateSolidBrush(RGB(sngRedCur, sngGreenCur, sngBlueCur))

      Let lReturn = FillRect(lDestHDC, udtRect, hBrush)

      Let lReturn = DeleteObject(hBrush)

      Let sngBlueCur = sngBlueCur + sngBlueStep

      Let sngGreenCur = sngGreenCur + sngGreenStep

      Let sngRedCur = sngRedCur + sngRedStep

      If iStyle = 0 Then

         Let udtRect.Left = udtRect.Left + intBANDWIDTH

         Let udtRect.Right = udtRect.Right + intBANDWIDTH

      ElseIf iStyle = 1 Then

         Let udtRect.Top = udtRect.Top + intBANDWIDTH

         Let udtRect.Bottom = udtRect.Bottom + intBANDWIDTH

      End If

   Next

End Sub    

'--end code block

No evento de leitura do Form coloque este código (Set Autoredraw to true to reduce flickering while resizing the form.)

Let Me.AutoRedraw = True

DrawGradient Me.hDC, Me.Width, Me.Height, vbBlue, vbRed, 0  

'--end code block

No evento de resize do Form coloque este código

Cls

DrawGradient Me.hDC, Me.Width, Me.Height, vbBlue, vbRed, 0  

'--end code block

References:

Tags: VBA, Tips, gradient, gradiente