[Resolvido]CurrentDb.Execute "UPDATE" erro 3340 consulta corrompida

Uso a tempo a função abaixo, e de maneira geral parou de funcionar me retornando o erro (3340) consulta corrompida

mas.... não tem nada corrompido


Dim X As Double
Dim Y As Double
X = Me.codigo
Y = Me.CBO_COD_CARREG

CurrentDb.Execute "UPDATE tbl_sis_expedicao_data_lista SET COD_VEICULO=" & X & " WHERE COD_CAR_LISTA=" & Y & ""

Boa noite Nois

Isso aconteceu motivado da atualização do Office.

Veja o link abaixo

https://www.maximoaccess.com/t36920-error-3340-consulta-corrompida-atualizacao-do-windows

complicou demais....

tem alguma sugestão para substituir o dito cujo

É Nois

Complicou mesmo. Esperemos auxílio dos Gr. Mestres.

Eu também estou com o mesmo problema, usava esta função:

CurrentDb.Execute "UPDATE Producao SET DtPgto2= #" & Format(DataPGTO, "mm-dd-yyyy") & "# WHERE NumOS=" & Me.NumOF & ";" 'ESTE FUNCIONA

e até semana passada funcionava perfeitamente, mas agora parou de funcionar e dá o erro 3340 consulta corrompida.

Alguma ideia de como solucionar?

paleativamente vou criar varias consultas baseado na tabela.... resolve por hora (conforme dica no topico do Assis)

de: CurrentDb.Execute "UPDATE tbl_sis_expedicao_data_lista SET COD_VEICULO=" & X & " WHERE COD_CAR_LISTA=" & Y & ""

para: CurrentDb.Execute "UPDATE cns_tbl_sis_expedicao_data_lista SET COD_VEICULO=" & X & " WHERE COD_CAR_LISTA=" & Y & ""

oi
tenta assim

CurrentDb.Execute ("UPDATE Producao SET DtPgto2= Format(DataPGTO, "mm-dd-yyyy") WHERE NumOS=" & Me.NumOF & ";")
CurrentDb.Execute ("UPDATE tbl_sis_expedicao_data_lista SET COD_VEICULO= X WHERE COD_CAR_LISTA=" & Y & "")

Boa noite

Fiz como o amigo Nois sugeriu através da consulta e deu certo

Antes: CurrentDb.Execute "UPDATE ProducaoSub SET DtPgto= #" & Format(DataPGTO, "mm-dd-yyyy") & "# WHERE IdOS=" & Me.NumOF & ";"

Depois: CurrentDb.Execute "UPDATE CsProducaoSub SET DtPgto= #" & Format(DataPGTO, "mm-dd-yyyy") & "# WHERE IdOS=" & Me.NumOF & ";"

Boas,

Eu fiz a rotina abaixo para superar o erro e não ter que criar consultas.



On Error GoTo ErrorHandler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String

sql = "Select * FROM DB_Sub_orcamento WHERE id=" & Me.txt_id_sub & ""

Set db = CurrentDb
Set rs = db.OpenRecordset(sql)

With rs

   If Not .BOF And Not .EOF Then
       .MoveLast
       .MoveFirst
       
       If .Updatable Then
       
           .Delete
       End If
       
   End If
           
End With

[Sub_orcamento].Form.Requery

ExitSub:
   Set db = Nothing
   Set rs = Nothing
   Exit Sub
   
ErrorHandler:
   Resume ExitSub
   
'CurrentDb.Execute "DELETE * FROM DB_Sub_orcamento WHERE id=" & Me.txt_id_sub & "" - parou de funcionar após atualizacao

no caso do Update como fica, tentei de algumas formas e não funfou

Segue o caso do Update.

creditos: by Robert Austin - Access All in One

On Error GoTo ErrorHandler

'This sub-produre will add 'z' to the first name of
'the record that corresponds to TeacherID 5

Dim sql As String
Dim rs As DAO.Recordset

sql = "SELECT * FROM tblTeachers WHERE TeacherID=5"
'We are using a select statement that will return only
'one record (TeacherID 5)

Set rs = CurrentDb.OpenRecordset(sql)
'Open RecordSet

With rs

If Not .BOF And Not .EOF Then
'Ensure that the recordset contains records
'If no records the code inside the if...end if
'statement won't run

.MoveLast
.MoveFirst
'Not necessary but good practice

If .Updatable Then
'It is possible that the record you want to update
'is locked by another user. If we don't check before
'updating, we will generate an error

.Edit
'Must start an update with the edit statement

![FirstName] = "z" & ![FirstName]
'Another way of accessing the fields would be to use
'.fields("FirstName") = z" & .fields("FirstName")

.Update
'And finally we will need to confirm the update

End If
End If

.Close
'Make sure you close the recordset...
End With

ExitSub:
Set rs = Nothing
'...and set it to nothing
Exit Sub
ErrorHandler:
Resume ExitSub

End Sub

deu não

Esse é o que tenho funcionando em meu banco

dim db as DAO.Database
dim rs1 as DAO.recordset
dim sql1 as string

sql1 = "Select * from SUATABELA WHERE NomeCampoTabela=" & me. Camposeuformulario & "" - (Se texto colocar aspas simples)

set db = currentDb
Set rs1 = db.OpenRecordset(sql1)

With rs1
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst

If .Updatable Then
.Edit
![CampoDaTabela] = Me!CampoDoFormulario
.Update
End If
End If
.Close
End With

Set rs1 = Nothing
Set db = Nothing

tente assim!! Aqui está funcionando.

Vejam isto
https://www.maximoaccess.com/t36980-codigo-para-ultrapassar-err-3340-em-instrucao-update

Boa noite Alexandre

Então como fica por exemplo a linha abaixo ?

DoCmd.RunSQL "UPDATE Clientes Set [Clientes].[Nome] = '" & Me.NovaLinha & "' WHERE [Clientes].[Nome] = '" & Me.Tipo & "'"


Obrigado

Boa noite, Assis
Call UPDATE("Clientes","[Clientes].[Nome] = '" & Me.NovaLinha & "' WHERE [Clientes].[Nome] = '" & Me.Tipo & "'")

Obrigado Alexandre

obrigado!

Alexandre Neves

Pode dar-me uma ajuda nestas 2 com datas  ?

Não estou a conseguir fazer funcionar

Obrigado

CurrentDb.Execute "UPDATE MovimentosAutomaticos SET Pago = false WHERE (dataP >=#" & Format(Me.dtInicio, "mm/dd/yyyy") & "# And datam <= #" & Format(Me.dtfim, "mm/dd/yyyy") & "#)"

CurrentDb.Execute "UPDATE MovimentosAutomaticos SET DataP = ""  Null  "" WHERE (datap >=#" & Format(Me.dtInicio, "mm/dd/yyyy") & "# And datam <= #" & Format(Me.dtfim, "mm/dd/yyyy") & "#)"

Boa noite, Assis
Deverá ser
Call UPDATE("MovimentosAutomaticos ","Pago = false WHERE (dataP >=#" & Format(Me.dtInicio, "mm/dd/yyyy") & "# And datam <= #" & Format(Me.dtfim, "mm/dd/yyyy") & "#)")

Call UPDATE("MovimentosAutomaticos ","DataP =Null WHERE (datap >=#" & Format(Me.dtInicio, "mm/dd/yyyy") & "# And datam <= #" & Format(Me.dtfim, "mm/dd/yyyy") & "#)")

Bom dia Alexandre

Dá o seguinte erro:



E depois de fazer Debug

Boa noite, Assis
isso acontece porque ultrapassaste a instrução de eliminação, após a criação da consulta

Coloca na linha anterior ao erro
CurrentDb.Execute "DROP TABLE qdf" & strNomeTab
depois de executar, elimina esta instrução

Obrigado Alexandre

Bom fim de semana.

PS- Esta atualização KB 4484119 só deu pau, e vai continuar a dar até resolver todos os casos mesmo em outras BDs.