Hello Quartz
I hope this help you
Option Explicit
Public Const BLOCK_SIZE = 10000
Public Cn As New ADODB.Connection
Sub exportGraphic()
'**************************************************
'adapted from source :
http://www.vbfrance.com/code.aspx?ID=26014
'**************************************************
'
Dim Rs As New ADODB.Recordset
Dim Pict As Picture
Dim FichierTemp As String
Dim Nb As Byte
FichierTemp = ThisWorkbook.Path & "\PictTemp.jpg"
On Error GoTo ShowError:
Set Pict = ActiveSheet.Pictures(1) 'graphical object : first picture in
sheets(1)
Pict.CopyPicture ' copy
With ActiveSheet.ChartObjects.Add(0, 0, Pict.Width, Pict.Height).Chart
' create temporary chart
..Paste 'paste in the chart
..Export FichierTemp, "JPG" ' save temporary jpg file on disk
End With
Nb = ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(Nb).Delete 'delete temporary chart
'export jpg temporary file in a Access database named "Images"
'for this example you need 3 fields in the dataBase :
'PicId ( numeric data )
'FieldName ( binay data )
'PicSize (numeric data)
Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& "C:\Images.mdb"
Rs.CursorLocation = adUseClient
Rs.Open "Select * From Pictures", Cn, adOpenDynamic, adLockOptimistic
With Rs
..AddNew
!PicId = .RecordCount
exportImage FichierTemp, Rs, "Pic", "PicSize"
..Update
End With
Rs.Close
Cn.Close
MsgBox "Image Saved"
Kill FichierTemp 'delete temporary jpg file
Exit Sub
ShowError:
MsgBox Err.Description
End Sub
Public Sub exportImage(filename As String, rstMain As Recordset, _
FieldName As String, SizeField As String)
Dim file_num As String
Dim file_length As Long
Dim bytes() As Byte
Dim num_blocks As Long, left_over As Long, block_num As Long
On Error GoTo Handler
file_num = FreeFile
Open filename For Binary Access Read As #file_num
file_length = LOF(file_num)
If file_length > 0 Then
num_blocks = file_length / BLOCK_SIZE
left_over = file_length Mod BLOCK_SIZE
rstMain(SizeField) = file_length
ReDim bytes(BLOCK_SIZE)
For block_num = 1 To num_blocks
Get #file_num, , bytes()
rstMain(FieldName).AppendChunk bytes()
Next block_num
If left_over > 0 Then
ReDim bytes(left_over)
Get #file_num, , bytes()
rstMain(FieldName).AppendChunk bytes()
End If
Close #file_num
End If
Exit Sub
Handler:
MsgBox Err.Description
End Sub
Regards ,
michel