Форум программистов [Powered by Invision Power Board]

Код

Option Explicit 'описываем необходимые структуры
Dim dx As New DirectX7
Dim dd As DirectDraw7
Dim di As DirectInput

Dim diDev As DirectInputDevice
Dim diState As DIKEYBOARDSTATE

Dim Prim As DirectDrawSurface7
Dim PrimBufer As DirectDrawSurface7
Dim OsnovaBMP As DirectDrawSurface7
Dim SpriteBMP As DirectDrawSurface7

Dim ddsdPrim As DDSURFACEDESC2
Dim ddsdPrimBufer As DDSURFACEDESC2
Dim ddsdOsnovaBMP As DDSURFACEDESC2
Dim ddsdSpriteBMP As DDSURFACEDESC2
Dim ddsdcapsPrimBufer As DDSCAPS2

Dim Key As DDCOLORKEY

Private Sub Form_Load()
'Инициализируем объекты и структуры
Set dd = dx.DirectDrawCreate("")
Set di = dx.DirectInputCreate()
Set diDev = di.CreateDevice("GUID_SysKeyboard")

dd.SetCooperativeLevel Me.hwnd, DDSCL_FULLSCREEN _
Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE
dd.SetDisplayMode 800, 600, 16, 0, DDSDM_DEFAULT

diDev.SetCommonDataFormat (DIFORMAT_KEYBOARD)
diDev.SetCooperativeLevel Form1.hwnd, DISCL_NONEXCLUSIVE _
Or DISCL_BACKGROUND
diDev.Acquire

ddsdPrim.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
ddsdPrim.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE _
Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
ddsdPrim.lBackBufferCount = 1
Set Prim = dd.CreateSurface(ddsdPrim)

ddsdcapsPrimBufer.lCaps = DDSCAPS_BACKBUFFER
Set PrimBufer = Prim.GetAttachedSurface(ddsdcapsPrimBufer)
PrimBufer.GetSurfaceDesc ddsdPrimBufer

ddsdOsnovaBMP.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
ddsdOsnovaBMP.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
ddsdOsnovaBMP.lWidth = 800 'ddsdPrimBufer.lWidth
ddsdOsnovaBMP.lHeight = 600 'ddsdPrimBufer.lWidth

Set OsnovaBMP = dd.CreateSurfaceFromFile("c:\1.bmp", ddsdOsnovaBMP) 'Загружаем первый буфер

ddsdSpriteBMP.lFlags = DDSD_CAPS
ddsdSpriteBMP.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
Set SpriteBMP = dd.CreateSurfaceFromFile("c:\2.bmp", ddsdSpriteBMP) 'Загружаем второй буфер

Key.low = 0
Key.high = 0
SpriteBMP.SetColorKey DDCKEY_SRCBLT, Key
Dim Kvadrat As RECT
Dim Kvadrat1 As RECT
Kvadrat.Top = 0
Kvadrat.Left = 0
Kvadrat.Bottom = 600 'ddsdPrimBufer.lHeight
Kvadrat.Right = 800 'ddsdPrimBufer.lWidth
Kvadrat1.Top = 0
Kvadrat1.Left = 0
Kvadrat1.Bottom = ddsdSpriteBMP.lHeight
Kvadrat1.Right = ddsdSpriteBMP.lWidth
PrimBufer.BltFast 0, 0, OsnovaBMP, Kvadrat, DDBLTFAST_WAIT
PrimBufer.BltFast 0, 0, SpriteBMP, Kvadrat1, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
Prim.Flip Nothing, DDFLIP_WAIT
End Sub

Private Sub Timer1_Timer()
Dim iKeyCounter As Integer
Dim Kvadrat As RECT
Dim Kvadrat1 As RECT
Kvadrat.Top = 0
Kvadrat.Left = 0
Kvadrat.Bottom = 600 'ddsdPrimBufer.lHeight
Kvadrat.Right = 800 'ddsdPrimBufer.lWidth
Kvadrat1.Top = 0
Kvadrat1.Left = 0
Kvadrat1.Bottom = ddsdSpriteBMP.lHeight
Kvadrat1.Right = ddsdSpriteBMP.lWidth
diDev.GetDeviceStateKeyboard diState
If diState.Key(2) Then '1'<> 0 Then
PrimBufer.BltFast 0, 0, OsnovaBMP, Kvadrat, DDBLTFAST_WAIT
PrimBufer.BltFast 100, 100, SpriteBMP, Kvadrat1, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
Prim.Flip Nothing, DDFLIP_WAIT
End If
If diState.Key(3) Then '1'<> 0 Then
PrimBufer.BltFast 0, 0, OsnovaBMP, Kvadrat, DDBLTFAST_WAIT
PrimBufer.BltFast 0, 0, SpriteBMP, Kvadrat1, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
Prim.Flip Nothing, DDFLIP_WAIT
End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 27 Then
diDev.Unacquire
dd.RestoreDisplayMode
dd.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
End
End If
End Sub