** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Access y VBA
  Mensajes nuevos Mensajes nuevos RSS - Corrupcion BD desde pc
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoCorrupcion BD desde pc

 Responder Responder
Autor
Mensaje
arcangelcaos Ver desplegable
Asiduo
Asiduo
Avatar

Unido: 15/Noviembre/2012
Localización: España
Estado: Sin conexión
Puntos: 243
Enlace directo a este mensaje Tema: Corrupcion BD desde pc
    Enviado: 08/Mayo/2020 a las 11:26
Buenas a todos. Haber si me podéis echar una mano.

Esto este código en un programa ya hace meses, pero desde hace un par de semanas no para de bloquear el pc corromper la BD backend.
Lo que hace este código es tengo un subfor con datos de fincas, trabajos e importes, y otro subform con trabajadores, pues al darle al botón que ejecuta el código añade tantas líneas por trabajador como tareas haya y reparte el dinero en todos.


Fechabloqueo = DLookup("FechaBloqueo", "FechaBloqueo")

If Me.Fecha <= Fechabloqueo Then
    MsgBox "No se puede modificar el parte, esta bloqueado porque las nominas estan realizadas"
    Me.Form.Undo
    DoCmd.CancelEvent
    Exit Sub
End If


aux = Nz(Forms!F_PartesTrabajoPrin!F_PartesTrabajoSub!TotalImporte, 0)

    If aux > 0 Then
        MsgBox "Ya se ya repartido el parte, no se puede volver a repartir borre todos los trabajadores y vuelva a intentarlo", vbExclamation + vbOKOnly, "Imposible"
        DoCmd.CancelEvent
        Exit Sub
    End If

respuesta = MsgBox("Se va a proceder a repartir entre los trabajadores, ¿Estas seguro?", vbQuestion + vbYesNo, "REPARTIR")

If respuesta = vbYes Then
Dim RSTrabajadores As Recordset
Dim RSFincas As Recordset
Dim sql As String
Dim Importe1 As Double
Dim Cantidad1 As Double
Dim Precio1 As Double


Set db = CurrentDb ' selecciono todos los trabajadores
sql = "SELECT IdParteTrabajo, IdParteTrabajoPrin, IdTrabajador, IdTarea, IdEmpresaTrabajador FROM PartesTrabajoTrabajadores WHERE IdParteTrabajoPrin = " & Me.IdTarea & ""
Set RSTrabajadores = db.OpenRecordset(sql)
If RSTrabajadores.RecordCount > 0 Then
RSTrabajadores.MoveLast
CuentaTrabajadores = RSTrabajadores.RecordCount


sql = "SELECT Fecha, Finca, Fase, Semana, SemanaTraz, Articulo, Cantidad, Precio, Importe, Campaña, IdEmpresaFinca FROM PartesTrabajoSub WHERE IdTareaPrin = " & Me.IdTarea & ""
Set RSFincas = db.OpenRecordset(sql)
If RSFincas.RecordCount > 0 Then
RSFincas.MoveLast
CuentaFincas = RSFincas.RecordCount

RSFincas.MoveFirst ' hacemos el primer reparto, y si hay más, lo que se hara será añadir registros
    Importe1 = RSFincas![Importe] / CuentaTrabajadores
    Cantidad1 = RSFincas![Cantidad] / CuentaTrabajadores
    Precio1 = RSFincas![Precio]

        RSTrabajadores.MoveFirst
        Do While Not RSTrabajadores.EOF
            linea = RSTrabajadores![IdParteTrabajo]
            db.Execute "UPDATE PartesTrabajoTrabajadores SET [Precio] = '" & Precio1 & "', [Importe] = '" & Importe1 & "', [Cantidad] = '" & Cantidad1 & "', [Fecha] = #" & Format(RSFincas![Fecha], "yy/mm/dd") & "#, [IdTarea] = " & RSFincas![Articulo] & ", [IdFinca] =" & RSFincas![Finca] & ",[IdCampaña]= " & RSFincas![Campaña] & ",[IdFase]= " & Nz(RSFincas![Fase], 0) & ", [IdSemana] = " & Nz(RSFincas![Semana], 0) & ", [IdEmpresaSemana] = " & RSFincas![IdEmpresaFinca] & ", [IdSemanaTraza] = " & Nz(RSFincas![SemanaTraz], 0) & " WHERE [IdParteTrabajo] = " & linea & " "
            
            FechaFin = DateSerial(Year(Me.Fecha), Month(Me.Fecha) + 1, 1 - 1)
            Dim RSDeuda As Recordset
            FechaI = DateSerial(Year(Me.Fecha), Month(Me.Fecha), 1)
    
            Set db = CurrentDb
            sql = "SELECT IdDeuda, Trabajador, Fecha, IdFactura, IdEmpresa FROM Deudas" _
               & " WHERE Trabajador = " & RSTrabajadores![IdTrabajador] & " And IdFactura = " & 0 & " And Fecha = #" & Format(FechaFin, "yy/mm/dd") & "# AND IdEmpresa = " & RSTrabajadores![IdEmpresaTrabajador] & ""
            Set RSDeuda = db.OpenRecordset(sql)
       
            ImporteDeuda = Nz(DSum("Importe", "PartesTrabajoTrabajadores", "IdTrabajador = " & RSTrabajadores![IdTrabajador] & " AND IdEmpresaTrabajador = " & RSTrabajadores![IdEmpresaTrabajador] & " AND Fecha >= #" & Format(FechaI, "yy/mm/dd") & "# AND Fecha <= #" & Format(FechaFin, "yy/mm/dd") & " # "), 0)
            DoCmd.SetWarnings False
            If RSDeuda.RecordCount > 0 Then
               CurrentDb.Execute "UPDATE Deudas SET Importe = " & Replace(ImporteDeuda, ",", ".") & " WHERE IdFactura = " & 0 & " AND IdDeuda = " & RSDeuda![IdDeuda] & ""
            Else
               DoCmd.RunSQL "INSERT INTO Deudas (Trabajador, Concepto, Fecha, IdFactura, Importe, IdEmpresa) VALUES (" & RSTrabajadores![IdTrabajador] & ", '" & "Nomina de " & Format(FechaFin, "mmmm") & "' , #" & Format(FechaFin, "yy/mm/dd") & "#, " & 0 & ", " & Replace(ImporteDeuda, ",", ".") & ", " & RSTrabajadores![IdEmpresaTrabajador] & " )"
            End If
            
            DoCmd.SetWarnings True
                   
            RSTrabajadores.MoveNext
        Loop
    RSFincas.MoveNext

