How to get the images out of tblBinary
by admin on Thursday, July 9th, 2020 | No Comments
The custom ribbon uses the tblBinary to store images, but how do you get them out, if you want to use the nice images again for something else like a webpage toolbar?
How to get the images out of tblBinary
Well this code will loop the tblBinary table and save each image to the specified folder:
Sub SaveImages() 'How to get the images out of tblBinary Dim rst As Recordset Dim strOrdner As String Dim strSelectFile As String Set rst = CurrentDb.OpenRecordset("SELECT FileName FROM tblBinary") strOrdner = "C:\a\_toolbar images\" Do Until rst.EOF strSelectFile = rst.Fields(0) If strSelectFile <> "" Then If strOrdner <> "" Then If RestoreBinFile(strSelectFile, strOrdner) = True Then MsgBox "The file """ & strSelectFile & """ was saved in """ & strOrdner & """ .", vbInformation, "Save File" End If End If End If rst.MoveNext Loop rst.Close Set rst = Nothing End Sub 'This code actually came from a database at this link: https://www.accessribbon.de/en/?Downloads:25 Function RestoreBinFile(sFileName, sPath As String, Optional Overwrite As Boolean = True) As Boolean Dim F As Integer Dim LSize As Long Dim arrBin() As Byte Dim rs As DAO.Recordset On Error GoTo Errr If Not tblBinExists Then Err.Raise vbObjectError + 3, "mdlBinary", _ "Binärtabelle 'tblBinary' existiert nicht in dieser Datenbank!" If Right(sPath, 1) <> "\" Then sPath = sPath & "\" If Dir(sPath, vbDirectory) = "" Then Err.Raise vbObjectError + 4, "mdlBinary", _ "Verzeichnis " & sPath & " existiert nicht!" If (Dir(sPath & sFileName) <> "") And Not Overwrite Then Err.Raise vbObjectError + 4, _ "mdlBinary", "Datei " & sFileName & " existiert bereits!" Set rs = DBEngine(0)(0).OpenRecordset("tblBinary", dbOpenDynaset) rs.FindFirst "[FileName]='" & sFileName & "'" If rs.NoMatch Then Err.Raise vbObjectError + 5, "mdlBinary", _ "Das Binär-File " & sFileName & " existiert nicht in der Tabelle 'tblBinary!'" Else LSize = rs.Fields("binary").FieldSize ReDim arrBin(LSize) arrBin = rs.Fields("binary").GetChunk(0, LSize) F = FreeFile Open sPath & sFileName For Binary As #F Put #F, , arrBin Close #F End If rs.Close RestoreBinFile = True fExit: Reset Erase arrBin Set rs = Nothing Exit Function Errr: MsgBox Err.Description Resume fExit End Function
Let me know if you have any questions.