DirectX слоеное окно

' Класс frmDXWindow - слоеное окно Direct3D
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Option Explicit
 
Private Type Size
    cx  As Long
    cy  As Long
End Type
 
Private Type RGBQUAD
    rgbBlue     As Byte
    rgbGreen    As Byte
    rgbRed      As Byte
    rgbReserved As Byte
End Type
 
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 BITMAPINFO
    bmiHeader   As BITMAPINFOHEADER
    bmiColors   As RGBQUAD
End Type
 
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
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 ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private Const pi                As Double = 3.14159275180032
Private Const refQ              As Long = 512                   ' Качество отражения
Private Const WS_EX_LAYERED     As Long = &H80000
Private Const GWL_EXSTYLE       As Long = -20
Private Const ULW_ALPHA         As Long = &H2
Private Const AB_32Bpp255       As Long = 33488896
Private Const HTCAPTION         As Long = 2
Private Const WM_NCLBUTTONDOWN  As Long = &HA1
Private Const HWND_TOPMOST      As Long = -1
Private Const SWP_NOMOVE        As Long = &H2
Private Const SWP_NOSIZE        As Long = &H1
 
Private dx8     As DirectX8
Private d3d     As Direct3D8
Private d3dx    As New D3DX8
Private d3ddev  As Direct3DDevice8
Private model   As D3DXMesh
Private texDiff As Direct3DTexture8 ' Диффузная текстура
Private texShdw As Direct3DTexture8 ' Теневая текстура
Private texRefl As Direct3DTexture8 ' Текстура отражений
Private srfOff  As Direct3DSurface8 ' Внеэкранная поверхность
Private rndTex  As D3DXRenderToSurface
Private biWnd   As BITMAPINFO       ' Битмап в буфере
Private mRot    As Single           ' Угол поворота
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then Unload Me
End Sub
 
Private Sub Form_Load()
    ' Поверх всех
    SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    ' Задаем стиль слоеного окна
    SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    ' Задаем размеры битмапа в буфере
    biWnd.bmiHeader.biSize = Len(biWnd.bmiHeader)
    biWnd.bmiHeader.biBitCount = 32
    biWnd.bmiHeader.biHeight = -Me.ScaleHeight
    biWnd.bmiHeader.biWidth = Me.ScaleWidth
    biWnd.bmiHeader.biPlanes = 1
    '-----------
    createDevice
    loadModel
    createTransform
    createLight
    createTexture
    '-----------
End Sub
 
' Перетаскиваем за любое место
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
    End If
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static oy As Single
    If Button = vbRightButton Then mRot = mRot + (oy - Y) / 30
    oy = Y
End Sub
 
' Очистка ресурсов
Private Sub Form_Unload(Cancel As Integer)
    Set texDiff = Nothing
    Set texShdw = Nothing
    Set texRefl = Nothing
    Set rndTex = Nothing
    Set srfOff = Nothing
    Set d3dx = Nothing
    Set d3ddev = Nothing
    Set d3d = Nothing
    Set dx8 = Nothing
End Sub
 
' Тик таймера
Private Sub tmrFPS_Timer()
    Dim mtx         As D3DMATRIX
    Dim lrc         As D3DLOCKED_RECT
    Dim vpt         As D3DVIEWPORT8
    Static frame    As Long
    
    On Error GoTo ERRORLABEL
    
    ' Периодически делаем скриншот экрана
    If (frame Mod 20) = 0 Then makeScreenShot
    frame = frame + 1
    
    ' Трансформируем модель
    D3DXMatrixTranslation mtx, 0, 50, 0
    d3ddev.SetTransform D3DTS_WORLD, mtx
    D3DXMatrixRotationX mtx, mRot
    d3ddev.MultiplyTransform D3DTS_WORLD, mtx
    D3DXMatrixTranslation mtx, 0, -50, 0
    d3ddev.MultiplyTransform D3DTS_WORLD, mtx
    D3DXMatrixRotationY mtx, frame / 30
    d3ddev.MultiplyTransform D3DTS_WORLD, mtx
    ' Получаем область вывода
    d3ddev.GetViewport vpt
    ' Начало рендера в текстуру
    rndTex.BeginScene srfOff, vpt
    d3ddev.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, 0, 1, 0
    ' Рисуем модель
    model.DrawSubset 0
    ' Конец рисования
    rndTex.EndScene
    ' Получаем данные внеэкранной плоскости
    srfOff.LockRect lrc, ByVal 0&, 0
    ' Копируем их на буфферный DC формы (т.к. Autoredraw = True)
    SetDIBitsToDevice Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, 0, 0, 0, Me.ScaleHeight, ByVal lrc.pBits, biWnd, 0
    ' Разблокируем внеэкранную плоскость
    srfOff.UnlockRect
    Dim pt  As Size
    Dim sz  As Size
    Dim pos As Size
    ' Указываем позицию окна
    pt.cx = Me.Left / Screen.TwipsPerPixelX
    pt.cy = Me.Top / Screen.TwipsPerPixelY
    ' Указываем размеры окна
    sz.cx = Me.ScaleWidth
    sz.cy = Me.ScaleHeight
    ' Обновляем слоеное окно
    UpdateLayeredWindow Me.hWnd, Me.hdc, pt, sz, Me.hdc, pos, 0, AB_32Bpp255, ULW_ALPHA
    Exit Sub
    
