mtools.bas

一个d3d实例程序

Attribute VB_Name = "mTools"
Option Explicit

Public Function EnumDeviceCallback(nGUID As Long, nDDDesc As Long, nDDName As Long, dHALDDDesc As D3DDEVICEDESC, dHELDDDesc As D3DDEVICEDESC, nOptions As Long) As Long

    ' Setup local variables ...
    
        Dim L_nTemp(256) As Byte                      ' Temporary array for name and guid translation
        Dim L_nChar As Byte                           ' Temporary charactar for name translation
        Dim L_nIndex As Long                          ' Variable to run through temp array
    
    ' Process current driver ...
    
        ' Inspect current driver
        With G_dD3DDriver
            
            ' Set driver capabilities...
              
                ' Decide if hardware supports color model and enable HAL or HEL support properly
                If dHALDDDesc.dcmColorModel Then
                  .DEVDESC = dHALDDDesc
                  .HDW = True
                Else
                  .DEVDESC = dHELDDDesc
                End If
                  
                ' Set RGB capability
                .RGB = (.DEVDESC.dcmColorModel = D3DCOLOR_RGB)
                ' Set emulation mode
                .EMU = (Not .HDW)
                ' Set mono ramp mode
                .MONO = (Not .RGB)
              
            ' Decide if driver fits application needs ...
            
                ' Exit without naming/enabling driver if no support for application color depth
                If (.DEVDESC.dwDeviceRenderBitDepth And DDBD_8) = 0 Then
                    EnumDeviceCallback = DDENUMRET_OK
                    Exit Function
                End If
                
                ' Exit without naming/enabling driver if no RGB support
                If Not .RGB Then
                    EnumDeviceCallback = DDENUMRET_OK
                    Exit Function
                End If
    
            ' DRIVER ACCEPTED ...
            
                ' Copy GUID data into temporary array
                CopyMemory VarPtr(L_nTemp(0)), VarPtr(nGUID), 16
                
                ' Set GUID data into driver structure
                .GUID = L_nTemp(0)
                .GUID1 = L_nTemp(1)
                .GUID2 = L_nTemp(2)
                .GUID3 = L_nTemp(3)
                .GUID4 = L_nTemp(4)
                .GUID5 = L_nTemp(5)
                .GUID6 = L_nTemp(6)
                .GUID7 = L_nTemp(7)
                .GUID8 = L_nTemp(8)
                .GUID9 = L_nTemp(9)
                .GUID10 = L_nTemp(10)
                .GUID11 = L_nTemp(11)
                .GUID12 = L_nTemp(12)
                .GUID13 = L_nTemp(13)
                .GUID14 = L_nTemp(14)
                .GUID15 = L_nTemp(15)
                
                ' Copy driver name into temporary array
                CopyMemory VarPtr(L_nTemp(0)), VarPtr(nDDName), 255
                  
                ' Parse name of driver
                For L_nIndex = 0 To 255
                    L_nChar = L_nTemp(L_nIndex)
                    If L_nChar < 32 Then Exit For
                    .NAME = .NAME + Chr(L_nChar)
                Next
                
                ' Copy driver Description into temporary array
                CopyMemory VarPtr(L_nTemp(0)), VarPtr(nDDDesc), 255
                  
                ' Parse description of driver
                For L_nIndex = 0 To 255
                    L_nChar = L_nTemp(L_nIndex)
                    If L_nChar < 32 Then Exit For
                    .DESC = .DESC + Chr(L_nChar)
                Next
        
        End With
            
        ' Return success
        G_bD3DDriverPresent = True
        EnumDeviceCallback = DDENUMRET_CANCEL

End Function

Public Function LoadBitmapIntoDXS(ByVal sFileName As String) As IDirectDrawSurface3

    ' Enable error handling ...
        On Error GoTo E_LoadBitmapIntoDXS
    
    ' 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_dDXD As DDSURFACEDESC           ' Surface descriptor
        Dim L_nDCDXS As Long                  ' Handle on dc of surface
        Dim L_oDDSTemp As IDirectDrawSurface3 ' 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", "LoadBitmapIntoDXS"
            Exit Function
        End If
        
        ' Get bitmap descriptor
        GetObject L_nBMBitmap, Len(L_dBitmap), L_dBitmap
        
        ' Fill DX surface description
        With L_dDXD
            .dwSize = Len(L_dDXD)
            .dwFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
            .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN
            .dwWidth = L_dBitmap.bmWidth
            .dwHeight = L_dBitmap.bmHeight
        End With
        
        ' Create DX surface
        G_oDDInstance.CreateSurface L_dDXD, L_oDDSTemp, Nothing
        
        ' Check surface existance
        If L_oDDSTemp Is Nothing Then
            AppError 0, "Surface could not be created", "LoadBitmapIntoDXS"
            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_dDXD.dwWidth, L_dDXD.dwHeight, 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 LoadBitmapIntoDXS = L_oDDSTemp
        
        ' Cleanup
        Set L_oDDSTemp = Nothing
    
    ' Error handler ...
    
        Exit Function
    
E_LoadBitmapIntoDXS:

        AppError Err.Number, Err.Description, "LoadBitmapIntoDXS"

End Function

Public Function MakeDXSurface(ByVal nWidth As Integer, ByVal nHeight As Integer, Optional bIs3D As Boolean) As IDirectDrawSurface3

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

        Dim L_dDXD As DDSURFACEDESC    ' Variable holding temporary surface description

    ' Create surface ...
    
        ' Fill surface description
        With L_dDXD
           .dwSize = Len(L_dDXD)
           .dwFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
           .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY Or IIf(bIs3D, DDSCAPS_3DDEVICE, 0)
           .dwWidth = nWidth
           .dwHeight = nHeight
        End With
    
        ' Create surface from description
        G_oDDInstance.CreateSurface L_dDXD, MakeDXSurface, Nothing
    
        ' Check for existance of surface
        If MakeDXSurface Is Nothing Then
           AppError 0, "Surface could not be created", "MakeDXSurface"
           Exit Function
        End If
    
    ' Error handler ...
        Exit Function
    
E_MakeDXSurface:

        AppError Err.Number, Err.Description, "MakeDXSurface"
    
End Function

Public Function LoadWaveIntoDSB(ByVal sFileName As String) As IDirectSoundBuffer
        
    ' Enable error handling ...
        
        On Error GoTo E_LoadWaveIntoDSB
    
    ' Setup local variables ...
    
        Dim L_dWFX As WAVEFORMATEX      ' Structure holding wave format description
        Dim L_nDataSize As Long         ' Size of audio data
        Dim L_nPosition As Long         ' Current position within wave file
        Dim L_nWaveBytes() As Byte      ' Array holding wave file data
        Dim L_dDSBD As DSBUFFERDESC     ' Structure holding description of DirectSound buffer
        
        Dim L_nPointer1 As Long      ' Pointer to left track data
        Dim L_nLength1 As Long       ' Length of left track data
        
        Dim L_nPointer2 As Long     ' Pointer to right track data
        Dim L_nLength2 As Long      ' Length of right track data
        
    ' Read wave file data into local array ...
        
        ' Set array size to file size
        ReDim L_nWaveBytes(1 To FileLen(sFileName))
        
        ' Load data into array
        Open sFileName For Binary As #1
        Get #1, , L_nWaveBytes
        Close #1
        
    ' Search for format data position ...
                
        ' Start at position 1
        L_nPosition = 1
        
        ' Look for format expression
        Do While Not (Chr(L_nWaveBytes(L_nPosition)) + Chr(L_nWaveBytes(L_nPosition + 1)) + Chr(L_nWaveBytes(L_nPosition + 2)) = "fmt")
            
            L_nPosition = L_nPosition + 1
            
            ' Cancel if no format expression found
            If L_nPosition > UBound(L_nWaveBytes) - 3 Then
                AppError 0, "Invalid file format", "LoadWaveIntoDSB"
            End If
            
        Loop