Private Type BITMAPINFOHEADER
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 RGB_Col
B As Byte
G As Byte
R As Byte
End Type
Private Declare Function SetDIBitsToDevice Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal dx As Long, _
ByVal dy As Long, _
ByVal SrcX As Long, _
ByVal SrcY As Long, _
ByVal Scan As Long, _
ByVal NumScans As Long, _
Bits As Any, _
BitsInfo As BITMAPINFO, _
ByVal wUsage As Long) As Long
Private Declare Function StretchDIBits Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal dx As Long, _
ByVal dy As Long, _
ByVal SrcX As Long, _
ByVal SrcY As Long, _
ByVal wSrcWidth As Long, _
ByVal wSrcHeight As Long, _
lpBits As Any, _
lpBitsInfo As BITMAPINFO, _
ByVal wUsage As Long, _
ByVal dwRop As Long) As Long
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
End
End Sub
Private Sub Timer1_Timer()
xx = 256
yy = 192
Dim bi24BitInfo As BITMAPINFO, bBytes() As RGB_Col
With bi24BitInfo.bmiHeader
.biBitCount = 24
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = xx '256
.biHeight = yy '192
End With
ReDim bBytes(1 To bi24BitInfo.bmiHeader.biWidth, 1 To bi24BitInfo.bmiHeader.biHeight) As RGB_Col
For x = 1 To xx Step 1
For y = 1 To yy Step 1
bBytes(x, y).R = Rnd * (x - 1)
bBytes(x, y).G = Rnd * (255 - y)
bBytes(x, y).B = Rnd * y
Next
Next
'SetDIBitsToDevice Form1.hdc, 0, 0, 256, 192, 0, 0, 0, 192, bBytes(1, 1), bi24BitInfo, 0
StretchDIBits Form1.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, 0, 0, 256, 192, bBytes(1, 1), bi24BitInfo, 0, vbSrcCopy
'StretchDIBits Form1.hdc, 0, 0, 300, 400, 0, 0, BITMAPINFOHEADER.biWidth, BITMAPINFOHEADER.biHeight, bBytes(1, 1), bi24BitInfo, 0, vbSrcCopy
End Sub
(заполнение матрицы не так важно)
Dim DirX As New DirectX7
Dim DirD As DirectDraw7
Dim objDDScreen As DirectDrawSurface7
Dim objDDBackBuffer As DirectDrawSurface7
Dim objDDClip As DirectDrawClipper
Dim ddsdLake As DDSURFACEDESC2
Dim ddsdScreen As DDSURFACEDESC2
Dim ddsdBackBuffer As DDSURFACEDESC2
Dim RectBuf As RECT
Dim RectScr As RECT
Private framen As Long
Private lasttime As String
'Всяческие подготовки
Set DirD = DirX.DirectDrawCreate("")
Call DirD.SetCooperativeLevel(Form1.hWnd, DDSCL_NORMAL)
ddsdScreen.lFlags = DDSD_CAPS
ddsdScreen.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
Set objDDScreen = DirD.CreateSurface(ddsdScreen)
Set objDDClip = DirD.CreateClipper(0)
ddsdBackBuffer.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
ddsdBackBuffer.lWidth = xx 'Picture1.Width
ddsdBackBuffer.lHeight = yy 'Picture1.Height
Set objDDBackBuffer = DirD.CreateSurface(ddsdBackBuffer)
ddsdLake.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
ddsdLake.lWidth = xx 'Picture1.Width
ddsdLake.lHeight = yy 'Picture1.Height
ddsdLake)
DDBLTFAST_WAIT)
objDDClip.SetHWnd Form1.Picture1.hWnd
objDDScreen.SetClipper objDDClip
'Далее идёт прорисовка одного кадра
objDDBackBuffer.Lock RectBuf, ddsdBackBuffer, DDLOCK_WAIT, 0
For a = 0 To 255: For s = 0 To 191
r = Rnd * 256' Собственно из-за этого заполнения показывается фпс чуть больше 20, а если просто перекидывать из матрицы будет 60-64
objDDBackBuffer.SetLockedPixel a, s, RGB(0, 0, r)
Next s, a
objDDBackBuffer.Unlock RectBuf
DirX.GetWindowRect Form1.Picture1.hWnd, RectScr
objDDScreen.Blt RectScr, objDDBackBuffer, RectBuf, DDBLT_WAIT
Сейчас этот форум просматривают: AhrefsBot, Bing-бот, YaCy [Bot] и гости: 56