Lire/ecrire dans des champs binaires

Soyez le premier à donner votre avis sur cette source.

Snippet vu 15 003 fois - Téléchargée 80 fois

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

Ajouter un commentaire

Commentaires

cs_xlt
Messages postés
15
Date d'inscription
vendredi 11 juillet 2003
Statut
Membre
Dernière intervention
18 octobre 2004
-
Tien tien ça ne marche pas avec MySQL!!! (OUINNNNNNNNNNNNN)
Fld.Type<--- les blob sous mysql sont de type '204' alors ça ne marche pas (meme en forçant ça plante après). Que faire??? Appeler microsoft et dire qu'ils devraient mettre du code pour les BDD gratuites??? :D

En tous les cas je suis un peu ennuyé
cs_Warny
Messages postés
478
Date d'inscription
mercredi 7 août 2002
Statut
Membre
Dernière intervention
10 juin 2015
-
Salut XLT,
Dans ton cas, le problème de vient pas de crosoft mais bien de MySQL. Ou plutot du driver ODBC de MySQL qui ne supporte pas cette routine.
Essaye les commandes AppendChunk et GetChunk qui permettent d'écrire des valeurs de champs en plusieurs blocs (très pratiques quand la bdd n'accepte pas l'écriture de bloc de plus d'une certaine taille)
Bien sur ça t'oblige à gérer toi même l'ouverture du fichier.
pointbin
Messages postés
71
Date d'inscription
lundi 5 janvier 2004
Statut
Membre
Dernière intervention
13 mai 2010
-
avec Microsoft ActiveX Data Object 2.0 et 2.1 j'ai l'erreur suivante:
ADO n'a pas trouver l'objet dans la collectioncorrespondant au nom ou
a la reference ordinaledemande par l'application.

y a t il une silution
lscherer
Messages postés
19
Date d'inscription
jeudi 21 mars 2002
Statut
Membre
Dernière intervention
3 novembre 2008
-
Bravo ! belle recopie de http://support.microsoft.com/kb/194975
tu aurais pu monter un projet au moins, c'est toujours un peu c... de devoir recopier le code sans être sûr que ça fonctionnera.

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.