Views

Histats

Vitrine

VBA Access - Inserindo cores gradientes nos formulários - Back Color Gradient

Inline image 1

A apresentação das nossas aplicações é muito importante. Por isso, termos a opção de deixar o fundo dos nossos formulários com um tom gradiente, certamente seria muito apropriado.

A técnica demonstrada abaixo envolve cobrirmos o nosso formulário com uma camada de retângulos, os quais são automaticamente colocados e posicionados por uma funcionalidade. Outra rotina faz a distribuição de cores de acordo com as cores que escolhermos.

Para escolhermos as cores, precisamos estar familiarizados com essa pequena lista das cores do Windows (ID Windows Colors)

ID da Cor   Descrição da Cor
----------- -----------------

-2147483648 Scroll bar
-2147483647 Desktop
-2147483646 Active window title bar
-2147483645 Inactive window title bar
-2147483644 Menu bar
-2147483643 Window
-2147483642 Window frame
-2147483641 Menu Text
-2147483640 Window Text (*)
-2147483639 Title bar text
-2147483638 Active window border
-2147483637 Inactive window border
-2147483636 Application background
-2147483635 Highlight
-2147483634 Highlight Text
-2147483633 3-D face (**)
-2147483632 3-D shadow
-2147483631 Dimmed (disabled) text
-2147483630 Button Text
-2147483629 Inactive window title bar text
-2147483628 3-D highlight (***)
-2147483627 3-D dark shadow
-2147483626 3-D light
-2147483625 ToolTip Text
-2147483624 ToolTip background

-2147483621 Active window title bar color2

Para que a sua combinação de cores não fique exdrúxula, também é importante que tenha compreensão de como as cores são formadas e compostas no ambiente computacional, aprenda mais aqui
Inline image 1
Voltando ao código, seguem as funcionalidades...



Insira no módulo basColorPicker:

' Original Code by Terry Kreft
' Modified by Stephen Lebans
' Contact Stephen@lebans.com
' Modified by Peter De Baets
' Contact Info@PetersSoftware.com

Option Compare Database
Option Explicit
'***********  Code Start  ***********
Private Type COLORSTRUC
  lStructSize As Long
  hwnd As Long
  hInstance As Long
  rgbResult As Long
  lpCustColors As String
  Flags As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Private Const CC_RGBINIT = &H1
Private Const CC_FULLOPEN = &H2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_SHOWHELP = &H8
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_ANYCOLOR = &H100

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
  (pChoosecolor As COLORSTRUC) As Long

Public Function aDialogColor (prop As Property) As Boolean
  Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
  
  CS.lStructSize = Len(CS)
  CS.hwnd = hWndAccessApp
  CS.rgbResult = Nz(prop.Value, 0)
  CS.Flags = CC_SOLIDCOLOR Or CC_RGBINIT
  CS.lpCustColors = String$(16 * 4, 0)
  x = ChooseColor(CS)
  If x = 0 Then
    ' ERROR - use Default White
    prop = RGB(255, 255, 255) ' White
    aDialogColor = False
    Exit Function
  Else
    ' Normal processing
     prop = CS.rgbResult
  End If
  aDialogColor = True
End Function
'***********  Code End   ***********

' If you want this Function to simply Return
' the Value of the Color the user selected
' from the Dialog just change the Function
' Declaration in modColorPicker to something like:
'Public Function DialogColor(ctl As Control) As Long
' Remember to add the line of code at the
' end of the Function
'DialogColor = CS.rgbResult
' Then call it from your Form with code like:

'***Code Start
'Private Sub CmdChooseBackColor_Click()
' Pass the TextBox Control to the function
'Me.textCtl.BackColor = DialogColor(Me.textCtl)
'End Sub
Public Function xg_ChooseColor (lngDefaultColor As Long) As Long
  Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
  Dim lngRtn As Long
  
  CS.lStructSize = Len(CS)
  CS.hwnd = hWndAccessApp
  'CS.rgbResult = Nz(prop.Value, 0)
  CS.rgbResult = Nz(lngDefaultColor, 0)
  CS.Flags = CC_SOLIDCOLOR Or CC_RGBINIT
  CS.lpCustColors = String$(16 * 4, 0)
  x = ChooseColor(CS)
  If x = 0 Then
    ' ERROR - use Default White
    'prop = RGB(255, 255, 255) ' White
    lngRtn = RGB(255, 255, 255) ' White
    'aDialogColor = False
    Exit Function
  Else
    ' Normal processing
     'prop = CS.rgbResult
     lngRtn = CS.rgbResult
  End If
  xg_ChooseColor = lngRtn
