Here’s an interesting way to insert binary data to an OLEObject field in a Microsoft Access (.accdb) database using a combination of ADOX/ADODB and .NET with a LibreOffice Basic project.
The whole story in the video
REM ***** BASIC *****
Option VBASupport 1
Private Const adTypeBinary = 1
Private Const adParamInput = 1
Private Const adLongVarBinary = 205
Private Const adVarChar = 200
Private localFile As String
Private Records() As String
Global oDlg As Object
Private oList As Object
Private DataBasePath As String
Private Running As Boolean
Private ReadRunning As Boolean
Private oListenerTop As Object
Private oController As Object
Private oDock As Object
Sub StartToWork
If Running Then Exit Sub
Running = True
oDoc = ThisComponent
oController = ThisComponent.CurrentController
oDoc.lockControllers
If ThisComponent.hasLocation() Then ThisComponent.store()
ThisComponent.setModified(False)
Dim filepicker As Object
filepicker = createUnoService("com.sun.star.ui.dialogs.FilePicker")
filepicker.setDisplayDirectory(Left(thisComponent.URL, InStrReverse(thisComponent.URL, "/") - 1))
filepicker.appendFilter("Images (*.jpg; *.png; *.gif; *.bmp; *.tiff)", "*.jpg;*.jpeg;*.png;*.gif;*.bmp;*.tiff")
filepicker.appendFilter("RTF (*.rtf)", "*.rtf")
filepicker.appendFilter("ZIP (*.zip)", "*.zip")
filepicker.setCurrentFilter("Images (*.jpg; *.png; *.gif; *.bmp; *.tiff)")
filepicker.setMultiSelectionMode(False)
If filepicker.Execute = com.sun.star.ui.dialogs.ExecutableDialogResults.OK Then
sFileArray = filepicker.getFiles()
localFile = ConvertFromUrl(sFileArray(0))
Else
MsgBox "Canceled by the user","48","System"
Running = False : Exit Sub
End If
Dim sURL$, basePath$, filePath$, dbPath$
sURL = ConvertFromUrl(thisComponent.URL)
basePath = Left(sURL, InStrRev(sURL, "\"))
filePath = localFile
dbPath = basePath & "AdoBase.accdb"
DataBasePath = dbPath
If Dir(dbPath) = "" Then
CreateDatabase dbPath
End If
InsertData dbPath, localFile
Running = False
End Sub
Sub ReadAdoBase()
Dim sURL$, basePath$, filePath$, dbPath$
sURL = ConvertFromUrl(thisComponent.URL)
basePath = Left(sURL, InStrRev(sURL, "\"))
filePath = localFile
dbPath = basePath & "AdoBase.accdb"
oDoc = ThisComponent
oController = ThisComponent.CurrentController
oDoc.lockControllers
If ThisComponent.hasLocation() Then ThisComponent.store()
ThisComponent.setModified(False)
If Dir(dbPath) <> "" Then
oDlg = CreateUnoDialog(DialogLibraries.Standard.Dialog1)
oList = oDlg.getControl("ListBox1")
oListenerTop = createUnoListener("TopListen_", "com.sun.star.awt.XTopWindowListener")
oDlg.addTopWindowlistener(oListenerTop)
oDlg.getControl("ListBox1").Model.StringItemList = Records
lTick = GetSystemTicks()
DoEvents
Do
If GetSystemTicks() > lTick + 500 Then Exit Do
Loop
CenterDialog
ReadFromDb dbPath
Else
DIm yesno As Integer
yesno = MsgBox("File " & dbPath & "does not exists." & chr(10) & _
"Do you want to create a new database file?", vbYesNo, "AdoBase")
Running = False
If yesno = 6 Then StartToWork
End If
Running = False
End Sub
Sub CreateDatabase(dbPath As String)
Dim cat As Object
Dim connstr As String
If Dir(dbPath) <> "" Then Kill dbPath
Set cat = CreateObject("ADOX.Catalog")
connstr = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & dbPath & ";Jet OLEDB:Database Password=" & Chr(34) & chr(34) & ";"
cat.Create connstr
Set cat = Nothing
Dim conn As Object
Set conn = CreateObject("ADODB.Connection")
conn.Open connstr
Dim sql As String
sql = "CREATE TABLE TABLE1 (Id LONG IDENTITY(1,1) PRIMARY KEY, File TEXT(255) NOT NULL, Data OLEObject NULL);"
conn.Execute sql
conn.Close
Set conn = Nothing
End Sub
Sub InsertData(dbPath As String, filePath As String)
Dim conn As Object, connstr As String, sql As String
Set conn = CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & dbPath & ";"
conn.Open connstr
Dim fName As String, size
fName = Replace(filePath, Left(filePath, InStrReverse(filePath, "\")), "")
size = 255
Dim cmd As Object
Set cmd = CreateObject("ADODB.Command")
cmd.ActiveConnection = conn
cmd.Prepared = True
cmd.CommandText = "INSERT INTO TABLE1 (File) VALUES (?)"
cmd.Parameters.Append cmd.CreateParameter("File", adVarChar, adParamInput, size, fName)
cmd.Execute
Set cmd = Nothing
conn.Close
Set conn = Nothing
Dim myNetBlob As Object, result As String
myNetBlob = CreateObject("NetOleBlob.helper")
result = myNetBlob.WriteBlob(dbPath, "TABLE1", "Data", filePath)
End Sub
Sub ReadFromDb(dbPath As String)
If ReadRunning Then Exit Sub
ReadRunning = True
sURL = ConvertFromUrl(thisComponent.URL)
basePath = Left(sURL, InStrRev(sURL, "\"))
filePath = localFile
dbPath = basePath & "AdoBase.accdb"
Dim conn As Object, connstr As String, sql As String
Set conn = CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & dbPath & ";Jet OLEDB:Database Password=" & Chr(34) & chr(34) & ";"
conn.Open connstr
Dim rs As Object, dbData()
Set rs = CreateObject("ADODB.Recordset")
sql = "SELECT File, Data FROM TABLE1;"
rs.Open sql, conn, 3, 3, 1
If rs.RecordCount > -1 Then
ReDim Records()
Dim rCount As Long, i As Long, lst As String
rCount = rs.RecordCount - 1
lst = Chr(10)
rs.MoveFirst
For i = 0 To rCount
If Not rs.EOF Then
lst = lst & rs.Fields.Item("File").Value
if i < rCount Then lst = lst & Chr(10)
Else
Exit For
End If
rs.MoveNext
Next i
Else
MsgBox "There is no records in database", "48", "System"
Exit Sub
End If
rs.Close : Set rs = Nothing
conn.Close : Set conn = Nothing
Records = Split(lst, Chr(10))
oList.Model.StringItemList = Records
oDlg.execute()
ReadRunning = False
End Sub
Sub TopListen_windowOpened
End Sub
Sub TopListen_windowClosed
oDlg.dispose
End Sub
Sub TopListen_windowMinimized
End Sub
Sub TopListen_windowClosing
Running = False
ReadRunning = False
oDlg.removeTopWindowListener(oListenerTop)
oListenerTop = Nothing
oDlg.endexecute
End Sub
Sub TopListen_windowNormalized
End Sub
Sub TopListen_windowActivated
End Sub
Sub TopListen_windowDeactivated
End Sub
Sub TopListen_disposing
End Sub
Sub CenterDialog
Dim oSize As New com.sun.star.awt.Size, factor As Double
Dim oCC, oComponentWindow, oTopWindowPosSize
oCC = ThisComponent.getCurrentController()
oComponentWindow = oCC.ComponentWindow
oTopWindowPosSize = oComponentWindow.Toolkit.ActiveTopWindow.getPosSize()
oSize.Width = oDlg.Model.Width
oSize.Height = oDlg.Model.Height
factor = oSize.Width / oDlg.convertSizeToPixel(oSize, com.sun.star.util.MeasureUnit.APPFONT).Width
With oDlg.Model
.PositionX = (factor * oTopWindowPosSize.Width - .Width) / 2
.PositionY = (factor * oTopWindowPosSize.Height - .Height) / 1.75
End With
End Sub
Sub ListBoxStateCahnged(oEvent)
If oEvent.Source.SelectedItems(0) <> "" Then
sURL = ConvertFromUrl(thisComponent.URL)
basePath = Left(sURL, InStrRev(sURL, "\"))
dbPath = basePath & "AdoBase.accdb"
Dim dbfName As String, sql As String
dbfName = oEvent.Source.SelectedItems(0)
Dim conn As Object, connstr As String
sql = "SELECT File, Data FROM TABLE1 Where File = '" & dbfName & "';"
Set conn = CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & dbPath & ";Jet OLEDB:Database Password=" & Chr(34) & Chr(34) & ";"
conn.Open connstr
Dim rs As Object, dbData()
Set rs = CreateObject("ADODB.Recordset")
rs.Open sql, conn, 3, 3, 1
If Not rs.BOF Then rs.MoveFirst
Dim fName As String, ext As String, pos
fName = rs.Fields.Item("File").Value
sURL = ConvertFromUrl(thisComponent.URL)
basePath = Left(sURL, InStrRev(sURL, "\"))
filePath = basePath & fName
ext = Replace(fName, Left(fName, InStrReverse(fName, ".") -1), "")
Dim fName2 As String
fName2 = Replace(fName, ext, "")
fName2 = fName2 & "2" & ext
Dim sFilePath As String
sFilePath = Replace(filePath, fName, fName2)
If Dir(sFilePath) <> "" Then Kill sFilePath
Do While Dir(sFilePath) <> "" : Loop
On Error Goto ErrorHandler
Dim oInstream As Object, fileBytes() As Byte
oInstream = com.sun.star.io.SequenceInputStream.createStreamFromSequence(rs.Fields.Item("Data").Value)
oInstream.readBytes(fileBytes, oInstream.getLength())
oInstream = Nothing
Dim sfa As Object, oOut As Object
sfa = createUnoService("com.sun.star.ucb.SimpleFileAccess")
oOut = sfa.openFileWrite(sFilePath)
oOut.writeBytes(fileBytes)
rs.Close : Set rs = nothing
conn.Close : Set conn = Nothing
Do While(sFilePath) = "" : Loop
Dim oShellExe As Object
oShellExec = CreateUnoService("com.sun.star.system.SystemShellExecute")
oShellExec.execute(sFilePath, "", 0)
oShellExec = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Description
Err.Clear
End If
End Sub
Function InStrReverse(sText As String, search As String) As Long
If sText = "" Or search = "" Or Len(search) > Len(sText) Then
InStrReverse = 0
Exit Function
End If
Dim i As Long
For i = Len(sText) To 1 Step -1
If Mid(sText, i, Len(search)) = search Then
InStrReverse = i : Exit Function
End If
Next i
End Function
Sub OnClose
ThisComponent.setModified(False)
End Sub
AdoBaseWithNetBlob.odt (22.1 KB)
To get this working you need to follow these instructions
The project with test files can be downloaded here