Do While Not RSFincas.EOF ' aqui si hay más fincas, se añadiran más registros
    Importe1 = RSFincas![Importe] / CuentaTrabajadores
    Cantidad1 = RSFincas![Cantidad] / CuentaTrabajadores
    Precio1 = RSFincas![Precio]

        RSTrabajadores.MoveFirst
        Do While Not RSTrabajadores.EOF
            DoCmd.SetWarnings False
            DoCmd.RunSQL "INSERT INTO PartesTrabajoTrabajadores (IdParteTrabajoPrin, IdTrabajador, IdEmpresaTrabajador) VALUES (" & Me.IdTarea & ", " & RSTrabajadores![IdTrabajador] & " , " & RSTrabajadores![IdEmpresaTrabajador] & " )"
            DoCmd.SetWarnings True
            linea = DMax("IdParteTrabajo", "PartesTrabajoTrabajadores")
            db.Execute "UPDATE PartesTrabajoTrabajadores SET [Precio] = '" & Precio1 & "', [Importe] = '" & Importe1 & "', [Cantidad] = '" & Cantidad1 & "', [Fecha] = #" & Format(RSFincas![Fecha], "yy/mm/dd") & "#, [IdTarea] = " & RSFincas![Articulo] & ", [IdFinca] =" & RSFincas![Finca] & ",[IdCampaña]= " & RSFincas![Campaña] & ",[IdFase]= " & Nz(RSFincas![Fase], 0) & ", [IdSemana] = " & Nz(RSFincas![Semana], 0) & ", [IdEmpresaSemana] = " & RSFincas![IdEmpresaFinca] & ", [IdSemanaTraza] = " & Nz(RSFincas![SemanaTraz], 0) & " WHERE [IdParteTrabajo] = " & linea & " "
            
            FechaFin = DateSerial(Year(Me.Fecha), Month(Me.Fecha) + 1, 1 - 1)
       
            FechaI = DateSerial(Year(Me.Fecha), Month(Me.Fecha), 1)
    
            Set db = CurrentDb
            sql = "SELECT IdDeuda, Trabajador, Fecha, IdFactura, IdEmpresa FROM Deudas" _
               & " WHERE Trabajador = " & RSTrabajadores![IdTrabajador] & " And IdFactura = " & 0 & " And Fecha = #" & Format(FechaFin, "yy/mm/dd") & "# AND IdEmpresa = " & RSTrabajadores![IdEmpresaTrabajador] & ""
            Set RSDeuda = db.OpenRecordset(sql)
       
            ImporteDeuda = Nz(DSum("Importe", "PartesTrabajoTrabajadores", "IdTrabajador = " & RSTrabajadores![IdTrabajador] & " AND IdEmpresaTrabajador = " & RSTrabajadores![IdEmpresaTrabajador] & " AND Fecha >= #" & Format(FechaI, "yy/mm/dd") & "# AND Fecha <= #" & Format(FechaFin, "yy/mm/dd") & " # "), 0)
            DoCmd.SetWarnings False
            If RSDeuda.RecordCount > 0 Then
               CurrentDb.Execute "UPDATE Deudas SET Importe = " & Replace(ImporteDeuda, ",", ".") & " WHERE IdFactura = " & 0 & " AND IdDeuda = " & RSDeuda![IdDeuda] & ""
            Else
               DoCmd.RunSQL "INSERT INTO Deudas (Trabajador, Concepto, Fecha, IdFactura, Importe, IdEmpresa) VALUES (" & RSTrabajadores![IdTrabajador] & ", '" & "Nomina de " & Format(FechaFin, "mmmm") & "' , #" & Format(FechaFin, "yy/mm/dd") & "#, " & 0 & ", " & Replace(ImporteDeuda, ",", ".") & ", " & RSTrabajadores![IdEmpresaTrabajador] & " )"
            End If
            
            DoCmd.SetWarnings True
                   
            RSTrabajadores.MoveNext
        Loop
    RSFincas.MoveNext
