How To Add Images To tblBinary

I have another post which tells you how you can extract your images from tblBinary (for the custom ribbon), but how do you get them in there in the first place?

When you click “Add file to data base” this happens:

Private Sub AddFile_Click()

   Dim strFile As String

    strFile = "file.jpg"
   
    If strFile <> "" Then
        If AddBinFile(strFile) = True Then
            MsgBox "The file was saved in binary format in table ""tblBinary"" .", vbInformation, "Safe File in data base"
        End If
    End If

End Sub

This is the additional “AddBinFile” code that I got from another German example database:

'Funktion 'AddBinFile' fügt der Tabelle tblBinary die Datei sFileName hinzu.
' Falls die Tabelle nicht existiert wird sie neu angelegt.
' Ergebnis der Funktion ist True bei Erfolg
'***************************************************************************
Function AddBinFile(sFileName As String) As Boolean
Dim f As Integer
Dim arrBin() As Byte
Dim rs As DAO.Recordset
 
    On Error GoTo Errr
 
    'Fehlertests...
    If Not tblBinExists(True) Then Err.Raise vbObjectError + 1, "mdlBinary", _
                                    "Binärtabelle konnte nicht erstellt werden!"
    If Dir(sFileName) = "" Then Err.Raise vbObjectError + 2, "mdlBinary", _
                                    "Datei " & sFileName & "existiert nicht!"
    'Datei einlesen in Byte-Array...
    f = FreeFile
    Open sFileName For Binary As #f
    ReDim arrBin(LOF(f))
    Get #f, , arrBin()
    Close #f
 
    'Byte-Array in Tabelle in Binärfeld abspeichern (> .AppendChunk!)
    Set rs = DBEngine(0)(0).OpenRecordset("tblBinary", dbOpenDynaset)
    rs.AddNew
    rs("FileName") = ExtractFileName(sFileName)
    rs("binary").AppendChunk arrBin()
    rs.Update
    rs.Close
    AddBinFile = True
 
fExit:
    Reset
    Erase arrBin
    Set rs = Nothing
    Exit Function
Errr:
    MsgBox Err.Description
    Resume fExit
End Function

'Hilfsfunktion 'tblBinExists':
'Überprüfen, ob Tabelle "tblBinary" existiert; falls ja, dann Rückgabe: True
'Falls Create=True wird sie erstellt, wenn sie noch nicht existiert
Public Function tblBinExists(Optional Create As Boolean = False) As Boolean
Dim S As String
    On Error Resume Next
    DBEngine(0)(0).TableDefs.Refresh
    S = DBEngine(0)(0).TableDefs("tblBinary").Name
    tblBinExists = (Err.Number = 0)
    If Create And Not tblBinExists Then tblBinExists = CreateBinTable
End Function

'Hilfsfunktion 'ExtractFileName':
'Gibt nur den Dateinamen aus dem vollständige Pfad zurück
Function ExtractFileName(sFilePath As String) As String
Dim n As Long
 
    For n = Len(sFilePath) To 1 Step -1
        If Mid(sFilePath, n, 1) = "\" Then Exit For
    Next n
    ExtractFileName = Mid(sFilePath, n + 1)
 
    'Ab A2000 reicht allein diese Zeile (!):
    'ExtractFileName = Split(sFilePath, "\")(UBound(Split(sFilePath, "\")))
 
End Function

Hope this helps.

Click here to see how to get the existing images out of tblBinary.

By the way, if you got or are getting value from the VBA information, please click the "Donate" button to give me a small token of your appreciation, thanks!