以編程方式創建一個在Access中打開表單的按鈕

Question

打開數據庫時，它會顯示一個帶有「加載欄」的窗體，用於報告鏈接外部表等的進度，然後顯示「主菜單」窗體。主菜單的代碼可以在後臺編程生成一個帶有按鈕的窗體，當完成後它會保存並重命名窗體，並將其作爲SourceObject指定給子窗體。

這一切都正常工作，也就是說，直到我決定讓按鈕實際上做一些有用的事情。在生成按鈕的循環中，它將VBA代碼添加到子模塊。出於某種原因，這樣做會使VBA完成執行，然後停止。這使得（模態）加載表單不會消失，因爲If語句會在加載完成時執行DoCmd.Close關閉加載表單。它還會中斷依賴於全局變量的功能，因爲全局在執行暫停時被清除。

有沒有更好的方式去創建按鈕，以編程方式做東西，缺少完全訪問權限和寫真正的代碼？儘管我很喜歡，但爲了離開公司，我不得不在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 

而且溝代碼寫入模塊。