Loop
End If ' el de las fincas
End If ' el de los trabajadores
End If ' el de la respuesta
db.Close
Me.Refresh
Arriba
Dabellaso Ver desplegable
Asiduo
Asiduo


Unido: 18/Noviembre/2012
Localización: España
Estado: Sin conexión
Puntos: 232
Enlace directo a este mensaje Enviado: 08/Mayo/2020 a las 12:56
Hola
Hace poco, pitxiku solucionó un problema que me surgió debido a una mala declaración de una las variales. Antes de aplicar la solución que me propuso, en mi caso la Db también se bloqueaba, e incluso, a veces, bloqueaba Access. Tras aplicar su solución, demás de resolver mi problema, desaparecieron todos los demás, ni la db, ni Access se han vuelto a bloquear

Creo que quizás te pueda estar pasando lo mismo, sin entrar en el código que supongo funcionará, veo que no cierras los recordset que utilizas, ni liberas estableciendo ninguno de los objetos utilizados a Nothing.

Creo que al final, faltan cosas como:
RSTrabajadores.Close
Set RSTrabajadores =Nothing
RSFincas.Close
Set RSFincas =Nothing
Set db = Nothing

Prueba a hacerlo y nos cuentas a ver que tal.

Pd. También veo muchas variables normales sin declarar, no creo que sean la causa del problema, pero si me parece buena práctica declararlas (respuestaCuentaTrabajadores, CuentaFincas, ImporteDeuda,...  y bastantes más) 


Saludos




Editado por Dabellaso - 08/Mayo/2020 a las 13:06
El saber no ocupa lugar, sólo tiempo
Arriba
arcangelcaos Ver desplegable
Asiduo
Asiduo
Avatar

Unido: 15/Noviembre/2012
Localización: España
Estado: Sin conexión
Puntos: 243
Enlace directo a este mensaje Enviado: 08/Mayo/2020 a las 18:19
Hola, gracias, pero he probado con eso y no es
Además, ha estado casi 1 año funcionando bien, y lleva 2 semana que no. Va super lento, que de tardar 5 seg en calcular, tarda 6minutos, cronometrado, y muchas veces corrompe la bd de datos, no la de formularios.

La cosa es que en otro pc funciona bien, es solo en 2, en los otros 3 va bien.
He desinstalado office y vuelvo a instalar, y nada. Incluso es el mismo fichero, no es una copia, quizás sea alguna actualización de Windows, o alguna librería, ni idea.
Arriba
pitxiku Ver desplegable
Colaborador
Colaborador
Avatar

Unido: 27/Septiembre/2017
Localización: En mi casa
Estado: Sin conexión
Puntos: 1218
Enlace directo a este mensaje Enviado: 08/Mayo/2020 a las 19:56
A ver si esto que posteó el maestro Nekkito en su foto te sirve:

- https://nksvaccessolutions.com/Foro/viewtopic.php?f=7&t=1739
Arriba
javier.mil Ver desplegable
Colaborador
Colaborador
Avatar

Unido: 10/Agosto/2005
Localización: España
Estado: Sin conexión
Puntos: 4518
Enlace directo a este mensaje Enviado: 09/Mayo/2020 a las 10:23
Mas cosas .......

Cambia la declaración del recordset

Donde pone
Dim RSTrabajadores As Recordset
Dim RSFincas As Recordset
Dim RSDeuda As Recordset

Deberia poner
Dim RSTrabajadores As DAO.Recordset
Dim RSFincas As DAO.Recordset
Dim RSDeuda As DAO.Recordset

Otra opción mas es importar todos los objetos a una base nueva , depurar y compactar la base y solo seleccionar las referencias / librerías mínimas para que funcione el código.


 



Editado por javier.mil - 09/Mayo/2020 a las 10:24
Arriba
arcangelcaos Ver desplegable
Asiduo
Asiduo
Avatar

Unido: 15/Noviembre/2012
Localización: España
Estado: Sin conexión
Puntos: 243
Enlace directo a este mensaje Enviado: 20/Mayo/2020 a las 16:29
Gracias.
Esto medio que lo ha solucionado.
Ya no me corrompe la backend, pero sigue siendo muy lenta ese pc.
En los otros va bien.
Ya no se que mirar más.


Podéis cerrarlo si queréis.
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable