|
Option Explicit
Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim bmpBackground(2) As DirectDrawSurface7
Const min_pos As Long = 0
Const max_pos As Long = 3000
Dim x_pos As Long
Dim move_rate As Integer
Dim running As Boolean
Private Sub Form_Load()
Dim srcrect As RECT
Dim tile_pos As Long
Dim screen_x As Long
Dim i As Single
Me.Show
Me.Refresh
Initialization
BitmapLaden
x_pos = 1400
move_rate = 0
running = True
Do
x_pos = x_pos + move_rate
If x_pos < min_pos Then
x_pos = min_pos
move_rate = 0
End If
If x_pos > max_pos Then
x_pos = max_pos
move_rate = 0
End If
For i = 0 To 2
tile_pos = 400 * i + (x_pos \ 1200) * 1200
If (tile_pos + 1200) < (x_pos + 640) Then _
tile_pos = tile_pos + 1200
If (tile_pos + 400) >= x_pos Then
screen_x = tile_pos - x_pos
With srcrect
.Left = 0: .Top = 0
.Right = 400: .Bottom = 480
End With
If screen_x < 0 Then
srcrect.Left = srcrect.Left - screen_x
screen_x = 0
Else
If (screen_x + srcrect.Right) > 640 Then
srcrect.Right = 640 - screen_x
End If
End If
BackBuffer.BltFast screen_x, 0, bmpBackground(i), _
srcrect, DDBLTFAST_WAIT
End If
Next i
BackBuffer.SetForeColor vbRed
BackBuffer.SetFont Me.Font
BackBuffer.DrawText _
10, 10, "DirectDraw und Hintergrund-Scrolling ", False
BackBuffer.DrawText _
10, 30, "<Esc> beendet das Programm", False
BackBuffer.DrawText _
10, 50, "Cursortasten Links/Rechts für scrollen", False
BackBuffer.DrawText 10, 70, "mehrfaches Betätigen der " & _
"Cursortasten beschleunigt das Scrollen", False
PrimarySurface.Flip Nothing, DDFLIP_WAIT
ClearBuffer vbBlack
DoEvents
Loop While running
Terminate
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If (KeyAscii = vbKeyEscape) Then
running = False
End If
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyLeft Then
If move_rate > -20 Then
move_rate = move_rate - 5
End If
End If
If KeyCode = vbKeyRight Then
If move_rate < 20 Then
move_rate = move_rate + 5
End If
End If
End Sub
Sub Initialization()
Set DD7 = DX7.DirectDrawCreate("")
DD7.SetCooperativeLevel Me.hWnd, DDSCL_EXCLUSIVE Or _
DDSCL_FULLSCREEN Or DDSCL_ALLOWREBOOT
DD7.SetDisplayMode 640, 480, 16, 0, DDSDM_DEFAULT
With SurfaceDesc
.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or _
DDSCAPS_FLIP Or DDSCAPS_COMPLEX
.lBackBufferCount = 1
End With
Set PrimarySurface = DD7.CreateSurface(SurfaceDesc)
SurfaceDesc.ddsCaps.lCaps = DDSCAPS_BACKBUFFER
Set BackBuffer = _
PrimarySurface.GetAttachedSurface(SurfaceDesc.ddsCaps)
End Sub
Sub BitmapLaden()
Dim BmpDesc As DDSURFACEDESC2
BmpDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
BmpDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
BmpDesc.lWidth = 400
BmpDesc.lHeight = 480
Set bmpBackground(0) = _
DD7.CreateSurfaceFromFile(App.Path & "\city1.bmp", BmpDesc)
Set bmpBackground(1) = _
DD7.CreateSurfaceFromFile(App.Path & "\city2.bmp", BmpDesc)
Set bmpBackground(2) = _
DD7.CreateSurfaceFromFile(App.Path & "\city3.bmp", BmpDesc)
End Sub
Sub ClearBuffer(Color As Long)
Dim destrect As RECT
With destrect
.Bottom = 480
.Left = 0
.Right = 640
.Top = 0
End With
BackBuffer.BltColorFill destrect, Color
End Sub
Function GetTime() As Long
GetTime = DX7.TickCount
End Function
Sub Terminate()
Dim i As Single
For i = 0 To 2
Set bmpBackground(i) = Nothing
Next i
DD7.RestoreDisplayMode
DD7.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
Set PrimarySurface = Nothing
Set DD7 = Nothing
Set DX7 = Nothing
End
End Sub
|
|