Récupérer / d'assigner la valeur d'une image ou un fichier complet

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 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_Alex001)