Question

当我的数据库打开时，它会显示一个带有“加载栏”的表单，该表单在显示“主菜单”表单之前报告链接外部表等的进度。主菜单有一些代码，可以在幕后以编程方式生成一个表单，上面有按钮，完成后，它会保存并重命名表单，并将其指定为子表单的SourceObject。

这一切都很好，花花公子，也就是说，直到我决定让按钮实际做一些有用的事情。在生成按钮的循环中，它将VBA代码添加到子窗体的模块中。出于某种原因，这样做会使VBA完成执行，然后停止。这使得（模态）加载形式不会消失，因为有一个If语句执行DoCmd.Close以在加载完成后关闭加载表单。它还会中断依赖于所设置的全局变量的功能，因为在执行暂停时会清除全局变量。

有没有更好的方法来创建按编程方式执行操作的按钮，而不是直接放弃Access并编写实际代码？尽管我很乐意，但是如果我离开公司，我就不得不在Access中这样做，以便那些技术娴熟的员工在我缺席的情况下仍能使用它。

如果需要，以下是相关代码的各个部分。

Form_USysSplash：

'Code that runs when the form is opened, before any processing.
Private Sub Form_Open(Cancel As Integer)
    'Don't mess with things you shouldn't be.
    If g_database_loaded Then
        MsgBox "Please don't try to run the Splash form directly.", vbOKOnly, "No Touching"
        Cancel = True
        Exit Sub
    End If

    'Check if the user has the MySQL 5.1 ODBC driver installed.
    Call CheckMysqlODBC 'Uses elfin majykks to find if Connector/ODBC is installed, puts the result into g_mysql_installed
    If Not g_mysql_installed Then
        Cancel = True
        DoCmd.OpenForm "Main"
        Exit Sub
    End If
End Sub

'Code that runs when the form is ready to render.
Private Sub Form_Current()

    'Prepare the form
    boxProgressBar.width = 0
    lblLoading.caption = ""

    'Render the form
    DoCmd.SelectObject acForm, Me.name
    Me.Repaint
    DoEvents

    'Start the work
    LinkOMTables
    UpdateStatus "Done!"

    DoCmd.OpenForm "Home"
    f_done = True
End Sub

Private Sub Form_Timer() 'Timer property set to 100
    If f_done Then DoCmd.Close acForm, Me.name
End Sub

Form_Home：

'Code run before the form is displayed.
Private Sub Form_Load()

    'Check if the user has the MySQL 5.1 ODBC driver installed.
    'Header contains an error message and a download link
    If Not g_mysql_installed Then
        FormHeader.Visible = True
        Detail.Visible = False
    Else
        FormHeader.Visible = False
        Detail.Visible = True
        CreateButtonList Me, Me.subTasks
    End If
End Sub

