bde
12-11-2003, 20:25
Нужно заполнить по точкам экран 1024х768 не более чем за 100 милисекунд, не используя DirectDraw.
Я уже пробовал функцию API PutPixel(), но для моих целей она очень медленная.
Видел такой способ: с помощью GetObjectA извлекается BitMap(из памяти) в переменную-структуру, затем в массив копируется какие-то данные с помощью RtlMoveMemory. Теперь этот массив - массив цветов. Вот код:
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Sub PictArrayInit2D(xPicture As Image, filepath As String, sa As SAFEARRAY2D, bmp As BITMAP, data() As Byte)
*'
*' Load picture into image box
*'
*If filepath <> "" Then
* *'
* *xPicture.Picture = LoadPicture(filepath)
* *'
*End If
*'
*' Get bitmap info from image box
*'
*GetObjectAPI xPicture.Picture, Len(bmp), bmp 'dest
*'
*' Exit if not a supported bitmap
*'
*If bmp.bmPlanes <> 1 Or bmp.bmBitsPixel <> 8 Then
* *MsgBox " 8-Bit Bitmaps Only!", vbCritical
* *Exit Sub
*End If
*'
*' Have the local matrix point to bitmap pixels
*'
*With sa
* *.cbElements = 1
* *.cDims = 2
* *.Bounds(0).lLbound = 0
* *.Bounds(0).cElements = bmp.bmHeight
* *.Bounds(1).lLbound = 0
* *.Bounds(1).cElements = bmp.bmWidthBytes
* *.pvData = bmp.bmBits
*End With
*'
*' Copy bitmap data into byte array
*'
*CopyMemory ByVal VarPtrArray(data), VarPtr(sa), 4
*'
End Sub
Вопрос, как это переориентировать на 16 и 32х битные битмэпы, *вот эта процедура только для 8-и битных. А для остальных действительно не работает(если выкинуть "Exit Sub")
Я уже пробовал функцию API PutPixel(), но для моих целей она очень медленная.
Видел такой способ: с помощью GetObjectA извлекается BitMap(из памяти) в переменную-структуру, затем в массив копируется какие-то данные с помощью RtlMoveMemory. Теперь этот массив - массив цветов. Вот код:
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Sub PictArrayInit2D(xPicture As Image, filepath As String, sa As SAFEARRAY2D, bmp As BITMAP, data() As Byte)
*'
*' Load picture into image box
*'
*If filepath <> "" Then
* *'
* *xPicture.Picture = LoadPicture(filepath)
* *'
*End If
*'
*' Get bitmap info from image box
*'
*GetObjectAPI xPicture.Picture, Len(bmp), bmp 'dest
*'
*' Exit if not a supported bitmap
*'
*If bmp.bmPlanes <> 1 Or bmp.bmBitsPixel <> 8 Then
* *MsgBox " 8-Bit Bitmaps Only!", vbCritical
* *Exit Sub
*End If
*'
*' Have the local matrix point to bitmap pixels
*'
*With sa
* *.cbElements = 1
* *.cDims = 2
* *.Bounds(0).lLbound = 0
* *.Bounds(0).cElements = bmp.bmHeight
* *.Bounds(1).lLbound = 0
* *.Bounds(1).cElements = bmp.bmWidthBytes
* *.pvData = bmp.bmBits
*End With
*'
*' Copy bitmap data into byte array
*'
*CopyMemory ByVal VarPtrArray(data), VarPtr(sa), 4
*'
End Sub
Вопрос, как это переориентировать на 16 и 32х битные битмэпы, *вот эта процедура только для 8-и битных. А для остальных действительно не работает(если выкинуть "Exit Sub")