Write Data (including and image) to a database record

[gmaxey]

Hi,

I do a lot of coding in Microsoft Word, but my skills working with Access and databases is very limited. This may not be the best forum for my question, but not knowing better here goes:

I have a very simple Access database file which has two tables (Table1 and Table2). Each table has three fields "Field1, Field2 and Field3" In both tables "Field1 and Field2" is set as short text. In Table Field3 is short text. In Table2 Field 3 is OLE Object.

I have been able to export or write to Table1 text to Fields1 2 and 3. Specifically an image file path to Field3. What I can't figure out how to do is export an image file path and have it appear in Table2 Field3 as the actual image.

I have succeeded in creating a Binary stream from the file path. That I where I am now stuck.

Here is my code. The code is in a standard module of a Word document. The document, image file and database are all in the same folder and contained in the attached zip file:


Sub ExportToAccess()
Dim varData(2)
Dim oStream As Object
varData(0) = "Text"
varData(1) = "More Text"
varData(2) = ThisDocument.Path & "\Sample Picture.png"
'Write data to Table1 all fields are "Short Text"
WriteToAccess ThisDocument.Path & "\Demo DataBase.accdb", "Table1", varData
'Convert the image file to a binary stream
Set oStream = CreateObject("ADODB.Stream")
oStream.Type = 1 'adTypeBinary
oStream.Open
oStream.LoadFromFile varData(2)
varData(2) = oStream.Read
oStream.Close
Set oStream = Nothing
On Error GoTo Err_Write
'Try to write text data and image to Table 2. In Table2 Field3 is OLE Object
WriteToAccess ThisDocument.Path & "\Demo DataBase.accdb", "Table2", varData
lbl_Exit:
Exit Sub
Err_Write:
MsgBox Err.Number & " " & Err.Description
MsgBox "The issue of coures is the binary stream consists of " & UBound(varData(2)) & " long values (not a string)."
Resume lbl_Exit
End Sub

Sub WriteToAccess(strDB_Path As String, strTable_Name As String, varRecordData)
Dim oConn As Object
Dim strConnection As String, strSQL As String

strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB_Path & ";"
'Establish connection.
Set oConn = CreateObject("ADODB.Connection") 'New ADODB.Connection
With oConn
.Open strConnection
strSQL = fcnGetRecordStrSQL(strTable_Name, varRecordData)
.Execute strSQL
End With
Cleanup:
oConn.Close
Set oConn = Nothing
lbl_Exit:
Exit Sub
End Sub

Function fcnGetRecordStrSQL(strTableName As String, varData) As String
Dim strField_Headings As String
Dim m_strDataField_Name As String, strField_Values As String
Dim lngIndex As Long
'Dim strLinkPath As String
Dim strCC_Data As String

'Initialize SQL statement variable values.
strField_Headings = ""
strField_Values = ""
For lngIndex = 0 To UBound(varData)
Select Case lngIndex
Case 0: m_strDataField_Name = "Field1"
Case 1: m_strDataField_Name = "Field2"
Case 2: m_strDataField_Name = "Field3"
End Select
'Adapt string to acount for any spaces.
If InStr(m_strDataField_Name, " ") > 0 Then m_strDataField_Name = "[" & m_strDataField_Name & "]"
'Get field data
strCC_Data = varData(lngIndex)
'Build SQL statement.
Select Case lngIndex
Case Is = UBound(varData) ' - 1
strField_Headings = strField_Headings & m_strDataField_Name
strField_Values = strField_Values & "'" & strCC_Data & "'"
Case Else
strField_Headings = strField_Headings & m_strDataField_Name & ", "
strField_Values = strField_Values & "'" & strCC_Data & "'" & ", "
End Select
Next lngIndex
fcnGetRecordStrSQL = "INSERT INTO " & strTableName & " (" & strField_Headings & ") VALUES (" & strField_Values & ")"
lbl_Exit:
Exit Function
End Function

I am fairly certain a big part of the issue is strSQL as String and big chunk of binary data. I just don't know what I need to do.

Thanks.