VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Graphics"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_MainWindow As Form

Private m_DirectDrawInterface As DirectDraw7

Private m_PrimarySurface As DirectDrawSurface7
Private m_BackBuffer As DirectDrawSurface7

Private m_DisplayClipper As DirectDrawClipper
Private m_BackBufferClipper As DirectDrawClipper
Private m_Palette As DirectDrawPalette

Private m_lDisplayWidth As Long
Private m_lDisplayHeight As Long
Private m_lDisplayDepth As Long

Private m_bModeChanged As Boolean
Private m_bRestoredSurfaces As Boolean
Private m_bInWindowedMode As Boolean

Private m_WindowRect As RECT
Private m_ClientRect As RECT
Private m_EmptyRect As RECT

Private m_bUseGdiBlt As Boolean

Private m_lFramesPerSecond As Long
Private m_lTotalFramesPerSecond As Long
Private Const m_lFramesPerSecondCount As Long = 64
Private Const m_lFramesPerSecondMask As Long = m_lFramesPerSecondCount - 1
Private m_lFramesPerSecondIndex As Long
Private m_lFramesPerSecondArray(0 To m_lFramesPerSecondMask) As Long
Private m_lLastTickCount As Long

Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 Const BITSPIXEL As Long = 12

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

Private Const SRCCOPY As Long = &HCC0020

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 GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint 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 DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Property Get MainWindow() As Form
    Set MainWindow = m_MainWindow
End Property

Public Property Set MainWindow(wnd As Form)
    On Error Resume Next

    If wnd Is m_MainWindow Then Exit Property

    If Not m_DirectDrawInterface Is Nothing Then
        m_DirectDrawInterface.RestoreDisplayMode
        m_bInWindowedMode = True

        If Not wnd Is Nothing Then
            m_DirectDrawInterface.SetCooperativeLevel wnd.hWnd, DDSCL_NORMAL
        End If
    End If

    Set m_MainWindow = wnd
End Property

Public Property Get DirectDrawInterface() As DirectDraw7
    Set DirectDrawInterface = m_DirectDrawInterface
End Property

Public Property Get PrimarySurface() As DirectDrawSurface7
    Dim IsLost As Boolean

    If Not m_PrimarySurface Is Nothing Then
        On Error Resume Next
    
        IsLost = m_PrimarySurface.IsLost <> 0
        If IsLost Or Err.Number = DDERR_SURFACELOST Then
            Do
                DoEvents
                If Not m_MainWindow Is Nothing Then
                    Exit Property
                Else
                    Err.Clear
                    m_DirectDrawInterface.TestCooperativeLevel
                    If Err.Number = 0 And m_MainWindow.WindowState <> vbMinimized Then Exit Do
                End If
            Loop

            On Error GoTo 0
            m_PrimarySurface.restore
            m_bRestoredSurfaces = True
        End If
    End If

    Set PrimarySurface = m_PrimarySurface
End Property

Public Property Get BackBuffer() As DirectDrawSurface7
    Dim IsLost As Boolean

    If Not m_BackBuffer Is Nothing Then
        On Error Resume Next
    
        IsLost = m_BackBuffer.IsLost <> 0
        If IsLost Or Err.Number = DDERR_SURFACELOST Then
            Do
                DoEvents
                If m_MainWindow Is Nothing Then
                    Exit Property
                Else
                    Err.Clear
                    m_DirectDrawInterface.TestCooperativeLevel
                    If Err.Number = 0 And m_MainWindow.WindowState <> vbMinimized Then Exit Do
                End If
            Loop

            m_BackBuffer.restore
            If Err.Number = DDERR_IMPLICITLYCREATED Then
                On Error GoTo 0
                m_PrimarySurface.restore
            End If

            m_bRestoredSurfaces = True
        End If
    End If

    Set BackBuffer = m_BackBuffer
End Property

Public Property Get DisplayClipper() As DirectDrawClipper
    Set DisplayClipper = m_DisplayClipper
End Property

Public Property Get Palette() As DirectDrawPalette
    Set Palette = m_Palette
End Property

Public Property Set Palette(myPal As DirectDrawPalette)
    Set m_Palette = myPal

    If Not m_BackBuffer Is Nothing Then
        m_BackBuffer.SetPalette myPal
    End If

    If Not m_bInWindowedMode And Not m_PrimarySurface Is Nothing Then
        m_PrimarySurface.SetPalette myPal
    End If
End Property

Public Property Get DisplayWidth() As Long
    DisplayWidth = m_lDisplayWidth
End Property

Public Property Get DisplayHeight() As Long
    DisplayHeight = m_lDisplayHeight
End Property

Public Property Get DisplayDepth() As Long
    DisplayDepth = m_lDisplayDepth
End Property

Public Property Get ModeChanged() As Boolean
    ModeChanged = m_bModeChanged
