Excel VBA質問箱 IV

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

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


70732 / 76734 ←次へ | 前へ→

【10504】Re:OLEオブジェクト型?
回答  ichinose  - 04/1/29(木) 20:22 -

引用なし
パスワード
   ▼大雪男 さん:
こんばんは。再送です(さっき、投稿したコードにちょっとしたバグがあったもので)。

>
>テーブルは3つのフィールドから出来ており、データ型が
>1.テキスト型
>2.テキスト型
>3.OLEオブジェクト型
>となっています。
>
>このテーブルは5レコードあるのですが、最初の1レコードのみ
>を取り込んで、2レコード以後がありません。
>OLEオブジェクト型のフィールドがあると取り込めないのでしょうか?
前回のコードは、OLEオブジェクト型を想定していませんでした。
OLEオブジェクト型のI/Oは、バイナリデータしかやったことがありません。
中のデータは色々ありますからねえ・・・。

>OLEオブジェクト型のフィールドは無しとしてでも、全てのレコードを
>読み込む事は可能でしょうか?
↑これを可能に改造してみました。
とりあえず、変更のないプロシジャーも全部載せますね!!
まず、標準モジュール(Modile1)に
'===============================================================
Sub main()
  Dim tblnm
  Dim fldlist
  Dim mysql As String
  If open_cat("D:\EXCELファイル\import.mdb") = 0 Then
   tblnm = get_tblnm
   If VarType(tblnm) <> vbBoolean Then
     For idx = 1 To UBound(tblnm) - 1
      Worksheets.Add after:=Worksheets(idx)
      Next
     For idx = LBound(tblnm) To UBound(tblnm)
      If chk_tbl(tblnm(idx), fldlist, mysql) = 0 Then
'        ↑ここで、フィールド名一覧取得とフィールドチェックとSqlを作成
        With Worksheets(idx)
         .Range("a1").Value = tblnm(idx)
         .Range(.Cells(2, 1), .Cells(2, UBound(fldlist))).Value = fldlist
         Call copy_rs(.Range("a3"), mysql)
         End With
      Else
        Exit For
        End If
      Next
     End If
   End If
  Call close_cat
End Sub

'標準モジュール(Module2)に
'===============================================================
Private cat As ADOX.Catalog
'===============================================================
Function open_cat(flnm As String) As Long
  On Error Resume Next
  Set cat = New 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_tblnm()
'テーブル名の列挙
  Dim mytbl()
  Dim tbl As ADOX.Table
  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
'===============================================================
Function chk_tbl(tblnm, fldnm, mysql As String)
'指定されたテーブルのフィールドのチェックとSqlの作成
  On Error GoTo err_chk_tbl
  Dim nmlist()
  Dim sql() As String
  Dim err_flg As Boolean
  Dim rs As ADODB.Recordset
  chk_tbl = 0
  err_flg = False
  Set rs = New ADODB.Recordset
  With rs
   .Open "select * from " & tblnm, cat.ActiveConnection, adOpenDynamic, adLockPessimistic
   For idx = 0 To .Fields.Count - 1
    ReDim Preserve nmlist(1 To idx + 1)
    ReDim Preserve sql(1 To idx + 1)
    nmlist(idx + 1) = .Fields(idx).Name
    If .Fields(idx).Type = adChapter Or .Fields(idx).Type = adLongVarBinary Then
      sql(idx + 1) = """"" as f" & idx + 1
      err_flg = True
    Else
      sql(idx + 1) = .Fields(idx).Name
      End If
    Next
   .Close
   End With
  fldnm = nmlist()
  If err_flg = False Then
   mysql = "select * from " & tblnm
  Else
   mysql = "select " & Join(sql(), ",") & " from " & tblnm
   End If
ret_chk_tbl:
  Set rs = Nothing
  On Error GoTo 0
  Exit Function
err_chk_tbl:
  MsgBox Error(Err.Number)
  chk_tbl = Err.Number
  Resume ret_chk_tbl
End Function
'===============================================================
Function copy_rs(rng As Range, sql_str) As Long
'データのコピー
  Dim rs As ADODB.Recordset
  copy_rs = 0
  Set rs = New ADODB.Recordset
  On Error GoTo err_copy_rs
  rs.Open sql_str, cat.ActiveConnection, adOpenDynamic, adLockPessimistic
  rng.CopyFromRecordset rs
  rs.Close
ret_copy_rs:
  On Error GoTo 0
  Exit Function
err_copy_rs:
  MsgBox Error(Err.Number) & sql_str
  copy_rs = Err.Number
  Resume ret_copy_rs
End Function
'===============================================================
Sub close_cat()
  cat.ActiveConnection.Close
  Set cat = Nothing
End Sub

コードを差し替えて確認をお願いします。
3 hits

【10434】MDBから情報を得たい・・・。 大雪男 04/1/26(月) 16:54 質問
【10435】Re:MDBから情報を得たい・・・。 INA 04/1/26(月) 17:19 回答
【10439】Re:MDBから情報を得たい・・・。 ichinose 04/1/26(月) 19:29 回答
【10442】Re:MDBから情報を得たい・・・。 大雪男 04/1/27(火) 8:44 お礼
【10494】OLEオブジェクト型? 大雪男 04/1/29(木) 14:14 質問
【10504】Re:OLEオブジェクト型? ichinose 04/1/29(木) 20:22 回答
【10511】Re:OLEオブジェクト型? 大雪男 04/1/30(金) 11:53 お礼

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