スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

視覚的フォームの模索 


以下の様な質問を見かけました。

Access2007で花壇マップは作れますか?

フラワーガーデンのデーターベースを構築してまして、園内に植栽されている約300種の品種管理を考えています。
花壇の区画数が60ほどありまして、どの品種がどの区画に植栽されているか視覚的にわかるような花壇マップを作りたいのですが、Access2007で作成することは可能でしょうか?

全品種のテーブル入力は完了しており、そこに花の画像を添付しフォーム上で表示できるようにしました。
現状は品種毎にどこの区画に植栽しているかチェックボックスで管理している状況です。
一つの品種が複数の区画に植栽されているケースが多々あり、見た目でわかりにくいのでマップ等に表示できないか思案しています。

私はあまり、フォームに画像を貼り付け・・・・しないので、どうしたら・・・・を考えてみました。

基本的に、
・画像は取り込まずに、リンクとして扱う。 ・・・・ Accessファイルが膨れるのを防ぐ??
(リンクと言っても、リンクフィールドじゃなく・・・・・・)

操作を楽にする・・・・
・中のテーブル構成/処理 等を見せない/意識させない?

ある意味、操作イメージからテーブルの構成を決める事があります(私には結構あります)
この方法はあまり推奨されるものではない・・・と思いますが・・・・・・

まず、操作イメージとして固まったのは
・フォームに基本となる画像(区画の配置図?・マップ?)を貼り付ける
・「区画」部分に ×× を配置しクリックして・・・ チェックして花を割付ける・・・・
・「区画」に花を割付けていなければ、背景(基本となる画像)が見えるように
・「区画」があるところでは、カーソル形状を変更する
 (つまり、背景が見えているけど「区画」として存在するのなら・・・)
・花を割付けている「区画」を認識しやすいようにしてみる

普通(?)に考えれば、「 画像 = イメージコントロール 」なのかもしれません。
ただ、2007 になって、コマンドボタンにカーソル(マウスポインタ)が入ったら、
カーソル形状を変更できるプロパティ( CursorOnHover )がサポートされ・・・
であれば、必要に応じて
・「透明( Transparent )」の切り換え
・画像( Picture )の設定
・・・・・
これで、何かいけそう・・・・という事で、コマンドボタンを使った方法でやってみます。













コマンドボタン群を配置して、コマンドボタン上でのカーソル形状は「指差し?」
コマンドボタン間のカーソル形状は、普通の矢印
コマンドボタンがクリックされたら「透明」を切り替えて・・・・
一覧で表示される花の並び順は、
・その区画に植えているもの(チェックされている:True )が上側
・その区画に今は植えていないもの(チェックされていない:False )がその次
・その区画に一度も植えた事がないもの( Null )が以降
 それぞれ、花名順で・・・・・
の様にしています。
チェック状態の違い3つを確認できたかと思いますが、
2003 では、チェックなし( False )とそれ以降( Null )の区別が出来ません(2000 では区別できます)
なお、前述の通りカーソル形状は 2000 / 2003 では変わりません。
なので「区画」が割り当てられている場合、ヒントテキストで区画名を表示する様に・・・・
ヒントテキスト・・・・・ これもチョッと・・・ すぐに表示してほしいのにじれったい・・・・・
頑張る部分ならどうにか考えないと・・・・・・・・ 今回、頑張りません

イメージコントロールを使った場合には、
 「マウス移動時」等のイベントで自力でやる必要があると思います。
(背景を見せるために Visible = False にしてしまうと、カーソルの位置確認等の処理が増えそう・・・・)
で、「区画」部分がクリックされたら・・・
花一覧を表示(割付けられた花を一覧先頭にまとめて・・・)しつつ、
割付けは、チェックボックスでチェックするだけ・・・
その花名部分のダブルクリックで、どの「区画」に植えられているか・・・・アニメーション?っぽく・・・
データをソコソコ入れてから操作してみると以下の様な感じで・・・・(携帯での撮影なので見難いですが)













操作順の雰囲気は、最終形から前に戻っていく感じで

最終形フォーム「FG7M/FG7S1/FG7S2」(メインにサブ2つ組込み)を使用
・マウスカーソル形状が変わるところ・・・・(見難かったので前の動画を撮影)
・「区画35」を選択後、花名のところをダブルクリックして、どの区画に植えられているか確認
 (アニメーション?を変えたものを4パターン:時々ぎこちない動きになります)
・植えていない区画をクリックしただけでは、植えた事にはなりません
 (チェックボックスにチェックを入れる事で、コマンドボタンは消えなくなります)
 (チェックを外し、チェックされたものがなくなればコマンドボタンは消えるようになります)

2つ前のフォーム「FG5/FG5S」(フォーム枠をなくして横に配置)を使用
 (これをやりたかったので「ウィンドウを重ねて表示する」に設定)
・アニメーション?すると画面表示が激しくチラつきます(アニメーション?しなければ使えるものかも)

3つ前のフォーム「FG4/FG4S」を使用
・「区画」選択のタイミングで「花一覧」フォームを Open し直す方法に・・・・
 (起動元フォームとの位置関係を考慮していないので、操作に難・・・)
・「区画」の画像を設定・解除してみる
 画像入力テキストボックスのダブルクリックで画像を指定できるように・・・・(「区画1」にて絶対パス)
 もちろん、手入力でも・・・(「区画4」にて相対パス)
(良く見えませんが、絶対パス/DBからの相対パスどちらでも・・・)

基本的な処理の考え方は「FG4/FG4S」で終わっています。
これを使って、見え方・組込み方を変えていったのが「FG5x」「FG6x」「FG7x」になっていきます。


花を選択して・・・区画の一覧・・・・っていうのでも良いのかもしれませんけど・・・・・
入れ物を用意して、何を入れる・・・・の方がシックリするので・・・

・・・他のやり方等いろいろあると思いますけど・・・・ 一例になればと・・・・・・・
※ 2007 での見え方がメインですが、2000 / 2003 での違いも合わせて記述していきます。
 (結構長くなります/なりましたけど・・・)
 
まず、画像を用意します。

kEnt168pic_1  kEnt168pic_2  kEnt168pic_3

用意したのは DB と同じところに「 pic 」フォルダ
・「 pic 」直下
   背景用 bmp / アニメーション?用 bmp
・「 pic\ku 」には
   区画(コマンドボタン)用 bmp
・「 pic\flw 」には
   花用 bmp
これらを フォーム / コマンドボタン / イメージ に割り当てていきます。
で、コマンドボタンを使って、「透明」の切り換え、画像表示がうまくできるか確認してみます。

フォーム「FG」 コマンドボタン bmp 確認用

フォーム「FG」をデザインから作っていきます。
レコードソースは指定しない(非連結フォーム)なので、
・レコードセレクタ ・移動ボタン は「いいえ」にしておきます。
フォーム名を「FG」で一時保存し、デザインで表示している状態で以下を実行します。
(標準モジュール「Module1」にある「MakeFG」)
Private Const IPX As Long = 567

Public Sub MakeFG()
  Dim iX As Long, iY As Long
  Dim i As Long, j As Long

  On Error Resume Next
  iY = 0
  For i = 1 To 35
    j = (i - 1) Mod 7
    If (j = 0) Then iY = ((i - 1) \ 7) * 2 * IPX + 0.1 * IPX
    With CreateControl("FG", acCommandButton, acDetail)
      .Name = "btn" & i
      .Caption = "区画" & i
      .Top = iY
      .Left = ((i - 1) Mod 7) * 2 * IPX + 0.1 * IPX
      .Height = 1.8 * IPX
      .Width = 1.8 * IPX
      .TabStop = False
      .PictureType = 1
      .Transparent = True
      .CursorOnHover = acCursorOnHoverHyperlinkHand
      .PictureCaptionArrangement = acBottom
    End With
  Next
End Sub

何をやっているかですが、
・ 1.8 cm 角のコマンドボタンを、横7 x 縦5(計35個)を配置
・コマンドボタン名は「btn1」~「btn35」、標題は「区画1」~「区画35」
・コマンドボタンに貼り付ける画像 bmp は、埋め込みではなく「リンク」ですよ
・「透明」を「はい」としておいて
・マウスカーソルが上に来たら、「指差し?」に変更する様に
・貼り付けた bmp が小さかったら、標題を下に表示してね・・・・

ここで、上記の最後2つは 2007 以外(2000 / 2003)では、
プロパティ設定はそうですが、それ以前のコンパイル時 acXXXX の定数が見つからないエラーになります。
なので、コンパイルエラーをなくすために
' 2000, 2003 定数エラー回避用
Public Const acCursorOnHoverDefault = 0     ' プロパティのエラーは無視
Public Const acCursorOnHoverHyperlinkHand = 1 ' (On Error Resume Next にて)
Public Const acBottom = 3
を定義しておく事に・・・・
実行時のエラーは、 On Error Resume Next で無視する様に・・・・

