FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

リストボックス操作の模索 


リストボックスは、コンボボックスと異なり
「複数選択することも出来る」
ものになりますが、操作する上で便利なんだろうか・・・・

マウスでクリックしながら「Shift」「Ctrl」キーを押したり・・・
便利は便利ですけど・・・・

という事で(脈絡ありませんが)、

テーブル「T1」
an: オートナンバー
src: テキスト型
メモ: テキスト型

を用意し、
「src」「メモ」をリストに表示し、選択したレコードの「メモ」に値を設定する
これをやってみたいと思います。

1)リストボックスを2つ並べて、クリックしたら他方に移す
kEnt122_11  kEnt122_12
それなりに表示する領域が必要になりますが、
横にリストボックスを並べて表示し、右側に表示された「メモ」に対して設定
この時、
1-1)ワークテーブルを使用する(フォーム:F1)
1-2)Dictionary を使用する(フォーム:F3)

2)複数選択を使ってみる
kEnt122_21  kEnt122_22
複数選択した「メモ」に対して設定(フォーム:F2)

私は並べた方が、処理対象はこれ・・・・イメージしやすいかな
選択した後、何をするかによるとは思います。


今回やってみて確認できたこと

CurrentProject.Connection.Execute "SQL文"
の記述だけでは ActiveX の参照設定は、いらないみたい
 

1)リストボックスを2つ並べて、クリックしたら他方に移す


横にリストボックスを並べて表示し、右側に表示された「メモ」に対して設定
1-1)ワークテーブルを使用する(フォーム:F1)
kEnt122_11  kEnt122_12
テンポラリテーブル「T1Tmp」を用意します。フィールドは、「an」数値型(長整数)のみ
左側のリストボックス「lst1」を作成します。
値集合ソースは
SELECT T1.an, T1.src, T1.[メモ] FROM T1 LEFT JOIN T1Tmp ON T1.an=T1Tmp.an
WHERE (((T1Tmp.an) Is Null)) ORDER BY T1.src;
連結列:1
列数:3
列幅:0cm;3cm;4.5cm
複数選択:しない

としておきます。
また、「src」追加用にテキストボックス「txt1」コマンドボタン「btn1」を配置します。

右側リストボックス「lst2」は「lst1」をコピーし、値集合ソースを変更します。
SELECT T1.an, T1.src, T1.[メモ] FROM T1 INNER JOIN T1Tmp ON T1.an=T1Tmp.an
ORDER BY T1.src;
「メモ」設定用にテキストボックス「txt2」コマンドボタン「btn2」を配置します。

以下VBAを記述します。
Private Sub init1()
  Me.lst1 = Null
  Me.lst1.Requery
End Sub

Private Sub init()
  Call init1
  Me.lst2 = Null
  Me.lst2.Requery
End Sub

Private Sub initd()
  CurrentProject.Connection.Execute "DELETE * FROM T1Tmp;"
  Call init
End Sub

Private Function Gikkon(iNum As Long)
  Dim sSql As String

  sSql = ""
  Select Case iNum
    Case 1: sSql = "INSERT INTO T1Tmp(an) VALUES(" & Me.lst1 & ");"
    Case 2: sSql = "DELETE * FROM T1Tmp WHERE an = " & Me.lst2 & ";"
  End Select
  If (Len(sSql) > 0) Then CurrentProject.Connection.Execute sSql
  Call init
End Function

Private Sub Form_Load()
  Call initd
  Me.lst1.OnClick = "=Gikkon(1)"
  Me.lst2.OnClick = "=Gikkon(2)"
End Sub

Private Sub btn1_Click()
  Dim sS As String

  sS = Trim(Nz(Me.txt1))
  If (Len(sS) > 0) Then
    CurrentProject.Connection.Execute "INSERT INTO T1(src) VALUES('" & sS & "');"
    Call init1
  End If
  Me.txt1 = Null
End Sub

Private Sub btn2_Click()
  Dim v As Variant
  Dim sS As String
  Dim sSql As String

  On Error Resume Next
  If (Me.lst2.ListCount <= Abs(Me.lst2.ColumnHeads)) Then Exit Sub
  sS = Trim(Nz(Me.txt2))
  If (Len(sS) = 0) Then
    sS = "Null"
  Else
    If (Left(sS, 1) = "=") Then
      v = Eval(Mid(sS, 2))
      If (IsEmpty(v)) Then Exit Sub
      sS = CStr(v)
    End If
    sS = "'" & Replace(sS, "'", "’") & "'"
  End If
  sSql = "UPDATE T1 SET メモ = " & sS & " WHERE an IN (SELECT an FROM T1Tmp);"
  CurrentProject.Connection.Execute sSql
  Call initd
