输入框access查询
背景 (Background)
The native message box of Microsoft Access 2013 is boring and lousy compared to the strong and clean Modern/Metro style of Windows 8+.
与强大而干净的Windows 8+的Modern / Metro风格相比，Microsoft Access 2013的本机消息框既乏味又糟糕。
You are probably just too familiar with the traditional message box of Windows 8 and 10:
您可能对Windows 8和10的传统消息框太熟悉了：
as well as the input box:
以及输入框：
Wouldn't it be nice with a more attractive style that fits Windows 8+ and 10 much better? Well, here it is:
具有更吸引人的风格以适合Windows 8+和Windows 10会更好吗？ 好吧，这里是：
and likewise:
同样：
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:
使用Microsoft Access 2013，可以使用全屏表单创建现代/地铁外观。 然后区别就突出了。 在这里您已致电：
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:
我们的Modern Box避免了样式之间的冲突。 调用代码是相同的：
Result = MsgMox( _
"This will delete all entries for this plan!", _
vbOKCancel + vbExclamation + vbDefaultButton2, _
"Reset Plan")
and this is the result:
结果如下：
Clearly, a much better match.
显然，这是更好的搭配。
造型 (Styling)
All styling is applied when opening the form:
打开表单时将应用所有样式：
Private Sub Form_Load()
' Adjust top and/or height of some controls.
Call SetControlSizes
' Apply modern colours to form.
Call SetColours
' Show specified icon.
Call SetIcon
End Sub
Private Sub Form_Open(Cancel As Integer)
Dim NoCancel As Boolean
' 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
' NoCancel has been set by SetButtonSequence.
If Not NoCancel Then
' Set close button status.
Call SetCloseButton(False)
End If
' 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:
这里的关键功能是通用的StyleCommandButtons ，在整个应用程序中都使用它来控制按钮的样式。 因此，它被放置在另一个模块中。 它从第三个模块检索配色方案：
' Adoption of Windows Phone 7.5/8.0 colour theme for VBA.
' 2017-04-19. Gustav Brock, Cactus Data ApS, CPH.
' Version 1.1.0
' License: MIT.
' *
' Windows Phone colour enumeration.
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
挑战性 (Challenges)
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:
最初，您可能会认为，该任务基本上只是设计一个无边界表单并以对话模式打开它。 但是，如果您这样做，则Windows的边框样式将强制显示在窗体上。 更糟糕的是，应用了无法控制的标题“消息”：
To be honest, this is for a reason. Without this titlebar, you cannot drag the form. Therefor, 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:
老实说，这是有原因的。 没有此标题栏，您将无法拖动表单。 因此，即使您想要的是对话表单，也无法在对话模式下打开该表单，因此必须将自定义代码添加到：
- simulate the dialogue mode 模拟对话模式
- enable dragging of the form 启用表格拖动
Other tasks to replicate the true function of MsgBox are:
复制MsgBox真正功能的其他任务是：
- enable and arrange the buttons and the icon 启用并排列按钮和图标
- expand the form to hold four buttons 展开表格以容纳四个按钮
- extend the form to hold an extended prompt 扩展表格以保留扩展提示
- retrieve localized captions for the buttons 检索按钮的本地化字幕
- enable calling a help file 启用呼叫帮助文件
- return the correct result for any mouse or key click 返回任何鼠标或按键的正确结果
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+.
此外，可以使用样式常量vbMsgBoxRtlReading在视觉上从右到左镜像MsgBox。 但是，由于我不需要此功能，因此无法在MsgMox中实现。 其他样式常量也将被忽略-vbApplicationModal，vbMsgBoxSetForeground，vbSystemModal-因为这些常量在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.
最后，必须创建包装函数以直接替代MsgBox和InputBox。 这样，可以通过简单的查找/替换来实现Modern / Metro框，而需要零代码重写。
Windows 10样式 (Windows 10 styling)
Under Windows 10, the visual style of the windows is slightly different from Windows 8.0/8.1. The titlebar is smaller, and the close button (if present) is animated to be red when hovered by the mouse.
在Windows 10下，窗口的视觉样式与Windows 8.0 / 8.1略有不同。 标题栏较小，并且当鼠标悬停时，关闭按钮（如果存在）会变为红色。
Both MsgMox and InputMox adopt automatically by calling a small helper function when loading:
MsgMox和InputMox都通过在加载时调用一个小的辅助函数来自动采用：
' Checks if the primary (current) Windows version is Windows 10.
' Returns True if Windows version is 10, False if not.
'
' The call to WMI takes about 50 ms. Thus, to speed up repeated calls,
' the result is kept in the static variable OsVersion.
'
' 2019-04-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function IsWindows10() As Boolean
Const NoVersion As Integer = 0
Const Version10 As Integer = 10
Static OsVersion As Integer
Dim OperatingSystem As Object
Dim Result As Boolean
If OsVersion = NoVersion Then
' Connect to WMI and obtain instances of Win32_OperatingSystem
For Each OperatingSystem In GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
If OperatingSystem.Primary = True Then
OsVersion = Val(OperatingSystem.Version)
Exit For
End If
Next
Else
' Repeated call. OsVersion has previously been found.
End If
Result = (OsVersion = Version10)
IsWindows10 = Result
End Function
for example here, where the style of the close button is set:
例如，在此处设置关闭按钮的样式：
Private Sub SetCloseButton(ByVal Active As Boolean)
Static Initialized As Boolean
Static Status As Boolean
If Not NoCancel Then
If IsWindows10 Then
If (Not Initialized) Or (Status <> Active) Then
Me!PictureCloseActive.Visible = Active
Me!PictureCloseInactive.Visible = Not Active
Status = Active
End If
Else
If Not Initialized Then
Me!PictureClose.Visible = True
End If
End If
Initialized = True
End If
End Sub
模拟对话模式 (Simulating dialogue mode)
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:
这是通过在打开表单后运行一个无限循环来实现的。 这里的主要问题是找到一个睡眠时间，该睡眠时间在提供快速退出循环的同时不会给CPU造成负担：
' API call for sleep function.
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
' Opens 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.
'
' 2018-04-26. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function OpenFormDialog( _
ByVal FormName As String, _
Optional ByVal TimeOut As Long, _
Optional ByVal OpenArgs As Variant = Null) _
As Boolean
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.
' Bring form to front; it may hide behind a popup form.
DoCmd.SelectObject acForm, FormName
' 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.
研究在线注释以获取详细信息。
()
Enable dragging of the form
启用表格拖动
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.
' WindowLeft and WindowTop must be within the range of Integer.
Const TopLeftMax As Single = 2 ^ 15 - 1
Const TopLeftMin As Single = -2 ^ 15
' 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
' Limit Top and Left.
If WindowTop > TopLeftMax Then
WindowTop = TopLeftMax
ElseIf WindowTop < TopLeftMin Then
WindowTop = TopLeftMax
End If
If WindowLeft > TopLeftMax Then
WindowLeft = TopLeftMax
ElseIf WindowLeft < TopLeftMin Then
WindowLeft = TopLeftMax
End If
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)
Call SetCloseButton(False)
' 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
()
Button sequence and form resizing
按钮顺序和表格大小调整
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 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
Else
' Reposition Cancel button and form's close button (picture).
Me!ButtonCancel.Left = Me!ButtonCancel.Left + WindowExpand
Me!PictureClose.Left = Me!PictureClose.Left + WindowExpand
Me!PictureCloseActive.Left = Me!PictureCloseActive.Left + WindowExpand
Me!PictureCloseInactive.Left = Me!PictureCloseInactive.Left + WindowExpand
Me!BoxInactive.Left = Me!BoxInactive.Left + WindowExpand
End If
' Extend the form to 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:
您会注意到数组广泛用于保存按钮及其属性，并且该表单根据需要进行了扩展和扩展。 这是一个例子：
(
)
Localized captions
本地字幕
Notice the localized captions above. These are pulled from user32.dll with a few API calls:
请注意上面的本地化字幕。 这些是通过一些API调用从user32.dll中提取的：
' API functions for retrieval of localized button captions.
#If VBA7 Then
Private Declare PtrSafe Function LoadString Lib "user32" Alias "LoadStringA" ( _
ByVal hInstance As LongPtr, _
ByVal wID As Long, _
ByVal lpBuffer As String, _
ByVal nBufferMax As Long) _
As Long
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" ( _
ByVal lpFileName As String) _
As LongPtr
#Else
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
#End If
Private Sub FillCaptions()
' Retrieve localized button captions into array Captions.
Const FileName As String = "user32.dll"
Const BufferMax As Long = 256
#If VBA7 Then
Dim Instance As LongPtr
#Else
Dim Instance As Long
#End If
Dim Buffer As String
Dim StringLength 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
()
Calling a help file
调用帮助文件
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.
尽管很少使用，但已实现了此功能。 在1.2.0版中，所有与API调用相关的代码已移至一个单独的模块HtmlHelp ，因为它可以单独使用，并且不会使ModernBox模块混乱。
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
()
Return the result
返回结果
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.
如果单击确定，则输入框仅将键入的字符串返回给全局变量mbInputText；如果单击取消，则将其返回空字符串。
包装全部 (Wrapping it all up)
As mentioned earlier, the forms are controlled by functions, MsgMox and InputMox, very similar to MsgBox and InputBox:
如前所述，表单由MsgMox和InputMox函数控制，与MsgBox和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"
' Opens a message box, using form ModernBox, similar to VBA.MsgBox.
'
' 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.
'
' 2018-04-26. Gustav Brock, Cactus Data ApS, CPH.
'
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
' 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
' Opens an input box, using form ModputBox, similar to VBA.InputBox.
'
' 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.
'
' 2018-04-26. Gustav Brock, Cactus Data ApS, CPH.
'
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
' 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.
窗体打开后，将读取控制其行为的全局变量，关闭窗体时，它将在另一个全局变量mbResult或mbInputText中返回结果，然后由函数返回该结果。
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.
您会注意到，与MsgBox和InputBox相比，已添加了一项功能：超时。 这对于无人值守的操作或其他您不希望应用程序挂起等待用户交互的情况很有用。
错误框随时可以使用 (Error box ready to use)
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:
如果您提供带有错误代码和描述的友好错误处理供用户报告，则可以利用包装MsgMox的ErrorMox函数，以便仅用零个附加代码即可显示有用的错误信息：
' Opens a MsgMox predefined for displaying the error number, source, and description if Err <> 0.
' Also reestablishes the application window, if Echo is False, and the cursor, if Hourglass is True,
' and resets the Status line.
'
' 2018-04-26. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ErrorMox( _
Optional ByVal Topic As String) _
As String
' 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.
如您所见，它从Err对象获取信息并对其进行格式化，并以应用程序的标题作为结尾。
The project for download contains a tiny demo to demonstrate this, and this is the result:
供下载的项目包含一个微型演示程序来演示此，这是结果：
码 (Code)
The complete ModernBox project consists of two forms and four modules which can be copy/pasted into any application.
完整的ModernBox项目包含两种形式和四个模块，可以将其复制/粘贴到任何应用程序中。
It has been tested in Access 365 32-bit and 64-bit under Windows 10.
它已在Windows 10下的Access 365 32位和64位中进行了测试。
From version 1.1 also a collection of helper functions for the colour theme is included.
从1.1版开始，还包括了用于颜色主题的辅助功能的集合。
Also, always the newest version at GitHub: VBA.ModernBox
另外，始终是GitHub上的最新版本： VBA.ModernBox
I hope you found this article useful. You are encouraged to ask questions, report any bugs or make any other comments about it below.
希望本文对您有所帮助。 鼓励您在下面提出问题，报告任何错误或对此作出任何其他评论。
Note: If you need further "Support" about this topic, please consider using the Ask a Question feature of Experts Exchange. I monitor questions asked and would be pleased to provide any additional support required in questions asked in this manner, along with other EE experts.
注意 ：如果您需要有关此主题的更多“支持”，请考虑使用Experts Exchange 的“提问”功能。 我会监督提出的问题，并很高兴与其他电子工程师一起为以这种方式提出的问题提供所需的任何其他支持。
Please do not forget to press the "Thumbs Up" button if you think this article was helpful and valuable for EE members.
如果您认为本文对EE成员有用且有价值，请不要忘记按下“竖起大拇指”按钮。
输入框access查询
扫一扫
1363
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