End Function
'***********  Code End   ***********

' If you want this Function to simply Return
' the Value of the Color the user selected
' from the Dialog just change the Function
' Declaration in modColorPicker to something like:
'Public Function DialogColor(ctl As Control) As Long
' Remember to add the line of code at the
' end of the Function
'DialogColor = CS.rgbResult
' Then call it from your Form with code like:

'***Code Start
'Private Sub CmdChooseBackColor_Click()
' Pass the TextBox Control to the function
'Me.textCtl.BackColor = DialogColor(Me.textCtl)
'End Sub

Insira no módulo basFormBackColorGradient:


Option Compare Database
Option Explicit
'  Back Color Gradient v1.0 for MS Access from Peter's Software
'
'    Adds a detail section back color gradient effect to your MS Access forms

'
'  This module was created by:
'
'    Peter's Software
'    10540 National Blvd #21
'    Los Angeles, CA  90034
'    USA
'    info@peterssoftware.com
'    http://www.peterssoftware.com
'
'  We do not require that this header be included in any apps you distribute,
'  but would appreciate credit being given in your documentation.
'
'  Usage:
'    bcg_CreateRectangles "<MyFormName>", False   - Run this from the "Examples" subroutine in this module
'                                                   (The last parm can be set to "True" for horizontal
'                                                   rectangles, providing a vertical color gradient)
'
'    bcg_SetColors Me, <Color1>, <Color2>         - From your form's OnOpen or OnActivate event procedure
'                                                   where <Color1> and <Color2> are Windows system color IDs
'                                                   or MS Access color values.

Const mconNamePrefix = "rctGrad"

Const SS_SW_HIDE = 0
Const SS_SW_SHOW = 5

Const COLOR_SCROLLBAR = 0
Const COLOR_BACKGROUND = 1
Const COLOR_ACTIVECAPTION = 2
Const COLOR_INACTIVECAPTION = 3
Const COLOR_MENU = 4
Const COLOR_WINDOW = 5
Const COLOR_WINDOWFRAME = 6
Const COLOR_MENUTEXT = 7
Const COLOR_WINDOWTEXT = 8
Const COLOR_CAPTIONTEXT = 9
Const COLOR_ACTIVEBORDER = 10
Const COLOR_INACTIVEBORDER = 11
Const COLOR_APPWORKSPACE = 12
Const COLOR_HIGHLIGHT = 13
Const COLOR_HIGHLIGHTTEXT = 14
Const COLOR_BTNFACE = 15
Const COLOR_BTNSHADOW = 16
Const COLOR_GRAYTEXT = 17
Const COLOR_BTNTEXT = 18
Const COLOR_INACTIVECAPTIONTEXT = 19
Const COLOR_BTNHIGHLIGHT = 20

