全てのサブフォーム名を取得したい

オフィス２００７です。

Sub test()
Dim obj As AccessObject
For Each obj In CurrentProject.AllForms
Debug.Print obj.Name
Next
End Sub
---------------------------------
上記のコードでデータベースのすべてのフォーム名は取得できますが
フォーム１に乗っかっている複数のサブフォームを取得するにはどうすればいいのでしょうか？

サブフォームに独自の名前を付けて、IFステートメントを使うしかないですか？

No.4 ベストアンサー 回答者： DexMachina 回答日時： 2012/03/10 00:08

No.3です。

> Function SFEnumの方が使い方がよくわかりません。

SFEnum関数は、
　・SFListup関数の「For Each ～ Next」のループ内
　・SFEnum関数自身の中(→再帰呼出)
で使用するために定義した関数ですので、直接呼び出す必要は
ありません。
(2つセットになって、初めて目的の動作をする関数です)

「◆こちらの関数の再帰呼出により～」のコメントがわかりにくかった
ようで、すみません(汗)


以下、かなり大雑把に、前回のコードの説明をしてみます。

1)SFListup関数内のループで、当該データベース内のフォームを、
　デザインビューで順次開いていく
2)当該フォームを「Frm」変数に記録した上で、指定したフォーム内
　のサブフォームの情報を確認するSFEnum関数を呼び出す
3)SFEnum関数では、その直下にある全てのコントロールを確認
　(→「For Each Cntl In Frm.Controls」以降)
4)コントロールがサブフォームだった場合は、更に詳細を確認
　(→「If Cntl.ControlType = acSubform Then」以降)
5-a)サブフォームに「ソースオブジェクト」が設定されていない場合
　(→「Case sSource = ""」)：
　イミディエイトウィンドウに、表示用フォームが指定されていないこと
　を明示するため、sSourceに「(オブジェクト未設定)」と記録
5-b)サブフォームの「ソースオブジェクト」に、テーブルやクエリを直接
　指定している場合(→「Case sSource Like "*.*"」)：
　※サブフォームには、「テーブル.(テーブル名)」の形を使用すると
　　 テーブルやクエリを指定できるため、これを曖昧検索で確認
　テーブル/クエリの中にサブフォームは設置できないので、その
　サブフォームは確認終了
　【訂正】
　半角ピリオドはフォーム名に使用できないのですが、全角なら使用
　可能なので、「sSource Like "*.*"」ではなくInStr関数を使用
　して、「半角ピリオドを含むかどうか」を判定するべきでした(汗)
　(→「Case InStr(1, sSource, ".", vbBinaryCompare) > 0」、と)
5-c)サブフォームの「ソースオブジェクト」にフォームを指定している
　場合(→「Case Else」)：
　その下に、さらにサブフォームが存在する可能性があるため、
　SFEnum関数で確認(→sFeNum関数の中で、同じSFEnum関数
　を呼出：これを再帰呼出といいます)
6)それぞれの場合の確認が終わったら、引数iLvに記録されている
　現在の階層数に合わせてスペースを追加して、変数sSourceに
　記録した情報を、引数sEnumに追記
　(→「sEnum = Space(iLv * 5) & Cntl.Name & "【" & sSource & "】"」)

・・・以上です。

この「再帰呼出」というのは、慣れないとちょっとわかりにくいと思います
ので(→少なくとも私自身はVBAを扱うようになってからも暫くは手が
出せていませんでした(汗))、気長に眺めてみることをお勧めします。

この再帰呼出の部分をさらに大雑把に説明すると、
　1)デザインビューで開いたフォームにサブフォームがあるか確認
　2)サブフォームがあったら、親フォームの情報をsEnumに記録する
　　前に、iLvに「1」を加算(→階層の記録)して、子フォームに移動
　3)子フォームにもサブフォーム(孫)があったら、子フォームの情報を
　　sEnumに記録する前に、孫フォームに移動
　4)サブフォームがなくなったところで、sEnumに自身の情報を記録
　　して、直接の呼出元(孫まであった場合は子の階層)に戻る
　5)戻ってきたところでsEnumに自身の情報を追加して、同じく直接
　　の呼出元(子の場合は親の階層)に戻る
　6)SFListup関数にまで戻ったら、イミディエイトウィンドウに表示
となります。

SFEnum関数内で定義したRslやCntlなどの変数は、再帰呼出を
しても上書されません。
(あたかも「Rsl’」や「Cntl’」という変数が別に用意されたかのように、
　繰り返した階層ごとの値が、パソコンのメモリ内に保持されます)
・・・多分ここが、一番感覚がついてこないところではないかと・・・(汗)


・・・長くなりましたが(汗)、以上です。

この回答へのお礼

とてもわかりやすい説明ありがとうございます。

お礼日時：2012/03/24 14:01

No.3 回答者： DexMachina 回答日時： 2012/02/23 21:04

遅れ馳せながら、再帰呼出により全てのサブフォームをデバッグ ウィンドウに

出力させる関数を作成してみました。

親子関係は、半角スペース5個のインデントで表す形としました。
また、サブフォームのコントロール名に加え、ソースオブジェクトも同時に
表示させています。
なお、サブフォームのソースオブジェクトが空白だったり、テーブル・クエリを
指定した場合にも念のため対応しました。


'◆イミディエイトウィンドウなどから呼び出すのはこちらの関数になります◆
Public Function SFListup() As Boolean
On Error GoTo エラー処理

　　Dim Rsl As Boolean, Obj As AccessObject, Frm As Form
　　Dim sName As String, sEnum As String

