Option Compare Database
Option Explicit

'削除テーブルが存在しないときのエラー
Const ERR_TABLENOTEXIST = 7874  
'フォームが見つからないときのエラー
Const ERR_NOTFINDFORM = 2450
'デザインビューでプロパティを参照できないエラー
Const ERR_CANTPROPREF = 2186

Public Function smp_Main()

  On Error GoTo Err_smp_Main

  'フォームの一覧を取得する
  If smp_GetFormList() Then
    'フォーム選択ダイアログを開く
    DoCmd.OpenForm "smp_frmSelectForm", , , , , acDialog
    With Forms!smp_frmSelectForm
      If .OKCancelFlg Then
        'OKボタンがクリックされたときすべてのプロパティを取得
        If smp_GetPropList(.SelectFormName) Then
          'プロパティ一覧のフォームをデータシートで表示
          DoCmd.OpenForm "smp_frmPropList", acFormDS
        End If
      End If
    End With
    'フォーム選択ダイアログを閉じる
    DoCmd.Close acForm, "smp_frmSelectForm"
  End If

Exit_smp_Main:
  Exit Function

Err_smp_Main:
  If Err.Number = ERR_NOTFINDFORM Then
    'フォーム選択ダイアログがフォームの[閉じる]ボタンで
    '閉じられたときはエラーを無視してそのまま終了
  Else
    Beep
    MsgBox Err.Description, vbOKOnly + vbCritical
  End If
  Resume Exit_smp_Main:

End Function

Private Function smp_GetFormList() As Boolean
'フォームの一覧を取得する
  Dim dbsCd As Database
  Dim dbs As Object
  Dim aObj As AccessObject
  Dim rst As Recordset

  On Error GoTo Err_smp_GetFormList

  DoCmd.Hourglass True

  DoCmd.SetWarnings False
  '既存テーブルを削除
  DoCmd.DeleteObject acTable, "smp_tblObjList"
  'テーブルを作成する定義クエリーを実行
  DoCmd.OpenQuery "smp_qdefObjList"
  DoCmd.SetWarnings True

  'フォーム一覧をコードDBのテーブルに書き出し
  Set dbsCd = CodeDb
  Set rst = dbsCd.OpenRecordset("smp_tblObjList")

  Set dbs = Application.CurrentProject
  For Each aObj In dbs.AllForms
    With rst
      .AddNew
        !ObjectName = aObj.Name
      .Update
    End With
  Next aObj

  smp_GetFormList = True

Exit_smp_GetFormList:
  rst.Close: Set rst = Nothing
  dbsCd.Close: Set dbsCd = Nothing
  Set dbs = Nothing
  DoCmd.Hourglass False
  Exit Function

Err_smp_GetFormList:
  If Err.Number = ERR_TABLENOTEXIST Then
    '削除テーブルが存在しない時のエラー
    Resume Next
  Else
    smp_GetFormList = False
    Beep
    MsgBox Err.Description, vbOKOnly + vbCritical
    Resume Exit_smp_GetFormList:
  End If

End Function

Private Function smp_GetPropList(strFormName As String) As Boolean
  Dim dbsCd As Database
  Dim dbs As Database
  Dim rst As Recordset
  Dim frm As Form
  Dim prp As Property

  On Error GoTo Err_smp_GetPropList

  DoCmd.Hourglass True

  DoCmd.SetWarnings False
  '既存テーブルを削除
  DoCmd.DeleteObject acTable, "smp_tblObjPropList"
  'テーブルを作成する定義クエリーを実行
  DoCmd.OpenQuery "smp_qdefObjPropList"
  DoCmd.SetWarnings True

  '指定フォームをデザインビューで開く
  DoCmd.OpenForm strFormName, acDesign
  Set frm = Forms(strFormName)

  'フォームのコントロール一覧をコードDBのテーブルに書き出し
  Set dbsCd = CodeDb
  Set dbs = CurrentDb
  Set rst = dbsCd.OpenRecordset("smp_tblObjPropList")
  '指定フォームのすべてのプロパティを列挙するループ
  For Each prp In frm.Properties
    With rst
      .AddNew
        !PropertyName = prp.Name
        !PropertyValue = CStr(Nz(prp.Value))
      .Update
    End With
  Next prp

  smp_GetPropList = True

Exit_smp_GetpropList:
  '指定フォームを閉じる
  DoCmd.Close acForm, strFormName, acSavePrompt
  rst.Close: Set rst = Nothing
  dbsCd.Close: Set dbsCd = CodeDb
  dbs.Close: Set dbs = CurrentDb
  DoCmd.Hourglass False
  Exit Function

Err_smp_GetPropList:
  If Err.Number = ERR_TABLENOTEXIST Then
    '削除テーブルが存在しない時のエラー
    Resume Next
  ElseIf Err.Number = ERR_CANTPROPREF Then
    'デザインビューでプロパティを参照できないエラー
    rst!PropertyValue = "<参照不可>"
    Resume Next
  Else
    smp_GetPropList = False
    Beep
    MsgBox Err.Description, vbOKOnly + vbCritical
    Resume Exit_smp_GetpropList:
  End If

End Function