Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 3932
  • Last Modified:

How to import/export load and unload PICTURES/OLE Objects from Excel to Access

Problem:
1.      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.

2.      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:
A.      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.
B.      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.
C.      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).

3.      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.

My thanks will go to the many who will have their hand at solving this issue. There are dozens of posts on the web that have went unanswered on this precise issue.
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.

Open in new window

post1.bmp
post2.bmp
0
karlos81
Asked:
karlos81
  • 2
2 Solutions
 
rockiroadsCommented:
Have u a sample xls and db?
0
 
karlos81Author Commented:
@ROCKIROADS: Did you not see that I have attached pictures of the database table and the format in the XLS file ? Please refrain to post if you have nothing new to add !

Now, here is the COMPLETE solution, for which I claim credit. Needless to say I have come up with the solution myself after 7 very stressfull days of which 3 or 4 were spent 'searching' - in vain! - through dedicated XLS&VBA forums. I truly hope my code will help you save some time and effort when trying to load or import excel pictures to and from an access database.

Feel free to use the code and change/optimize it as much as you want. Also if you have questions do not hesitate to post them.


'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 to 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

Open in new window

0
 
rockiroadsCommented:
I asked for a sample xls as you have one with attached pics and in the format you wanted. I also noted no one else made an effort to look into this for you. Well I was trying to help and would of looked into it for you had I got your xls file but obviously you felt I was wasting your time. Not a problem, that is your opinion, we shall leave it at that. But good of you to post your solution, which helps ee and readers of ee in the long run.
0

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now