ERRORLABEL:
    MsgBox "Error rendering: " & d3dx.GetErrorString(Err.Number), vbCritical
    End
End Sub
 
' Создание устройства видеоадаптера
Private Sub createDevice()
    Dim d3dpp   As D3DPRESENT_PARAMETERS
    
    On Error GoTo ERRORLABEL
 
    ' Создаем DirectX8 объект
    Set dx8 = New DirectX8
    ' Создаем Direct3d объект
    Set d3d = dx8.Direct3DCreate
    ' Оконный режим
    d3dpp.Windowed = 1
    ' Без vsync
    d3dpp.SwapEffect = D3DSWAPEFFECT_DISCARD
    ' Формат заднего буфера
    d3dpp.BackBufferFormat = D3DFMT_A8R8G8B8
    ' Количество задних буферов
    d3dpp.BackBufferCount = 1
    ' Автоматическое создание и удаление Z-буфера
    d3dpp.EnableAutoDepthStencil = 1
    ' Формат Z-буфера
    d3dpp.AutoDepthStencilFormat = D3DFMT_D16
    ' Создаем усройство
    Set d3ddev = d3d.createDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
    ' Включаем Z-буфер
    d3ddev.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE
    ' Отсечение невидимых граней
    d3ddev.SetRenderState D3DRS_CULLMODE, D3DCULL_CCW
    Exit Sub
    
ERRORLABEL:
    MsgBox "Ошибка создания устройства", vbCritical
    End
End Sub
 
' Загрузка модели
Private Sub loadModel()
    On Error GoTo ERRORLABEL
 
    Set model = d3dx.LoadMeshFromX(App.Path & "\Trick.X", D3DXMESH_MANAGED, d3ddev, Nothing, Nothing, 0)
    Exit Sub
    
ERRORLABEL:
    MsgBox "Ошибка загрузки модели", vbCritical
    End
End Sub
' Настройка трансформаций
Private Sub createTransform()
    Dim mtx As D3DMATRIX
    
    ' Нулевая мировая трансформация
    D3DXMatrixIdentity mtx
    d3ddev.SetTransform D3DTS_WORLD, mtx
    ' Левосторонняя перспективная проекция
    D3DXMatrixPerspectiveFovLH mtx, pi / 4, Me.ScaleHeight / Me.ScaleWidth, 0.5, 1000
    d3ddev.SetTransform D3DTS_PROJECTION, mtx
    ' Камера смотрит в центр модели
    D3DXMatrixLookAtLH mtx, vec3(0, 50, -150), vec3(0, 50, 0), vec3(0, 1, 0)
    d3ddev.SetTransform D3DTS_VIEW, mtx
End Sub
 
' Создание и настройка освещения
Private Sub createLight()
    Dim lth As D3DLIGHT8
    Dim mat As D3DMATERIAL8
    
    ' Создаем точечный источник света
    lth.Type = D3DLIGHT_POINT
    ' Цвет
    lth.diffuse = col(1, 1, 1)
    ' Позиция
    lth.Position = vec3(0, 100, -100)
    ' Квадратичное затухание
    lth.Attenuation1 = 0.01
    ' Размер
    lth.Range = 300
    
    ' Установка света #1
    d3ddev.SetLight 0, lth
    ' Включение света #1
    d3ddev.LightEnable 0, 1
    ' Включение освещения
    d3ddev.SetRenderState D3DRS_LIGHTING, 1
    
    ' Цвет материала - белый
    mat.diffuse = col(1, 1, 1)
    ' Устанавливаем материал
    d3ddev.SetMaterial mat
End Sub
 