End Property

Public Property Get RestoredSurfaces() As Boolean
    RestoredSurfaces = m_bRestoredSurfaces
    m_bRestoredSurfaces = False
End Property

Public Property Get InWindowedMode() As Boolean
    InWindowedMode = m_bInWindowedMode
End Property

Public Property Let InWindowedMode(Flag As Boolean)
    Dim MyErr As Long

    If Flag = m_bInWindowedMode Then Exit Property

    If Flag Then
        MyErr = SetWindowedMode
        If MyErr <> DD_OK Then SetFullScreenMode
    Else
        MyErr = SetFullScreenMode
        If MyErr <> DD_OK Then SetWindowedMode
    End If

    If MyErr <> DD_OK Then
        Err.Raise MyErr, App.EXEName & ".Graphics"
        Exit Property
    End If

    m_bInWindowedMode = Flag
    m_bModeChanged = True
    m_bRestoredSurfaces = True
End Property

Public Property Get UseGdiBlt() As Boolean
    UseGdiBlt = m_bUseGdiBlt
End Property

Public Property Let UseGdiBlt(Flag As Boolean)
    m_bUseGdiBlt = Flag

    SetDisplayRect
End Property

Public Property Get FramesPerSecond() As Long
    FramesPerSecond = m_lFramesPerSecond
End Property

Public Function BltToDC(hDC As Long, DestRect As RECT, Surface As DirectDrawSurface7, SrcRect As RECT) As Long
    Dim mySrcRect As RECT
    Dim myDestRect As RECT
    Dim ddsd As DDSURFACEDESC2
    Dim hdcSurface As Long

    On Error Resume Next
    mySrcRect = SrcRect
    myDestRect = DestRect

    With mySrcRect
        If .Left = 0 And .Top = 0 And .Right = 0 And .Bottom = 0 Then
            ddsd.lFlags = DDSD_HEIGHT Or DDSD_WIDTH
            Surface.GetSurfaceDesc ddsd
            If Err.Number Then
                BltToDC = Err.Number
                Exit Function
            End If

            .Left = 0
            .Top = 0
            .Right = ddsd.lWidth
            .Bottom = ddsd.lHeight
        End If

        With myDestRect
            If .Left = 0 And .Right = 0 And .Top = 0 And .Bottom = 0 Then
                .Left = mySrcRect.Left
                .Top = mySrcRect.Top
                .Right = mySrcRect.Right
                .Bottom = mySrcRect.Bottom
            End If
        End With

        hdcSurface = Surface.GetDC
        If Err.Number Then
            BltToDC = Err.Number
            Exit Function
        End If

        StretchBlt hDC, myDestRect.Left, myDestRect.Top, myDestRect.Right - myDestRect.Left, myDestRect.Bottom - myDestRect.Top, _
                   hdcSurface, .Left, .Top, .Right - .Left, .Bottom - .Top, SRCCOPY
        Surface.ReleaseDC hdcSurface
    End With

    BltToDC = DD_OK
End Function

Public Function CreatePalette(FileName As String) As DirectDrawPalette
    Dim FileNum As Integer, i As Integer
    Dim TextLine As String
    Dim PaletteEntries(255) As PALETTEENTRY
    Dim peRed As Byte, peGreen As Byte, peBlue As Byte
    
    If m_DirectDrawInterface Is Nothing Then
        Err.Raise DDERR_INVALIDOBJECT, App.EXEName & ".Graphics", "DirectDraw not created."
        Exit Function
    End If

    FileNum = FreeFile
    Open FileName For Input As FileNum
    If Err.Number Then
        MsgBox "Attempt to open palette file failed"
        Set CreatePalette = Nothing
        Exit Function
    End If

    Line Input #FileNum, TextLine
    Line Input #FileNum, TextLine
    Line Input #FileNum, TextLine
    
    If Val(TextLine) <> 256 Then
        Set CreatePalette = Nothing
        Exit Function
    End If
    
    For i = 0 To 255
        Input #FileNum, peRed, peGreen, peBlue

        With PaletteEntries(i)
            .red = peRed * 255 / 63
            .green = peGreen * 255 / 63
            .blue = peBlue * 255 / 63
            .flags = 0
        End With
    Next i

    Close FileNum
    
    Set CreatePalette = m_DirectDrawInterface.CreatePalette(DDPCAPS_8BIT Or DDPCAPS_ALLOW256, PaletteEntries)
End Function

