Export bitmap OLE Object to file

[jdmartin74]

I have a database with a table of images stored as OLE Object field types.

I would like to export these to individual files, however, I can't seem to do it. I have tried the following code below. It works in that the file is written, however, it is not a usable bitmap file.

Can anyone help? Thanks very much.

Function WriteFile()

Dim iFileNum As Integer, strFile As String, strOutput As String
Dim strImage As String
Dim db As Database, rs As Recordset, strSQL As String

strFile = "d:\test.bmp"

Set db = CurrentDb()
strSQL = "select ImageData from tblImages where ImageID = 800"
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)

With rs
Do Until .EOF
strOutput = !ImageData.GetChunk(0, !ImageData.FieldSize)

' Open the log file and write the entry
iFileNum = FreeFile()
Open strFile For Append Access Write Lock Read Write As #iFileNum
Print #iFileNum, strOutput
Close #iFileNum

.MoveNext
Loop
End With



End Function

 

[sfm6s524]

I have some code I've used to create binary files using an ADO recordset from a SQL Server:

Dim RS As ADODB.Recordset
Dim mStream As ADODB.Stream
Dim SQL, TempFName as String

Set RS = New ADODB.Recordset
' Whatever SQL works for you. In this SQL Server DB, FileObj is Image datatype.
' Filename is original filename.
' txtFileID is unique key of table, file records are in subform.
' This is a Document Manager program that stores Word, Excel files, etc.
SQL = "SELECT FileObj, Filename FROM tblFiles WHERE FileID = " & Me![frmMainSubForm].Form!txtFileID
' gcnn is a global ADODB.Connection, already open.
RS.Open SQL, gcnn, adOpenKeyset, adLockOptimistic
' What if no records.
If RS.EOF Then
MsgBox "No records found."
Exit Sub
End If
Set mStream = New ADODB.Stream
mStream.Type = adTypeBinary
mStream.Open
mStream.Write RS!FileObj
' TempFName is original filename, but temporary directory.
mStream.SaveToFile TempFName, adSaveCreateOverWrite
' At this point, check if files exists and perhaps open.
Application.FollowHyperlink TempFName
' Close objects below ...

Might get you going. Ken

 

[jdmartin74]

Thanks. I'll give it a go.