FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

サブフォームを辿る 


For Each obj In CurrentProject.AllForms
  Debug.Print obj.Name
Next

で、作成済みのフォーム名をすべて取得できますが、
フォームに埋め込んだサブフォームとの関係も取得したい・・・・

ってな場合、再帰処理する関数を作成すれば楽そうです。

また、サブフォームコントロールには、フォームだけではなく、
テーブル/クエリも表示できるので、その辺切り分けて・・・

【3/17】カテゴリを関数を作ってみるから辿るに変更
 
標準モジュールに以下を記述して、SubFormSearch を実行します。
Public Sub SubFormSearch()
  Dim oFrm As Object
  Dim sMsg As String

  sMsg = ""
  For Each oFrm In CurrentProject.AllForms
    DoCmd.OpenForm oFrm.Name, acDesign, , , , acHidden
    Call ReFrmSearch(Forms(oFrm.Name), 0, sMsg)
    DoCmd.Close acForm, oFrm.Name, acSaveNo
  Next
  MsgBox Mid(sMsg, Len(vbCrLf) + 1)
End Sub

Private Sub ReFrmSearch(frm As Form, iNst As Long, sMsg As String)
  Dim ctl As Control
  Dim vSo As Variant
  Dim sS As String
  Dim bSubF As Boolean
  Const sTable As String = "テーブル."
  Const sQuery As String = "クエリ."
  Const iSp As Long = 4

  For Each ctl In frm.Controls
    If (ctl.ControlType = acSubform) Then
      sS = ctl.SourceObject
      sMsg = sMsg & vbCrLf & Space(iNst * 4) & "フォーム:" & frm.Name _
            & Space(iSp) & "コントロール:" & ctl.Name
      If (Len(sS) > 0) Then
        sMsg = sMsg & Space(iSp)
        bSubF = True
        For Each vSo In Array(sTable, sQuery)
          If (Left(sS, Len(vSo)) = vSo) Then
            bSubF = False
            Exit For
          End If
        Next
        If (bSubF) Then
          sMsg = sMsg & "サブフォーム:" & sS
          Call ReFrmSearch(ctl.Form, iNst + 1, sMsg)
        Else
          sMsg = sMsg & Left(vSo, Len(vSo) - 1) & ":" & Mid(sS, Len(vSo) + 1)
        End If
      End If
    End If
  Next
End Sub

 
サンプルでやってみた結果は以下のような感じ
フォーム:F1  コントロール:FSUB  サブフォーム:F1_2
  フォーム:F1_2  コントロール:FSUB  サブフォーム:F1_3
フォーム:F1_2  コントロール:FSUB  サブフォーム:F1_3
フォーム:F2  コントロール:FSUB  サブフォーム:F2_2
  フォーム:F2_2  コントロール:FSUB  サブフォーム:F2_3
フォーム:F2_2  コントロール:FSUB  サブフォーム:F2_3
フォーム:F3  コントロール:FSUB  サブフォーム:F1_3
フォーム:F4  コントロール:FSUB  サブフォーム:F2_3
フォーム:FF  コントロール:埋め込み0  テーブル:T講座一覧
フォーム:FF  コントロール:埋め込み2  クエリ:Q1
で、ネストしていくたびに、行初めの空白が増えていくようになっています。
ここで表示されるフォームは、サブフォームコントロールを持つものだけになります。
また、
フォーム:F1  コントロール:FSUB  サブフォーム:F1_2
  フォーム:F1_2  コントロール:FSUB  サブフォーム:F1_3
フォーム:F1_2  コントロール:FSUB  サブフォーム:F1_3
のように、「F1」-「F1_2」-「F1_3」のネストになっていた時、
「F1_2」-「F1_3」の情報も再度表示されるようになっています。
これは、CurrentProject.AllForms にあるもので無条件にループしているから、
また、重複の確認等細工していないので・・・・
テーブルを使ってやれば、楽に実現できそうです。(今回手抜き)

フォームを一度、非表示のデザインモードで開いて、コントロールを見ていきます。
ただ、デザインで開いた方が良いのか・・・どうか・・・・
普通に開いたとしても、Form_Open で Cancel = True を返す処理を埋め込まれていたら・・・
等々あるので、やっぱりデザインモードで開くのが良いのでしょうか。

調査対象はデザインで貼り付けているもの・・・・限定で・・・・ということで。
(VBAで切り替えるものは対象外で・・・・)

全部のフォームに対して処理していましたが、SubFormSearch に引数として
フォーム名を指定する等改造すれば、使いやすくなるのかも・・・・

なお、SubFormSearch 実行時、フォームはすべて閉じておくことが前提です。


今回、サンプルはありません。

【追記(3/12)】

再帰を使わないで、ベタで書いてみました。
記述一番下の FrmSearch を実行してみてください。
ほぼ同じ結果となると思います。
(SourceObject が空の時に、無駄なスペースが付加される位です)

関数を記述している順ですが、
主を記述していて関数にしたい部分がでてきたら、その上側に関数を記述しています。
(VBAを読む時、上から読む癖があって、主のところに辿り着くまで一度は目にするよねって)

Dim vStock As Variant