Public Function Initialize(Optional frm As Form = Nothing, Optional dx As DirectX7 = Nothing, Optional guid As String = "") As Boolean
    Initialize = False

    If Not frm Is Nothing Then Set MainWindow = frm
    
    If dx Is Nothing Then Exit Function

    On Error Resume Next

    Set m_DirectDrawInterface = dx.DirectDrawCreate(guid)
    If Err.Number Then Exit Function

    If Not m_MainWindow Is Nothing Then
        m_DirectDrawInterface.RestoreDisplayMode
        m_DirectDrawInterface.SetCooperativeLevel m_MainWindow.hWnd, DDSCL_NORMAL
        SetDisplayRect

        While m_DirectDrawInterface.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0) <> DD_OK
        Wend
            
        m_lFramesPerSecond = 0
        m_lTotalFramesPerSecond = 0
        For m_lFramesPerSecondIndex = 0 To m_lFramesPerSecondMask
            m_lLastTickCount = GetTickCount

            While m_DirectDrawInterface.WaitForVerticalBlank(DDWAITVB_BLOCKEND, 0) <> DD_OK
            Wend

            While m_DirectDrawInterface.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0) <> DD_OK
            Wend

            m_lFramesPerSecondArray(m_lFramesPerSecondIndex) = 1000& \ (GetTickCount - m_lLastTickCount)
            m_lTotalFramesPerSecond = m_lTotalFramesPerSecond + m_lFramesPerSecondArray(m_lFramesPerSecondIndex)
        Next m_lFramesPerSecondIndex
        m_lFramesPerSecondIndex = 0

        m_lFramesPerSecond = m_lTotalFramesPerSecond \ m_lFramesPerSecondCount

        m_bInWindowedMode = True
    End If

    Initialize = True
End Function

Public Sub ShutDown()
    Class_Terminate
End Sub

Public Function SystemWidth() As Long
    SystemWidth = GetSystemMetrics(SM_CXSCREEN)
End Function

Public Function SystemHeight() As Long
    SystemHeight = GetSystemMetrics(SM_CYSCREEN)
End Function

Public Function SystemDepth() As Long
    Dim hDC As Long
    Dim retVal As Long

    hDC = GetDC(0&)
    If hDC = 0& Then
        SystemDepth = 0
        Exit Function
    End If

    retVal = GetDeviceCaps(hDC, BITSPIXEL)

    ReleaseDC 0&, hDC
    SystemDepth = retVal
End Function

Public Function SetDisplayMode(fsMode As Boolean, Optional w As Long = -1, Optional h As Long = -1, Optional bpp As Long = -1) As Long
    If w = 0 Then
        m_lDisplayWidth = 0
    ElseIf m_lDisplayWidth <= 0 Then
        If w > 0 Then
            m_lDisplayWidth = w
        Else
            m_lDisplayWidth = SystemWidth
        End If
    End If

    If h = 0 Then
        m_lDisplayHeight = 0
    ElseIf m_lDisplayHeight <= 0 Then
        If h > 0 Then
            m_lDisplayHeight = h
        Else
            m_lDisplayHeight = SystemHeight
        End If
    End If

    If bpp = 0 Then
        m_lDisplayDepth = 0
    ElseIf m_lDisplayDepth <= 0 Then
        If bpp > 0 Then
            m_lDisplayDepth = bpp
        Else
            m_lDisplayDepth = SystemDepth
        End If
    End If

    If m_lDisplayWidth = 0 Or m_lDisplayHeight = 0 Or m_lDisplayDepth = 0 Then
        m_lDisplayWidth = 0
        m_lDisplayHeight = 0
        m_lDisplayDepth = 0
        SetDisplayMode = DD_OK
        Exit Function
    End If

    If fsMode Then
        SetDisplayMode = SetFullScreenMode
    Else
        SetDisplayMode = SetWindowedMode
    End If
End Function

Public Sub SetDisplayRect()
    Dim myPoint As POINTAPI

    If Not m_bInWindowedMode Or m_MainWindow Is Nothing Then Exit Sub

    GetWindowRect m_MainWindow.hWnd, m_WindowRect
    GetClientRect m_MainWindow.hWnd, m_ClientRect

    If m_bUseGdiBlt Then Exit Sub

    With m_ClientRect
        myPoint.X = .Left
        myPoint.Y = .Top
        ClientToScreen m_MainWindow.hWnd, myPoint
        .Left = myPoint.X
        .Top = myPoint.Y

        myPoint.X = .Right
        myPoint.Y = .Bottom
        ClientToScreen m_MainWindow.hWnd, myPoint
        .Right = myPoint.X
        .Bottom = myPoint.Y
    End With
End Sub

' CreateDisplaySurfaces
'
' Creates the Primary and Back Buffer surfaces.
' Handles support for Full Screen and Windowed Modes.
'
' Returns DD_OK is successful or an error code otherwise.
'
Public Function CreateDisplaySurfaces() As Long
    If m_DirectDrawInterface Is Nothing Then
        CreateDisplaySurfaces = DDERR_INVALIDPARAMS
        Exit Function
    End If

    If m_bInWindowedMode Then
        CreateDisplaySurfaces = CreateWindowedSurfaces
    Else
        CreateDisplaySurfaces = CreateFullScreenSurfaces
    End If
