Merge pull request #388 from adrianbielsa1/fix_locked_array_error_on_…

…texture_cleanup

Fix locked array error on texture cleanup

CODIGO/clsTexManager.cls

@@ -33,34 +33,28 @@ Const HASH_TABLE_SIZE As Long = 337
 Const E_OUTOFMEMORY = 7
 
 Private Type SURFACE_ENTRY_DYN
-
     FileName As Integer
     UltimoAcceso As Long
     Texture As Direct3DTexture8
     size As Long
     texture_width As Integer
     texture_height As Integer
-
 End Type
 
 Private Type HashNode
-
     surfaceCount As Integer
     SurfaceEntry() As SURFACE_ENTRY_DYN
-
 End Type
 
 Private TexList(HASH_TABLE_SIZE - 1) As HashNode
 
 Private mD3D                         As D3DX8
 Private device                       As Direct3DDevice8
 Private mMaxEntries                  As Integer
-Private mCantidadGraficos            As Integer
 Private mFreeMemoryBytes             As Long
 
 
 Private Sub Class_Terminate()
-
     On Error GoTo Class_Terminate_Err
     Dim i As Long
     Dim j As Long
@@ -76,165 +70,181 @@ Private Sub Class_Terminate()
 
     Next i
 
-    
+
     Exit Sub
 
 Class_Terminate_Err:
-    Call RegistrarError(Err.number, Err.Description, "clsTexManager.Class_Terminate", Erl)
+    Call RegistrarError(Err.Number, Err.Description, "clsTexManager.Class_Terminate", Erl)
     Resume Next
-    
+
 End Sub
 
 Public Function GetTexture(ByVal FileName As Integer, ByRef textwidth As Long, ByRef textheight As Long) As Direct3DTexture8
-
-    On Error GoTo GetTexture_Err
-
-
-    If FileName = 0 Then
-        Debug.Print "0 GRH ATMPT TO BE LOADED"
-        Exit Function
-
-    End If
-
+On Error GoTo GetTexture_Err
+    Debug.Assert FileName > 0
+    Set GetTexture = Nothing
+    textwidth = 0
+    textheight = 0
     Dim i As Long
-
     ' Search the index on the list
     With TexList(FileName Mod HASH_TABLE_SIZE)
-
         For i = 1 To .surfaceCount
-
             If .SurfaceEntry(i).FileName = FileName Then
                 .SurfaceEntry(i).UltimoAcceso = GetTickCount()
                 textwidth = .SurfaceEntry(i).texture_width
                 textheight = .SurfaceEntry(i).texture_height
                 Set GetTexture = .SurfaceEntry(i).Texture
                 Exit Function
-
             End If
-
         Next i
-
     End With
-
     'Not in memory, load it!
     Set GetTexture = CreateDirect3dTexture(FileName, textwidth, textheight)
-
     Exit Function
 
 GetTexture_Err:
-    Call RegistrarError(Err.number, Err.Description, "clsTexManager.GetTexture", Erl)
+    Call RegistrarError(Err.Number, Err.Description, "clsTexManager.GetTexture", Erl)
     Resume Next
-
 End Function
 
 Public Function Init(ByRef D3D8 As D3DX8, ByRef d3d_device As Direct3DDevice8, ByVal MaxMemory As Long) As Boolean
-    '**************************************************************
-    'Author: Juan Martín Sotuyo Dodero
-    'Last Modify Date: 5/04/2005
-    '
-    '**************************************************************
-
-    On Error GoTo Init_Err
-
-    mCantidadGraficos = 0
-
-    'Seteamos el objeto
+On Error GoTo Init_Err
+
     Set mD3D = D3D8
     Set device = d3d_device
     mFreeMemoryBytes = MaxMemory
-
     Init = True
 
-
     Exit Function
-
 Init_Err:
-    Call RegistrarError(Err.number, Err.Description, "clsTexManager.Init", Erl)
+    Call RegistrarError(Err.Number, Err.Description, "clsTexManager.Init", Erl)
     Resume Next
-    
+
 End Function
 
 Private Function LoadTexture(ByVal FileName As String, ByRef Dest As Direct3DTexture8) As Long
+
 On Error GoTo LoadTexture_ErrHandler
-    Dim bytArr()     As Byte
+
+    Dim bytArr() As Byte
+
     #If Compresion = 1 Then
         If Not Extract_File_To_Memory(Graphics, App.path & "\..\Recursos\OUTPUT\", LTrim(FileName) & ".png", bytArr, ResourcesPassword) Then
             Debug.Print "¡No se puede cargar el grafico numero " & FileName & "!"
             Exit Function
         End If
-        Set Dest = mD3D.CreateTextureFromFileInMemoryEx(device, bytArr(0), UBound(bytArr) + 1, D3DX_DEFAULT, D3DX_DEFAULT, 1, 0, _
-                                                            D3DFMT_A8R8G8B8, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, &HFF000000, ByVal 0, ByVal 0)
+
+        Set Dest = mD3D.CreateTextureFromFileInMemoryEx( _
+            device, bytArr(0), UBound(bytArr) + 1, _
+            D3DX_DEFAULT, D3DX_DEFAULT, 1, 0, _
+            D3DFMT_A8R8G8B8, D3DPOOL_DEFAULT, _
+            D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, &HFF000000, _
+            ByVal 0, ByVal 0 _
+        )
     #Else
         Dim PathToFile As String
         PathToFile = App.path & "\..\Recursos\Graficos\" & LTrim(FileName) & ".png"
+
         If Not FileExist(PathToFile, vbArchive) Then
             Debug.Print "¡No se puede cargar el grafico numero " & PathToFile & "!"
             Exit Function
         End If
 
-        Set Dest = mD3D.CreateTextureFromFileEx(device, PathToFile, 0, 0, _
-             1, 0, D3DFMT_A8R8G8B8, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, &HFF000000, ByVal 0, ByVal 0)
+        Set Dest = mD3D.CreateTextureFromFileEx( _
+            device, PathToFile, _
+            0, 0, 1, 0, _
+            D3DFMT_A8R8G8B8, D3DPOOL_DEFAULT, _
+            D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, &HFF000000, _
+            ByVal 0, ByVal 0 _
+        )
     #End If
+
+    Debug.Assert (Not (Dest Is Nothing))
+
     Exit Function
+
 LoadTexture_ErrHandler:
     LoadTexture = Err.Number
+
 End Function
+Private Sub ReleaseMemory()
+    Dim i As Long
+    For i = 0 To 100
+       Call RemoveLRU
+    Next
+End Sub
+Private Function CreateDirect3dTexture(ByVal FileNum As Integer, ByRef TextureWidth As Long, ByRef TextureHeight As Long) As Direct3DTexture8
 
-Private Function CreateDirect3dTexture(ByVal FileNum As Integer, ByRef texture_width As Long, ByRef texture_height As Long) As Direct3DTexture8
 On Error GoTo ErrHandler
-    Dim surface_desc As D3DSURFACE_DESC
-    Dim Index        As Integer
-    Dim DirArchico   As String
-    Dim LoadResult As Long
-
+
+    Dim Texture         As Direct3DTexture8
+    Dim surfaceDesc     As D3DSURFACE_DESC
+    Dim loadResult      As Long
     Set CreateDirect3dTexture = Nothing
-    texture_width = 0
-    texture_height = 0
+    TextureWidth = 0
+    TextureHeight = 0
+    loadResult = LoadTexture(str(FileNum), Texture)
 
-    Index = FileNum Mod HASH_TABLE_SIZE
-
-    With TexList(Index)
-        .surfaceCount = .surfaceCount + 1
-        ReDim Preserve .SurfaceEntry(1 To .surfaceCount) As SURFACE_ENTRY_DYN
-
-        With .SurfaceEntry(.surfaceCount)
-            .FileName = FileNum
-            .UltimoAcceso = GetTickCount()
-            LoadResult = LoadTexture(str(FileNum), .Texture)
-            If LoadResult = E_OUTOFMEMORY Then
-                Dim i As Integer
-                For i = 0 To 100
-                    Call RemoveLRU
-                Next i
-                LoadResult = LoadTexture(str(FileNum), .Texture)
-            ElseIf LoadResult <> 0 Then
-                Call RegistrarError(LoadResult, "Unhandled error", "clsTexManager.LoadTexture", 0)
-            End If
-
-            .Texture.GetLevelDesc 0, surface_desc
-            .texture_width = surface_desc.Width
-            .texture_height = surface_desc.Height
-            .size = surface_desc.size
-            texture_width = .texture_width
-            texture_height = .texture_height
-            mFreeMemoryBytes = mFreeMemoryBytes - .size
-            Set CreateDirect3dTexture = .Texture
+    Select Case loadResult
+        Case D3DERR_INVALIDCALL
+            Debug.Assert False
+            Debug.Print "LoadTexture failed with D3DERR_INVALIDCALL"
+        Case D3DERR_NOTAVAILABLE
+            Debug.Assert False
+            Debug.Print "LoadTexture failed with D3DERR_NOTAVAILABLE"
+        Case D3DXERR_INVALIDDATA
+            Debug.Assert False
+            Debug.Print "LoadTexture failed with D3DXERR_INVALIDDATA"
+        Case D3DERR_OUTOFVIDEOMEMORY
+        Case E_OUTOFMEMORY
+            Call ReleaseMemory
+            'Try to load the texture again, if it fails we've run out of options.
+            loadResult = LoadTexture(str(FileNum), Texture)
+    End Select
+
+    If loadResult <> D3D_OK Then
+       Call RegistrarError(loadResult, "Unhandled error", "clsTexManager.LoadTexture", 0)
+       Exit Function
+    Else
+        Call Texture.GetLevelDesc(0, surfaceDesc)
+
+        With TexList(FileNum Mod HASH_TABLE_SIZE)
+            .surfaceCount = .surfaceCount + 1
+            ReDim Preserve .SurfaceEntry(1 To .surfaceCount) As SURFACE_ENTRY_DYN
+
+            With .SurfaceEntry(.surfaceCount)
+                .FileName = FileNum
+                .UltimoAcceso = GetTickCount()
+                Set .Texture = Texture
+                .texture_width = surfaceDesc.Width
+                .texture_height = surfaceDesc.Height
+                .size = surfaceDesc.size
+            End With
         End With
-
-    End With
+
+        'Keep track of how many memory we've been using.
+        mFreeMemoryBytes = mFreeMemoryBytes - surfaceDesc.size
+
+        'Ensure all return values are filled.
+        TextureWidth = surfaceDesc.Width
+        TextureHeight = surfaceDesc.Height
+        Set CreateDirect3dTexture = Texture
+    End If
+
+
 
     Exit Function
 
-errhandler:
+ErrHandler:
     Debug.Print "ERROR EN GRHLOAD>" & FileNum & ".png"
 
 End Function
 
 Public Function CreateTexture(ByVal Width As Long, ByVal Height As Long) As Direct3DTexture8
 On Error GoTo ErrHandler
     Dim Texture As Direct3DTexture8
-    Set Texture = mD3D.CreateTexture(device, Width, Height, 1, 0, D3DFMT_A8R8G8B8, D3DPOOL_MANAGED)
-    
+    Set Texture = mD3D.CreateTexture(device, Width, Height, 1, 0, D3DFMT_A8R8G8B8, D3DPOOL_DEFAULT)
+
     Set CreateTexture = Texture
     Exit Function
 ErrHandler:
@@ -243,13 +253,13 @@ End Function
 
 Public Sub SetTextureData(ByRef Texture As Direct3DTexture8, ByRef Bytes() As Byte, ByVal size As Long, _
                           ByVal TextureWidth As Long, ByVal DrawWidth As Integer, _
-                          ByVal startY As Integer, ByVal endY As Integer)
+                          ByVal StartY As Integer, ByVal endY As Integer)
 On Error GoTo ErrHandler
     Debug.Assert Not Texture Is Nothing
     Dim lr As D3DLOCKED_RECT
-    Dim RenderArea As RECT
+    Dim RenderArea As Rect
     RenderArea.Left = 0
-    RenderArea.Top = startY
+    RenderArea.Top = StartY
     RenderArea.Bottom = endY
     RenderArea.Right = DrawWidth
     Call Texture.LockRect(0, lr, ByVal RenderArea, 0)
@@ -268,20 +278,8 @@ ErrHandler:
     Call RegistrarError(Err.Number, Err.Description, "clsTexManager.SetTextureData", Erl)
 End Sub
 
-Public Function CreateTextureFromData(ByRef Bytes() As Byte, ByVal Size As Long, ByVal Width As Long, ByVal Height As Long) As Direct3DTexture8
-On Error GoTo ErrHandler
-    Dim Texture As Direct3DTexture8
-    Set Texture = mD3D.CreateTextureFromFileInMemoryEx(device, Bytes(0), UBound(Bytes) + 1, Width, Height, 1, 0, D3DFMT_A8R8G8B8, D3DPOOL_DEFAULT, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, &HFF000000, ByVal 0, ByVal 0)
-    Set CreateTextureFromData = Texture
-    Debug.Assert Not Texture Is Nothing
-    Exit Function
-ErrHandler:
-    Debug.Print "Failed to generate texture from memory, " & Err.Description
-End Function
-
-
 Private Function RemoveLRU() As Boolean
-    
+
         On Error GoTo RemoveLRU_Err
 
         Dim LRUi         As Long
@@ -292,7 +290,7 @@ Private Function RemoveLRU() As Boolean
 
         Dim surface_desc As D3DSURFACE_DESC
 100     LRUtime = GetTickCount()
-    
+
         'Check out through the whole list for the least recently used
 102     For i = 0 To HASH_TABLE_SIZE - 1
 104         With TexList(i)
@@ -306,14 +304,14 @@ Private Function RemoveLRU() As Boolean
 116             Next j
             End With
 118     Next i
-    
+
         'Retrieve the surface desc
 120     Call TexList(LRUi).SurfaceEntry(LRUj).Texture.GetLevelDesc(0, surface_desc)
-    
+
         'Remove it
 122     Set TexList(LRUi).SurfaceEntry(LRUj).Texture = Nothing
 124     TexList(LRUi).SurfaceEntry(LRUj).FileName = 0
-    
+
         'Move back the list (if necessary)
 126     If LRUj Then
 128         RemoveLRU = True
@@ -337,5 +335,3 @@ RemoveLRU_Err:
      Call RegistrarError(Err.Number, Err.Description, "clsTexManager.RemoveLRU", Erl)
      Resume Next
 End Function
-
-

CODIGO/frmMain.frm

@@ -2096,6 +2096,7 @@ Private Sub exp_MouseMove(button As Integer, Shift As Integer, x As Single, y As
 End Sub
 
 Private Sub Form_Activate()
+    renderer.Refresh
 
     On Error GoTo Form_Activate_Err