スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

予定表 


以下の2つのテーブルがあったとします。

テーブル「T顧客」
 顧客ID:オートナンバ(主キー)
 名前:テキスト
 略称:テキスト

テーブル「T予定表」
 予定ID:オートナンバ(主キー)
 予定日:日付/時刻
 顧客ID:長整数
 順:長整数

このテーブルを使って指定月を一覧で表示&入力
この時、1日に割付けられるのは20人まで・・・
表示は、略称を20人分・・・

そこで、テーブル「T表示日付」を設け、表示対象の日付だけを登録し直す事に・・・
サンプルで用意したフォームは10種類
大まかには、
・クロス集計で表示&その画面で入力
・日付のみの帳票フォームで、表示/入力はコントロールソースを駆使
上記2パターンで、表示/入力部分を各サブフォーム化
入力時のコンボ表示では、割付けしていない人に絞って、重複入力を防ぐ


F1改:クロス集計表示 タブ使用

kEnt183_F1  kEnt183_F1_2000

このフォームでは表示するだけです。
タブ上で、コントロールを重ねて・・・ 動きがおかしくなって使えないみたい
右側 2000 での表示はチョッとなぁ~

F4改:クロス集計表示上で入力(コンボ&コンボ重ね)

kEnt183_F4

表示用コンボと入力用コンボを重ねる方法で、コンボで入力するんだから表示もコンボのままでいいか・・・
チョッと圧迫感?があり・・・

F5:クロス集計表示上で入力(テキスト&コンボ&コンボ重ね)

kEnt183_F5

表示に使うコンボとそのコンボの Column(1) を参照して略称を表示するテキストボックス
さらに、入力用コンボ・・・計3つのコントロールを重ねるもの

F6:クロス集計表示上で入力位置管理(テキスト&コンボ&コンボ重ね)

kEnt183_F6

コントロールの構成は「F5」と同じですが、クロス集計の内容を見直したもの
「F5」までのクロス集計では、テーブル「T予定表」内「順」を使わず、「顧客ID」順で表示してました。
その方法では、データが多くなればクロス集計自体が遅くなり使えないものになりそう・・・
なので、入力した位置情報で「順」を設定し、「順」を使ったクロス集計にしましょう。
そうすれば、そんなに遅くはならない?かと

F7:日付のみの帳票 Dictionary で表示/入力(テキスト&コンボ重ね)

kEnt183_F7

「F6」までは、クロス集計を使っていたので、1入力ごとに再クエリする必要がありました。
画面も結構チラつくし・・・
重ねるコントロールも、テキストボックス&コンボに減らす事が出来るし・・・
表示対象日付、テーブル「T表示日付」のみを表示させ、略称は各コントロールソースで表示しましょう。
情報を持つものに、2段構成の Dictionary を使いましょう。
1段目キー:日付
2段目キー:順  値:顧客ID と 略称 の配列

F8:日付のみの帳票 配列 で表示/入力(テキスト&コンボ重ね)

kEnt183_F8

「F7」の情報の持ち方を 配列 にしましょう。
配列は、dic(1 To 31, 1 To 20) の dic(日にち, 順) Variant
設定する値は、Dictionary 同様の 顧客ID と 略称 の配列

F9:日付のみの帳票 Dictionary で表示位置切替/入力(テキスト&コンボ重ね)

kEnt183_F9  kEnt183_F9A

「F6」「F7」「F8」は、入力の位置を意識していましたが、表示は左詰めが分かりやすい??
ということで、画面上で切り替え出来る様に・・・
左詰め表示での入力では、先頭の空いている部分(指定位置表示時での)から埋めていく事に・・・
処理のベースは「F7」になります。

F_M1:メイン・サブ(F_S11/F_S12) クロス集計

kEnt183_M1

表示用/入力用を分け、表示用にクロス集計を利用したもの

F_M2:メイン・サブ(F_S21/F_S22) 日付のみの帳票 Dictionary

kEnt183_M2

表示用/入力用を分け、表示用に Dictionary 処理を利用したもの