End Function

' Present
'
' Presents (displays) the content of the back buffer.
'
' If forcedGdiBlt parameter is True, Present uses the GDI StretchBlt function
' to display the back buffer in windowed mode.  This parameter has no effect
' in full screen mode.
'
' Returns DD_OK if successful or an error code if not.
'
Public Function Present() As Long
    Dim lTickCount As Long
    Dim lTickCountDiff As Long

    On Error Resume Next

    If m_lLastTickCount = 0 Then
        m_lLastTickCount = GetTickCount
    Else
        lTickCount = GetTickCount
        lTickCountDiff = lTickCount - m_lLastTickCount
        m_lLastTickCount = lTickCount
        If lTickCountDiff < 1 Then lTickCountDiff = 1
        m_lTotalFramesPerSecond = m_lTotalFramesPerSecond - m_lFramesPerSecondArray(m_lFramesPerSecondIndex)
        m_lFramesPerSecondArray(m_lFramesPerSecondIndex) = 1000& \ lTickCountDiff
        m_lTotalFramesPerSecond = m_lTotalFramesPerSecond + m_lFramesPerSecondArray(m_lFramesPerSecondIndex)
        m_lFramesPerSecondIndex = m_lFramesPerSecondIndex + 1 And m_lFramesPerSecondMask
        m_lFramesPerSecond = m_lTotalFramesPerSecond \ m_lFramesPerSecondCount
    End If

    m_bModeChanged = False

    If m_bInWindowedMode Then
        If m_DirectDrawInterface Is Nothing Or m_PrimarySurface Is Nothing Or m_BackBuffer Is Nothing Then
            Present = DDERR_INVALIDOBJECT
            Exit Function
        End If
        
        m_DirectDrawInterface.WaitForVerticalBlank DDWAITVB_BLOCKBEGIN, 0
        If Err.Number Then
            Present = Err.Number
            Exit Function
        End If

        If m_bUseGdiBlt Then
            Dim hdcWnd As Long
            Dim hDC As Long

            If m_MainWindow Is Nothing Then
                Present = DDERR_INVALIDOBJECT
                Exit Function
            End If

            hdcWnd = GetDC(m_MainWindow.hWnd)
            If hdcWnd = 0 Then
                Present = DDERR_INVALIDOBJECT
                Exit Function
            End If

            hDC = m_BackBuffer.GetDC
            If Err.Number Then
                ReleaseDC m_MainWindow.hWnd, hdcWnd
                Present = Err.Number
                Exit Function
            End If
            
            With m_ClientRect
                StretchBlt hdcWnd, 0, 0, .Right, .Bottom, _
                           hDC, 0, 0, m_lDisplayWidth, m_lDisplayHeight, SRCCOPY
            End With

            m_BackBuffer.ReleaseDC hDC
            ReleaseDC m_MainWindow.hWnd, hdcWnd
            Present = DD_OK
            Exit Function
        Else
            Present = m_PrimarySurface.Blt(m_ClientRect, m_BackBuffer, m_EmptyRect, DDBLT_WAIT)
            Exit Function
        End If
    Else
        If m_PrimarySurface Is Nothing Then
            Present = DDERR_INVALIDOBJECT
            Exit Function
        End If
        
        m_PrimarySurface.Flip Nothing, DDFLIP_WAIT
        Present = Err.Number
        Exit Function
    End If
End Function

' ColorRGBToDD
'
' Uses the GDI to map an RGB color to a DDPIXELFORMAT pixel value.
'
Public Function ColorRGBToDD(Optional myRGB As Long = -1, Optional Surface As DirectDrawSurface7 = Nothing) As Long
    Dim hDC As Long
    Dim rgbT As Long
    Dim ddsd As DDSURFACEDESC2
    Dim color As Long
    Dim r As RECT

    On Error Resume Next

    color = -1

    If Surface Is Nothing Then Set Surface = m_BackBuffer
    If Surface Is Nothing Then
        ColorRGBToDD = -1
        Exit Function
    End If

    If myRGB <> -1 Then
        hDC = Surface.GetDC
        If Err.Number = DD_OK Then
            rgbT = GetPixel(hDC, 0, 0)
            SetPixel hDC, 0, 0, myRGB
            Surface.ReleaseDC hDC
        End If
        Err.Clear
    End If
    
    With r
        .Left = 0
        .Top = 0
        .Right = 0
        .Bottom = 0
    End With

    Surface.Lock r, ddsd, DDLOCK_NOSYSLOCK Or DDLOCK_WAIT, 0
    If Err.Number = DD_OK Then
        color = Surface.GetLockedPixel(0, 0)
        Surface.Unlock r
        Err.Clear
    End If

    If myRGB <> -1 Then
        hDC = Surface.GetDC
        If Err.Number = DD_OK Then
            SetPixel hDC, 0, 0, rgbT
            Surface.ReleaseDC hDC
        End If
        Err.Clear
    End If

    ColorRGBToDD = color
End Function

Public Function GetSurfaceFromFile(Surface As DirectDrawSurface7, szBitmap As String, ddsd As DDSURFACEDESC2) As Long
    Dim myPicture As StdPicture
    Dim mySurface As DirectDrawSurface7

    Dim retVal As Long

    On Error Resume Next

    If m_DirectDrawInterface Is Nothing Or m_MainWindow Is Nothing Then
        GetSurfaceFromFile = DDERR_INVALIDOBJECT
        Exit Function
    End If

    Set myPicture = LoadPicture(szBitmap)
    If Err.Number Then
        GetSurfaceFromFile = DDERR_INVALIDPARAMS
        Exit Function
    End If

    Err.Clear

    If Surface Is Nothing Then
        With ddsd
            If (.lFlags And DDSD_CAPS) = 0 Then
                .lFlags = .lFlags Or DDSD_CAPS
                .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
            End If
            
            If (.lFlags And DDSD_HEIGHT) = 0 Then
                .lFlags = .lFlags Or DDSD_HEIGHT
                .lHeight = m_MainWindow.ScaleY(myPicture.Height, vbHimetric, vbPixels)
            End If
            
            If (.lFlags And DDSD_WIDTH) = 0 Then
                .lFlags = .lFlags Or DDSD_WIDTH
                .lWidth = m_MainWindow.ScaleX(myPicture.Width, vbHimetric, vbPixels)
            End If
        End With
        
        Set Surface = m_DirectDrawInterface.CreateSurface(ddsd)
    Else
        Surface.restore
    End If

    retVal = Err.Number
    If retVal = 0 Then
        retVal = CopyPictureToSurface(Surface, myPicture)
    End If
    Set myPicture = Nothing

    GetSurfaceFromFile = retVal
End Function

Public Function CreatePSCompatibleSurface(ddsd As DDSURFACEDESC2) As DirectDrawSurface7
    Dim Surface As DirectDrawSurface7
    Dim psSurfDesc As DDSURFACEDESC2
    Dim myPalette As DirectDrawPalette

    If m_DirectDrawInterface Is Nothing Or m_PrimarySurface Is Nothing Then
        Err.Raise DDERR_INVALIDOBJECT, App.EXEName & ".Graphics", "Direct Draw interface or Primary Surface is Nothing."
        Exit Function
    End If

    On Error Resume Next

    psSurfDesc.lFlags = DDSD_HEIGHT Or DDSD_WIDTH
    m_PrimarySurface.GetSurfaceDesc psSurfDesc
    If Err.Number Then
        On Error GoTo 0
        Err.Raise Err.Number, App.EXEName & ".Graphics", "Unable to get surface description from Primary Surface."
        Exit Function
    End If

    With ddsd
        If (.lFlags And DDSD_CAPS) = 0 Then
            .lFlags = .lFlags Or DDSD_CAPS
            .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        End If

        If (.lFlags And DDSD_HEIGHT) = 0 Then
            .lFlags = .lFlags Or DDSD_HEIGHT
            .lHeight = psSurfDesc.lHeight
        End If

        If (.lFlags And DDSD_WIDTH) = 0 Then
            .lFlags = .lFlags Or DDSD_WIDTH
            .lWidth = psSurfDesc.lWidth
        End If
    End With

    Set Surface = m_DirectDrawInterface.CreateSurface(ddsd)
    If Err.Number Then
        On Error GoTo 0
        Err.Raise Err.Number, App.EXEName & ".Graphics", "Unable to create new surface."
        Exit Function
    End If

    Set myPalette = m_PrimarySurface.GetPalette
    If Err.Number = DDERR_NOPALETTEATTACHED Then
        Err.Clear
    ElseIf Err.Number = 0 Then
        Surface.SetPalette myPalette
    End If

    If Err.Number Then
        On Error GoTo 0
        Err.Raise Err.Number, App.EXEName & ".Graphics", "Unable to get attached palette."
        Exit Function
    End If

    Set CreatePSCompatibleSurface = Surface
End Function

