Yurich » 02.07.2003 (Ср) 3:35
Ниже часть кода из моей программы (в общем стандартный). Взгляни.
' **********************************************
' ***************** В модуль
Option Explicit
' Патчи для поиска файлов
Public BmpPath As String
Public Type Color
Red As Integer
Green As Integer
Blue As Integer
End Type
' Цвет фона
Public BColor As Color
' Цвет переднего плана
Public FColor As Color
'=============================================
'Объявления объектов DirectDraw
Public dx As New DirectX7
Public dd As DirectDraw7 'Объект DirectDraw
Public ddsPrimary As DirectDrawSurface7 'Главная поверхность
Public ddsBack As DirectDrawSurface7 'Задний буфер
Public ddsd As DDSURFACEDESC2 'Структура с описанием поверхности
Private ddsdStore As DDSURFACEDESC2 'Вспомогательная структура описания
Public rc As RECT 'Структура RECT для блиттинга
Public Caps As DDSCAPS2 'Структура с аппаратными возможностями
Public CurrentFont As New StdFont
'Инициализация DirectDraw в полноэкранном режиме
'============================================
Public Sub CreateDDFullscreen(srcHwnd As Long, ByVal dispX As Long, ByVal dispY As Long, ByVal dispColor As Long)
'Создаем объекты и устанавливаем режим
Set dd = dx.DirectDrawCreate("")
Call dd.SetCooperativeLevel(srcHwnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN Or DDSCL_ALLOWREBOOT)
Call dd.SetDisplayMode(dispX, dispY, dispColor, 0, DDSDM_DEFAULT)
'Создаем flipping chain
ddsd.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
ddsd.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
ddsd.lBackBufferCount = 1
Set ddsPrimary = dd.CreateSurface(ddsd)
'Получить BackBuffer
Caps.lCaps = DDSCAPS_BACKBUFFER
Set ddsBack = ddsPrimary.GetAttachedSurface(Caps)
End Sub
'Уничтожить DirectDraw
'====================
Public Sub DestroyDD()
'Убиваем поверхности, а ПОТОМ объект DirectDraw
Set ddsBack = Nothing
Set ddsPrimary = Nothing
'Восстанавливаем режим
Call dd.RestoreDisplayMode
Call dd.SetCooperativeLevel(0, DDSCL_NORMAL)
Set dd = Nothing
End Sub
'Очистка заданного буфера
'========================
Public Sub ClearBuffer(BackgroundColor As Color)
ddsBack.GetSurfaceDesc ddsdStore 'Получить описание очищаемой поверхности
'Заполняем структуру RECT, так, чтобы она охватывала всю поверхность
With rc
.Top = 0
.Left = 0
.Right = ddsdStore.lWidth 'Вот зачем нам надо было описание поверхности
.Bottom = ddsdStore.lHeight 'Высота и ширина подгоняются под нее
End With
' Заполняем цветом область, указанную в RECT
ddsBack.BltColorFill rc, RGB(BackgroundColor.Red, BackgroundColor.Green, BackgroundColor.Blue)
End Sub
'Создание поверхности из картинки в файле
'======================================
Public Function LoadPic(ByVal FileName As String, Optional CKey As Long = 0) As DirectDrawSurface7
'Объявления
Dim dds As DirectDrawSurface7 'Временная вспомогательная поверхность
Dim ddsd As DDSURFACEDESC2 'Описание временной поверхности
Dim StorePic As Long 'Временное хранилище картинки
Dim Bmp As Win32.BITMAP 'Тип BITMAP, описывающий растровое изображение
Dim hDCPicture As Long, hDCSurface As Long 'DC картинки и поверхности
Dim ddCK As DDCOLORKEY 'Для установки ключевого цвета
Const LR_LOADFROMFILE = &H10
Const LR_CREATEDIBSECTION = &H2000
'Загружаем картинку и получаем объект картинки
StorePic = LoadImage(0&, FileName, 0, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION) 'Загружаем картинку из файла
'Получаем описание картинки в структуру BITMAP
Win32.GetObject StorePic, Len(Bmp), Bmp
'Теперь, создаем поверхность
ddsd.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT 'Необходимые флаги
ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN 'Поверхность оффскринная
ddsd.lHeight = Bmp.bmHeight 'Высота поверхности как у картинки
ddsd.lWidth = Bmp.bmWidth 'Ширина поверхности как у картинки
'Вызываем метод, создающий поверхность
Set dds = dd.CreateSurface(ddsd) 'dd - глобальный объект DirectDraw7
'Получаем DC картинки
hDCPicture = Win32.CreateCompatibleDC(ByVal 0&)
Win32.SelectObject hDCPicture, StorePic
'Переводим картинку на поверхность
Call dds.restore
hDCSurface = dds.GetDC 'Подготовка к прямому доступу к поверхности
Call Win32.StretchBlt(hDCSurface, 0, 0, Bmp.bmWidth, Bmp.bmHeight, hDCPicture, 0, 0, Bmp.bmWidth, Bmp.bmHeight, SRCCOPY) 'Это копирует картинку в буфер
Call dds.ReleaseDC(hDCSurface) 'Конец прямого доступа к поверхности
Call Win32.DeleteDC(hDCPicture) 'Уничтожить объект картинки - больше не нужен
'Устанавливаем ключевой цвет
ddCK.low = RGB(BColor.Red, BColor.Green, BColor.Blue) 'Работает правильно только в 24-битном цвете (Но для случая 0 пойдет)
ddCK.high = ddCK.low
Call dds.SetColorKey(DDCKEY_SRCBLT, ddCK)
'Возвращаем объект
Set LoadPic = dds
'Set dds = Nothing
End Function
' Рисование картинок
' =======================================
Public Sub DrawPic(DdsPic As DirectDrawSurface7, ByVal OffsX As Long, ByVal OffsY As Long, Count As Integer, Width As Integer, Height As Integer, Optional Vvec As Boolean = False, Optional BmpX As Integer = 0, Optional BmpY As Integer = 0)
If Vvec = True Then
rc.Top = BmpY + Count * Height
rc.Left = BmpX
rc.Bottom = rc.Top + Height
rc.Right = BmpX + Width
Else
rc.Top = BmpY
rc.Left = BmpX + Count * Width
rc.Bottom = BmpY + Height
rc.Right = rc.Left + Width
End If
Call ddsBack.BltFast(OffsX, OffsY, DdsPic, rc, DDBLTFAST_DONOTWAIT Or DDBLTFAST_SRCCOLORKEY)
End Sub
'Рисование текста
'===========================================
Public Sub DrawText(OffsX As Long, OffsY As Long, TextBackColor As Color, TextForeColor As Color, Text As String, FontSize As Integer, Optional Transparent As Boolean = False, Optional FontBold As Boolean = False, Optional FontName As String = "Arial")
Dim TColor As Long
If Text = "" Then Exit Sub
ddsBack.SetFontBackColor RGB(TextBackColor.Red, TextBackColor.Green, TextBackColor.Blue)
ddsBack.SetFontTransparency Transparent
CurrentFont.Bold = FontBold
CurrentFont.Size = FontSize
CurrentFont.Name = FontName
ddsBack.SetFont CurrentFont
TColor = ddsBack.GetForeColor 'Чтобы не влиять потом на установленный цвет
ddsBack.SetForeColor RGB(TextForeColor.Red, TextForeColor.Green, TextForeColor.Blue)
ddsBack.DrawText OffsX, OffsY, Text, False
ddsBack.SetForeColor TColor
End Sub
' *****************************************************
' ******** В форму
Option Explicit
'Implements DirectXEvent
Dim Clouds As DirectDrawSurface7 ' Поверхность для рисунка облаков
Dim Running As Boolean 'Программа все еще работает?
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyEscape
Running = False ' Выход
End Select
End Sub
Private Sub Form_Activate()
BmpPath = App.path & "\Bitmaps\"
Running = True
' ---------------------------------------------------------------------------------------------------------------------------------
' Установить окно проги поверх всех остальных
Dim Flags As Long
SetWindowPos Me.HWnd, -1, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, Flags
' ----------------------------------------------------------------------------------------------------------------------------------
' Цвет фона
BColor.Red = 255
BColor.Green = 255
BColor.Blue = 255
' Цвет переднего плана
FColor.Red = 0
FColor.Green = 0
FColor.Blue = 0
' ----------------------------------------------------------------------------------------------------------------------------------
' Инициализация DirectSound
' DirectSoundCreate Me.HWnd
' Инициализация DirectMusic
'DirectMusicCreate
'LoadMID MusicPath & "Matrix.mid"
'MusicPlay
' Инициализация DirectDraw
CreateDDFullscreen Me.HWnd, 800, 600, 16
'----------------------------------------------------------------
' Загружаем картинки
Set Clouds = LoadPic(BmpPath & "Clouds.bmp") 'Создаем буфер с нашей графикой
' --------------------------------------------------------
' Создать DirectInput
' и установить мышь
' MouseInitialise Me, Me.HWnd
' Инициализируем наш курсор
' MouseX = 400
' MouseY = 300
' MouseSens = 2
' UpdateCursor
' Теперь создаем главный цикл прорисовки экрана
While Running = True
DoEvents 'Будем жалостливы к системе
ClearBuffer BColor 'Чистим полотно
' Рисуем облака
DrawPic Clouds, 0, 0, 0, 800, 600, False, 0
'DrawText 0, 0, BColor, FColor, "Description "
'Теперь, завершающие действия витка
ddsPrimary.Flip ddsBack, DDFLIP_WAIT ' Переводим задний буфер на передний
Wend
ClearBuffer BColor 'Чистим полотно перед выходом
'MusicStop
'DestroyDS
DestroyDD
'DestroyMouse
'Unload Me
'MainMenu.Show
End
End Sub