Problemas com conexão Microsoft.ACE.OLEDB.12.0

Boa tarde a todos,

Alguém poderia me ajudar?

tenho um form Home, no qual tem uma lista, a lista é atualizada via ado com registros de forma crescente.
nessa mesmíssima lista faço uma troca baseada nos registros, por exemplo:

----------Era-----
cod   titulo    chamado   Ordem
1  -   teste1   -   1234    -   1
2   -  teste2   -   1235    -    2

----------Fica-----
cod   titulo    chamado  Ordem    
2 -    teste2  -    1235   -     1
1   -  teste1   -   1234    -    2

a cada mudança, faço 2 updates no banco, trocando então o campo que ordena de forma crescente esses registros.

Tudo certinho, maravilhoso, porém, quando eu faço duas vezes seguidas essa mudança de ordem, a conexão da lista abre, executa mas não consegue fechar e o access reinicia, isso é péssimo pois essa parte de mudança de ordem é essencial para mim.

Alguém indica outra conexão, ou mudança desse código?


Código classe modulo de conexão

Código:

Option Compare Database
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Public lt As ADODB.Recordset

Function ConectaDB()
'referancia microsoft activex data objects 2.8
ConectaDB = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=H:\1 - Projetos\1 - Em andamento\SISTEMA_PROJETOS\09- PRODUCAO\3. Banco\SIBUS_be.accdb;"
'ConectaDB = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\Malu Lopes\Downloads\sibus\SIBUS_be.accdb;"

End Function


Public Sub Inserir_banco(sql As String)

Set cn = New ADODB.Connection
cn.Open ConectaDB
Set rs = New ADODB.Recordset
rs.Open sql, cn
cn.Close
Set cn = Nothing
MsgBox " Registro adicionado com sucesso"
Executar = Criar(sql)
End Sub

 Public Sub Inserir_banco_senha(sql As String)

Set cn = New ADODB.Connection
cn.Open ConectaDB
Set rs = New ADODB.Recordset
rs.Open sql, cn
cn.Close
rs.Close
Set cn = Nothing
Set rs = Nothing
MsgBox " Registro adicionado com sucesso"
Executar = Criar("Inseriu dados em recurso, não disponivel pois há uso de senhas")
End Sub


'Executa a query do tipo READ/SELECT
Public Sub procurar_banco(sql As String)
Set cn = New ADODB.Connection
cn.Open ConectaDB
On Error GoTo erro
    Set lt = New ADODB.Recordset
        lt.Open sql, cn
Exit Sub
erro:
    MsgBox "Falha ao executar o Select"
End Sub

'Fecha o SELECT e a Conexao
Public Sub fechar_procura()
On Error GoTo erro
    lt.Close
    Set lt = Nothing
    cn.Close
Set cn = Nothing
Exit Sub
erro:
    MsgBox "Falha ao fechar o Select"
End Sub

Function SeleNome() As Variant
    Dim Usuario As String
    Usuario = Environ("Username")
    
    
    
    sql = "SELECT Cod_Recurso FROM Recurso WHERE Login=" & Usuario & ""
    Dim resultado As Variant
    Set cn = New ADODB.Connection
    cn.Open ConectaDB
    Set rs = New ADODB.Recordset
    rs.Open sql, cn
    
 
    I = 2
    If Not rs.EOF Then
        Do While Not rs.EOF
            resultado = rs(0)
            rs.MoveNext
        Loop
    End If

    cn.Close

    SelectNome = resultado

End Function


Function SelectNome() As Variant

    Dim resultado As Variant

    Dim sql As String
    Dim cn  As ADODB.Connection
    Dim rs  As ADODB.Recordset
    Dim Usuario As String
    Usuario = Environ("Username")
    Set cn = New ADODB.Connection

    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=H:\1 - Projetos\1 - Em andamento\SISTEMA_PROJETOS\09- PRODUCAO\3. Banco\SIBUS_be.accdb;Jet OLEDB:Databas"
    'cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\Malu Lopes\Downloads\sibus\SIBUS_be.accdb;Jet OLEDB:Databas"


    cn.Open

    Set rs = New ADODB.Recordset

    sql = "SELECT Cod_Recurso FROM Recurso WHERE Login=" & Usuario & ""

    rs.Open sql, cn

    I = 2
    If Not rs.EOF Then
        Do While Not rs.EOF
            resultado = rs(0)
            rs.MoveNext
        Loop
    End If

    cn.Close

    SelectNome = resultado

    

End Function

Código formulario home

Código:

Option Compare Database
Dim CONEXAO As New cls_conexao