End Sub

基本的な動作としては、左側をクリックされたらテンポラリテーブルの「an」に対象の「an」を追加し、
右側をクリックされたらテンポラリテーブルの「an」から対象を削除するものになります。
なぜ「an」なのか・・・・は、レコードを特定できるものだから・・・
その「an」を、リストボックスの連結列に指定して、表示しなくて良いから列幅は 0cm に。
LEFT JOIN なり INNER JOIN なりで結び付けを考えるだけなので、結構楽と言えば楽。
いろいろなサイトで説明されていますね。私も忘れないうちにと言う事で・・・

「メモ」を設定する時に遊びを入れています。
設定する文字列の先頭が "=" であったら、Eval() を介した結果で設定するようにしてみました。
つまり、"=Date()" であったのなら、Eval("Date()") の結果を設定するように・・・・
また、"'" の文字が入力中にあったら、全角の "’" に変更するように・・・

設定対象がテーブルにあるという事で、いろいろクエリ(SQL)で加工できて便利だなぁ・・・と思います

注意する点が1つあって、リストボックスに表示しているレコード数ですが、
列見出しが「はい」となっている時には、ListCount に1件としてカウントされている・・・・
なので、レコードを表示しているのか、どうか
  If (Me.lst2.ListCount <= Abs(Me.lst2.ColumnHeads)) Then Exit Sub
という判別をしてみました。


1-2)Dictionary を使用する(フォーム:F3)
kEnt122_31  kEnt122_32
テンポラリテーブルを使用しないで、テンポラリテーブルの役目を Dictionary で代用しましょう・・・

Dictionary に追加/削除・・・等々の関数を必要に応じて標準モジュールに用意しておきます。
今回用意したのは以下(標準モジュール「Module1」)
Private dic As Object


Public Function DicInit() As Boolean
  If (dic Is Nothing) Then Set dic = CreateObject("Scripting.Dictionary")
  dic.RemoveAll
  DicInit = True
End Function

Public Function DicExists(iNum As Long) As Boolean
  DicExists = False
  If (dic Is Nothing) Then Exit Function
  If (dic.Count = 0) Then Exit Function
  DicExists = dic.Exists(iNum)
End Function

Public Function DicCount() As Long
  DicCount = 0
  If (dic Is Nothing) Then Exit Function
  DicCount = dic.Count
End Function

Public Function DicEntry() As Variant
  DicEntry = Empty
  If (dic Is Nothing) Then Exit Function
  If (dic.Count = 0) Then Exit Function
  DicEntry = dic.keys
End Function

Public Sub DicAdd(iNum As Long)
  If (dic Is Nothing) Then Call DicInit
  dic.Item(iNum) = Null
End Sub

Public Sub DicDel(iNum As Long)
  On Error Resume Next
  If (dic Is Nothing) Then Exit Sub
  If (dic.Count = 0) Then Exit Sub
  dic.Remove iNum
End Sub

 
フォーム「F3」としてフォーム「F1」をコピー作成し、値集合ソースを変更します。
左側リストボックス「lst1」
SELECT an, src, [メモ] FROM T1 WHERE Not DicExists(an) ORDER BY src;
右側リストボックス「lst2」
SELECT an, src, [メモ] FROM T1 WHERE DicExists(an) ORDER BY src;


そしてVBAで以下を記述します
Private Sub init1()
  Me.lst1 = Null
  Me.lst1.Requery
End Sub

Private Sub init()
  Call init1
  Me.lst2 = Null
  Me.lst2.Requery
End Sub

Private Sub initd()
  Call DicInit
  Call init
End Sub

Private Function Gikkon(iNum As Long)
  Select Case iNum
    Case 1: Call DicAdd(Me.lst1)
    Case 2: Call DicDel(Me.lst2)
  End Select
  Call init
End Function

Private Sub Form_Load()
  Call initd
  Me.lst1.OnClick = "=Gikkon(1)"
  Me.lst2.OnClick = "=Gikkon(2)"
End Sub

