Learn Microsoft Access Advanced Programming Techniques, Tips and Tricks.

CREATE 3D-HEADINGS ON FORMS

Introduction.

Form/Report Heading Text with the above Design can be created within seconds filling-in your own text and font color of your choice. You can create it manually by copying and pasting the same Label with the required caption text five or seven times, placing one over the other, each one slightly up vertically and to the right/left horizontally, offsetting the previous one. 

But, creating it manually every time may take several minutes, to arrange the labels properly to get the required 3D effect and it is a waste of time. Instead, we can write a function to automate and create the 3D Style heading in seconds and place it on Forms or Reports. 

The design can be customized with required Caption Text on Label controls, with text color and styles of your choice like Font, font size, Bold, and Italic. When TextBox-based 3D style is created you can display information from the Table or Query data fields.

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

The VBA Code

Copy and Paste the following code into 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 
'---------------------------------------------------
'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 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 

How the Functions are Used

The first 3 Functions in the above code:

FormTxtLabels()

Validate_Dup()

MsgLabel()

The above functions are directly called from the Heading3D() Function (they are not directly run) and will be used for other forthcoming Heading Styles too.

How to Create a Customizable Sample 3D Heading

To create the 3D-Heading on a new Form, display the Visual Basic Window (if not already open) and press Alt+F11. Press Ctrl+G (or select the Immediate Window option from the View menu) to display the Debug 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 a new Form (with a name like Form1 etc.) and create a 3D-Heading with default text msaccesstips.com and help-text below it suggesting modifications. Select all the controls together by clicking outside the controls and dragging the mouse over them. Copy and paste them into your Form/Report where you need them. Display the property sheet while all the controls remain 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 text color of your choice. If you have selected all the controls together to change color by mistake, press Ctrl+Z (undo).

Defining the Shadow Position

The position of the 3D-Text shadow can be controlled by the first parameter value of the Function and the following values are used:

  1. - Shadow tilted to the left top corner
  2. - Left Bottom Corner
  3. - Right top Corner
  4. - Bottom Right corner

The second parameter value 0 creates Label-based 3D-Heading and 1 creates TextBox-based 3D-Heading with its Control Source Property set with a Formula to display the Text. On 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.

Downloads

Download Demo Database
Share:

2 comments:

  1. plz send this software to e mail id

    ReplyDelete
  2. You can Download a Demo Database from the Link given at the bottom of the Article.

    ReplyDelete

Comments subject to moderation before publishing.

PRESENTATION: ACCESS USER GROUPS (EUROPE)

Translate

PageRank

Post Feed


Search

Popular Posts

Blog Archive

Powered by Blogger.

Labels

Forms Functions How Tos MS-Access Security Reports msaccess forms Animations msaccess animation Utilities msaccess controls Access and Internet MS-Access Scurity MS-Access and Internet Class Module External Links Queries Array msaccess reports Accesstips WithEvents msaccess tips Downloads Objects Menus and Toolbars Collection Object MsaccessLinks Process Controls Art Work Property msaccess How Tos Combo Boxes Dictionary Object ListView Control Query VBA msaccessQuery Calculation Event Graph Charts ImageList Control List Boxes TreeView Control Command Buttons Controls Data Emails and Alerts Form Custom Functions Custom Wizards DOS Commands Data Type Key Object Reference ms-access functions msaccess functions msaccess graphs msaccess reporttricks Command Button Report msaccess menus msaccessprocess security advanced Access Security Add Auto-Number Field Type Form Instances ImageList Item Macros Menus Nodes RaiseEvent Recordset Top Values Variables Wrapper Classes msaccess email progressmeter Access2007 Copy Excel Export Expression Fields Join Methods Microsoft Numbering System Records Security Split SubForm Table Tables Time Difference Utility WScript Workgroup database function msaccess wizards tutorial Access Emails and Alerts Access Fields Access How Tos Access Mail Merge Access2003 Accounting Year Action Animation Attachment Binary Numbers Bookmarks Budgeting ChDir Color Palette Common Controls Conditional Formatting Data Filtering Database Records Defining Pages Desktop Shortcuts Diagram Disk Dynamic Lookup Error Handler External Filter Formatting Groups Hexadecimal Numbers Import Labels List Logo Macro Mail Merge Main Form Memo Message Box Monitoring Octal Numbers Operating System Paste Primary-Key Product Rank Reading Remove Rich Text Sequence SetFocus Summary Tab-Page Union Query User Users Water-Mark Word automatically commands hyperlinks iSeries Date iif ms-access msaccess msaccess alerts pdf files reference restore switch text toolbar updating upload vba code