Private Sub btn_mudarordem_Click()
btn_next.Visible = True
btn_anterior.Visible = True
btn_salvar.Visible = True

End Sub


Private Sub btn_salvar_Click()
btn_next.Visible = False
btn_anterior.Visible = False
Me.Check_priorizados.SetFocus
btn_salvar.Visible = False

End Sub

Private Sub Check_Npriorizados_Click()
Me.Check_priorizados = False
Me.Check_Npriorizados = True
Me.btn_mudarordem.Visible = False
btn_next.Visible = False
btn_anterior.Visible = False
btn_salvar.Visible = False

query = "SELECT Chamado.Cod_chamado,Chamado.Ticket_chamado,Area.Nome_area,Chamado.Titulo_chamado,Chamado.Data_abertura_chamado,Torre_TI.Nome_torre,Prioridade.Descricao_prioridade,Recurso.Nome_recurso FROM Prioridade,Chamado,Torre_TI,Recurso,Area WHERE Chamado.Cod_prioridade=2 AND Chamado.Cod_prioridade=Prioridade.Cod_prioridade AND Torre_TI.Cod_torre = Chamado.Cod_torre AND Recurso.Cod_recurso = Chamado.Cod_recurso AND Area.Cod_area = Chamado.Cod_area ORDER BY Cod_chamado_anterior ASC;"

Preencher_lista_Adodb (query)


End Sub

Private Sub Check_priorizados_Click()
Me.Check_priorizados = True
Me.Check_Npriorizados = False
Me.btn_mudarordem.Visible = True
btn_next.Visible = False
btn_anterior.Visible = False
btn_salvar.Visible = False

'0000
query = "SELECT Chamado.Cod_chamado,Chamado.Ticket_chamado,Area.Nome_area,Chamado.Titulo_chamado,Chamado.Data_abertura_chamado,Torre_TI.Nome_torre,Prioridade.Descricao_prioridade,Recurso.Nome_recurso FROM Prioridade,Chamado,Torre_TI,Recurso,Area WHERE Chamado.Cod_prioridade=1 AND Chamado.Cod_prioridade=Prioridade.Cod_prioridade AND Torre_TI.Cod_torre = Chamado.Cod_torre AND Recurso.Cod_recurso = Chamado.Cod_recurso AND Area.Cod_area = Chamado.Cod_area ORDER BY Cod_chamado_anterior ASC;"

Preencher_lista_Adodb (query)

End Sub

Private Sub Comando175_Click()
Dim Cod_c As Variant
Dim resultado As VbMsgBoxResult
Cod_c = CInt(Lista_fato.Column(0))

resultado = MsgBox("Tem certeza que deseja prosseguir com esta ação?", vbYesNo, "Mudar priorização")
     If resultado = vbYes Then
        


If Me.Check_priorizados = True Then




sql = "UPDATE Chamado SET Cod_prioridade = 2 WHERE Cod_chamado = " & Cod_c & ";"


Else
sql = "UPDATE Chamado SET Cod_prioridade = 1 WHERE Cod_chamado = " & Cod_c & ";"

End If

Inserir_banco (sql)
Else
          
End If




End Sub

Private Sub Comando62_Click()
DoCmd.Quit
End Sub

Private Sub Comando63_Click()
Me.Refresh
End Sub


Private Sub Form_Close()

End Sub

Private Sub Form_Load()

Check_priorizados_Click

Dim usu As Variant
Dim nome As Variant

usu = Environ("Username")
nome = DLookup("[Nome_recurso]", "Recurso", "[Login]= '" & usu & "'")
txt_usu_home.Value = "Bem vinda(o) " & nome & ","

End Sub




Private Sub Lista_fato_DblClick(Cancel As Integer)
Dim aux As Variant
Dim aux2 As Integer


'aux = DLookup("[Cod_iniciativa]", "Chamado", "[Cod_chamado]= '" & aux2 & "' ")

aux2 = CInt(Lista_fato.Column(0))



aux = DLookup("[Cod_iniciativa]", "Chamado", "[Cod_chamado]= " & aux2 & " ")


If IsNull(aux) Then

DoCmd.OpenForm "Descricao_Chamado_Iniciativa_2"
Else

DoCmd.OpenForm "Descricao_Chamado_Iniciativa"
End If

