Порядок создания объектов

[Каденов Мират]

Расскажите, пожалуйста, в каком порядке кто кого рожает (Create...) в DirectX Immedate Mode и в часности, как создать Direct3D7?

[Yurich]

Привет, Мират!

Технология создания Direct3D7 (в смысле оконч продукта) довольно длительна и муторна. Подробностями технологии киты игрового бизнеса ни с кем делиться не будут. Так что, будет тяжело. Могу посоветовать начать с RM-mode (в нем проще освоить азы). Отличается от IM незначительно. Я не крутой в D3D, но за пол-года научился делать модели, правильно накладывать текстуры, управлять моделями, сглаживание, туман, освещение, прозрачность, перемещение камеры (как в нормальной 3D от клавы и мыши), DirecMusic & Sound. Впереди полупрозрачность и анимация.
Что надо:
1. 3DSMax или подобный
2. DX7SDK
3. Конвертер .3DS в .X (идет вместе с SDK)
4. Как можно больше работоспособных примеров.

Чтобы не было скучно, читай ниже!!!

В модуль:

Option Explicit

' Патчи для поиска файлов
' -----------------------------------------------------------------------
Public MeshPath As String ' Путь для загрузки Х-моделей
Public BmpPath As String ' Путь для загрузки текстур

' Объекты DirectX 7
' -----------------------------------------------------------------------
Public dx As New DirectX7 ' От него все произрастает
Public DDFullScreen As DirectDraw4 ' Объект DirectDraw для
' полноэкранного режима
Public D3DRM As Direct3DRM3 ' Объект D3D:RM
Public ddsd3D As DDSURFACEDESC2 ' Описание поверхности
Public Caps As DDSCAPS2 ' Описание аппаратных
' возможностей
Public Device As Direct3DRMDevice3 ' Устройство рендеринга

Public Scene As Direct3DRMFrame3 ' Фрейм сцены
Public CameraSupport As Direct3DRMFrame3 ' Фрейм тележки для
' камеры
Public Camera As Direct3DRMFrame3 ' Фрейм камеры
Public CameraLight As Direct3DRMLight ' Подсветка со стороны
' камеры
Public MainLightPoint As Direct3DRMLight ' Основное точечное
' освещение сцены
Public MainLightAmbient As Direct3DRMLight ' Основное окружающее
' освещение сцены
Public FrameMainLight As Direct3DRMFrame3 ' Фрейм основного
' освещения сцены

Public dds4Primary As DirectDrawSurface4 ' Передний буфер для
' DDFullScreen
Public dds4Back As DirectDrawSurface4 ' Задний буфер для
' DDFullScreen
Public ViewPort As Direct3DRMViewport2 ' Все будет
' рендериться сюда
Public RenderGuid As String ' Используемое
' устройство
' рендеринга
Public Texture As Direct3DRMTexture3 'Текстура
Public Face As Direct3DRMFace2 ' Лицо модели

Public Const BACKSURFACECOLORNULL = 0 ' Цвет для заднего
' буфера
Public RC As RECT

Public Sub InitFullscreen(HWnd As Long, sX As Long, sY As Long, sBitDepth As Long)
' Стандартное создание DirectDraw4 с главной поверхностью и
' одним задним буфером
' (под 3D ускоритель)

RenderGuid = "IID_IDirect3DHALDevice"

ddsd3D.lFlags = DDSD_BACKBUFFERCOUNT Or DDSD_CAPS
ddsd3D.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_3DDEVICE Or DDSCAPS_COMPLEX Or DDSCAPS_FLIP
ddsd3D.lBackBufferCount = 1

Set DDFullScreen = dx.DirectDraw4Create("")
DDFullScreen.SetCooperativeLevel HWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE Or DDSCL_ALLOWREBOOT
DDFullScreen.SetDisplayMode sX, sY, sBitDepth, 0, DDSDM_STANDARDVGAMODE
Set dds4Primary = DDFullScreen.CreateSurface(ddsd3D)
Caps.lCaps = DDSCAPS_BACKBUFFER _
Or DDSCAPS_3DDEVICE Or DDSCAPS_VIDEOMEMORY
Set dds4Back = dds4Primary.GetAttachedSurface(Caps)

' Создание Direct3D:RM
' --------------------------------------------------

Set D3DRM = dx.Direct3DRMCreate()

Set Device = D3DRM.CreateDeviceFromSurface(RenderGuid, DDFullScreen, dds4Back, D3DRMDEVICE_DEFAULT)
Device.SetRenderMode D3DRMRENDERMODE_VIEWDEPENDENTSPECULAR _
Or D3DRMRENDERMODE_BLENDEDTRANSPARENCY
'Or D3DRMRENDERMODE_SORTEDTRANSPARENCY