F_M3:メイン・サブ(F_S31/F_S32) 日付のみの帳票 Dictionary + 条件付き書式

kEnt183_M3

「F_M2」に条件付き書式を設定して、見栄えを良く?したもの
2007 では、帳票フォーム表示時、代替えの背景色があって、レコードの区切りはわかりやすですが、
2000 / 2003 には無いので・・・ わかりやすいかな?ということで・・・
また、対象部分(レコード選択)を双方に反映してみる

今回、フォーム数が多いので細かくは説明しませんが、技を1つ紹介しておきます。

クロス集計を使っているフォームでは、
スクロールしている状態で再クエリして、入力を表示に反映する必要があります。
クロス集計に限った事ではありませんが、帳票フォームでスクロールしていた位置を動かしたくない・・・
再クエリしても元の位置にいて欲しい・・・・・・・・
そういった時に簡単に戻せる方法になります。

まず、詳細部分どこでも良いのでフォーカスをあてておきます。
その時、レコードを一意に決めれるをものを覚えておきます。(以下例では「日付」)
また、Me.CurrentSectionTop 値を覚えておきます。
そして再クエリ後
Me.Recordset.FindFirst にて覚えていた一意のものを検索します。
で、Me.GoToPage 1, , Me.CurrentSectionTop - 前に覚えていた Me.CurrentSectionTop 値
これで元に戻ります。
コードで記述してみると
  Dim dt As Date, iMove As Long

  Me.txt1.SetFocus     ' 詳細部分のコントロール(既にフォーカスが詳細にあるのなら不要)
  iMove = Me.CurrentSectionTop
  dt = Me.日付       ' 一意になるものを覚えておいて
  Me.Requery
  Me.Recordset.FindFirst "日付 = #" & dt & "#"    ' 一意のものを検索
  Me.GoToPage 1, , Me.CurrentSectionTop - iMove

※ ここで、一意に覚えていたものが再クエリ後、存在する事が前提です。
 場所が変わらないから Recordset 内の AbsolutePosition を覚えておいて、再設定すれば・・・
 これ、やってみたのですが・・・ 再設定時、タイミングが速すぎるのか、エラーに・・・
(FindFirst を使う分にはエラーにならないようです)

※ Me.GoToPage / DoCmd.GoToPage する際には、フォームがアクティブになっていないと・・・ 要注意
 (特にサブフォーム組み込み時には・・・・ 「F_M1」でやってます)
 
ここまで、クロス集計・・・ と記述していましたが、3種類のクロス集計を記述しています。
パターン1)フォーム「F1改」
TRANSFORM First(T2.顧客ID) AS 値
SELECT T1.日付 FROM T表示日付 AS T1 LEFT JOIN
(SELECT Q1.予定日, Q1.顧客ID, Count(*) AS CT FROM T予定表 AS Q1 INNER JOIN T予定表 AS Q2
ON (Q1.予定日=Q2.予定日) AND (Q1.顧客ID>=Q2.顧客ID)
GROUP BY Q1.予定日, Q1.顧客ID) AS T2
ON T1.日付=T2.予定日
GROUP BY T1.日付
PIVOT T2.CT In (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20);
各予定日での顧客ID順位を求めて、それと表示日付を結び付けたもの

パターン2)フォーム「F4改」「F5」
TRANSFORM First(T2.顧客ID) AS 値
SELECT T1.日付 FROM T表示日付 AS T1 LEFT JOIN
(SELECT Q1.予定日, Q1.顧客ID, Count(*) AS CT FROM
(SELECT 予定日, 顧客ID FROM T予定表 WHERE 予定日 In (SELECT 日付 FROM T表示日付)) AS Q1
INNER JOIN
(SELECT 予定日, 顧客ID FROM T予定表 WHERE 予定日 In (SELECT 日付 FROM T表示日付)) AS Q2
ON (Q1.顧客ID>=Q2.顧客ID) AND (Q1.予定日=Q2.予定日)
GROUP BY Q1.予定日, Q1.顧客ID) AS T2 ON T1.日付=T2.予定日
GROUP BY T1.日付
PIVOT T2.CT In (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20);
表示日付に絞り込んだ予定を使って、
各予定日での顧客ID順位を求めて、それと表示日付を結び付けたもの

