Learn Microsoft Access Advanced Programming Techniques, Tips and Tricks.

MsgBox with Office Assistant

Two Message Box images are shown above.  The  left side Message Box is the default style of MS-Access and the one at the right side, with the Office-Cat image below,  is created in Ms-Access with the use of Office Assistant in VBA Programs. The new programs uses the default Office Assistant’s features for Message Boxes. You can change the Animation character from the Tools Menu.  By adding few VBA Functions in your MS-Access Project enables you to make use of this feature, wherever you need them in your programs.

Some frequently used message box functions are created as user-defined functions, with the use of Office Assistant, separately for ease of use in your programs,  limiting the Number of Parameters required for these Functions are only two.  The first Parameter is for Message Text and the second one for Title. The 2nd Parameter is Optional and it can be omitted, if it is not important. Button Type and Icon Type (the question mark shown on left top corner on both message boxes) changes depending on the type of message box.  Default values for these features are already added to the Function. The following user-defined functions are available and their usage Syntax is as shown below:

MsgOK("Message Text","Title") - MessageBox with only OK Button

MsgYN("Message Text","Title") MessageBox with Yes & No Buttons. Returned Value is vbYes or vbNo

MsgOKCL("Message Text","Title") - MessageBox with OK, Cancel Buttons. Returned Value is vbOK or vbCancel

The function names shown above gives an indication as what type of Command Buttons will appear on the message box and which values are returned from User responses.

First of all, you must attach the Microsoft Office 9.0 Object Library files (or whatever version of Office you have) to your Project. This is required to make use of Office Assistant features in your programs.  You must add other essential Library Files (additional VBA functions which are not attached to Ms-Access by default) to your Project as well. Please refer my earlier Post Command-Button Animation for a list of Library Files and procedures explaining how to attach them to your Project. After attaching the library files copy the following Code into a Global Module and save them:

Public Function MsgOK(ByVal strmsg As String, Optional ByVal strHeading As String) As Integer
    On Error resume next
 MsgOK = MsgBalun(strmsg, strHeading, msoButtonSetOK, msoAnimationGestureUp, msoIconAlertInfo) 
End Function



Public Function MsgOKCL(ByVal strmsg As String, Optional ByVal strHeading As String) As Integer
  On Error Resume Next
  MsgOKCL = MsgBalun(strmsg, strHeading, msoButtonSetOkCancel, msoAnimationWritingNotingSomething, msoIconAlertQuery)
End Function 



Public Function MsgYN(ByVal strmsg As String, Optional ByVal strHeading As String) As Integer
on error resume next
    MsgYN = MsgBalun(strmsg, strHeading, msoButtonSetYesNo, msoAnimationWritingNotingSomething, msoIconAlertQuery)
End Function


Private Function MsgBalun(ByVal strText As String, ByVal strTitle As String, ByVal lngButtons As Long, ByVal intAnimation, ByVal intIcon) As Integer '------------------------------------------------------------ 
'Author : a.p.r. pillai 
'Date   : September 2006 
'Rights : All Rights Reserved by www.msaccesstips.com
'------------------------------------------------------------ 
Dim lngx As Long, intVal As Integer, Balu As Balloon 
On Error GoTo MsgBaloons_Err  
With Assistant   
If .On = False Then     
    .On = True
   '.FileName = "OFFCAT.acs"
     .Animation = msoAnimationGetAttentionMinor
     .AssistWithHelp = True
     .GuessHelp = True
     .FeatureTips = False
     .Visible = True
End If 
End With
  Set Balu = Assistant.NewBalloon
 With Balu
     .Animation = intAnimation
     .Icon = intIcon
    .Heading = strTitle
    .Text = strText
    .BalloonType = msoBalloonTypeButtons
    .Button = lngButtons
  Select Case Balu.Show
        Case msoBalloonButtonOK
            MsgBalun = vbOK
        Case msoBalloonButtonCancel
           MsgBalun = vbCancel
        Case msoBalloonButtonYes
           MsgBalun = vbYes
        Case msoBalloonButtonNo
           MsgBalun = vbNo
 End Select
 End With
  Assistant.Visible = False

MsgBaloons_Exit: 
Exit Function  

