VB6 WinXPPro
■やりたいこと
・テーブル
フィールド1 OLE オブジェクト型
・フォーム
連結オブジェクトでテーブルと接続
1.連結オブジェクトの上で右クリック→「オブジェクトの挿入」
「ファイルから選択」でファイルを選ぶ(JPGなど)
2.連結オブジェクトの上で右クリック→「コピー」
ディスクトップなどに貼り付け
上記の内容だとMDBの中にファイルを格納して
出し入れが可能なように思えます。
これをACCESSでやるのではなく
VBでMDBを使いファイルの出し入れが行いたいです。
よろしくお願いします。
Access独自の実装をVBで再現するのは大変ですよ。
ただのバイナリではなくて、仕様非公開のOLEヘッダがついていますし。
とりあえず、こちらを参考にしてください。
http://support.microsoft.com/default.aspx?scid=kb;ja;242243
Private Const BUFFER_SIZE As Long = 16384
'----バイナリファイルをテーブルに保存-------------------
' strFileName : ファイル名
' strFieldName : フィールド名
' strMDBName : MDBファイル名
'-------------------------------------------------------
Private Sub ReadBinaryFromFile(ByVal strFileName As String, ByVal strFieldName As String, ByVal strMDBName As String)
Dim cnn As DAO.Database
Dim crs As DAO.Recordset
Dim fld As DAO.Field
Dim FNo As Long
Dim Buffer() As Byte
Dim lngLength As Long
On Error GoTo Except
'レコードセットを開く
Set cnn = OpenDatabase(strMDBName)
Set crs = cnn.OpenRecordset("T_Data", dbOpenDynaset)
crs.Edit
'ファイルを開く
FNo = FreeFile
Open strFileName For Binary Access Read As #FNo
'フィールドに保存
Set fld = crs.Fields(strFieldName)
ReDim Buffer(0 To BUFFER_SIZE - 1)
lngLength = LOF(FNo)
While lngLength > 0
If lngLength < BUFFER_SIZE Then ReDim Buffer(0 To lngLength - 1)
Get #FNo, , Buffer
fld.AppendChunk Buffer
lngLength = lngLength - BUFFER_SIZE
Wend
'閉じる
Close #FNo
'レコード保存
crs.Update
Erase Buffer
Set fld = Nothing
crs.Close: Set crs = Nothing
cnn.Close: Set cnn = Nothing
Finally:
Exit Sub
Except:
MsgBox "エラー番号 : " & Err.Number & vbCr & "エラー内容 : " & Err.Description, vbExclamation
GoTo Finally
End Sub
'----テーブルからバイナリデータに保存-------------
' strFileName : ファイル名
' strFieldName : フィールド名
' strMDBName : MDBファイル名
'-------------------------------------------------
Private Sub SaveBinaryToFile(ByVal strFileName As String, ByVal strFieldName As String, Optional strMDBName As String)
Dim cnn As DAO.Database
Dim crs As DAO.Recordset
Dim fld As DAO.Field
Dim strSql As String
Dim FNo As Long
Dim Buffer() As Byte
Dim lngOffset As Long
On Error GoTo Except
'レコードセットを開く
Set cnn = OpenDatabase(strMDBName)
strSql = "SELECT " & strFieldName & " FROM T_Data"
Set crs = cnn.OpenRecordset(strSql, dbOpenDynaset)
Set fld = crs.Fields(strFieldName)
'ファイルを開く
FNo = FreeFile
Open strFileName For Binary Access Write As #FNo
'ファイルに保存
lngOffset = 0
ReDim Buffer(0 To BUFFER_SIZE - 1)
While lngOffset < fld.FieldSize
Buffer() = fld.GetChunk(lngOffset, BUFFER_SIZE)
Put #FNo, , Buffer()
lngOffset = lngOffset + BUFFER_SIZE
Wend
'閉じる
Close #FNo
Erase Buffer
Set fld = Nothing
crs.Close: Set crs = Nothing
cnn.Close: Set cnn = Nothing
Finally:
Exit Sub
Except:
MsgBox "エラー番号 : " & Err.Number & vbCr & "エラー内容 : " & Err.Description, vbExclamation
GoTo Finally
End Sub
これって元のファイルに戻ってるのかな?
不安・・・
ツイート | ![]() |