Startseite / Tipps / VB 5/6-Tipp 0444: ADO Binärdaten in einer DB speichern und wieder auslesen

VB 5/6-Tipp 0444: ADO Binärdaten in einer DB speichern und wieder auslesen

 von ActiveVB

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'-------------- Anfang Projektdatei BLOBs.vbp  --------------
' Es muss ein Verweis auf 'Microsoft ActiveX Data Objects 2.5 Library' gesetzt werden.
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Listen-Steuerelement "lstDateien"
' Steuerelement: Schaltfläche "cmdDelete"
' Steuerelement: Standarddialog-Steuerelement "dlgDialog"
' Steuerelement: Schaltfläche "cmdAddFile"
' Steuerelement: Beschriftungsfeld "lblHinweis"
Option Explicit
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim Doc As ADODB.Stream

Public Sub Aktualisieren()
    On Error Goto Fehler
    lstDateien.Clear
    Rs.MoveFirst
    Do While Not Rs.EOF = True
        lstDateien.AddItem Rs.Fields("Beschreibung").Value
        Rs.MoveNext
    Loop
    Exit Sub
    
Fehler:
    If Err.Number = 3021 Then
        MsgBox "Keine Datensätze vorhanden", vbInformation
    End If
End Sub

Private Sub cmdAddFile_click()
    On Error Goto Fehler
    Set Doc = New ADODB.Stream
    dlgDialog.ShowOpen
    With Doc
        .Type = adTypeBinary
        .Open
        .LoadFromFile dlgDialog.FileName
    End With
    Rs.AddNew
    Rs.Fields("File") = Doc.Read
    Rs.Fields("Beschreibung") = InputBox("Beschreibung;")
    Rs.Update
    Aktualisieren
    Exit Sub
    
Fehler:
    If Err.Number = 32755 Then Exit Sub
End Sub

Private Sub cmdDelete_Click()
    Rs.MoveFirst
    Rs.Move lstDateien.ListIndex
    Rs.Delete
    Rs.Update
    Aktualisieren
End Sub

Private Sub Form_Load()
    Set Cn = New ADODB.Connection
    Set Rs = Nothing
    With Cn
        .Provider = "Microsoft.Jet.OLEDB.3.51"
        .ConnectionString = "Data Source=" & App.Path & "\Tips.mdb"
        .Open
    End With
    Set Rs = New ADODB.Recordset
    With Rs
        .Source = "select Beschreibung, File from tblTips"
        .LockType = adLockOptimistic
        .CursorType = adOpenStatic
        Set .ActiveConnection = Cn
        .Open
    End With
    Aktualisieren
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set Rs = Nothing
    Set Cn = Nothing
    Set Doc = Nothing
End Sub

Private Sub lstDateien_DblClick()
    On Error Goto Fehler
    Set Doc = New ADODB.Stream
    dlgDialog.ShowSave
    With Doc
        .Type = adTypeBinary
        .Open
        Rs.MoveFirst
        Rs.Move lstDateien.ListIndex
        .Write Rs.Fields("File")
        .SaveToFile dlgDialog.FileName
        .Close
    End With
    Exit Sub
    
Fehler:
    If Err.Number = 32755 Then Exit Sub
End Sub

'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'--------------- Ende Projektdatei BLOBs.vbp  ---------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 12 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.