Registro duplicando sozinho no evento Onclick ( apenas um clique de mouse ) !!!

Prezados, bom dia / boa tarde / boa noite!

Tenho passado por uma situação atípica em um sistema desenvolvido por mim a 8 anos. De 2 semanas para cá, até a presente data, alguns registros têm se
duplicado sozinho.

Não é algo constante, não é sempre na mesma rotina, não é sempre no mesmo formulário.

Simplesmente se duplicam. O Evento, a rotina estão ao clicar apenas uma vez.

Já compactei e reparei o Back end e nada. Já compactei e reparei o front end também nos 8 computadores ligados ao Back end, cada um com seu front end.

Não é sempre o mesmo computador que duplica a rotina.

Essa situação tem me tirado o sono aqui, já revi a rotina

Abaixo uma das rotinas, que ora duplica registo...ora não duplica.

Código:

Private Sub Dinheiro_Click()
DoCmd.Save
On Error Resume Next
' caso realize o pagamento em dinheiro....


If Me.Dinheiro = -1 Then
 If MsgBox("Confirma o pgto em dinheiro ?", vbYesNo, Me.Caption) = vbNo Then
  Me.Dinheiro = 0
  Me.Carteira = 0
  Me.Cheques = 0
  Me.CCredito = 0
  Me.CDebito = 0
  Me.ValorDinheiro = ""
  Exit Sub
  Else
 
 On Error Resume Next
If IsNull(Me.DataPagamento) Or Me.DataPagamento = "" Then
MsgBox " Data pagamento é campo obrigatório !", vbCritical, Me.Caption
Me.Cheques.Value = 0
Me.Dinheiro.Value = 0
Exit Sub

Else
Call CRM
'----------------------------------------------------------------------------------------------------------------------------------------------
'aqui inicio a exportação para o historico de caixa da tabela proprietarios
 Dim strHist As String
 Dim rs As DAO.Recordset
    Set rs = Me.SFrmCaixa.Form.RecordsetClone    'Clono o recorset do subform
    rs.MoveFirst    'Para evitar erros, posiciono o ponteiro do recordset no primeiro registro
    Do Until rs.EOF
    strHist = strHist & "Proc/Med: " & rs!Servico & vbCrLf & _
                        "Valor R$: " & FormatCurrency(rs!Custo) & vbCrLf & _
                        "Qtd    : " & rs!Qtd & vbCrLf & _
                        "Valor Total R$: " & FormatCurrency(rs!Tcusto)

    rs.MoveNext
    Loop
    rs.Close 'Fecho a conexao com recordset
    Set rs = Nothing 'apagado o rs da memória
 

Dim db7 As Database, rs7 As DAO.Recordset
Set db7 = CurrentDb
Set rs7 = db7.OpenRecordset("proprietarios", dbOpenDynaset)
rs7.FindFirst "idprop  = " & Forms!Frmcaixa!IdProp
With rs7

.Edit
 If IsNull(!HistCaixa) Or !HistCaixa = " " Then
  !HistCaixa = !HistCaixa & vbCrLf & "*-*-*-*-*-*-*-*-*-*-*-*-* Dinheiro *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-"
  !HistCaixa = !HistCaixa & vbCrLf & "DATA: " & Me.DataPagamento & vbCrLf & _
                                      "Mascote:  " & Me.Animal & vbCrLf & _
                                      "Desc.:  " & FormatCurrency(Me.Descontos) & " Total pago:  " & FormatCurrency(Me.Valor) & vbCrLf & strHist
                                     
                                     
                                     
 Else
 !HistCaixa = !HistCaixa & vbCrLf & "*-*-*-*-*-*-*-*-*-*-*-*-* Dinheiro *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-"
 !HistCaixa = !HistCaixa & vbCrLf & "DATA: " & Me.DataPagamento & vbCrLf & _
                                      "Mascote:  " & Me.Animal & vbCrLf & _
                                      "Desc.:  " & FormatCurrency(Me.Descontos) & " Total pago:  " & FormatCurrency(Me.Valor) & vbCrLf & strHist
                                   

 End If
.Update

End With