End Sub
Sub Preencher_lista_Adodb(query As String)
 
    CONEXAO.CONEXAO_ABRIR 'abre a conexao
    
    CONEXAO.EXECUTAR_DATAREADER (query) 'executa a sql
    
    With Me.Lista_fato
        .ColumnCount = 8 ' 2 colunas
        '.ColumnWidths = "2cm;2cm" ' largura das colunas
        Set .Recordset = Nothing 'limpa a lista
        Set .Recordset = CONEXAO.DATA_READER 'preenche a lista com os dados da conexao
    End With
    CONEXAO.FECHAR_DATAREADER ' fecha o data reader e a conexao
End Sub


Private Sub btn_next_Click()
Dim Cod_c As Variant
Dim resultado As VbMsgBoxResult
Dim cod_atual As Integer
Dim cod_sup As Integer
Dim cod_atual_a As Integer
Dim cod_sup_a As Integer
Dim ctlSource As Control
Dim strItems As String
Dim intCurrentRow As Integer
Dim aux As Integer

Set ctlSource = Lista_fato

    If Lista_fato.ListIndex = 0 Then Exit Sub
    
  
Cod_c = CInt(Lista_fato.Column(0))

resultado = MsgBox("Tem certeza que deseja prosseguir com esta ação?", vbYesNo, "Mudar priorização")
     If resultado = vbYes Then
    
 For intCurrentRow = 0 To ctlSource.ListCount - 1
 If ctlSource.Selected(intCurrentRow) Then
 ' pegando cod e cod anterior do select atual
  cod_atual = CInt(Lista_fato.Column(0))
  cod_atual_a = DLookup("[Cod_chamado_anterior]", "Chamado", "[Cod_chamado]= " & cod_atual & "")
  
  
  aux = intCurrentRow - 2
  Form_Formulario_Home.Lista_fato.SetFocus
  Form_Formulario_Home.Lista_fato.ListIndex = aux
  
  ' pegando cod e cod anetrior do select superior
  cod_sup = CInt(Lista_fato.Column(0))
  cod_sup_a = DLookup("[Cod_chamado_anterior]", "Chamado", "[Cod_chamado]= " & cod_sup & "")
  
  Exit For
  End If
 Next intCurrentRow

 Set ctlSource = Nothing
   MsgBox "atual" & cod_atual
   MsgBox "atual" & cod_atual_a
 
   MsgBox "sup" & cod_sup
   MsgBox "sup" & cod_sup_a
  
  sql = "UPDATE Chamado SET Cod_chamado_anterior =" & cod_sup_a & "   WHERE Cod_chamado = " & cod_atual & ";"
CONEXAO.EXECUTAR_NONQUERY (sql)
 
 sql = "UPDATE Chamado SET Cod_chamado_anterior =" & cod_atual_a & "  WHERE Cod_chamado = " & cod_sup & ";"
CONEXAO.EXECUTAR_NONQUERY (sql)

 
query = "SELECT Chamado.Cod_chamado,Chamado.Ticket_chamado,Area.Nome_area,Chamado.Titulo_chamado,Chamado.Data_abertura_chamado,Torre_TI.Nome_torre,Prioridade.Descricao_prioridade,Recurso.Nome_recurso FROM Prioridade,Chamado,Torre_TI,Recurso,Area WHERE Chamado.Cod_prioridade=1 AND Chamado.Cod_prioridade=Prioridade.Cod_prioridade AND Torre_TI.Cod_torre = Chamado.Cod_torre AND Recurso.Cod_recurso = Chamado.Cod_recurso AND Area.Cod_area = Chamado.Cod_area ORDER BY Cod_chamado_anterior ASC;"

Preencher_lista_Adodb (query)


Me.Requery
Else
          
End If
End Sub





Private Sub btn_anterior_Click()
Dim Cod_c As Variant
Dim resultado As VbMsgBoxResult
Dim cod_atual As Integer
Dim cod_sup As Integer
Dim cod_atual_a As Integer
Dim cod_sup_a As Integer
Dim ctlSource As Control
Dim strItems As String
Dim intCurrentRow As Integer
Dim aux As Integer




Set ctlSource = Lista_fato
Cod_c = CInt(Lista_fato.Column(0))

resultado = MsgBox("Tem certeza que deseja prosseguir com esta ação?", vbYesNo, "Mudar priorização")
     If resultado = vbYes Then
    
 For intCurrentRow = 0 To ctlSource.ListCount - 1
 If ctlSource.Selected(intCurrentRow) Then
 ' pegando cod e cod anterior do select atual
  cod_atual = CInt(Lista_fato.Column(0))
  cod_atual_a = DLookup("[Cod_chamado_anterior]", "Chamado", "[Cod_chamado]= " & cod_atual & "")
  
  aux = intCurrentRow - 1
  Form_Formulario_Home.Lista_fato.SetFocus
  Form_Formulario_Home.Lista_fato = aux
  
  ' pegando cod e cod anetrior do select superior
  cod_sup = CInt(Lista_fato.Column(0))
  cod_sup_a = DLookup("[Cod_chamado_anterior]", "Chamado", "[Cod_chamado]= " & cod_sup & "")

