How To Add Images To tblBinary
by admin on Thursday, July 9th, 2020 | No Comments
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.