　　For Each Obj In CurrentProject.AllForms
　　　　sName = Obj.Name
　　　　DoCmd.OpenForm sName, acDesign
　　　　Set Frm = Forms(sName)
　　　　sEnum = ""　　 '初期化
　　　　Rsl = SFEnum(Frm, sEnum, 0)
　　　　If Rsl = False Then
　　　　　　sEnum = Space(5) & "★エラーにより確認不可★" & vbCrLf
　　　　ElseIf sEnum = "" Then
　　　　　　sEnum = Space(5) & "(サブフォームなし)" & vbCrLf
　　　　End If
　　　　Debug.Print "～～～以下『" & sName & "』配下～～～"
　　　　Debug.Print sEnum
　　　　DoCmd.Close acForm, sName
　　Next

終了処理:
　　SFListup = Rsl
　　Set Obj = Nothing
　　Set Frm = Nothing
　　Exit Function

エラー処理:
　　MsgBox Err.Number & "：" & Err.Description
　　Resume 終了処理

End Function

'◆こちらの関数の再帰呼出により、全階層のサブフォームを取得します◆
Private Function SFEnum(Frm As Form, sEnum As String, ByVal iLv As Integer) As Boolean
On Error GoTo エラー処理
'[Frm=サブフォームを確認するフォーム, sEnum=デバッグウィンドウに表示する情報を記録, iLv=サブフォームの階層を記録]

　　Dim Rsl As Boolean, Cntl As Control, sSource As String

　　iLv = iLv + 1
　　For Each Cntl In Frm.Controls
　　　　If Cntl.ControlType = acSubform Then
　　　　　　sSource = Cntl.SourceObject
　　　　　　Select Case True
　　　　　　　　Case sSource = ""
　　　　　　　　　　Rsl = True
　　　　　　　　　　sSource = "(オブジェクト未設定)"
　　　　　　　　Case sSource Like "*.*"
　　　　　　　　　　Rsl = True
　　　　　　　　Case Else
　　　　　　　　　　Rsl = SFEnum(Cntl.Form, sEnum, iLv)
　　　　　　End Select
　　　　　　If Rsl = False Then GoTo 終了処理
　　　　　　sEnum = Space(iLv * 5) & Cntl.Name & "【" & sSource & "】" & vbCrLf & sEnum
　　　　End If
　　Next
　　Rsl = True

終了処理:
　　SFEnum = Rsl
　　Set Cntl = Nothing
　　Exit Function
　　
エラー処理:
　　MsgBox Err.Number & "：" & Err.Description, vbCritical, "SFEnum"
　　Rsl = False
　　Resume 終了処理

End Function


・・・以上、参考まで。

この回答へのお礼

ご回答がとても遅くなってしまい申し訳ございませんでした。

二つのプロシージャー
・Function SFListup
・Function SFEnum
を標準モジュールに張り付けて実行してみました。

Function SFListupはVBE画面でF5を押したら実行され、
イミティエイドウインドウに求める結果が表示されたのですが
Function SFEnumの方が使い方がよくわかりません。

Ｆ５を押しても何も起きないです・・・

せっかく教えていただいたのに
うまく使えてなくてごめんなさい。
もっと勉強してみます。

お礼日時：2012/03/09 19:44

No.2 回答者： nicotinism 回答日時： 2012/02/20 14:05

孫フォームまでですが、フォーム１が有った場合に

親子関係を分かりやすくしたつもり。

Sub b()
Dim ctl As Control
Dim ctl2 As Control
Dim frm As Object
Dim sMsg As String
For Each frm In CurrentProject.AllForms
　　If frm.Name = "フォーム１" Then
　　　　DoCmd.OpenForm frm.Name, view:=acDesign, windowmode:=acIcon
　　　　For Each ctl In Forms(frm.Name).Controls
　　　　　　If ctl.ControlType = acSubform Then
　　　　　　　　 sMsg = "親=" & frm.Name & "　　子=" & ctl.Name
　　　　　　　　For Each ctl2 In ctl.Form
　　　　　　　　　　If ctl2.ControlType = acSubform Then
　　　　　　　　　　　　sMsg = sMsg & "　　孫=" & ctl2.Name
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　Debug.Print sMsg
　　　　　　End If
　　　　Next
　　　　DoCmd.Close acForm, frm.Name
　　End If
Next
End Sub

この回答へのお礼

孫フォームまで取得できました！ありがとうございました。

お礼日時：2012/02/22 07:53

No.1 回答者： masa_019 回答日時： 2012/02/19 22:49

こんにちは。

すべてのフォームと、それに乗っているサブフォーム名をイミディエイトに出力します。


Sub test()
Dim obj As AccessObject
For Each obj In Application.CurrentProject.AllForms
Macro2 obj.Name
Next
End Sub


Sub Macro2(ByVal fName As String)
Dim ctrl As Control
Dim sbf As SubForm
Dim str As String
DoCmd.OpenForm fName
str = "**** " & fName & "のサブフォーム名 ****" & vbCrLf
For Each ctrl In Forms(fName).Controls
On Error GoTo 10
Set sbf = ctrl
str = str & vbTab & sbf.Name & vbCrLf
20:
Next
DoCmd.Close acForm, fName
Debug.Print str
Exit Sub
10:
Resume 20
End Sub

この回答へのお礼

うーん、なぜか無限ループに陥ってしまいました。原因を調べてみます。ありがとうございました。

お礼日時：2012/02/22 07:52