MsgBaloons_Err: 
MsgBox Err.Description, , "MsgBaloons" 
Resume MsgBaloons_Exit 
End Function 

You can use these Functions without bothering about selecting the Button-Type, IconType etc. that you normally need to give along with the Message Box Command like:

vbYesNo+vbDefaultButton2+vbQuestion

Usage Example:

If MsgYN("Select Yes to Proceed, No to Cancel.","cmdProcess") = vbYes then
    Docmd.runmacro "Process" 
End if 

OR

Second Parameter Title is omitted in the second example.

If MsgYN("Select Yes to Proceed, No to Cancel.") = vbYes then
    Docmd.runmacro "Process"
End if 

You can type any of the above commands in the Debug Window and press Enter Key, like the sample given below, to test the commands before using them in your programs:

MsgOK "System is preparing to Shut Down","cmdExit_Click"

OR

MsgOK "System is preparing to Shut Down"

The MsgBalun() Function is not directly used in programs.

Implement the procedures in your Project and try them out.



Download Demo Database


Share:

SHADOW3D HEADING STYLE

This is the continuation of a series of different 3D-Heading-Styles introduced for designing Microsoft Access Form/Report Headings. This design is a variant of the 3D-Heading Style presented under the Title Create 3D Headings on Forms. Both the Styles has its own beauty and once they are created you may copy the same Controls and customize them with different Fore-color, Font & Font Styles (Bold, Italics etc.) and use it on Form or Report Headings.

I have several of this type of designs and if this is the first one you came across on this site then you must prepare your MS-Access Project by adding few Library Files and Main Programs of this series (if you have not already done) before you are able to run the Code for this Heading Style and others presented on this Site. Follow the steps given below:

  1. Link few Common Library Files (they are already there in your System, you only need to attach them) to your Project by following the steps described in my earlier post with the Title Command-Button Animation
  2. Copy the following Main Program Codes given below into a new Global VBA Module in your Project and save it.

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

    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
    
    
  3. This Code implements the Main Functions of each Heading Styles presented so far including this one. Once you are ready with the above you may copy the Code for this Heading Style and try it out.
  4. Copy the Code below into the same Global Module where you have copied the Main Programs, or any Global Module you prefer and save it.
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  

To create the Shadow3D Heading Style:

  1. Press Alt+F11 to Display the Visual Basic Editing Screen (you can toggle Database and VBA Window alternatively by pressing Alt+F11 Keyboard shortcut).  Press Ctrl+G (or View --> Immediate Window) to display the Debug Window.
  2. Type the following in the Debug Window and press Enter Key:
  3. Shadow3D 1, 4,0

You will see the Screen flashes briefly, as if it is refreshed. Minimize the Visual Basic Window and you will find the above Heading Style created on a new Form. Besides the 3D heading on the form you will find some help text with tips to customize the 3D heading with your own heading text, Font or Font Style you like.

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.  First parameter value Range is 0 to 3

  • 0 - Shadow is tilted to the left top corner of the heading text.
  • 1 - bottom left corner
  • 2 - Right top corner
  • 3 - Right bottom corner

Second parameter value 4 (Red Color) is the topmost label's text color. The range of color values can be 0 to 15. The QBColor codes are given on the Page with the Title: Border2D Heading Text.

Third parameter value 0 creates 3D Text on Label controls. This is optional and can be omitted if you need only Label based 3D Text. When third parameter is omitted, do not use a coma after the second parameter. When this value is 1 it draws a Text Box based Design.  An expression, like ="Sample Text", with default text is inserted into the Control Source Property of all the Text Box layers created for the heading.

You can change the constant value in the expression with your own text, in the control source property, or change it to show values from the underlying field of Table/Query attached to the Form. Or you can write a Dlookup() Function to pick the Value from a different Table/Query.

Example: =Dlookup("CountryName","CountryTable","CountryCode = 'USA'")

The above example will show United States of America in 3D Style from the CountryTable based on the Values in CountryCode & CountryName Fields. If The criteria parameter of the Function needs the reference of a control on the Form then modify it to use the control name as criteria, as shown below:

=Dlookup("CountryName","CountryTable","CountryCode = '" & Me![CCode] & "'")

