
![]() |
Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
|
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[18.97.14.90] |
![]() |
|
![]() |
Сообщ.
#1
,
|
|
Я в ступоре. Та к и не смог сделать сабж.
Т.е. имея IPictureDisp с загруженой в него картинкой получить 24-х битный массив его изображения. Есть одно условие - загруженное в IPIctureDisp изображение может быть любой битности, т.е. 1, 4, 8, 24, 32. Постоянные вылеты с ошибкой доступа к памяти. |
Сообщ.
#2
,
|
|
|
Качни FreeImage отсюда FreeImage
Там есть для VB6 пример и в модуле MFreeImage.bas реализованы функции работы с изображением. Сама библа FreeImage.dll на C++, но Wrapper на VB. По идее там есть все, что тебе нужно для рабты с картинкой. |
![]() |
Сообщ.
#3
,
|
|
![]() ![]() Option Explicit 'Written by SCINER: lenar2003@mail.ru '04/05/2007 'GetDIBfromBitmap function Private Type BITMAPINFOHEADER '40 bytes biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Private Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, _ lpObject As Any) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _ ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Function GetDIBfromBitmap(iPic As IPictureDisp, _ Dib() As Byte, _ Optional ByVal lWidth As Long = 0, _ Optional ByVal lHeight As Long = 0) As Boolean Dim Bmp As BITMAP Dim dwHdc As Long, TmpDC As Long Dim hBmp As Long, OldBmp As Long Dim mem() As Byte Dim bminfo As BITMAPINFO Call GetObject(iPic, LenB(Bmp), Bmp) If lWidth = 0 Then lWidth = Bmp.bmWidth If lHeight = 0 Then lHeight = Bmp.bmHeight If (lWidth < 1) Or (lHeight < 1) Then Exit Function With bminfo.bmiHeader .biSize = 40 .biPlanes = 1 .biWidth = lWidth .biHeight = -lHeight .biBitCount = 24 'Bmp.bmBitsPixel End With dwHdc = CreateCompatibleDC(0) If dwHdc = 0 Then GoTo Fail hBmp = CreateCompatibleBitmap(dwHdc, lWidth, lHeight) OldBmp = SelectObject(dwHdc, iPic.Handle) 'подгоним по размерам байтовый массив ReDim Dib(0 To 2, lWidth - 1, lHeight - 1) 'захват изображения из пикчурбокса Call GetDIBits(dwHdc, iPic.Handle, 0, lHeight, Dib(0, 0, 0), bminfo, 0) Call SelectObject(dwHdc, OldBmp) Call DeleteObject(hBmp) Call DeleteDC(dwHdc) GetDIBfromBitmap = True Exit Function Fail: If hBmp <> 0 Then Call DeleteObject(hBmp) If dwHdc <> 0 Then Call DeleteDC(dwHdc) End Function Private Sub Form_Load() Dim Dib() As Byte Call GetDIBfromBitmap(Picture1, Dib) Stop End Sub |
Сообщ.
#4
,
|
|
|
SCINER ваш код не работает. Массив всегда возвращает UBound(Dib) = 2
Мда... Добавлено Самый-самый простой код это ![]() ![]() Public Function SavePictureAsByteArray(pPic As StdPicture, bArray() As Byte) As Boolean Dim PB As PropertyBag Set PB = New PropertyBag PB.WriteProperty "Pic", pPic bArray = MidB(PB.Contents, 51) End Function Но преобразовывает в BMP массив он только в EXE почему-то, я хз почему, но зато работает хотябы. |
![]() |
Сообщ.
#5
,
|
|
О! не прошло и восемнадцати лет...
|