Learn Microsoft Access Advanced Programming Techniques, Tips and Tricks.

MsgBox with Office Assistant

Introduction - Access2003.


Two Message Box images are shown above.  The left side Message Box is the default style of MS-Access and the one on 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 use the default Office Assistant’s features for Message Boxes. You can change the Animation character from the Tools Menu.  Adding a 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 is only two.  The first Parameter is for the Message Text and the second one for the 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 the left top corner of both message boxes) change depending on the type of message box.  Default values of 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 and Cancel Buttons. Returned Value is vbOK or vbCancel

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

Essential Library Files

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 that are not attached to Ms-Access by default) to your Project as well. Please refer to 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

The 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 

Testing the Code

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

Download Demo Database


Share:

SHADOW3D HEADING STYLE

Introduction.

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 have their 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 to form or Report Headings.

I have several of this type of design and if this is the first one you came across on this site then you must prepare your MS-Access Project by adding a few Library Files and the 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 website. Follow the steps given below:

  1. Link a 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. The VBA Programs

  3. Copy the following main program Codes given below into a new Global VBA Module of 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
    
    
  4. The above 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 given below for this Heading Style and try it out.
  5. Copy the code given below into the same global module where you have copied the main programs, or in 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  

Create Shadow3D Heading Style.

  1. Press Alt+F11 to display the Visual Basic editing screen (you can toggle Database and VBA Window by pressing an 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.  The 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

The 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.

The 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 the third parameter is omitted, do not use a comma 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 of 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","Country Table","CountryCode = 'USA'")

The above example will show the United States of America in 3D Style from the Country Table based on the Values in CountryCode & CountryName Fields. If The criteria parameter of the Function needs the reference of 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

Download Demo Database
Share:

BORDER3D HEADING


Introduction.

If you have landed straight on this page, then please refer to 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 is 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 into 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 by the main program Border3D for all other 2D/3D styles:

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

The Functions VBA Code.

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  

How to Create

To create the Border3D Heading Text, press ALT+F11 to open the VBA Window and press Ctrl+G to display the Debug Window (Immediate Window). Type the following line in the immediate window and press the Enter key:

Border3D 1,4,15,0

The module window will flash for a moment as if it is refreshed. Minimize the VBA Window and you will see a new form created and kept minimized on the taskbar by the program. Restore the form and save it, with the Heading Text.

First, let us get familiarized with the Parameter values of the function. The first three Parameters are mandatory.   If any of them is omitted, then the program will show an Error Message 'Parameter not optional' and the fourth value is optional.

Parameter Values

The 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 the 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.

The third parameter value 15 draws white-colored borders to the text and the value range is 0 to 15.

The 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.

Customizing Text

After creating the 3D Heading, to select all the labels together, click and hold the left mouse button, somewhere outside near the labels and drag the mouse over them. After selecting all the labels together display the property sheet (Press F4 or View--> Property) and change the Caption property value with your own required text.  Change the font, font size, font style bold, or italic to your liking.

To de-select, all the labels, click somewhere on the form away from the labels. Now, you can change the fore-color of the heading of your choice.  Click on the top layer of the labels carefully so that you don’t disturb the arrangement of the labels, and change the fore-color of the Heading to your liking.  Now, select all the labels together, as you did earlier, and press Ctrl+C to copy them into the clipboard. Open your target Form or Report in design view and paste the heading on it. This form you can save 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.

Downloads

Download Demo Database
Share:

Border2D Heading Text


Introduction.

MS-Access Form/Report Design Tools are very easy to use and need only some 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 topmost 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.

The 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.

Automating Text Styling

Copy and Paste the VBA Code given below into 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 all 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 the required text, text size, color, and text in bold or italics. 

How to Run the Code Manually.

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, Label, or Text

Type the following and press the 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 of 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 to 15).  The 3rd parameter value 0 will create a Label based design and 1 will create a textbox-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 Form1 and the Border2D heading is created with a white border. 

Customizing Text Properties.

Once the Heading is created you can change text, text size, forecolor, 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 the selected state you can make the text Bold, Italic, or change the size of the text.  Select a color from the color palette for the border first. This will change the fore-color of all Labels. Now, click only on the top Label and apply a different foreground color.

Downloads

Download Demo Database
Share:

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:

COMMAND-BUTTON ANIMATION

Introduction


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

When an Application is developed under any Database Management System it should be user-friendly and visually pleasing too. An unattractive Database 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.

Here, I would like to present some Programs, that I have developed to use on the Form controls with some amusing twists in their use, in my own Projects and I am sure that you will find them interesting too.

Demo Programs are written for Access 2000 and will run in Access 97 versions too.

Attaching Access System Reference Library Files.

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

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

On the Visual Basic Editor Window, select References' from the Tools menu. Put a 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 Access Library Files may change for different versions of Microsoft Office. The Library Files List is in alphabetical order. The selected items will appear at the top of the list.

Design Modification

On the MS Access user interface, the command button control is the most frequently used control besides text boxes, 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 the command button control a more interesting and attractive control on the Form. 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, filled with some dark color, behind the command button, and with a few lines of Visual Basic Code.

Animating Command Button

The animation design is very simple. There is a rectangular control, with almost the same dimension as the Command Button and with a black background color, that is kept hidden behind the Button. When the Mouse Moves over the Command Button, the Button moves slightly up and to the left, showing part of the rectangle control, like the shadow of the command button. When the Mouse is moved out, the Command Button goes back into its original state, hiding the rectangle control again. 

When this action is repeated in quick succession the Button gives a lively appearance by moving up and down, showing the shadow on and off. Check the images given above to show both states 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

@@@Note: All object specifications on this site are in U.S. Measurements.

Those who follow the Metric System, please convert the values or select the US in the Regional Settings of the Control Panel or convert the given values into your Regional values.

Command Button Animation Design:

  1. Open one of your Access 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: The name of the rectangle-control must be the same as the command button suffixed with the word ‘Box’.

    Visible = False
    SpecialEffect = Shadowed
    BorderColor = 0
    BorderStyle = Solid
    BackStyle = Transparent
  • Drag and place the rectangle object 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.

  • 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
  • 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 part of the rectangle frame, which looks like the shadow of the Command Button. When the Mouse is moved out to the blank area in the Form Footer Section the command button goes back into 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.

    Add More Animated Command Buttons

    Any number of command buttons can be added this way anywhere on the form by placing the code for the 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 to the form footer, each button should have its own Call the ButtonAnimate Function with 1 and 0 values as a parameter at the Command Button & Form Footer MouseMove Event Procedures respectively.


    Download Demo CommandButtonAnimation.zip

    1. Command Button Animation
    2. Double Action Command Button
    3. Colorful Command Buttons
    4. Transparent Command Button
    5. Command Button Animation-2
    6. Creating Animated Command Button with VBA
    7. Command Button Color Change on Mouse Move

    Share:

    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