Discussion :

[jaffael]

Bonjour, après moult recherche, j'ai bien trouvé des chose pour m'aider, mais voilà ça ne marche pas !!

Mon but est simple, j'ai des vieilles bases qui était en Access97 et dont certaines table contiennent des champs typés "ObjetOle" qui sont en fait des images bitmap, quand je double clique dessus ou par code pour les afficher dans un formulaire, aucun problème l'image et bien là, mais j'aimerais pouvoir les sortir de la base et les stocker sur le HD dans un répertoire particulier.

Je suis passé à OfficeXP (donc Access 2002 me semble-t-il) et je suis sous Win XP, et j'ai commencé à codé l'extraction des images. Ce qui donne ceci (je me suis aidé de ce que j'ai déjà trouvé dans mes recherches)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
Public Sub TryExport(NomTable As String, Prefix As String)
  Dim db As Database
  Dim rs As Recordset
  Dim mstream As ADODB.Stream
  Dim tmp As String
 
  'Ouverture de la base
  Set db = DBEngine.Workspaces(0).OpenDatabase(DatabaseFile)
  'Ouverture de la table
  Set rs = db.OpenRecordset(NomTable)
 
  rs.MoveFirst
  'Parcours des enrg
  While Not rs.EOF
    'Si l'image est dans la base, rs!Ext = False pour les images internes,True pour externe
    If not rs!Ext Then
 
      Set mstream = New ADODB.Stream
      mstream.Type = adTypeBinary
      mstream.Open
 
      'Nom de l'image de forme Prefix + "xxxxxxx.bmp" où xxxxxxx= "0..0" + la valeur de la clé primaire "Compteur" = numéro auto
      tmp = Prefix & FillString(7 - Len(rs.Fields("Compteur")), "0")
 
      mstream.Write rs.Fields("Nom Bmp").Value
      mstream.SaveToFile Dir_ApplicationPicture & tmp & rs.Fields("Compteur") & ".bmp", adSaveCreateOverWrite
 
      mstream.Close
    End If
 
    rs.MoveNext
  Wend
 
End Sub
 
'renvoie un chaîne faites de : cnt * "Str"
Private Function FillString(cnt As Integer, str As String) As String
  Dim s As String
 
  s = ""
  While Len(s) < cnt
    s = s + str
  Wend
 
  FillString = s
 
End Function

DatabaseFile(= Nom de la base externe contenant des tables liées à l'application principale) et Dir_ApplicationPicture(= Dossier où je veux stockée toutes les images) sont des var globales de mon application.

Je lance la procédure, ça à l'air de se passer correctement, les fichiers sont créés et tous de taille différente....mais pas correctement, l'aperçu Windows dit "Pas d'aperçu disponible", Paint dit "Paint ne peut pas lire ce fichier. Ce fichier n'est pas un bitmap valide, ou son format n'est pas pris en charge."

Que faire ??
Faut-il sauver sous une autre extension ? Ou peut-on typer plus fortement le Stream ?

Merci d'avance.

(P.S: je suis programmeur Pascal et C++, je n'ai pas fait de vba depuis longtemps mais j'ai besoin de récupérer ces vieilleries).

[jaffael]

Ceci est une partie de l'en-tête de l'un des fichiers obtenus (ouvert avec le bloc-notes)

! ÿÿÿÿImage Bitmap Paint.Picture
   PBrush €8 BMF8 6 ( Æ ô
 8 Ä Ä

Ce qui à l'air de bien vouloir dire que c'est un bitmap, alors.. je ne comprends pas

[LedZeppII]

Bonjour,

Ce que ton code extrait, ce n'est pas directement le fichier image.
Lorsqu'on insère quelque chose à partir d'un fichier dans un champ OLE, ce quelque chose est encapsulé dans autre chose.
Et je me demande même si certaine fois il n'y a pas transformation.

Une petite piste ici : kb175261, mais qui ne fonctionne que pour des bitmaps.
Une autre ici : http://www.developpez.net/forums/d33...le-to-fichier/ (voir réponse de =JBO=)

A+

[vodiem]

salut LedZeppII et jaffael,

il suffit que tu positionnes le début de la copie à partir de "BM" (en les incluants).
ces deux premières lettre détermine le format BITMAP, la suite représente l'entête du format et le contenu.
l'encapsulation consiste à mettre du baratin devant pour dire avec quel filtre on peut l'ouvrir. la taille de l'encapsulation ne dois pas être fixe et il peut avoir plusieurs filtre pour un format donc il faut se fier à l'entête du format: "BM...".
en pratique je n'ai pas constaté de suffixe.

[jaffael]

Merci,
grâce à ce lien
http://www.developpez.net/forums/d33...le-to-fichier/
je suis tombé sur ce lien
http://support.microsoft.com/default...d=kb;fr;463107
j'ai donc ajouté ce code dans mon module et j'appelle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

CreerBMP file, rs![Nom Bmp]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
 (trouver sur http://support.microsoft.com/default...d=kb;fr;463107)
Sub CreerBMP(Fichier As String, ChampOLE As Field)
Dim NumChunks As Long, TotalSize As Long, BMPPos As Long
Dim RemChunk As Integer, CurSize As Integer
Dim FNum As Integer, CurChunk As String
Dim ChunkSize As Long
Dim I As Long
 
'* Définit la taille de la tranche de données.
ChunkSize = 2000
 
'* récupère la position des caractères BM
BMPPos = InStr(ChampOLE, "BM")
 
'* Lit la taille du fichier.
TotalSize = ChampOLE.FieldSize() - (BMPPos - 1)
 
'* Définit le nombre nécessaires de tranches de données.
NumChunks = TotalSize \ ChunkSize
 
'* Définit le nombre d'octets disponibles.
RemChunk = TotalSize Mod ChunkSize
 
'* Définit la taille initiale de la tranche de données.
CurSize = ChunkSize
 
'* retourne le numéro de fichier disponible.
FNum = FreeFile
 
'* création du fichier bitmap
Open Fichier For Binary As #FNum
For I = 0 To NumChunks
If I = NumChunks Then CurSize = RemChunk
'* (entrez les deux lignes sur une même ligne)
CurChunk = ChampOLE.GetChunk((I * ChunkSize) + (BMPPos - 1), CurSize)
'* Ecrit la tranche de données dans le fichier.
Put #FNum, , CurChunk
Next I
Close FNum
End Sub

Mais ça donne toujours des fichiers illisibles..... mais ça ne m'étonne pas tant que ça, en premier lieu j'ai passé i en long, sinon il y avait un dépassement de capacité, de plus

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

BMPPos = InStr(ChampOLE, "BM")

renvoie toujours 0 ce qui est fait j'ai vérifié dans les chaines binaires et c'est souvent entre 50 et 80.
Quelle correction faire pour que ça fonctionne

PS: J'ai bien vu le message de =JBO= et j'ai testé, effectivement ça fonctionne, mais j'ai plusieurs vieilles bases avec plusieurs tables ayant des bitmaps, je préférerais donc corriger mon code pour qu'il fonctionne et faire une procédure automatique genre -> ExtraxtBmp(dbName As String, tableName As String, oleFieldName as string)

J'ajoute, bout de code trouvé sur le lien -> kb175261

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Buffer = ""
        For i = ObjectOffset To ObjectOffset + 512
            Buffer = Buffer & Chr(Arr(i))
        Next i
 
        'Make sure the class of the object is a Paint Brush object
        If Mid(Buffer, 12, 6) = "PBrush" Then
            BitmapHeaderOffset = InStr(Buffer, "BM")

ce qui montre bien que

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

BMPPos = InStr(ChampOLE, "BM")

ne peut pas marcher directement, comme quoi même le code des articles microsoft est pas toujours net.

[jaffael]

Voilà après maintes réécritures, j'ai enfin obtenu mes images, d'abord merci à tout ceux qui m'ont donné des liens très utile (car mon code est un mélange de ce que j'y ai trouvé), et voici, pour les intéressé la fonction CreerBitmap opérationnelle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
Option Compare Database
Option Explicit
 
' Enter the following Declare statement as one single line:
  Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
 
      Type PT
        Width As Integer
        Height As Integer
      End Type
 
      Type OBJECTHEADER
        Signature As Integer
        HeaderSize As Integer
        ObjectType As Long
        NameLen As Integer
        ClassLen As Integer
        NameOffset As Integer
        ClassOFfset As Integer
        ObjectSize As PT
        OleInfo As String * 256
      End Type
 
Sub CreerBMP(Fichier As String, ChampOLE As Field)
 
  Dim NumChunks As Long, TotalSize As Long
  Dim RemChunk As Integer, CurSize As Integer
  Dim FNum As Integer, CurChunk As String
  Dim ChunkSize As Long
  Dim i As Long, J As Long
  Dim Arr() As Byte
  Dim ObjHeader As OBJECTHEADER
  Dim Buffer As String
  Dim ObjectOffset As Long
  Dim BitmapOffset As Long
  Dim BitmapHeaderOffset As Integer
 
  ReDim Arr(ChampOLE.FieldSize)
  Arr() = ChampOLE.GetChunk(0, ChampOLE.FieldSize)
 
  'Copy the first 19 bytes into a variable 'of the OBJECTHEADER user defined type.
  CopyMemory ObjHeader, Arr(0), 19
 
  'Determine where the Access Header ends.
  ObjectOffset = ObjHeader.HeaderSize + 1
 
  'Grab enough bytes after the OLE header to get the bitmap header.
  Buffer = ""
  For i = ObjectOffset To ObjectOffset + 512
    Buffer = Buffer & Chr(Arr(i))
  Next i
 
        'Make sure the class of the object is a Paint Brush object
        If Mid(Buffer, 12, 6) = "PBrush" Then
            BitmapHeaderOffset = InStr(Buffer, "BM")
            If BitmapHeaderOffset > 0 Then
 
                'Calculate the beginning of the bitmap
                BitmapOffset = ObjectOffset + BitmapHeaderOffset - 1
            Else
              MsgBox "PBrush non trouvé"
            End If
        End If
 
'* Définit la taille de la tranche de données.
ChunkSize = 2000
 
'* Lit la taille du fichier.
TotalSize = ChampOLE.FieldSize() - BitmapOffset
 
'* Définit le nombre nécessaires de tranches de données.
NumChunks = TotalSize \ ChunkSize
 
'* Définit le nombre d'octets disponibles, nombre d'octets pour la dernière tranche
RemChunk = TotalSize Mod ChunkSize - 1
 
'* Définit la taille initiale de la tranche de données.
CurSize = ChunkSize
 
'* retourne le numéro de fichier disponible.
FNum = FreeFile
 
'* création du fichier bitmap
  Open Fichier For Binary As #FNum
    For i = 0 To NumChunks
      If i = NumChunks Then CurSize = RemChunk
 
      Buffer = ""
      For J = (i * ChunkSize) + (BitmapOffset) To (i * ChunkSize) + (BitmapOffset) + CurSize - 1
          Buffer = Buffer & Chr(Arr(J))
      Next J
 
      Put #FNum, , Buffer
    Next i
  Close FNum
 
End Sub