[ APORTE ] Drag&Drop (Dx7)

por Shermie80 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: