画像データをファイルに

job

AccessからSQLServerに登録した画像データ（varbinary）を、ファイルで保存したいと思ったのですが、どうにもやり方が分かりません。
とりあえず今回は件数も少ないので、いったんAccessのイメージコントロールに表示して、それをファイルに保存するというやり方で対応することにしました。
DBからAccessのImageコントロールのPictureDataプロパティにセットし、それを外部ファイルに保存します。
元の画像が、BMP形式とBMP以外（PNG, JPG, GIF）のときで保存の仕方を変えないとだめみたいでした。
あと、BMPファイルは、元のファイルの色数によってbfOffBitsの値を調整する必要があるようです。
出来上がったファイルはペイントブラシでは開けるのですが他のソフトで開けなかったりしたので、ペイントブラシで一回開いて名前を付けて保存しないとだめかもしれません。
適当ですいません。とりあえず、藁レベルのメモということで。

標準モジュール内に記述。



Type BITMAPFILEHEADER

    bfType As String * 2

    bfSize As Long

    bfReserved1 As Integer

    bfReserved2 As Integer

    bfOffBits As Long

End Type

フォームにイメージコントールを「imgZumen」という名前で配置。
DBから画像データを取得して、Me.imgZumen.PictureDataにセットすると表示されるという前提で。
それをファイルに保存します。
以下をフォーム内に記述して、適当に呼び出してください。



' 元ファイルがBMP形式の場合

Private Sub SaveBMP()
    Dim cArray()    As Byte         ' 画像バイナリデータ

    Dim nFileNo     As Integer      ' ファイル番号

    Dim i       As Long

    Dim ln      As Long

    Dim path    As String

    Dim filenm  As String

    Dim BMPfh As BITMAPFILEHEADER 'ヘッダ定義
    path = Application.CurrentProject.path

    If path <> "" Then

        If Right$(path, 1) <> "\" Then path = path & "\"

    End If
    ' 画像データをファイルに書き出す

    nFileNo = FreeFile

    filenm = "output.bmp"
    cArray() = Me.imgZumen.PictureData

    With BMPfh

        .bfType = "BM"      ' 固定

        .bfSize = 14 + UBound(cArray) + 1 'ファイルサイズ

        .bfReserved1 = 0    ' 固定

        .bfReserved2 = 0    ' 固定

''        .bfOffBits = 62     ' 白黒

        .bfOffBits = 54     ' カラー（24ビット）

    End With

    Open path & filenm For Binary As #nFileNo

        Put #nFileNo, , BMPfh ' ヘッダ書き込み

        Put #nFileNo, , cArray()

    Close #nFileNo
End Sub
' 元ファイルがBMP形式以外の場合

Private Sub SaveNotBMP()
    Dim cArray()    As Byte         ' 画像バイナリデータ

    Dim bArray()    As Byte         ' 画像バイナリデータ

    Dim nFileNo     As Integer      ' ファイル番号

    Dim i       As Long

    Dim ln      As Long

    

    Dim path    As String

    Dim filenm  As String

    Dim sf      As Long
    sf = 8

    path = Application.CurrentProject.Path

    If path <> "" Then

        If Right$(path, 1) <> "\" Then path = path & "\"

    End If
    ' 画像データをファイルに書き出す

    nFileNo = FreeFile

    filenm = "output.png"    ' とりあえず。何でもいいみたい。
    bArray() = Me.imgZumen.PictureData

    ' Copy the embedded EMF - SKIP first 8 bytes

    ln = UBound(bArray)

    ReDim cArray(ln - sf)

    For i = sf To ln

        cArray(i - sf) = bArray(i)

    Next

    Open path & filenm For Binary As #nFileNo

        Put #nFileNo, , cArray()

    Close #nFileNo
End Sub

先頭を8バイトずらすというのは、こちらのサイトを参考にしました。
http://msmvps.com/blogs/nateoliver/archive/2010/03/10/let-s-move-an-image-from-access-to-excel.aspx