End If
 Next intCurrentRow
 
 
  Set ctlSource = Nothing
 sql = "UPDATE Chamado SET Cod_chamado_anterior =" & cod_sup_a & "   WHERE Cod_chamado = " & cod_atual & ";"
 'Inserir_banco (sql)
 MsgBox "" & sql
 
 sql = "UPDATE Chamado SET Cod_chamado_anterior =" & cod_atual_a & "  WHERE Cod_chamado = " & cod_sup & ";"
  'Inserir_banco (sql)
 MsgBox "" & sql



Else
          
End If
End Sub



Bom dia,

Poderia enviar uma cópia do bd para facilitar com a solução?

Claro, obrigada pela sua contribuição, é a primeira vez que programo em vba.

o problema é no formulario Home, e a classe de conexão é cls_conexão.

Para as outras classes ela funciona bem, pois é só Insert, na home, como tem 2 updates seguidos, ela dá problema.

Maria Luiza, no código tem várias sub-rotinas.
Em qual delas existem esses dois updates?

Você sabe que tem a possibilidade de enviar o arquivo como anexo em uma mensagem aqui no forum?
Isso facilita muito em situações em que temos que realizar testes em código, quando temos dificuldade de simular o problema, quando precisamos das tabelas com alguns registros, etc.

Maria Luiza, no código tem várias sub-rotinas.
Em qual delas existem esses dois updates?

Há 2 sub rotinas que eu faço dois updates,


' Nessa function, eu troco a variavel do item superior pela a do item inferior de uma listbox
Private Sub btn_next_Click()

' Nessa function, eu troco a variavel do item inferior pela a do item superior de uma listbox
Private Sub btn_anterior_Click()

'Nessa function eu preencho uma lista baseada em um sql
Sub Preencher_lista_Adodb(query As String)

nas 3 eu abro e fecho a conexão

e na primeira e segunda função eu chamo a terceira. sempre na segunda vez que eu uso eles, o access da erro no fechamento e fecha sozinho




Você sabe que tem a possibilidade de enviar o arquivo como anexo em uma mensagem aqui no forum?
Isso facilita muito em situações em que temos que realizar testes em código, quando temos dificuldade de simular o problema, quando precisamos das tabelas com alguns registros, etc.

eu tentei, mas o arquivo estava grande, mas consegui por esse link aqui no drive

Sistema

Cláudio Más

Andei pesquisando aqui, e será que tem alguma relação por meu pc ser de 64 bits e o access 32 ?

Vê se está funcionando no arquivo do link abaixo.
Precisa atualizar os vínculos das tabelas.

Sistema

Andei pesquisando aqui, e será que tem alguma relação por meu pc ser de 64 bits e o access 32 ?

É possível, mas o erro também ocorreu aqui (tudo 64 bits) e acho que consegui corrigir.

Olá a todos,

Maria Luiza, desconfio desta SUB, repare que abre a conexão mas não fecha.

Código:

Sub Preencher_lista_Adodb(query As String)
 
    CONEXAO.CONEXAO_ABRIR 'abre a conexao
    
    CONEXAO.EXECUTAR_DATAREADER (query) 'executa a sql
    
    With Me.Lista_fato
        .ColumnCount = 8 ' 2 colunas
        '.ColumnWidths = "2cm;2cm" ' largura das colunas
        Set .Recordset = Nothing 'limpa a lista
        Set .Recordset = CONEXAO.DATA_READER 'preenche a lista com os dados da conexao
    End With
    CONEXAO.FECHAR_DATAREADER ' fecha o data reader e a conexao
End Sub

Testei e apresentava o erro relatado, comentado a linha da chamada desta SUB não dá o erro.
Verifique

Abraço a todos

Cláudio Más

OBRIGADA!

Não faço ideia do que você fez, mas funcionou perfeitamente, muito obrigada.
o que você mudou?

Maria Luiza, não foi necessário fazer alterações no código.

Primeiro, vi que ao executar o código passo a passo, não ocorria erro.
Então resolvi compilar os módulos e salvei.
Por último, compactei o banco de dados.

O arquivo devia estar corrompido de alguma forma, mas ainda em condições de recuperação.