FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

コンボ vs リスト vs メイン/サブ 


コンボボックスで候補を選択する(1件選ぶ)
候補自体が 20 件とかなら選択する操作は楽なのかも・・・・
件数が多くなっても、直に入力すれば前方一致で候補に飛んでくれます。

でも、部分的にしか覚えていない・・・・とか
表示する件数が かなりある・・・・とか

そこで登場するのが
・リストボックス表示で絞り込み・・・・
・メイン/サブの帳票表示で絞り込み・・・・

また、よくリストボックスの表示で、あるフィールド部分を右詰にしたい・・・
(文字列の部分と、数値部分の表示配置を分けたい・・・・)
こういう時には、リストボックス表示に似せた帳票サブフォームで実現したら・・・・・・・
ってなことを言う時があります。

そこで、今回はそれぞれの表示/操作を比較しながら同じような事をしてみたいと・・・
(無理な部分もありますが)

なお、
リストボックス、
メイン/サブフォーム構成では、各フィールドでの曖昧検索を組み込んでみたいと思います。
(コンボボックスでは表示している部分での前方一致だけ・・・・と言っても機能そのまま)

コンボボックスでの画面は、
kEnt124_Comb  kEnt124_Comb2

リストボックス、メイン/サブフォームでの画面では、操作も近いようにしてみる
kEnt124_List  kEnt124_Msub
(この画面では、入力するたびに曖昧検索して絞り込みできやすくするように)
 
テーブル「T商品」を用意しました。
フィールド名
 商品ID 数値(長整数)
 商品CD テキスト
 商品名 テキスト
 単価 通貨
 作成日 日付/時刻
 備考 テキスト

「商品ID」が主キーで、他のフィールドに重複ありのインデックスを設定してみました。
(曖昧検索を主に確認するので、インデックスを設定しても意味無いのかも)

「商品ID」はいらなくて、「商品CD」を主キーで・・・・っていうのもあるかもしれません。
・「商品CD」は今後見直しによって変更があるかもしれない
  であれば、変更の対象は1テーブルにとどめておきたいかなぁ・・・・・
・他テーブルと結びつける際、テキスト型より数値型の方が処理上速いんではないかなぁ・・・・・・
・マスタ側になる主キーにはオートナンバは使いたくないかなぁ・・・・・
(私の中での雰囲気です)

このテーブルには、1000 件のデータを入れておきました。
(標準モジュール「Module2」内の関数実行で、指定件数分のダミーデータを作成できるように)
また、テーブル「T商品B」も同じ構成で、データ3件だけ(基本的なフォーム動作確認用として)

用意したフォームは以下
参照
テーブル
フォーム内容
T商品B F0_LB リストボックスでの絞り込み
 F0_M 帳票フォームでの絞り込み(メイン側)
 F0_S 帳票フォームでの絞り込み(サブ側)
T商品 F1_CHK コンボボックス+他フォームで絞り込み
 F1_LB リストボックスでの絞り込み
 F1_M 帳票フォームでの絞り込み(メイン側)
 F1_S 帳票フォームでの絞り込み(サブ側)
 F2_CHK コンボボックス+他フォームで絞り込み
 F3_CHK コンボボックス+他フォームで絞り込み
 F3_LB リストボックスでの絞り込み
 F3_M 帳票フォームでの絞り込み(メイン側)
 F3_S 帳票フォームでの絞り込み(サブ側)


F0 系のフォームは、単独で起動確認できるもの
F1 系のフォームは、コンボボックスの連結列を「商品ID」として、
・コンボボックスの入力は「商品CD」
・必要に応じて他フォームを起動
・他フォームからはコンボボックスに対して、選択された「商品ID」を設定
 (F0 系に起動元フォームとの連携組み込み)
F2 系のフォームは、コンボボックスの連結列を「商品CD」として、
・コンボボックスの入力は「商品CD」
・必要に応じて他フォームを起動
・他フォームからはコンボボックスに対して、選択された「商品CD」を設定
F3 系のフォームは、コンボボックスの連結列を「商品ID」として、
・コンボボックスの入力は「商品CD」
・必要に応じて他フォームを起動
・他フォームからはコンボボックスに対して、選択された「商品ID」を設定
 (この選択する時に F1 系での方法を若干変更)

