Attribute VB_Name = "VBDXHelper"
''************************************************''
''* DirectX-files helper module. This file may not
''* be ditributed unless consent has been giving
''* either Soren Skov (soren@VBExplorer.com) or
''* Burt Abreu (webmaster@VBExplorer.com).
''*
''* Use of the contents of any part of this
''* module is at your own risk.
''* Copyright (c) 1999 Visual Basic Explorer
''*
''************************************************''
''*
''* Version 1.0
''*
''* Covers: Usage for DirectDraw
''*
''* Documentation: DirectX-files 1 & 2
''*
''* Comments: Please always update to the
''* latest version of the module. All versions
''* will be backward compatible. If you have
''* any comments please direct them to:
''* soren@VBExplorer.com
''*
''************************************************''


Option Explicit

Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
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
Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function GetBitmapDimensionEx Lib "gdi32" (ByVal hBitmap As Long, lpDimension As SIZE) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Public Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type

Public Type SIZE
        cx As Long
        cy As Long
End Type

'''Surface types with some 'tagged' info
Public Type VBDXSurface
    dds As DirectDrawSurface7
    strFileName As String       ''File name of the bitmap source for surface
    ddsd2 As DDSURFACEDESC2
    rectDDS As RECT
End Type

Public Type VBDXMainSurfaces
    ddsPrimary As DirectDrawSurface7
    ddsBackbuffer As DirectDrawSurface7
    ddsd2Primary As DDSURFACEDESC2
    ddsd2Backbuffer As DDSURFACEDESC2
    rBackBuffer As RECT
    rPrimary As RECT
End Type

''Error constants
Public Const DXVBHELPER_ERR_BITMAPSIZE As Long = &H100
Public Const DXVBHELPER_ERR_CREATEDCFAILED As Long = &H101
Public Const DXVBHELPER_ERR_LOADIMAGEFAILED As Long = &H102

'**LoadImage Constants**
Public Const IMAGE_BITMAP As Long = 0
Public Const LR_LOADFROMFILE As Long = &H10
Public Const LR_CREATEDIBSECTION As Long = &H2000


'Reads a bitmap file and generates a Memory context for it
'
'IN: CompatibleDC: The context, which the generated DC
'    should be compatible with.
'FileName: The file name of the graphics
'OUT: The Generated DC
Public Function GenerateDCFromBitmap(BitmapFileName As String) As Long
Dim DC As Long
Dim hBitmap As Long

'Create a Device Context
DC = CreateCompatibleDC(0)

If DC < 1 Then
    GenerateDCFromBitmap = 0
    Exit Function
End If

'Load the image....
hBitmap = LoadImage(0, BitmapFileName, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)

If hBitmap = 0 Then 'Failure in loading bitmap
    DeleteDC DC
    GenerateDCFromBitmap = 0
    Exit Function
End If

'Throw the Bitmap into the Device Context
SelectObject DC, hBitmap

'Return the device context
GenerateDCFromBitmap = DC

DeleteObject hBitmap

End Function

''
''Fills the passed surface with bitmap data specified in the [strBitmapFile] parameter
''If the bitmap is larger or smaller than the surface it will be stretched to fit appropriately
''0 is returned on failure
''
Public Function VBDXLoadSurface(strBitmapFile As String, dds As DirectDrawSurface7) As Long
On Error GoTo ErrHandler
Dim DC As Long, SurfaceDC As Long
Dim szBitmap As BITMAP
Dim rSurface As RECT
Dim hBitmap As Long
Dim ddsd As DDSURFACEDESC2


''Get the DC of the surface
SurfaceDC = dds.GetDC()
'Create a Device Context
DC = CreateCompatibleDC(SurfaceDC)

If DC = 0 Then
    Err.Raise vbObjectError Or DXVBHELPER_ERR_CREATEDCFAILED, "VBDXLoadSurface", "Could not create compatible Device context from surface"
End If

'Load the image....
hBitmap = LoadImage(0, strBitmapFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)

If hBitmap = 0 Then 'Failure in loading bitmap
    Err.Raise vbObjectError Or DXVBHELPER_ERR_LOADIMAGEFAILED, "VBDXLoadSurface", "Could not load image: " & strBitmapFile
End If

'Throw the Bitmap into the Device Context
SelectObject DC, hBitmap

''Get the size of the bitmap
GetObject hBitmap, Len(szBitmap), szBitmap

''Check if the bitmap has the valid sizes
If szBitmap.bmWidth < 1 Or szBitmap.bmHeight < 1 Then
    Err.Raise vbObjectError Or DXVBHELPER_ERR_BITMAPSIZE, "VBDXLoadSurface", "Bitmap does not have a valid size"
End If

''We now have a memory device context, so on to the the filling of the surface
''First get the size of the surface
dds.GetSurfaceDesc ddsd

rSurface.Bottom = ddsd.lHeight
rSurface.Right = ddsd.lWidth

''Compare sizes and detemine whether strecthing should be applied
If rSurface.Right <> szBitmap.bmWidth Or rSurface.Bottom <> szBitmap.bmHeight Then    ''We stretchblt
        
    ''Stretch the bitmap to fit the surface
    StretchBlt SurfaceDC, 0, 0, rSurface.Right, rSurface.Bottom, DC, 0, 0, szBitmap.bmWidth, szBitmap.bmWidth, vbSrcCopy
        
Else

    ''Just Blt it there - it is faster hence the conditions
    BitBlt SurfaceDC, 0, 0, rSurface.Right, rSurface.Bottom, DC, 0, 0, vbSrcCopy
    
End If

ErrHandler:

    Select Case Err.Number

        Case 0 ''No errors - just clean up
            DeleteDC DC
            DeleteObject hBitmap
            dds.ReleaseDC SurfaceDC
            
        Case Else ''Clean up and throw (raise) err
            If SurfaceDC Then
                dds.ReleaseDC SurfaceDC
            End If
            DeleteDC DC
            DeleteObject hBitmap
            
            Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, Err.HelpContext
    
    End Select

End Function


''Loads an offscrenn (plain) surface from a specified user defined surface type
Public Function VBDXLoadOffScreenSurfaceFromType(ByRef SurfaceType As VBDXSurface, lgSourceColorKey As Long, ByRef objDraw As DirectDraw7)
On Error GoTo ErrHandler
    
    If lgSourceColorKey <> -1 Then
        SurfaceType.ddsd2.lFlags = DDSD_CAPS Or DDSD_CKSRCBLT
           
        ''Set source color key
        SurfaceType.ddsd2.ddckCKSrcBlt.high = lgSourceColorKey
        SurfaceType.ddsd2.ddckCKSrcBlt.low = lgSourceColorKey
    Else
        
        SurfaceType.ddsd2.lFlags = DDSD_CAPS
    End If
    
    SurfaceType.ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    
    Set SurfaceType.dds = objDraw.CreateSurfaceFromFile(SurfaceType.strFileName, SurfaceType.ddsd2)
        
    ''Get the size of the surface and load the rect structure
    SurfaceType.dds.GetSurfaceDesc SurfaceType.ddsd2
    
    SurfaceType.rectDDS.Bottom = SurfaceType.ddsd2.lHeight
    SurfaceType.rectDDS.Right = SurfaceType.ddsd2.lWidth
    
ErrHandler:

    Select Case Err.Number

        Case 0 ''No errors - just clean up
        
        Case Else ''Clean up and throw (raise) err
            
            Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, Err.HelpContext
    
    End Select
End Function

''Initializes main DirectDraw surfaces
Public Function VBDXInitializeMainsurfaces(Main As VBDXMainSurfaces, objDraw As DirectDraw7) As Long
On Error GoTo ErrHandler

Dim ddsd2 As DDSCAPS2
''
''Create primary surface with backbuffer
''
Main.ddsd2Primary.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
Main.ddsd2Primary.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
Main.ddsd2Primary.lBackBufferCount = 1

Set Main.ddsPrimary = objDraw.CreateSurface(Main.ddsd2Primary)

''Get backbuffer
ddsd2.lCaps = DDSCAPS_BACKBUFFER
Set Main.ddsBackbuffer = Main.ddsPrimary.GetAttachedSurface(ddsd2)

''Get the surface descriptions

Main.ddsPrimary.GetSurfaceDesc Main.ddsd2Primary
Main.ddsBackbuffer.GetSurfaceDesc Main.ddsd2Backbuffer

''Set the rects
Main.rBackBuffer.Bottom = Main.ddsd2Backbuffer.lHeight
Main.rBackBuffer.Right = Main.ddsd2Backbuffer.lWidth

Main.rPrimary.Bottom = Main.ddsd2Primary.lHeight
Main.rPrimary.Right = Main.ddsd2Primary.lWidth


ErrHandler:

    Select Case Err.Number

        Case 0
                    
            VBDXInitializeMainsurfaces = 1
                    
        Case Else ''Clean up and throw (raise) err
            
            VBDXInitializeMainsurfaces = 0
            Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, Err.HelpContext
    
    End Select
    
End Function

''Create a directdrawclipper object and attaches it to the surface.
''The clipper is returned from the function
''The aryRects must be Zer0-based indexed
Public Function VBDXCreateClipper(objDraw As DirectDraw7, dds As DirectDrawSurface7, aryRects() As RECT) As DirectDrawClipper
On Error GoTo ErrHandler
Dim ddClipper As DirectDrawClipper
 
''Create Clipper
Set ddClipper = objDraw.CreateClipper(0)

ddClipper.SetClipList UBound(aryRects) + 1, aryRects

dds.SetClipper ddClipper

ErrHandler:

    Select Case Err.Number

        Case 0
                    
            Set VBDXCreateClipper = ddClipper
                    
        Case Else ''Clean up and throw (raise) err
            
            Set VBDXCreateClipper = Nothing
            Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, Err.HelpContext
    
    End Select
    
End Function