OLE object to files
Jeff Herron
school I work for. I need to copy all of the photos of these students from
the database (these are embedded bitmaps), convert them to jpegs, and then
save them as individual files. These files must be named with the ID of the
student to whom the picture belongs.
Any suggestions would be helpful.
Jeff Herron
Werner Traxinger
Jeff Herron wrote in message ...
Jeff,
look at the following code. Maybe it will help you.
Werner.
Option Compare Database
Option Explicit
Option Base 1
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any,
lpvSource As Any, ByVal cbCopy As Long)
Type PT
Width As Integer
Height As Integer
End Type
Type OBJECTHEADER
Signature As Integer ' Type signature (0x1c15).
HeaderSize As Integer ' Size of header (sizeof(struct OBJECTHEADER) +
cchName + cchClass).
ObjectType As Long ' OLE Object type code (OT_STATIC, OT_LINKED,
OT_EMBEDDED).
NameLen As Integer ' Count of characters in object name
(CchSz(szName) + 1).
ClassLen As Integer ' Count of characters in class name
(CchSz(szClass) + 1).
NameOffset As Integer ' Offset of object name in structure
(sizeof(OBJECTHEADER)).
ClassOffset As Integer ' Offset of class name in structure (ibName +
cchName).
ObjectSize As PT ' Original size of object.
End Type
Type OLEHEADER
OleVersion As Long
Format As Long
TypeLen As Long
End Type
Dim strArr() As String * 1
Sub Output_OLE_Object(strDescription)
Dim rsTemp As Recordset
'
Set rsTemp = CurrentDb.OpenRecordset("SELECT * FROM Images WHERE
Description = '" & strDescription & "'", dbOpenDynaset)
If Not rsTemp.EOF Then
rsTemp.MoveFirst
Do
If Not IsNull(rsTemp!Photo) Then Call RestoreObject(rsTemp!Photo,
rsTemp!Description)
rsTemp.MoveNext
Loop While Not rsTemp.EOF
End If
rsTemp.Close
End Sub
Sub RestoreObject(objField As Field, objDescription As String)
'
' Note:
' Retrieval of information by Put, Get and Seek seemed to me the fastest
way in the momement,
' because the above declared "CopyMemory" API routine does not work the
way it should!
' The code works, but still may be improved.
'
Dim objHead As OBJECTHEADER
Dim oleHead As OLEHEADER
Dim i, j As Integer
Dim iStrings As Integer
Dim lObject As Long
Dim lFileSize As Long
Dim l As Long
Dim strNL As String
Dim strDir As String
Dim strMsg As String
Dim strDummy As String
Dim objName As String
Dim strFilename As String
Dim strPath As String
Dim strExtention As String
Dim strByte As String * 1
Dim lValue As Long
Dim iAction As Integer
'
If objField.FieldSize = 0 Then Exit Sub
'
strNL = Chr$(13) & Chr$(10)
'
strDir = Dir("C:\WINDOWS\TEMP", vbDirectory)
If strDir = "TEMP" Then
strDir = "C:\WINDOWS\TEMP\"
Else
strDir = "C:\"
End If
'
Open strDir & "object.tmp" For Binary As #2
Put #2, , objField.Value ' write out 12 bytes for unknown
info + the Object
'
Seek #2, 12 + 1 ' move to start position of
OBJECTHEADER and skip the 12 bytes + 1 for seek (must be > 0)
Get #2, , objHead ' get the ObjectHeader
strMsg = "========== OBJECT-HEADER ==========" & strNL
strMsg = strMsg & "Signature:" & Chr$(9) & Hex$(objHead.Signature) &
strNL
strMsg = strMsg & "HeaderSize:" & Chr$(9) & Format(objHead.HeaderSize) &
strNL
strMsg = strMsg & "ObjectType:" & Chr$(9) & Format(objHead.ObjectType)
If objHead.ObjectType = 2 Then strMsg = strMsg & " (embedded)"
If objHead.ObjectType = 3 Then strMsg = strMsg & " (static)"
strMsg = strMsg & strNL
strMsg = strMsg & "NameLength:" & Chr$(9) & Format(objHead.NameLen) &
strNL
strMsg = strMsg & "ClassLength:" & Chr$(9) & Format(objHead.ClassLen) &
strNL
strMsg = strMsg & "NameOffset:" & Chr$(9) & Format(objHead.NameOffset) &
strNL
strMsg = strMsg & "ClassOffset:" & Chr$(9) & Format(objHead.ClassOffset)
& strNL
'
Seek #2, 12 + objHead.NameOffset + 1 ' move to start of Object-Name
ReDim strArr(objHead.NameLen) ' adjust strArr-length
Get #2, , strArr ' get Object-Name
objName = ""
For i = 1 To objHead.NameLen - 1
objName = objName & strArr(i)
Next i
strMsg = strMsg & "Name:" & Chr$(9) & Chr$(9) & objName & strNL
'
Seek #2, 12 + objHead.ClassOffset + 1 ' move to start of Object-Class
ReDim strArr(objHead.ClassLen) ' adjust strArr-length
Get #2, , strArr ' get Object-Class
strDummy = ""
For i = 1 To objHead.ClassLen - 1
strDummy = strDummy & strArr(i)
Next i
strMsg = strMsg & "Class:" & Chr$(9) & Chr$(9) & strDummy & strNL
strMsg = strMsg & strNL
'
Seek #2, 12 + objHead.HeaderSize + 1 ' move to start position of
OLEHEADER
Get #2, , oleHead
strMsg = strMsg & "========== OLE-HEADER ==========" & strNL
strMsg = strMsg & "OleVersion:" & Chr$(9) & Hex$(oleHead.OleVersion) &
strNL
strMsg = strMsg & "Format:" & Chr$(9) & Chr$(9) & Format(oleHead.Format)
& strNL
strMsg = strMsg & "TypeLength:" & Chr$(9) & Format(oleHead.TypeLen) &
strNL
'
ReDim strArr(oleHead.TypeLen)
Get #2, , strArr ' get OLE-Type
strDummy = ""
For i = 1 To oleHead.TypeLen - 1
strDummy = strDummy & strArr(i)
Next i
strMsg = strMsg & "OLEType:" & Chr$(9) & strDummy & strNL
Get #2, , l
strMsg = strMsg & "Unknown: " & Chr$(9) & Format(l) & strNL
Get #2, , l
strMsg = strMsg & "Unknown: " & Chr$(9) & Format(l) & strNL
Get #2, , l ' this is the length of the OLE-Data
field
strMsg = strMsg & "OLESize: " & Chr$(9) & Format(l) & strNL
strMsg = strMsg & strNL
'
Select Case objName
Case "Document" ' Word
ReDim strArr(l) ' Filesize = OLESize
Get #2, , strArr
Close #2
'
Open strDir & objDescription & ".doc" For Binary As #2
Put #2, , strArr
Close #2
strMsg = strMsg & "========== saved " & Format(l) & " Bytes as
==========" & strNL
strMsg = strMsg & strDir & objDescription & ".doc"
Case "Worksheet" ' Excel
ReDim strArr(l) ' Filesize = OLESize
Get #2, , strArr
Close #2
'
Open strDir & objDescription & ".xls" For Binary As #2
Put #2, , strArr
Close #2
strMsg = strMsg & "========== saved " & Format(l) & " Bytes as
==========" & strNL
strMsg = strMsg & strDir & objDescription & ".xls"
Case "Bitmap Image" ' PBrush image
ReDim strArr(l) ' Filesize = OLESize
Get #2, , strArr
Close #2
'
Open strDir & objDescription & ".bmp" For Binary As #2
Put #2, , strArr
Close #2
strMsg = strMsg & "========== saved " & Format(l) & " Bytes as
==========" & strNL
strMsg = strMsg & strDir & objDescription & ".bmp"
Case "Picture" ' DIB (images pasted from Clipboard)
Close #2
strMsg = strMsg & "========== saved 0 Bytes ==========" & strNL
strMsg = strMsg & "'Picture' object format still unknown!"
Case "Package" ' JPG, GIF, ...
strMsg = strMsg & "========== PACKAGE-HEADER ==========" & strNL
Get #2, , iStrings
strMsg = strMsg & "Unknown:" & Chr$(9) & Format(iStrings) & strNL
strFilename = ""
Do
Get #2, , strByte
If Asc(strByte) > 0 Then strFilename = strFilename & strByte
Loop Until Asc(strByte) = 0
strMsg = strMsg & "Filename:" & Chr$(9) & strFilename & strNL
strPath = ""
Do
Get #2, , strByte
If Asc(strByte) > 0 Then strPath = strPath & strByte
Loop Until Asc(strByte) = 0
strMsg = strMsg & "Pathname:" & Chr$(9) & strPath & strNL
Get #2, , l
strMsg = strMsg & "Unknown: " & Chr$(9) & Format(l) & strNL
Get #2, , l
strMsg = strMsg & "Unknown: " & Chr$(9) & Format(l) & strNL
strDummy = ""
Do
Get #2, , strByte
If Asc(strByte) > 0 Then strDummy = strDummy & strByte
Loop Until Asc(strByte) = 0
strMsg = strMsg & "Original:" & Chr$(9) & Chr$(9) & strDummy &
strNL
Get #2, , lFileSize
strMsg = strMsg & "Filesize:" & Chr$(9) & Chr$(9) &
Format(lFileSize) & strNL
'
If lFileSize Then
ReDim strArr(lFileSize)
Get #2, , strArr
Close #2
'
strExtention = "" ' get the file-extention
For j = Len(strFilename) To 1 Step -1
strByte = Mid(strFilename, j, 1)
strExtention = strByte & strExtention
If strByte = "." Then j = 0
Next j
Open strDir & objDescription & strExtention For Binary As #2
Put #2, , strArr
Close #2
'
strMsg = strMsg & strNL
strMsg = strMsg & "========== saved " & Format(lFileSize) & "
Bytes as ==========" & strNL
strMsg = strMsg & strDir & objDescription & strExtention
Else
Close #2
strMsg = strMsg & strNL
strMsg = strMsg & "========== saved 0 Bytes ==========" & strNL
strMsg = strMsg & "file is linked to " & strPath
End If
Case Else
Close #2
strMsg = strMsg & "========== saved 0 Bytes ==========" & strNL
strMsg = strMsg & "Unknown object format!"
End Select
'
iAction = MsgBox(strMsg, vbOKOnly, objDescription)
End Sub