パターン3)フォーム「F6」「F_S11」
TRANSFORM First(T2.顧客ID) AS 値
SELECT T1.日付 FROM T表示日付 AS T1 LEFT JOIN T予定表B AS T2 ON T1.日付=T2.予定日
GROUP BY T1.日付
PIVOT T2.順 In (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20);
※ 「F_S11」は「T予定表B」→「T予定表C」

パターン1) 2)は、テーブル「T予定表」にある「順」を使わずに、「顧客ID」順で並び替える
パターン3)は、テーブル「T予定表」にある「順」を使って、その順で並び替える

※ このテーブル「T予定表」は、パターンによって「T予定表B」「T予定表C」を使っています。
中の構成はどれも同じです。
「T予定表」は、「順」を使わない (「F1改」「F4改」「F5」)
「T予定表B」は、1 ~ 20 の値を場所にあったもので埋めていく (「F6」「F7」「F8」「F9」)
「T予定表C」は、1 ~ 20 の値を連番で採番するもの (「F_Mx」系)

※ データが多くなると、パターン1) 2)は遅くなっていきそう・・・
例えば、30日ある月で、20人全部予定が埋まっていたとすると、順を求める時に
( 1 + 2 + 3 + ・・・ + 19 + 20 ) * 30 日 のレコードが瞬間作られる?
= (20 + 21) / 2 * 30 = 210 * 30 = 6300

これは、パターン2)の時の計算式ですが、パターン1)ならもっともっと・・・
再クエリのたびに、6000 レコードの解釈って遅そうですよね・・・
それよりも、「順」を使った パターン3)は 20 * 30 = 600

「順」を使うっていうのは必須?でしょうか・・・


F1改:クロス集計表示 タブ使用

kEnt183_F1  kEnt183_F1_2000

このフォームでは表示するだけです。この方法は hatena さんから教えていただきました。


F4改:クロス集計表示上で入力(コンボ&コンボ重ね)

kEnt183_F4

表示用コンボと入力用コンボを重ねる方法で・・・
表示するコンボ cbx1 ~ cbx20 は、コントロールソースを設定して前面に
入力するコンボ cmb1 ~ cmb20 は、フォーカスを得る時、重複した顧客を選択できない様に・・・
で、帳票フォームで再クエリしても位置を動かさない様に・・・
このフォームの画面は、標準モジュール「Module2」の「MkFrm34」実行で出来上がります。

処理として記述したのは以下)
Private Const CSQL As String = "SELECT 顧客ID, 略称 FROM T顧客" _
              & " WHERE 顧客ID Not In ({%1}) ORDER BY 略称;"

Private Function GetNums(iNum As Long) As String
  Dim sS As String
  Dim i As Long

  sS = ""
  For i = 1 To 20
    With Me("cbx" & i)
      If (IsNull(.Value)) Then Exit For
      If (i <> iNum) Then sS = sS & "," & .Value
    End With
  Next
  GetNums = Mid(sS, 2)
End Function

Private Function fncCmbExter()
  Dim sS As String
  Dim iNum As Long

  iNum = Mid(Me.ActiveControl.Name, 4)
  sS = GetNums(iNum)
  If (Len(sS) = 0) Then sS = "0"
  With Me("cmb" & iNum)
    .RowSource = Replace(CSQL, "{%1}", sS)
    .Value = Me("cbx" & iNum)
    .Dropdown
  End With
End Function

Private Sub fncDelete(iNum As Long)
  Dim sSql As String

  sSql = "DELETE * FROM T予定表 WHERE 顧客ID=" & iNum _
    & " AND 予定日 = #" & Me.日付 & "#;"
  CurrentProject.Connection.Execute sSql
End Sub

Private Sub fncAdd(iNum As Long)
  Dim sSql As String

  sSql = "INSERT INTO T予定表(顧客ID, 予定日) VALUES (" & iNum _
    & ", #" & Me.日付 & "#);"
  CurrentProject.Connection.Execute sSql
