Views

Important:

Quaisquer necessidades de soluções e/ou desenvolvimento de aplicações pessoais/profissionais, que não constem neste Blog podem ser tratados como consultoria freelance à parte.

...

6 de março de 2012

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


Nenhum comentário:

Postar um comentário

eBooks VBA na AMAZOM.com.br

Vitrine