Conversion tableau de pixels en bitmap ou picture

Télécharger le projet
Commenter

Description

Vous avez une matrice de points genre toto(x,y) et vous voulez l'envoyer vers une picturebox ou la sauvegarder?
Vous utilisez PSet ou SetPixel et c'est leeeeeennnt ?

Alors copiez ce code :)

Attention, le code publié n'est qu'un extrait du module Matrixbuffer.bas du zip qui contient en plus :
- Rendu par PSet (VB classique)
- Rendu SetDIBits (très rapide mais non mémorisable)
- Fusion entre deux matrices de points
- Réduction 2:1 par algorithme bilinéaire
- Convertisseur HSL et HSV vers RGB par deux méthode (standard et "exacte")
- Traçage de ligne Bresenham
- Point "WU pixel", précision du pixel en virgule flottante

Source / Exemple : 


'================
' MATRIXBUFFER
'**************
' Rien a voir avec le film
' Par Proger - 2002
' Placer les couleurs dans un tableau (x,y) et ce module permet de l'envoyer en tant que Picture
' Interêt : 5 à 40 fois plus rapide que d'utiliser .PSet ou SetPixel
'   pour dessiner une image point par point
'
'Source : allapi (pour la création de palette et d'IPictureDisp)
'Idée original : utiliser CreateBitmap()
'
'Ajout d'un traçeur de ligne et du remplissage en background
'Correction du bug de ligne noir
Option Base 1

'Déclaration pour une image DIB (Device Independant Bitmap)
'========
Private Type BITMAPINFOHEADER
    biSize As Long 'Taille en octet du type
    biWidth As Long 'x
    biHeight As Long 'y
    biPlanes As Integer 'Plan de dessin (?) défaut=1
    biBitCount As Integer 'Bits par pixel (couleurs)
    biCompression As Long 'Compression utilisé (défaut=0)
    biSizeImage As Long 'Taille de l'image, octet
    biXPelsPerMeter As Long 'Résolution (comme le dpi, mais en dpm)
    biYPelsPerMeter As Long 'Résolution hauteur
    biClrUsed As Long '?
    biClrImportant As Long '?
End Type
Private Type RGBQUAD 'valeur de la couleur, en 24-bits RGB + 8
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER 'Définition bitmap
    bmiColors As RGBQUAD  'Stockage des couleurs
End Type
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByRef lpBits As Any) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
'========

'déclaration pour un IPictureDisp a partir d'un DC
'=====
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'=====

'super API pour manip mémoire rapide des tableaux.
Private Declare Sub RtlMoveMemory Lib "kernel32" (refDest As Any, refFrom As Any, ByVal Longueur As Long)

'la représentation mémoire de la matrixbuffer :)
Public MxBuf() As Long
'===============================

'Démarre une session avec la matrixbuffer du module (sub optionnel)
Public Sub M_StartRender(xWidth, yHeight)
    'paramètres : dimensions en pixels de l'image
    ReDim MxBuf(yHeight, xWidth) As Long 'debug : ptite inversion
    
    'usage de la matrixbuffer :
    'MxBuf(x, y) = RGB(r, g, b)
    'comparaison à la méthode VB PSet :
    'PictureBox.PSet (x, y), RGB(r, g, b)
End Sub

'envoie la matrixbuffer à l'écran
Public Function M_StopRender(ColorDepht As Long) As IPictureDisp
'usage : Set machin.Picture = M_StopRender(32)
    Dim iDC As Long, iDIB As Long, iFk As Long
    Static iBMP As Long
    Dim Xlng As Long, Ylng As Long
    Dim DefDIB As BITMAPINFO, voidPt As Long
    
    'récupère les dimensions de la matrice de point
    Xlng = UBound(MxBuf(), 1)
    Ylng = UBound(MxBuf(), 2)
    
    'crée le DC temporaire
    iDC = CreateCompatibleDC(GetDC(0))
    'crée la palette de couleurs
    With DefDIB
        .bmiHeader.biWidth = Xlng      'largeur
        .bmiHeader.biHeight = Ylng     'hauteur
        .bmiHeader.biBitCount = ColorDepht  'bits par pixel (1,2,4,8,16,32)
        .bmiHeader.biPlanes = 1       'nombre de couche de travail
        .bmiHeader.biSize = Len(.bmiHeader)  'taille de la structure
    End With

    DeleteObject iDIB
    'crée la DIB
    iDIB = CreateDIBSection(iDC, DefDIB, 0, voidPt, 0, 0)
    'envoie la dib au DC
    SelectObject iDC, iDIB
    'crée la BMP depuis la matrixbuffer
    DeleteObject iBMP 'supprime l'ancienne
    iBMP = CreateBitmap(Xlng , Ylng, 1, ColorDepht, MxBuf(1, 1))
    'envoie la bmp au DC
    SelectObject iDC, iBMP
    
    'création de l'IPictureDisp
    Dim exeAPI As Long
    Dim PicDef As PicBmp, IID_IDispatch As GUID

    '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, M_StopRender)

    'libère la mémoire
    DeleteObject iDIB
    DeleteDC iDC
End Function

Conclusion :


Cadeau pour tout ceux qui travaillent dans le graphisme :)
post ici surtout pour sibosisITS

Les fonctions de base utilisant les API peuvent être utilisées indifférement dans l'IDE ou compilé.
Les différents algorithmes supplémentaires sont très rapide lorsque le programme est compilé.

J'utilise le module Matrixbuffer.bas comme base de mes programmes utilisant une sortie dans picturebox. Il y a dedans suffisament de fonctions et de manipulations mémoire pour couvrir les besoins habituels lorsqu'on fait des sortie par image en VB.

LIMITE : la sortie M_StopRender() crée un objet IPictureDisp qui ne peux être affecté qu'a une picturebox à la fois. Il convient d'utiliser le rendu M_SetDIBIts() si votre programme n'exige pas d'objet IPictureDisp.
Télécharger le projet

Codes Sources

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 (Proger)