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
    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("FileName") = ExtractFileName(sFileName)
    rs("binary").AppendChunk arrBin()
    AddBinFile = True
    Erase arrBin
    Set rs = Nothing
    Exit Function
    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
    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.

Offsite Related Information:

“Go Fund Me” Page

($5 suggested amount)

(…10% of your gift amount will go to charity)

Free! Subscribe To Our YouTube Channel!

Free MS Access VBA Programming Course

Facebooktwitterredditpinterestlinkedinmailby feather
Tags: ,