Device.SetQuality D3DRMRENDER_GOURAUD ' Or D3DRMSHADE_GOURAUD

'Device.SetShades 256
Device.SetDither D_TRUE
Device.SetTextureQuality D3DRMTEXTURE_MIPLINEAR

Set Scene = D3DRM.CreateFrame(Nothing)

' Создадим "тележку", на которой будет стоять камера.
Set CameraSupport = D3DRM.CreateFrame(Scene)
' Прицепим на тележку камеру.
Set Camera = D3DRM.CreateFrame(CameraSupport)

' Чертов ViewPort - долго из-за него пришлось повозиться
Set ViewPort = D3DRM.CreateViewport(Device, Camera, 0, 0, sX, sY)

End Sub

Public Sub DestroyEverything()
'Убиваем все что можно и нельзя
Set dds4Back = Nothing
Call DDFullScreen.RestoreDisplayMode
Call DDFullScreen.SetCooperativeLevel(0, DDSCL_NORMAL)
Set DDFullScreen = Nothing
Set ViewPort = Nothing
Set Device = Nothing
Set D3DRM = Nothing
Set dx = Nothing
End Sub

Public Sub GetBackSurfaceDescription(ddsBack As DirectDrawSurface4)
'Получить описание очищаемой поверхности
ddsBack.GetSurfaceDesc ddsd3D

'Заполняем структуру RECT, так, чтобы она охватывала всю поверхность
With RC
.Top = 0
.Left = 0
.Right = ddsd3D.lWidth ' Вот зачем нам надо было описание поверхности
.Bottom = ddsd3D.lHeight ' Высота и ширина подгоняются под нее
End With
End Sub

Public Sub ClearBuffer3D(dds As DirectDrawSurface4)
' Заполняем цветом область, указанную в RC (задний буфер)
dds.BltColorFill RC, BACKSURFACECOLORNULL
End Sub

Public Sub DestroyAll()
'SoundStop BackSound
'DestroyDS ' Уничтожить DirectSound
'DestroyKeyboard
'DestroyMouse
DestroyEverything ' Уничтожить все созданные D3D объекты
End Sub

' В форму:
' --------------------------------------------------------------------
Option Explicit
Implements DirectXEvent

Dim Running As Boolean 'Программа все еще работает?

Dim dir As D3DVECTOR
Dim up As D3DVECTOR

Dim CX As Single, CZ As Single
Dim CameraX As Single
Dim CameraY As Single
Dim CameraZ As Single

' Головной SUB
Private Sub Form_Load()
Dim MyFont As New StdFont
Dim Fps As Integer
Dim i As Integer, D As Integer

' -------------------- настройка патчей

SoundPath = App.Path & "\Sound\"
MeshPath = App.Path & "\Meshes\"
BmpPath = App.Path & "\Bitmaps\"

Dim Flags As Long

' Установить окно проги поверх всех остальных (надо подключить
' к проекту Win32.tlb или описать эту API ф-ю ручками)

SetWindowPos Me.HWnd, -1, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, Flags

' ---------------------------------------------------------------------------------------------------------------------------------
' Инициализация Direct3D
InitFullscreen Me.HWnd, 800, 600, 16

' ----------------------------------------------------------------------------------------------------------------------------------

' подготвка сцены и запуск
LoadMyObjects
dds4Back.SetFontBackColor dx.CreateColorRGB(100, 20, 180)
dds4Back.SetFontTransparency False
MyFont.Size = 22
MyFont.Name = "Arial"
dds4Back.SetFont MyFont

Running = True

' Опции отображения

'ViewPort.SetField 0.5
ViewPort.SetBack 5000 ' Задает радиус видимости объектов

'ViewPort.SetPlane -1, 1, -1, 1 ' Придает изображению трапецеидальность
'ViewPort.SetUniformScaling D_FALSE ' Что-то похожее на предыдущее, но в
' вертикальном направлении. Картинка
' как бы сплющивается (трапецеидальность
' проявляется при наклоне камеры).
Dim FPSTimer As Single
Do While Running
DoEvents ' Обязательная строка !!!

i = i + 1
If Timer - FPSTimer > 1 Then
Fps = i
FPSTimer = Timer
i = 0
End If

dds4Back.BltColorFill RC, BACKSURFACECOLORNULL 'Чистим задний буфер
D3DRM.Tick 0 ' Рендеринг кадра
dds4Back.DrawText 100, 100, "FPS=" & Fps, True
dds4Primary.Flip Nothing, DDFLIP_NOVSYNC Or DDFLIP_WAIT 'Показываем сцену
Loop
DestroyAll ' Выход
Unload Me
End Sub

Sub LoadMyObjects()

' Без этой строки текстуры грузятся только из корневой
' папки проекта
D3DRM.SetSearchPath BmpPath

