PDA

View Full Version : Solved: LOAD/UNLOAD Pictures from/to Excel <> Access database



alexgiurca
02-17-2009, 12:19 AM
The problem has three steps/stages and can be summed up as:


Loading excel data from excel file – SOLVED SOLVED: open the workbook, read from each sheet the data in the columns and insert the data into the Access database table.


Loading pictures from excel to Access / SQL database – not solved NOT SOLVED – HELP NEEDED: read pictures/ole objects from the excel sheet and store them in the database. This could be achieved in three different ways:

Read and save all pictures from the worksheet into Clipboard and then save them to a specified directory on the disk. Afterwards read the pictures from the predefined location and load them accordingly into the table, using a browse button to select the picture and a load button to actually load it.
Use VBA native function xlsht.Shapes.Item(1).CopyPicture for example. However I have been unable to make it work after 5 days of intense programming. Help is more than welcomed.
Convert the pictures/objects to Excel Charts (or chart background – correct me if I am wrong) and than save those on the HDD and use a browse and load button in Access to store them into the database (similar to solution A).

Inserting loaded pictures from Access/SQL Database back into excel – not solved. NOT SOLVED – HELP NEEDED: do the vice-versa of 2.). For each record in the database insert the picture back into the excel file, at the exact position & size as it was initially read.


What I did so far to solve step 1:


VBA code for button “Load Data from Excel”
Private Sub btnload_Click()
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook
Dim myrec As DAO.Recordset
Set myrec = CurrentDb.OpenRecordset("reportfc")
Set xl = CreateObject("Excel.Application")
Set xlWrkBk = GetObject("C:/Data_Local_old/book1.xls")
Set xlsht = xlWrkBk.Worksheets(5)
myrec.AddNew
myrec.Fields("idrfc") = 1
myrec.Fields("idr") = 1
myrec.Fields("ido") = 1
myrec.Fields("idv") = 0
myrec.Fields("name") = xlsht.Cells(4, "A")
myrec.Fields("tehname") = xlsht.Cells(4, "B")
myrec.Fields("flag_activ") = 1
myrec.Fields("data") = "10.02.2009"
MsgBox xlsht.Shapes.Item(1).Name
'myrec.Fields("file") = xlsht.Shapes.Item("Picture 1") ‘ this does not work…
myrec.Fields("nota") = "no comment!"
myrec.Update
myrec.Close
MsgBox ("Successfully loaded data from excel sheet")
End Sub

Those who wish to use my code to load similar formatted data should be aware to change .Worksheets(5) to .Worksheets(x) , where X is the actual number of the sheet in the workbook.

It would be great if we could solve this issue once and for all 'cause the web is full of posts similar to this one and so far, there hasn't been given any acceptable solution. So: :help :help :help

Kenneth Hobs
02-17-2009, 10:50 AM
Welcome to the forum!

If you can simplify what you need, it would be easier to help. Rather than do a whole project in one thread, try just doing each part. You can always add the link to another thread if it applies.

If you can create a very simple xls and an mdb file, we can go from there. The smaller the files the better. You can attach them to your reply or zip and attach them both in one attachment.

We could write the shapes to their own files. There may be another route using some more involved methods.

alexgiurca
02-20-2009, 01:36 AM
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 :devil2: ).

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! :beerchug:

'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

slamet Harto
02-20-2009, 03:16 AM
hi Alexgiurca

With respect of your tenacity. But I can't wait to see a sample workbook if you ever get finished it, So I can score them up

Bes, Harto

alexgiurca
02-20-2009, 04:00 AM
@Slamet Harto:

Thanks! I have attached a sample. The database file is in Access and the workbook is XLS.

Feel free to play with them.

This was a VERY THOUGH NUT to crack afterwall! Really! :banghead:


Enjoy the sample & praise for my well-being!
:thumb