Introduction.
This article continues the series showcasing various 3D Heading Styles for designing Microsoft Access Form and Report headers. The style demonstrated here is a variant of the 3D Heading design previously introduced under the title Create 3D Headings on Forms.
Each style offers its own unique visual appeal, and once created, it can be easily copied and customized, changing the foreground color, font, and font styles (such as Bold or Italic) to suit the look and feel of your form or report headings.
I have created several heading designs of this type. If this is the first one you’ve come across on this site, please note that some initial setup is required before you can successfully run the code for this heading style—or any of the others shared here.
To prepare your Microsoft Access project environment:
- Link the required library files to your project. These are common libraries already available on your system. You simply need to attach them by following the steps outlined in my earlier post titled Command-Button Animation.
- Copy the necessary program code (listed below) into a new global VBA module in your project and save it.
- If you’ve already added the core functions from earlier posts, then you only need to copy the final function: Shadow3D()
The VBA Programs
Option Compare Database
Option Explicit
'-- Global declarations
Private Const lngheight as long = 0.45 * 1440
Private Const lngWidth as long = 4.5 * 1440
Private Const intFontSize as integer = 26
Private Const intTextAlign as integer = 0
Private Const intBackStyle as integer = 0
Private Const LngI as long = 0.0104 * 1440
Private Const intX as long = 0.15 * 1440
Private Const intY as long = 0.15 * 1440
Dim MyFrm As Form
Public Function FormTxtLabels(Optional ByVal ControlType As Integer) As String
'---------------------------------------------------
'Author : a.p.r. pillai
'Date : September 2006
'ControlType = 0 for label
'ControlTYPE = 1 for TextBox
'---------------------------------------------------
Dim ctl As Control
'On Error GoTo FormTxtLabels_Err
If ControlType > 0 Then ControlType = 1
Set MyFrm = CreateForm
If ControlType = 1 Then
Set ctl = CreateControl(MyFrm.NAME, acTextBox, acDetail, , , (0.2 * 1440), (0.2 * 1440), lngWidth, lngheight)
With ctl
.ControlSource = "=" & Chr(34) & "msaccesstips.com" & Chr(34)
End With
Else
Set ctl = CreateControl(MyFrm.NAME, acLabel, _acDetail, , , (0.2 * 1440), (0.2 * 1440), lngWidth, lngheight)
With ctl
.Caption = "msaccesstips.com"
End With
End If
FormTxtLabels = MyFrm.NAME
FormTxtLabels_Exit:
Exit Function
Public Function Validate_Dup(ByRef MyFrm As Form, ByVal intNooflabels As Integer) As Integer
'---------------------------------------------------
'Author : a.p.r. pillai
'Date : September 2006
'ControlType = 0 for label
'ControlTYPE = 1 for TextBox
'---------------------------------------------------
Dim mysec As Section, lblcount As Integer
Dim myctrl As Control, newctrl As Control, j As Integer
Dim lngx As Long, lngY As Long, lngH As Long, lngW As Long
Dim strCap As String, ctrltype As Integer, intlbls As Integer
Dim ctrlName() As String, ctrlIndex() As Integer, i As Long
Dim strFont As String, intFntSize As Integer, x As Integer
Dim intFntWeight As Integer
'On Error GoTo Validate_Dup_Err
Set mysec = MyFrm.Section(acDetail)
intlbls = mysec.Controls.Count - 1
Set myctrl = mysec.Controls(0)
ctrltype = myctrl.ControlType
intNooflabels = intNooflabels - 1
If intlbls > 0 Then
ReDim ctrlName(intlbls) As String
ReDim ctrlIndex(intlbls) As Integer
End If
If ctrltype = 109 And intlbls > 0 Then
For j = 0 To intlbls
Set myctrl = mysec.Controls(j)
ctrlIndex(j) = myctrl.ControlType
ctrlName(j) = myctrl.NAME
Next
For j = 0 To intlbls
If ctrlIndex(j) = 100 Then
DeleteControl MyFrm.NAME, ctrlName(j)
End If
Next
intlbls = mysec.Controls.Count - 1
End If
Set myctrl = mysec.Controls(0)
If intlbls < intNooflabels Then
With myctrl
lngx = .Left
lngY = .Top
lngW = .Width
lngH = 0.0208 * 1440 ' 0.0208 inches
strFont = .FontName
intFntSize = .FontSize
intFntWeight = .FontWeight
End With
If ctrltype = 100 Then
strCap = myctrl.Caption
ElseIf ctrltype = 109 Then
strCap = myctrl.ControlSource
End If
If ctrltype = 109 And intlbls > 0 Then
For j = 0 To intlbls
Set myctrl = mysec.Controls(j)
ctrlIndex(j) = myctrl.ControlType
ctrlName(j) = myctrl.NAME
Next
For j = 0 To intlbls
If ctrlIndex(j) = 100 Then
DeleteControl MyFrm.NAME, ctrlName(j)
End If
Next
intlbls = mysec.Controls.Count - 1
Set myctrl = mysec.Controls(intlbls)
With myctrl
lngx = .Left
lngY = .Top
lngW = .Width
lngH = .Height
ctrltype = .ControlType
strFont = .FontName
intFntSize = .FontSize
intFntWeight = .FontWeight
End With
End If
i = 0.0104 * 1440 + lngH ' 0.0104 inches
lngY = lngY + i
For j = intlbls + 1 To intNooflabels
Set newctrl = CreateControl(MyFrm.NAME, ctrltype, _acDetail, "","", lngx, lngY, lngW, lngH)
If ctrltype = 100 Then
newctrl.Caption = strCap
newctrl.FontName = strFont
newctrl.FontSize = intFntSize
newctrl.FontWeight = intFntWeight
Else
newctrl.ControlSource = strCap
newctrl.FontName = strFont
newctrl.FontSize = intFntSize
newctrl.FontWeight = intFntWeight
End If
lngY = lngY + i
Next
End If
If intlbls > intNooflabels Then
For j = intNooflabels + 1 To intlbls
Set myctrl = mysec.Controls(j)
ctrlIndex(j) = myctrl.ControlType
ctrlName(j) = myctrl.NAME
Next
For j = intNooflabels + 1 To intlbls
DeleteControl MyFrm.NAME, ctrlName(j)
Next
Validate_Dup = 0
End If
intlbls = mysec.Controls.Count - 1
Set myctrl = mysec.Controls(0)
ctrltype = myctrl.ControlType
If ctrltype = 109 Then
For j = 0 To intlbls
Set myctrl = mysec.Controls(j)
With myctrl
.Enabled = False
.Locked = True
.SpecialEffect = 0
End With
Next
End If
Validate_Dup = 0
Validate_Dup_Exit:
Exit Function
Validate_Dup_Err:
MsgBox Err.Description, ,"Validate_Dup"
Validate_Dup = 1
Resume Validate_Dup_Exit
End Function
Public Function MsgLabel() '------------------------------------------------------------ 'Author : a.p.r. pillai 'Date : September 2006 '------------------------------------------------------------ Dim mySection As Section, ctl As Control, xForm As Form Dim l As Long, t As Long, w As Long, h As Long, F As Long F = 1440 l = 0.5 * F: t = 1.2 * F: w = 3.6563 * F: h = 0.4896 * F 'values in inches On Error Resume Next Set mySection = MyFrm.Section(acDetail) Set ctl = CreateControl(MyFrm.NAME, acLabel, _acDetail, , "", l, t, w, h) ctl.Caption = "Click outside the Controls and Drag Over. " & "Display the Property Sheet. " & "Type New Text for Caption/Control " & "Source Property area for Label/ Text Boxes. " & "Copy and Paste the Controls to " & "Target Form/Report Area." End Function
Public Function Shadow3D(ByVal intStyle As Integer, ByVal intForeColor As Integer, _
Optional ByVal Label0Text1 As Integer) As String
'----------------------------------------------------------
'Author : a.p.r. pillai
'Date : September 2006
'Rights : All Rights Reserved by www.msaccesstips.com
'----------------------------------------------------------
Dim intlbls As Integer, intFSize As Integer
Dim j As Integer, mySection As Section
Dim lblName() As String, lngForecolor As Long, X As Integer
Dim l As Long, t As Long
On Error Resume Next
Shade3D = FormTxtLabels(Label0Text1)
Set mySection = MyFrm.Section(acDetail)
intlbls = mySection.Controls.Count - 1
On Error GoTo Shadow3D_Err
X = Validate_Dup(MyFrm, 5) ' check type and duplicate
If X = 1 Then
Exit Function
End If
intlbls = mySection.Controls.Count - 1
X = intStyle
intStyle = IIf(X < 0, 0, IIf(X > 3, 3, intStyle))
X = intForeColor
intForeColor = IIf(X < 0, 0, IIf(X > 15, 15, intForeColor))
ReDim lblName(0 To intlbls) As String
For j = 0 To intlbls
lblName(j) = mySection.Controls(j).NAME
Next
For j = 0 To intlbls
With mySection.Controls(lblName(j))
.Height = lngheight
.Width = lngWidth
.FontName = "Times New Roman"
intFSize = .FontSize
If intFSize < intFontSize Then
.FontSize = intFontSize
End If
.FontUnderline = False
.TextAlign = intTextAlign
.BackStyle = intBackStyle
Select Case j
Case 0
lngForecolor = 8421504
Case 1 To intlbls - 2
lngForecolor = 8421504
Case intlbls - 1
lngForecolor = 0 '12632256
Case intlbls
lngForecolor = QBColor(intForeColor)
End Select
.ForeColor = lngForecolor
End With
Next
l = intX: t = intY
With mySection.Controls(lblName(1))
.Left = l
.Top = t
End With
For j = 0 To intlbls
Select Case intStyle
Case 0
l = l + LngI
t = t + LngI
Case 1
l = l + LngI
t = t - LngI
Case 2
l = l - LngI
t = t + LngI
Case 3
l = l - LngI
t = t - LngI
End Select
With mySection.Controls(lblName(j))
.Left = l
.Top = t
End With
Next
MsgLabel
Shadow3D_Exit:
Exit Function
Shadow3D_Err:
Msgbox Err.Description,, "Shadow3D"
Resume Shadow3D_Exit
End Function
Create Shadow3D Heading Style.
- Press Alt + F11 to open the Visual Basic for Applications (VBA) editor. (You can toggle between the Access Database window and the VBA editor using this keyboard shortcut.)
- Press Ctrl + G (or go to View > Immediate Window) to open the Immediate Window at the bottom of the VBA screen.
In the Immediate Window, type the following line and then press Enter:
Shadow3D 1, 4, 0
This will execute the function with the specified parameters:
1 = Text Fore-Color (e.g., Blue) 4 = Border Color (e.g., Red) 0 = Label-based design (default)
To run the Shadow3D function manually from the VBA editor:
You will notice the screen briefly flashes, indicating that the form has been updated. Minimize the Visual Basic window, and you will see a new form created with the 3D heading style applied. Along with the heading, the form also displays help text providing tips on how to customize the 3D heading with your own caption, preferred font, and font styles such as bold or italic.
Let us examine the Command Line Values.
Shadow3D is the function name.
The first parameter value 1 controls the Shadow position of the Heading Text. The first parameter value range is 0 to 3
- 0 - Shadow is tilted to the top left corner of the heading text.
- 1 - bottom left corner
- 2 - Right top corner
- 3 - Right bottom corner
The second parameter value 4 (Red color) sets the text color of the topmost label. The acceptable range of color values is from 0 - 15, based on the QBColor codes. A reference chart of these codes is provided on the page titled
Border2D Heading Text.
The third parameter value 0 creates 3D text using Label controls. This parameter is optional, and when omitted, the function defaults to creating a Label-based 3D heading.
Note: If you choose to omit this parameter, do not add a comma after the second parameter.
If the third parameter is1 then the function that creates a TextBox-based design. In this case, an expression such as ="Sample Text" is automatically inserted into the Control Source property of each TextBox layer created for the heading.You can replace the constant text in the Control Source property with your own text, or set it to display values from a field in the underlying Table or Query linked to the form. Alternatively, you can use a DLookup() function to retrieve values from a different Table or Query.
Example: =Dlookup("CountryName","Country Table","CountryCode = 'USA'")
The above example will display "United States of America" in a 3D style by retrieving the value from the CountryName field of the Country table, using the CountryCode as the lookup key. If the criteria parameter of the function needs to reference a control on the form, modify the expression accordingly to use the control name as the criteria, as shown below:
=Dlookup("CountryName","CountryTable","CountryCode = '" & Me![CCode] & "'")
[CCode] The field that stores country codes in the table or query attached to the Form. The current value of this field on the form is used to find the corresponding country name.
=), followed by a double-quote, and the closing single quote within double-quotes before the closing parenthesis, indicates that the value of [CCode] is treated as text (character data type) in the expression.Tip: Search in MS Access Help for more details on the Dlookup() Function.
Download
Download Demo Database
No comments:
Post a Comment
Comments subject to moderation before publishing.