Public Function CreateBBCompatibleSurface(ddsd As DDSURFACEDESC2) As DirectDrawSurface7
    Dim MyErr As Long
    Dim Surface As DirectDrawSurface7
    Dim bbSurfDesc As DDSURFACEDESC2
    Dim myPalette As DirectDrawPalette

    If m_DirectDrawInterface Is Nothing Or m_BackBuffer Is Nothing Then
        Err.Raise DDERR_INVALIDOBJECT, App.EXEName & ".Graphics", "Direct Draw interface or Back Buffer is Nothing."
        Exit Function
    End If

    On Error Resume Next

    bbSurfDesc.lFlags = DDSD_ALL
    m_BackBuffer.GetSurfaceDesc bbSurfDesc
    If Err.Number Then
        MyErr = Err.Number
        On Error GoTo 0
        Err.Raise MyErr, App.EXEName & ".Graphics", "Unable to get surface description from Back Buffer."
        Exit Function
    End If

    With ddsd
        If (.lFlags And DDSD_CAPS) = 0 Then
            .lFlags = .lFlags Or DDSD_CAPS
            .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        End If
        
        With .ddsCaps
            If (.lCaps And DDSCAPS_SYSTEMMEMORY) <> DDSCAPS_SYSTEMMEMORY Then
                .lCaps = .lCaps And Not (DDSCAPS_SYSTEMMEMORY Or DDSCAPS_VIDEOMEMORY)
                .lCaps = .lCaps Or (bbSurfDesc.ddsCaps.lCaps And (DDSCAPS_SYSTEMMEMORY Or DDSCAPS_VIDEOMEMORY))
            End If
        End With

        If (.lFlags And DDSD_HEIGHT) = 0 Then
            .lFlags = .lFlags Or DDSD_HEIGHT
            .lHeight = bbSurfDesc.lHeight
        End If

        If (.lFlags And DDSD_WIDTH) = 0 Then
            .lFlags = .lFlags Or DDSD_WIDTH
            .lWidth = bbSurfDesc.lWidth
        End If

        .lFlags = .lFlags Or DDSD_PIXELFORMAT
        .ddpfPixelFormat = bbSurfDesc.ddpfPixelFormat
    End With

    Set Surface = m_DirectDrawInterface.CreateSurface(ddsd)
    If Err.Number = DDERR_OUTOFVIDEOMEMORY Then
        With ddsd.ddsCaps
            .lCaps = .lCaps And Not DDSCAPS_VIDEOMEMORY
            .lCaps = .lCaps Or DDSCAPS_SYSTEMMEMORY
        End With

        Set Surface = m_DirectDrawInterface.CreateSurface(ddsd)
    End If

    If Err.Number Then
        MyErr = Err.Number
        On Error GoTo 0
        Err.Raise MyErr, App.EXEName & ".Graphics", "Unable to create surface."
        Exit Function
    End If

    If ddsd.ddpfPixelFormat.lRGBBitCount <= 8 Then
        Set myPalette = m_BackBuffer.GetPalette
        If Err.Number = DDERR_NOPALETTEATTACHED Then
            Err.Clear
        ElseIf Err.Number = 0 Then
            Surface.SetPalette myPalette
        End If
    

        If Err.Number Then
            MyErr = Err.Number
            On Error GoTo 0
            Err.Raise MyErr, App.EXEName & ".Graphics", "Unable to get palette from the back buffer."
            Exit Function
        End If
    End If

    Set CreateBBCompatibleSurface = Surface
End Function

Private Function CopyPictureToSurface(Surface As DirectDrawSurface7, myPicture As StdPicture, Optional X As Long = 0, Optional Y As Long = 0, Optional w As Long = 0, Optional h As Long = 0) As Long
    Dim ddsd As DDSURFACEDESC2

    Dim hdcPicture As Long
    Dim hdcSurface As Long

    Dim nWidth As Long
    Dim nHeight As Long

    On Error Resume Next

    hdcPicture = CreateCompatibleDC(ByVal 0&)
    SelectObject hdcPicture, myPicture.Handle

    If h = 0 Then
        nHeight = m_MainWindow.ScaleY(myPicture.Height, vbHimetric, vbPixels)
    Else
        nHeight = h
    End If

    If w = 0 Then
        nWidth = m_MainWindow.ScaleX(myPicture.Width, vbHimetric, vbPixels)
    Else
        nWidth = w
    End If

    ddsd.lFlags = DDSD_HEIGHT Or DDSD_WIDTH
    Surface.GetSurfaceDesc ddsd
    If Err.Number Then
        CopyPictureToSurface = Err.Number
        Exit Function
    End If

    hdcSurface = Surface.GetDC
    If Err.Number Then
        CopyPictureToSurface = Err.Number
        Exit Function
    End If

    StretchBlt hdcSurface, 0, 0, ddsd.lWidth, ddsd.lHeight, _
               hdcPicture, X, Y, nWidth, nHeight, SRCCOPY

    DeleteDC hdcPicture
    Surface.ReleaseDC hdcSurface
    CopyPictureToSurface = Err.Number
End Function