' Елки-палки
Dim Tree As Direct3DRMMeshBuilder3
Set Tree = D3DRM.CreateMeshBuilder
Tree.LoadFromFile MeshPath & "Tree.x", 0, D3DRMLOAD_FROMFILE, Nothing, Nothing
Tree.SetColorRGB 1, 1, 1
Set Face = Tree.GetFace(0)
Set Texture = Face.GetTexture
Texture.SetDecalTransparency D_TRUE ' прозрачность
Texture.SetDecalTransparentColor 0 ' черный прозрачен
Tree.SetQuality D3DRMRENDER_GOURAUD Or D3DRMLIGHT_ON
Scene.AddVisual Tree

' Объект для установки основного освещения
Set FrameMainLight = D3DRM.CreateFrame(Scene)
' Основное точечное освещение сцены
'Set MainLightPoint = D3DRM.CreateLight(D3DRMLIGHT_POINT, dx.CreateColorRGB(1, 1, 1))
' Основное окружающее освещение сцены
Set MainLightAmbient = D3DRM.CreateLightRGB(D3DRMLIGHT_AMBIENT, 0.75, 0.75, 0.75)
' Точечное освещение со стороны камеры
'Set CameraLight = D3DRM.CreateLight(D3DRMLIGHT_POINT, dx.CreateColorRGB(0.6, 0.6, 0.6))
'Camera.AddLight CameraLight
'FrameMainLight.AddLight MainLightPoint
FrameMainLight.AddLight MainLightAmbient
'FrameMainLight.SetPosition Nothing, 0, 20, 0

' ---------------------
'Устанавливаем камеру
CameraX = 0
CameraY = 0
CameraZ = -100
CameraSupport.SetPosition Nothing, CameraX, Floor(CurrentFloor).MaxY, CameraZ
Camera.SetPosition CameraSupport, 0, 0, 0
End Sub

' По обработке клавы для выхода смотри в DX-форуме!!!
' Спрашивай, безусловно постараюсь помочь.

[Каденов Мират]

Спасибо за сообщение - долгий разбор "по косточкам" еще впереди

[Yurich]

Загляни в тему "Поспорьте со мной", тебя это тоже касается!

[Каденов Мират]

Почитал тему, но предложить ничего не могу. Перечитаю еще раз По вашему примеру я сделал программку, котороя благополучно работает, но как можно программно создавать Mesh'и, а не загружать их из файла?

[Yurich]

" как можно программно создавать Mesh'и, а не загружать их из файла? "

Должно выглядеть прим (я этим пока не занимался) так :
Dim Mesh As Direct3DRMMesh
Dim MeshB As Direct3DRMMeshBuilder3
Set Mesh=MeshB.CreateMesh
Mesh.SetVertex ....
Mesh.SetVertices ...
...
Call MeshB.AddMesh(Mesh)
Загляни в Object Browser и поэкспериментируй

-----------------------------------------------------------------
Клавиатура и мышь!!! Код подходит и
для DX8 (за исключением нескольких деталей)
-----------------------------------------------------------------

В модуль:
-----------------------

Option Explicit

Public Kbdi As DirectInput
Public KbdiDEV As DirectInputDevice

''' Public DX8 As New DirectX8
''' Public DX8Input As DirectInput8
''' Public KbdiDEV As DirectInputDevice8

Public KbdiState As DIKEYBOARDSTATE

Public Const KEY_ESCAPE = 1
Public Const KEY_1 = 2
Public Const KEY_2 = 3
Public Const KEY_3 = 4
Public Const KEY_4 = 5
Public Const KEY_5 = 6
Public Const KEY_6 = 7
Public Const KEY_7 = 8
Public Const KEY_8 = 9
Public Const KEY_9 = 10
Public Const KEY_0 = 11
Public Const KEY_MINUS = 12
Public Const KEY_EQUALS = 13
Public Const KEY_BACKSPACE = 14
Public Const KEY_TAB = 15
Public Const KEY_Q = 16
Public Const KEY_W = 17
Public Const KEY_E = 18
Public Const KEY_R = 19
Public Const KEY_T = 20
Public Const KEY_Y = 21
Public Const KEY_U = 22
Public Const KEY_I = 23
Public Const KEY_O = 24
Public Const KEY_P = 25
Public Const KEY_LBRACKET = 26
Public Const KEY_RBRACKET = 27
Public Const KEY_ENTER = 28
Public Const KEY_LCTRL = 29 ' Left CTRL key
Public Const KEY_A = 30
Public Const KEY_S = 31
Public Const KEY_D = 32
Public Const KEY_F = 33
Public Const KEY_G = 34
Public Const KEY_H = 35
Public Const KEY_J = 36
Public Const KEY_K = 37
Public Const KEY_L = 38
Public Const KEY_SEMICOLON = 39
Public Const KEY_APOSTROPHE = 40
Public Const KEY_GRAVE = 41 ' Grave accent (`)
Public Const KEY_LSHIFT = 42
Public Const KEY_BSLASH = 43 ' Back slash (\)on main keyboard"
Public Const KEY_Z = 44
Public Const KEY_X = 45
Public Const KEY_C = 46
Public Const KEY_V = 47
Public Const KEY_B = 48
Public Const KEY_N = 49
Public Const KEY_M = 50
Public Const KEY_COMMA = 51
Public Const KEY_PERIOD = 52
Public Const KEY_FSLASH = 53 ' Forward slash (/)on main keyboard
Public Const KEY_RSHIFT = 54
Public Const KEY_MULTIPLY = 55 ' Asterisk on numeric keypad
Public Const KEY_LMENU = 56
Public Const KEY_SPACE = 57 ' Spacebar
Public Const KEY_CAPSLOCK = 58
Public Const KEY_F1 = 59
Public Const KEY_F2 = 60
Public Const KEY_F3 = 61
Public Const KEY_F4 = 62
Public Const KEY_F5 = 63
Public Const KEY_F6 = 64
Public Const KEY_F7 = 65
Public Const KEY_F8 = 66
Public Const KEY_F9 = 67
Public Const KEY_F10 = 68
Public Const KEY_NUMLOCK = 69
Public Const KEY_SCROLLLOCK = 70
Public Const KEY_NUMPAD7 = 71
Public Const KEY_NUMPAD8 = 72
Public Const KEY_NUMPAD9 = 73
Public Const KEY_NUMPADMINUS = 74 ' Hyphen (minus sign) on numeric keypad
Public Const KEY_NUMPAD4 = 75
Public Const KEY_NUMPAD5 = 76
Public Const KEY_NUMPAD6 = 77
Public Const KEY_NUMPADPLUS = 78 ' Plus sign on numeric keypad
Public Const KEY_NUMPAD1 = 79
Public Const KEY_NUMPAD2 = 80
Public Const KEY_NUMPAD3 = 81
Public Const KEY_NUMPAD0 = 82
Public Const KEY_NUMPADPOINT = 83 ' Period (decimal point) on numeric keypad
Public Const KEY_F14 = 84
Public Const KEY_F15 = 85
Public Const KEY_F13 = 86
Public Const KEY_F11 = 87
Public Const KEY_F12 = 88
Public Const KEY_NUMPADENTER = 156
Public Const KEY_RCTRL = 157 ' Right CTRL key
Public Const KEY_NUMPADCOMMA = 91 ' Comma on NEC PC98 numeric keypad
Public Const KEY_NUMPADFSLASH = 181 ' Forward slash (/)on numeric keypad
Public Const KEY_SYSRQ = 183
Public Const KEY_RMENU = 184
Public Const KEY_HOME = 199
Public Const KEY_UP = 200
Public Const KEY_PGUP = 201
Public Const KEY_LEFT = 203
Public Const KEY_RIGHT = 205
Public Const KEY_END = 207
Public Const KEY_DOWN = 208
Public Const KEY_PGDN = 209
Public Const KEY_INSERT = 210
Public Const KEY_DELETE = 211
Public Const KEY_LWIN = 219 ' Left Windows key
Public Const KEY_RWIN = 220 ' Right Windows key
Public Const KEY_APPS = 221 ' Application key
Public Const KEY_PAUSE = 116

''' Public Sub DX8InputCreate()
''' Set DX8Input = DX8.DirectInputCreate
''' End Sub

Public Sub KeyboardInit(HWnd As Long)

''' If DX8Input Is Nothing Then DX8InputCreate
''' Set KbdiDEV = DX8Input.CreateDevice("GUID_SysKeyboard")

Set Kbdi = dx.DirectInputCreate() 'create the object, must be done before anything else
Set KbdiDEV = Kbdi.CreateDevice("GUID_SysKeyboard") 'Create a keyboard object off the Input object
KbdiDEV.SetCommonDataFormat DIFORMAT_KEYBOARD 'specify it as a normal keyboard, not mouse or joystick
KbdiDEV.SetCooperativeLevel HWnd, DISCL_FOREGROUND Or DISCL_NONEXCLUSIVE
KbdiDEV.Acquire 'aquire the keystates.
End Sub

' Отруб клавиатуры
Public Sub DestroyKeyboard()
KbdiDEV.Unacquire
Set KbdiDEV = Nothing
Set Kbdi = Nothing

''' Set DX8Input = Nothing
''' Set DX8 = Nothing

End Sub

-----------------------------------------
В модуль:
-----------------------------------------

Option Explicit

Public SystemCursorPoint As POINTAPI

''' Public objDXEvent As DirectXEvent8
''' Public objDIDev As DirectInputDevice8
''' Public objDIEnum As DirectInputEnumDevices8

Public objDXEvent As DirectXEvent
Public objDI As DirectInput
Public objDIDev As DirectInputDevice
Public objDIEnum As DirectInputEnumDevices
Public Const BUFFERSIZE = 50 ' Определялся экспериментально.
' Значение меньше 20 может приводить к зависаниям, почему, пока не знаю
Public EventHandle As Long
Public procOld As Long
'Public Const WM_ENTERMENULOOP = &H211


' =================================================================
' Создать DirectInput и установить мышь

Public Sub MouseInitialise(MouseEvent As DirectXEvent, HWnd As Long)
Dim MouseName As String

' Получить позицию перед тем, как Windows потеряет курсор
GetCursorPos SystemCursorPoint
' Выключить SisMouse
ShowCursor 0

''' If DX8Input Is Nothing Then DX8InputCreate
''' Set objDIEnum = DX8Input.GetDIDevices(DI8DEVTYPE_MOUSE,DIEDFL_ATTACHEDONLY)
''' MouseName = objDIEnum.GetItem(1).GetGuidInstance
''' Set objDIDev = DX8Input.CreateDevice(MouseName) 'This is where it lists all the available devices


Set objDI = dx.DirectInputCreate
Set objDIEnum = objDI.GetDIEnumDevices(DIDEVTYPE_MOUSE, DIEDFL_ATTACHEDONLY)

' Определить системное имя мыши
MouseName = objDIEnum.GetItem(1).GetGuidInstance
Set objDIDev = objDI.CreateDevice(MouseName) 'This is where it lists all the available devices

' Установить Dx-прерывание от мыши
objDIDev.SetCommonDataFormat DIFORMAT_MOUSE
objDIDev.SetCooperativeLevel HWnd, DISCL_FOREGROUND Or DISCL_EXCLUSIVE

' Установить размер буфера
Dim diProp As DIPROPLONG
diProp.lHow = DIPH_DEVICE
diProp.lSize = Len(diProp) ' ЭТО ДЛЯ DX8 НЕ НУЖНО !!!
diProp.lObj = 0
diProp.lData = BUFFERSIZE
Call objDIDev.SetProperty("DIPROP_BUFFERSIZE", diProp)

' Спросить об уведомлениях и назначить обработчик события
''' EventHandle = DX8.CreateEvent(MouseEvent)
EventHandle = dx.CreateEvent(MouseEvent)
objDIDev.SetEventNotification EventHandle

' Захватить прерывание от мыши
objDIDev.Acquire

End Sub

' Отруб мыши
Public Sub DestroyMouse()

''' If EventHandle <> 0 Then DX8.DestroyEvent EventHandle
''' Set objDIDev = Nothing
''' Set DX8Input = Nothing
''' Set DX8 = Nothing

objDIDev.Unacquire
If EventHandle <> 0 Then dx.DestroyEvent EventHandle
Set objDIDev = Nothing
Set objDI = Nothing
'Поставить системный курсор в старую позицию
SetCursorPos SystemCursorPoint.X, SystemCursorPoint.Y
ShowCursor 1
End Sub

--------------------------------------------
В форму (добавить к предыдущему коду)!!!
-------------------------------------------


Implements DirectXEvent
' ...
Dim ViewUpDown As Single

Private Sub Form_Load()
' ...
' ...
' ...
dds4Back.SetFont MyFont

' Создать DirectInput и установить мышь
MouseInitialise Me, Me.HWnd
' Перехватить клавиатуру
KeyboardInit Me.HWnd

Running = True
' ...
' ...
Do While Running
DoEvents ' Обязательная строка !!!
KeyBoard
' ...
' ...
Loop
DestroyAll ' Не забудь там снять ремарки!!!
Unload Me
End Sub

' ----------------------------------------------------
' Обработка клавы (придется убрать все Бейсик-процедуры)

Private Sub KeyBoard()
Dim i As Integer

' получить состояние клавиатуры
KbdiDEV.GetDeviceStateKeyboard KbdiState
' здесь можно проверить, нажата ли
' клавиша и если нет, выполнить Exit Sub !

' Определить текущую ориентацию тележки
' с камерой
CameraSupport.GetOrientation Nothing, dir, up

With KbdiState

' нажата 'Escape' - выход
If .Key(KEY_ESCAPE) Then
Running = False
Exit Sub
End If

CX = CameraX
CZ = CameraZ

' вперед
If .Key(KEY_UP) Or .Key(KEY_W) Then
CX = CX + dir.X
CZ = CZ + dir.Z
End If

' назад
If .Key(KEY_DOWN) Or .Key(KEY_S) Then
CX = CX - dir.X
CZ = CZ - dir.Z
End If

' вправо
If .Key(KEY_D) Then
CX = CX + dir.Z
CZ = CZ - dir.X
End If

' влево
If .Key(KEY_A) Then
CX = CX - dir.Z
CZ = CZ + dir.X
End If

' если положение тележки поменялось
If CX <> CameraX Or CZ <> CameraZ Then RunCamera

' повернуться вправо
If .Key(KEY_RIGHT) Then
CameraSupport.AddRotation D3DRMCOMBINE_BEFORE, 0, 1, 0, 0.05
End If

' повернуться влево
If .Key(KEY_LEFT) Then
CameraSupport.AddRotation D3DRMCOMBINE_BEFORE, 0, -1, 0, 0.05
End If

' посмотреть вниз
If .Key(KEY_PGDN) Then
If ViewUpDown < 1.2 Then
ViewUpDown = ViewUpDown + 0.05
Camera.AddRotation D3DRMCOMBINE_BEFORE, 1, 0, 0, 0.05
End If
End If

' посмотреть вверх
If .Key(KEY_PGUP) Then
If ViewUpDown > -1.2 Then
ViewUpDown = ViewUpDown - 0.05
Camera.AddRotation D3DRMCOMBINE_BEFORE, -1, 0, 0, 0.05
End If
End If
End With
End Sub

' ---------------------------------------------------------------------------------------------------------------------
' перемещение камеры
Private Sub RunCamera()
CameraSupport.SetPosition Nothing, CX, 0, CZ
'SoundPlay Sound, 0 ' звуки шагов, мотора и т.п.
CameraX = CX
CameraZ = CZ
End Sub

' ==================================================================
Private Sub DirectXEvent_DXCallback(ByVal eventid As Long)
' Здесь мы распознаем изменения в положении мыши. Обычно это движение по осям
' или нажатие или отпускание кнопки, но это может также означать "потерю" мыши.
' Note: нет события, означающего потерю мыши. Обычно потеря мыши означает,
' что окно приложения потеряло фокус
Dim diDeviceData(1 To BUFFERSIZE) As DIDEVICEOBJECTDATA
Dim i As Integer
Dim Y As Single
' Обработать данные
For i = 1 To objDIDev.GetDeviceData(diDeviceData, DIGDD_DEFAULT)
Select Case diDeviceData(i).lOfs
' Повороты влево-право
Case DIMOFS_X
Y = diDeviceData(i).lData * 0.005
CameraSupport.AddRotation D3DRMCOMBINE_BEFORE, 0, 1, 0, Y
' Головой вверх-вниз
Case DIMOFS_Y
Y = diDeviceData(i).lData * 0.005
If (Y < 0 And ViewUpDown > -1.2) Or _
(Y > 0 And ViewUpDown < 1.2) Then
ViewUpDown = ViewUpDown + Y
Camera.AddRotation D3DRMCOMBINE_BEFORE, 1, 0, 0, Y
End If
Case DIMOFS_BUTTON0 ' Левая кнопка
Running = False ' стоп игра!!!
'If diDeviceData(i).lData And &H80 Then ' Нажата
'
'End If
End Select
Next i
End Sub

[Каденов Мират]

Разберем и это Спасибо за помощь. Кстати, ведь в более поздних версиях DX нет RM? Тогда все равно когда-нибудь придется переходить на IM

[Yurich]

Ничего подобного! RM включен и в DX8, только без явного названия.
По DX9 пока не знаю.

Код для саунда
------------------------------------

Option Explicit

Public SoundPath As String
Public Const MaxSounds = 20

Public m_ds As DirectSound 'Это объект DirectSound. Позже, мы "Создадим" его из главного объекта DirectX
Public m_dsBuffer(1 To MaxSounds) As DirectSoundBuffer
Public BufferDesc As DSBUFFERDESC 'этот новый объект передается DS, чтобы описать, какой буфер создается
'Очень похоже на описание поверхности DirectDraw
Public WaveFormat As WAVEFORMATEX


Public Sub DirectSoundCreate(HWnd As Long)
On Local Error Resume Next
'Сначала нам надо создать объект DSound.
' Это должно быть сделано прежде, чем использовать
' любые его возможности.
'Это также должно быть сделано перед созданием.
Set m_ds = dx.DirectSoundCreate("")
'Эти строки проверяют наличие ошибок, если ошибок нет, то у пользователя установлен DirectX7 и работающая звуковая карта
If Err.Number <> 0 Then
MsgBox "Unable to start DirectSound. Check to see that your sound card is properly installed"
End
End If

'ЭТО ДОЛЖНО БЫТЬ УСТАНОВЛЕНО ПЕРЕД СОЗДАНИЕМ БУФЕРОВ
'DSSCL_PRIORITY=нет совместной работы. Эксклюзивный доступ к звуковой карте
' Нужно для игр
' DSSCL_NORMAL=совместная работа с другими приложениями
' Полезен для мультимедийных приложений Windows
m_ds.SetCooperativeLevel HWnd, DSSCL_PRIORITY

'Эти утановки выполняются почти для каждого приложения
BufferDesc.lFlags = DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME Or DSBCAPS_STATIC
WaveFormat.nFormatTag = WAVE_FORMAT_PCM
WaveFormat.nChannels = 2 'Два канала
WaveFormat.lSamplesPerSec = 44100 '44 kHz можно конечно менять
WaveFormat.nBitsPerSample = 8 '16 бит лучше чем 8 (лучше качество)
WaveFormat.nBlockAlign = WaveFormat.nBitsPerSample / 8 * WaveFormat.nChannels
WaveFormat.lAvgBytesPerSec = WaveFormat.lSamplesPerSec * WaveFormat.nBlockAlign

End Sub

' =========================================
' Код загрузки Wav - файла. Функция возвращает номер буфера
Public Function LoadWav(WavName As String, SoundBuffer As Integer) As Integer
On Error GoTo FindErr
' Загружаем в буфер Wav-файл
Set m_dsBuffer(SoundBuffer) = m_ds.CreateSoundBufferFromFile(WavName, BufferDesc, WaveFormat)

' Установим "свойства" паннинга и громкости
m_dsBuffer(SoundBuffer).SetPan 0
m_dsBuffer(SoundBuffer).SetVolume 0
LoadWav = SoundBuffer ' возвращаем номер буфера
Exit Function
FindErr:
LoadWav = 0 ' Иначе ошибка
End Function
' ===========================================
' Код проигрывания музыки
Public Sub SoundPlay(NumBuffer As Integer, Repeat As Integer, Optional Reset As Boolean = False)
If m_dsBuffer(NumBuffer) Is Nothing Then Exit Sub ' Если буфер пуст, то выйдем из процедуры
If Reset = True Then
m_dsBuffer(NumBuffer).Stop
m_dsBuffer(NumBuffer).SetCurrentPosition 0
End If
'Когда применяется метод "m_dsbuffer(*).play", можно указать режим "DSBPLAY_NORMAL"
'и "DSBPLAY_LOOPING", переменная Repeat выполняет то же, 0 = нормально, 1=зацикленно.
m_dsBuffer(NumBuffer).Play Repeat
End Sub

' ==========================================
' Код остановки музыки
Public Sub SoundStop(NumBuffer As Integer, Optional Reset As Boolean = True)
If m_dsBuffer(NumBuffer) Is Nothing Then Exit Sub ' Если буфер пуст, то выйдем из процедуры
m_dsBuffer(NumBuffer).Stop
If Reset = True Then
m_dsBuffer(NumBuffer).SetCurrentPosition 0
End If
End Sub

Public Sub DestroyDS()
Dim i As Integer
On Error Resume Next
i = 1
While i <= MaxSounds
If m_dsBuffer(i) Is Nothing Then GoTo NonStop
m_dsBuffer(i).Stop
NonStop:
i = i + 1
Wend
Set m_ds = Nothing
End Sub

---------------------------------------------
Код для мюзик (лишнее уберешь сам)
---------------------------------------------
Option Explicit

Public MusicPath As String

Dim Perf As DirectMusicPerformance
Dim Perf2 As DirectMusicPerformance
'Эти 2 переменные - буфера. "perf" - главный, "perf2" используется чтобы
'Собрать информацию о MIDI файле

Dim Seg As DirectMusicSegment
Dim SegState As DirectMusicSegmentState 'Сегменты - содержат сегменты музыки!
Dim Loader As DirectMusicLoader 'Это объект, который помогает загрузить файлы в буферы

Public GetStartTime As Long
Public Offset As Long
Public MtTime As Long
Public MtLength As Double
Public DTempo As Double
Public FIsPaused As Boolean

Public Timesig As DMUS_TIMESIGNATURE 'Содержит подпись времени в MIDI файле

Public IsPlayingCheck As Boolean 'Простое значение, говорящее проигрывается музыка или нет
Dim msg As String 'Будет использовано при отлове ошибок
Dim Time As Double
Dim ISITPAUSED As Boolean
'--ВРЕМЯ-- Эти установки будут использованы в секции разработки прогресс-бара
Dim Total_Time As Double



Dim Current_Time As Double
Dim Percent_Time As Double