'Sub to create buttons on the form's Detail section, starting at a given height from the top.
Sub CreateButtonList(ByRef frm As Form, ByRef buttonPane As SubForm)
    Dim rsButtons As Recordset
    Dim newForm As Form
    Dim newButton As CommandButton
    Dim colCount As Integer, rowCount As Integer, curCol As Integer, curRow As Integer
    Dim newFormWidth As Integer
    Dim taskFormName As String, newFormName As String

    Set rsButtons = CurrentDb.OpenRecordset("SELECT * FROM USysButtons WHERE form LIKE '" & frm.name & "'")
    If Not rsButtons.EOF And Not rsButtons.BOF Then

        taskFormName = "USys" & frm.name & "Tasks"
        On Error Resume Next
        If TypeOf CurrentProject.AllForms(taskFormName) Is AccessObject Then
            buttonPane.SourceObject = ""
            DoCmd.DeleteObject acForm, taskFormName
        End If
        Err.Clear
        On Error GoTo 0
        Set newForm = CreateForm
        newFormName = newForm.name
        With newForm
            .Visible = False
            .NavigationButtons = False
            .RecordSelectors = False
            .CloseButton = False
            .ControlBox = False
            .width = buttonPane.width
            .HasModule = True
        End With

        rsButtons.MoveLast
        rsButtons.MoveFirst
        colCount = Int((buttonPane.width) / 1584) 'Twips: 1440 in an inch. 1584 twips = 1.1"
        rowCount = Round(rsButtons.RecordCount / colCount, 0)
        newForm.Detail.height = rowCount * 1584
        curCol = 0
        curRow = 0

        Do While Not rsButtons.EOF
            Set newButton = CreateControl(newForm.name, acCommandButton)
            With newButton
                .name = "gbtn_" & rsButtons!btn_name
                .Visible = True
                .Enabled = True
                .caption = rsButtons!caption
                .PictureType = 2
                .Picture = rsButtons!img_name
                .PictureCaptionArrangement = acBottom
                .ControlTipText = rsButtons!tooltip
                .OnClick = "[Event Procedure]"
                'This If block is the source of my headache.
                If Not IsNull(rsButtons!open_query) And rsButtons!open_query <> "" Then
                    newForm.Module.InsertLines newForm.Module.CountOfLines, _
                        "Private Sub gbtn_" & rsButtons!btn_name & "_Click()"
                    newForm.Module.InsertLines newForm.Module.CountOfLines, _
                        "DoCmd.OpenQuery """ & rsButtons!open_query & """"
                    newForm.Module.InsertLines newForm.Module.CountOfLines, _
                        "End Sub" & vbCrLf & vbCrLf
                ElseIf Not IsNull(rsButtons!open_form) And rsButtons!open_form <> "" Then
                    newForm.Module.InsertLines newForm.Module.CountOfLines, _
                        "Private Sub gbtn_" & rsButtons!btn_name & "_Click()"
                    newForm.Module.InsertLines newForm.Module.CountOfLines, _
                        "DoCmd.OpenForm """ & rsButtons!open_form & """"
                    newForm.Module.InsertLines newForm.Module.CountOfLines, _
                        "End Sub" & vbCrLf & vbCrLf
                End If
                .height = 1584
                .width = 1584
                .Top = 12 + (curRow * 1584)
                .Left = 12 + (curCol * 1584)
                .BackThemeColorIndex = 1
                .HoverThemeColorIndex = 4 'Accent 1
                .HoverShade = 0
                .HoverTint = 40 '60% Lighter
                .PressedThemeColorIndex = 4 'Accent 1
                .PressedShade = 0
                .PressedTint = 20 '80% Lighter
            End With
            curCol = curCol + 1
            If curCol = colCount Then
                curCol = 0
                curRow = curRow + 1
            End If
            rsButtons.MoveNext
        Loop
        DoCmd.Close acForm, newForm.name, acSaveYes
        DoCmd.Rename taskFormName, acForm, newFormName
        buttonPane.SourceObject = taskFormName
    End If
End Sub

Answer 1

代码运行时无需编写代码，尤其是在反复编写基本相同的代码时。您所需要做的就是调用函数而不是事件过程。

在上面的代码中，像这样编写OnClick事件：

If Not IsNull(rsButtons!open_query) And rsButtons!open_query <> "" Then
    .OnClick = "=MyOpenForm(""" & rsButtons!open_form & """)"
ElseIf Not IsNull(rsButtons!open_form) And rsButtons!open_form <> "" Then
    .OnClick = "=MyOpenQuery(""" & rsButtons!open_form & """)"
End If

然后在表单可以看到的地方创建这两个永久（非生成）函数：

Public Function MyOpenForm(FormName as String)
    DoCmd.OpenForm FormName
End Function

Public Function MyOpenQuery(QueryName as String)
    DoCmd.OpenQuery QueryName
End Function

抛弃代码写入模块。

以编程方式创建一个在Access中打开窗体的按钮

1 个答案: