Soyez le premier à donner votre avis sur cette source.
Vue 20 547 fois - Téléchargée 1 247 fois
'================ ' 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
J'etudie ton code ,je debute et je m'interresse au dibits and co en ce moment.
Aurais tu un tuyau ou saurais tu comment une fois une image chargee ds picturebox,
je peux en extraire le tablo de pixel (byte ou long) sans utiliser,point ou getpixel,ou
ouvrir le jpeg en binaire?. Si tu as un lien ou une piste fais moi signe. J'utilise ton code
pour afficher des tablo de long ca va tres vite et plus souple que la classe Cdibits. Merci tro fort.
moi non ! et apres je veut bien faire rgb(val,val,val) jé essayé mé ca marche pas !!
aide moi pleaseeeee lol :-p
Maintenant, le noir & blanc il faut le convertir en 24 bit (pas trop dur avec rgb() )
Pour qu'elle fonctionne en mode 8 ou 16bit couleurs, faut faire qq retouches.
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.