Border3D Heading Image

If you have landed straight on this Page then please refer my earlier Article: Command-Button Animation to link the essential Library Files to your Project.  The list of Library Files and guidelines for attaching them to your project are given there. These files are required to run the program on this page successfully.

The Function given below creates an interesting and attractive Heading Style, like the sample image shown above. The Font, Font-Style (Bold, Italic), Shadow, Border and Fore-color can be customized, after creating the sample heading on a new Form.

Copy and Paste the VBA Code given below in a new Global Module in your Database. If you have already copied the first three functions (Function Names given below) and the Global Declarations from the earlier Post: Create 3D Headings on Forms then Copy and Paste the last Function Border3D() only.

The following common functions are used for all 2D/3D styles:

  • FormTxtLabels()
  • Validate_Dup()
  • MsgLabel()

If you have already copied them earlier then copy only the last Function: Border3D()

 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 
'---------------------------------------------------
'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 Border3D(ByVal intStyle As Integer, ByVal intForeColor As Integer, _
ByVal intBorderColor As Integer, Optional ByVal Label0Text1 As Integer) As String
'--------------------------------------------------
'Author : a.p.r. Pillai
'Date   : September 2006 
'--------------------------------------------------
Dim intlbls As Integer 
Dim j As Integer, ForeColor As Long, BorderColor As Long 
Dim lblName() As String, X As Integer, mySection As Section 
Dim l As Long, t As Long, I As Long, intFSize As Integer
On Error Resume Next
 I = 0.0104 * 1440 ' 0.0104 inches
 Border3D = FormTxtLabels(Label0Text1)
 Set mySection = MyFrm.Section(acDetail)
 intlbls = mySection.Controls.Count - 1 
On Error GoTo Border3D_Err
 X = Validate_Dup(MyFrm, 7) ' check type and duplicate
 If X = 1 Then
    Exit Function 
End If
 intlbls = mySection.Controls.Count - 1 
X = intForeColor 
intForeColor = IIf(X < 0, 0, IIf(X > 15, 15, intForeColor))
X = intBorderColor
intBorderColor = IIf(X < 0, 0, IIf(X > 15, 15, intBorderColor))
 X = intStyle
 intStyle = IIf(X < 0, 0, IIf(X > 3, 3, intStyle)) 
ReDim lblName(0 To intlbls) As String 
ForeColor = QBColor(intForeColor) 
BorderColor = QBColor(intBorderColor) 
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
   End With 
Next 
mySection.Controls(lblName(intlbls)).ForeColor = ForeColor
  For j = 0 To intlbls - 1
   mySection.Controls(lblName(j)).ForeColor = BorderColor
 Next
 l = intX: t = intY
 With mySection.Controls(lblName(intlbls))
   .Left = l
   .Top = t
 End With 
For j = 2 To intlbls - 1
   With mySection.Controls(lblName(j))
      Select Case j
         Case 2
           .Left = l + I
           .Top = t + I
         Case 3
           .Left = l + I
           .Top = t - I
         Case 4
           .Left = l - I
           .Top = t + I
         Case 5
           .Left = l - I
           .Top = t - I
      End Select
   End With
 Next
   For j = 0 To 1
    With mySection.Controls(lblName(j))
     '.ForeColor = 9868950
     .ForeColor = 0
    If j = 0 Then
     Select Case intStyle
        Case 0
            .Left = l - (I * 3)
            .Top = t - (I * 3)
        Case 1
            .Left = l - (I * 3)
            .Top = t + (I * 3)
        Case 2
            .Left = l + (I * 3)
            .Top = t - (I * 3)
        Case 3
            .Left = l + (I * 3)
            .Top = t + (I * 3)
     End Select
   Else
     Select Case intStyle
          Case 0
            .Left = l - (I * 2)
            .Top = t - (I * 2)
        Case 1
            .Left = l - (I * 2)
            .Top = t + (I * 2)
        Case 2
            .Left = l + (I * 2)
            .Top = t - (I * 2)
        Case 3
            .Left = l + (I * 2)
            .Top = t + (I * 2)
     End Select
   End If
     End With
 Next
 MsgLabel
 Border3D_Exit:
 Exit Function

 Border3D_Err:
 Msgbox Err.Description,, "Border3D"
 Resume Border3D_Exit
 End Function 

To Create the Border3D Heading Text, press ALT+F11 to open VBA Editing Window and press CTRL+G to display the Debug Window (Immediate Window). Type the following line in the Immediate Window and press Enter Key:

Border3D 1,4,15,0

The Module window will flash for a moment, as if it is refreshed. Minimize the VB Module Window and you will see a New Form Created and kept minimized on the task bar by the Program. Restore the Form and Save it with the Heading Text.

First, let us get familiarized with the Values entered as Parameter to the above Function. The first three Parameters are mandatory when the function is called.   If any of them is omitted then the program will show Error Message ‘Parameter not optional‘ and the fourth value is optional.

Parameter Values:

First parameter value represents the shadow position. The value range and their shadow positions are as given below:

  • 0 – Top Left
  • 1 – Bottom Left
  • 2 – Top Right
  • 3 – Bottom Right

By using one of the four values as first parameter you can display the shadow tilted to any one of the four corners of the heading.

The Second Parameter Value 4 (Red Color) is Text color and the Value Range is 0 to 15.  You can find the color numbers and their description here.

Third parameter value 15 draws White colored borders to the text and the value range is 0 to 15.

Fourth parameter value is optional, if omitted 0 is assumed and it will create a Label based Heading Text, 1 will create a Text Box based Heading.

After creating the 3D Heading, select all the labels together, by clicking and holding the left mouse button, somewhere outside near the labels, and dragging the mouse over them. Once all the controls are selected together display the Property Sheet (Press F4 or View–> Property) and change the Caption Property Value to your own Text.  Change the Font, Font Size, Font Style Bold or Italic to your liking.

Now, click somewhere on the form away from the labels to de-select them then click on the top layer of the Labels carefully, so that you don’t disturb the arrangement of labels, and change the Fore-Color of the Heading to your choice.  Now Select all the labels together, as you did earlier, press Ctrl+C to Copy them into clipboard. open your target Form or Report in Design view and Paste the Heading on it. This Form you can save it as a Template so that you can copy, modify and use it on other Forms or Reports without running the Program from the Module window again.

–oOo–

Download Demo Database