✔ Programação GLOBAL®: VBA Access - Inserindo cores gradientes nos formulários

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

| Blog Office VBA | Blog Excel | Blog Access |

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.

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