mtools.bas

游戏常见三为场景

Attribute VB_Name = "mTools"
Option Explicit

' ADVANCEDBLIT: Decide if to blit using blitfast or using GDI based on surface memory
Public Sub AdvancedBlit(nTargetX As Integer, nTargetY As Integer, oDDTarget As IDirectDrawSurface4, oDDSource As IDirectDrawSurface4, dSourceArea As RECT)

    ' Enable error handling ...
        On Error GoTo E_AdvancedBlit
    
    ' Setup local variables ...
        Dim L_nDCSource As Long                  ' Handle on dc of surface
        Dim L_nDCTarget As Long                  ' Handle on dc of surface
        
' NOTE: THIS CODE SHOULD ACHIEVE TEXTURE ANIMATION ON 3DFX CARDS
' ACCORDING TO MOST PEOPLE ON THE NET I ASKED ABOUT IT. BUT IT
' DOESN'T WORK. TRY IF IT WORKS ON YOUR CARD ...

    ' Blit...
    
        ' Use BitBlt, because we deal with a 3DFX card
        If (G_dDXSelectedDriver.DriverType = EDXDTPlus) Then
            
            ' Lock and get DC for source
'            oDDSource.Restore
'            oDDSource.GetDC L_nDCSource
            
'            ' Lock and get DC for target
'            oDDTarget.Restore
'            oDDTarget.GetDC L_nDCTarget
'
'            ' BitBlit from source to destination
'            With dSourceArea
'                StretchBlt L_nDCTarget, nTargetX, nTargetY, .Right - .Left, .Bottom - .Top, L_nDCSource, .Left, .Top, .Right - .Left, .Bottom - .Top, SRCCOPY
'            End With
'
'            ' Cleanup
'            oDDTarget.ReleaseDC L_nDCTarget
'            oDDSource.ReleaseDC L_nDCSource
        
        ' Use BltFast, because we deal with a standard card
        Else
        
            oDDTarget.BltFast nTargetX, nTargetY, oDDSource, dSourceArea, DDBLTFAST_NOCOLORKEY Or DDBLTFAST_WAIT
            
        End If
        
    ' Error handling
    
        Exit Sub
    
E_AdvancedBlit:

        ' Cleanup
        If L_nDCSource <> 0 Then oDDSource.ReleaseDC L_nDCSource
        If L_nDCTarget <> 0 Then oDDTarget.ReleaseDC L_nDCTarget
        
        ' Report error
        AppError Err.Number, Err.Description, "AdvancedBlit"
                    
