アクセスでフォームを開くボタンをプログラムで作成

Question

データベースを開くと、「メインメニュー」フォームを表示する前に、外部テーブルなどのリンクの進行状況をレポートする「ローディングバー」を含むフォームが表示されます。メインメニューには、ボタンのあるフォームの背後にプログラムでフォームを生成するコードがあります。実行すると、フォームの保存と名前の変更が行われ、SourceObjectというサブフォームが割り当てられます。

これはすべてうまく機能しています。つまり、ボタンを実際に何か便利なものにすることにします。ボタンを生成するループでは、VBAコードをサブフォームの対象モジュールに追加します。何らかの理由で、これを実行するとVBAは実行を終了し、その後停止します。これにより、読み込みが完了したときに読み込みフォームを閉じるためにDoCmd.Closeを実行するIfステートメントがあるので、（モーダル）読み込みフォームは消えません。また、実行が停止するとグローバルがクリアされるため、設定されているグローバル変数に依存する機能が中断されます。

プログラマチックに機能するボタンを作成するには、より良い方法がありますか？私が気に入っている限り、私は退社した場合でも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イベントを記述します。

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

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

そして捨てる：

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 

その後どこかにフォームがそれらを見ることができ、これらの二つの永久（非生成）関数を作成コードをモジュールに書き込む。