[CCode] is the Field Name where the country codes are stored in the Table/Query attached to the Form and the current value on the form is used for finding the country name. Note the single quote immediately after the equal sign followed by a double-quote and the closing single quote within double-quotes, before the closing parenthesis, indicates that [CCode] field value is character type data.

Tip: Search in MS-Access Help for more details on Dlookup() Function.

Download Demo Database
Share:

BORDER3D HEADING

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
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
Share:

Border2D Heading Text

MS-Access Form/Report Design Tools are very easy to use and needs only little practice to master them.  But creating controls like the image given above manually is very difficult, but it can be done manually too. You can do it with five identical labels by arranging one over the other, the top most one with font color red and others in white.  The four labels with white color must be moved, each one about one pixel distance, to four corners of the topmost label with red color.

Sample Report Title image is given below:

But, arranging all the labels properly in the right places, without distortion of the style, is not that easy to do manually.  The above red colored (you can customize the color later) heading text with white borders can be created in seconds with the user-defined Function given below, by automating the technique I have explained above.

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 Border2D() 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: Border2D()

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 Border2D(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, intFSize As Integer
On Error Resume Next
  
Border2D = FormTxtLabels(Label0Text1)  
Set mySection = MyFrm.Section(acDetail)  
intlbls = mySection.Controls.Count - 1  
On Error GoTo Border2D_Err  
X = Validate_Dup(MyFrm, 5) ' 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))
  
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(4))   
    .Left = l   
    .Top = t   
End With    
For j = 0 To intlbls - 1   
With mySection.Controls(lblName(j))   
If j = 0 Or j = 3 Then  .Left = l - LngI    
If j = 1 Or j = 2 Then  .Left = l + LngI    
If j = 0 Or j = 1 Then .Top = t    
If j = 1 Then .Top = t - (0.0104 * 1440)    
If j = 0 Then .Top = t + (0.0104 * 1440)    
If j = 2 Then .Top = t + LngI    
If j = 3 Then .Top = t - LngI    
End With   
Next   
MsgLabel    
Border2D_Exit:   
Exit Function    

Border2D_Err:   
MsgBox Err.Description,, "Border2D"   
Resume Border2D_Exit   
End Function

Note : Before Running this Function ensure that the essential Library files, which I have mentioned in my earlier Article Command-Button Animation, are linked to your Project. The Main Programs given under the Topic Create 3D-Headings on Forms are also required here. Copy and paste those Programs into a Global Module in your Project, if it is not already done earlier.

The above Function will create a new Form and will design the heading text on it in seconds. You can copy & paste it anywhere on Forms or Reports you like and customize it with required text, text-size, color, text in bold or italics. 

Open the VBA Module Window (if not already open) by pressing Alt+F11 then press Ctrl+G to open the Immediate Window (Debug window).

Command Syntax:

Border2D TextForeColor, TextBorderColor, LabelorText

Type the following and press Enter Key in the Debug Window:

Border2D 4,15,0

If you prefer to run the program with a Command Button click Event Procedure, then you must use text boxes on the Form to set the parameter values for the function and use references of the text boxes in command parameters.

Example:

Private Sub cmdBorder2D_Click()
   Border2D Me![txtForeColor], Me![txtBorderColor],0
End Sub

The first two Parameter values are for Text Fore-Color and Border Color respectively (Value Range is 0 – 15).  The 3rd parameter value 0 will create a Label based design and 1 will create a Tex box based design.  The third parameter value is optional, when omitted it will create a Label based design by default. 

QBColor Description QBColor Description
0 Black 8 Gray
1 Blue 9 Light Blue
2 Green 10 Light Green
3 Cyan 11 Light Cyan
4 Red 12 Light Red
5 Magenta 13 Light Magenta
6 Yellow 14 Light Yellow
7 White 15 Bright White

The Module Window will flash a little as if it is refreshed. Minimize the Module Window (with Alt+F11 you can toggle the window) to show up the Database Window and you will see a New Form is Created with the name like Form1 and the Border2D heading is created with White Border.  Once the Heading is created you can change text, text size, fore-color, border color and change the style to bold, italic etc.

To change the Heading Text, Text Style, Border Color and Text Color:

Select all the controls together and display the Property Sheet and change the Caption with the Text of your choice. While all the labels are in selected state you can make the Text Bold, Italic or change the Size of the Text.  Select a Color from the Color Pallette for Border first. This will change the Fore-color of all Labels. Now Click only on the top Label and apply a different foreground color.

Download Demo Database
Share:

CREATE 3D-HEADINGS ON FORMS

Goto Download Demo Database

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 required Caption text five or seven times, placing one over the other, each one slightly up vertically and to the right/left horizontally, off-setting with 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, Italic. When Text Box based 3D style is created you can display information from 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. Read my earlier post Command-Button Animation and follow the steps described there to Link all the essential Library Files to your Project.

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 
'---------------------------------------------------
'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 

The first 3 Functions in the above code:

FormTxtLabels()

Validate_Dup()

MsgLabel()

are Sub-Routines for the Heading3D() Function (they are not directly run) and will be used for other forthcoming 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 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 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:

  1. - Shadow tilted to 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 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.

Download Demo Database

Go Top

Share:

COMMAND-BUTTON ANIMATION

Microsoft Access (the Relational Database Management System), is the Jewell among Ms-Office Suite of Applications, with superior Designing Tools and built-in Visual Basic Language for programming. These Pages are not intended for Beginner's but for those who have the basic knowledge of Database designing with MS-Access Tables, Queries, Forms, Reports, and Macros and have general understanding of Visual Basic Language (the Programming Language of all MS-Office Applications) Modules, Class Modules, Functions and Event Procedures.

When developing an Application under any Database Management System it should be user-friendly and visually pleasing too. An un-attractive design spoils the appeal of the whole Project and it reflects the developer's lack of creativity as well as his inability to approach the data processing tasks effectively.

You can cook good food in the kitchen but if the final presentation on the table is not right then all the efforts put behind the scene doesn't get the appeal that it deserves. Like the saying goes, “face is the mirror of mind”, attractively designed Screens and Reports definitely dictates the personality of a User-friendly Application.

Here, I would like to present some of the simple Controls and Programs that I have developed for my own Projects and I am sure that you will find them interesting too.

Example Programs are written for MS-Access 2000 and will run under later versions too.

First of all, please ensure that the essential Reference Library Files are attached to your Project. Do the following to configure Microsoft Access:

Display the Visual Basic Editor Window. Select Visual Basic Editor Option from Tools Menu or Code from View Menu.

On the Visual Basic Editor Window select References' from Tools menu. Put check mark on the following Library Files in the Available References Dialogue Control:

  1. Visual Basic for Applications
  2. Microsoft Access 11.0 Object Library
  3. OLE Automation.
  4. Microsoft DAO 3.6 Object Library
  5. Microsoft ActiveX Data Objects 2.5 Library
  6. Microsoft Office 11.0 Object Library
  7. Microsoft Visual Basic for Applications Extensibility 5.3

The Version numbers of Library Files may change for different version of Microsoft Office. The Library Files List is in alphabetical order. The selected items will appear on top of the list.

On MS-Access User Interface, Command Button Control is the most frequently used object, with appropriate labels on it indicating the task executed when clicked. Besides this we never gave much attention to this Control.

Here, we are trying to make this object little more interesting and attractive. We will introduce some animated actions on the Command Button to make it lively on the screen.

We can do this with an addition of a rectangle to the command button design and with few lines of Visual Basic Code.

The Mouse movement over the Command Button will move the command button slightly up and to the left, showing part of the rectangle control like a shadow of the command button. When the Mouse is moved out and over the blank area of the Form the Command Button goes back into its original state, hiding the rectangle control again. When this action is repeated the Button gives a lively appearance by moving up and down, showing the shadow on and off. Check the images given above which shows both state of the Command Button.

Copy and paste the following VBA code into a new Global Module:

Public Function ButtonAnimate(ByVal strForm As String,ByVal mode As Integer, ByVal lblName As String)
'------------------------------------------------------------
'Command Button Animation
'Author : a.p.r. pillai
'Date : September 2006
'------------------------------------------------------------
Dim FRM As Form, l As Long, t As Long
On Error GoTo ButtonAnimate_Err
Set FRM = Forms(strForm)
l = FRM.Controls(lblName & "Box").Left
t = FRM.Controls(lblName & "Box").Top
If (mode = 1) And (FRM.Controls(lblName & "Box").Visible = False) Then
    FRM.Controls(lblName & "Box").Visible = True
    FRM.Controls(lblName).Left = l - (0.0208 * 1440)' 0.0208 inches
    FRM.Controls(lblName).Top = t - (0.0208 * 1440)' 0.0208 inches
    FRM.Controls(lblName).FontWeight = 700
ElseIf (mode = 0) And (FRM.Controls(lblName & "Box").Visible = True) Then
    FRM.Controls(lblName & "Box").Visible = False
    FRM.Controls(lblName).Left = l
    FRM.Controls(lblName).Top = t
    FRM.Controls(lblName).FontWeight = 400
End If
ButtonAnimate_Exit:
Exit Function

ButtonAnimate_Err:
Err.Clear
Resume ButtonAnimate_Exit
End Function

NB: All object specifications on this site are in U.S. measurements.

Those who follow Metric System please convert the values or select U.S. in the Regional Settings on Control Panel or convert the given values into your Regional values.

Command Button Design:

  1. Open one of your forms in Design View.
  2. Create a Command Button control on the Footer Section of the form.
  3. Display the Property Sheet (F4) of the command button and change the following Property values as given below:
    Name = cmdClose
        Caption = Close
        ControlTipText = Click
  4. Create a Rectangle Control on the footer of the form slightly smaller by height and width of the command button, so that when the command button is placed over the rectangle control it stays hidden.
  5. Change the following property values of the rectangle control:
    Name = cmdCloseBox

    Note : Name of the rectangle control must be same as the command button suffixed with the word ‘Box’.

    Visible = False
        SpecialEffect = Shadowed
        BorderColor = 0
        BorderStyle = Solid
        BackStyle = Transparent
  6. Drag and place the rectangle control correctly underneath the command button control completely hidden. You can use Ctrl-Key with Arrow Keys in MS-Access 2000 or Arrow Key alone in later Versions to move the rectangle control precisely behind the Command Button.

    The Rectangle control will not be visible when correctly placed underneath the Command Button. If necessary, click the Send-to-Back Toolbar Button (or Select Send-to-Back from the Format Menu), if the Rectangle Control is overlapping the Command Button.

  7. Copy and paste the following Code into the Form’s Visual Basic Module and save the Form:
    Private Sub cmdClose_MouseMove(Button as Integer, Shift as Integer, X as Single, Y as single)
    ButtonAnimate Me.Name, 1, "cmdClose"
    End Sub
    
    Private Sub FormFooter_MouseMove(Button as Integer, Shift As Integer, X As Single, Y As Single)
    ButtonAnimate Me.Name, 0, "cmdClose"
    End Sub
  8. Open the form in normal view and try moving the Mouse over the Command Button and over the blank area in the Form Footer in a continuous stroke.

When the Mouse moves over the command button the button moves slightly up and to the left, exposing the rectangle frame, as if it is the shadow of the Command Button. When the Mouse is dragged over the blank area in the form footer the command button goes back to its original position hiding the shadow. When this action is repeated the Command Button becomes a lively control among other static controls on the form.

Any number of command buttons can be added this way anywhere on the form by placing the code for MouseMove Event Procedure. When the ButtonAnimate() Function is called the function Parameter value 1 moves the button up and 0 brings it back to its original position. If more buttons are added at the form footer, each button should have its own Call to the ButtonAnimate() Function with 1 and 0 values at the Command Button & Form Footer MouseMove Event Procedures respectively.



Download Demo Database
Share:

Translate



PageRank
Your email address:

Delivered by FeedBurner

Search

Infolinks Text Ads


Blogs Directory

Popular Posts

Search This Blog

Blog Archive

Powered by Blogger.

Labels

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

Featured Post

Function Parameter Array Passing

Last week we have explored the usage of ByVal (By Value) and ByRef (By Reference),  in the Function Parameter, to pass the value from  a Va...

Labels

Blog Archive

Recent Posts