| |
いつもお世話になっております。inuと申します。
フォームのコントロールからテーブルを操作する方法について
教えて頂きたく書き込みをしました。
以下のコードとデザインは検索結果をリストボックスに表示さ
せるというものです。（VBA初心者なものでコードの書き方は
むちゃくちゃかと思いますが、なにか効率の良い書き方があれ
ばアドバイスして頂けると幸いです）
---
Option Compare Database
Private Sub B_DocSearch_Click() '検索ボタン
On Error GoTo Err_B_DocSearch_Click
Dim tmp As String
Dim sql As String
Mgt.Value = Nz(Me!Mgt.Value)
If (Mgt.Value <> "") Then
tmp = " AND " & "文書管理台帳.文書管理番号='" & Mgt.Value & "'"
End If
Namea.Value = Nz(Me!Namea.Value)
If (Namea.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.文書名='" & Namea.Value & "'"
End If
RevNum.Value = Nz(Me!RevNum.Value)
If (RevNum.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.版番='" & RevNum.Value & "'"
End If
If (Make.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.作成者='" & Make.Value & "'"
End If
Ena.Value = Nz(Me!Ena.Value)
If (Ena.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.制定日='" & Ena.Value & "'"
End If
Last.Value = Nz(Me!Last.Value)
If (Last.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.最終更新者='" & Last.Value & "'"
End If
LastDate.Value = Nz(Me!LastDate.Value)
If (LastDate.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.最終更新日='" & LastDate.Value & "'"
End If
Term.Value = Nz(Me!Term.Value)
If (Term.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.有効期限='" & Term.Value & "'"
End If
Abo.Value = Nz(Me!Abo.Value)
If (Abo.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.廃止文書='" & Abo.Value & "'"
End If
AboDate.Value = Nz(Me!AboDate.Value)
If (AboDate.Value <> "") Then
tmp = tmp & " AND " & "文書管理台帳.廃止日='" & AboDate.Value & "'"
End If
sql = Mid(tmp, 6)
If (Me.フレーム38.Value = 1) Then
If (sql = "") Then Exit Sub
Call MakeQuery(sql)
DoCmd.DeleteObject acQuery, "Q_Tmp"
リスト0.RowSource = "Q_DocSearchOR"
Else
If (sql = "") Then Exit Sub
Call MakeQuery(sql)
リスト0.RowSource = "Q_Tmp"
DoCmd.DeleteObject acQuery, "Q_Tmp"
End If
Exit_B_DocSearch_Click:
Exit Sub
Err_B_DocSearch_Click:
MsgBox Err.Description
Resume Exit_B_DocSearch_Click
End Sub
Private Sub B_FormExit_Click() '終了ボタン
On Error GoTo Err_B_FormExit_Click
DoCmd.Close
Exit_B_FormExit_Click:
Exit Sub
Err_B_FormExit_Click:
MsgBox Err.Description
Resume Exit_B_FormExit_Click
End Sub
Public Sub MakeQuery(tmp2 As String) 'リストボックスに表示する検索結果のクエリ
Dim CAT As ADOX.Catalog
Dim CMD As ADODB.Command
Dim CAT2 As ADOX.Catalog
Dim CMD2 As ADODB.Command
'接続
Set CAT = New ADOX.Catalog
CAT.ActiveConnection = CurrentProject.Connection
Set CAT2 = New ADOX.Catalog
CAT2.ActiveConnection = CurrentProject.Connection
'クエリの定義
Set CMD = New ADODB.Command
CMD.CommandText = "SELECT * FROM 文書管理台帳 WHERE " & tmp2
Set CMD2 = New ADODB.Command
CMD2.CommandText = "SELECT * FROM 文書管理台帳 WHERE " & tmp2
'クエリ作成
CAT.Views.Append "Q_Tmp", CMD
If (CAT2.Views.Count = 2) Then
DoCmd.DeleteObject acQuery, "Q_Rep"
End If
If (CAT2.Views.Count <= 1 Or 2) Then
CAT2.Views.Append "Q_Rep", CMD2
End If
'終了
Set CMD = Nothing
Set CAT = Nothing
Set CMD2 = Nothing
Set CAT2 = Nothing
End Sub
Private Sub コマンド32_Click() 'クリアボタン
Mgt.Value = ""
Namea.Value = ""
RevNum.Value = ""
Ena.Value = ""
Last.Value = ""
LastDate.Value = ""
Term.Value = ""
Abo.Value = ""
AboDate.Value = ""
リスト0.RowSource = "SELECT * FROM 文書管理台帳"
End Sub
Private Sub 印刷プレビュー_Click() '印刷プレビューボタン
On Error GoTo Err_印刷プレビュー_Click
Dim stDocName As String
If ((Mgt.Value = "" And Namea.Value = "" And RevNum.Value = "" And Ena.Value = "" And Last.Value = "" And LastDate.Value = "" And Term.Value = "" And Abo.Value = "" And AboDate.Value = "") Or (IsNull(Mgt.Value) And IsNull(Namea.Value) And IsNull(RevNum.Value) And IsNull(Ena.Value) And IsNull(Last.Value) And IsNull(LastDate.Value) And IsNull(Term.Value) And IsNull(Abo.Value) And IsNull(AboDate.Value))) Then
DoCmd.OpenReport "R_null", acPreview
Else
stDocName = "Q_Rep"
DoCmd.OpenReport stDocName, acPreview
End If
Exit_印刷プレビュー_Click:
Exit Sub
Err_印刷プレビュー_Click:
MsgBox Err.Description
Resume Exit_印刷プレビュー_Click
End Sub
デザイン画像
http://www.imgup.org/file/iup142347.jpg
---
私がやりたいのは、リストボックスに表示されているレコードを
右クリックすれば「追加」、「変更」といメニューが表示され
メニューをクリックするとダイアログが表示されレコードの追加、変更
ができるようなVBAを書きたいのですがどのようにコードを修正すれば
良いかわかりません。さらにレコードをダブルクリックすると参照先の
ファイルを開きに行くようなVBAも書きたいのですが、教えていただけ
ないでしょうか？宜しくお願いいたします。
|
|
inu
- 06/1/6(金) 15:25 -