Private Declare Function apiGetSysColor Lib "user32" Alias "GetSysColor" (ByVal nIndex As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Sub Examples()

'* This example adds vertical color gradient rectangles to the form "MyForm".
'* To run it, just uncomment the line below, replace "MyForm" with your form name
'* and Press F5.
bcg_CreateRectangles "MyForm", False

'* This example adds horizontal color gradient rectangles to the form "MyForm".
'* To run it, just uncomment the line below, replace "MyForm" with your form name
'* and Press F5.
'bcg_CreateRectangles "MyForm", True

End Sub

Sub bcg_CreateRectangles (strFormName As String, blnHorizontal As Boolean)
'* This routine adds a contiguous set of thin rectangles to the detail section of the specified form.
'* Setting the blnHorizontal parm to True will create thin horizontal rectangles instead of vertical ones.
'* Because this routine changes the form design, it is recommended to make a backup of the form
'* before executing this routine.
Dim i As Integer
Dim s As String
Dim intNumOfRectangles As Integer
Dim intWidth As Integer
Dim intHeight As Integer
Dim intLeft As Integer
Dim intTop As Integer
Dim sngAreaCovered As Single
Dim sngAreaToCover As Single
Dim frm As Form
Dim lngRtn As Long
Dim ctl As Control
Dim Finished As Boolean
Dim strProcName As String

On Error Resume Next
strProcName = "bcg_CreateRectangles"

s = "This routine will update the design of your form: '" & strFormName & "'. " & _
    "It is recommended that you make a backup of your form first. " & vbCrLf & vbCrLf & _
    "Do you wish to continue?"
If MsgBox(s, vbYesNo) = vbYes Then
    '*Continue
Else
    MsgBox "Action cancelled."
    GoTo Exit_Section
End If

'* Open form in design mode
DoCmd.OpenForm strFormName, acDesign, , , , acNormal
If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (1): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section
Set frm = Forms(strFormName)
If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (2): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section

'* Hide the form during processing
lngRtn = apiShowWindow(frm.hwnd, SS_SW_HIDE)

'* Delete any and all controls that begin with our rectangle control name prefix
Finished = False
Do While Not Finished
    Finished = True
    For Each ctl In frm.Controls
        If Left(ctl.name, Len(mconNamePrefix)) = mconNamePrefix Then
            DeleteControl frm.name, ctl.name
            Finished = False
            Exit For
        End If
    Next ctl
Loop
If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (3): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section

If blnHorizontal Then
    intWidth = frm.Width
    intHeight = 1440 / 24
    sngAreaToCover = frm.Section(acDetail).Height
    intLeft = 0
Else
    intWidth = 1440 / 24
    intHeight = frm.Section(acDetail).Height
    sngAreaToCover = frm.Width
    intTop = 0
End If

'* Create enough rectangle controls to cover the form detail section.
sngAreaCovered = 0
i = 0
Do While sngAreaCovered < sngAreaToCover

    If blnHorizontal Then
        intTop = i * (1440 / 24)
    Else
        intLeft = i * (1440 / 24)
    End If
    
    '* Create a rectangle on the form
    Set ctl = CreateControl(frm.name, acRectangle, acDetail, , , intLeft, intTop, intWidth, intHeight)
    If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (4): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section

    ctl.name = mconNamePrefix & i
    ctl.BackStyle = 1       '* Normal
    ctl.BorderStyle = 0     '* Transparent
    ctl.SpecialEffect = 0   '* Flat
    ctl.Visible = True
    
    '* Send rectangle to back so it won't cover other controls
    ctl.InSelection = True
    DoCmd.RunCommand acCmdSendToBack
    
    If blnHorizontal Then
        sngAreaCovered = sngAreaCovered + ctl.Height
    Else
        sngAreaCovered = sngAreaCovered + ctl.Width
    End If
    
    i = i + 1
Loop

'* Close the form
DoCmd.Close acForm, strFormName, acSaveYes
If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (5): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section

MsgBox "Done. Added color gradient rectangles to form '" & strFormName & "'."

Exit_Section:
Set ctl = Nothing

End Sub

Sub bcg_SetColors (frm As Form, plngStartingColor As Long, plngEndingColor As Long)
'* Loop through all the gradient rectangles on the form and color them.
Dim i As Integer
Dim intNumOfBoxes As Integer
Dim intBoxNo As Integer
Dim intTailLength As Integer
Dim intStartingRed As Integer
Dim intStartingGreen As Integer
Dim intStartingBlue As Integer
Dim intEndingRed As Integer
Dim intEndingGreen As Integer
Dim intEndingBlue As Integer
Dim intIncrementRed As Integer
Dim intIncrementGreen As Integer
Dim intIncrementBlue As Integer
Dim sngRemainingDiffRed As Single
Dim sngRemainingDiffGreen As Single
Dim sngRemainingDiffBlue As Single
Dim lngStartingColor As Long
Dim lngEndingColor As Long
Dim ctl As Control
Dim intMax As Integer
Dim intThisBoxNo As Integer
Dim strProcName As String

On Error Resume Next
strProcName = "bcg_SetColors"

If plngStartingColor < 0 Then
    '* Get system color using system color id
    lngStartingColor = apiGetSysColor(bcg_GetColorIndexFromColorID(plngStartingColor))
Else
    lngStartingColor = plngStartingColor
End If

If plngEndingColor < 0 Then
    '* Get system color using system color id
    lngEndingColor = apiGetSysColor(bcg_GetColorIndexFromColorID(plngEndingColor))
Else
    lngEndingColor = plngEndingColor
End If

If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (1): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section

'* Find number of boxes (color gradient rectangle controls)
intMax = 0
For Each ctl In frm.Controls
    If Left(ctl.name, Len(mconNamePrefix)) = mconNamePrefix Then
        intThisBoxNo = CInt(Right(ctl.name, Len(ctl.name) - Len(mconNamePrefix)))
        If intThisBoxNo > intMax Then
            intMax = intThisBoxNo
        End If
    End If
Next ctl
If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (2): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section

If intMax = 0 Then
    '* No gradient rectangle controls found
    GoTo Exit_Section
End If

intNumOfBoxes = intMax + 1

'* Compute starting and ending RGB color values
intStartingRed = GetRGB(lngStartingColor, 1)
intStartingGreen = GetRGB(lngStartingColor, 2)
intStartingBlue = GetRGB(lngStartingColor, 3)
intEndingRed = GetRGB(lngEndingColor, 1)
intEndingGreen = GetRGB(lngEndingColor, 2)
intEndingBlue = GetRGB(lngEndingColor, 3)

'* Find difference between starting and ending values
sngRemainingDiffRed = (intEndingRed - intStartingRed)
sngRemainingDiffGreen = (intEndingGreen - intStartingGreen)
sngRemainingDiffBlue = (intEndingBlue - intStartingBlue)

'* Loop through all gradient rectangle controls and set gradient colors by
'* smoothly decrementing the difference between the two colors.
For i = 0 To intNumOfBoxes - 1
    Set ctl = frm(mconNamePrefix & i)
    If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (3): " & Err.Number & " - " & Err.description: Err.Clear: Exit For
    
    ctl.BackColor = RGB( _
        intEndingRed - CInt(sngRemainingDiffRed), _
        intEndingGreen - CInt(sngRemainingDiffGreen), _
        intEndingBlue - CInt(sngRemainingDiffBlue) _
        )
    If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (4): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section
    
    sngRemainingDiffRed = sngRemainingDiffRed - (sngRemainingDiffRed / (intNumOfBoxes - i))
    sngRemainingDiffGreen = sngRemainingDiffGreen - (sngRemainingDiffGreen / (intNumOfBoxes - i))
    sngRemainingDiffBlue = sngRemainingDiffBlue - (sngRemainingDiffBlue / (intNumOfBoxes - i))
Next i

ctl.BackColor = RGB( _
    intEndingRed - CInt(sngRemainingDiffRed), _
    intEndingGreen - CInt(sngRemainingDiffGreen), _
    intEndingBlue - CInt(sngRemainingDiffBlue) _
    )
If Err <> 0 Then Beep: MsgBox "Error in " & strProcName & " (5): " & Err.Number & " - " & Err.description: Err.Clear: GoTo Exit_Section

Exit_Section:
    Set ctl = Nothing

End Sub
Function bcg_GetColorIndexFromColorID(lngSystemColorID As Long) As Long
'* Find the Windows system color index from the Windows system color ID
bcg_GetColorIndexFromColorID = lngSystemColorID + 2147483648#
End Function

Function GetRGB (RGBval As Long, Num As Integer) As Integer
'* Returns the Red (Num=1), Green (Num=2), or Blue (Num=3) value for the passed MS Access color value.
   ' Check if Num, RGBval are valid.
   If Num > 0 And Num < 4 And RGBval > -1 And RGBval < 16777216 Then
     GetRGB = RGBval \ 256 ^ (Num - 1) And 255
   Else
     ' Return True (-1) if Num or RGBval are invalid.
     GetRGB = True
   End If
End Function


Tags: VBA, Office, Access, color, color, cor, cores, degradê, gradiente, download
Inspiration: 

DownloadDownload bcg.zip - aplicável no Access 97, Access 2000, Access 2002/XP, Access 2003, Access 2007 e Access 2010


✔ VBA Brazil®

✔ VBA Brazil®
brazilsalesforceeffectiveness@gmail.com
Related Posts Plugin for WordPress, Blogger...
diHITT - Notícias