(*´д`*)ｱﾊｧ… VB初心者質問スレ Part20

>>618の質問をしたものです。
皆さんのご協力のおかげで、かなりの力技ですが、ついにファイルを
取り出すことができました！本当にありがとうございました。
つきましては、汚いソースですが、一応他の方の参考になるかもしれないので
以下に記述します。

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Sub Command1_Click()
Dim b() As Byte
Dim buf As String
Dim db As DAO.Database
Dim rec As DAO.Recordset

buf = App.Path & "\tmp.mdb"
Set db = DAO.OpenDatabase(buf)
Set rec = db.OpenRecordset("テーブル")
If rec.EOF = False Then
If GetPSD(rec.Fields("画像"), b) = True Then
Open "c:\tmp.psd" For Binary Access Write As #1
Put #1, , b
Close #1
End If
End If
Call rec.Close
Set rec = Nothing
Call db.Close
Set db = Nothing
End Sub

<<ソース続き>>

Private Function GetPSD(ByVal OleField As DAO.Field, ByRef b() As Byte) As Boolean
Dim Arr() As Byte
Dim Buffer As String
Dim HeaderOffset As Integer
Dim ArrBmp() As Byte
Dim i As Long

GetPSD = False

ReDim Arr(OleField.FieldSize)
Arr() = OleField.GetChunk(0, OleField.FieldSize)

' この辺がかなり強引
Buffer = ""
For i = 0 To 15000
Buffer = Buffer & Chr(Arr(i))
Next i

HeaderOffset = InStr(Buffer, "8BPS")
If HeaderOffset > 0 Then
ReDim ArrBmp(UBound(Arr) - HeaderOffset + 1)
CopyMemory ArrBmp(0), Arr(HeaderOffset - 1), UBound(Arr) - HeaderOffset + 2

b = ArrBmp
GetPSD = True
End If
End Function