How to get the images out of tblBinary

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.

Read this for how to get the images into 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: ,