VBA Tipp: Binär-Daten speichern

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Es gibt eine gewisse Scheu, in Access-Datenbanken binäre Daten abzuspeichern.

Dabei kann das recht nützlich sein. Die wahrscheinlich häufigste Anwendung ist das Abspeichern von Bilddateien, ohne die Datenbank aufzublähen. Möglicherweise liegt es daran, dass die entsprechenden Methoden (GetChunk, AppendChunk) relativ unbekannt sind, und sich selten in Codebeispielen finden.

Lösung

Beispiel für ein Modul, das allgemein verwendbar ist.

Option Compare Database
Option Explicit
 
'Funktion 'AddBinFile': Fügt der Tabelle tblBinary (s.u.)
'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
 
   'Quelle: www.dbwiki.net oder www.dbwiki.de
 
   Dim fNum     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) = vbNullString Then _
      Err.Raise vbObjectError + 2, "mdlBinary", _
                "Datei " & sFileName & "existiert nicht!"
 
   'Datei einlesen in Byte-Array...
   fNum = FreeFile()
   Open sFileName For Binary As fNum
   ReDim arrBin(LOF(fNum))
   Get #fNum, , arrBin
   Close fNum
 
   '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
 
'Funktion 'RestoreBinFile': Stellt eine Datei aus der
'Binär-Tabelle wieder her.
'sFileName ist Dateiname (ohne Pfad).
'sPath ist das Verzeichnis, in dem die Datei
'wiederhergestellt werden soll.
'Overwrite ist optional und standardmäßig True,
'd.h. eine bereits existierende Datei gleichen Namens
'wird überschrieben.
'Ergebnis der Funktion ist True bei Erfolg
Function RestoreBinFile(sFileName As String, sPath As String, _
                        Optional Overwrite As Boolean = True) As Boolean
 
   'Quelle: www.dbwiki.net oder www.dbwiki.de
 
   Dim fNum     As Integer
   Dim lSize    As Long
   Dim arrBin() As Byte
   Dim rs       As DAO.Recordset
 
   On Error GoTo Errr
 
   If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
 
   If Not tblBinExists Then _
      Err.Raise vbObjectError + 3, "mdlBinary", _
                "Binärtabelle 'tblBinary' existiert nicht in dieser Datenbank!"
   If Dir(sPath, vbDirectory) = vbNullString Then _
      Err.Raise  vbObjectError + 4, "mdlBinary", _
                 "Verzeichnis " & sPath & " existiert nicht!"
   If (Dir(sPath & sFileName) <> vbNullString) 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)
      fNum = FreeFile()
      Open sPath & sFileName For Binary As fNum
      Put #fNum, , arrBin
      Close fNum
   End If
   rs.Close
   RestoreBinFile = 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
Private Function tblBinExists(Optional Create As Boolean) As Boolean
   Dim tmp As String
 
   On Error Resume Next
 
   DBEngine(0)(0).TableDefs.Refresh
   tmp = DBEngine(0)(0).TableDefs("tblBinary").Name
   tblBinExists = CBool(Err.Number = 0)
   If Create And Not tblBinExists Then tblBinExists = CreateBinTable
End Function
 
'Hilfsfunktion 'CreateBinTable':
'Erzeugen der Tabelle 'tblBinary'
'Rückgabe: True bei Erfolg
Private Function CreateBinTable() As Boolean
   Dim strSQL As String
 
   On Error GoTo Errr
 
   strSQL = "CREATE TABLE tblBinary (ID COUNTER CONSTRAINT ID PRIMARY KEY, " & _
            "FileName VARCHAR(255) NOT NULL, [binary] IMAGE NOT NULL)"
   DBEngine(0)(0).Execute strSQL
 
   'Die Tabelle enthält nun die Felder:
   ' ID (Autowert, pKey) | FileName (Text 255) | binary (OLE-Feld)
   DBEngine(0)(0).TableDefs.Refresh
 
   'Der folgende Block bzw. einzelne Elemente ist/sind optional...
    With DBEngine(0)(0).TableDefs("tblBinary")
      .Fields("FileName").Properties.Append _
         .Fields("FileName").CreateProperty("UnicodeCompression", dbBoolean, True)
      .Properties.Append .CreateProperty("DatasheetFontName", dbText, "Arial")
      .Properties.Append .CreateProperty("DatasheetFontHeight", dbInteger, 8)
      '...Tabelle ist versteckt! '(Nur sichtbar mit Option 'Systemobjekte',
      'kann aber auch dann nicht editiert werden!)
      .Attributes = dbSystemObject
   End With
   CreateBinTable = True
 
fExit:
    Exit Function
 
Errr:
   Resume fExit
End Function
 
'Hilfsfunktion 'ExtractFileName':
'Gibt nur den Dateinamen aus dem vollständige Pfad zurück
#Const ACC97 = 0  'für Access Version 97 auf 1 setzen
Public Function ExtractFileName(sFilePath As String) As String
#If ACC97 Then
   Dim n As Long
 
   For n = Len(sFilePath) To 1 Step -1
      If Mid$(sFilePath, n, 1) = "\" Then Exit For
   Next
   ExtractFileName = Mid$(sFilePath, n + 1)
#Else
   'Ab A2000 reicht allein diese Zeile (!):
   ExtractFileName = Split(sFilePath, "\")(UBound(Split(sFilePath, "\")))
#End If
End Function

Aufruf

Eine Routine, die den Einsatz der beiden Funktionen verdeutlicht:

Sub TestBinaryStorage()
 
   'Die Datei msjet40.dll in die Datenbank einlesen und binär speichern
   AddBinFile "c:\winnt\system32\msjet40.dll"
 
   'Datei msjet40.dll aus Binärtabelle im Verzeichnis c:\temp wiederherstellen
   RestoreBinFile "msjet40.dll", "c:\temp", True
 
   '...Das Ganze ist also quasi eine Kopierfunktion ;-)
 
End Sub