画像データをファイルに

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

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です