' SetWindowedMode
'
' Sets the Windowed mode for the game.
' This is a private helper function for SetDisplayMode.
'
' Returns DD_OK if successful or an error otherwise.
'
Private Function SetWindowedMode() As Long
    On Error Resume Next

    If m_DirectDrawInterface Is Nothing Or m_MainWindow Is Nothing Then
        SetWindowedMode = DDERR_INVALIDPARAMS
        Exit Function
    End If

    m_DirectDrawInterface.RestoreDisplayMode
    Err.Clear

    m_DirectDrawInterface.SetCooperativeLevel m_MainWindow.hWnd, DDSCL_NORMAL
    If Err.Number Then
        SetWindowedMode = Err.Number
        Exit Function
    End If

    With m_WindowRect
        If .Left <> 0 Or .Top <> 0 Or .Right <> 0 Or .Bottom <> 0 Then
            MoveWindow m_MainWindow.hWnd, .Left, .Top, .Right - .Left, .Bottom - .Top, True
        End If
    End With

    SetDisplayRect
    m_bInWindowedMode = True

    SetWindowedMode = CreateWindowedSurfaces
End Function

' SetFullScreenMode
'
' Sets the Full Screen mode for the game.
' This is a private helper function for SetDisplayMode.
'
' Returns DD_OK if successful or an error otherwise.
'
Private Function SetFullScreenMode() As Long
    Dim myWindowRect As RECT

    On Error Resume Next

    If m_DirectDrawInterface Is Nothing Or m_MainWindow Is Nothing Then
        SetFullScreenMode = DDERR_INVALIDPARAMS
        Exit Function
    End If

    SetDisplayRect
    myWindowRect = m_WindowRect

    m_DirectDrawInterface.SetCooperativeLevel m_MainWindow.hWnd, DDSCL_ALLOWMODEX Or DDSCL_ALLOWREBOOT Or DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN
    If Err.Number Then
        SetFullScreenMode = Err.Number
        Exit Function
    End If

    m_DirectDrawInterface.SetDisplayMode m_lDisplayWidth, m_lDisplayHeight, m_lDisplayDepth, 0, DDSDM_DEFAULT
    If Err.Number Then
        SetFullScreenMode = Err.Number
        Exit Function
    End If

    m_WindowRect = myWindowRect

    m_bInWindowedMode = False
    SetFullScreenMode = CreateFullScreenSurfaces
End Function

' CreateWindowedSurfaces
'
' Creates Primary and Back Buffer surfaces for use in Windowed Mode.
' Private support function for CreateDisplaySurfaces function.
'
' Returns DD_OK is successful or an error code otherwise.
'
Private Function CreateWindowedSurfaces() As Long
    Dim SurfaceDesc As DDSURFACEDESC2

    On Error Resume Next

    Set m_PrimarySurface = Nothing
    Set m_BackBuffer = Nothing

    SurfaceDesc.lFlags = DDSD_CAPS
    SurfaceDesc.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE

    Set m_PrimarySurface = m_DirectDrawInterface.CreateSurface(SurfaceDesc)
    If Err.Number Then
        CreateWindowedSurfaces = Err.Number
        Exit Function
    End If

    If m_DisplayClipper Is Nothing Then
        Err.Clear
        Set m_DisplayClipper = m_DirectDrawInterface.CreateClipper(0)
        If Err.Number Then
            CreateWindowedSurfaces = Err.Number
            Exit Function
        End If

        m_DisplayClipper.SetHWnd m_MainWindow.hWnd
        If Err.Number Then
            CreateWindowedSurfaces = Err.Number
            Exit Function
        End If
    End If
    
    m_PrimarySurface.SetClipper m_DisplayClipper
    If Err.Number Then
        CreateWindowedSurfaces = Err.Number
        Exit Function
    End If

    'If Not m_BackBuffer Is Nothing Then
    '    m_BackBuffer.restore
    '    CreateWindowedSurfaces = Err.Number
    '    Exit Function
    'End If

    With SurfaceDesc
        .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        .lWidth = m_lDisplayWidth
        .lHeight = m_lDisplayHeight

        If m_lDisplayDepth <> SystemDepth Then
            .lFlags = .lFlags Or DDSD_PIXELFORMAT
            .ddsCaps.lCaps = .ddsCaps.lCaps Or DDSCAPS_SYSTEMMEMORY

            Select Case m_lDisplayDepth
            Case 1
                With .ddpfPixelFormat
                    .lFlags = DDPF_PALETTEINDEXED1 Or DDPF_RGB
                    .lRGBBitCount = 1
                End With
            Case 2
                With .ddpfPixelFormat
                    .lFlags = DDPF_PALETTEINDEXED2 Or DDPF_RGB
                    .lRGBBitCount = 2
                End With
            Case 4
                With .ddpfPixelFormat
                    .lFlags = DDPF_PALETTEINDEXED4 Or DDPF_RGB
                    .lRGBBitCount = 4
                End With
            Case 8
                With .ddpfPixelFormat
                    .lFlags = DDPF_PALETTEINDEXED8 Or DDPF_RGB
                    .lRGBBitCount = 8
                End With
            Case 15, 16
                With .ddpfPixelFormat
                    .lFlags = DDPF_RGB
                    .lRGBBitCount = 16
                    .lRBitMask = &H7C00
                    .lGBitMask = &H3E0
                    .lBBitMask = &H1F
                    .lAlphaBitDepth = 0
                End With
            Case 24, 32
                With .ddpfPixelFormat
                    .lFlags = DDPF_RGB
                    .lRGBBitCount = m_lDisplayDepth
                    .lRBitMask = &HFF
                    .lGBitMask = &HFF00
                    .lBBitMask = &HFF0000
                    .lAlphaBitDepth = 0
                End With
            Case Else
                CreateWindowedSurfaces = DDERR_UNSUPPORTEDMODE
                Exit Function
            End Select
        End If
    End With

    Set m_BackBuffer = m_DirectDrawInterface.CreateSurface(SurfaceDesc)
    If Err.Number Then
        CreateWindowedSurfaces = Err.Number
        Exit Function
    End If
    m_BackBuffer.BltColorFill m_EmptyRect, 0

    CreateWindowedSurfaces = DD_OK
