Bonjour

Je cale sur un problème d'extraction d'image embarquées dans un fichier metafile.
Pour cela j'utilise l'enumeration et j'arrive bien à produire des fichiers images.
Le probléme survient avec le record de type EMR_STRETCHDIBITS. L'image obtenue n'a pas les bonnes couleurs pour certaines images.
Voici un extrait du code que j'utilise.

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
Public Function CallBack_ENumMetafile(ByVal hdc As Long, _
                                      ByVal lpHtable As Long, _
                                      ByVal lpMFR As Long, _
                                      ByVal nObj As Long, _
                                      ByVal lpClientData As Long) As Long
  Dim PEnhEMR As EMR
  Dim PEnhStrecthDiBits As EMRSTRETCHDIBITS
  Dim tmpDc As Long
  Dim hBitmap  As Long
  Dim lRet As Long
  Dim BITMAPINFO As BITMAPINFO
  Dim pBitsMem As Long
  Dim pBitmapInfo As Long
  Static RecordCount As Long
 
  lRet = PlayEnhMetaFileRecord(hdc, ByVal lpHtable, ByVal lpMFR, ByVal nObj)
 
 
  RecordCount = RecordCount + 1
  CopyMemory PEnhEMR, ByVal lpMFR, Len(PEnhEMR)
  Select Case PEnhEMR.iType
  Case 1  'header
    RecordCount = 1
  Case EMR_STRETCHDIBITS
    CopyMemory PEnhStrecthDiBits, ByVal lpMFR, Len(PEnhStrecthDiBits)
    pBitmapInfo = lpMFR + PEnhStrecthDiBits.offBmiSrc
    CopyMemory BITMAPINFO, ByVal pBitmapInfo, Len(BITMAPINFO)
    pBitsMem = lpMFR + PEnhStrecthDiBits.offBitsSrc
 
    tmpDc = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    hBitmap = CreateDIBitmap(tmpDc, _
                            BITMAPINFO.bmiHeader, _
                            CBM_INIT, _
                            ByVal pBitsMem, _
                            BITMAPINFO, _
                            DIB_RGB_COLORS)
    lRet = DeleteDC(tmpDc)
    If hBitmap Then
      'init du pcturebox qui va recevoir le bitmap
      frmExtractImgFromEmf.pctExport.Cls
      frmExtractImgFromEmf.pctExport.Picture = LoadPicture("")
      frmExtractImgFromEmf.pctExport.Width = BITMAPINFO.bmiHeader.biWidth
      frmExtractImgFromEmf.pctExport.Height = BITMAPINFO.bmiHeader.biHeight
      tmpDc = CreateCompatibleDC(frmExtractImgFromEmf.hdc)
      lRet = SelectObject(tmpDc, hBitmap)
      lRet = BitBlt(frmExtractImgFromEmf.pctExport.hdc, _
                    0, 0, _
                    frmExtractImgFromEmf.pctExport.Width, _
                    frmExtractImgFromEmf.pctExport.Height, _
                    tmpDc, _
                    0, 0, _
                    vbSrcCopy)
      DeleteDC tmpDc
      Set frmExtractImgFromEmf.pctExport.Picture = frmExtractImgFromEmf.pctExport.Image
      SavePicture frmExtractImgFromEmf.pctExport.Picture, App.Path & "\temp" & CStr(RecordCount) & ".bmp"
      MsgBox "la creation du bitmap a réussi"
      DeleteObject hBitmap
    Else
      MsgBox "la création du bitmap a échoué"
    End If
  End Select
  CallBack_ENumMetafile = True
 
End Function
je vous mets un lien vers le source complet , ce qui vous permetra de faire un test avec le fichier exemple joint.

Je ne sais pas pas du tout ou est le problème, ma boule de cristal cassée me sussure un problème de palette. Je cale.