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.

Darum hier ein 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
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
'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, 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
'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 = 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 'CreateBinTable':
'Erzeugen der Tabelle 'tblBinary'
'Rückgabe: True bei Erfolg
Private Function CreateBinTable() As Boolean
Dim dbs As DAO.Database
Dim strSQL As String
  On Error GoTo Errr
 
  strSQL = "CREATE TABLE tblBinary (ID COUNTER CONSTRAINT ID PRIMARY KEY, " & _
           "FileName CHAR(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:
    Set dbs = Nothing
    Exit Function
Errr:
    Resume fExit
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

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:\ wiederherstellen
    RestoreBinFile "msjet40.dll", "c:\", True
    '...Das Ganze ist also quasi eine Kopierfunktion ;-)
 
End Sub