[Aporte] Carga de recursos de ImperiumAO - Dx8 (Parte1)

Cliente: (Comenzaremos con los Graficos)

Buscamos:

Código:

Private Sub LoadGrhData()

o similar

Y todo el sub lo reemplazamos por:

Código:

Public Sub LoadGrhData()
'*****************************************************************
'Loads Grh.dat
'*****************************************************************
 
On Error GoTo ErrorHandler
 
Dim Grh As Integer
Dim Frame As Integer
Dim tempInt As Integer
Dim F As Integer
 
ReDim GrhData(0 To 40000) As GrhData
 
F = FreeFile()
Open App.path & "\Init\Graficos.ind" For Binary Access Read As #F
 
    Seek #F, 1
 
    Get #F, , tempInt
    Get #F, , tempInt
    Get #F, , tempInt
    Get #F, , tempInt
    Get #F, , tempInt
 
    'Get first Grh Number
    Get #F, , Grh
 
    Do Until Grh <= 0
        'Get number of frames
        Get #F, , GrhData(Grh).NumFrames
     
        If GrhData(Grh).NumFrames <= 0 Then
            GoTo ErrorHandler
        End If
     
        ReDim GrhData(Grh).Frames(1 To GrhData(Grh).NumFrames)
     
        If GrhData(Grh).NumFrames > 1 Then
     
            'Read a animation GRH set
            For Frame = 1 To GrhData(Grh).NumFrames
                Get #F, , GrhData(Grh).Frames(Frame)
                If GrhData(Grh).Frames(Frame) <= 0 Or GrhData(Grh).Frames(Frame) > 40000 Then GoTo ErrorHandler
            Next Frame
     
            Get #F, , tempInt
         
            If tempInt <= 0 Then GoTo ErrorHandler
            GrhData(Grh).speed = CSng(tempInt)
         
            'Compute width and height
            GrhData(Grh).pixelHeight = GrhData(GrhData(Grh).Frames(1)).pixelHeight
            If GrhData(Grh).pixelHeight <= 0 Then GoTo ErrorHandler
         
            GrhData(Grh).pixelWidth = GrhData(GrhData(Grh).Frames(1)).pixelWidth
            If GrhData(Grh).pixelWidth <= 0 Then GoTo ErrorHandler
 
            GrhData(Grh).TileWidth = GrhData(GrhData(Grh).Frames(1)).TileWidth
            If GrhData(Grh).TileWidth <= 0 Then GoTo ErrorHandler
 
            GrhData(Grh).TileHeight = GrhData(GrhData(Grh).Frames(1)).TileHeight
            If GrhData(Grh).TileHeight <= 0 Then GoTo ErrorHandler
        Else
            'Read in normal GRH data
            Get #F, , GrhData(Grh).FileNum
            If GrhData(Grh).FileNum <= 0 Then GoTo ErrorHandler
 
            Get #F, , GrhData(Grh).sX
            If GrhData(Grh).sX < 0 Then GoTo ErrorHandler
         
            Get #F, , GrhData(Grh).sY
            If GrhData(Grh).sY < 0 Then GoTo ErrorHandler
 
            Get #F, , GrhData(Grh).pixelWidth
            If GrhData(Grh).pixelWidth <= 0 Then GoTo ErrorHandler
 
            Get #F, , GrhData(Grh).pixelHeight
            If GrhData(Grh).pixelHeight <= 0 Then GoTo ErrorHandler
 
            'Compute width and height
            GrhData(Grh).TileWidth = GrhData(Grh).pixelWidth / 32
            GrhData(Grh).TileHeight = GrhData(Grh).pixelHeight / 32
         
            GrhData(Grh).Frames(1) = Grh
        End If
        'Get Next Grh Number
        Get #F, , Grh
    Loop
 
Close #F
Exit Sub
 
ErrorHandler:
    Close #1
    MsgBox "Error al cargar el recurso de índice de gráficos: " & Err.Description & " (" & Grh & ")", vbCritical, "Error al cargar"
    prgRun = False
 
End Sub

Ahora buscamos:

Código:

Public Type GrhData

Y lo reemplazamos todo por:

Código:

Public Type GrhData
    sX As Integer
    sY As Integer
 
    FileNum As Integer
 
    pixelWidth As Integer
    pixelHeight As Integer
 
    TileWidth As Single
    TileHeight As Single
 
    NumFrames As Integer
    Frames() As Integer
 
    speed As Single
End Type

Ahora buscamos:

Código:

Public Type Grh

Y lo reemplazamos por:

Código:

Public Type Grh
    grhindex As Integer
    FrameCounter As Single
    speed As Single
    Started As Byte
    Loops As Integer
End Type

Ahora Buscamos

Código:

Private Sub DDrawGrhtoSurface(ByRef Grh As Grh, ByVal X As Integer, ByVal Y As Integer, ByVal Center As Byte, ByVal Animate As Byte)

Y lo reemplazamos todo por:

Código:

Private Sub DDrawGrhtoSurface(ByRef Grh As Grh, ByVal X As Integer, ByVal Y As Integer, ByVal Center As Byte, ByVal Animate As Byte)
On Error Resume Next
Dim CurrentGrhIndex As Integer
Dim SourceRect As RECT
 
    If Grh.grhindex = 0 Then Exit Sub
    If GrhData(Grh.grhindex).NumFrames = 0 Then Exit Sub
 
    If Animate Then
        If Grh.Started = 1 Then
            Grh.FrameCounter = Grh.FrameCounter + (timerTicksPerFrame * Grh.speed)
            If Grh.FrameCounter > GrhData(Grh.grhindex).NumFrames Then
                Grh.FrameCounter = (Grh.FrameCounter Mod GrhData(Grh.grhindex).NumFrames) + 1
             
                If Grh.Loops <> INFINITE_LOOPS Then
                    If Grh.Loops > 0 Then
                        Grh.Loops = Grh.Loops - 1
                    Else
                        Grh.Started = 0
                    End If
                End If
            End If
        End If
    End If
 
    'Figure out what frame to draw (always 1 if not animated)
    CurrentGrhIndex = GrhData(Grh.grhindex).Frames(Grh.FrameCounter)
 
    With GrhData(CurrentGrhIndex)
        'Center Grh over X,Y pos
        If Center Then
            If .TileWidth <> 1 Then
                X = X - Int(.TileWidth * TilePixelWidth / 2) + TilePixelWidth \ 2
            End If
         
            If .TileHeight <> 1 Then
                Y = Y - Int(.TileHeight * TilePixelHeight) + TilePixelHeight
            End If
        End If
     
        SourceRect.Left = .sX
        SourceRect.Top = .sY
        SourceRect.Right = SourceRect.Left + .pixelWidth
        SourceRect.bottom = SourceRect.Top + .pixelHeight
     
        'Draw
        Call Device_Textured_Render(X, Y, SurfaceDB.Surface(.FileNum), SourceRect)
    End With
Exit Sub
End Sub

Ahora buscamos:

Código:

Sub DDrawTransGrhtoSurface(ByRef Grh As Grh, ByVal X As Integer, ByVal Y As Integer, ByVal Center As Byte, ByVal Animate As Byte)

Y Reemplazamos todo por:

Código:

Sub DDrawTransGrhtoSurface(ByRef Grh As Grh, ByVal X As Integer, ByVal Y As Integer, ByVal Center As Byte, ByVal Animate As Byte, Optional ByVal Alpha As Boolean = False)
'*****************************************************************
'Draws a GRH transparently to a X and Y position
'*****************************************************************
On Error Resume Next
Dim CurrentGrhIndex As Integer
Dim SourceRect As RECT
 
    If Animate Then
        If Grh.Started = 1 Then
            Grh.FrameCounter = Grh.FrameCounter + (timerTicksPerFrame * Grh.speed)
            If Grh.FrameCounter > GrhData(Grh.grhindex).NumFrames Then
                Grh.FrameCounter = (Grh.FrameCounter Mod GrhData(Grh.grhindex).NumFrames) + 1
             
                If Grh.Loops <> INFINITE_LOOPS Then
                    If Grh.Loops > 0 Then
                        Grh.Loops = Grh.Loops - 1
                    Else
                        Grh.Started = 0
                    End If
                End If
            End If
        End If
    End If
 
    'Figure out what frame to draw (always 1 if not animated)
    CurrentGrhIndex = GrhData(Grh.grhindex).Frames(Grh.FrameCounter)
 
    With GrhData(CurrentGrhIndex)
        'Center Grh over X,Y pos
        If Center Then
            If .TileWidth <> 1 Then
                X = X - Int(.TileWidth * TilePixelWidth / 2) + TilePixelWidth \ 2
            End If
         
            If .TileHeight <> 1 Then
                Y = Y - Int(.TileHeight * TilePixelHeight) + TilePixelHeight
            End If
        End If
             
        SourceRect.Left = .sX
        SourceRect.Top = .sY
        SourceRect.Right = SourceRect.Left + .pixelWidth
        SourceRect.bottom = SourceRect.Top + .pixelHeight
     
        'Draw
        'Call BackBufferSurface.BltFast(X, Y, SurfaceDB.Surface(.FileNum), SourceRect, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT)
        Call Device_Textured_Render(X, Y, SurfaceDB.Surface(.FileNum), SourceRect, Alpha)
    End With
Exit Sub
End Sub

Ahora buscamos:

Código:

Call DDrawTransGrhtoSurface(.fX, PixelOffsetX + FxData(.FxIndex).OffsetX, PixelOffsetY + FxData(.FxIndex).OffsetY, 1, 1)

Y lo reemplazamos por:

Código:

Call DDrawTransGrhtoSurface(.fX, PixelOffsetX + FxData(.FxIndex).OffsetX, PixelOffsetY + FxData(.FxIndex).OffsetY, 1, 1, True)

*** ATENCION ***
Ahora para evitar futuros errores hay que eliminar el sistema de lluvias:

Código:

Sub CargarArrayLluvia()
    Dim N As Integer
    Dim i As Long
    Dim Nu As Integer
 
    N = FreeFile()
    Open App.path & "\init\fk.ind" For Binary Access Read As #N
 
    'cabecera
    Get #N, , MiCabecera
 
    'num de cabezas
    Get #N, , Nu
 
    'Resize array
    ReDim bLluvia(1 To Nu) As Byte
 
    For i = 1 To Nu
        Get #N, , bLluvia(i)
    Next i
 
    Close #N
End Sub

Y también:

Código:

Call CargarArrayLluvia

Ahora buscamos:

Código:

Sub RenderScreen(ByVal tilex As Integer, ByVal tiley As Integer, ByVal PixelOffsetX As Integer, ByVal PixelOffsetY As Integer)

Y lo reemplazamos todo por:

Código:

Sub RenderScreen(ByVal tilex As Integer, ByVal tiley As Integer, ByVal PixelOffsetX As Integer, ByVal PixelOffsetY As Integer)
'**************************************************************
'Author: Aaron Perkins
'Last Modify Date: 8/14/2007
'Last modified by: Juan Martín Sotuyo Dodero (Maraxus)
'Renders everything to the viewport
'**************************************************************
    Dim Y          As Long    'Keeps track of where on map we are
    Dim X          As Long    'Keeps track of where on map we are
    Dim screenminY  As Integer  'Start Y pos on current screen
    Dim screenmaxY  As Integer  'End Y pos on current screen
    Dim screenminX  As Integer  'Start X pos on current screen
    Dim screenmaxX  As Integer  'End X pos on current screen
    Dim minY        As Integer  'Start Y pos on current map
    Dim maxY        As Integer  'End Y pos on current map
    Dim minX        As Integer  'Start X pos on current map
    Dim maxX        As Integer  'End X pos on current map
    Dim ScreenX    As Integer  'Keeps track of where to place tile on screen
    Dim ScreenY    As Integer  'Keeps track of where to place tile on screen
    Dim minXOffset  As Integer
    Dim minYOffset  As Integer
    Dim PixelOffsetXTemp As Integer 'For centering grhs
    Dim PixelOffsetYTemp As Integer 'For centering grhs
 
 
    'Figure out Ends and Starts of screen
    screenminY = tiley - HalfWindowTileHeight
    screenmaxY = tiley + HalfWindowTileHeight
    screenminX = tilex - HalfWindowTileWidth
    screenmaxX = tilex + HalfWindowTileWidth
 
    minY = screenminY - TileBufferSize
    maxY = screenmaxY + TileBufferSize
    minX = screenminX - TileBufferSize
    maxX = screenmaxX + TileBufferSize
 
    'Make sure mins and maxs are allways in map bounds
    If minY < XMinMapSize Then
        minYOffset = YMinMapSize - minY
        minY = YMinMapSize
    End If
 
    If maxY > YMaxMapSize Then maxY = YMaxMapSize
 
    If minX < XMinMapSize Then
        minXOffset = XMinMapSize - minX
        minX = XMinMapSize
    End If
 
    If maxX > XMaxMapSize Then maxX = XMaxMapSize
 
    'If we can, we render around the view area to make it smoother
    If screenminY > YMinMapSize Then
        screenminY = screenminY - 1
    Else
        screenminY = 1
        ScreenY = 1
    End If
 
    If screenmaxY < YMaxMapSize Then screenmaxY = screenmaxY + 1
 
    If screenminX > XMinMapSize Then
        screenminX = screenminX - 1
    Else
        screenminX = 1
        ScreenX = 1
    End If
 
    If screenmaxX < XMaxMapSize Then screenmaxX = screenmaxX + 1
 
    'Draw floor layer
    For Y = screenminY To screenmaxY
        For X = screenminX To screenmaxX
         
            'Layer 1 **********************************
            Call DDrawGrhtoSurface(MapData(X, Y).Graphic(1), _
                (ScreenX - 1) * TilePixelWidth + PixelOffsetX, _
                (ScreenY - 1) * TilePixelHeight + PixelOffsetY, _
                0, 1)
            '******************************************
         
            ScreenX = ScreenX + 1
        Next X
     
        'Reset ScreenX to original value and increment ScreenY
        ScreenX = ScreenX - X + screenminX
        ScreenY = ScreenY + 1
    Next Y
 
    'Draw floor layer 2
    ScreenY = minYOffset - TileBufferSize
    For Y = minY To maxY
        ScreenX = minXOffset - TileBufferSize
        For X = minX To maxX
         
            'Layer 2 **********************************
            If MapData(X, Y).Graphic(2).grhindex <> 0 Then
                Call DDrawTransGrhtoSurface(MapData(X, Y).Graphic(2), _
                        ScreenX * TilePixelWidth + PixelOffsetX, _
                        ScreenY * TilePixelHeight + PixelOffsetY, _
                        1, 1)
            End If
            '******************************************
         
            ScreenX = ScreenX + 1
        Next X
        ScreenY = ScreenY + 1
    Next Y
 
    'Draw Transparent Layers
    ScreenY = minYOffset - TileBufferSize
    For Y = minY To maxY
        ScreenX = minXOffset - TileBufferSize
        For X = minX To maxX
            PixelOffsetXTemp = ScreenX * TilePixelWidth + PixelOffsetX
            PixelOffsetYTemp = ScreenY * TilePixelHeight + PixelOffsetY
         
            With MapData(X, Y)
                'Object Layer **********************************
                If .ObjGrh.grhindex <> 0 Then
                    Call DDrawTransGrhtoSurface(.ObjGrh, _
                            PixelOffsetXTemp, PixelOffsetYTemp, 1, 1)
                End If
                '***********************************************
             
             
                'Char layer ************************************
                If .CharIndex <> 0 Then
                    Call CharRender(.CharIndex, PixelOffsetXTemp, PixelOffsetYTemp)
                End If
                '*************************************************
             
             
                'Layer 3 *****************************************
                If .Graphic(3).grhindex <> 0 Then
                    'Draw
                    Call DDrawTransGrhtoSurface(.Graphic(3), _
                            PixelOffsetXTemp, PixelOffsetYTemp, 1, 1)
                End If
                '************************************************
            End With
         
            ScreenX = ScreenX + 1
        Next X
        ScreenY = ScreenY + 1
    Next Y
 
    If Not bTecho Then
        'Draw blocked tiles and grid
        ScreenY = minYOffset - TileBufferSize
        For Y = minY To maxY
            ScreenX = minXOffset - TileBufferSize
            For X = minX To maxX
             
                'Layer 4 **********************************
                If MapData(X, Y).Graphic(4).grhindex Then
                    'Draw
                    Call DDrawTransGrhtoSurface(MapData(X, Y).Graphic(4), _
                        ScreenX * TilePixelWidth + PixelOffsetX, _
                        ScreenY * TilePixelHeight + PixelOffsetY, _
                        1, 1)
                End If
                '**********************************
             
                ScreenX = ScreenX + 1
            Next X
            ScreenY = ScreenY + 1
        Next Y
    End If
