Hi,
I have a program for storing recipes with photos in an mdb-file. Over the
last 5 years I put about 400 bmp, gif and jpg images into the database.
Unfortunately I did not care about the size so the database grew to 1 Gb.
I don't have access to MS-Access, therefore I tried to replace the images
with smaller copies by using Excel VBA.
Putting together some code with the help of Microsoft's 'How To Read and
Write BLOBs Using GetChunk and AppendChunk' Q194975 I can get data in and
out of the database.

But the new blobs are not displayed! And the exportet Blobs don't have a
file extension! If I add one manually the image still can't be displayed
by Irfanview.

What did I miss?

The program should start with the first record, look for the ID in the
Excel-table, if found, get the path to the Image from this table, write the
file to the database (or the blob to a file) and move to the next record.

Thanks for any ideas.
Willem

PS. I use Win XP Home and Offce 2000
PSS. My code
Attribute VB_Name = "BLOB2MDB"
Option Explicit
Const BLOCK_SIZE = 16384
Dim dbsDATENBANK As ADODB.Connection
Dim rstTABELLE As ADODB.Recordset
Sub Blooooooooooob()
Dim RowXL1 , F, firstREC, lastREC, I, J As Integer
Dim Row_in_XL, StatProz As Long
Dim Datenbank, Tabelle, Statustext As String
Dim arrBin() As Byte
Dim sFileName As String

'-------database path and table name
Datenbank = "F:\Kochen\Rezepte.mdb"
Tabelle = "T_REZ_Kopf"

'--------
Set dbsDATENBANK = New ADODB.Connection
Set rstTABELLE = New ADODB.Recordset


'---open database
With dbsDATENBANK
.CursorLocation = adUseClient
.Mode = adModeReadWrite
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = Datenbank
.Open
End With

'--- open table
Set rstTABELLE.ActiveConnection = dbsDATENBANK
rstTABELLE.LockType = adLockOptimistic
rstTABELLE.Source = "Select * From " & "T_Rez_Kopf" 'whole table
rstTABELLE.Open


Application.ScreenUpdating = False

With rstTABELLE
.MoveFirst 'wirklich am ersten Satz anfangen
lastREC = .RecordCount
firstREC = 1
lastREC = 3000 'for tests

For I = firstREC To lastREC

Row_in_XL = Find_in_XL(.Fields(0)) '(!ID)
If Row_in_XL < 0 Then
'------------
' Switch by commenting this or the other paragraf

'' Edit = write Blob from file to mdb

'sFileName = ActiveCell.Offset(0, RowXL1) 'Path&Filename
'FileToBlob sFileName, rstTABELLE!RezBild, 16384
'.Update

'------------
'write blob from mdb to file

sFileName = "F:\Kochen\Pix\" & .Fields(0) 'file extension???

BlobToFile rstTABELLE!RezBild, sFileName
'------------
End If
'---StatusBar----
j = CInt(I * 100 / lastREC)
StatProz = CStr(j)
Statustext = StatProz & "% erledigt. Satz " & I & "
von " & lastREC
Application.StatusBar = Statustext
'********************

.MoveNext
Next I

End With

Application.ScreenUpdating = True
Application.StatusBar = ""

rstTABELLE.Close
dbsDATENBANK.Close
Set dbsDATENBANK = Nothing 'delete object
End Sub
Function Find_in_XL(ByVal suchID As Variant)
Columns("A:A").Select
On Error GoTo nixDa
Selection.Find(What:=suchID, After:=ActiveCell, LookIn:=xlFormulas,
LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:= _
False).Activate
Find_in_XL = ActiveCell.Row
Exit Function
nixDa:
Find_in_XL = 0
End Function
Sub FileToBlob(ByVal FName As String, fld As ADODB.Field, _
Optional Threshold As Long = 1048576)
'
' Assumes file exists
' Assumes calling routine does the UPDATE
' File cannot exceed approx. 2Gb in size
'


Dim F As Long, Data() As Byte, FileSize As Long
F = FreeFile
Open FName For Binary As #F
FileSize = LOF(F)
Select Case fld.Type
Case adLongVarBinary
If FileSize Threshold Then
ReadToBinary F, fld, FileSize
Else
Data = InputB(FileSize, F)
fld.Value = Data
End If
Case adLongVarChar, adLongVarWChar
If FileSize Threshold Then
ReadToText F, fld, FileSize
Else
fld.Value = Input(FileSize, F)
End If
End Select
Close #F
End Sub

