Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


35574 / 76738 ←次へ | 前へ→

【46362】Re:アクセスのクエリを実行したい 1
発言  ichinose  - 07/1/31(水) 21:54 -

引用なし
パスワード
   こんばんは。
既に解決しているようですが、
Keinさんコードで解決されたのでしょうね!!


>
>Parameters:= は使ったことないのでわかりませんが、
>UserForm2.TextBox1.Textは文字列型ですから、パラメータが日付型だったら
>どうなるんですかね?
でも、滅多にお目にかかれないせっかくのパラメータクエリの問題だったので
これが朝から気になっていました。
(朝の忙しい時には、検証できませんでしたが・・・)

パラメータクエリの場合は 'も#も%も要らないと思いましたが
私も試したことはありませんでした。(文字列では要らなかった)

で試しました。結果は、要りません。

でよかったら、皆さんも再現してみてください。

まず、新規ブック(Sheet1というシートは必ず存在する)
にユーザーフォームを作成してください。

ユーザーフォームのコントロール構成は以下のとおりです。

Userform1
  コマンドボタン----Commandbutton1 サンプルDB作成用
  テキストボックス---TextBox1    日付範囲指定 開始日
  テキストボックス---TextBox2    日付範囲指定 終了日
  コマンドボタン----Commandbutton2 パラメータクエリ実行用
  

まず、標準モジュールに

'=================================================================
Option Explicit
Sub main()
  Sheets("sheet1").Select
  UserForm1.Show
End Sub


別の標準モジュールにDBを操作するプロシジャー群
'================================================================
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

以上です。

0 hits

【46311】アクセスのクエリを実行したい phoo 07/1/30(火) 13:00 質問
【46313】Re:アクセスのクエリを実行したい neptune 07/1/30(火) 13:29 発言
【46362】Re:アクセスのクエリを実行したい 1 ichinose 07/1/31(水) 21:54 発言
【46363】Re:アクセスのクエリを実行したい 2 ichinose 07/1/31(水) 21:54 発言
【47697】Re:アクセスのクエリを実行したい 2 phoo 07/3/19(月) 17:00 質問
【47709】Re:アクセスのクエリを実行したい 2 ichinose 07/3/20(火) 7:56 発言
【47731】Re:アクセスのクエリを実行したい 2 ichinose 07/3/21(水) 8:09 発言
【47837】Re:アクセスのクエリを実行したい 2 phoo 07/3/23(金) 18:35 お礼
【46318】Re:アクセスのクエリを実行したい Kein 07/1/30(火) 14:39 回答
【46319】Re:アクセスのクエリを実行したい Kein 07/1/30(火) 14:41 発言
【46321】Re:アクセスのクエリを実行したい phoo 07/1/30(火) 15:43 お礼

35574 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free