Lire/ecrire dans des champs binaires

Commenter

Contenu du snippet

Dans une DB, on peut trouver des champs Image, OLE, Text, NText, ... Bref, tout ce qu'il faut pour sauver une image, un fichier complet. Mais le problème auquel j'ai été confronté est qu'il n'était pas facile de récupérer ni d'assigner la valeur de façon simple.

Ce Code ne possède que deux fonctions publiques: BlobToFile (qui sauve la valeur du champs dans un fichier, pour pouvoir le réutiliser) et FileToBlob (qui sauve le contenu d'un fichier dans un champs)

Ce code n'a pas été écrit à la sueur de mon front, je l'ai trouvé dans la Knowledge Base de Microsoft.

Source / Exemple : 


Const BLOCK_SIZE = 16384

Public Sub BlobToFile(ByRef Fld As ADODB.Field, _
                      ByVal FName As String, _
                      Optional FieldSize As Long = -1, _
                      Optional Threshold As Long = 1048576)
Dim F As Long
Dim bData() As Byte
Dim sData As String
  
  ' Assumes file does not exist
  ' Data cannot exceed approx. 2Gb in size
  
  F = FreeFile
  Open FName For Binary As #F
  Select Case Fld.Type
  Case adLongVarBinary
    If FieldSize = -1 Then   ' blob field is of unknown size
      WriteFromUnsizedBinary F, Fld
    Else                     ' blob field is of known size
      If FieldSize > Threshold Then   ' very large actual data
        WriteFromBinary F, Fld, FieldSize
      Else                            ' smallish actual data
        bData = Fld.Value
        Put #F, , bData  ' PUT tacks on overhead if use fld.Value
      End If
    End If
  Case adLongVarChar, adLongVarWChar
    If FieldSize = -1 Then
      WriteFromUnsizedText F, Fld
    Else
      If FieldSize > Threshold Then
        WriteFromText F, Fld, FieldSize
      Else
        sData = Fld.Value
        Put #F, , sData  ' PUT tacks on overhead if use fld.Value
      End If
    End If
  End Select
  Close #F
End Sub

Private Sub WriteFromBinary(ByVal F As Long, _
                            ByRef Fld As ADODB.Field, _
                            ByVal FieldSize As Long)
Dim Data() As Byte
Dim BytesRead As Long

  Do While FieldSize <> BytesRead
    If FieldSize - BytesRead < BLOCK_SIZE Then
      Data = Fld.GetChunk(FieldSize - BLOCK_SIZE)
      BytesRead = FieldSize
    Else
      Data = Fld.GetChunk(BLOCK_SIZE)
      BytesRead = BytesRead + BLOCK_SIZE
    End If
    Put #F, , Data
  Loop
End Sub

Private Sub WriteFromUnsizedBinary(ByVal F As Long, _
                                   ByRef Fld As ADODB.Field)
Dim Data() As Byte
Dim Temp As Variant

  Do
    Temp = Fld.GetChunk(BLOCK_SIZE)
    If IsNull(Temp) Then Exit Do
    Data = Temp
    Put #F, , Data
  Loop While LenB(Temp) = BLOCK_SIZE
End Sub

Private Sub WriteFromText(ByVal F As Long, _
                          ByRef Fld As ADODB.Field, _
                          ByVal FieldSize As Long)
Dim Data As String
Dim CharsRead As Long

  Do While FieldSize <> CharsRead
    If FieldSize - CharsRead < BLOCK_SIZE Then
      Data = Fld.GetChunk(FieldSize - BLOCK_SIZE)
      CharsRead = FieldSize
    Else
      Data = Fld.GetChunk(BLOCK_SIZE)
      CharsRead = CharsRead + BLOCK_SIZE
    End If
    Put #F, , Data
  Loop
End Sub

Private Sub WriteFromUnsizedText(ByVal F As Long, _
                                 ByRef Fld As ADODB.Field)
Dim Data As String
Dim Temp As Variant

  Do
    Temp = Fld.GetChunk(BLOCK_SIZE)
    If IsNull(Temp) Then Exit Do
    Data = Temp
    Put #F, , Data
  Loop While Len(Temp) = BLOCK_SIZE
End Sub

' Assumes file exists
' Assumes calling routine does the UPDATE
' File cannot exceed approx. 2Gb in size
Public Sub FileToBlob(ByVal FName As String, _
                      ByRef Fld As ADODB.Field, _
                      Optional Threshold As Long = 1048576)
Dim F As Long
Dim Data() As Byte
Dim FileSize As Long

  F = FreeFile
  Open FName For Binary As #F
  FileSize = LOF(F)
  Select Case Fld.Type
  Case adLongVarBinary
    If FileSize > Threshold Then
      ReadToBinary F, Fld, FileSize
    Else
      Data = InputB(FileSize, F)
      Fld.Value = Data
    End If
  Case adLongVarChar, adLongVarWChar
    If FileSize > Threshold Then
      ReadToText F, Fld, FileSize
    Else
      Fld.Value = Input(FileSize, F)
    End If
  End Select
  Close #F
End Sub

Private Sub ReadToBinary(ByVal F As Long, _
                         ByRef Fld As ADODB.Field, _
                         ByVal FileSize As Long)
Dim Data() As Byte
Dim BytesRead As Long

  Do While FileSize <> BytesRead
    If FileSize - BytesRead < BLOCK_SIZE Then
      Data = InputB(FileSize - BytesRead, F)
      BytesRead = FileSize
    Else
      Data = InputB(BLOCK_SIZE, F)
      BytesRead = BytesRead + BLOCK_SIZE
    End If
    Fld.AppendChunk Data
  Loop
End Sub

Private Sub ReadToText(ByVal F As Long, _
                       ByRef Fld As ADODB.Field, _
                       ByVal FileSize As Long)
Dim Data As String
Dim CharsRead As Long

  Do While FileSize <> CharsRead
    If FileSize - CharsRead < BLOCK_SIZE Then
      Data = Input(FileSize - CharsRead, F)
      CharsRead = FileSize
    Else
      Data = Input(BLOCK_SIZE, F)
      CharsRead = CharsRead + BLOCK_SIZE
    End If
    Fld.AppendChunk Data
  Loop
End Sub

Conclusion :


Par exemple, imaginons que vous souhaitiez sauver le contenu d'une PictureBox (MyPic) dans un champ (FldPic):
SavePicture MyPic.Picture, "C:\Temp\Pic.tmp"
FileToBlob "C:\Temp\Pic.tmp",RS("FldPic")

pour le récupérer par la suite:
BlobToFile RS("FldPic"),"C:\Temp\Pic.tmp"
Set MyPic = LoadPicture("C:\Temp\Pic.tmp")

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_FlyKiller)