Private Sub btn1_Click()
  Dim sS As String

  sS = Trim(Nz(Me.txt1))
  If (Len(sS) > 0) Then
    CurrentProject.Connection.Execute "INSERT INTO T1(src) VALUES('" & sS & "');"
    Call init1
  End If
  Me.txt1 = Null
End Sub

Private Sub btn2_Click()
  Dim v As Variant
  Dim sS As String
  Dim sSql As String

  On Error Resume Next
  If (DicCount = 0) Then Exit Sub
  v = DicEntry
  If (IsEmpty(v)) Then Exit Sub
  sS = Join(v, ",")
  sSql = Trim(Nz(Me.txt2))
  If (Len(sSql) = 0) Then
    sSql = "Null"
  Else
    If (Left(sSql, 1) = "=") Then
      v = Empty
      v = Eval(Mid(sSql, 2))
      If (IsEmpty(v)) Then Exit Sub
      sSql = CStr(v)
    End If
    sSql = "'" & Replace(sSql, "'", "’") & "'"
  End If
  sSql = "UPDATE T1 SET メモ = " & sSql & " WHERE an IN (" & sS & ");"
  CurrentProject.Connection.Execute sSql
  Call initd
End Sub

 

2)複数選択を使ってみる


複数選択した「メモ」に対して設定(フォーム:F2)
kEnt122_21  kEnt122_22

フォーム「F1」を「F2」としてコピー作成後、
・右側リストボックスを削除
・左側リストボックスの設定を変更していきます
値集合ソース
SELECT T1.an, T1.src, T1.メモ FROM T1 ORDER BY T1.src;
複数選択:拡張

VBA記述を以下に
Private Sub init()
  Dim i As Long

'  For i = Abs(Me.lst1.ColumnHeads) To Me.lst1.ListCount - 1
'    Me.lst1.Selected(i) = False
'  Next
  Me.lst1.Requery
End Sub

Private Sub Form_Load()
  Call init
End Sub

Private Sub btn1_Click()
  Dim sS As String

  sS = Trim(Nz(Me.txt1))
  If (Len(sS) > 0) Then
    CurrentProject.Connection.Execute "INSERT INTO T1(src) VALUES('" & sS & "');"
  End If
  Call init
  Me.txt1 = Null
End Sub

Private Sub btn2_Click()
  Dim v As Variant
  Dim sS As String
  Dim sSql As String

  On Error Resume Next
  sS = ""
  For Each v In Me.lst1.ItemsSelected
    sS = sS & "," & Me.lst1.ItemData(v)
  Next
  If (Len(sS) = 0) Then Exit Sub
  sS = Mid(sS, 2)

  sSql = Trim(Nz(Me.txt2))
  If (Len(sSql) = 0) Then
    sSql = "Null"
  Else
    If (Left(sSql, 1) = "=") Then
      v = Eval(Mid(sSql, 2))
      If (IsEmpty(v)) Then Exit Sub
      sSql = CStr(v)
    End If
    sSql = "'" & Replace(sSql, "'", "’") & "'"
  End If
  sSql = "UPDATE T1 SET メモ = " & sSql & " WHERE an IN (" & sS & ");"
  CurrentProject.Connection.Execute sSql
  Call init
End Sub

 
ふ~~ん
  Me.lst1.Requery
した時点で、選択状態は解消されるんですね・・・・

1-2)、2)でもそうですが、条件として設定したい場合は、
 ・・・・ WHERE an IN (" & sS & ");"
ってな記述に限定されるんですかね・・・・

1-1)では、対象がテーブルに作られているので、
INNER JOIN だとか Exists だとか、それなりに変形した指定が出来そうです。

ただ、リストに表示している件数が多いとか・・・
状況によって変わってくるんでしょうか・・・


それはそうと、
  CurrentProject.Connection.Execute sSql

  CurrentDb.Execute sSql
でも同じだと思います。
私は ADODB.Recordset をよく記述で用いるので CurrentProject.Connection の方を使ってました。
なので ActiveX の参照設定してました。
が、今回、記述して動いた・・・・で、参照設定してなかったね・・・・
そこそこ収穫あったものになりました。


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt122_2000.zipkEnt122_2003.zipkEnt122_2007.zip
 サイズ 29,63131,16033,638
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

※ テーブル「T1」は空です
※ 適当にレコード追加して確認してみてください
関連記事

2012/03/31

Category: サンプルかな

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

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

top △


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