End Sub

Private Function fncCmbAfterUpdate()
  Dim iNum As Long
  Dim dt As Date
  Dim iPos As Long, iMove As Long

  Me.Painting = False
  iNum = Mid(Me.ActiveControl.Name, 4)
  If (IsNull(Me("cmb" & iNum))) Then
    If (Not IsNull(Me("cbx" & iNum))) Then
      Call fncDelete(Me("cbx" & iNum))
    End If
  ElseIf (IsNull(Me("cbx" & iNum))) Then
    Call fncAdd(Me("cmb" & iNum))
  ElseIf (Me("cmb" & iNum) <> Me("cbx" & iNum)) Then
    Call fncDelete(Me("cbx" & iNum))
    Call fncAdd(Me("cmb" & iNum))
  End If

  iMove = Me.CurrentSectionTop
  dt = Me.日付
  Me.Requery
  Me.txt1.SetFocus
  Me.Recordset.FindFirst "日付 = #" & dt & "#"
  Me.GoToPage 1, , Me.CurrentSectionTop - iMove
  Me.Painting = True
  Me("cmb" & iNum).SetFocus
End Function

Private Function fncCbxEnter()
  Me("cmb" & Mid(Me.ActiveControl.Name, 4)).SetFocus
End Function

Private Sub InitCmbEvents()
  Dim i As Long

  For i = 1 To 20
    Me("cmb" & i).OnEnter = "=fncCmbExter()"
    Me("cmb" & i).AfterUpdate = "=fncCmbAfterUpdate()"
    Me("cbx" & i).OnEnter = "=fncCbxEnter()"
  Next
End Sub

Private Sub myRequery(bInit As Boolean)
  If (bInit) Then Call MkDate(Me.lab0.Caption)
  Me.Requery
End Sub

Private Sub btn1_Click()
  Me.lab0.Caption = Format(DateAdd("m", -1, Me.lab0.Caption), "yyyy/mm")
  Call myRequery(True)
End Sub

Private Sub btn2_Click()
  Me.lab0.Caption = Format(DateAdd("m", 1, Me.lab0.Caption), "yyyy/mm")
  Call myRequery(True)
End Sub

Private Sub Form_Load()
  Call InitCmbEvents
  Me.lab0.Caption = Format(Date, "yyyy/mm")
  Call myRequery(True)
End Sub

 

チョッと圧迫感?があり・・・???
ということで、
表示用コンボボックスを隠すために、テキストボックスを上に重ねる事にしたのが次の「F5」


F5:クロス集計表示上で入力(テキスト&コンボ&コンボ重ね)

kEnt183_F5

表示に使うコンボとそのコンボの Column(1) を参照して略称を表示するテキストボックス
さらに、入力用コンボ・・・計3つのコントロールを重ねるもの
今度は、テキストボックスが前面に表示されているので、テキストボックスにフォーカスが・・・
で、記述を変更します。

Private Function fncTxEnter()
  Me("cmb" & Mid(Me.ActiveControl.Name, 3)).SetFocus
End Function


Private Sub InitCmbEvents()
  Dim i As Long

  For i = 1 To 20
    Me("cmb" & i).OnEnter = "=fncCmbExter()"
    Me("cmb" & i).AfterUpdate = "=fncCmbAfterUpdate()"
    Me("tx" & i).OnEnter = "=fncTxEnter()"
  Next
End Sub


F6:クロス集計表示上で入力位置管理(テキスト&コンボ&コンボ重ね)

kEnt183_F6

コントロールの構成は「F5」と同じですが、クロス集計の内容を見直したもの
「F5」までのクロス集計では、テーブル「T予定表」内「順」を使わず、「顧客ID」順で表示してました。
その方法では、データが多くなればクロス集計自体が遅くなり使えないものになりそう・・・
なので、入力した位置情報で「順」を設定し、「順」を使ったクロス集計にしましょう。
そうすれば、そんなに遅くはならない?かと

「順」を設定する時、値は cmb1 ~ cmb20 の名前最後の数字を使いましょう・・・
フォーム「F5」から、さほど変更はありません。


F7:日付のみの帳票 Dictionary で表示/入力(テキスト&コンボ重ね)

kEnt183_F7

「F6」までは、クロス集計を使っていたので、1入力ごとに再クエリする必要がありました。
画面も結構チラつくし・・・
重ねるコントロールも、テキストボックス&コンボに減らす事が出来るし・・・
表示対象日付、テーブル「T表示日付」のみを表示させ、略称は各コントロールソースで表示しましょう。
情報を持つものに、2段構成の Dictionary を使いましょう。
1段目キー:日付
2段目キー:順  値:顧客ID と 略称 の配列

フォームのレコードソースは、 SELECT 日付 FROM T表示日付;  だけです。
表示用のテキストボックス tx1 ~ tx20 のコントロールソース、例えば、tx1 には
 =fncUserName([日付],1)
と関数を参照する様にします。この関数の内容は
Dim dic As Object

Private Function fncUserName(dt As Date, iNum As Long) As String
  Dim v As Variant

  fncUserName = ""
  v = dic(dt)(iNum)
  If (IsArray(v)) Then fncUserName = v(1)
End Function

じゃ・・・ dic はどう作ってるの・・・ということで
Private Sub myRequery()
  Dim rs As New ADODB.Recordset
  Dim sSql As String
  Dim i As Long

  Call MkDate(Me.lab0.Caption)
  If (dic Is Nothing) Then Set dic = CreateObject("Scripting.Dictionary")
  dic.RemoveAll
  rs.Open "T表示日付", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    dic.Add rs(0).Value, CreateObject("Scripting.Dictionary")
    For i = 1 To 20
      dic(rs(0).Value)(i) = Null
    Next
    rs.MoveNext
  Wend
  rs.Close

  sSql = "SELECT Q2.日付, Q3.顧客ID, Q3.順, Q1.略称" _
    & " FROM T顧客 AS Q1 INNER JOIN" _
    & " (T表示日付 AS Q2 INNER JOIN T予定表B AS Q3 ON Q2.日付 = Q3.予定日)" _
    & " ON Q1.顧客ID = Q3.顧客ID;"
  rs.Source = sSql
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    dic(rs("日付").Value)(rs("順").Value) = _
            Array(rs("顧客ID").Value, rs("略称").Value)
    rs.MoveNext
  Wend
  rs.Close
  Me.Requery
End Sub
まず、表示日付で1段目の Dictionary を作って、2段目のキー 1 ~ 20 を登録しておいて
予定表を見てデータがあったら、顧客ID、略称の2つを配列にして登録・・・


F8:日付のみの帳票 配列 で表示/入力(テキスト&コンボ重ね)

kEnt183_F8

「F7」の情報の持ち方を 配列 にしましょう。
配列は、dic(1 To 31, 1 To 20) の dic(日にち, 順) Variant
設定する値は、Dictionary 同様の 顧客ID と 略称 の配列


F9:日付のみの帳票 Dictionary で表示位置切替/入力(テキスト&コンボ重ね)

kEnt183_F9  kEnt183_F9A

「F6」「F7」「F8」は、入力の位置を意識していましたが、表示は左詰めが分かりやすい??
ということで、画面上で切り替え出来る様に・・・
左詰め表示での入力では、先頭の空いている部分(指定位置表示時での)から埋めていく事に・・・
処理のベースは「F7」になります。


F_M1:メイン・サブ(F_S11/F_S12) クロス集計

kEnt183_M1

表示用/入力用を分け、表示用にクロス集計を利用したもの
左側のサブフォームは表示用で、一覧はフォーム「F5」をベースに入力機能を削除したもの・・・
一覧内をクリックする事で対象日を切り替えます。
これはレコード移動時に、対象日を親に通知して・・・
右側のサブフォームは入力用で、予定表を「順」順で表示しているもので、
リンク親/子フィールドを使って、対象日を変更しようというもの・・・
入力/更新したら、親を経由して一覧の再表示を指示・・・


F_M2:メイン・サブ(F_S21/F_S22) 日付のみの帳票 Dictionary

kEnt183_M2

表示用/入力用を分け、表示用に Dictionary 処理を利用したもの
やっている事は、上記「F_M1」と同じで、
一覧表示部分は「F7」をベースに、入力に使っていたコンボを表示用に転用したもの・・・
これにより、Dictionary で持っていた値、顧客ID・略称の配列を顧客IDだけに・・・


F_M3:メイン・サブ(F_S31/F_S32) 日付のみの帳票 Dictionary + 条件付き書式

kEnt183_M3

「F_M2」に条件付き書式を設定して、見栄えを良く?したもの
2007 では、帳票フォーム表示時、代替えの背景色があって、レコードの区切りはわかりやすですが、
2000 / 2003 には無いので・・・ わかりやすいかな?ということで・・・
また、対象部分(レコード選択)を双方に反映してみる
左側一覧の略称部分をクリックすると、右側フォームは対象のレコードに移動・・・
右側入力部分のレコードを選択し直すと、左側の色も、そこに移動・・・
一覧表示部分は上記「F_S21」をベースに・・・


「F_M1」「F_M2」では、リンク親/子フィールドを使って、右側の対象日を変更してましたが、
動きにチョッと・・・っていうところがあって、リンク親/子フィールドは使わずに
対象日を親を経由して右側に通知して、レコードソースを書き換える方法に変更・・・

これだけでもコードを紹介すると、

フォーム「F_M3」 (サブフォーム間のやり取りを中継)
Public Sub SetCol(iNum As Long)
  On Error Resume Next
  Call Me.FSUB1.Form.SetCol(iNum)
End Sub

Public Sub ReShow()
  On Error Resume Next
  Call Me.FSUB1.Form.ReShow
End Sub

Public Sub SetDate(dt As Date)
  On Error Resume Next
  Me.lab99.Caption = Day(dt) & "日" ' 右側への1発目の通知は失敗に
  Call Me.FSUB2.Form.init(dt)    ' 右側フォームが立ち上がってないから
End Sub

Public Sub RecMove(iNum As Long)
  On Error Resume Next
  Call Me.FSUB2.Form.RecMove(iNum)
End Sub

Private Sub Form_Load()
  On Error Resume Next
  Call SetDate(Me.FSUB1.Form.日付) ' 失った1発目の通知を代理で
End Sub

上記コメントは、この記事用に追記したものになりますが、実際には2発呼ばれます。
で、2回とも失敗(右側が立ち上がっていない)
1発目は、自分が処理する初期の内容で「T表示日付」を書き換えた後の再クエリでの Current からの様・・・で
2発目は、呼び出し履歴のない Current からの様・・・??? (これは何だろう???)
基本で動く?ものの前で、再クエリした為の計2発???
処理的には Load で代理設定すれば良いので・・・ 現状 OK

まぁ、前のフォーム「F_M1」「F_M2」では、リンク親/子フィールドを使っていたので正常に・・・
 

フォーム「F_S31」
Dim dic As Object

Public Sub SetCol(iNum As Long)
  Me.txcolumn = iNum
End Sub

Public Sub ReShow()
  Dim rs As New ADODB.Recordset
  Dim dt As Date

  dt = Me.日付
  dic.Remove dt
  dic.Add dt, CreateObject("Scripting.Dictionary")
  rs.Source = "SELECT * FROM T予定表C WHERE 予定日 =#" & dt & "#;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    dic(dt)(rs("順").Value) = rs("顧客ID").Value
    rs.MoveNext
  Wend
  rs.Close
  Me.Recalc
End Sub

Private Function fncUserId(dt As Date, iNum As Long) As Variant
  fncUserId = Null
  If (dic(dt).Exists(iNum)) Then fncUserId = dic(dt)(iNum)
End Function

Private Function ToTxt1()
  With Me.ActiveControl
    If (Len(Nz(.Value))) Then Call Me.Parent.RecMove(Mid(.Name, 3))
  End With
  Me.txt1.SetFocus
End Function

