| |
こんばんは。
既に解決しているようですが、
Keinさんコードで解決されたのでしょうね！！
>
>Parameters:= は使ったことないのでわかりませんが、
>UserForm2.TextBox1.Textは文字列型ですから、パラメータが日付型だったら
>どうなるんですかね？
でも、滅多にお目にかかれないせっかくのパラメータクエリの問題だったので
これが朝から気になっていました。
（朝の忙しい時には、検証できませんでしたが・・・）
パラメータクエリの場合は 'も#も%も要らないと思いましたが
私も試したことはありませんでした。（文字列では要らなかった）
で試しました。結果は、要りません。
でよかったら、皆さんも再現してみてください。
まず、新規ブック（Sheet1というシートは必ず存在する）
にユーザーフォームを作成してください。
ユーザーフォームのコントロール構成は以下のとおりです。
Userform1
コマンドボタン----Commandbutton1 サンプルＤＢ作成用
テキストボックス---TextBox1 日付範囲指定 開始日
テキストボックス---TextBox2 日付範囲指定 終了日
コマンドボタン----Commandbutton2 パラメータクエリ実行用
まず、標準モジュールに
'=================================================================
Option Explicit
Sub main()
Sheets("sheet1").Select
UserForm1.Show
End Sub
別の標準モジュールにＤＢを操作するプロシジャー群
'================================================================
Option Explicit
Private cat As Object
'================================================================
Function create_cat(flnm As String) As Long
On Error Resume Next
Set cat = CreateObject("ADOX.Catalog")
cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & flnm
create_cat = Err.Number
On Error GoTo 0
End Function
'================================================================
Function open_cat(flnm As String) As Long
On Error Resume Next
Set cat = CreateObject("ADOX.Catalog")
cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & flnm
open_cat = Err.Number
On Error GoTo 0
End Function
'================================================================
Function get_cn() As Object
Set get_cn = cat.ActiveConnection
End Function
'================================================================
Function cr_cmd(text As String, nm As String) As Long
On Error Resume Next
cr_cmd = 0
cat.Views.Delete nm
Err.Clear
Dim cmd As Object
Set cmd = CreateObject("ADODB.Command")
cmd.CommandText = text
cat.Views.Append nm, cmd
cr_cmd = Err.Number
On Error GoTo 0
End Function
'================================================================
Function exe_cmd(o_obj As Object, nm, Optional myarray As Variant = "") As Long
'パラメータクエリ実行ルーチン
On Error Resume Next
Dim cmd As Object
Set cmd = CreateObject("ADODB.Command")
With cmd
.CommandText = nm
.ActiveConnection = get_cn
If TypeName(myarray) = "String" Then
Set o_obj = cmd.Execute
Else
Set o_obj = cmd.Execute(Parameters:=myarray)
End If
End With
exe_cmd = Err.Number
On Error GoTo 0
End Function
'================================================================
Function Exec(sql_str) As Long
On Error Resume Next
Exec = 0
cat.ActiveConnection.Execute sql_str
If Err.Number <> 0 Then
Exec = Err.Number
End If
On Error GoTo 0
End Function
'================================================================
Sub delete_fl(flnm)
On Error Resume Next
Kill flnm
On Error GoTo 0
End Sub
'================================================================
Function append_autonumber_col(tblnm, colnm) As Long
Dim col As ADOX.Column
Set col = New ADOX.Column
With col
.Name = colnm
.Type = adInteger
Set .ParentCatalog = cat
.properties("AutoIncrement") = True
End With
cat.Tables(tblnm).Columns.Append col
Set col = Nothing
append_autonumber_col = 0
End Function
'================================================================
Function create_tbl(tblnm As String, nmarray, tparray, attarray, blkarray) As Long
'tblnmというテーブルを作成し、最初の列に主キーを設定する
'Input:tblnm----テーブル名
' nmarray----列の名前の配列
' tparray----列のタイプの配列
' attarray---列のオートナンバーか否かの配列 Trueオートナンバー、falseオートナンバーでない
' blkarray---空白を許可する --true許可 false許可しない
On Error GoTo err_create_tbl
Dim RS As Object
Dim tbl As Object
Dim col As Object
Dim kky As Object
Dim idx As Long
Dim jdx As Long
create_tbl = 0
Set tbl = CreateObject("ADOX.Table")
tbl.Name = tblnm
jdx = 0
For idx = LBound(nmarray) To UBound(nmarray)
Set col = CreateObject("ADOX.Column")
With col
.Name = nmarray(idx)
.Type = tparray(idx)
Set .ParentCatalog = cat
.properties("AutoIncrement") = attarray(idx)
.properties("Jet OLEDB:Allow Zero Length") = blkarray(idx)
.DefinedSize = 100
End With
tbl.Columns.Append col
Set col = Nothing
Next idx
cat.Tables.Append tbl
Set kky = CreateObject("ADOX.Key")
cat.Tables(tblnm).Keys.Append nmarray(LBound(nmarray)), 1, nmarray(LBound(nmarray))
Set tbl = Nothing
Set col = Nothing
On Error GoTo 0
ret_create_tbl:
Exit Function
err_create_tbl:
MsgBox Error(Err.Number)
create_tbl = Err.Number
Resume ret_create_tbl
End Function
'================================================================
Function get_tblnm()
'テーブル名の列挙
Dim mytbl()
Dim tbl As Object
idx = 1
For Each tbl In cat.Tables
If UCase(tbl.Type) = UCase("table") Then
ReDim Preserve mytbl(1 To idx)
mytbl(idx) = tbl.Name
idx = idx + 1
End If
Next
If idx > 1 Then
get_tblnm = mytbl()
Else
get_tblnm = False
End If
End Function
'================================================================
Sub close_cat()
On Error Resume Next
get_cn.Close
Set cat = Nothing
On Error GoTo 0
End Sub
尚、このプロシジャー群は今回の事象には使っていないものも含まれています。
Userform1のモジュールに
'===================================================================
Option Explicit
Const flnm = "sample.mdb"
Const qry_samp = "qry_samp"
Private Sub CommandButton1_Click()
Dim dbpath As String
Dim retcode As Long
Dim nm As Variant
Dim tp As Variant
Dim att As Variant
Dim blk As Variant
Dim sqlstr As String
dbpath = ThisWorkbook.Path & "\" & flnm
Call delete_fl(dbpath)
retcode = create_cat(dbpath)
If retcode = 0 Then
nm = Array("dbid", "dbdate", "dbstr")
tp = Array(3, 7, 202)
att = Array(True, False, False)
blk = Array(False, False, True)
retcode = create_tbl("tblsamp", nm, tp, att, blk)
If retcode = 0 Then
With Worksheets("sheet1")
.Range("a:c").ClearContents
.Range("a1:c1").Value = Array("dbid", "dbdate", "dbstr")
With .Range("a2:c21")
.Formula = Array("=row()-1", "=""2007/1/1""+row()-1", "=REPT(CHAR(63+row()),3)")
.Value = .Value
.Columns(2).NumberFormatLocal = "yyyy/m/d"
End With
End With
sqlstr = "insert into [tblsamp] SELECT dbid, dbdate, dbstr FROM [Excel 8.0;Database=" _
& ThisWorkbook.FullName & "]" & ".[sheet1$a1:c21];"
If Exec(sqlstr) = 0 Then
If cr_cmd("SELECT * FROM tblsamp where dbdate between [date1:] and [date2:];", qry_samp) = 0 Then
'パラメータクエリの作成
MsgBox "サンプル作成成功"
Else
MsgBox "クエリー作成失敗"
End If
Else
MsgBox "サンプル作成失敗"
End If
Else
MsgBox Error$(retcode)
End If
Else
MsgBox Error(retcode)
End If
Call close_cat
End Sub
'=========================================================================
Private Sub CommandButton2_Click()
Dim dbpath As String
Dim myRS As Object
dbpath = ThisWorkbook.Path & "\" & flnm
Set myRS = CreateObject("adodb.recordset")
If open_cat(dbpath) = 0 Then
If exe_cmd(myRS, qry_samp, Array(TextBox1.text, TextBox2.text)) = 0 Then
'パラメータクエリの実行
With Worksheets("sheet1")
.Range("f:h").ClearContents
.Range("f1:h1").Value = Array("dbid", "dbdate", "dbstr")
.Range("f2").CopyFromRecordset myRS
.Range("g:g").NumberFormatLocal = "yyyy/m/d"
End With
myRS.Close
Else
MsgBox "error"
End If
Call close_cat
Else
MsgBox "接続失敗"
End If
Set myRS = Nothing
End Sub
以上です。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