'------------------------------------------------------------------------------------------------------------------------------------------
Dim DB1 As Database
Dim db2 As Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim db4 As Database
Dim rs4 As DAO.Recordset
'------------------------------------------------------------------------------------------------------------------------------------------
'Nova rotina de exportação para a tabela ateencerado
If Me.Dinheiro = -1 Then

   
        'fazendo do subformulário um recordset
        Set rs1 = Me!SFrmCaixa.Form.RecordsetClone
       
        'verificando se há registros no subformulário
        If rs1.RecordCount > 0 Then
       
            Call rs1.MoveFirst
            Set DB1 = CurrentDb
            Set rs2 = DB1.OpenRecordset("Ateencerrado", , 'abrindo para somente adição
           
            With rs2
            Do 'iniciando loop

                Call .AddNew
               
                    ![idcaixa] = Me.idcaixa
                    ![proprietario] = Me.proprietario
                    ![Animal] = Me.Animal
                    ![DataPagamento] = Me.DataPagamento
                    ![Valor] = Me.ValorDinheiro
                    ![Dinheiro] = -1
                    ![Usuario] = [Forms]![login]![USER] & " / " & Now

                    'campos que estão no subformulário
                    ![TipoServico] = rs1!TipoServico
                    ![Servico] = rs1!Servico
                    ![Custo] = rs1!Custo
                    ![Qtd] = rs1!Qtd
                    ![NomeGrupo] = rs1!NomeGrupo
                   
                Call .Update
                Call rs1.MoveNext

            'condição para finalizar o loop
            Loop Until rs1.EOF
            End With
           
            Call rs2.Close: Set rs2 = Nothing
            Set DB1 = Nothing
           
        End If
       
        Set rs1 = Nothing
       
    End If
 

'---------------------------------------------------------------------------------------------------------------------------------
Set db2 = CurrentDb
Set rs2 = db2.OpenRecordset("tblsaldo")
With rs2
.AddNew
![idcaixa] = Me.idcaixa
![Valorentrada] = Me.ValorDinheiro
![Data] = Me.DataPagamento
![Descricao] = "Pgto Caixa Dinheiro" & " Nº : " & Me.idcaixa & "    Cliente:  " & Me.proprietario
.Update
End With

'realizo a exportação para a tblentradadia que mostra o quanto esta entrando em R$
Set db4 = CurrentDb
Set rs4 = db4.OpenRecordset("tblentradadia")
With rs4
.AddNew
![idcaixa] = Me.idcaixa
![DataEntrada] = Me.DataPagamento
![proprietario] = Me.proprietario & "  - " & " Dinheiro"
![EntrValor] = Me.ValorDinheiro
.Update
End With
End If
End If
End If
MsgBox "Entrada Caixa... salva com sucesso!", vbInformation, Me.Caption
End Sub

Se alguém puder me dar uma luz, fico agradecido desde já.

Abraços a todos.

UP

up

UP

Silvio,

Consegue mandar somente os objetos envolvidos nesta questão, para análise e solução do problema?
Previamente, fiz uma análise no código que vc mandou, e está muito confuso.

No código existe 2 declarações de "On Error Resume Next", desnecessárias. Somente 1 já basta.
A propósito, não se deve colocar esta instrução pois ela "ignora" qualquer erro que ocorra no procedimento. O correto é fazer o tratamento de erro.

Declarações abaixo:
Dim DB1 As Database => instanciado para o CurrentDb
Dim db2 As Database => instanciado para o CurrentDb
Dim db4 As Database => instanciado para o CurrentDb
Dim db7 As Database => instanciado para o CurrentDb

Varias instâncias declaradas para o mesmo database. Desnecessário também!

Dentro do código que vc mandou existe vários processos rodando dentro dele.
Sempre que possível, separar esses processos em Sub's pertinentes ao processo desejado.

Ex.:
'Rotina para exportar historicos
Private Sub ExportHistCaixa()

'Nova rotina de exportação para a tabela ateencerado
Private Sub ExportAteEncerado()

'realizo a exportação para a tblentradadia que mostra o quanto esta entrando em R$
Private Sub ExportEntradaDia()

No aguardo do encvio do bd para análise.

é isso

Att,

Alexandre Fim

Bom dia / boa tarde / boa noite.

Alexandre, o segundo " on error..." já tinha suprido ele antes de mandar aqui.

Agora, a ideia foi boa de fazer uma chamada para um Private sub, não havia pensado nisso ainda.

O sistema cresceu vertiginosamente de um ano para cá, fica quase impossível de mandar.