Private Function SavePicture() As String
Dim adStr     As ADODB.Stream
Dim rsDBase   As ADODB.Recordset
Dim sFileName As String
 
  Set adStr = New ADODB.Stream
  Set rsDBase = New ADODB.Recordset
 
  sSql = ""
  sSql = sSql & " SELECT sFileName, olePicture"
  sSql = sSql & " FROM Bilder"
  sSql = sSql & " WHERE ID = " & lstPictures.ItemData(lstPictures.ListIndex)
  Call rsDBase.Open(sSql, goConn, , adLockReadOnly)
 
  With adStr
    .Type = adTypeBinary
    .Open
    ' Dateiname übernehmen
    sFileName = App.Path & "\" & rsDBase.Fields("sFileName")
    ' Bild in Programmverzeichnis mit entsprechendem Namen abspeichern
    Call .Write(rsDBase.Fields("olePicture"))
    Call .SaveToFile(sFileName)
  End With
 
  SavePicture = sFileName
 
  adStr.Close
 
End Function

Private Sub SavePic2DB(ByVal sFile As String) ' In sFile steht der Komplette 
' Pfad drin (z.B.: C:\Temp\Bild1.jpg)
Dim adStr     As ADODB.Stream
Dim rsDBase   As ADODB.Recordset
Dim sFileName As String
 
  Set adStr = New ADODB.Stream
  Set rsDBase = New ADODB.Recordset
 
  ' Dateiname herausfiltern
  sFileName = ExtractFullFileName(sFile)
 
  sSql = ""
  sSql = sSql & " SELECT TOP1 *"
  sSql = sSql & " FROM Bilder"
  Call rsDBase.Open(sSql, goConn, , adLockOptimistic)
 
  With adStr
    .Type = adTypeBinary
    .Open
  End With
 
  With rsDBase
    .AddNew
    ' Dateiname abspeichern
    .Fields("sFileName") = sFileName
    ' Bild in DB speichern
    Call adStr.LoadFromFile(sFile)
    .Fields("olePicture").Value = adStr.Read
    .Update
  End With
  adStr.Close
 
End Sub
 
 
Private Function ExtractFullFileName(ByVal sFile As String) As String
Dim i               As Integer
 
  For i = 1 To Len(sFile)
    If InStr(1, Right$(sFile, i), "\") <> 0 Then
      ExtractFullFileName = Right$(sFile, i - 1)
      Exit Function
    ElseIf InStr(1, sFile, "\") = 0 Then
      ExtractFullFileName = sFile
      Exit Function
    End If
  Next i
 
End Function