Private Function SubFrmCtlSearch(Frm As Form) As Variant
  Dim ctl As Control
  Dim vR As Variant

  For Each ctl In Frm.Controls
    If (ctl.ControlType = acSubform) Then
      If (IsEmpty(vR)) Then
        ReDim vR(0)
        Set vR(0) = ctl
      Else
        ReDim Preserve vR(UBound(vR) + 1)
        Set vR(UBound(vR)) = ctl
      End If
    End If
  Next
  SubFrmCtlSearch = vR
End Function

Private Function SubFrmName(SubFrm As Variant, bSubF As Boolean) As String
  Dim vSo As Variant
  Dim sS As String
  Const sTable As String = "テーブル."
  Const sQuery As String = "クエリ."

  bSubF = False
  sS = SubFrm.SourceObject
  If (Len(sS) > 0) Then
    bSubF = True
    For Each vSo In Array(sTable, sQuery)
      If (Left(sS, Len(vSo)) = vSo) Then
        bSubF = False
        Exit For
      End If
    Next
    If (bSubF) Then
      sS = "サブフォーム:" & sS
    Else
      sS = Left(vSo, Len(vSo) - 1) & ":" & Mid(sS, Len(vSo) + 1)
    End If
  End If
  SubFrmName = sS
End Function

Private Sub fncPush(sFrm As String, iNum As Long, vAry As Variant, vAryS As Variant, iNst As Long)
  If (IsEmpty(vStock)) Then
    ReDim vStock(0)
    vStock(0) = Array(sFrm, iNum, vAry)
  Else
    ReDim Preserve vStock(UBound(vStock) + 1)
    vStock(UBound(vStock)) = Array(sFrm, iNum, vAry)
  End If
  sFrm = vAry(iNum).SourceObject
  vAry = vAryS
  iNum = -1
  iNst = iNst + 1
End Sub

Private Sub fncPop(sFrm As String, iNum As Long, vAry As Variant, iNst As Long)
  Dim v As Variant

  Do
    If (IsEmpty(vStock)) Then
      sFrm = ""
      iNum = -1
      vAry = Empty
      iNst = -1
      Exit Do
    Else
      v = vStock(UBound(vStock))
      sFrm = v(0)
      iNum = v(1) + 1
      vAry = v(2)
      iNst = iNst - 1
      If (UBound(vStock) = 0) Then
        vStock = Empty
      Else
        ReDim Preserve vStock(UBound(vStock) - 1)
      End If
    End If
  Loop While (iNum > UBound(vAry))
End Sub

Public Sub FrmSearch()
  Dim oFrm As Object
  Dim sFrm As String
  Dim sMsg As String
  Dim vAry As Variant, vAryS As Variant
  Dim bSubF As Boolean
  Dim iNst As Long
  Dim i As Long
  Const iSp As Long = 4

  sMsg = ""
  For Each oFrm In CurrentProject.AllForms
    sFrm = oFrm.Name
    DoCmd.OpenForm oFrm.Name, acDesign, , , , acHidden
    vAry = SubFrmCtlSearch(Forms(oFrm.Name))
    i = 0: iNst = 0: vStock = Empty
    While (Not IsEmpty(vAry))
      sMsg = sMsg & vbCrLf & Space(iNst * 4) & "フォーム:" & sFrm _
        & Space(iSp) & "コントロール:" & vAry(i).Name _
        & Space(iSp) & SubFrmName(vAry(i), bSubF)
      If (bSubF) Then
        vAryS = SubFrmCtlSearch(vAry(i).Form)
        If (Not IsEmpty(vAryS)) Then Call fncPush(sFrm, i, vAry, vAryS, iNst)
      End If
      i = i + 1
      If (i > UBound(vAry)) Then Call fncPop(sFrm, i, vAry, iNst)
    Wend
    DoCmd.Close acForm, oFrm.Name, acSaveNo
  Next
'  MsgBox Mid(sMsg, Len(vbCrLf) + 1)
  Debug.Print Mid(sMsg, Len(vbCrLf) + 1)
End Sub

 
上記をテストしている時に、非表示のフォームが残ったりで・・・
起動しているフォームを全部閉じるには
Public Sub CleanForm()
  While (Forms.Count > 0)
    DoCmd.Close acForm, Forms(0).Name, acSaveNo
  Wend
End Sub
とか・・・


サブフォームを辿る時には、
・再帰の方が記述量が少ないし、
・何をやっているか掴みやすい
という結論になるのでしょうか・・・・

ただ、最近、読みにくい記述を見ることがありましたが・・・・


本題と関係ありませんが、みなさん、エラー処理(on error)どうされているんでしょうか。
判を押したように MsgBox でエラーを表示するだけ・・・・
メッセージを出した後、操作している人に何をさせたいんでしょう・・・・・
今回の様な処理でメッセージ出されても、何をすればいいのかわかるんでしょうか・・・
リカバリーできるエラーなら、そのまま処理を記述すればよいと思うし、
できないのなら、そこで止まってくれた方が被害が少ないと思うんですけど・・・・

なんで続行するんですかね・・・・
関連記事

2012/02/21

Category: 辿る

TB: 0  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/118-e377a5bf
この記事にトラックバックする(FC2ブログユーザー)

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。