End Sub

Ahora buscamos:

Código:

Public Function RenderSounds()

Y lo borramos todo.
Ahora buscamos:

Código:

'Play ambient sounds
            Call RenderSounds

Y lo borramos.
Ahora buscamos:

Código:

Private Sub HandleRainToggle()

Y lo reemplazamos por:

Código:

Private Sub HandleRainToggle()
'***************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modification: 05/17/06
'
'***************************************************
    'Remove packet ID
    Call incomingData.ReadByte
 
    If Not InMapBounds(UserPos.X, UserPos.Y) Then Exit Sub
 
    bTecho = (MapData(UserPos.X, UserPos.Y).Trigger = 1 Or _
            MapData(UserPos.X, UserPos.Y).Trigger = 2 Or _
            MapData(UserPos.X, UserPos.Y).Trigger = 4)
 
    bRain = Not bRain
End Sub

Ahora buscamos:

Código:

Private Sub HandleChangeMap()

Y lo reemplazamos todo por:

Código:

Private Sub HandleChangeMap()
'***************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modification: 05/17/06
'
'***************************************************
    If incomingData.length < 5 Then
        Err.Raise incomingData.NotEnoughDataErrCode
        Exit Sub
    End If
 
    'Remove packet ID
    Call incomingData.ReadByte
 
    UserMap = incomingData.ReadInteger()
 
'TODO: Once on-the-fly editor is implemented check for map version before loading....
'For now we just drop it
    Call incomingData.ReadInteger
     
#If SeguridadAlkon Then
    Call InitMI
#End If
 
    If FileExist(DirMapas & "Mapa" & UserMap & ".csm", vbNormal) Then
        Call SwitchMap(UserMap)
    Else
        'no encontramos el mapa en el hd
        MsgBox "Error en los mapas, algún archivo ha sido modificado o esta dañado."
        Call CloseClient
    End If
End Sub

Me olviaba deven Implementar esto Primero Clic Aqui

E.E DLOBE POST!! va yo moderador 2014 ?) , muy bueno a los pajas que solo quieren implementar los graficos de 120 jaja xD buen aporte por separar todo muchas gracias.