clsmemmgr.cls

一个游戏的原代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Cls_MemoryMgr"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'This class is used for simple texture-pooling
Option Compare Text

Private Const MIP_LEVELS = D3DX_DEFAULT

Private Type MmgrTexture
 path As String
 tex As Direct3DTexture8
End Type

Private TexPool() As MmgrTexture
Private numTextures As Long
Private curTexture(7) As String

Private sID As Long

Public Function LoadTexture(ByVal TexPath As String) As String
If TexPath = "$lightmap" Then
    LoadTexture = "$lightmap"
    Exit Function
End If

TexPath = PathWin32(TexPath)

If numTextures > 0 Then
 For sID = 0 To numTextures - 1
    If TexPool(sID).path = TexPath Then LoadTexture = TexPool(sID).path: Exit Function 'Texture already exists in pool -> don't do anything!
    If TexPool(sID).path = TexPath & ".jpg" Then LoadTexture = TexPool(sID).path: Exit Function
    If TexPool(sID).path = TexPath & ".tga" Then LoadTexture = TexPool(sID).path: Exit Function

    TexPath = Replace$(TexPath, ".jpg", "")
    TexPath = Replace$(TexPath, ".tga", "")

    If TexPool(sID).path = TexPath & ".jpg" Then LoadTexture = TexPool(sID).path: Exit Function
    If TexPool(sID).path = TexPath & ".tga" Then LoadTexture = TexPool(sID).path: Exit Function
 Next sID
End If

ReDim Preserve TexPool(numTextures)


If FileExists(TexPath) Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, TexPath, 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
    GoTo TexFound:
ElseIf FileExists(TexPath & ".jpg") Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, TexPath & ".jpg", 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
    GoTo TexFound:
ElseIf FileExists(TexPath & ".tga") Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, TexPath & ".tga", 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
    GoTo TexFound:
End If

If Mid(App.path, 1, 2) <> "C:" Then

If FileExists(App.path & "\" & TexPath) Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, App.path & "\" & TexPath, 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
    GoTo TexFound:
ElseIf FileExists(App.path & "\" & TexPath & ".jpg") Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, App.path & "\" & TexPath & ".jpg", 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
    GoTo TexFound:
ElseIf FileExists(App.path & "\" & TexPath & ".tga") Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, App.path & "\" & TexPath & ".tga", 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
    GoTo TexFound:
End If

'Try without extension
TexPath = Replace$(TexPath, ".jpg", "")
TexPath = Replace$(TexPath, ".tga", "")
If FileExists(App.path & "\" & TexPath & ".jpg") Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, App.path & "\" & TexPath & ".jpg", 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
ElseIf FileExists(App.path & "\" & TexPath & ".tga") Then
    Set TexPool(numTextures).tex = D3DX.CreateTextureFromFileEx(D3Ddevice, App.path & "\" & TexPath & ".tga", 0, 0, MIP_LEVELS, 0, TexFormat, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
Else
    Set TexPool(numTextures).tex = Nothing
    'Debug.Print "notfound: " & TexPath
End If

End If

TexFound:
TexPool(numTextures).path = TexPath
LoadTexture = TexPath
numTextures = numTextures + 1
End Function

Public Sub EraseAllTextures()
For sID = 0 To numTextures - 1
    Set TexPool(sID).tex = Nothing
    TexPool(sID).path = vbNullString
Next sID

Erase TexPool()
End Sub

Public Sub DumbTexturesToFile(filename As String)
Dim it As Long
Dim fp As Integer

fp = FreeFile()

Open filename For Append As #fp
Print #fp, "textures loaded"
 For it = 0 To numTextures - 1
    Print #fp, TexPool(it).path
 Next it
Close #fp
End Sub

Public Sub SetTexture(lngStage As Long, ByVal TexPath As String)
If curTexture(lngStage) = TexPath Then Exit Sub
For sID = 0 To numTextures - 1
    If TexPool(sID).path = TexPath Then
        D3Ddevice.SetTexture lngStage, TexPool(sID).tex
        curTexture(lngStage) = TexPool(sID).path
        Exit Sub
    End If
Next sID
End Sub

Public Sub ClearTexture(lngStage, Optional DeleteAll As Boolean)
curTexture(lngStage) = ""
If DeleteAll Then
    D3Ddevice.SetTexture lngStage, Nothing
End If
End Sub