Public Sub DirectMusicCreate()
On Error GoTo LocalErrors
Set Loader = dx.DirectMusicLoaderCreate() 'Это главный компонент DMusic
' Созданием Perf2 мы добиваемся того, что получаеи информацию о сегментах без их
' проигрывания
Set Perf2 = dx.DirectMusicPerformanceCreate() 'Создать второй буфер.

Call Perf2.Init(Nothing, 0)
Perf2.SetPort -1, 80
Call Perf2.GetMasterAutoDownload
Set Perf = dx.DirectMusicPerformanceCreate() 'Создать первый буфер
Call Perf.Init(Nothing, 0)
Perf.SetPort -1, 80
Call Perf.SetMasterAutoDownload(True)
' Устанавливаем громкость музыки

Perf.SetMasterVolume (100)
Exit Sub
LocalErrors:

End Sub

' =======================================
' Загрузка миди

Public Sub LoadMID(MidName As String)
Dim Minutes As Integer
Dim a As Integer
Dim Length As Integer
Dim Length2 As Integer

On Error GoTo LocalErrors
If Not Seg Is Nothing And Not SegState Is Nothing Then ' Cостояния Segment и SegmentState
If Perf.IsPlaying(Seg, SegState) = True Then ' сегмент проигрывается, поэтому
MsgBox "Пожалуйста, остановите музыку прежде чем выбирать новый сегмент"
Exit Sub
ElseIf ISITPAUSED = True Then
MsgBox "Пожалуйста, остановите музыку прежде чем выбирать новый сегмент"
'Простой отловщик ошибок
Exit Sub
End If
End If
Set Loader = Nothing
Set Loader = dx.DirectMusicLoaderCreate

Set Seg = Loader.LoadSegment(MidName)
' Установть поисковую диреторию на основе размещения загруженного .mid файла
Length = Len(MidName)
Length2 = Length

Dim path As String
Do While path <> "\"
path = Mid(MidName, Length, 1)
Length = Length - 1
Loop
Dim SearchDir As String
SearchDir = Left(MidName, Length)
Loader.SetSearchDirectory (Left(MidName, Length + 1))
Perf2.SetMasterAutoDownload True

Seg.SetStandardMidiFile
Exit Sub
LocalErrors:
If Not Seg Is Nothing Then
Call Perf2.Stop(Seg, Nothing, 0, 0) 'При ошибке прекращаем музыку
End If
MsgBox ("Проблема при открытии файла.") 'Скажем об ошибке пользователю
End Sub

' =============================================
' Код проигрывания MIDI

Public Sub MusicPlay()
If Seg Is Nothing Then 'Пользоваель еще не нажимал "Открыть"
MsgBox ("Пожалуйста, откройте сегмент или MIDI файл перед проигрыванием ")
Exit Sub
End If
If FIsPaused Then 'Если в режиме паузы, продолжаем проигрывать с этого места
Offset = MtTime - GetStartTime + Offset + 1
Call Seg.SetStartPoint(Offset)
Set SegState = Perf.PlaySegment(Seg, 0, 0)
Else 'Перемотка назад, а затем возобновляем проигрывание
Offset = 0
If Perf.IsPlaying(Seg, SegState) = True Then
Call Perf.Stop(Seg, SegState, 0, 0)
End If
Seg.SetStartPoint (0)
Set SegState = Perf.PlaySegment(Seg, 0, 0)
Exit Sub
End If
FIsPaused = False
End Sub

' =============================================
' Код паузы

Public Sub MusicPause()

On Error GoTo LocalErrors
If Seg Is Nothing Then 'Если еще ничего не загружено, уходим
Exit Sub
End If
IsPlayingCheck = Perf.IsPlaying(Seg, SegState)
If IsPlayingCheck = True Then 'музыка играет
FIsPaused = True
' приостановить музыку и "нажать" кнопку
MtTime = Perf.GetMusicTime()
GetStartTime = SegState.GetStartTime()
Call Perf.Stop(Seg, Nothing, 0, 0)
Else
FIsPaused = False
Offset = MtTime - GetStartTime + Offset + 1
Call Seg.SetStartPoint(Offset)
Set SegState = Perf.PlaySegment(Seg, 0, 0)
End If
Exit Sub
LocalErrors:
Call localerror(Err.Number, Err.Description) 'Отловщик ошибок
End Sub

Sub localerror(ErrorNum As Long, ErrorDesc As String) 'Здесь и объяснять-то нечего......
msg = ErrorDesc
msg = "(" & ErrorNum & ") - " & msg
MsgBox msg
End Sub


' ===============================================
' Код остановки

Public Sub MusicStop()
If Seg Is Nothing Then 'Еще ничего не загрузили
Exit Sub
End If
FIsPaused = False 'внутренний флаг, говорящий о том, что нет паузы
Call Perf.Stop(Seg, SegState, 0, 0)
End Sub