End Function

' CreateFullScreenSurfaces
'
' Creates Primary and Back Buffer surfaces for use in Full Screen Mode.
' Private support function for CreateDisplaySurfaces function.
'
' Returns DD_OK is successful or an error code otherwise.
'
Private Function CreateFullScreenSurfaces() As Long
    Dim SurfaceDesc As DDSURFACEDESC2

    On Error Resume Next

    If Not m_PrimarySurface Is Nothing Then
        Set m_BackBuffer = Nothing
        Set m_PrimarySurface = Nothing
    End If

    If m_DirectDrawInterface Is Nothing Then
        CreateFullScreenSurfaces = DDERR_INVALIDPARAMS
        Exit Function
    End If

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

    Set m_PrimarySurface = m_DirectDrawInterface.CreateSurface(SurfaceDesc)
    If Err.Number Then
        CreateFullScreenSurfaces = Err.Number
        Exit Function
    End If
    
    SurfaceDesc.ddsCaps.lCaps = DDSCAPS_BACKBUFFER
    Set m_BackBuffer = m_PrimarySurface.GetAttachedSurface(SurfaceDesc.ddsCaps)
    If Err.Number Then
        CreateFullScreenSurfaces = Err.Number
        Exit Function
    End If
    m_BackBuffer.BltColorFill m_EmptyRect, 0
    Err.Clear
    
    If m_DisplayClipper Is Nothing Then
        Set m_DisplayClipper = m_DirectDrawInterface.CreateClipper(0)
        If Err.Number Then
            CreateFullScreenSurfaces = Err.Number
            Exit Function
        End If

        m_DisplayClipper.SetHWnd m_MainWindow.hWnd
        If Err.Number Then
            CreateFullScreenSurfaces = Err.Number
            Exit Function
        End If
    End If

    m_PrimarySurface.SetClipper Nothing
    If Err.Number = DDERR_NOCLIPPERATTACHED Then Err.Clear
    CreateFullScreenSurfaces = Err.Number
End Function

Private Sub Class_Initialize()
    Dim i As Long

    Set m_MainWindow = Nothing

    Set m_DirectDrawInterface = Nothing

    Set m_PrimarySurface = Nothing
    Set m_BackBuffer = Nothing

    Set m_DisplayClipper = Nothing
    Set m_BackBufferClipper = Nothing
    Set m_Palette = Nothing

    m_lDisplayWidth = 0
    m_lDisplayHeight = 0
    m_lDisplayDepth = 0

    m_bModeChanged = False
    m_bRestoredSurfaces = False
    m_bInWindowedMode = True

    With m_WindowRect
        .Left = 0
        .Top = 0
        .Right = 0
        .Bottom = 0
    End With

    With m_ClientRect
        .Left = 0
        .Top = 0
        .Right = 0
        .Bottom = 0
    End With

    With m_EmptyRect
        .Left = 0
        .Top = 0
        .Right = 0
        .Bottom = 0
    End With

    m_bUseGdiBlt = False

    m_lFramesPerSecond = 0
    m_lTotalFramesPerSecond = 0
    m_lFramesPerSecondIndex = 0
    For i = 0 To 31
        m_lFramesPerSecondArray(i) = 0
    Next i
    m_lLastTickCount = 0
End Sub

Private Sub Class_Terminate()
    Set m_DisplayClipper = Nothing
    Set m_BackBufferClipper = Nothing
    Set m_Palette = Nothing

    Set m_BackBuffer = Nothing
    Set m_PrimarySurface = Nothing
    
    Set m_DirectDrawInterface = Nothing

    Set m_MainWindow = Nothing
End Sub
