[ APORTE ] Drag&Drop (Dx7)

Ir abajo

[ APORTE ] Drag&Drop (Dx7)

Mensaje por Shermie80 el Sáb Nov 02, 2013 12:10 am

en el codigo del frmmain, debajo del option explicit

ponemos

Código:
Private last_i            As Long
 
Public usando_Drag        As Boolean
Public usaba_Drag          As Boolean
en el Sub Form_MouseMove del frmmain abajo de

Código:
LastPressed.ToggleToNormal
ponemos

Código:
          Call ConvertCPtoTP(X, Y, tX, tY)
     
        If usando_Drag Then
                General_Drop_X_Y tX, tY
                usaba_Drag = False
        End If
al final de todo el codigo ponemos

Código:
Dim i        As Integer
 
                Dim file_path As String
             
                'Inventario.SelectedItem  X, Y
 
              If Inventario.GrhIndex(Inventario.SelectedItem) > 0 Then
 
                      last_i = Inventario.SelectedItem
     
                      If last_i > 0 And last_i <= MAX_INVENTORY_SLOTS Then
 
                              Dim Poss As Integer
 
                              Poss = Search_GhID(Inventario.GrhIndex(Inventario.SelectedItem))
                             
                              If Poss = 0 Then
                             
                                      i = GrhData(Inventario.GrhIndex(Inventario.SelectedItem)).FileNum
 
                                      DoEvents
                                     
                                      i = GrhData(Inventario.GrhIndex(Inventario.SelectedItem)).FileNum
                               
                                      file_path = DirGraficos & CStr(GrhData(Inventario.GrhIndex(Inventario.SelectedItem)).FileNum) & ".bmp"
                         
                                      frmMain.ImageList1.ListImages.Add , CStr("g" & Inventario.GrhIndex(Inventario.SelectedItem)), Picture:=LoadPicture(file_path)
                                      Poss = frmMain.ImageList1.ListImages.Count
                              End If
         
                              usando_Drag = True
         
                              Set picInv.MouseIcon = frmMain.ImageList1.ListImages(Poss).ExtractIcon
                              frmMain.picInv.MousePointer = vbCustom
 
                              Exit Sub
 
                      End If
              End If
      End If
 
End Sub
 
Private Function Search_GhID(Gh As Integer) As Long
 
      ' / Author: Dunkansdk
 
        Dim i As Long
 
        For i = 1 To frmMain.ImageList1.ListImages.Count
 
                If frmMain.ImageList1.ListImages(i).Key = "g" & CStr(Gh) Then
                        Search_GhID = i
 
                        Exit For
 
                End If
 
        Next i
 
End Function
 
Private Sub PicInv_MouseMove(Button As Integer, _
                            Shift As Integer, _
                            X As Single, _
                            Y As Single)
 
        If Not usando_Drag Then
                picInv.MousePointer = vbDefault
        End If
 
End Sub
Buscamos en el modulo de clase clsGrapchicalInventory

pero antes declaramos esto abajo de su option explicit

Código:
Private MouseDownSelectedItem      As Long
Dim TempItem                      As Long
ahora buscamos

Código:
Private Sub InventoryWindow_MouseUp(Button As Integer,
y remplazamos todo el sub por esto

Código:
Private Sub InventoryWindow_MouseDown(Button As Integer, _
                                      Shift As Integer, _
                                      X As Single, _
                                      Y As Single)
 
        Dim TempItem As Long
 
        If Button = 2 Then
                TempItem = ClickItem(X, Y)
             
                If TempItem = 0 Then Exit Sub
           
                If Inventory(TempItem).GrhIndex Then
                        MouseDownSelectedItem = TempItem
 
                        Exit Sub
 
                End If
        End If
 
        'MouseDownSelectedItem = 0
End Sub
 
Private Sub InventoryWindow_MouseUp(Button As Integer, _
                                  Shift As Integer, _
                                  X As Single, _
                                  Y As Single)
      '***************************************************
        'Author: Juan Martín Sotuyo Dodero (Maraxus)
      'Last Modify Date: 27/07/04
        'Implements the mouse up event of the inventory picture box
      'Check outs which item was clicked
        '***************************************************
      'Store previously selected item
 
        Dim prevSelItem As Long
 
        'Exit if it got outside the control's area
 
        If X < 0 Or Y < 0 Or X > InventoryWindow.Width Or Y > InventoryWindow.Height Then
 
                Exit Sub
 
        End If
 
        prevSelItem = InvSelectedItem
 
        'Get the currently clickced item
 
      InvSelectedItem = ClickItem(CInt(X), CInt(Y))
 
      'Update needed inventory slots
 
 
        If prevSelItem <> InvSelectedItem Then
                If prevSelItem <> 0 And prevSelItem <> FLAGORO Then Call DrawInventorySlot(prevSelItem)
                If InvSelectedItem Then Call DrawInventorySlot(InvSelectedItem)
        End If
     
        If frmMain.usando_Drag And TempItem <= 25 And TempItem >= 0 And Not frmMain.usaba_Drag Then
                'If InvSelectedItem <> MouseDownSelectedItem And MouseDownSelectedItem <> 0 And InvSelectedItem <> 0 Then
              Call WriteDragInventory(prevSelItem, TempItem)
              frmMain.usando_Drag = False
              'Else
                'frmMain.usando_Drag = False
              'End If
        Else
                frmMain.usando_Drag = False
        End If
 
End Sub
 
 
Agregamos un nuevo modulo con el siguiente codigo

Codigo:
Código:
Option Explicit
 
Public Sub General_Drop_X_Y(ByVal X As Byte, ByVal Y As Byte)
 
        ' /  Author  : Dunkan
      ' /  Note    : Calcular la posición de donde va a tirar el item
 
        If (Inventario.SelectedItem > 0 And Inventario.SelectedItem < MAX_INVENTORY_SLOTS + 1) Then
     
                ' - Hay que pasar estas funciones al servidor
 
              If MapData(X, Y).Blocked = 1 Then
                      Call ShowConsoleMsg("Elige una posición válida para tirar tus objetos.")
                      frmMain.usando_Drag = False
 
                      Exit Sub
 
              End If
     
              If HayAgua(X, Y) = True Then
                      Call ShowConsoleMsg("No está permitido tirar objetos en el agua.")
                      frmMain.usando_Drag = False
 
                      Exit Sub
 
              End If
     
              ' - Hay que pasar estas funciones al servidor
     
                If GetKeyState(vbKeyShift) < 0 Then
                        'frmCantidad.Show vbModal
              Else
                      Call Mod_DragAndDrop.WriteDragToPos(X, Y, Inventario.SelectedItem, 1)
              End If
     
      End If
 
      frmMain.usando_Drag = False
 
End Sub
 
Public Sub WriteDragInventory(ByVal originalSlot As Byte, ByVal targetSlot As Byte)
 
      ' @ Author : maTih.-
        '            Drag&Drop de objetos en el inventario.
 
      With outgoingData
              .WriteByte ClientPacketID.DragInventario
              .WriteByte originalSlot
              .WriteByte targetSlot
      End With
 
End Sub
 
Public Sub WriteDragToPos(ByVal X As Byte, _
                        ByVal Y As Byte, _
                        ByVal slot As Byte, _
                        ByVal Amount As Integer)
 
      ' @ Author : maTih.-
        '            Drag&Drop de objetos en del inventario a una posición.
 
      With outgoingData
              .WriteByte ClientPacketID.DragToPos
              .WriteByte X
              .WriteByte Y
              .WriteByte slot
              .WriteInteger Amount
      End With
 
End Sub
 

Buscamos

Código:
StopSharingNpc          '/NOCOMPARTIRNPC
abajo

Código:
DragToPos
    DragInventario
AHORA AL SERVIDOR

nuevo modulo llamado Mod_DragAndDrop

Codigo:
Código:
 
Option Explicit
 
Public Sub DragToUser(ByVal UserIndex As Integer, _
                      ByVal tIndex As Integer, _
                      ByVal Slot As Byte, _
                      ByVal Amount As Integer)
 
        ' @ Author : maTih.-
      '            Drag un slot a un usuario.
 
        Dim tObj    As Obj
        Dim tString As String
        Dim Espacio As Boolean
 
        'Preparo el objeto.
      tObj.Amount = Amount
      tObj.objIndex = UserList(UserIndex).Invent.Object(Slot).objIndex
 
      Espacio = MeterItemEnInventario(tIndex, tObj)
 
      'No tiene espacio.
 
        If Not Espacio Then
                WriteConsoleMsg UserIndex, "El usuario no tiene espacio en su inventario.", FontTypeNames.FONTTYPE_CITIZEN
 
                Exit Sub
 
        End If
 
        'Quito el objeto.
      QuitarUserInvItem UserIndex, Slot, Amount
 
      'Hago un update de su inventario.
        UpdateUserInv False, UserIndex, Slot
 
        'Preparo el mensaje para userINdex (quien dragea)
 
      tString = "Le has arrojado"
 
      If tObj.Amount <> 1 Then
              tString = tString & " " & tObj.Amount & " - " & ObjData(tObj.objIndex).name
      Else
              tString = tString & " Tu " & ObjData(tObj.objIndex).name
      End If
 
      tString = tString & " ah " & UserList(tIndex).name
 
      'Envio el mensaje
        WriteConsoleMsg UserIndex, tString, FontTypeNames.FONTTYPE_CITIZEN
 
        'Preparo el mensaje para el otro usuario (quien recibe)
      tString = UserList(UserIndex).name & " Te ha arrojado"
 
      If tObj.Amount <> 1 Then
              tString = tString & " " & tObj.Amount & " - " & ObjData(tObj.objIndex).name
      Else
              tString = tString & " su " & ObjData(tObj.objIndex).name
      End If
 
      'Envio el mensaje al otro usuario
        WriteConsoleMsg UserIndex, tString, FontTypeNames.FONTTYPE_CITIZEN
 
End Sub
 
Public Sub DragToNPC(ByVal UserIndex As Integer, _
                    ByVal tNpc As Integer, _
                    ByVal Slot As Byte, _
                    ByVal Amount As Integer)
 
        ' @ Author : maTih.-
      '            Drag un slot a un npc.
 
        On Error GoTo errHandler
 
        Dim TeniaOro As Long
        Dim teniaObj As Integer
        Dim tmpIndex As Integer
 
        tmpIndex = UserList(UserIndex).Invent.Object(Slot).objIndex
        TeniaOro = UserList(UserIndex).Stats.GLD
        teniaObj = UserList(UserIndex).Invent.Object(Slot).Amount
 
        'Es un banquero?
 
      If Npclist(tNpc).NPCtype = eNPCType.Banquero Then
              Call UserDejaObj(UserIndex, Slot, Amount)
              'No tiene más el mismo amount que antes? entonces depositó.
 
                If teniaObj <> UserList(UserIndex).Invent.Object(Slot).Amount Then
                        WriteConsoleMsg UserIndex, "Has depositado " & Amount & " - " & ObjData(tmpIndex).name, FontTypeNames.FONTTYPE_CITIZEN
                        UpdateUserInv False, UserIndex, Slot
                End If
 
                'Es un npc comerciante?
      ElseIf Npclist(tNpc).Comercia = 1 Then
              'El npc compra cualquier tipo de items?
 
                If Not Npclist(tNpc).TipoItems <> eOBJType.otCualquiera Or Npclist(tNpc).TipoItems = ObjData(UserList(UserIndex).Invent.Object(Slot).objIndex).OBJType Then
                        Call Comercio(eModoComercio.Venta, UserIndex, tNpc, Slot, Amount)
                        'Ganó oro? si es así es porque lo vendió.
 
                      If TeniaOro <> UserList(UserIndex).Stats.GLD Then
                              WriteConsoleMsg UserIndex, "Le has vendido al " & Npclist(tNpc).name & " " & Amount & " - " & ObjData(tmpIndex).name, FontTypeNames.FONTTYPE_CITIZEN
                      End If
 
              Else
                      WriteConsoleMsg UserIndex, "El npc no está interesado en comprar este tipo de objetos.", FontTypeNames.FONTTYPE_CITIZEN
              End If
      End If
 
      Exit Sub
 
errHandler:
 
End Sub
 
Public Sub DragToPos(ByVal UserIndex As Integer, _
                    ByVal X As Byte, _
                    ByVal Y As Byte, _
                    ByVal Slot As Byte, _
                    ByVal Amount As Integer)
 
      ' @ Author : maTih.-
        '            Drag un slot a una posición.
 
      Dim errorFound As String
      Dim tObj      As Obj
      Dim tString    As String
 
      'No puede dragear en esa pos?
 
        If Not CanDragToPos(UserList(UserIndex).Pos.Map, X, Y, errorFound) Then
                WriteConsoleMsg UserIndex, errorFound, FontTypeNames.FONTTYPE_CITIZEN
 
                Exit Sub
 
        End If
 
        'Creo el objeto.
      tObj.objIndex = UserList(UserIndex).Invent.Object(Slot).objIndex
      tObj.Amount = Amount
 
      'Agrego el objeto a la posición.
        MakeObj tObj, UserList(UserIndex).Pos.Map, CInt(X), CInt(Y)
 
        'Quito el objeto.
      QuitarUserInvItem UserIndex, Slot, Amount
 
      'Actualizo el inventario
        UpdateUserInv False, UserIndex, Slot
 
        'Preparo el mensaje.
      tString = "Has arrojado "
 
      If tObj.Amount <> 1 Then
              tString = tString & tObj.Amount & " - " & ObjData(tObj.objIndex).name
      Else
              tString = tString & "tu " & ObjData(tObj.objIndex).name 'faltaba el tstring &
        End If
 
        'ENvio.
      WriteConsoleMsg UserIndex, tString, FontTypeNames.FONTTYPE_CITIZEN
 
End Sub
 
Private Function CanDragToPos(ByVal Map As Integer, _
                            ByVal X As Byte, _
                            ByVal Y As Byte, _
                            ByRef Error As String) As Boolean
 
      ' @ Author : maTih.-
        '            Devuelve si se puede dragear un item a x posición.
 
      CanDragToPos = False
 
      'Zona segura?
 
        If Not MapInfo(Map).Pk Then
                Error = "No está permitido arrojar objetos al suelo en zonas seguras."
 
                Exit Function
 
        End If
 
        'Ya hay objeto?
 
      If Not MapData(Map, X, Y).ObjInfo.objIndex = 0 Then
              Error = "Hay un objeto en esa posición!"
 
              Exit Function
 
      End If
 
      'Tile bloqueado?
 
        If Not MapData(Map, X, Y).Blocked = 0 Then
                Error = "No puedes arrojar objetos en esa posición"
 
                Exit Function
 
        End If
     
        If HayAgua(Map, X, Y) Then
                Error = "No puedes arrojar objetos al agua"
             
                Exit Function
 
        End If
 
        CanDragToPos = True
 
End Function
 
Private Function CanDragObj(ByVal objIndex As Integer, _
                            ByVal Navegando As Boolean, _
                            ByRef Error As String) As Boolean
 
        ' @ Author : maTih.-
      '            Devuelve si un objeto es drageable.
        CanDragObj = False
 
        If objIndex < 1 Or objIndex > UBound(ObjData()) Then Exit Function
 
        'Objeto newbie?
 
      If ObjData(objIndex).Newbie <> 0 Then
              Error = "No puedes arrojar objetos newbies!"
 
              Exit Function
 
      End If
 
      'Está navgeando?
 
        If Navegando Then
                Error = "No puedes arrojar un barco si estás navegando!"
 
                Exit Function
 
        End If
 
        CanDragObj = True
 
End Function
 
Public Sub HandleDragInventory(ByVal UserIndex As Integer)
 
        ' @ Author : Amraphen.
      '            Drag&Drop de objetos en el inventario.
 
        Dim ObjSlot1  As Byte
        Dim ObjSlot2  As Byte
 
        Dim tmpUserObj As UserObj
 
        If UserList(UserIndex).incomingData.Length < 3 Then
                Err.Raise UserList(UserIndex).incomingData.NotEnoughDataErrCode
 
                Exit Sub
 
        End If
 
        With UserList(UserIndex)
     
                'Leemos el paquete
              Call .incomingData.ReadByte
   
              ObjSlot1 = .incomingData.ReadByte
              ObjSlot2 = .incomingData.ReadByte
   
              'Cambiamos si alguno es un anillo
 
                If .Invent.AnilloEqpSlot = ObjSlot1 Then
                        .Invent.AnilloEqpSlot = ObjSlot2
                ElseIf .Invent.AnilloEqpSlot = ObjSlot2 Then
                        .Invent.AnilloEqpSlot = ObjSlot1
                End If
     
                'Cambiamos si alguno es un armor
 
              If .Invent.ArmourEqpSlot = ObjSlot1 Then
                      .Invent.ArmourEqpSlot = ObjSlot2
              ElseIf .Invent.ArmourEqpSlot = ObjSlot2 Then
                      .Invent.ArmourEqpSlot = ObjSlot1
              End If
   
              'Cambiamos si alguno es un barco
 
                If .Invent.BarcoSlot = ObjSlot1 Then
                        .Invent.BarcoSlot = ObjSlot2
                ElseIf .Invent.BarcoSlot = ObjSlot2 Then
                        .Invent.BarcoSlot = ObjSlot1
                End If
     
                'Cambiamos si alguno es un casco
 
              If .Invent.CascoEqpSlot = ObjSlot1 Then
                      .Invent.CascoEqpSlot = ObjSlot2
              ElseIf .Invent.CascoEqpSlot = ObjSlot2 Then
                      .Invent.CascoEqpSlot = ObjSlot1
              End If
   
              'Cambiamos si alguno es un escudo
 
                If .Invent.EscudoEqpSlot = ObjSlot1 Then
                        .Invent.EscudoEqpSlot = ObjSlot2
                ElseIf .Invent.EscudoEqpSlot = ObjSlot2 Then
                        .Invent.EscudoEqpSlot = ObjSlot1
                End If
     
                'Cambiamos si alguno es munición
 
              If .Invent.MunicionEqpSlot = ObjSlot1 Then
                      .Invent.MunicionEqpSlot = ObjSlot2
              ElseIf .Invent.MunicionEqpSlot = ObjSlot2 Then
                      .Invent.MunicionEqpSlot = ObjSlot1
              End If
   
              'Cambiamos si alguno es un arma
 
                If .Invent.WeaponEqpSlot = ObjSlot1 Then
                        .Invent.WeaponEqpSlot = ObjSlot2
                ElseIf .Invent.WeaponEqpSlot = ObjSlot2 Then
                        .Invent.WeaponEqpSlot = ObjSlot1
                End If
     
                'Hacemos el intercambio propiamente dicho
              tmpUserObj = .Invent.Object(ObjSlot1)
              .Invent.Object(ObjSlot1) = .Invent.Object(ObjSlot2)
              .Invent.Object(ObjSlot2) = tmpUserObj
 
              'Actualizamos los 2 slots que cambiamos solamente
                Call UpdateUserInv(False, UserIndex, ObjSlot1)
                Call UpdateUserInv(False, UserIndex, ObjSlot2)
        End With
 
End Sub
 
Public Sub HandleDragToPos(ByVal UserIndex As Integer)
 
        ' @ Author : maTih.-
      '            Drag&Drop de objetos en del inventario a una posición.
 
        Dim X      As Byte
        Dim Y      As Byte
        Dim Slot  As Byte
        Dim Amount As Integer
        Dim tUser  As Integer
        Dim tNpc  As Integer
 
        Call UserList(UserIndex).incomingData.ReadByte
 
        X = UserList(UserIndex).incomingData.ReadByte()
        Y = UserList(UserIndex).incomingData.ReadByte()
        Slot = UserList(UserIndex).incomingData.ReadByte()
        Amount = UserList(UserIndex).incomingData.ReadInteger()
 
        'tUser = MapData(UserList(userIndex).Pos.Map, X, Y).userIndex
      tNpc = MapData(UserList(UserIndex).Pos.Map, X, Y).NpcIndex
     
      If MapData(UserList(UserIndex).Pos.Map, X, Y).NpcIndex <> 0 Then
              Mod_DragAndDrop.DragToNPC UserIndex, tNpc, Slot, Amount
      Else
     
              Mod_DragAndDrop.DragToPos UserIndex, X, Y, Slot, Amount
      End If
 
End Sub
 

buscan

Código:
Case ClientPacketID.Consultation
            Call HandleConsultation(UserIndex)
abajo

Código:
                Case ClientPacketID.DragInventario          'DINVENT
                      Call Mod_DragAndDrop.HandleDragInventory(UserIndex)
         
              Case ClientPacketID.DragToPos              'DTOPOS
                        Call Mod_DragAndDrop.HandleDragToPos(UserIndex)
buscamos en los paquetes

Código:
StopSharingNpc
abajo

Código:
 DragToPos
        DragInventario
remplazar los clsSurfaceManDyn y clsSurfaceManStatic

por estos

clsSurfaceManStatic:
Código:
'**************************************************************
' clsSurfaceManStatic.cls - Inherits from clsSurfaceManager. Is designed to load
' surfaces at startup, and never deallocating them.
' This grants high performance can use a lot of RAM.
'
' Developed by Maraxus (Juan Martín Sotuyo Dodero - juansotuyo@hotmail.com)
' Last Modify Date: 3/06/2006
'**************************************************************
 
'**************************************************************
'This program is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published by
'the Free Software Foundation; either version 2 of the License, or
'any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'Affero General Public License for more details.
'
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
'
'Argentum Online is based on Baronsoft's VB6 Online RPG
'You can contact the original creator of ORE at aaron@baronsoft.com
'for more information about ORE please visit http://www.baronsoft.com/
'**************************************************************
 
Option Explicit
 
'Inherit from the surface manager
Implements clsSurfaceManager
 
'Size to which we resize the list when we start loading textures to prevent ReDim Preserve on each add
'Once done the list is trimmed to the proper size if it's larger than needed.
'A ReDim Preserve is executed for each surface after DEFAULT_LIST_SIZE + 1
Private Const DEFAULT_LIST_SIZE As Integer = 1500
 
Private Type SURFACE_ENTRY_STATIC
  fileIndex As Long
  Surface As DirectDrawSurface7
End Type
 
Private surfaceList() As SURFACE_ENTRY_STATIC
Private surfaceCount As Long
 
Private DirectDraw As DirectDraw7
 
Private useVideoMemory As Boolean
 
Private Sub Class_Initialize()
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'
'**************************************************************
    surfaceCount = 0
    ReDim surfaceList(0) As SURFACE_ENTRY_STATIC
End Sub
 
Private Sub Class_Terminate()
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Clean up
'**************************************************************
  Dim i  As Long
 
  'Destroy every surface in memory
    For i = 0 To surfaceCount - 1
        Set surfaceList(i).Surface = Nothing
    Next i
 
    'Destroy the array
  Erase surfaceList
End Sub
 
Private Sub clsSurfaceManager_Initialize(ByRef DD As DirectDraw7, ByVal videoMemory As Boolean, ByVal graphicPath As String, Optional ByVal maxMemoryUsageInMb As Long = -1&)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'
'**************************************************************
    Set DirectDraw = DD
 
    useVideoMemory = videoMemory
 
    Call LoadSurfaces(graphicPath)
End Sub
 
Private Property Get clsSurfaceManager_Surface(ByVal fileIndex As Long) As DirectDrawSurface7
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Retrieves the requested texture
'**************************************************************
On Error GoTo ErrHandler:
  Dim index As Long
 
  ' Search the index on the list
    index = BinarySearch(fileIndex)
 
    'Return it
  Set clsSurfaceManager_Surface = surfaceList(index).Surface
Exit Property
 
ErrHandler:
  If index < 0 Then
      MsgBox "No se encuentra el archivo " & CStr(fileIndex) & ".bmp. Reinstale el juego, " _
              & "y si el problema persiste contactese con los adminsitradores", vbOKOnly Or vbCritical Or vbExclamation, "Error"
  Else
      MsgBox "Un error inesperado ocurrió a intentar cargar el archivo " & CStr(fileIndex) & ".bmp. & vbcrlf" _
              & "Error: " & CStr(Err.number), vbOKOnly Or vbCritical Or vbExclamation, "Error"
  End If
 
  End
End Property
 
Private Sub LoadSurfaces(ByVal GrhPath As String)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Loads all surfaces in random order and then sorts them
'**************************************************************
On Error Resume Next
    Dim FileName As String
    Dim surfaceIndex As Long
 
    'Set up the list at a standard value big enough to prevent using ReDim Preserve constantly (which is slow)
  ReDim surfaceList(DEFAULT_LIST_SIZE) As SURFACE_ENTRY_STATIC
 
  FileName = Dir$(GrhPath & "*.bmp", vbArchive)
 
  While FileName <> ""
      'Get the surface index (numeric part of the number) - NEVER use Val() here or the error won't be raised!!! - Don't use IsNumeric or hexa strings will be accepted
        surfaceIndex = CLng(Left$(FileName, Len(FileName) - 4))
     
        If Err.number = 13 Then
            'Type mysmatch - the name of the file isn't numneric, therefore it isn't a surface
          Err.Clear
      Else
          'Increase surface count and resize list if needed
            surfaceCount = surfaceCount + 1
            If surfaceCount > DEFAULT_LIST_SIZE + 1 Then
                ReDim Preserve surfaceList(surfaceCount - 1) As SURFACE_ENTRY_STATIC
            End If
         
            Call LoadSurface(GrhPath, surfaceIndex, surfaceCount - 1)
        End If
     
        'Get next .bmp file
      FileName = Dir$()
  Wend
 
  'Trim the list if needed
    If surfaceCount <> UBound(surfaceList) + 1 Then
        ReDim Preserve surfaceList(surfaceCount - 1) As SURFACE_ENTRY_STATIC
    End If
 
    'Sort the list
  Call SortSurfaces(0, surfaceCount - 1)
End Sub
 
Private Function BinarySearch(ByVal fileIndex As Long) As Long
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Returns the index of the surface in the list, or the negation
'of the position were it should be if not found (for binary insertion)
'**************************************************************
  Dim min As Long
  Dim max As Long
  Dim mid As Long
 
  min = 0
  max = surfaceCount - 1
 
  Do While min <= max
      mid = (min + max) \ 2
     
      If surfaceList(mid).fileIndex < fileIndex Then
          min = mid + 1
      ElseIf surfaceList(mid).fileIndex > fileIndex Then
          max = mid - 1
      Else
          'We found it
            BinarySearch = mid
            Exit Function
        End If
    Loop
 
    'Not found, return the negation of the position where it should be
  '(all higher values are to the right of the list and lower values are to the left)
    BinarySearch = Not min
End Function
 
Private Sub LoadSurface(ByVal GrhPath As String, ByVal fileIndex As Long, ByVal listIndex As Long)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Loads the surface named fileIndex + ".bmp" and inserts it to the
'surface list in the listIndex position
'**************************************************************
On Error GoTo ErrHandler
 
    Dim newSurface As SURFACE_ENTRY_STATIC
    Dim ddsd As DDSURFACEDESC2
    Dim ddck As DDCOLORKEY
    Dim filePath As String
 
    'Store complete file path
  filePath = GrhPath & CStr(fileIndex) & ".bmp"
 
  'Set up the surface desc
    ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
 
    If useVideoMemory Then
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    Else
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
    End If
 
    Call surfaceDimensions(filePath, ddsd.lHeight, ddsd.lWidth)
 
    With newSurface
        .fileIndex = fileIndex
     
        'Load surface
      Set .Surface = DirectDraw.CreateSurfaceFromFile(filePath, ddsd)
     
      'Set colorkey
        ddck.high = 0
        ddck.low = 0
        Call .Surface.SetColorKey(DDCKEY_SRCBLT, ddck)
    End With
 
    'Store the surface in the given index (it MUST be empty or data will be lost)
  surfaceList(listIndex) = newSurface
Exit Sub
 
ErrHandler:
  MsgBox "Un error inesperado ocurrió al intentar cargar el gráfico " & filePath & ". " & vbCrLf & _
          "El código de error es " & CStr(Err.number) & " - " & Err.Description & vbCrLf & "Copia este mensaje y notifica a los administradores.", _
          vbOKOnly Or vbCritical Or vbExclamation, "Error"
      End
End Sub
 
Private Sub surfaceDimensions(ByVal Archivo As String, ByRef Height As Long, ByRef Width As Long)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Loads the headers of a bmp file to retrieve it's dimensions at rt
'**************************************************************
  Dim handle As Integer
  Dim bmpFileHead As BITMAPFILEHEADER
  Dim bmpInfoHead As BITMAPINFOHEADER
 
  handle = FreeFile()
  Open Archivo For Binary Access Read Lock Write As handle
      Get handle, , bmpFileHead
      Get handle, , bmpInfoHead
  Close handle
 
  Height = bmpInfoHead.biHeight
  Width = bmpInfoHead.biWidth
End Sub
 
Private Sub SortSurfaces(ByVal first As Integer, ByVal last As Integer)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 5/04/2005
'Sorts the list using quicksort, this allows the use of BinarySearch for faster searches
'**************************************************************
    Dim min As Integer      'First item in the list
  Dim max As Integer      'Last item in the list
    Dim comp As Long        'Item used to compare
  Dim temp As SURFACE_ENTRY_STATIC
 
  min = first
  max = last
 
  comp = surfaceList((min + max) \ 2).fileIndex
 
  Do While min <= max
      Do While surfaceList(min).fileIndex < comp And min < last
          min = min + 1
      Loop
      Do While surfaceList(max).fileIndex > comp And max > first
          max = max - 1
      Loop
      If min <= max Then
          temp = surfaceList(min)
          surfaceList(min) = surfaceList(max)
          surfaceList(max) = temp
          min = min + 1
          max = max - 1
      End If
  Loop
 
  If first < max Then SortSurfaces first, max
  If min < last Then SortSurfaces min, last
End Sub
 

clsSurfaceManDyn:
Código:
'**************************************************************
' clsSurfaceManDyn.cls - Inherits from clsSurfaceManager. Is designed to load
'surfaces dynamically without using more than an arbitrary amount of Mb.
'For removale it uses LRU, attempting to just keep in memory those surfaces
'that are actually usefull.
'
' Developed by Maraxus (Juan Martín Sotuyo Dodero - juansotuyo@hotmail.com)
' Last Modify Date: 3/06/2006
'**************************************************************
 
'**************************************************************
'This program is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published by
'the Free Software Foundation; either version 2 of the License, or
'any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'Affero General Public License for more details.
'
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
'
'Argentum Online is based on Baronsoft's VB6 Online RPG
'You can contact the original creator of ORE at aaron@baronsoft.com
'for more information about ORE please visit http://www.baronsoft.com/
'**************************************************************
 
Option Explicit
 
'Inherit from the surface manager
Implements clsSurfaceManager
 
Private Const BYTES_PER_MB As Long = 1048576                        '1Mb = 1024 Kb = 1024 * 1024 bytes = 1048576 bytes
Private Const MIN_MEMORY_TO_USE As Long = 4 * BYTES_PER_MB          '4 Mb
Private Const DEFAULT_MEMORY_TO_USE As Long = 16 * BYTES_PER_MB    '16 Mb
 
Private Type SURFACE_ENTRY_DYN
  fileIndex As Long
  lastAccess As Long
  Surface As DirectDrawSurface7
End Type
 
Private surfaceList() As SURFACE_ENTRY_DYN
Private surfaceCount As Long
 
Private surfaceIndexes() As Long
Private surfaceIndexCount As Long
 
Private DirectDraw As DirectDraw7
 
Private maxBytesToUse As Long
Private usedBytes As Long
 
Private useVideoMemory As Boolean
 
Private GrhPath As String
 
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef dest As Any, ByRef source As Any, ByVal byteCount As Long)
 