単独起動確認


リストボックスや帳票フォーム表示で1件選択する操作を、
その行がダブルクリックされた時に選択されたものとする・・・と決めました。

リストボックス動作「F0_LB」
 
kEnt124_List  kEnt124_List1
フォームをデザインから作成していきます。
単票/非連結として作成するので、レコードセレクタ等表示しない様にしておきます。
どのフィールドに対して曖昧検索するか、オプショングループ「op1」で選択できるようにします。
「op1」は、値 1 ~ 6 を取るようにします。
オプショングループが変更された場合、文字の色を「赤」に変更したいかな・・・・・
ってんで、フォーム依存しない共通の処理なので、標準モジュール「Module1」に以下を記述しておきます。
Public Sub OpgMojiColor(ctlOpg As OptionGroup)
  Dim ctl As Control

  For Each ctl In ctlOpg.Controls
    With ctl
      Select Case .ControlType
        Case acCheckBox, acOptionButton
          If (.OptionValue = ctlOpg.Value) Then
            .Controls(0).ForeColor = RGB(255, 0, 0)
          Else
            .Controls(0).ForeColor = RGB(0, 0, 0)
          End If
        Case acToggleButton
          If (.OptionValue = ctlOpg.Value) Then
            .ForeColor = RGB(255, 0, 0)
          Else
            .ForeColor = RGB(0, 0, 0)
          End If
      End Select
    End With
  Next
End Sub

これは、チェックボックス/オプションボタンの構成の場合は、くっついているラベルの文字色を・・・・
なので、ラベルがくっついていないとエラーになります。

検索文字を入力する為のテキストボックス「txt1」を配置します。
その下にリストボックス「lst1」を配置します。
リストボックス「lst1」に表示する際、絞り込みをしていくわけですが、
値集合ソースを直接書き換える方法もありますが、今回は値集合ソースは固定してやってみます。
値集合ソースは
SELECT 商品ID, 商品CD, 商品名, 単価, 作成日, 備考
FROM T商品B
WHERE
IIF(IsNull([tx1]),True,商品ID Like '*' & [tx1] & '*') AND
IIF(IsNull([tx2]),True,商品CD Like '*' & [tx2] & '*') AND
IIF(IsNull([tx3]),True,商品名 Like '*' & [tx3] & '*') AND
IIF(IsNull([tx4]),True,単価 Like '*' & [tx4] & '*') AND
IIF(IsNull([tx5]),True,作成日 Like '*' & [tx5] & '*') AND
IIF(IsNull([tx6]),True,備考 Like '*' & [tx6] & '*')
ORDER BY 商品ID;
としておきます。
つまり、オプショングループの値と連携した、非表示のテキストボックス「tx1」~「tx6」を配置します。
オプショングループ「op1」が 1 なら、「tx1」に検索文字を設定しますよ・・・・
この時、同じフォーム上の為に名前が解決するのか、
[Forms]![F0_LB]![tx1] と記述しなくても良いようです。
連結列は 1 としておきます。列幅は相応に

VBAで記述したのは以下
Private Sub Form_Load()
  Me.op1 = 2
  Call op1_Click
End Sub

Private Sub op1_Click()
  Dim i As Long

  Call OpgMojiColor(Me.op1)

  For i = 1 To 6
    Me("tx" & i) = Null
  Next
  On Error Resume Next
  Me.txt1.SetFocus
  Me.txt1.Text = ""
End Sub

Private Sub txt1_Change()
  Me("tx" & Me.op1) = Me.txt1.Text
  Me.lst1 = Null
  Me.lst1.Requery
End Sub

Private Sub lst1_DblClick(Cancel As Integer)
  MsgBox "ダブルクリック: " & Me.lst1
End Sub

 
※※ さて、ここでですが
オプショングループがクリックされた時、対象のフィールドのみ初期設定する為に
  Me.txt1.SetFocus
  Me.txt1.Text = "" ' ★
として txt1_Change を動かしているわけですが、★ の処理で戻ってきた後でなぜかエラーが発生します。
kEnt124_err
フォームが表示される前に1回通るのですが、その時にはエラーは発生せず。
フォーム表示後、オプショングループをクリックすると、その都度エラーとなるのです。
処理としてはチャンと動いているので、On Error Resume Next でエラーを無視するようにしました。
処理の仕方が悪い・・・・・等、ご指摘いただければと思います。

なお、オプショングループで切り換えた検索対象フィールドの初期表示は、Null 以外を表示するように。

メイン/サブ動作「F0_M」「F0_S」
 
kEnt124_Msub  kEnt124_Msub1
フォーム「F0_LB」の表示に似せるために、そのフォームを「F0_M」名でコピーします。
リストボックス「lst1」を削除し、サブフォームコントロール「FSUB」を同じ大きさで作成します。
帳票フォームとなるサブフォームを絞り込む方法として、フォームの Filter を使うようにしました。
(サブフォームのレコードソースを書き換える方法もあるかと思いますが)
検索文字列を Filter に設定する際、前後の文字を op1_Click 時に作っておくように・・・・
それ用に、非表示で配置していたテキストボックス「tx1」「tx2」を使いましょうか・・・・
(VBA内の変数に作っておいても良いかも)
「tx3」~「tx6」を削除します。
サブ用の帳票フォームが出来上がったら、それを「ソースオブジェクト」に設定して作成は完了になります。

記述したVBAは以下
Private Sub Form_Load()
  Me.op1 = 2
  Call op1_Click
End Sub

Private Sub op1_Click()
  Call OpgMojiColor(Me.op1)

  Select Case Me.op1
    Case 1: Me.tx1 = "商品ID Like '*": Me.tx2 = "*'"
    Case 2: Me.tx1 = "商品CD Like '*": Me.tx2 = "*'"
    Case 3: Me.tx1 = "商品名 Like '*": Me.tx2 = "*'"
    Case 4: Me.tx1 = "単価 Like '*": Me.tx2 = "*'"
    Case 5: Me.tx1 = "作成日 Like '*": Me.tx2 = "*'"
    Case 6: Me.tx1 = "備考 Like '*": Me.tx2 = "*'"
  End Select
  On Error Resume Next
  Me.txt1.SetFocus
  Me.txt1.Text = ""
End Sub

Private Sub txt1_Change()
  With Me.FSUB.Form
    Call .init
    .Filter = Me.tx1 & Me.txt1.Text & Me.tx2
    .FilterOn = True
  End With
End Sub

 
帳票フォーム「F0_S」は、テーブル「T商品B」を元に、フォームウイザードで表形式作成。
レコードソースを変更して「商品ID」昇順を指定しておきます。
レコードセレクタ/移動ボタンを表示しないようにします。
誤ってレコード等をいじれない様に、追加/削除/更新の許可を「いいえ」にしておきます。
フォーム「F0_LB」のリストボックス表示の列幅に合わせて配置し直します。

ここからチョッと細工を・・・・
ヘッダ部に非表示のテキストボックス「txt1」を配置します。
詳細にある全テキストボックスの「タブストップ」を「いいえ」に変更します。
詳細にあるテキストボックス全てを覆うようにコマンドボタン「btn1」を配置します。
「透明」を「はい」として、タブ移動順を一番先頭に変更します。
リストボックス内をクリックした時に反転する処理は、全テキストボックスで条件付き書式を使用します。
この時の判定に、ヘッダ部に配置した「txt1」に、
コマンドボタン「btn1」がクリックされたところの「商品ID」を格納し、
「txt1」と表示行の「商品ID」が一致するかで・・・・
コマンドボタン「btn1」を配置したことで、下側のテキストボックスをクリックし辛くなったので
VBAで条件付き書式を設定するように。(デザイン時の操作でクリックしにくい)
また、リストボックスの選択を解除するマネとして、「txt1」をクリアする関数を Public にし、
メインで Filter をかける際に呼んでもらうように・・・・

記述したVBAは以下
Public Sub init()
  Me.txt1 = 0
End Sub

Private Function initChk() As Boolean
  initChk = Me.txt1 <> 0
End Function

Private Sub Form_Load()
  Dim ctl As Control

  For Each ctl In Me.Section(acDetail).Controls
    If (ctl.ControlType = acTextBox) Then
      ctl.FormatConditions.Delete
      With ctl.FormatConditions.Add(acExpression, , "[txt1]=[商品ID]")
        .BackColor = RGB(0, 0, 0)
        .ForeColor = RGB(255, 255, 255)
      End With
    End If
  Next
  Call init
End Sub

Private Sub Form_Current()
  If (initChk) Then Me.txt1 = Me.商品ID
End Sub

Private Sub btn1_Click()
  Me.txt1 = Me.商品ID
  Me.Recalc
End Sub

Private Sub btn1_DblClick(Cancel As Integer)
  MsgBox "ダブルクリック: " & Me.商品ID
End Sub

 
これで、リストボックス風の動きになると思います。
表示しているデータは違いますが、2000 / 2003 で表示してみた感じは以下の様になります。
kEnt124_Msub2000  kEnt124_Msub2003
動きとして、
・レコードをクリックすると反転表示
その後、「↑」「↓」キーや「Page Up」「Page Down」でも移動できるかと思います。
また、リストボックスでの動きとは異なり、「tab」キーでも移動できます。
ただ、チョッとチラつきますね(大目にみるという事で)

なお、2000 だけ、「Page Up」「Page Down」で動きませんでした。

レコードを選択した・・・・・今回ダブルクリックを用いましたが、どこかに配置したボタンでも良いと思います。


連携確認


連結列「商品ID」その1
 
コンボボックス動作「F1_CHK」
 
kEnt124_Comb  kEnt124_Comb2
コンボボックスの動きだけを確認するのではなく、コンボボックスのダブルクリックで、
リストボックス・メイン/サブで選択した値を受け取れるようにしてみました。

最終的には非連結のフォームになるのですが、
テーブル「T商品」を元にフォームウィザードで単票として作成します。
「レコードソース」を空白にします。
どれをコンボボックスに変更するかですが、「商品CD」を表示したいのかなぁ・・・・ということで、
テキストボックス「商品CD」のコントロールソースを空白にし、コンボボックスに変更します。
値集合ソースを
SELECT 商品ID, 商品CD, 商品名, 単価, 作成日, 備考 FROM T商品 ORDER BY 商品CD;
として、「商品ID」以外を表示するようにします。(「商品CD」で昇順に)
連結列は 1 とします。列幅はリストボックスの設定値を参考にして・・・
他のテキストボックスの「コントロールソース」を変更し、
常にコンボボックス「商品CD」をみるように変更します。
「商品ID」なら、=[商品CD].[Column](0) と。

コンボボックス選択でじれったくなった場合、
・リストボックスのフォームから値をもらうのか
・メイン/サブの帳票表示フォームから値をもらうのか
選択するオプショングループ「op1」を配置します。
(コンボボックスでも、直に入力すれば先頭一致でそこんところに飛んでくれますね)

設定値として何をもらいたいのか tag に設定して、選択したフォームを起動します。
起動操作は、コンボボックス「商品CD」をダブルクリックした時・・・とします。
コンボボックスの連結列を 1 としたので、「商品ID」が欲しい tag = 0 を設定します。
(tag の値の取り決めとして、リストボックス(コンボボックス)に設定した Column(x) の x とする)

記述したのは以下
Private Sub Form_Load()
  Call op1_Click
End Sub

Private Sub op1_Click()
  Call OpgMojiColor(Me.op1)
End Sub

Private Sub 商品CD_DblClick(Cancel As Integer)
  Dim sFN As String

  Select Case Me.op1
    Case 1: sFN = "F1_LB"
    Case 2: sFN = "F1_M"
    Case Else
      Exit Sub
  End Select
  Me.商品CD.Tag = 0
  DoCmd.OpenForm sFN
  Cancel = True
End Sub

 

リストボックス動作「F1_LB」
 
フォーム「F0_LB」を「F1_LB」名でコピーします。
リストボックス「lst1」の対象テーブル名を「T商品B」から「T商品」に、「商品CD」の昇順に変更します。
値を戻す先を覚えておいて、覚えていたら設定してフォームを閉じます。
(値を戻す時、リストボックス表示の何列目を設定するかは設定先の Tag が持っている)

VBAで以下の黄色部分を追加/修正します。
Dim ctlRet As Control

Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  Set ctlRet = Screen.ActiveControl
End Sub


Private Sub Form_Load()
  Me.op1 = 2
  Call op1_Click
End Sub

Private Sub op1_Click()
  Dim i As Long

  Call OpgMojiColor(Me.op1)

  For i = 1 To 6
    Me("tx" & i) = Null
  Next
  On Error Resume Next
  Me.txt1.SetFocus
  Me.txt1.Text = ""
End Sub

Private Sub txt1_Change()
  Me("tx" & Me.op1) = Me.txt1.Text
  Me.lst1 = Null
  Me.lst1.Requery
End Sub

Private Sub lst1_DblClick(Cancel As Integer)
  Me.Visible = False
  If (Not ctlRet Is Nothing) Then ctlRet = Me.lst1.Column(ctlRet.Tag)
  DoCmd.Close acForm, Me.Name, acSaveNo

End Sub

Private Sub Form_Close()
  Set ctlRet = Nothing
End Sub


 

メイン/サブ動作「F1_M」「F1_S」
 
フォーム「F0_M」を「F1_M」名でコピーします。
フォーム「F1_LB」と同様に、起動元とのやり取り部分を追加します。
ただ、「F1_LB」と異なるのは、ダブルクリックされるのはサブフォーム側であること・・・・
サブフォームに配置したコントロールのイベントを直接取得する方法もありますが、
今回は、サブフォーム側でダブルクリックを検知したら関数を呼んでもらうように・・・
その時、欲しいフィールド値をサブフォームから取得できるように・・・・
メイン側に LastCall 関数を用意し、
サブ側にリストボックス風の書き方になるように Column 関数を用意しました。
サブフォームコントロール「FSUB」のソースオブジェクトを変更したサブに変更します。

フォーム「F1_M」に記述したのは以下(「F0_M」に追加/変更した部分を黄色で)
Dim ctlRet As Control

Public Sub LastCall()
  Me.Visible = False
  If (Not ctlRet Is Nothing) Then ctlRet = Me.FSUB.Form.Column(ctlRet.Tag)
  DoCmd.Close acForm, Me.Name, acSaveNo
End Sub

Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  Set ctlRet = Screen.ActiveControl
End Sub


Private Sub Form_Load()
  Me.op1 = 2
  Call op1_Click
End Sub

Private Sub op1_Click()
  Call OpgMojiColor(Me.op1)

  Select Case Me.op1
    Case 1: Me.tx1 = "商品ID Like '*": Me.tx2 = "*'"
    Case 2: Me.tx1 = "商品CD Like '*": Me.tx2 = "*'"
    Case 3: Me.tx1 = "商品名 Like '*": Me.tx2 = "*'"
    Case 4: Me.tx1 = "単価 Like '*": Me.tx2 = "*'"
    Case 5: Me.tx1 = "作成日 Like '*": Me.tx2 = "*'"
    Case 6: Me.tx1 = "備考 Like '*": Me.tx2 = "*'"
  End Select
  On Error Resume Next
  Me.txt1.SetFocus
  Me.txt1.Text = ""
End Sub

Private Sub txt1_Change()
  With Me.FSUB.Form
    Call .init
    .Filter = Me.tx1 & Me.txt1.Text & Me.tx2
    .FilterOn = True
  End With
End Sub

Private Sub Form_Close()
  Set ctlRet = Nothing
End Sub


 
フォーム「F0_S」を「F1_S」名でコピーします。
レコードソースの対象テーブル名を「T商品B」から「T商品」に、「商品CD」の昇順に変更します。
また、コマンドボタン「btn1」がダブルクリックされた時点でメインの関数を呼び出すので、
単独起動後ダブルクリックされると必然とエラーが発生するので、
単独起動されない様に Form_Open で起動可否判別を追加・・・
(過去記事でも、いろいろと判別方法を変えながら書いてました。で、今回の判別はこれで・・・)

フォーム「F1_S」に記述したのは以下(「F0_S」に追加/変更した部分を黄色で)
Public Function Column(iNum As Long) As Variant
  Select Case iNum
    Case 0: Column = Me.商品ID.Value
    Case 1: Column = Me.商品CD.Value
    Case 2: Column = Me.商品名.Value
    Case 3: Column = Me.単価.Value
    Case 4: Column = Me.作成日.Value
    Case 5: Column = Me.備考.Value
    Case Else
      Column = Null
  End Select
End Function


Public Sub init()
  Me.txt1 = 0
End Sub

Private Function initChk() As Boolean
  initChk = Me.txt1 <> 0
End Function

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


Private Sub Form_Load()
  Dim ctl As Control

  For Each ctl In Me.Section(acDetail).Controls
    If (ctl.ControlType = acTextBox) Then
      ctl.FormatConditions.Delete
      With ctl.FormatConditions.Add(acExpression, , "[txt1]=[商品ID]")
        .BackColor = RGB(0, 0, 0)
        .ForeColor = RGB(255, 255, 255)
      End With
    End If
  Next
  Call init
End Sub

Private Sub Form_Current()
  If (initChk) Then Me.txt1 = Me.商品ID
End Sub

Private Sub btn1_Click()
  Me.txt1 = Me.商品ID
  Me.Recalc
End Sub

Private Sub btn1_DblClick(Cancel As Integer)
  Call Me.Parent.LastCall
End Sub

 

連結列「商品CD」
 
コンボボックス動作「F2_CHK」
 
フォーム「F1_CHK」を「F2_CHK」名でコピーします。
サンプルテーブル「T商品」の「商品CD」に重複がなかったようなので、
他フォームから設定される値を「商品CD」としてみます。
コンボボックスの「連結列」を 2 に変更し、VBA記述以下を変更します。
(戻り値に「商品CD」が欲しいことを、tag に設定するだけ)
Private Sub Form_Load()
  Call op1_Click
End Sub

Private Sub op1_Click()
  Call OpgMojiColor(Me.op1)
End Sub

Private Sub 商品CD_DblClick(Cancel As Integer)
  Dim sFN As String

  Select Case Me.op1
    Case 1: sFN = "F1_LB"
    Case 2: sFN = "F1_M"
    Case Else
      Exit Sub
  End Select
  Me.商品CD.Tag = 1
  DoCmd.OpenForm sFN
  Cancel = True
End Sub

 


連結列「商品ID」その2
 
ここでは、F0 / F1 系で曖昧検索する時には常に前後が曖昧で検索されていました。
検索する文字を入力するところで、自分でどの部分を曖昧にするか指定したい・・・・
頭が「S」で最後が「7」だった・・・・「 S*7 」これを直接指定したい・・・ということで

コンボボックス動作「F3_CHK」
 
フォーム「F1_CHK」を「F3_CHK」名でコピーします。
起動するフォーム名を変更するだけです
Private Sub Form_Load()
  Call op1_Click
End Sub

Private Sub op1_Click()
  Call OpgMojiColor(Me.op1)
End Sub

Private Sub 商品CD_DblClick(Cancel As Integer)
  Dim sFN As String

  Select Case Me.op1
    Case 1: sFN = "F3_LB"
    Case 2: sFN = "F3_M"
    Case Else
      Exit Sub
  End Select
  Me.商品CD.Tag = 0
  DoCmd.OpenForm sFN
  Cancel = True
End Sub

 
リストボックス動作「F3_LB」
 
フォーム「F1_LB」を「F3_LB」名でコピーします。
リストボックス「lst1」の値集合ソースを変更します。
SELECT 商品ID, 商品CD, 商品名, 単価, 作成日, 備考
FROM T商品
WHERE
IIF(IsNull([tx1]),True,商品ID Like [tx1]) AND
IIF(IsNull([tx2]),True,商品CD Like [tx2]) AND
IIF(IsNull([tx3]),True,商品名 Like [tx3]) AND
IIF(IsNull([tx4]),True,単価 Like [tx4]) AND
IIF(IsNull([tx5]),True,作成日 Like [tx5]) AND
IIF(IsNull([tx6]),True,備考 Like [tx6])
ORDER BY 商品CD;

VBAでは、以下の黄色部分を変更します。
Dim ctlRet As Control

Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  Set ctlRet = Screen.ActiveControl
End Sub

Private Sub Form_Load()
  Me.op1 = 2
  Call op1_Click
End Sub

Private Sub op1_Click()
  Dim i As Long

  Call OpgMojiColor(Me.op1)

  For i = 1 To 6
    Me("tx" & i) = Null
  Next
  On Error Resume Next
  Me.txt1.SetFocus
  Me.txt1.Text = "**"
  Me.txt1.SelStart = 1

End Sub

Private Sub txt1_Change()
  Me("tx" & Me.op1) = Me.txt1.Text
  Me.lst1 = Null
  Me.lst1.Requery
End Sub

Private Sub lst1_DblClick(Cancel As Integer)
  Me.Visible = False
  If (Not ctlRet Is Nothing) Then ctlRet = Me.lst1.Column(ctlRet.Tag)
  DoCmd.Close acForm, Me.Name, acSaveNo
End Sub

Private Sub Form_Close()
  Set ctlRet = Nothing
End Sub

 
メイン/サブ動作「F3_M」「F3_S」
 
フォーム「F1_S」を「F3_S」名でコピーします。
(変更箇所はないので、そのままでも良かったんですが・・・・)

フォーム「F1_M」を「F3_M」名でコピーします。
サブフォームコントロール「FSUB」のソースオブジェクトを「F3_S」に変更します。

以下黄色部分を変更します。
Dim ctlRet As Control

Public Sub LastCall()
  Me.Visible = False
  If (Not ctlRet Is Nothing) Then ctlRet = Me.FSUB.Form.Column(ctlRet.Tag)
  DoCmd.Close acForm, Me.Name, acSaveNo
End Sub

Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  Set ctlRet = Screen.ActiveControl
End Sub

Private Sub Form_Load()
  Me.op1 = 2
  Call op1_Click
End Sub

Private Sub op1_Click()
  Call OpgMojiColor(Me.op1)

  Select Case Me.op1
    Case 1: Me.tx1 = "商品ID Like '": Me.tx2 = "'"
    Case 2: Me.tx1 = "商品CD Like '": Me.tx2 = "'"
    Case 3: Me.tx1 = "商品名 Like '": Me.tx2 = "'"
    Case 4: Me.tx1 = "単価 Like '": Me.tx2 = "'"
    Case 5: Me.tx1 = "作成日 Like '": Me.tx2 = "'"
    Case 6: Me.tx1 = "備考 Like '": Me.tx2 = "'"

  End Select
  On Error Resume Next
  Me.txt1.SetFocus
  Me.txt1.Text = "**"
  Me.txt1.SelStart = 1

End Sub

Private Sub txt1_Change()
  With Me.FSUB.Form
    Call .init
    .Filter = Me.tx1 & Me.txt1.Text & Me.tx2
    .FilterOn = True
  End With
End Sub

Private Sub Form_Close()
  Set ctlRet = Nothing
End Sub

 

サンプルデータ作成


標準モジュール「Module2」にある関数 MakeTableData を実行します
Public Sub MakeTableData()
  If (MakeMain(1000)) Then ' 作成レコード数が引数
    MsgBox "データ作成成功", vbInformation
  Else
    MsgBox "データ作成失敗" & vbCrLf & MakeMain(0), vbCritical
  End If
End Sub

Private Function MakeMain(iNum As Long) As Variant
  Static sMsg As String
  Dim rs As New ADODB.Recordset
  Dim iErrCnt As Long
  Dim i As Long
  Const iErrMax As Long = 3

  If (iNum < 1) Then
    MakeMain = sMsg
    Exit Function
  End If
  sMsg = ""

  Randomize

  iErrCnt = 0
  Do While (iErrCnt < iErrMax)
    On Error GoTo ERR_HND
    CurrentProject.Connection.Execute "DELETE * FROM T商品;"
    rs.Open "T商品", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
    For i = 1 To iNum
      rs.AddNew
      rs("商品ID") = MakeRec1
      rs("商品CD") = MakeRec2
      rs("商品名") = MakeRec3
      rs("単価") = MakeRec4
      rs("作成日") = MakeRec5
      rs("備考") = MakeRec6
      rs.Update
    Next
    rs.Close
    Exit Do

ERR_HND:
    If (Err = -2147217887) Then
      Debug.Print "重複 商品ID = " & rs("商品ID") ' サンプルファイルには記述ないかも
      rs("商品ID") = rs("商品ID") + 1
      Resume
    End If
    sMsg = Err.Number & " : " & Err.Description
    iErrCnt = iErrCnt + 1
    Resume ERR_NEXT
ERR_NEXT:
    On Error Resume Next
    If (rs.State = adStateOpen) Then
      If (rs.EditMode = adEditAdd) Then rs.CancelUpdate
      rs.Close
    End If
  Loop
  MakeMain = iErrCnt < iErrMax
End Function

Private Function MakeRec1() As Long
  MakeRec1 = Int(Rnd() * 99999) + 1
End Function

Private Function MojiOne() As String
  MojiOne = Chr(Asc("A") + Int(Rnd() * (Asc("Z") - Asc("A") + 1)))
End Function

Private Function MakeRec2() As String
  MakeRec2 = MojiOne & MojiOne & Format(Int(Rnd() * 99999) + 1, "00000")
End Function

Private Function MakeRec3() As String
  Dim sS As String
  Dim iCnt As Long
  Dim i As Long

  iCnt = Int(Rnd() * 11) + 5
  sS = ""
  For i = 1 To iCnt
    sS = sS & MojiOne
  Next
  MakeRec3 = sS
End Function

Private Function MakeRec4() As Currency
  MakeRec4 = (Int(Rnd() * 999) + 1) * 10
End Function

Private Function MakeRec5() As Date
  MakeRec5 = DateAdd("d", -Int(Rnd() * 3650), Date)
End Function

Private Function MakeRec6() As Variant
  Dim vAry As Variant
  Dim sS As String
  Dim iCnt As Long
  Dim i As Long

  MakeRec6 = Null
  If (Int(Rnd() + 0.2) = 0) Then Exit Function
  vAry = Array("北海道", "青森", "岩手", "秋田", "宮城" _
        , "山形", "福島", "宮崎", "富山", "東京", "京都")
  iCnt = Int(Rnd() * 3) + 1
  sS = ""
  For i = 1 To iCnt
    sS = sS & " " & vAry(Int(Rnd() * (UBound(vAry) + 1)))
  Next
  MakeRec6 = Trim(sS)
End Function

エラー時の処理をチョッと盛り込んでみましたが・・・・・
(でも、あまりこういう書き方はしないのかなっっと。 動きました、というレベルでしょうか・・・)

なお、記事によっては同じことをする時でも書き方を変えてみたりしていますので、
1つの記事を読んで、書き方はこう、という判断はしないでください。
参考にする等々、すべて自己責任でお願いします。


余談

テーブル「T商品」にテストデータを作った後、連続する「商品ID」があるか ??・・・・
これ、クエリを作って確認していたのですが、作り方によっては表示までの時間が違いますね・・・・

遅かったのは、
SELECT * FROM T商品 AS A WHERE
EXISTS (SELECT 1 FROM T商品 AS B WHERE (B.商品ID = A.商品ID+1) OR (B.商品ID = A.商品ID-1))
ORDER BY 商品ID;

そこそこ速かったのは
SELECT * FROM T商品 AS A WHERE
EXISTS (SELECT 1 FROM T商品 AS B WHERE B.商品ID = A.商品ID+1) OR
EXISTS (SELECT 1 FROM T商品 AS B WHERE B.商品ID = A.商品ID-1)
ORDER BY 商品ID;

今回の収穫でした。


もっといい方法知ってるよ・・・・教えてください。

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt124_2000.zipkEnt124_2003.zipkEnt124_2007.zip
 サイズ 147,438156,699160,285
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2012/04/09

Category: サンプルかな

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

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

top △


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