CREATE 3D-HEADINGS ON FORMS

Form/Report Heading Text with the above Design can be created within seconds filling-in your own text and forecolor of your choice. Even though you can do it manually by copying and pasting the same label several times one over the other slightly off-setting with the previous one, doing it every time, when you need them, is a waste of time. Instead, adding a few functions to the global module of your Project will help you to create it in seconds and can be added to your Forms/Reports, while designing them with required text, color and style.

Before proceeding further ensure that you have linked the essential Project Library Files to your Project otherwise you may end up with Error while running the code. Read my earlier post Command-Button Animation and follow the steps described there to Link all the essential Library Files to your Project.

1. Copy and Paste the following code in a new Global Module and save it:

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 

FormTxtLabels_Err: 
MsgBox Err.Description, , "FormTxtLabels" 
FormTxtLabels = "" 
Resume FormTxtLabels_Exit 
End Function 


Public Function Validate_Dup(ByRef MyFrm As Form, _
ByVal intNooflabels As Integer) As Integer 

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 Heading3D(ByVal intStyle As Integer, _
ByVal intForeColor As Integer, _ 
Optional ByVal Label0Text1 As Integer) As String 

'------------------------------------------------------------ 
'Author : a.p.r. pillai 
'Date : September 2006 
'------------------------------------------------------------ 
Dim intlbls As Integer, mySection As Section 
Dim j As Integer, intFSize As Integer 
Dim lblName() As String, lngForecolor As Long, x As Integer 
Dim l As Long, t As Long 

On Error Resume Next 

Heading3D = FormTxtLabels(Label0Text1) 

Set mySection = MyFrm.Section(acDetail) 
intlbls = mySection.Controls.Count - 1 

On Error GoTo Heading3D_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 = 0  
Case 1 To intlbls - 2 
lngForecolor = 9868950 
Case intlbls - 1 
lngForecolor = 16777215 
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 3 
l = l - LngI 
t = t - LngI 
Case 2 
l = l - LngI 
t = t + LngI 
End Select 
With mySection.Controls(lblName(j)) 
.Left = l 
.Top = t 
End With 
Next 

MsgLabel 

Heading3D_Exit: 
Exit Function 

Heading3D_Err: 
Msgbox Err.Description, ,"Heading3D" 
Resume Heading3D_Exit 
End Function 

The first 3 Functions in the above code:

FormTxtLabels()

Validate_Dup()

MsgLabel()

are Sub-Routines for the Heading3D() Function (they are not direcctly run) and will be used for other forth-coming Heading Styles too.

To create the 3D-Heading on a new Form, display the Visual Basic Window (if not already open) press Alt+F11. Press Ctrl+G (or select Immediate Window from View Menu) to display the Immediate Window.

Type the next line in the immediate window and press Enter Key:

Heading3D 1, 0

The module window will flash as if it is refreshed. Minimize the Visual Basic window. You will see the program has created a new Form (with name like Form1 etc.) and created a 3D-Heading with default text msaccesstips.com with help-text below it suggesting modifications. Select all the controls together by clicking outside the controls and draging the mouse over them. Copy and paste them in your Form/Report where you need it. Display the property sheet while all the controls are selected together and change the caption property with your own text. Change the font or style like Bold, Italic etc, if needed. Click on the top control carefully (so that the top label is not moved out of place) and change the color of your choice. If you have selected all the controls together to change Color by mistake, press Ctrl+Z (undo).

The position of the 3D-Text shadow can be controlled by the First Parameter to the Function and the following Values are used:

0 - Shadow tilted to Left top corner

1 - Left Bottom Corner

2 - Right top Corner

3 - Bottom Right corner

The Second Parameter Value 0 creates Label based 3D-Heading and 1 creates TextBox based 3D-Heading with it’s Control Source Property set with a Formula to display the Text. On the TextBox’s Control Source Property you may change to Display Values from the underlying Data Fields (of Tables/Queries) which will change when the Records are moved from one to the other on your Data Editing Form.

Tip: You may omit the second parameter while running the Function, if you need only a Label based 3D-Heading.

--oOo--

---

Download Demo Database

---

Border 2D Heading Style.
Border 3D Heading Style
Shadow 3D Heading Style