' Создание текстур
Private Sub createTexture()
    
    On Error GoTo ERRORLABEL
    
    ' Диффузная текстура
    Set texDiff = d3dx.CreateTextureFromFile(d3ddev, App.Path & "\DiffuseMap.jpg")
    ' Теневая текстура
    Set texShdw = d3dx.CreateTextureFromFile(d3ddev, App.Path & "\ShadowsMap.jpg")
    ' Текстура отражения
    Set texRefl = d3dx.createTexture(d3ddev, refQ, refQ, 0, 0, D3DFMT_X8R8G8B8, D3DPOOL_MANAGED)
    ' Рендер в текстуру
    Set rndTex = d3dx.CreateRenderToSurface(d3ddev, Me.ScaleWidth, Me.ScaleHeight, D3DFMT_A8R8G8B8, 1, D3DFMT_D16)
    ' Создаем внеэкранную поверхность
    Set srfOff = d3ddev.CreateImageSurface(Me.ScaleWidth, Me.ScaleHeight, D3DFMT_A8R8G8B8)
    ' Настройка мультитекстурирования
    ' 0 стадия: Result = Diffuse * DiffuseTexture
    d3ddev.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_MODULATE
    d3ddev.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_DIFFUSE
    d3ddev.SetTextureStageState 0, D3DTSS_COLORARG2, D3DTA_TEXTURE
    ' 1 стадия: Temp = Result * ShadowTexture
    d3ddev.SetTextureStageState 1, D3DTSS_COLOROP, D3DTOP_MODULATE
    d3ddev.SetTextureStageState 1, D3DTSS_COLORARG1, D3DTA_TEXTURE
    d3ddev.SetTextureStageState 1, D3DTSS_COLORARG2, D3DTA_CURRENT
    d3ddev.SetTextureStageState 1, D3DTSS_RESULTARG, D3DTA_TEMP
    ' Координаты берем из 0 текстурных координат
    d3ddev.SetTextureStageState 1, D3DTSS_TEXCOORDINDEX, 0
    ' Сила отражения (TexFactor)
    d3ddev.SetRenderState D3DRS_TEXTUREFACTOR, &H202020
    ' 2 стадия: Result = TexFactor * ReflTexture
    ' Координаты отражения
    d3ddev.SetTextureStageState 2, D3DTSS_TEXCOORDINDEX, D3DTSS_TCI_CAMERASPACEREFLECTIONVECTOR
    d3ddev.SetTextureStageState 2, D3DTSS_COLOROP, D3DTOP_MODULATE
    d3ddev.SetTextureStageState 2, D3DTSS_COLORARG1, D3DTA_TEXTURE
    d3ddev.SetTextureStageState 2, D3DTSS_COLORARG2, D3DTA_TFACTOR
    ' 3 стадия: Result = Result + Temp
    d3ddev.SetTextureStageState 3, D3DTSS_COLOROP, D3DTOP_ADD
    d3ddev.SetTextureStageState 3, D3DTSS_COLORARG1, D3DTA_CURRENT
    d3ddev.SetTextureStageState 3, D3DTSS_COLORARG2, D3DTA_TEMP
    ' Устанавливаем текстуры
    d3ddev.SetTexture 0, texDiff
    d3ddev.SetTexture 1, texShdw
    d3ddev.SetTexture 2, texRefl
    Exit Sub
    
ERRORLABEL:
    MsgBox "Ошибка загрузки текстур", vbCritical
    End
End Sub
 
' Создать скриншот (для отражения)
Private Function makeScreenShot()
    Dim srcDc   As Long
    Dim dstDc   As Long
    Dim bi      As BITMAPINFO
    Dim oldBmp  As Long
    Dim newBmp  As Long
    Dim lpDat   As Long
    Dim lrc     As D3DLOCKED_RECT
 
    ' Фиксируем в памяти данные текстуры
    texRefl.LockRect 0, lrc, ByVal 0&, D3DLOCK_DISCARD
    ' Получаем экранный контекст
    srcDc = GetDC(0)
    If srcDc = 0 Then Unload Me: Exit Function
    ' Создаем совместимый контекст
    dstDc = CreateCompatibleDC(srcDc)
    If dstDc = 0 Then Unload Me: Exit Function
    ' Настраиваем DIB-секцию
    bi.bmiHeader.biBitCount = 32
    bi.bmiHeader.biHeight = -refQ
    bi.bmiHeader.biWidth = refQ
    bi.bmiHeader.biPlanes = 1
    bi.bmiHeader.biSize = Len(bi.bmiHeader)
    ' Создаем DIB-секцию
    newBmp = CreateDIBSection(srcDc, bi, 0, lpDat, 0, 0)
    If newBmp = 0 Then Unload Me: Exit Function
    ' Выбираем в новый контекст
    oldBmp = SelectObject(dstDc, newBmp)
    ' Копируем с экранного контекста на новый контекст с масштабированием
    StretchBlt dstDc, 0, 0, refQ, refQ, srcDc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, vbSrcCopy
    ' Копируем данные рисунка в текстуру
    memcpy ByVal lrc.pBits, ByVal lpDat, refQ * refQ * 4
    ' Возвращаем на место
    SelectObject dstDc, oldBmp
    DeleteObject newBmp
    DeleteDC dstDc
    ReleaseDC 0, srcDc
    ' Разблокировка текстуры
    texRefl.UnlockRect 0
End Function
 
' Функция быстрого создания векторов (by Mikle)
Private Function vec3(X As Single, Y As Single, z As Single) As D3DVECTOR
    vec3.X = X
    vec3.Y = Y
    vec3.z = z
End Function
' Функция быстрого создания цвета
Private Function col(r As Single, g As Single, b As Single) As D3DCOLORVALUE
    col.r = r
    col.g = g
    col.b = b
    col.a = 1
End Function