mdb OLE オブジェクト型 ファイルの出入


○×△□  2006-10-12 05:06:55  No: 96886

VB6  WinXPPro

■やりたいこと
  ・テーブル
    フィールド1  OLE オブジェクト型
  ・フォーム
    連結オブジェクトでテーブルと接続
  
  1.連結オブジェクトの上で右クリック→「オブジェクトの挿入」
  「ファイルから選択」でファイルを選ぶ(JPGなど)
  2.連結オブジェクトの上で右クリック→「コピー」
  ディスクトップなどに貼り付け

  上記の内容だとMDBの中にファイルを格納して
  出し入れが可能なように思えます。

これをACCESSでやるのではなく
VBでMDBを使いファイルの出し入れが行いたいです。

よろしくお願いします。


もげ  2006-10-12 17:48:16  No: 96887

Access独自の実装をVBで再現するのは大変ですよ。
ただのバイナリではなくて、仕様非公開のOLEヘッダがついていますし。
とりあえず、こちらを参考にしてください。
http://support.microsoft.com/default.aspx?scid=kb;ja;242243


○×△□  URL  2006-10-12 19:56:11  No: 96888

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


○×△□  URL  2006-10-12 19:58:54  No: 96889

これって元のファイルに戻ってるのかな?

不安・・・


※返信する前に利用規約をご確認ください。

※Google reCAPTCHA認証からCloudflare Turnstile認証へ変更しました。






  このエントリーをはてなブックマークに追加