TABLEAU DE PIXELS EN PICTURE

Question

J'utilise la fonction de 'Proger'

(CONVERSION TABLEAU DE PIXELS EN BITMAP OU PICTURE
http://www.codes-sources.com/code.aspx?ID=4978)

modifier pour que j'affiche mon image avec un tableau
du style TableauBits(0) au lieu de TableauBits(0,0) 

Voila la fonction modifiée

Function PictureFromTableauBits(Bits() As Byte, XWidth As Long, YHeight As Long, Optional ColorDepht As Long = 24) As IPictureDisp
'envoie la matrixbuffer à l'écran (converti l'image en bitmap OLE multiusages)
'usage : Set machin.Picture = PictureFromTableauBits(,,,,)

Dim iDC As Long            'handle du DC
Dim idib As Long           'handle du descripteur DIB
Dim DefDIB As BITMAPINFO   'description du DIB  (BITMAPINFOHEADER ou BITMAPINFO)
Dim voidPt As Long         '(retour de l'api du descripteur DIB)
Static iBMP As Long        'handle de la liste de pixel (bitmap)
Dim Xlng As Long, Ylng As Long   'dimensions de l'image
'DIB OLE :
Dim exeAPI As Long
Dim PicDef As PicBmp, IID_IDispatch As GUID
        
    'crée le DC temporaire
    iDC = CreateCompatibleDC(GetDC(0))
    'crée la palette de couleurs
    With DefDIB.bmiHeader
        .biWidth = XWidth      'largeur
        .biHeight = YHeight     'hauteur
        .biBitCount = ColorDepht  'bits par pixel
        .biPlanes = 1       'nombre de couche de travail
        .biSize = Len(DefDIB.bmiHeader)  'taille de la structure si BITMAPINFO
        '.biSize = Len(DefDIB)  'taille de la structure si BITMAPINFOHEADER
    End With

    'crée la DIB
    idib = CreateDIBSection(iDC, DefDIB, 0, voidPt, 0, 0)
    'envoie la dib au DC
    SelectObject iDC, idib
    
    DeleteObject iBMP 'supprime l'ancienne
    'METHODE 1 : ne fonctionne que si colordepht nombre de couleur bureau windows
'        iBMP = CreateBitmap(XWidth, YHeight, 1, ColorDepht, Bits(0))
'        'envoie la bmp au DC
'        SelectObject iDC, iBMP
    
    '=== METHODE 2 : fonctionne indépendamment du nombre de couleur de windows, est légèrement plus lent
        iBMP = CreateCompatibleBitmap(iDC, XWidth, YHeight)
        SelectObject iDC, iBMP
        SetDIBitsToDevice iDC, 0, 0, XWidth, YHeight, 0, 0, 0, YHeight, Bits(0), DefDIB, 0
    
    'création de l'IPictureDisp, DIB OLE :

    'Défini le GUID = bitmap
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    'Défini l'image
    With PicDef
        .Size = Len(PicDef) '=20
        .Type = vbPicTypeBitmap 'Type (bitmap)
        .hBmp = iBMP 'Handle de la bitmap
    End With

    'Crée la IPictureDisp et renvoie le pointeur dans la fonction
    exeAPI = OleCreatePictureIndirect(PicDef, IID_IDispatch, 1, PictureFromTableauBits)

    'libère la mémoire
    DeleteObject idib
    DeleteDC iDC
    
End Function

Fonctionne très bien pour les images
24Bits couleurs  codé sur 3 Bits/pixel

Mais pas pour
256 couleurs est codé sur 1 Bit/pixel
16 couleurs est codé 1 bit pour 2 pixels

Une idée de ce qui va pas

Renfield · Answer

ou, la vilaine fuite...

iDC = CreateCompatibleDC(GetDC(0))

et comment tu vas le Releaser, maintenant, ton DC ? ^^

Renfield
Admin CodeS-SourceS- MVP Visual Basic

cs_Tropic · Answer

Est la bonne modif

hdc = GetDC(0)
'crée le DC temporaire
 iDC = CreateCompatibleDC(GetDC(hdc))
 ReleaseDC 0, hdc

Merci [auteurdetail.aspx?ID=2359 Renfield] mais ça corrige pas mon problême

Renfield · Answer

non, ca raison pas ton soucis, c'est sur ^^

hdc = GetDC(0)
'crée le DC temporaire
 iDC = CreateCompatibleDC(hDc)
...
 ReleaseDC 0, hdc

Renfield
Admin CodeS-SourceS- MVP Visual Basic

cs_Tropic · Answer

HOOOOO  l'erreur
iDC = CreateCompatibleDC(GetDC(hdc))
OUI bien sur!

Renfield · Answer

je pense que ton soucis, c'est le CreateCompatibleDC

=> conforme aux couleurs de ton bureau

tentes d'utiliser CreateDC

Renfield
Admin CodeS-SourceS- MVP Visual Basic

cs_Tropic · Answer

Oui mais dans ce cas,
si les couleurs ne sont pas comforme,
je devrait au moin avoir une image
quelque soit sa teinte non?

Il faut savoir que mon tableau a 3 octets/pixel cas du 24bits/pixel (qui fonctionne)
alors qu'il aura 1 octet/pixel cas du 256 couleurs.
et 1 octet pour 2 pixel cas du 16 couleur.
----------------------------------------------------------

OU ALORS EST UN PROBLEME DE FIN DE LIGNE
j'ai trouvé une formule sur http://www.vbfrance.com/article.aspx?ID=3971
Extrait:
' connaissance de la longueur de la ligne 
( dans le format bmp le total des données de la ligne horizontale 
doit être un multiple de 32bits si ce n'est le cas, 
la ligne horizontale est comblée par des octets vides)

Sa formule
Dim finligne As Byte
Dim finligne2 As Integer
Sub evallongueurligne() 'recherche du multiple de 32 bits
    x = (fileinfo.biWidth * 24) / 32
    X1 = (x - Int(x)) * 100 'extraction des deux chiffres après la virgule de x
    Select Case X1
        Case 25
            Get #numfile, , finligne 'recupération de l'octet vide
        Case 50
            Get #numfile, , finligne2 'recupération des deux octets vides
        Case 75
            Get #numfile, , finligne
    End Select
End Sub

La formule adapté. qui tourne très bien pour du 3 Bits/pixel
fin32Bit = (FileInfo.biWidth * 24) / 32
finligneS = ((fin32Bit - Int(fin32Bit)) * 100) Mod 2If finligneS 0 Then finligneS 2

en fait [finligneS] aura 0, 1, ou 2
En gros ça donne

Redim TableauBits (largeurLigne + finligneS)
Get #FF, SeekFileHeader + PosY, TableauBits 

Puis je tombe sur cette information
'http://docvb.free.fr/vbplus/Infograp/imagebitmap.php

Extrait:
La largeur BMP doit être paire.
Si la résolution est par exemple de 179 avec un mode 8 bits,
alors chaque ligne aura une taille de 180 octets,
avec un octet vide à chaque fin de ligne pour combler le vide

Le but de cette formule est de justement de connaitre le nombre
d'octet vide à récuper et à combler pour l'image destination

TABLEAU DE PIXELS EN PICTURE

6 réponses

Votre réponse

Discussions similaires