Learn the top ten threats that are present in modern web-application development and how to protect your business from them.
The native message box of Microsoft Access 2013 is boring and lousy compared to the strong and clean Modern/Metro style of Windows 8+. You are probably just too familiar with the traditional message box:
as well as the input box:
Wouldn't it be nice with a more attractive style that fits Windows 8 and later much better? Well, here it is:
With Microsoft Access 2013 it is possible to create a Modern/Metro look using the full-screen forms. Then the difference stands out. Here you have called:
Result = MsgBox( _ "This will delete all entries for this plan!", _ vbOKCancel + vbExclamation + vbDefaultButton2, _ "Reset Plan")
and this could be the result:
This clash between styles is avoided with our Modern Box. The calling code is identical:
Result = MsgMox( _ "This will delete all entries for this plan!", _ vbOKCancel + vbExclamation + vbDefaultButton2, _ "Reset Plan")
and this is the result:
A much better match.
All styling is applied when opening the form:
Private Sub Form_Load() ' Apply modern colours to form. Call SetColours ' Show specified icon. Call SetIcon End Sub Private Sub Form_Open(Cancel As Integer) ' Set the messagebox style variables. Call SetMsgBoxStyle ' Set caption of title bar. Call SetTitle ' Set prompt. Call SetPrompt ' Set active buttons and captions and taborder. ' Eventually resize form to accommodate buttons and a supersized prompt. Call SetButtonSequence ' Set default result value. Result = vbCancel End Sub
The exception is the colouring of the buttons as this changes according to which button is the default:
Private Sub ButtonFocus(ByVal ButtonIndex As Long) ' Style buttons to indicate the new default button. ' Set (new) default button. Me("Button" & CStr(ButtonIndex)).Default = True ' Set (new) default result value. Result = Buttons(ButtonIndex)(ButtonProperty.Value) ' Recolour visible buttons. Call StyleCommandButtons(Me) End Sub Public Sub StyleCommandButtons(ByRef frm As Form) ' Apply a style to all non-transparent command buttons on a form. ' 2014-10-10. Gustav Brock, Cactus Data ApS, CPH. ' Version 1.0.0 ' License: MIT. ' Requires: ' Module: ' ModernThemeColours ' Typical usage: ' ' Private Sub Form_Load() ' Call StyleCommandButtons(Me) ' End Sub Dim ctl As Control For Each ctl In frm.Controls If ctl.ControlType = acCommandButton Then If ctl.Transparent = True Then ' Leave transparent buttons untouched. Else ctl.Height = 454 ctl.UseTheme = True If ctl.Default = True Then ctl.BackColor = wpThemeColor.Cobalt Else ctl.BackColor = ctl.Parent.Section(ctl.Section).BackColor End If ctl.HoverForeColor = ctl.BackColor ctl.HoverColor = wpThemeColor.White ctl.PressedColor = wpThemeColor.Darken ctl.BorderWidth = 2 ctl.BorderStyle = 1 ctl.BorderColor = wpThemeColor.White ctl.ForeColor = wpThemeColor.White ctl.FontName = "Segoe UI" ctl.FontSize = 11 ctl.FontBold = True ctl.FontItalic = False End If End If Next Set ctl = Nothing End Sub
The key function here is the generic StyleCommandButtons which is used throughout the application to control the style of buttons. Therefore it is placed in another module. It retrieves a colour scheme from a third module:
' Adoption of Windows Phone 7.5/8.0 colour theme for VBA. ' 2014-10-10. Gustav Brock, Cactus Data ApS, CPH. ' Version 1.0.0 ' License: MIT. Public Enum wpThemeColor ' Official colour names from WP8. Lime = &HC4A4& Green = &H17A960 Emerald = &H8A00& Teal = &HA9AB00 Cyan = &HE2A11B Cobalt = &HEF5000 Indigo = &HFF006A Violet = &HFF00AA Pink = &HD072F4 Magenta = &H7300D8 Crimson = &H2500A2 Red = &H14E5& Orange = &H68FA& Amber = &HAA3F0 Yellow = &HC8E3& Brown = &H2C5A82 Olive = &H64876D Steel = &H87766D Mauve = &H8A6076 Sienna = &H2D52A0 ' Colour name aliases from WP7.5 Viridian = &HA9AB00 Blue = &HE2A11B Purple = &HFF00AA Mango = &H68FA& ' Used for black in popups. Darken = &H1D1D1D ' Additional must-have names for grey scale. Black = &H0& DarkGrey = &H3F3F3F Grey = &H7F7F7F LightGrey = &HBFBFBF White = &HFFFFFF End Enum
At first, you may think, this task basically is just to design a borderless form and open it in dialogue mode. However, if you do so, the border style of Windows is forced upon the form. Even worse, an uncontrollable title "Message" is applied:
To be honest, this is for a reason. Without this titlebar, you cannot drag the form. So, even if what you want is a dialogue form, you cannot open the form in dialogue mode, so you will have to add custom code to:
Other tasks to replicate the true function of MsgBox are:
Further, the MsgBox can be visually right-to-left mirrored using the style constant vbMsgBoxRtlReading. This, hovewer, is not implemented in MsgMox as I have no need for this feature. Other style constants are also ignored - vbApplicationModal, vbMsgBoxSetForeground, vbSystemModal - as these have little or no impact in Windows 8+.
The input box is simpler as neither the buttons nor an icon can be controlled. The Help button is displayed only if both helpfile and content are specified. The major difference is that the opening position of the form can be specified relative to the top-left screen corner. This has little or no use with the larger screens used today, so this option has been modified to set the position relative to the application window. If left out, the form is centered relative to the application window.
Finally, wrapper functions must be created to act as a direct replacement for MsgBox and InputBox. This way, the Modern/Metro boxes can be implemented by a simple find/replace requiring zero rewriting of the code.
This has been implemented by running an endless loop after the form has been opened. The main issue here is to find a sleep time that does not load the CPU while offering fast exit from the loop:
' API call for sleep function. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Function OpenFormDialog( _ ByVal FormName As String, _ Optional ByVal TimeOut As Long, _ Optional ByVal OpenArgs As Variant = Null) _ As Boolean ' Open a modal form in non-dialogue mode to prevent dialogue borders to be displayed ' while simulating dialogue behaviour using Sleep. ' If TimeOut is negative, zero, or missing: ' Form FormName waits forever. ' If TimeOut is positive: ' Form FormName exits after TimeOut milliseconds. Const SecondsPerDay As Single = 86400 Dim LaunchTime As Date Dim CurrentTime As Date Dim TimedOut As Boolean Dim Index As Integer Dim FormExists As Boolean ' Check that form FormName exists. For Index = 0 To CurrentProject.AllForms.Count - 1 If CurrentProject.AllForms(Index).Name = FormName Then FormExists = True Exit For End If Next If FormExists = True Then If CurrentProject.AllForms(FormName).IsLoaded = True Then ' Don't reopen the form should it already be loaded. Else ' Open modal form in non-dialogue mode to prevent dialogue borders to be displayed. DoCmd.OpenForm FormName, acNormal, , , , acWindowNormal, OpenArgs End If ' Record launch time and current time with 1/18 second resolution. LaunchTime = Date + CDate(Timer / SecondsPerDay) Do While CurrentProject.AllForms(FormName).IsLoaded ' Form FormName is open. ' Make sure form and form actions are rendered. DoEvents ' Halt Access for 1/20 second. ' This will typically cause a CPU load less than 1%. ' Looping faster will raise CPU load dramatically. Sleep 50 If TimeOut > 0 Then ' Check for time-out. CurrentTime = Date + CDate(Timer / SecondsPerDay) If (CurrentTime - LaunchTime) * SecondsPerDay > TimeOut / 1000 Then ' Time-out reached. ' Close form FormName and exit. DoCmd.Close acForm, FormName, acSaveNo TimedOut = True Exit Do End If End If Loop ' At this point, user or time-out has closed form FormName. End If ' Return True if the form was not found or was closed by user interaction. OpenFormDialog = Not TimedOut End Function
Study the in-line comments for details.
One function inside the forms handles this:
' Parameters for mouse action. Private Enum MouseAction MouseDown = 1 MouseMove = 0 MouseUp = -1 End Enum Private Sub FormMove(Button As Integer, Shift As Integer, X As Single, Y As Single, _ ByVal MouseAction As MouseAction) ' Move the form by dragging the title bar or the label upon it. ' Statics to hold the position of the form when mouse is clicked. Static PositionX As Single Static PositionY As Single ' Static to hold that a form move is enabled. Static MoveEnabled As Boolean Dim WindowTop As Single Dim WindowLeft As Single ' The value of MoveEnable indicates if the call is from ' mouse up, mouse down, or mouse move. If MouseAction = MouseMove Then ' Move form. If MoveEnabled = True Then ' Form move in progress. If Button = acLeftButton Then ' Calculate new form position. WindowTop = Me.WindowTop + Y - PositionY WindowLeft = Me.WindowLeft + X - PositionX ' Reposition form. Me.Move WindowLeft, WindowTop End If End If Else ' Enable/disable form move. If Button = acLeftButton Then ' Only left-button click accepted. 'If MoveEnable = True Then If MouseAction = MouseDown Then ' MouseDown. ' Store cursor start position. PositionX = X PositionY = Y MoveEnabled = True Else ' MouseUp. ' Stop form move. MoveEnabled = False End If End If End If End Sub
Armed with this, the mouse actions control if we can drag the form:
Private Sub LabelTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ' Enable dragging of the form. Call FormMove(Button, Shift, X, Y, MouseDown) End Sub Private Sub LabelTitle_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ' Drag the form if dragging is enabled. Call FormMove(Button, Shift, X, Y, MouseMove) End Sub Private Sub LabelTitle_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ' Disable dragging of the form. Call FormMove(Button, Shift, X, Y, MouseUp) End Sub
Setting the button sequence in the message box is a bit more complicated than you may think. Some exclude the normal Cancel button of the form itself or the captions changes, and a Help button can be added. This is solved by stacking four buttons on first position, then repositioning these as needed. The main function is this:
Private Sub SetButtonSequence() ' Arrange from one to four visible buttons and refresh their captions. ' Maximum count of enabled (visible) buttons including Help button. Const MaxButtonCount As Long = 3 + 1 ' First button index. Const FirstButton As Long = 0 ' Undefined result value for Help button and inactive buttons. Const MsgBoxResultNone As Long = 0 Dim WindowWidth As Long Dim WindowExpand As Long Dim WindowExtend As Long Dim ActiveButtonCount As Long Dim HelpButtonCount As ButtonCount Dim ButtonIndex As Long Dim NoCancel As Boolean Dim LineCount As Integer ' Fill array of localized captions. Call FillCaptions ' Fill array of button positions. Call FillPositions If HelpButton = vbMsgBoxHelpButton Then ' The Help button shall be displayed. HelpButtonCount = ButtonCount.Help End If ' Set captions and return values on active (visible) buttons. Select Case ButtonSequence Case vbAbortRetryIgnore ActiveButtonCount = ButtonCount.AbortRetryIgnore Buttons(FirstButton) = Array(True, Captions(ButtonCaption.ButtonAbort), VbMsgBoxResult.vbAbort) Buttons(FirstButton + 1) = Array(True, Captions(ButtonCaption.ButtonRetry), VbMsgBoxResult.vbRetry) Buttons(FirstButton + 2) = Array(True, Captions(ButtonCaption.ButtonIgnore), VbMsgBoxResult.vbIgnore) NoCancel = True Case vbOKCancel ActiveButtonCount = ButtonCount.OKCancel Buttons(FirstButton) = Array(True, Captions(ButtonCaption.ButtonOK), VbMsgBoxResult.vbOK) Buttons(FirstButton + 1) = Array(True, Captions(ButtonCaption.ButtonCancel), VbMsgBoxResult.vbCancel) Case vbOKOnly ' Note: Any click action (except Help) will result in Cancel. ActiveButtonCount = ButtonCount.OKOnly Buttons(FirstButton) = Array(True, Captions(ButtonCaption.ButtonOK), VbMsgBoxResult.vbCancel) Case vbRetryCancel ActiveButtonCount = ButtonCount.RetryCancel Buttons(FirstButton) = Array(True, Captions(ButtonCaption.ButtonTryAgain), VbMsgBoxResult.vbRetry) Buttons(FirstButton + 1) = Array(True, Captions(ButtonCaption.ButtonCancel), VbMsgBoxResult.vbCancel) Case vbYesNo ActiveButtonCount = ButtonCount.YesNo Buttons(FirstButton) = Array(True, Captions(ButtonCaption.ButtonYes), VbMsgBoxResult.vbYes) Buttons(FirstButton + 1) = Array(True, Captions(ButtonCaption.ButtonNo), VbMsgBoxResult.vbNo) NoCancel = True Case vbYesNoCancel ActiveButtonCount = ButtonCount.YesNoCancel Buttons(FirstButton) = Array(True, Captions(ButtonCaption.ButtonYes), VbMsgBoxResult.vbYes) Buttons(FirstButton + 1) = Array(True, Captions(ButtonCaption.ButtonNo), VbMsgBoxResult.vbNo) Buttons(FirstButton + 2) = Array(True, Captions(ButtonCaption.ButtonCancel), VbMsgBoxResult.vbCancel) Case Else ' Identical to OKOnly. ' Note: Any click action (except Help) will result in Cancel. ActiveButtonCount = ButtonCount.OKOnly Buttons(FirstButton) = Array(True, Captions(ButtonCaption.ButtonOK), VbMsgBoxResult.vbCancel) End Select ' Add a Help button at far right if requested. If HelpButtonCount = 1 Then HelpButtonIndex = ActiveButtonCount Buttons(HelpButtonIndex) = Array(True, Captions(ButtonCaption.ButtonHelp), MsgBoxResultNone) ActiveButtonCount = ActiveButtonCount + HelpButtonCount End If ' Reset remaining buttons. For ButtonIndex = ActiveButtonCount To MaxButtonCount - 1 Buttons(ButtonIndex) = Array(False, vbNullString, MsgBoxResultNone) Next ' Set display status for all buttons. For ButtonIndex = FirstButton To MaxButtonCount - 1 With Me("Button" & CStr(ButtonIndex)) .Visible = Buttons(ButtonIndex)(ButtonProperty.Visible) .Caption = Buttons(ButtonIndex)(ButtonProperty.Caption) End With Next ' Expand the form to make room for multiple buttons. WindowExpand = Positions(ActiveButtonCount - 1) - Positions(FirstButton) WindowWidth = Me.WindowWidth + WindowExpand Me.Move Me.WindowLeft, Me.WindowTop, WindowWidth ' Remove form's close button for certain button combinations. If NoCancel = True Then Me!ButtonCancel.Enabled = False Me!PictureClose.Visible = False Else ' Reposition Cancel button and form's close button (picture). Me!ButtonCancel.Left = Me!ButtonCancel.Left + WindowExpand Me!PictureClose.Left = Me!PictureClose.Left + WindowExpand End If ' Extend the form fit a supersized prompt. LineCount = PromptLineCount() If LineCount > 0 Then ' Extend the form and controls (except buttons) to ' make room for multiple prompt lines. WindowExtend = FormExtend(LineCount) End If ' Position active buttons. For ButtonIndex = FirstButton To ActiveButtonCount - 1 With Me("Button" & CStr(ButtonIndex)) .Left = Positions(ButtonIndex) .Top = .Top + WindowExtend End With Next ' Apply tab settings. Call SetDefaultButton End Sub
You will notice the extensive use of arrays for holding the buttons and their properties, and that the form is expanded and extended as needed. Here is an example:
Notice the localized captions above. These are pulled from user32.dll with a few API calls:
' API functions for retrieval of localized button captions. Private Declare Function LoadString Lib "user32" Alias "LoadStringA" ( _ ByVal hInstance As Long, _ ByVal wID As Long, _ ByVal lpBuffer As String, _ ByVal nBufferMax As Long) _ As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" ( _ ByVal lpFileName As String) _ As Long Private Sub FillCaptions() ' Retrieve localized button captions into array Captions. Const FileName As String = "user32.dll" Const BufferMax As Long = 256 Dim Buffer As String Dim StringLength As Long Dim Instance As Long Dim CaptionId As Long Instance = LoadLibrary(FileName) ' Read localized captions into static array. For CaptionId = FirstCaptionId To LastCaptionId Buffer = String(BufferMax, vbNullChar) StringLength = LoadString(Instance, CaptionId, Buffer, BufferMax) Captions(CaptionId) = Left(Buffer, StringLength) Next End Sub
Though hardly used very often, this feature is implemented. In version 1.2.0, all the code related to the API call has been moved to a separate module, HtmlHelp, as it can be used separately, and to not clutter the ModernBox module.
What's left is a set of simple functions to open and close the Help Viewer:
' Open a help file at context ContextID if found. ' ' Note: ' An opened help viewer window must be closed before exiting the application, ' or, most likely, Access will chrash. ' ' Requires: ' HtmlHelp ' ' 2018-04-26. Gustav Brock, Cactus Data ApS, CPH. ' Public Function OpenHelp( _ ByVal HelpFile As String, _ Optional ByVal ContextID As Long = 1) _ As Boolean Const MinimumContextID As Long = 1 Dim Success As Boolean ' Adjust invalid context IDs. If ContextID < MinimumContextID Then ContextID = MinimumContextID End If ' Open help file. ' Fails silently if help file or context ID is not found. Success = HelpControl(OpenContext, HelpFile, ContextID) OpenHelp = Success End Function ' Close all open HTML Help Viewer windows. ' ' Requires: ' HtmlHelp ' ' 2018-04-26. Gustav Brock, Cactus Data ApS, CPH. ' Public Function CloseHelp() As Boolean Dim Success As Boolean ' Close help file. ' Fails silently if no Help Viewer windows are open. Success = HelpControl(CloseAll) CloseHelp = Success End Function
The message result to return is preset every time a button gains focus:
Private Sub ButtonFocus(ByVal ButtonIndex As Long) ' Style buttons to indicate the new default button. ' Set (new) default button. Me("Button" & CStr(ButtonIndex)).Default = True ' Set (new) default result value. Result = Buttons(ButtonIndex)(ButtonProperty.Value) ' Recolour visible buttons. Call StyleCommandButtons(Me) End Sub
and at the same time the buttons are recoloured to indicate which button now is the default button.
The input box simply returns the typed in string to the global variable mbInputText if OK is clicked, or an empty string if Cancel is clicked.
As mentioned earlier, the forms are controlled by functions, MsgMox and InputMox, very similar to MsgBox and InputBox:
' Global variables for forms ModernBox and ModputBox. Public mbPrompt As String Public mbTitle As Variant Public mbHelpFile As String Public mbContext As Long ' Global variables for form ModernBox. Public mbButtons As VbMsgBoxStyle ' Global variables for form ModputBox. Public mbDefault As String Public mbXPos As Variant Public mbYPos As Variant ' Global variable set by form ModernBox when closed. Public mbResult As VbMsgBoxResult ' Global variable set by form ModputBox when closed. Public mbInputText As String ' Form name of the modern message box. Private Const ModernBoxName As String = "ModernBox" ' Form name of the modern input box. Private Const ModputBoxName As String = "ModputBox" Public Function MsgMox( _ Prompt As String, _ Optional Buttons As VbMsgBoxStyle = vbOKOnly, _ Optional Title As Variant = Null, _ Optional HelpFile As String, _ Optional Context As Long, _ Optional TimeOut As Long) _ As VbMsgBoxResult ' Syntax. As for MsgBox with an added parameter, TimeOut: ' MsgMox(Prompt, [Buttons As VbMsgBoxStyle = vbOKOnly], [Title], [HelpFile], [Context], [TimeOut]) As VbMsgBoxResult ' ' If TimeOut is negative, zero, or missing: ' MsgMox waits forever as MsgBox. ' If TimeOut is positive: ' MsgMox exits after TimeOut milliseconds, returning the result of the current default button. ' Set global variables to be read by form ModernBox. mbButtons = Buttons mbPrompt = Prompt mbTitle = Title mbHelpFile = HelpFile mbContext = Context Call OpenFormDialog(ModernBoxName, TimeOut) ' Return result value set by form ModernBoxName. MsgMox = mbResult End Function Public Function InputMox( _ Prompt As String, _ Optional Title As Variant = Null, _ Optional Default As String, _ Optional XPos As Variant = Null, _ Optional YPos As Variant = Null, _ Optional HelpFile As String, _ Optional Context As Long, _ Optional TimeOut As Long) _ As String ' Syntax. As for InputBox with an added parameter, TimeOut: ' InputMox(Prompt, [Title], [Default], [XPos], [YPos], [HelpFile], [Context], [TimeOut]) As VbMsgBoxResult ' ' Note: ' XPos and YPos are relative to the top-left corner of the ' application, not the screen as it is for InputBox. ' ' If TimeOut is negative, zero, or missing: ' InputMox waits forever as InputBox. ' If TimeOut is positive: ' InputMox exits after TimeOut milliseconds, returning an empty string. ' Set global variables to be read by form ModernBox. mbPrompt = Prompt mbTitle = Title mbDefault = Default mbXPos = XPos mbYPos = YPos mbHelpFile = HelpFile mbContext = Context Call OpenFormDialog(ModputBoxName, TimeOut) ' Return return value set by form ModputBoxName. InputMox = mbInputText End Function
When opened, the form reads the global variables that control its behaviour and, when closing, it returns the result in another global variable, mbResult or mbInputText, that then is returned by the function.
You will notice that one feature compared to MsgBox and InputBox has been added: A timeout. This can be useful for unattended operation or other situations where you don't want the application to hang waiting for a user interaction.
If you provide friendly error handling with error code and description for the user to report, you may take advantage of the function ErrorMox which wrap MsgMox so you can display useful error information with just about zero additional code:
Public Function ErrorMox( _ Optional ByVal Topic As String) _ As String ' Opens a MsgMox predefined for displaying the error number, source, and description if Err <> 0. ' Also reestablishes the application window if Echo is False, the cursor if Hourglass is True, ' and resets the Status line. ' Text to prefix the error number. Const Prefix As String = "Error" Dim Prompt As String Dim Title As String Dim Buttons As VbMsgBoxStyle Dim Message As String If Err = 0 Then ' No error. Exit. Else ' Reestablish display. DoCmd.Hourglass False DoCmd.Echo True ' Display error message. Title = ApplicationTitle Title = Title & ": " & Application.CurrentObjectName If Topic <> "" Then Title = Title & ", " & Topic End If If Prefix <> "" Then Prompt = Prefix & ": " End If Prompt = Prompt & CStr(Err.Number) & vbCrLf & _ Err.Description & "." Buttons = vbOKOnly + vbCritical MsgMox Prompt, Buttons, Title ' Clear status line. StatusLineReset ' Return message lines. Message = Title & vbCrLf & Prompt End If ErrorMox = Message End Function
As you can see, it takes info from the Err object and formats these and finish it up with the title of the application.
The project for download contains a tiny demo to demonstrate this, and this is the result:
The complete ModernBox project consists of two forms and four modules which can be copy/pasted into any application.
It has been tested in Access 2013/2016 32-bit and 64-bit under Windows 8.1/10.
From version 1.1 also a collection of helper functions for the colour theme is included.
Feel free to leave a comment.