このフォーム「FG」に記述したのは以下
Private Function btnShow()
  Me.ActiveControl.Transparent = Not Me.ActiveControl.Transparent
End Function

Private Sub Form_Load()
  Dim ctl As Control

  On Error Resume Next
  Me.PictureType = 1
  Me.Picture = CurrentProject.Path & "\pic\gb.bmp"
  For Each ctl In Me.Section(acDetail).Controls
    With ctl
      If (.ControlType = acCommandButton) Then
        .OnClick = "=btnShow()"
        Err = 0
        .PictureType = 1
        .Picture = CurrentProject.Path & "\pic\ku\g" & Mid(.Name, 4) & ".bmp"
        .Transparent = Err <> 0
      End If
    End With
  Next
  Me.InsideWidth = 14 * 567
  Me.InsideHeight = 10 * 567
End Sub

 
フォームの「読み込み時」に、
・フォームの背景画像を貼り付けた後、
・各コマンドボタン「btn1」~「btn35」に、
 区画用として画像を置いている 「pic\ku」フォルダ内の「g1.bmp」~「g25.bmp」を
 「btn1」なら「g1.bmp」を、「btn25」なら「g25.bmp」を・・・・
・画像があったら「透明」を「いいえ」に、画像がなく設定エラーなら「透明」を「はい」に・・・

で、ボタンがクリックされたら、「透明」状態を逆に・・・
このフォームの表示は以下の様になります。(左:2007 中:2003 右:2000)

FG_2007  FG_2003  FG_2000

2007 での一番上の段では、画像の下に標題が見えてますね・・・
※ ボタンだけを配置した状態でフォームを表示してみて、その表示を採取してペイントで見たら
 66x66 がボタンの大きさだったようで・・・
 なので上の段の画像は 66x44 の大きさで、縦側を小さくしています。
 2段目は 66x66 の bmp 、3段目以降は 66x66 を超えるものに・・・

コマンドボタンの「透明」は、Visible = False とは違い、イベントを取る事が出来ますね。
※ 2000 / 2003 では、コマンドボタン上にカーソルが来てもカーソル形状は変わりません。

さて、ここで表示を制御するテーブルを考えていきます。
現在は「btn1」~「btn35」を配置したので、それらをどう使うか・・・
テーブル「T区画」
・区画番号(長整数:主キー)
・区画名(テキスト型)
を作ります。
区画番号には、1 ~ 35 のどの区画を使うのか・・・・ボタンに表示する標題(区画名)を・・・

う~~ん・・・・っと
そのボタンに表示する画像情報はどうしよう・・・・
画像を指定したり/しなかったり・・・・更新したり・・・テーブル「T区画」には持たせたくないな・・・
ってことで、テーブル「T区画状況」
・区画番号(長整数:主キー)
・画像(テキスト型)
・更新日時
まず今回、このテーブルの使い方として
・植えている花が1つでもあるのならデータを入れておきましょう
 つまり、データがない = 今植えている花がない・・・としましょう
※ こう考えると、花を植えた/植えてない・・・この状況で更新する必要があります。
 フィールド「画像」の Null / Not Null で、画像自体の貼り付けは制御できると思いますが、
 ボタン自体の「透明」は制御しにくい???
 今回冒頭で、植えているものがなければボタンは見せずに背景を表示する・・・・としたので・・・
 この条件がなければ、データ自体残っていても良いと思います。
 また、植えている = 画像の設定を必須とする・・・・とかにすれば・・・・・・

テーブル「T区画」に以下を実行して 1 ~ 35 のデータを作ります。
(標準モジュール「Module1」にある「MakeSepTbl」)
Public Sub MakeSepTbl()
  Dim rs As New ADODB.Recordset
  Dim i As Long

  CurrentProject.Connection.Execute "DELETE * FROM T区画;"
  rs.Open "T区画", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
  For i = 1 To 35
    rs.AddNew
    rs("区画番号") = i
    rs("区画名") = "区画" & i
    rs.Update
  Next
  rs.Close
End Sub


区画割当確認用フォーム「FG1」

フォーム「FG」を「FG1」名でコピーし、読み込み時の記述を変更します。

Private Function btnShow()
  Me.ActiveControl.Transparent = Not Me.ActiveControl.Transparent
End Function

