Damn it was hard! Hard to find appropriate information, hard to code everything into one piece. I'm a good VB.NET programmer, but I never thought that getting pictures from excel to access would pose such a great problem for so many people (including me, that is 
).
Now, I have modified the table in access so that it has the following fields: REPORTFC(idrfc, idr, ido, idv, nume, numeteh, flag_activ, data, file, nota, imgr, imgh, imgw, imge, imgrh). From excel I will import data into the fields: imgr (row number in excel, like 4 or 5 etc), imgh (image height), imgw (image width), imge (image exist in the row in access table - when you export data back to excel you will not be able to determine if the row in the table will have or not data in the field FILE by using ISNULL(rs!file)!) , imgrh (excel row height - it is different from the height of the image and if we want to maintain the format of the original excel file we need to store this information).
Here is the rest of the code! Feel free to optimize it and change it to meet your purpose. If you have comments please feel free to post them!
Cheers! 
'First make a new project in Access. In the project tree window choose
'INSERT->New Module and paste this code.
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyImage Lib "user32" (ByVal hImage As Long, ByVal uType As Long, ByVal PixelWidth As Long, ByVal PixelHeight As Long, ByVal Flags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pPictDesc As PictDesc, riid As Guid, ByVal fOwn As Long, ppvObj As IPicture) As Long
Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Const BLOCK_SIZE = 16384
Private Const CF_BITMAP = 2
Private Const S_OK As Long = &H0
Private Const LR_COPYRETURNORG = &H4
Function IPictureFromCopyPicture(Source As Object, Optional StretchWidth As Single, Optional StretchHeight As Single) As IPictureDisp
Dim hBmp As Long
Dim PictDesc As PictDesc
Dim IDispatch As Guid
Dim SaveWidth As Single
Dim SaveHeight As Single
Dim PicIsRng As Boolean
If StretchWidth <> 0 Or StretchHeight <> 0 Then
If TypeOf Source Is Range Then
Source.CopyPicture
ActiveSheet.PasteSpecial "Picture (Enhanced Metafile)"
Set Source = Selection
PicIsRng = True
End If
SaveWidth = Source.Width
SaveHeight = Source.Height
Source.Width = IIf(StretchWidth = 0, Source.Width, StretchWidth)
Source.Height = IIf(StretchHeight = 0, Source.Height, StretchHeight)
Source.CopyPicture xlScreen, xlBitmap
If PicIsRng Then
Source.Delete
Else
Source.Width = SaveWidth
Source.Height = SaveHeight
End If
Else
Source.CopyPicture xlScreen, xlBitmap
End If
If OpenClipboard(0) <> 0 Then
hBmp = GetClipboardData(CF_BITMAP)
hBmp = CopyImage(hBmp, 0, 0, 0, LR_COPYRETURNORG)
CloseClipboard
If hBmp <> 0 Then
With IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With PictDesc
.cbSizeofStruct = Len(PictDesc)
.picType = 1
.hImage = hBmp
End With
If OleCreatePictureIndirect(PictDesc, IDispatch, False, IPictureFromCopyPicture) <> S_OK Then
Set IPictureFromCopyPicture = Nothing
End If
End If
End If
End Function
Function SaveObjectPictureToFile(ByVal Source As Object, FileName As String, Optional StretchWidth As Single, Optional StretchHeight As Single) As Boolean
Dim Ipic As IPictureDisp
Set Ipic = IPictureFromCopyPicture(Source, StretchWidth, StretchHeight)
If Not Ipic Is Nothing Then
SavePicture Ipic, FileName
SaveObjectPictureToFile = True
End If
End Function
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
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
Now add a new form or use the wizard to create a form from the table reportfc, which fields have been shown in the original post.
Add the code below to the form. Also add two buttons: one for import and one for export.
Option Compare Database
' Button CMDLOAD will load the data from an EXCEL workbook which has
' 5 sheets. The data will be loaded from the fifth sheet and will
' import 3 rows: name, technical name and picture.
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook
Dim myrec As DAO.Recordset
Dim sho As Shape
Set myrec = CurrentDb.OpenRecordset("reportfc")
Set xl = CreateObject("Excel.Application")
Set xlWrkBk = GetObject("C:/Data_Local_old/book1.xls")
Set xlsht = xlWrkBk.Worksheets(5)
Dim idrfc As Integer, idr As Integer, ido As Integer, idv As Integer
dim i As Integer
Dim r As Long
Dim lastrow As Long, startrow As Long
idrfc = 1
idr = 1
ido = 1
idv = 0
i = 0
startrow = 1
' count the total number of rows in the excel sheet.
With xlsht.UsedRange
lastrow = .Rows.Count + .Row - 1
End With
'start reading the sheet, from the first record and up to the last one
For r = startrow To lastrow
If r > 1 Then
myrec.AddNew
myrec.Fields("idrfc") = idrfc
idrfc = idrfc + 1
myrec.Fields("idr") = idr
myrec.Fields("ido") = ido
myrec.Fields("idv") = idv
myrec.Fields("nume") = xlsht.Cells(r, "A")
myrec.Fields("numeteh") = xlsht.Cells(r, "B")
myrec.Fields("flag_activ") = 1
myrec.Fields("data") = "10.02.2009"
' the field IMGR will keep track of the number of the excel row.
myrec.Fields("imgr") = r
myrec.Fields("imge") = 0
' I use the integer field IMGRH to remember the height of each cell
myrec.Fields("imgrh") = xlsht.Cells(r, "A").Height
myrec.Fields("imgh") = 0
myrec.Fields("imgw") = 0
myrec.Fields("nota") = "no comment!"
myrec.Update
End If
Next r
myrec.Close
' now that we loaded the data into Access, but we STILL do not have any pictures in our OLE OBJECT field FILE, _
we will read each shape in the sheet and we will insert the shape into the database where
Dim sqlcon As String
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim crow As Integer
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
On Error GoTo Except
Set con = New ADODB.Connection
con.Provider = "Microsoft.Jet.OLEDB.4.0"
con.ConnectionString = "data source=C:\Documents and Settings\x01020750\My Documents\SAPBW1.mdb"
con.Mode = adModeReadWrite
con.Open
MsgBox "Connected via " & con.Provider & " OLE DB Provider!", vbInformation
Except:
MsgBox Err.Description, vbCritical
For Each sho In xlsht.Shapes
'because we have stored the number of the EXCEL row in the access table on our first run, now we know _
which row of the table needs to be update. So we will get the SHAPE row and launch a SELECT query to _
determine the correspondent row in the ACCESS database.
crow = sho.TopLeftCell.Row
sqlcon = "SELECT * FROM reportfc WHERE imgr=" & crow
rs.Open sqlcon, con, adOpenKeyset, adLockOptimistic
rs.Update
If Not SaveObjectPictureToFile(sho, "C:\Data_Local\" + sho.Name + ".bmp") Then
MsgBox "Picture was not saved!"
End If
FileToBlob "C:\Data_Local\" + sho.Name + ".bmp", rs!file, 16384
' we need rs!image to keep track of access table rows that have a value in the OLE OBJECT column. Otherwise _
we will get some weird errors if we do something like IF ISNULL(rs!file) then ... when we try to export the data _
back to excel and we obviously need to know if we have (or not) a picture in the table row.
rs!imge = 1
' we keep track of shape Height and Width (with export in mind)
rs!imgh = sho.Height
rs!imgw = sho.Width
rs.Update
rs.Close
Next sho
con.Close
MsgBox ("The import of data from EXCEL has been completed!")
end sub
The Button cmdexport will export the data back to excel. It will also keep the same format used at the time of the import.
Private Sub cmdexport_Click()
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook
Set xlWrkBk = Workbooks.Add
xlWrkBk.Worksheets.Add
xlWrkBk.Worksheets.Add
xlWrkBk.Worksheets(1).Name = "GENERAL"
xlWrkBk.Worksheets(2).Name = "ROWS"
xlWrkBk.Worksheets(3).Name = "COLUMNS"
xlWrkBk.Worksheets(4).Name = "FILTER"
xlWrkBk.Worksheets(5).Name = "FREE"
' apply some formatting for xls sheet - Model
Set xlsht = xlWrkBk.Worksheets(5)
xlsht.Cells(1, "A") = "NAME"
xlsht.Cells(1, "A").Font.Bold = True
xlsht.Cells(1, "A").Font.size = 14
xlsht.Cells(1, "A").HorizontalAlignment = xlCenter
xlsht.Cells(1, "B") = "TECHNICAL"
xlsht.Cells(1, "B").Font.Bold = True
xlsht.Cells(1, "B").Font.size = 14
xlsht.Cells(1, "B").HorizontalAlignment = xlCenter
xlsht.Cells(1, "C") = "IMAGE"
xlsht.Cells(1, "C").Font.Bold = True
xlsht.Cells(1, "C").Font.size = 14
xlsht.Cells(1, "C").HorizontalAlignment = xlCenter
xlsht.Columns(1).ColumnWidth = 40
xlsht.Columns(2).ColumnWidth = 55
xlsht.Columns(3).ColumnWidth = 70
xlsht.Rows(1).RowHeight = 22
' Now I will read from the table REPORTFC and export to ONE excel sheet
Dim sqlcon As String
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim shp As Shape
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
Dim col As Integer, size As Integer, size2 As Integer, zece As Integer
Dim shpnr As Integer
Set con = New ADODB.Connection
con.Provider = "Microsoft.Jet.OLEDB.4.0"
con.ConnectionString = "data source=C:\Documents and Settings\x01020750\My Documents\SAPBW1.mdb"
con.Mode = adModeReadWrite
con.Open
sqlcon = "SELECT * FROM reportfc where idr=1"
rs.Open sqlcon, con, adOpenStatic, adLockReadOnly
shpnr = 0
zece = 0
size = xlsht.Cells(1, "A").Height + 1
rs.MoveFirst
Do While Not rs.EOF
col = rs!imgr
xlsht.Cells(col, "A") = rs!nume
xlsht.Cells(col, "B") = rs!numeteh
xlsht.Rows(col).RowHeight = rs!imgrh
If rs!imge = 1 Then
If shpnr = 0 Then
size2 = xlsht.Cells(1, "C").Width / 0.75 + 12
End If
' export the picture using the function BlobToFile to a temporary
' HDD location. Then I use XLSHT.SHAPES.ADDPICTURE to load the
' picture into the excel sheet. Variable Size will keep track of the
' height for each cell so that the excel file will have the same
' formatting (looks) as the original one.
BlobToFile rs!file, "C:\Data_Local\picexport.bmp"
MsgBox "Size:" & (size)
xlsht.Shapes.AddPicture "C:\Data_Local\picexport.bmp", True, True, Left:=size2, Top:=size, Width:=rs!imgw, Height:=rs!imgh
shpnr = shpnr + 1
End If
size = size + rs!imgrh
rs.MoveNext
Loop
rs.Close
con.Close
' end of export sequence
xlWrkBk.SaveAs FileName:="C:/Data_Local/test.xls"
xlWrkBk.Close
MsgBox "Export was successfull!"
End Sub
LOAD/UNLOAD Pictures from/to Excel <> Access database
Reply With Quote