Private Sub Class_Initialize()
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'
'**************************************************************
    usedBytes = 0
    surfaceCount = 0
    surfaceIndexCount = 0
    ReDim surfaceList(0) As SURFACE_ENTRY_DYN
    ReDim surfaceIndexes(0) As Long
    maxBytesToUse = MIN_MEMORY_TO_USE
End Sub
 
Private Sub Class_Terminate()
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Clean up
'**************************************************************
  Dim i  As Long
 
  'Destroy every surface in memory
    For i = 0 To surfaceCount - 1
        Set surfaceList(i).Surface = Nothing
    Next i
 
    'Destroy the arrays
  Erase surfaceList
  Erase surfaceIndexes
End Sub
 
Private Sub clsSurfaceManager_Initialize(ByRef DD As DirectDraw7, ByVal videoMemory As Boolean, ByVal graphicPath As String, Optional ByVal maxMemoryUsageInMb As Long = -1)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Initializes the manager
'**************************************************************
    Set DirectDraw = DD
 
    useVideoMemory = videoMemory
 
    GrhPath = graphicPath
 
    If maxMemoryUsageInMb = -1 Then
        maxBytesToUse = DEFAULT_MEMORY_TO_USE  ' 16 Mb by default
  ElseIf maxMemoryUsageInMb * BYTES_PER_MB < MIN_MEMORY_TO_USE Then
      maxBytesToUse = MIN_MEMORY_TO_USE      ' 4 Mb is the minimum allowed
    Else
        maxBytesToUse = maxMemoryUsageInMb * BYTES_PER_MB
    End If
End Sub
 
Private Property Get clsSurfaceManager_Surface(ByVal fileIndex As Long) As DirectDrawSurface7
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Retrieves the requested texture
'**************************************************************
  Dim index As Long
 
  ' Search the index on the list
    index = BinarySearch(fileIndex)
 
    If index < 0 Then
        'Not found, we have to load the file and add it in the position given by the negation of the index
      '(it may be changed by the removal of indexes though, so we let the LoadSurface method notify us)
        index = LoadSurface(fileIndex, Not index)
    End If
 
    'Return it
  With surfaceList(surfaceIndexes(index))
      .lastAccess = GetTickCount
      Set clsSurfaceManager_Surface = .Surface
  End With
End Property
 
Private Function BinarySearch(ByVal fileIndex As Long) As Long
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Returns the index of the surface in the list, or the negation
'of the position were it should be if not found (for binary insertion)
'**************************************************************
  Dim min As Long
  Dim max As Long
  Dim mid As Long
 
  min = 0
  max = surfaceIndexCount - 1
 
  Do While min <= max
      mid = (min + max) \ 2
     
      If surfaceList(surfaceIndexes(mid)).fileIndex < fileIndex Then
          min = mid + 1
      ElseIf surfaceList(surfaceIndexes(mid)).fileIndex > fileIndex Then
          max = mid - 1
      Else
          'We found it
            BinarySearch = mid
            Exit Function
        End If
    Loop
 
    'Not found, return the negation of the position where it should be
  '(all higher values are to the right of the list and lower values are to the left)
    BinarySearch = Not min
End Function
 
Private Function LoadSurface(ByVal fileIndex As Long, ByVal listIndex As Long) As Long
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Loads the surface named fileIndex + ".bmp" and inserts it to the
'surface list in the listIndex position
'**************************************************************
On Error GoTo ErrHandler
 
    Dim newSurface As SURFACE_ENTRY_DYN
    Dim ddsd As DDSURFACEDESC2
    Dim ddck As DDCOLORKEY
    Dim filePath As String
 
    'Store complete file path
  filePath = GrhPath & CStr(fileIndex) & ".bmp"
 
  'Set up the surface desc
    ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
 
    If useVideoMemory Then
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    Else
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
    End If
 
    Call surfaceDimensions(filePath, ddsd.lHeight, ddsd.lWidth)
 
    With newSurface
        .fileIndex = fileIndex
     
        'Set last access time (if we didn't we would reckon this texture as the one lru)
        .lastAccess = GetTickCount
     
        'Load surface
      Set .Surface = DirectDraw.CreateSurfaceFromFile(filePath, ddsd)
     
      'Set colorkey
        ddck.high = 0
        ddck.low = 0
        Call .Surface.SetColorKey(DDCKEY_SRCBLT, ddck)
     
        'Retrieve the updated surface desc
      Call .Surface.GetSurfaceDesc(ddsd)
  End With
 
  'Insert surface to the list at the given pos
    Call InsertSurface(newSurface, listIndex)
 
    'Update used bytes
  usedBytes = usedBytes + ddsd.lHeight * ddsd.lPitch
 
  Dim removedFile As Integer
  'Check if we have exceeded our allowed share of memory usage
    Do While usedBytes > maxBytesToUse And surfaceCount > 1
        'Remove a file
      removedFile = RemoveLRU
     
      'If no file could be removed we continue, if the file was previous to our surface we update the index
        If removedFile = 0 Then
            Exit Do
        ElseIf removedFile < listIndex Then
            listIndex = listIndex - 1
        End If
    Loop
 
    'Return the real index in wich it ended after removing any necessary files
  LoadSurface = listIndex
Exit Function
 
ErrHandler:
  If Err.number = DDERR_OUTOFMEMORY Or Err.number = DDERR_OUTOFVIDEOMEMORY Then
      If surfaceCount Then
          'Remove a surface and try again
            Call RemoveLRU
            Resume Next
        Else
            MsgBox "No hay memoria disponible! El programa abortará. Cierra algunos programas e intenta de nuevo"
            End
        End If
    Else
        MsgBox "Un error inesperado ocurrió al intentar cargar el gráfico " & filePath & ". " & vbCrLf & _
                "El código de error es " & CStr(Err.number) & " - " & Err.Description & vbCrLf & "Copia este mensaje y notifica a los administradores.", _
                vbOKOnly Or vbCritical Or vbExclamation, "Error"
        End
    End If
End Function
 
Private Sub surfaceDimensions(ByVal Archivo As String, ByRef Height As Long, ByRef Width As Long)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Loads the headers of a bmp file to retrieve it's dimensions at rt
'**************************************************************
    Dim handle As Integer
    Dim bmpFileHead As BITMAPFILEHEADER
    Dim bmpInfoHead As BITMAPINFOHEADER
 
    handle = FreeFile()
    Open Archivo For Binary Access Read Lock Write As handle
        Get handle, , bmpFileHead
        Get handle, , bmpInfoHead
    Close handle
 
    Height = bmpInfoHead.biHeight
    Width = bmpInfoHead.biWidth
End Sub
 
Private Sub InsertSurface(ByRef Surface As SURFACE_ENTRY_DYN, ByVal listIndex As Long)
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Inserts the given surface in the requested position of the surface list
'**************************************************************
On Error GoTo ErrHandler
  Dim i As Long
 
  'Search for an empty spot in the list
    For i = 0 To surfaceCount - 1
        If surfaceList(i).Surface Is Nothing Then Exit For
    Next i
 
    'Enlarge the list if no empty spot was found
  If i = surfaceCount Then
      ReDim Preserve surfaceList(surfaceCount) As SURFACE_ENTRY_DYN
     
      'Increase surface count
        surfaceCount = surfaceCount + 1
    End If
 
    'Insert the new surface
  surfaceList(i) = Surface
 
  'Resize the list
    ReDim Preserve surfaceIndexes(surfaceIndexCount) As Long
 
    'Update the index list
  If surfaceIndexCount > listIndex Then
      'Move back the list - Copying this way is up to 6 times faster than a For
        Dim tempList() As Long
        ReDim tempList(surfaceIndexCount - listIndex) As Long
     
        CopyMemory tempList(0), surfaceIndexes(listIndex), (surfaceIndexCount - listIndex) * 4
        surfaceIndexes(listIndex) = i
        CopyMemory surfaceIndexes(listIndex + 1), tempList(0), (surfaceIndexCount - listIndex) * 4
    Else
        'We are inserting at the bottom of the list
      surfaceIndexes(listIndex) = i
  End If
 
  surfaceIndexCount = surfaceIndexCount + 1
Exit Sub
 
ErrHandler:
  MsgBox "Un error irreparable ocurrió al insertar un nuevo gráfico en la lista." & vbCrLf _
          & "El cliente se cerrará" & vbCrLf _
          & "Intente usar el cliente no dinámico"
  End
End Sub
 
Private Function RemoveLRU() As Integer
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 3/06/2006
'Removes the Least Recently Used surface to make some room for new ones
'**************************************************************
    Dim LRU As Long
    Dim i As Long
    Dim ddsd As DDSURFACEDESC2
 
    'Should never happen, but just in case....
  If surfaceCount = 0 Then Exit Function
 
  'Initialize with the first element of the list
    LRU = 0
 
    'Check out through the whole list for the least recently used
  For i = 1 To surfaceIndexCount - 1
      If surfaceList(surfaceIndexes(LRU)).lastAccess > surfaceList(surfaceIndexes(i)).lastAccess Then
          LRU = i
      End If
  Next i
 
  'Store the index of the surface removed
    RemoveLRU = LRU
 
    'Retrieve the surface desc
  Call surfaceList(surfaceIndexes(LRU)).Surface.GetSurfaceDesc(ddsd)
 
  'Remove it
    Set surfaceList(surfaceIndexes(LRU)).Surface = Nothing
    surfaceList(surfaceIndexes(LRU)).fileIndex = 0
 
    'Move back the list (if necessary)
  If LRU < surfaceIndexCount - 1 Then
      CopyMemory surfaceIndexes(LRU), surfaceIndexes(LRU + 1), (surfaceIndexCount - LRU - 1) * 4
  End If
 
  'Resize the list
    ReDim Preserve surfaceIndexes(surfaceIndexCount - 1) As Long
 
    'Decrease index count
  surfaceIndexCount = surfaceIndexCount - 1
 
  'Update the used bytes
    usedBytes = usedBytes - ddsd.lHeight * ddsd.lPitch
End Function
 

Fuente:
Gs-zone
Shermie80
Shermie80



CoverAOStaff
Aportes : 55
Mensajes : 139
Puntos : 822
Edad : 22

Ver perfil de usuario http://todo-argentum.foroargentina.net

Volver arriba Ir abajo

Volver arriba


 
Permisos de este foro:
No puedes responder a temas en este foro.