Sub ReadToBinary(ByVal F As Long, fld As ADODB.Field, _
ByVal FileSize As Long)
Dim Data() As Byte, BytesRead As Long
Do While FileSize < BytesRead
If FileSize - BytesRead < BLOCK_SIZE Then
Data = InputB(FileSize - BytesRead, F)
BytesRead = FileSize
Else
Data = InputB(BLOCK_SIZE, F)
BytesRead = BytesRead + BLOCK_SIZE
End If
fld.AppendChunk Data
Loop
End Sub

Sub ReadToText(ByVal F As Long, fld As ADODB.Field, _
ByVal FileSize As Long)
Dim Data As String, CharsRead As Long
Do While FileSize < CharsRead
If FileSize - CharsRead < BLOCK_SIZE Then
Data = Input(FileSize - CharsRead, F)
CharsRead = FileSize
Else
Data = Input(BLOCK_SIZE, F)
CharsRead = CharsRead + BLOCK_SIZE
End If
fld.AppendChunk Data
Loop
End Sub



Sub BlobToFile(fld As ADODB.Field, ByVal FName As String, _
Optional FieldSize As Long = -1, _
Optional Threshold As Long = 1048576)
'
' Assumes file does not exist
' Data cannot exceed approx. 2Gb in size
'
Dim F As Long, bData() As Byte, sData As String
F = FreeFile
Open FName For Binary As #F
Select Case fld.Type
Case adLongVarBinary
If FieldSize = -1 Then ' blob field is of unknown size
WriteFromUnsizedBinary F, fld
Else ' blob field is of known size
If FieldSize Threshold Then ' very large actual data
WriteFromBinary F, fld, FieldSize
Else ' smallish actual data
bData = fld.Value
Put #F, , bData ' PUT tacks on overhead if use fld.Value
End If
End If
Case adLongVarChar, adLongVarWChar
If FieldSize = -1 Then
WriteFromUnsizedText F, fld
Else
If FieldSize Threshold Then
WriteFromText F, fld, FieldSize
Else
sData = fld.Value
Put #F, , sData ' PUT tacks on overhead if use fld.Value
End If
End If
End Select
Close #F
End Sub

Sub WriteFromBinary(ByVal F As Long, fld As ADODB.Field, _
ByVal FieldSize As Long)
Dim Data() As Byte, BytesRead As Long
Do While FieldSize < BytesRead
If FieldSize - BytesRead < BLOCK_SIZE Then
Data = fld.GetChunk(FieldSize - BLOCK_SIZE)
BytesRead = FieldSize
Else
Data = fld.GetChunk(BLOCK_SIZE)
BytesRead = BytesRead + BLOCK_SIZE
End If
Put #F, , Data
Loop
End Sub

Sub WriteFromUnsizedBinary(ByVal F As Long, fld As ADODB.Field)
Dim Data() As Byte, Temp As Variant
Do
Temp = fld.GetChunk(BLOCK_SIZE)
If IsNull(Temp) Then Exit Do
Data = Temp
Put #F, , Data
Loop While LenB(Temp) = BLOCK_SIZE
End Sub

Sub WriteFromText(ByVal F As Long, fld As ADODB.Field, _
ByVal FieldSize As Long)
Dim Data As String, CharsRead As Long
Do While FieldSize < CharsRead
If FieldSize - CharsRead < BLOCK_SIZE Then
Data = fld.GetChunk(FieldSize - BLOCK_SIZE)
CharsRead = FieldSize
Else
Data = fld.GetChunk(BLOCK_SIZE)
CharsRead = CharsRead + BLOCK_SIZE
End If
Put #F, , Data
Loop
End Sub

Sub WriteFromUnsizedText(ByVal F As Long, fld As ADODB.Field)
Dim Data As String, Temp As Variant
Do
Temp = fld.GetChunk(BLOCK_SIZE)
If IsNull(Temp) Then Exit Do
Data = Temp
Put #F, , Data
Loop While Len(Temp) = BLOCK_SIZE
End Sub