End Sub
' LOADTEXTURE: Loads a bitmap from file into memory as a texture
Public Function LoadTexture(ByVal sFileName As String, Optional ByVal bForceSystemMemory As Boolean) As IDirectDrawSurface4

    ' Enable error handling ...
        On Error GoTo E_LoadTexture
    
    ' Setup local variables ...
        
        Dim L_nBMBitmap As Long               ' Handle on bitmap
        Dim L_nDCBitmap As Long               ' Handle on dc of bitmap
        Dim L_dBitmap As BITMAP               ' Bitmap descriptor
        Dim L_nDCDXS As Long                  ' Handle on dc of surface
        Dim L_oDDSTemp As IDirectDrawSurface4 ' Temporary DD surface
        Dim L_dRenderArea As RECT             ' Rectangle for blitting
        
    ' Load bitmap into surface ...
    
        ' Load bitmap
        L_nBMBitmap = LoadImage(ByVal 0&, sFileName, 0, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
        
        ' Check for validity of bitmap handle
        If L_nBMBitmap < 1 Then
            AppError 0, "Bitmap could not be loaded", "LoadTextureIntoDX"
            Exit Function
        End If
        
        ' Get bitmap descriptor
        GetObject L_nBMBitmap, Len(L_dBitmap), L_dBitmap
        
        ' Check validity of image
        If L_dBitmap.bmWidth <> L_dBitmap.bmHeight Then
            AppError 0, "Invalid texture image format", "LoadTexture"
            Exit Function
        End If
        
        ' Create temporary surface
        Set L_oDDSTemp = CreateSurface(L_dBitmap.bmWidth, L_dBitmap.bmHeight, DDSCAPS_OFFSCREENPLAIN, bForceSystemMemory)
        
        ' Check surface existance
        If L_oDDSTemp Is Nothing Then
            AppError 0, "Surface could not be created", "LoadTexture"
            Exit Function
        End If
        
        ' Create API memory DC
        L_nDCBitmap = CreateCompatibleDC(ByVal 0&)
        
        ' Select the bitmap into API memory DC
        SelectObject L_nDCBitmap, L_nBMBitmap
        
        ' Restore DX surface
        L_oDDSTemp.Restore
        
        ' Get DX surface API DC
        L_oDDSTemp.GetDC L_nDCDXS
        
        ' Blit BMP from API DC into DX DC using standard API BitBlt
        StretchBlt L_nDCDXS, 0, 0, L_dBitmap.bmWidth, L_dBitmap.bmHeight, L_nDCBitmap, 0, 0, L_dBitmap.bmWidth, L_dBitmap.bmHeight, SRCCOPY
        
        ' Cleanup API stuff
        L_oDDSTemp.ReleaseDC L_nDCDXS
        DeleteDC L_nDCBitmap
        DeleteObject L_nBMBitmap
                
        ' Create surface
        Set LoadTexture = CreateTexture(L_dBitmap.bmWidth, bForceSystemMemory)
                
        ' Blit loaded data into texture
        With L_dRenderArea
            .Top = 0
            .Left = 0
            .Bottom = L_dBitmap.bmHeight
            .Right = L_dBitmap.bmWidth
        End With
        LoadTexture.BltFast 0, 0, L_oDDSTemp, L_dRenderArea, DDBLTFAST_NOCOLORKEY
                
        ' Cleanup
        Set L_oDDSTemp = Nothing
    
    ' Error handler ...
    
        Exit Function
    
E_LoadTexture:

        AppError Err.Number, Err.Description, "LoadTexture"

End Function

' LOADSURFACE: Loads a bitmap from file into a DirectDraw surface
Public Function LoadSurface(ByVal sFileName As String, Optional ByVal bForceSystemMemory As Boolean) As IDirectDrawSurface4

    ' Enable error handling ...
        On Error GoTo E_LoadSurface
    
    ' Setup local variables ...
        
        Dim L_nBMBitmap As Long               ' Handle on bitmap
        Dim L_nDCBitmap As Long               ' Handle on dc of bitmap
        Dim L_dBitmap As BITMAP               ' Bitmap descriptor
        Dim L_nDCDXS As Long                  ' Handle on dc of surface
        Dim L_oDDSTemp As IDirectDrawSurface4 ' Temporary DD surface
    
    ' Load bitmap into surface ...
    
        ' Load bitmap
        L_nBMBitmap = LoadImage(ByVal 0&, sFileName, 0, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
        
        ' Check for validity of bitmap handle
        If L_nBMBitmap < 1 Then
            AppError 0, "Bitmap could not be loaded", "LoadSurface"
            Exit Function
        End If
        
        ' Get bitmap descriptor
        GetObject L_nBMBitmap, Len(L_dBitmap), L_dBitmap
        
        Set L_oDDSTemp = CreateSurface(L_dBitmap.bmWidth, L_dBitmap.bmHeight, DDSCAPS_OFFSCREENPLAIN)
        
        ' Create API memory DC
        L_nDCBitmap = CreateCompatibleDC(ByVal 0&)
        
        ' Select the bitmap into API memory DC
        SelectObject L_nDCBitmap, L_nBMBitmap
        
        ' Restore DX surface
        L_oDDSTemp.Restore
        
        ' Get DX surface API DC
        L_oDDSTemp.GetDC L_nDCDXS
        
        ' Blit BMP from API DC into DX DC using standard API BitBlt
        StretchBlt L_nDCDXS, 0, 0, L_dBitmap.bmWidth, L_dBitmap.bmHeight, L_nDCBitmap, 0, 0, L_dBitmap.bmWidth, L_dBitmap.bmHeight, SRCCOPY
        
        ' Cleanup
        L_oDDSTemp.ReleaseDC L_nDCDXS
        DeleteDC L_nDCBitmap
        DeleteObject L_nBMBitmap
        
        ' Return success
        Set LoadSurface = L_oDDSTemp
        
        ' Cleanup
        Set L_oDDSTemp = Nothing
    
    ' Error handler ...
    
        Exit Function
    
E_LoadSurface:

        Set L_oDDSTemp = Nothing
        AppError Err.Number, Err.Description, "LoadSurface"

End Function

' CREATESURFACE: Creates a DirectDraw surface of given size
Public Function CreateSurface(ByVal nWidth As Integer, ByVal nHeight As Integer, Optional nAdditionalCaps As Long, Optional ByVal bForceSystemMemory As Boolean) As IDirectDrawSurface4

    ' Enable error handling ...
        
        On Error GoTo E_CreateSurface
    
    ' Setup local variables ...

        Dim L_dDXD As DDSURFACEDESC2   ' Variable holding temporary surface description
    
    ' Create surface ...
    
        ' Fill surface description
        With L_dDXD
           .dwSize = Len(L_dDXD)