Private Sub myRequery()
  Dim rs As New ADODB.Recordset
  Dim sSql As String
  Dim i As Long

  Call MkDate(Me.lab0.Caption)
  If (dic Is Nothing) Then Set dic = CreateObject("Scripting.Dictionary")
  dic.RemoveAll
  rs.Open "T表示日付", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    dic.Add rs(0).Value, CreateObject("Scripting.Dictionary")
    rs.MoveNext
  Wend
  rs.Close

  sSql = "SELECT Q1.日付, Q2.顧客ID, Q2.順 FROM" _
    & " T表示日付 AS Q1 INNER JOIN T予定表C AS Q2 ON Q1.日付 = Q2.予定日;"
  rs.Source = sSql
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    dic(rs("日付").Value)(rs("順").Value) = rs("顧客ID").Value
    rs.MoveNext
  Wend
  rs.Close
  Me.Requery
End Sub

Private Sub btn1_Click()
  Me.lab0.Caption = Format(DateAdd("m", -1, Me.lab0.Caption), "yyyy/mm")
  Call myRequery
End Sub

Private Sub btn2_Click()
  Me.lab0.Caption = Format(DateAdd("m", 1, Me.lab0.Caption), "yyyy/mm")
  Call myRequery
End Sub

Private Sub Form_Current()
  Me.txdate = Me.日付
  Call Me.Parent.SetDate(Me.日付)
End Sub

Private Sub Form_Load()
  Dim ctl As Control

  For Each ctl In Me.Section(acDetail).Controls
    If (ctl.ControlType = acTextBox) Then
      If (Len(ctl.Tag) > 0) Then
        With ctl.FormatConditions
          .Delete
          If (ctl.Tag = "Day") Then
            With .Add(acExpression, , "WeekDay([日付])=1")
              .BackColor = RGB(255, 210, 210)
            End With
            With .Add(acExpression, , "WeekDay([日付])=7")
              .BackColor = RGB(210, 210, 255)
            End With
          Else
            ctl.OnEnter = "=ToTxt1()"
            With .Add(acExpression, _
              , "[txdate]=[日付] AND [txcolumn]=" & Mid(ctl.Name, 3))
              .BackColor = RGB(255, 255, 160)
            End With
          End If
          With .Add(acExpression, , "[txdate]=[日付]")
            .BackColor = RGB(224, 255, 255)
          End With
        End With
      End If
    End If
  Next

  Me.lab0.Caption = Format(Date, "yyyy/mm")
  Call myRequery
End Sub

 

フォーム「F_S32」
Private Const CRSQL As String = "SELECT 顧客ID, 予定日, 順 FROM T予定表C" _
              & " WHERE 予定日=#{%1}# ORDER BY 順; "
Private Const CSQL As String = "SELECT 顧客ID, 略称 FROM T顧客" _
              & " WHERE 顧客ID Not In ({%1}) ORDER BY 略称; "

Dim myDt As Date

Public Sub init(dt As Date)
  myDt = dt
  Me.RecordSource = Replace(CRSQL, "{%1}", dt)
  Me.AllowAdditions = Me.Recordset.RecordCount < 20
End Sub

Public Sub RecMove(iNum As Long)
  On Error Resume Next
  Me.Recordset.FindFirst "順=" & iNum
End Sub

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

Private Function fncListMove(iNum As Long)
  Dim i As Long, iPos As Long

  If (Me.Dirty) Then Exit Function
  If (Me.NewRecord) Then Exit Function
  With Me.RecordsetClone
    If (.RecordCount < 2) Then Exit Function
    .Bookmark = Me.Bookmark
    iPos = .AbsolutePosition + iNum
    If ((iPos < 0) Or (iPos >= .RecordCount)) Then Exit Function
    i = .Fields("顧客ID")
    Me.btn0.SetFocus
    .Edit
    .Fields("順") = .Fields("順") + iNum
    .Update
    .Move iNum
    .Edit
    .Fields("順") = .Fields("順") - iNum
    .Update
  End With
  Me.Requery
  Me.Recordset.FindFirst "顧客ID = " & i
  Call Form_AfterUpdate
End Function

Private Sub Form_Load()
  Me.btn1.OnClick = "=fncListMove(-1)"
  Me.btn2.OnClick = "=fncListMove(1)"
  Me.cbx1.ValidationRule = "Not Is Null"
  Me.cbx1.ValidationText = "削除はレコードセレクタから・・・"
End Sub

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

Private Sub Form_AfterDelConfirm(Status As Integer)
  If (Status = acDeleteOK) Then
    With Me.RecordsetClone
      If (.RecordCount > 0) Then
        .MoveFirst
        While (Not .EOF)
          If (.Fields("順") <> .AbsolutePosition + 1) Then
            .Edit
            .Fields("順") = .AbsolutePosition + 1
            .Update
          End If
          .MoveNext
        Wend
      End If
    End With
    Call Form_AfterUpdate
  End If
End Sub

Private Sub Form_Current()
  Call Me.Parent.SetCol(Nz(Me.順))
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  If (Me.NewRecord) Then
    Me.予定日 = myDt
    Me.順 = Me.Recordset.RecordCount + 1
  End If
End Sub

Private Sub Form_AfterUpdate()
  Me.AllowAdditions = Me.Recordset.RecordCount < 20
  Call Me.Parent.ReShow
  Call Me.Parent.SetCol(Nz(Me.順))
End Sub

Private Sub cbxShow_Enter()
  Me.cbx1.SetFocus
End Sub

Private Sub cbx1_Enter()
  Dim i As Long
  Dim sS As String

  i = Nz(Me.cbxShow)
  With Me.RecordsetClone
    sS = ""
    If (.RecordCount > 0) Then
      .MoveFirst
      While (Not .EOF)
        If (.Fields("顧客ID") <> i) Then
          sS = sS & "," & .Fields("顧客ID")
        End If
        .MoveNext
      Wend
      sS = Mid(sS, 2)
    End If
    If (Len(sS) = 0) Then sS = "0"
    Me.cbx1.RowSource = Replace(CSQL, "{%1}", sS)
    Me.cbx1 = Me.cbxShow
  End With
End Sub

Private Sub cbx1_GotFocus()
  Me.cbx1.Dropdown
End Sub

Private Sub cbx1_AfterUpdate()
  Me.cbxShow = Me.cbx1
  Me.Dirty = False
  Me.btn0.SetFocus
End Sub

 
※ この右側「F_S12」「F_S22」「F_S32」フォームのコンボボックス部分は、
 コンボ&コンボを重ねる事をしています。
 これは、入力時に顧客が重複しない様に絞った表示にする必要があったためです。

【追記】10/15
今回、コンボ&コンボの重ねにして、一方を非連結として記述していましたが、
・同じものを連結して
・入力側を前面に
・入力側の背景スタイルを透明に
設定する事でも、同じような動きをさせる事が出来ます。
(過去記事「重ねる」になりますが・・・)

また、クロス集計での入力は「クロス集計表示上で入力 前編」でも取り上げてました。
そこでは、今回の様に列見出しを固定(1 ~ 20)していないのでチョッと複雑になってます。


※ 「F_S21」「F_S31」のフォームは、テキスト&入力用を転用したコンボの重ねになってますが
 テキストボックスのみにすると、チラツキが減るかもしれません???
 コンボを削除する時には、内部で持っているデータを「F7」の様に戻す必要があります。


チラツキをどうする・・・ を追い回すと、いろいろな方法が考えられるんですかね?
ま、ソコソコ動けば・・・ という事にしますか?

再クエリ後、スクロールの状態を戻す方法もわかったし・・・
やっぱり、いろいろやってみるとチョコチョコとひらめくんですかね・・・

危ないよ・・・ こういう方法があるよ・・・ 等々教えてください。


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt183_2000.zipkEnt183_2003.zipkEnt183_2007.zip
 サイズ 220,270245,288262,166
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

なお、予定表にはデータは入っていません。
また、標準モジュール「Module2」~「Module8」は、主要フォーム画面作成用記述になってます。
処理の記述は、各フォームでの記述を見てください。
関連記事

2013/10/14

Category: サンプルかな

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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