Private Sub Form_Load()
  Dim rs As New ADODB.Recordset
  Dim sS As String

  On Error Resume Next
  Me.PictureType = 1
  Me.Picture = CurrentProject.Path & "\pic\gb.bmp"
  rs.Source = "SELECT Q1.区画番号, Q1.区画名, Q2.区画番号 AS 区画番号2,Q2.画像 FROM T区画 AS Q1 " _
        & "LEFT JOIN T区画状況 AS Q2 ON Q1.区画番号=Q2.区画番号;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    With Me("btn" & rs("区画番号"))
      .Caption = rs("区画名")
      .ControlTipText = .Caption
      .OnClick = "=btnShow()"
      .PictureType = 1
      If (Not IsNull(rs("区画番号2"))) Then
        sS = Nz(rs("画像"))
        If ((Mid(sS, 2, 2) <> ":\") And (Left(sS, 2) <> "\\")) Then
          sS = CurrentProject.Path & "\" & sS
        End If
        .Picture = sS
        .Transparent = False
      Else
        .Picture = ""
        .Transparent = True
      End If
    End With
    rs.MoveNext
  Wend
  rs.Close
  Me.InsideWidth = 14 * 567
  Me.InsideHeight = 10 * 567
End Sub

 
ここでの処理は、テーブル「T区画」と「T区画状況」とをみて、"btn" & 区画番号 としたコマンドボタンに設定していきます。
・「区画名」をコマンドボタンの「標題」「ヒントテキスト」に設定します。
 ヒントテキストへの設定は、2000 / 2003 でカーソル形状が変わらない事への配慮???
・テーブル「T区画」と「T区画状況」を結び付けますが、初めは「T区画状況」は空です。
 もし、「T区画状況」側に「区画番号」があったら、「透明」ではなく表示します。
 また、「画像」に文字列があったら、絶対パスに変更した画像パスで設定します。
 文字列の判別は、
  「D:\」とかの「:\」があるか・・・「\\」で始まっているとか・・・・ ならそのままで
  違ったら相対なんでしょう・・・・絶対パスに変更して・・・・

このフォーム「FG1」の表示としては、テーブル「T区画状況」は空なので、背景だけが見えてます。
コマンドボタン「btn1」~「btn35」があるところにカーソルを持って行くと・・・
チョッとするとヒントテキストで「区画名」が表示され、クリックすると「透明」が切り替わると思います。

テーブル「T区画」では、フォームの持つコマンドボタン数をそのまま指定していたけど・・・
チョッと限定してみましょうか・・・・・ということで、

テーブル「T区画」を「T区画2」名でコピーし、区画番号 26 以降を削除しておきます。
フォーム「FG1」を「FG2」名でコピーし、
コマンドボタンのカーソル形状の初期値をデザイン上で変更しておきます。
実は、「T区画」で指定された区画のコマンドボタンだけカーソル形状を変更したい場合、
(つまり、区画番号 26 ~ 35 部分は、そのまま矢印でいてもらいたい・・・)
処理の先頭で、全コマンドボタンの状態を初期化してから、設定されたものだけを変更・・・
とかの処理になるので、初期化部分を割愛する為の変更になります。

で、フォーム「FG2」に記述した内容は、
Private Function btnShow()
  Me.ActiveControl.Transparent = Not Me.ActiveControl.Transparent
End Function

Private Sub Form_Load()
  Dim rs As New ADODB.Recordset
  Dim sS As String

  On Error Resume Next
  Me.PictureType = 1
  Me.Picture = CurrentProject.Path & "\pic\gb.bmp"
  rs.Source = "SELECT Q1.区画番号, Q1.区画名, Q2.区画番号 AS 区画番号2,Q2.画像 FROM T区画2 AS Q1 " _
        & "LEFT JOIN T区画状況 AS Q2 ON Q1.区画番号=Q2.区画番号;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    With Me("btn" & rs("区画番号"))
      .Caption = rs("区画名")
      .ControlTipText = .Caption
      .OnClick = "=btnShow()"
      .PictureType = 1
      If (Not IsNull(rs("区画番号2"))) Then
        sS = Nz(rs("画像"))
        If ((Mid(sS, 2, 2) <> ":\") And (Left(sS, 2) <> "\\")) Then
          sS = CurrentProject.Path & "\" & sS
        End If
        .Picture = sS
        .Transparent = False
      Else
        .Picture = ""
        .Transparent = True
      End If
      .CursorOnHover = acCursorOnHoverHyperlinkHand
    End With
    rs.MoveNext
  Wend
  rs.Close
  Me.InsideWidth = 14 * 567
  Me.InsideHeight = 10 * 567
End Sub

 
変更は、チョッとだけですね・・・・・
動き的には、「btn26」~「btn35」部分にカーソルを持っていっても
・カーソル形状 / ヒントテキストは・・・意図した様に動きませんね

では、このコマンドボタンで「ここよ~~」っていう意思表示させるには・・・・ということで・・・
少しずつズレた画像を周期的に入れ替えていけば・・・・アニメーション?っぽくなるのでは・・・
この動きを確かめてみます。

フォーム「FG2」を「FG3」名でコピーし、
「透明」を切り替えていない「btn32」~「btn35」部分で確認してみます。
「btn32」~「btn35」がクリックされたら、フォームの「タイマー時」を 100 ms 周期で画像切り換え・・・
連続した画像が何枚になるかわからないので、エラーになったら前に戻って設定し直す・・・

フォーム「FG3」で、元フォーム「FG2」の処理に追加した部分は以下
Dim iCnt As Long
Dim iLoop As Long
Dim sPname As String
Dim ctl As Control

Private Sub Form_Timer()
  On Error Resume Next
  iLoop = iLoop + 1
  With ctl
    .Transparent = False
    .Picture = CurrentProject.Path & sPname & iLoop & ".bmp"
    If (Err <> 0) Then
      iCnt = iCnt - 1
      If (iCnt > 0) Then
        iLoop = 1
        .Picture = CurrentProject.Path & sPname & iLoop & ".bmp"
      Else
        iLoop = 0
        .Transparent = True
        Me.TimerInterval = 0
      End If
    End If
  End With
End Sub

Private Sub btn32_Click()
  If (Me.TimerInterval > 0) Then Exit Sub
  sPname = "\pic\gm_"
  Set ctl = Me.btn32
  iCnt = 3
  Me.TimerInterval = 100
End Sub
Private Sub btn33_Click()
  If (Me.TimerInterval > 0) Then Exit Sub
  sPname = "\pic\gm"
  Set ctl = Me.btn33
  iCnt = 3
  Me.TimerInterval = 100
End Sub
Private Sub btn34_Click()
  If (Me.TimerInterval > 0) Then Exit Sub
  sPname = "\pic\gmo_"
  Set ctl = Me.btn34
  iCnt = 3
  Me.TimerInterval = 100
End Sub
Private Sub btn35_Click()
  If (Me.TimerInterval > 0) Then Exit Sub
  sPname = "\pic\gmo"
  Set ctl = Me.btn35
  iCnt = 3
  Me.TimerInterval = 100
End Sub

 
サンプルとして、丸、四角、それぞれの、中央から外へ・・・・ 外から中央へ・・・ の4パターン
中央から外へ・・・・ 私はここに居ますよ・・・のイメージ?
外から中央へ・・・・ ここに居たんですか・・・のイメージ?
後述しますが、この辺はあまり凝らない方が良いかも・・・・
同時に動かすコマンドボタンの数が多くなるとかすると、
・画面がチラつく様になる傾向があるみたい・・・
・動きがぎこちなく・・・ギコギコ・・・・・
例えば、真っ赤の画像だけ用意しておいて、0.5 秒間隔で表示してみたり・・・でも良さそう・・・
要は、その位置(区画)を認識できれば良いと思うので・・・・
(今回は 100 ms 周期で画像を入れ替える事に・・・)

FG3_2007

コマンドボタンの意思表示など確認できたので、花の割付けについて考えていきます。

花は、画像があればそのまま記述しておけばいいか・・・・ということで
テーブル「T花」
・花番号(長整数:主キー) ・・・・ オートナンバでも良かったかな?
・花名(テキスト型)
・画像(テキスト型)
区画の時の画像では触れませんでしたが、「画像」はハイパーリンク型ではなく、テキスト型で持ちます。
ハイパーリンク型って使いようによっては便利なのかもしれませんが・・・・私は好きじゃない・・・・
その辺は、過去記事「ハイパーリンクって、、、セキュリティは」で記述しています。

※ その記事が出てきたので・・・・
  その記事にある標準モジュール「API利用」をインポートしておきます。
  ビットマップファイルを指定したり、画像ファイルを開いたり・・・・で使用します。
  修正は、すべてのファイル → ビットマップファイル に限定した記述に・・・・そこだけです。

※※ 余談

「T花」のデータを簡単に登録出来たらいいなぁ~~ということで、登録専用のフォームがあります。
フォーム「FR」がそれになります。

これは、スペース区切りの文字列を入力して「取込」すると文字列を重複削除しながら覚えます。
で、覚えたものを、テーブル「T花」をクリアしてから登録するか・・・追加するか・・・・
以下のブログに表示されている内容を拝借して 148 件のデータを作っています。

草花写真館
http://kusabanaph.web.fc2.com/index.html
(5・6 月の花の頁での花名および画像)


花のマスタテーブルが出来たところで、花をどの区画に植えているか・・・・
これを、簡単に・・・・チェックボックスだけで・・・指定できるようにできるだろうか・・・・
結果的に、テーブル「T花割当」は
・an (オートナンバ:主キー)
・used (Yes/No型)  ・・・ True:植えている Flase:植えていない
・区画番号(長整数)
・花番号(長整数)
・更新日時(日付/時刻型)

クエリ「Q1」をまず作ります。
SELECT * FROM T花 AS Q1 LEFT JOIN
(SELECT * FROM T花割当 WHERE 区画番号=0) AS Q2 ON Q1.花番号=Q2.花番号
ORDER BY SWITCH(Q2.used Is Null,3,Q2.used,1,True,2), Q1.花名;

やっている事と言えば、
テーブル「T花」全部と、テーブル「T花割当」の区画番号を指定したものとを花番号で関連付け。
ORDER BY SWITCH(Q2.used Is Null,3,Q2.used,1,True,2), Q1.花名;
では、
・該当するデータが「T花割当」に無ければ 3
・該当するデータがあって used = True であれば 1、データがあっても used = False なら 2
として表示順を・・・・また、花名で昇順・・・・

このクエリでは、「used」をチェックすると「T花割当」にデータが自動で作られます。
ただし、「区画番号」「更新日時」にはデータが埋まりません(「花番号」は自動で設定される)
このクエリ「Q1」を元に帳票フォームを作ります。
表示するのは「used」と「花名」の2つのみとして、(「花名」は編集不可に)
フォームの更新前処理で、足りない「区画番号」「更新日時」を指定する様に。
クエリ「Q1」では、区画番号 = 0 固定になっているので、フォームが起動される時に OpenArgs で
区画番号を教えてもらって、対象の区画番号に書き換えた SQL をレコードソースに設定する様に・・・
また、不可視のテキストボックスをヘッダに配置して、コントロールソースを 「Q1.花番号」 に。
このテキストボックスの用途は、花名をダブルクリックされた時に、
この「花番号」で割付けを見て区画を示してよ・・・・・ってな時に使います。
(クエリ「Q1」のままでは、「花番号」は「AS Q1」「AS Q2」のどちらにも存在するので・・・どっちの)

フォームが起動された時にレコードソースを設定し直すので、元々のレコードソースは空白でも・・・・
じゃなかったですね・・・・・
レコードソースを空欄にしてから、VBE 側で「デバッグ」→「xx コンパイル」するとナンチャラのエラーに・・・
どのみち書き換えるのなら、データが存在しない 区画番号 = 0 で抽出しておけば速いんじゃ・・・???
ってなことで、クエリ「Q1」は出来上がってます。

せっかく区画番号を OpenArgs 経由で通知してもらうので、ヘッダ部で区画の画像を設定できるように・・・
この部分は、非連結・・・ですね。

花一覧を表示するフォームの概要はこんな感じです。


区画用フォーム「FG4」と、花一覧用フォーム「FG4S」の連携

FG4M_2007

区画用フォーム「FG4」は、フォーム「FG3」をコピーして記述内容を変更していきます。
まず、フォームが起動されたら「読み込み時」で、コマンドボタン等を初期設定/初期状態設定します。
Public Sub init()
  Dim rs As New ADODB.Recordset
  Dim i As Long

  On Error Resume Next
  rs.Source = "SELECT Q1.区画番号, Q1.区画名, Q2.区画番号 AS 区画番号2,Q2.画像 FROM T区画 AS Q1 " _
        & "LEFT JOIN T区画状況 AS Q2 ON Q1.区画番号=Q2.区画番号;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    i = rs("区画番号")
    If ((i >= 1) And (i <= 35)) Then
      With Me("btn" & i)
        .Caption = rs("区画名")
        .ControlTipText = .Caption
        .OnClick = "=btnShow()"
        If (Not IsNull(rs("区画番号2"))) Then
          .Picture = MkPath(Nz(rs("画像")))
          .Transparent = False
        Else
          .Picture = ""
          .Transparent = True
        End If
        .CursorOnHover = acCursorOnHoverHyperlinkHand
      End With
    End If
    rs.MoveNext
  Wend
  rs.Close
End Sub

Private Sub DefFrm()
  Dim i As Long

  On Error Resume Next
  Me.PictureType = 1
  Me.Picture = CurrentProject.Path & "\pic\gb.bmp"

  For i = 1 To 35
    With Me("btn" & i)
      .Transparent = True
      .PictureType = 1
      .Picture = ""
      .CursorOnHover = acCursorOnHoverDefault
    End With
  Next
  Me.InsideWidth = 14 * 567
  Me.InsideHeight = 10 * 567
End Sub

Private Sub Form_Load()
  Call DefFrm
  Call init
End Sub

init() 部分は、以前のフォームで見たものですね。
花一覧フォームを閉じた時にも動かしたいので Public で外出ししておきます。

で、フォームを閉じる時には、花一覧フォームを閉じたいので
Const sFn As String = "FG4S"

Private Sub Form_Close()
  If (CurrentProject.AllForms(sFn).IsLoaded) Then
    DoCmd.Close acForm, sFn, acSaveNo
  End If
End Sub
まあ DoCmd.Close では、起動していないフォームを指定してもエラーにはならないようなので
判別はいらないのかも・・・???

コマンドボタンがクリックされたら
Const sFn As String = "FG4S"

Private Function btnShow()
  If (CurrentProject.AllForms(sFn).IsLoaded) Then
    DoCmd.Close acForm, sFn, acSaveNo
  End If
  With Me.ActiveControl
    .Transparent = False
    DoCmd.OpenForm sFn, acNormal, , , , , Mid(.Name, 4)
  End With
End Function
花一覧フォームが起動されていたら一度閉じておいてから、
コマンドボタンの「透明」を「いいえ」(表示)しておいてから、花一覧フォームを起動・・・
起動時の OpenArgs で、コマンドボタンの数字(区画番号)部分を通知する様に・・・

区画(コマンドボタン)をアニメーション?表示するタイミングは、
花一覧フォームから、花番号を引数にして picPosShow(iNum As Long) が動くように Public ・・・
Private Type PICCHG
  iNo As Long
  sPath As String
End Type

Dim itCnt As Long
Dim tPic() As PICCHG
Dim iCnt As Long
Dim iLoop As Long

Public Sub picPosShow(iNum As Long)
  Dim rs As New ADODB.Recordset

  If (Me.TimerInterval > 0) Then Exit Sub
  itCnt = -1
  rs.Source = "SELECT 区画番号 FROM T花割当 WHERE used=True AND 花番号=" & iNum & ";"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    itCnt = itCnt + 1
    If (itCnt = 0) Then
      ReDim tPic(itCnt)
    Else
      ReDim Preserve tPic(itCnt)
    End If
    With tPic(itCnt)
      .iNo = rs(0)
      .sPath = Me("btn" & .iNo).Picture
    End With
    rs.MoveNext
  Wend
  rs.Close
  If (itCnt < 0) Then Exit Sub
  iCnt = 3
  iLoop = 0
  Me.TimerInterval = 100
End Sub

花番号をもらったら、その花が植えられている区画番号を求めます。
求まったら、現在のコマンドボタンに割り当てられている画像パスを退避しておきます。
で、フォームの「タイマ時」を起動する様に・・・

「タイマ時」では、その退避した情報を元に、
対象のコマンドボタンにアニメーション?用の画像を貼り付けていきます。
アニメーション?が終わったら、退避していた画像パスをコマンドボタンに戻します。
Const sPname As String = "\pic\gmo"

Private Sub Form_Timer()
  Dim i As Long, j As Long

  On Error Resume Next
  Me.Painting = False
  iLoop = iLoop + 1
  For i = 0 To itCnt
    With Me("btn" & tPic(i).iNo)
      .Picture = CurrentProject.Path & sPname & iLoop & ".bmp"
      If (Err <> 0) Then
        Err = 0
        iCnt = iCnt - 1
        If (iCnt > 0) Then
          iLoop = 1
          .Picture = CurrentProject.Path & sPname & iLoop & ".bmp"
        Else
          For j = 0 To itCnt
            Me("btn" & tPic(j).iNo).Picture = tPic(j).sPath
          Next
          Me.TimerInterval = 0
          Exit For
        End If
      End If
    End With
  Next
  Me.Painting = True
End Sub

区画の画像だけ変更して・・・・
関数を呼んでもらう様に・・・・区画番号はこれで、画像のパスはこれで・・・・
Public Sub picChange(iNum As Long, sPath As String)
  On Error Resume Next
  If (Me.TimerInterval > 0) Then Exit Sub
  Me("btn" & iNum).Picture = MkPath(sPath)
End Sub

アニメーション?していたら変更はしませんよ・・・・
ここでの指定は一時的なものです。
正式には、前述した init() 実行時に、テーブル「T区画状況」から取得します。
なので、花一覧フォームを閉じる時には、テーブル「T区画状況」を更新し、init() を呼び出します。
画像パスの、相対/絶対 判別&作成部分は関数化
Private Function MkPath(sPath As String) As String
  If (Len(sPath) = 0) Then
    MkPath = ""
  ElseIf ((Mid(sPath, 2, 2) = ":\") Or (Left(sPath, 2) = "\\")) Then
    MkPath = sPath
  Else
    MkPath = CurrentProject.Path & "\" & sPath
  End If
End Function

細かく説明してみるとこんな感じで・・・・記述した全部は以下
Private Type PICCHG
  iNo As Long
  sPath As String
End Type

Dim itCnt As Long
Dim tPic() As PICCHG
Dim iCnt As Long
Dim iLoop As Long

Const sPname As String = "\pic\gmo"
Const sFn As String = "FG4S"

Private Sub Form_Timer()
  Dim i As Long, j As Long

  On Error Resume Next
  Me.Painting = False
  iLoop = iLoop + 1
  For i = 0 To itCnt
    With Me("btn" & tPic(i).iNo)
      .Picture = CurrentProject.Path & sPname & iLoop & ".bmp"
      If (Err <> 0) Then
        Err = 0
        iCnt = iCnt - 1
        If (iCnt > 0) Then
          iLoop = 1
          .Picture = CurrentProject.Path & sPname & iLoop & ".bmp"
        Else
          For j = 0 To itCnt
            Me("btn" & tPic(j).iNo).Picture = tPic(j).sPath
          Next
          Me.TimerInterval = 0
          Exit For
        End If
      End If
    End With
  Next
  Me.Painting = True
End Sub

Private Function btnShow()
  If (CurrentProject.AllForms(sFn).IsLoaded) Then
    DoCmd.Close acForm, sFn, acSaveNo
  End If
  With Me.ActiveControl
    .Transparent = False
    DoCmd.OpenForm sFn, acNormal, , , , , Mid(.Name, 4)
  End With
End Function

Private Function MkPath(sPath As String) As String
  If (Len(sPath) = 0) Then
    MkPath = ""
  ElseIf ((Mid(sPath, 2, 2) = ":\") Or (Left(sPath, 2) = "\\")) Then
    MkPath = sPath
  Else
    MkPath = CurrentProject.Path & "\" & sPath
  End If
End Function

Public Sub picPosShow(iNum As Long)
  Dim rs As New ADODB.Recordset

  If (Me.TimerInterval > 0) Then Exit Sub
  itCnt = -1
  rs.Source = "SELECT 区画番号 FROM T花割当 WHERE used=True AND 花番号=" & iNum & ";"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    itCnt = itCnt + 1
    If (itCnt = 0) Then
      ReDim tPic(itCnt)
    Else
      ReDim Preserve tPic(itCnt)
    End If
    With tPic(itCnt)
      .iNo = rs(0)
      .sPath = Me("btn" & .iNo).Picture
    End With
    rs.MoveNext
  Wend
  rs.Close
  If (itCnt < 0) Then Exit Sub
  iCnt = 3
  iLoop = 0
  Me.TimerInterval = 100
End Sub

Public Sub picChange(iNum As Long, sPath As String)
  On Error Resume Next
  If (Me.TimerInterval > 0) Then Exit Sub
  Me("btn" & iNum).Picture = MkPath(sPath)
End Sub

Public Sub init()
  Dim rs As New ADODB.Recordset
  Dim i As Long

  On Error Resume Next
  rs.Source = "SELECT Q1.区画番号, Q1.区画名, Q2.区画番号 AS 区画番号2,Q2.画像 FROM T区画 AS Q1 " _
        & "LEFT JOIN T区画状況 AS Q2 ON Q1.区画番号=Q2.区画番号;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    i = rs("区画番号")
    If ((i >= 1) And (i <= 35)) Then
      With Me("btn" & i)
        .Caption = rs("区画名")
        .ControlTipText = .Caption
        .OnClick = "=btnShow()"
        If (Not IsNull(rs("区画番号2"))) Then
          .Picture = MkPath(Nz(rs("画像")))
          .Transparent = False
        Else
          .Picture = ""
          .Transparent = True
        End If
        .CursorOnHover = acCursorOnHoverHyperlinkHand
      End With
    End If
    rs.MoveNext
  Wend
  rs.Close
End Sub

Private Sub DefFrm()
  Dim i As Long

  On Error Resume Next
  Me.PictureType = 1
  Me.Picture = CurrentProject.Path & "\pic\gb.bmp"

  For i = 1 To 35
    With Me("btn" & i)
      .Transparent = True
      .PictureType = 1
      .Picture = ""
      .CursorOnHover = acCursorOnHoverDefault
    End With
  Next
  Me.InsideWidth = 14 * 567
  Me.InsideHeight = 10 * 567
End Sub

Private Sub Form_Load()
  Call DefFrm
  Call init
End Sub

Private Sub Form_Close()
  If (CurrentProject.AllForms(sFn).IsLoaded) Then
    DoCmd.Close acForm, sFn, acSaveNo
  End If
End Sub

 

花一覧用フォーム「F4S」

クエリ「Q1」を元にフォームウィザードで「used」「花名」を選んで、表形式で作成
デザイン表示にして、フォームの
・「レコードセレクタ」「移動ボタン」を「いいえ」
・「スクロールバー」を「垂直のみ」
・「追加の許可」「削除の許可」を「いいえ」
used のラベル部分を「植」に変更
テキストボックス「花名」の「編集ロック」を「はい」
ヘッダ部に
・不可視のテキストボックス「txt0」を配置  コントロールソースを「Q1.花番号」
・区画画像用テキストボックス「txt1」を配置

デザイン上での設定はこんな感じで・・・・・

フォームが起動されたら
Private Const SRSQL As String = _
   "SELECT * FROM T花 AS Q1 LEFT JOIN " _
  & "(SELECT * FROM T花割当 WHERE 区画番号={%1}) AS Q2 ON Q1.花番号=Q2.花番号 " _
  & "ORDER BY SWITCH(Q2.used Is Null,3,Q2.used,1,True,2), Q1.花名;"

Dim frm As Form
Dim iKuNo As Long


Private Sub Form_Open(Cancel As Integer)
  Dim ctl As Control

  On Error Resume Next
  Set ctl = Screen.ActiveControl
  If (ctl Is Nothing) Then
    Cancel = True
    Exit Sub
  End If

  While (TypeOf ctl.Parent Is Control)
    Set ctl = ctl.Parent
  Wend
  Set frm = ctl.Parent
  
  iKuNo = Nz(Me.OpenArgs, 1)
  Me.RecordSource = Replace(SRSQL, "{%1}", iKuNo)
  Me.Caption = "区画番号 " & iKuNo & " の割当状況"
  Me.InsideHeight = Me.Section(acHeader).Height _
          + Me.Section(acDetail).Height * 20 _
          + 100
  Me.txt1 = DLookup("画像", "T区画状況", "区画番号=" & iKuNo)
End Sub

まず、スクリーン上のアクティブコントロールを求めます。
求められなかったら、直接起動したんでしょ・・・・で、Cancel = True で戻ります。
そのアクティブコントロールから、そのコントロールが存在するフォームを求めます。
というのは、アクティブコントロール = 区画用フォームのクリックされたコマンドボタン
になっているはず・・・・・
そのフォームで Public (外出し)した関数を呼び出すには そのフォーム.関数名 なので・・・
起動元フォームが単純であれば、Screen.ActiveForm で取得できますが、
起動元フォームがサブフォームとして組み込まれていたとかすると 関数の呼び出しに失敗する・・・・
なので、そのフォームにあるコントロールからフォームを辿った方が確かなのかな・・・
(この辺は過去記事にもあったかと・・・・例えば「起動元に値を設定」)
普通だと、コントロールの親がフォームの場合が多いですが、タブ内のコントロールとかなら・・・

OpenArgs で通知してもらった区画番号を覚えておいて、レコードソースの再設定・・・
表示するフォームの大きさ(上記では 20件を表示できる縦指定)
で、通知してもらった区画番号の画像パスを入手(非連結部分)

このフォームの基本は、花の割付けはチェックボックスをチェックしたら・・・なので、
チェックボックスの値が変わったら(更新後処理)で、レコードを確定します。
確定する際に足りない「区画番号」「更新日時」は、フォームの「更新前処理」で設定します。
(花番号は自動で設定されるようですので・・・)
Private Sub Form_BeforeUpdate(Cancel As Integer)
  Me.区画番号 = iKuNo
  Me.更新日時 = Now()
End Sub

Private Sub used_AfterUpdate()
  Me.Refresh
End Sub

区画への画像設定部分(ヘッダ部の非連結テキストボックス「txt1」)の更新後処理では
「txt1」の内容が何であろうと、テーブル「T区画状況」にレコードを作成します。
また、ダブルクリックされたらダイアログを表示して指定できるように・・・
Private Sub txt1_AfterUpdate()
  Dim rs As New ADODB.Recordset

  rs.Source = "SELECT * FROM T区画状況 WHERE 区画番号=" & iKuNo & ";"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
  If (rs.EOF) Then
    rs.AddNew
    rs("区画番号") = iKuNo
  End If
  rs("画像") = Me.txt1
  rs("更新日時") = Now()
  rs.Update
  rs.Close
  If (Not frm Is Nothing) Then
    Call frm.picChange(iKuNo, Nz(Me.txt1, ""))
  End If
End Sub

Private Sub txt1_DblClick(Cancel As Integer)
  Dim sFullPath As String, sFileName As String

  Cancel = True
  If (appFileNameGet(Me.hwnd, "区画画像の指定", sFullPath, sFileName)) Then
    Me.txt1 = sFullPath
    Call txt1_AfterUpdate
  End If
End Sub

「花名」部分がダブルクリックされたら、元フォームの関数 picPosShow を呼び出します。
Private Sub 花名_DblClick(Cancel As Integer)
  Cancel = True
  If (Not frm Is Nothing) Then Call frm.picPosShow(Me.txt0)
End Sub

ここで、テキストボックスがダブルクリックされた時の処理を記述する時の注意点として、

通常のテキストボックスでの動作は、クリックされた部分の文字列を反転表示するようです。
ここでは、反転表示・・・云々は意図していないので Cancel = True しておきます。
これにより、関数から戻った時に Access さんが余計な処理をしないで済みます。
よく、ダブルクリックしたら他フォームを起動・・・・ってなことをするかもしれませんが、
Cancel = True していないと、バージョンによっては、起動したフォームの表示が、
起動元フォームの下側になってしまう等あるようです。


フォームを閉じる時に、テーブル間の整合を取ります。
Private Sub Form_Close()
  Dim sSql As String

  sSql = "DELETE * FROM T区画状況 WHERE 区画番号={%1} AND " _
    & "NOT EXISTS (SELECT 1 FROM T花割当 WHERE used=True AND 区画番号={%1});"
  CurrentProject.Connection.Execute Replace(sSql, "{%1}", iKuNo)

  If (Not IsNull(DLookup("花番号", "T花割当", "used=True AND 区画番号=" & iKuNo)) _
    And IsNull(DLookup("区画番号", "T区画状況", "区画番号=" & iKuNo))) Then
    sSql = "INSERT INTO T区画状況(区画番号) VALUES (" & iKuNo & ");"
    CurrentProject.Connection.Execute sSql
  End If

  If (Not frm Is Nothing) Then
    Call frm.init
  End If
  Set frm = Nothing
End Sub

テーブル「T区画状況」に処理した区画番号のデータが、割付けた花がないにもかかわらず存在したら・・・
削除・・・します。(区画フォームでの「透明」処理のために不要なレコードは消しておく)
さらに、割付けた花があるんだけど・・・
テーブル「T区画状況」にデータがなかったら画像のないレコードを追加・・・
さて、テーブルがチャンとしたから起動元フォームさん・・・もう一回表示してみて・・・・

今回は、あまり処理を分散しない様(?)にしたのでこんな感じになりましたが、
花一覧用フォームに関数を用意して、Open / Close しなくても区画切り換えできる様にするとか・・・
実現方法はいろいろあると思います。
また、閉じる時には自分が扱った区画番号に着目していますが、全体を見て・・・・
っていうやり方もあるかも・・・・

フォーム「FG4S」に記述した全 VBA は以下
Private Const SRSQL As String = _
   "SELECT * FROM T花 AS Q1 LEFT JOIN " _
  & "(SELECT * FROM T花割当 WHERE 区画番号={%1}) AS Q2 ON Q1.花番号=Q2.花番号 " _
  & "ORDER BY SWITCH(Q2.used Is Null,3,Q2.used,1,True,2), Q1.花名;"

Dim frm As Form
Dim iKuNo As Long


Private Sub Form_Open(Cancel As Integer)
  Dim ctl As Control

  On Error Resume Next
  Set ctl = Screen.ActiveControl
  If (ctl Is Nothing) Then
    Cancel = True
    Exit Sub
  End If

  While (TypeOf ctl.Parent Is Control)
    Set ctl = ctl.Parent
  Wend
  Set frm = ctl.Parent
  
  iKuNo = Nz(Me.OpenArgs, 1)
  Me.RecordSource = Replace(SRSQL, "{%1}", iKuNo)
  Me.Caption = "区画番号 " & iKuNo & " の割当状況"
  Me.InsideHeight = Me.Section(acHeader).Height _
          + Me.Section(acDetail).Height * 20 _
          + 100
  Me.txt1 = DLookup("画像", "T区画状況", "区画番号=" & iKuNo)
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  Me.区画番号 = iKuNo
  Me.更新日時 = Now()
End Sub

Private Sub txt1_AfterUpdate()
  Dim rs As New ADODB.Recordset

  rs.Source = "SELECT * FROM T区画状況 WHERE 区画番号=" & iKuNo & ";"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
  If (rs.EOF) Then
    rs.AddNew
    rs("区画番号") = iKuNo
  End If
  rs("画像") = Me.txt1
  rs("更新日時") = Now()
  rs.Update
  rs.Close
  If (Not frm Is Nothing) Then
    Call frm.picChange(iKuNo, Nz(Me.txt1, ""))
  End If
End Sub

Private Sub txt1_DblClick(Cancel As Integer)
  Dim sFullPath As String, sFileName As String

  Cancel = True
  If (appFileNameGet(Me.hwnd, "区画画像の指定", sFullPath, sFileName)) Then
    Me.txt1 = sFullPath
    Call txt1_AfterUpdate
  End If
End Sub

Private Sub used_AfterUpdate()
  Me.Refresh
End Sub

Private Sub 花名_DblClick(Cancel As Integer)
  Cancel = True
  If (Not frm Is Nothing) Then Call frm.picPosShow(Me.txt0)
End Sub

Private Sub Form_Close()
  Dim sSql As String

  sSql = "DELETE * FROM T区画状況 WHERE 区画番号={%1} AND " _
    & "NOT EXISTS (SELECT 1 FROM T花割当 WHERE used=True AND 区画番号={%1});"
  CurrentProject.Connection.Execute Replace(sSql, "{%1}", iKuNo)

  If (Not IsNull(DLookup("花番号", "T花割当", "used=True AND 区画番号=" & iKuNo)) _
    And IsNull(DLookup("区画番号", "T区画状況", "区画番号=" & iKuNo))) Then
    sSql = "INSERT INTO T区画状況(区画番号) VALUES (" & iKuNo & ");"
    CurrentProject.Connection.Execute sSql
  End If

  If (Not frm Is Nothing) Then
    Call frm.init
  End If
  Set frm = Nothing
End Sub

 
出来上がったので、フォーム「FG4」を起動してどこか区画部分をクリックすると、
花一覧用の「FG4S」が起動されると思います。
ただ、この時にフォーム「FG4」「FG4S」の表示位置について何も処理していないので、
区画を選ぶたびに・・・フォームを横にずらして・・・・って面倒なのかな・・・・・ということで FG5 系に。
ただ、基本的な区画用フォームと花一覧フォームの連携部分は、ほぼ完成です。

※ バージョンによっての動きの違い

フォーム「FG4S」が起動元フォームに重なって上側にある状態で、
花名のダブルクリックにより区画画像が変わる(アニメーション?する)場合、
・2007 ではフォームの前後関係に変化はありません。
・2000 / 2003 では、起動元フォームが前面に表示されるようです。

※ このフォーム「FG4S」は、元々クエリ「Q1」をベースにしています。
花のマスタ「T花」全てと、「T花割当」のその区画のものとを結び付けて・・・・やってますが
(SELECT * FROM T花割当 WHERE 区画番号=0) AS Q2
部分を、起動元フォームを参照する形
(SELECT * FROM T花割当 WHERE 区画番号=[Forms]![FG4]![txtX]) AS Q2
でも良いと思いますが・・・・
もちろん起動元フォームのテキストボックス「txtX」に区画番号が入っている事が条件になりますけど・・・・
起動元のフォームがどういう構成になっているか・・・・サブフォーム組み込みの中で起動しているのか・・・・
だったら [Forms]![フォーム名]![サブフォームコントロール名]![txtX] とかに変更しないと・・・・とか
それよりは、書き換えたものをレコードソースに設定し直した方が良いんでは・・・・??? ということで・・・・


表示位置を固定したフォーム「FG5」「FG5S」

FG5M_2007

これはフォーム枠をなくして、意図した位置に配置しましょうというもの・・・・
これをしたい場合、2007 では「オプション」→「カレントデータベース」にある
「ドキュメント ウィンドウ オプション」を「ウィンドウを重ねて表示する」に変更しておきます。

フォーム「FG4」を「FG5」名で、「FG4S」を「FG5S」名でコピーします。
各フォーム「FG5」「FG5S」をデザインで開き、「境界線スタイル」を「なし」とします。
これにより、今まで表示されていたウィンドウの枠は表示されないようになり、
また、右上にあった「閉じる(×部分)」も表示されなくなります。
この状態ではウィンドウを閉じる事が出来なくなるので、閉じる用のボタンを配置します。
で、各フォームが表示される時に配置位置( DoCmd.MoveSize )を指定します。

※ バージョンによる表示の違い

フォーム「FG5」を起動する際には、
・2007 ではそのままでも
・2000 / 2003 では、メニュー「表示」→「ツールバー」から全てのツールバーを表示しないように・・・
 ツールバーを表示していると、「FG5」表示後ツールバーが消えます。
 という事は、フォームを表示している上側に空白部分が増える事になります。
 この空白部分が増えた状態で「FG5S」が起動されると、縦の表示位置が「FG5」とズレる事になります。

フォーム「FG5」で、フォーム「FG4」から変更追加した部分は以下
Const sFn As String = "FG5S"

Private Sub Form_Open(Cancel As Integer)
  DoCmd.MoveSize 0.5 * 567, 0.5 * 567, 14 * 567, 12 * 567
End Sub


 
フォーム「FG5S」で、フォーム「FG4S」から変更追加した部分は以下
Private Sub Form_Open(Cancel As Integer)
  Dim ctl As Control

  On Error Resume Next
  Set ctl = Screen.ActiveControl
  If (ctl Is Nothing) Then
    Cancel = True
    Exit Sub
  End If

  While (TypeOf ctl.Parent Is Control)
    Set ctl = ctl.Parent
  Wend
  Set frm = ctl.Parent

  iKuNo = Nz(Me.OpenArgs, 1)
  Me.RecordSource = Replace(SRSQL, "{%1}", iKuNo)
  Me.InsideHeight = Me.Section(acHeader).Height _
          + Me.Section(acDetail).Height * 20 _
          + 100
  Me.txt1 = DLookup("画像", "T区画状況", "区画番号=" & iKuNo)

  DoCmd.MoveSize 14.6 * 567, 0.5 * 567
End Sub

 
この変更で、動くには動くのですが、アニメーション?表示させると画面が結構チラつきます。
じゃぁ、表示位置を決めながら・・・操作で意識しない様に・・・・
フォーム「FG4」「FG4S」をサブフォームとして組み込んで、一体化させてみましょうか・・・・
という事で・・・

メインフォームに2つのサブフォーム組み込み「FG6M / FG6S1 / FG6S2」

フォーム「FG4」を「FG6S1」名でコピー、フォーム「FG4S」を「FG6S2」名でコピー
新しいフォームをフォームデザインから作成
基本的な「レコードセレクタ」「レコード移動」を「いいえ」としておきます。
で、詳細部分にフォーム「FG6S1」をドラッグ&ドロップ・・・・
サブフォームコントロール名を「FSUB1」に変更
また、フォーム「FG6S2」をドラッグ&ドロップ・・・・
サブフォームコントロール名を「FSUB2」に変更し、「ソースオブジェクト」部分を空欄に・・・
花一覧の表示が必要になったら、「ソースオブジェクト」に「FG6S2」を設定しますが、
どの区画番号のものを・・・・
これ、OpenArgs では渡せないので、メインフォームの Tag 経由で通知する事に・・・・
(初期表示時、「FSUB2」は不可視とするようにサブフォームコントロールの可視を設定)

今まで、直接「花一覧フォームの起動」や、花一覧からの「区画表示要求」等・・・・
メインフォームを経由する事に・・・・
メインフォームを経由する事で、相手のフォームが、どのサブフォームコントロールに居るのか・・・・
知らなくて済みます。

フォーム「FG6M」が起動されたら、初期表示で区画部分のみ表示したいので・・・・
サブフォームコントロール「FSUB1」もとのフォーム「FG6S1」の大きさを求めて、
メインフォームの大きさを変更後、サブフォームコントロールの大きさを設定します。
Private Sub Form_Load()
  Dim iWidth As Long, iHeight As Long

  With Me.FSUB1
    With .Form
      iWidth = .InsideWidth
      iHeight = .InsideHeight
    End With
    Me.InsideWidth = iWidth + .Left * 2
    Me.InsideHeight = iHeight + .Top * 2
    .Width = iWidth
    .Height = iHeight
  End With
End Sub

区画表示フォームから、花一覧フォームの起動要求が来たら
花一覧表示用フォームへ、処理対象の「区画番号」を Tag 経由で通知する事に・・・・
ソースオブジェクトへ花表示フォームを設定した次の行では、フォームの大きさを求める事が出来るので、
初めて花一覧フォームを表示するのであれば(サブフォームコントロール「FSUB2」の Visible が False )
フォームの大きさを求めて、メインフォームを大きくしてからサブフォームコントロールのサイズを変更・・・・
これ、順を逆にしてしまうと・・・・エラーが起きたような気が・・・・
Public Sub btnShow(iNum As Long)
  Dim iWidth As Long, iHeight As Long
  Dim i As Long, j As Long

  Me.txt1 = iNum
  Me.Tag = iNum
  Me.FSUB2.SourceObject = "FG6S2"
  If (Not Me.FSUB2.Visible) Then
    With Me.FSUB2
      With .Form
        iWidth = .InsideWidth + 150
        iHeight = .InsideHeight + 270
      End With
      .Left = Me.FSUB1.Width + Me.FSUB1.Left * 2
      .Width = iWidth
      Me.InsideWidth = .Left + .Width + Me.FSUB1.Left
      Me.InsideHeight = iHeight + .Top + Me.FSUB1.Top
      .Height = iHeight
      .Visible = True
    End With
    Me.txt1.Visible = True
  End If
End Sub

花一覧フォームから区画フォームへの要求が来たら、橋渡しします。
Public Sub picPosShow(iNum As Long)
  Call Me.FSUB1.Form.picPosShow(iNum)
End Sub

Public Sub picChange(iNum As Long, sPath As String)
  Call Me.FSUB1.Form.picChange(iNum, sPath)
End Sub

Public Sub init()
  Call Me.FSUB1.Form.init
End Sub


メインフォーム「FG6M」に記述した全内容は以下
Private Sub Form_Load()
  Dim iWidth As Long, iHeight As Long

  With Me.FSUB1
    With .Form
      iWidth = .InsideWidth
      iHeight = .InsideHeight
    End With
    Me.InsideWidth = iWidth + .Left * 2
    Me.InsideHeight = iHeight + .Top * 2
    .Width = iWidth
    .Height = iHeight
  End With
End Sub

Public Sub btnShow(iNum As Long)
  Dim iWidth As Long, iHeight As Long
  Dim i As Long, j As Long

  Me.txt1 = iNum
  Me.Tag = iNum
  Me.FSUB2.SourceObject = "FG6S2"
  If (Not Me.FSUB2.Visible) Then
    With Me.FSUB2
      With .Form
        iWidth = .InsideWidth + 150
        iHeight = .InsideHeight + 270
      End With
      .Left = Me.FSUB1.Width + Me.FSUB1.Left * 2
      .Width = iWidth
      Me.InsideWidth = .Left + .Width + Me.FSUB1.Left
      Me.InsideHeight = iHeight + .Top + Me.FSUB1.Top
      .Height = iHeight
      .Visible = True
    End With
    Me.txt1.Visible = True
  End If
End Sub

Public Sub picPosShow(iNum As Long)
  Call Me.FSUB1.Form.picPosShow(iNum)
End Sub

Public Sub picChange(iNum As Long, sPath As String)
  Call Me.FSUB1.Form.picChange(iNum, sPath)
End Sub

Public Sub init()
  Call Me.FSUB1.Form.init
End Sub

 
区画用フォーム「FG6S1」では、「FG4」からの変更・追加部分は以下になります。
Private Function btnShow()
  With Me.ActiveControl
    Call Me.Parent.btnShow(CLng(Mid(.Name, 4)))
    .Transparent = False
  End With
End Function

Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Me.Parent.Tag <> "") Then Cancel = True
End Sub

 
花一覧用フォームの起動は、メインフォーム経由で・・・
また、フォームの「開く時」で、サブフォームとして組み込まれているか・・・・
(今回はこの判別で・・・・他にも判別の方法はありますが・・・)

花一覧フォーム「FG6S2」側での大きな変更点は、
・一回に見える件数を 20 → 15 件にして、区画フォーム下の空きを少なくしましょうか・・・
・処理対象の区画番号は、メインの Tag 経由でもらいましょう・・・
・区画フォームへの要求は、メインフォーム経由にしましょう・・・
 どのサブフォームコントロールに区画フォームがあるのか知らなくても良いので・・・

で、花一覧フォーム「FG6S2」への記述は
Private Const SRSQL As String = _
   "SELECT * FROM T花 AS Q1 LEFT JOIN " _
  & "(SELECT * FROM T花割当 WHERE 区画番号={%1}) AS Q2 ON Q1.花番号=Q2.花番号 " _
  & "ORDER BY SWITCH(Q2.used Is Null,3,Q2.used,1,True,2), Q1.花名;"

Dim iKuNo As Long


Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Me.Parent.Tag = "") Then
    Cancel = True
    Exit Sub
  End If
    
  iKuNo = Me.Parent.Tag
  Me.RecordSource = Replace(SRSQL, "{%1}", iKuNo)
  Me.InsideHeight = Me.Section(acHeader).Height _
          + Me.Section(acDetail).Height * 15 _
          + 100
  Me.txt1 = DLookup("画像", "T区画状況", "区画番号=" & iKuNo)
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  Me.区画番号 = iKuNo
  Me.更新日時 = Now()
End Sub

Private Sub txt1_AfterUpdate()
  Dim rs As New ADODB.Recordset

  rs.Source = "SELECT * FROM T区画状況 WHERE 区画番号=" & iKuNo & ";"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
  If (rs.EOF) Then
    rs.AddNew
    rs("区画番号") = iKuNo
  End If
  rs("画像") = Me.txt1
  rs("更新日時") = Now()
  rs.Update
  rs.Close
  Call Me.Parent.picChange(iKuNo, Nz(Me.txt1, ""))
End Sub

Private Sub txt1_DblClick(Cancel As Integer)
  Dim sFullPath As String, sFileName As String

  Cancel = True
  If (appFileNameGet(Me.hwnd, "区画画像の指定", sFullPath, sFileName)) Then
    Me.txt1 = sFullPath
    Call txt1_AfterUpdate
  End If
End Sub

Private Sub used_AfterUpdate()
  Me.Refresh
End Sub

Private Sub 花名_DblClick(Cancel As Integer)
  Cancel = True
  Call Me.Parent.picPosShow(Me.txt0)
End Sub

Private Sub Form_Close()
  Dim sSql As String

  sSql = "DELETE * FROM T区画状況 WHERE 区画番号={%1} AND " _
    & "NOT EXISTS (SELECT 1 FROM T花割当 WHERE used=True AND 区画番号={%1});"
  CurrentProject.Connection.Execute Replace(sSql, "{%1}", iKuNo)

  If (Not IsNull(DLookup("花番号", "T花割当", "used=True AND 区画番号=" & iKuNo)) _
    And IsNull(DLookup("区画番号", "T区画状況", "区画番号=" & iKuNo))) Then
    sSql = "INSERT INTO T区画状況(区画番号) VALUES (" & iKuNo & ");"
    CurrentProject.Connection.Execute sSql
  End If

  Call Me.Parent.init
End Sub

 
さて、これでサブフォーム組み込みで動くものが出来ました。
まぁ、このままでも良いんですけど・・・・
花一覧フォームから区画フォームへの要求は直接呼び出しましょうか・・・・

っていうのが「FG7M / FG7S1 / FG7S2」 (左:2007 中:2003 右:2000)

FG7M_2007  FG7M_2003  FG7M_2000

フォーム「FG6M / FG6S1 / FG6S2」と「FG7M / FG7S1 / FG7S2」の見え方・動作は同じです。

フォーム「FG6M」を「FG7M」名で、「FG6S1」を「FG7S1」名で、「FG6S2」を「FG7S2」名でコピー
修正を入れていくのは「FG7M」「FG7S2」の2つ。
(区画フォーム「FG7S1」に変更はありません)

メイン「FG7M」では、サブフォームコントロール「FSUB1」のソースオブジェクトを「FG7S1」に・・・
また、サブフォームコントロール「FSUB2」のソースオブジェクトへは「FG7S2」を設定する記述に・・・
後は、
Public Function GetFrm() As Form
  Set GetFrm = Me.FSUB1.Form
End Function
を新設。区画フォームの Form を教えて・・・ってきたら、教えてあげる。

この、区画フォームを教えて・・・・は、花一覧フォーム「FG7S2」の「開く時」に発行&入手しておきます。
Dim frm As Form


Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Me.Parent.Tag = "") Then
    Cancel = True
    Exit Sub
  End If

  iKuNo = Me.Parent.Tag
  Me.RecordSource = Replace(SRSQL, "{%1}", iKuNo)
  Me.InsideHeight = Me.Section(acHeader).Height _
          + Me.Section(acDetail).Height * 15 _
          + 100
  Me.txt1 = DLookup("画像", "T区画状況", "区画番号=" & iKuNo)
  Set frm = Me.Parent.GetFrm
End Sub

後は、この frm を使って直接呼び出します。
  Call frm.picChange(iKuNo, Nz(Me.txt1, ""))
とか
  Call frm.picPosShow(Me.txt0)
とか
  Call frm.init


※ バージョンによる見え方

 フォーム「FG7M」で掲示した図でわかると思いますが、花一覧でのチェックボックスの表示状態・・・・
 2003 では、False / Null の区別がつきません。
 2007 / 2000 では、False / Null の区別はつきます。


※※ 全体的にソコソコ動くんですけど

いろいろやって確認した後で、時々最適化するんですが・・・・
その時、毎回ではなく・・・エラー通知のテーブルが出来る事があります。

kEnt168_err

これは何を言っているかわからないので、そのまま放っておいてます。
・・・・教えてくださいませ

なお、フォーム「FG4」以降の処理では、わざわざもう一回しなくても・・・・
と思う記述になっていたりします。(サンプルとしては、まぁ・・・良いか・・・かな)


おまけフォーム)



イメージコントロールを使ってみます。
フォーム名で言えば
・「F_T花」    ・・・ 帳票フォーム(2007 で動作:という事は 2000 / 2003 では NG)
・「F_T花2000」  ・・・ 単票フォーム
・「F_T花2000D」  ・・・ 帳票フォーム(イメージコントロールはヘッダに1つ)
・「F_T区画状況」 ・・・ 帳票フォーム(2007 で動作:という事は 2000 / 2003 では NG)

「F_T花」

kEnt168_e1  kEnt168_e1D

これは 2007 でのものになります。
というか、2000 / 2003 でも動作はしますが、イメージコントロールに画像が表示されません。

フォームの作り方)

テーブル「T花」を元にフォームウィザードで表形式として作ります。
「花番号」部分は中で採番するので、いじらせない様に「編集ロック」を「はい」に・・・
「画像」に入力されたパスを、相対/絶対解釈するテキストボックス「txt1」を配置
(実際では見えている必要はないので、不可視にしますが・・・今回は見えたままで)
テキストボックス「txt1」のコントロールソースに
=IIf(IsNull([画像]),"",IIf(Mid([画像],2,2)=":\" Or Left([画像],2)="\\",[画像],[CurrentProject].[Path] & "\" & [画像]))
を設定します。
で、右側にイメージコントロール「img1」を配置し、コントロールソースに
=[txt1]
を設定します。(「ピクチャタイプ」が「埋め込み」でも良い(?)みたいですね??)
イメージコントロール「img1」がダブルクリックされたら、大元の画像を表示する様に・・・
Private Sub img1_DblClick(Cancel As Integer)
  If (Len(Me.txt1) > 0) Then Call appShellExecute(Me.txt1)
End Sub
(「ハイパーリンクアドレス」を使う手もあるかと思いますが・・・・)

ま、大まかな動作はこれで良いかな・・・・と、動かしてみると・・・・
結論)イメージコントロールをクリックしてもレコードの移動は起きないんですね・・・
レコード1番目がカレントでいた場合、レコード6番目の「img1」をダブルクリックしても、
表示される画像は、レコード1番目のもの・・・・

ということで、レコードを移動させるために、フォーカス移動が発生するコマンドボタン「btn1」を
「透明」を「はい」として、イメージコントロールの上に重ねて配置する
・・・・ことに

で、記述した内容は以下
Dim sDelNo As String

Private Sub Form_Load()
  sDelNo = ""
End Sub

Private Sub Form_Delete(Cancel As Integer)
  sDelNo = sDelNo & "," & Me.花番号
End Sub

Private Sub Form_BeforeDelConfirm(Cancel As Integer, Response As Integer)
  Response = acDataErrContinue
End Sub

Private Sub Form_AfterDelConfirm(Status As Integer)
  Dim sSql As String

  On Error Resume Next
  If (Status = acDeleteOK) Then
    If (Len(sDelNo) > 0) Then
      sSql = "DELETE * FROM T花割当 WHERE 花番号 IN (" & Mid(sDelNo, 2) & ");"
      CurrentProject.Connection.Execute sSql
    End If
  End If
  sDelNo = ""
End Sub

Private Sub btn1_DblClick(Cancel As Integer)
  If (Len(Me.txt1) > 0) Then Call appShellExecute(Me.txt1)
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  If (Me.NewRecord) Then
    Me.花番号 = Nz(DMax("花番号", "T花"), 0) + 1
  End If
End Sub

Private Sub img1_DblClick(Cancel As Integer)
  If (Len(Me.txt1) > 0) Then Call appShellExecute(Me.txt1)
End Sub

Private Sub 画像_DblClick(Cancel As Integer)
  Dim sFullPath As String, sFileName As String

  Cancel = True
  If (appFileNameGet(Me.hwnd, "画像の指定", sFullPath, sFileName)) Then
    Me.画像 = sFullPath
  End If
End Sub

Private Sub 画像_ラベル_Click()
  Me.画像.SetFocus
End Sub

 
2000 / 2003 で表示できないのは、イメージコントロールにコントロールソースがない・・・為かと・・・
なお、上記記述では、レコードが削除されたら
・削除される花番号を覚えておいて
・テーブル「T花割当」の対象レコード(同じ花番号)も削除しておきますか・・・
※ そこまでやるんなら、「T区画状況」も見直せばいいのに・・・・今回手抜きで

※※ 2000 / 2003 で帳票フォーム表示したい・・・となったら、以下が参考になります

OleImage 関数 - 表形式(帳票)フォームにパスから画像を表示する方法
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsFrmOleImage.html


「F_T花2000」

kEnt168_e2

2000 / 2003 でも画像が見られるようにしてみましょうかという事で・・・
フォーム「F_T花」を「F_T花2000」名でコピーします。
・「既定のビュー」を単票フォームに変更します
・イメージコントロールに重ねていたコマンドボタン「btn1」を削除します
 (単票なので、そのレコードしか見えていないのでレコード移動・・・関係なくなるので)

で、以下の記述を追加します。
Private Sub Form_Current()
  On Error Resume Next
  Me.img1.Picture = Me.txt1
  If (Err <> 0) Then Me.img1.Picture = ""
End Sub

その他の余計な記述がありますが、
・レコード移動時に、画像パスを設定してあげます


「F_T花2000D」

kEnt168_e3

フォーム「F_T花2000」を帳票フォームにしてみましょうか・・・・という事で・・・・
フォーム「F_T花2000」を「F_T花2000D」名でコピーします。
・イメージコントロール「img1」をヘッダ部に移動します。
・「既定のビュー」を帳票フォームに変更します。

VBA の記述に変更はありません。

レコードを移動していくと、
「画像」にパスがある場合、ヘッダ部のイメージコントロールに画像が表示されます。


「F_T区画状況」

これは、フォーム「F_T花」の対象テーブル「T区画状況」版になります。
特記する事はありません。


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt168_2000.zipkEnt168_2003.zipkEnt168_2007.zip
 サイズ 2,167,4792,192,7242,198,772
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化


いつもに比べてサンプルファイルのサイズが大きくなっています。
確認される場合は、mdb / accdb を解凍した場所に、「pic」フォルダ以下も存在させてください。
割当データ等は空です。
ある程度データを入れてから、前のフォームに戻って確認・・・・が良いのかも・・・かも

※ 2000 / 2003 の mdb を 2007 で動かしてみると、アニメーション?時の色が暗めですね・・・
 何かあるんだろうか??


やっと記述が終わった・・・・終わった・・・何日経ったのだろう・・・・
今後は、細切れにでもしてみるかなぁ~~
関連記事

2013/09/03

Category: サンプルかな

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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