| |
▼大雪男 さん：
こんばんは。再送です（さっき、投稿したコードにちょっとしたバグがあったもので）。
>
>テーブルは３つのフィールドから出来ており、データ型が
>１．テキスト型
>２．テキスト型
>３．ＯＬＥオブジェクト型
>となっています。
>
>このテーブルは５レコードあるのですが、最初の１レコードのみ
>を取り込んで、２レコード以後がありません。
>ＯＬＥオブジェクト型のフィールドがあると取り込めないのでしょうか？
前回のコードは、ＯＬＥオブジェクト型を想定していませんでした。
ＯＬＥオブジェクト型のＩ／Ｏは、バイナリデータしかやったことがありません。
中のデータは色々ありますからねえ・・・。
>ＯＬＥオブジェクト型のフィールドは無しとしてでも、全てのレコードを
>読み込む事は可能でしょうか？
↑これを可能に改造してみました。
とりあえず、変更のないプロシジャーも全部載せますね！！
まず、標準モジュール（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
コードを差し替えて確認をお願いします。
|
|
