Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Ajuda Conexão VBA com Bando Access

Discussões sobre a integração do Excel com o Banco de Dados Access

Moderador: joseA

Avatar do usuário
Guedelha
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Dom Jul 08, 2018 5:02 pm

Ajuda Conexão VBA com Bando Access

Mensagem por Guedelha »

Prezados,

Sou um novato na linguagem VBA, e estou adequando cadastro com bando de dados Access.
Contudo apesar de inúmeras pesquisas e tentativas não consigo corrigir o erro abaixo.
Será que alguém pode me ajudar?

Erro em tempo de execução '-2147352571 (80020005)':
Não foi possível definir a propriedade Value. Tipo não corresponde.


Aqui esta os códigos:

FORMULÁRIO VBA DE CADASTRO

Código: Selecionar todos

Option Explicit
Const corDisabledTextBox As Long = -2147483633
Const corEnabledTextBox As Long = -2147483643
Public Indice As Long
Public cx As New ClasseConexao
Public banco As ADODB.Recordset
Public sql As String


Sub Incluir_Registro()

    sql = "INSERT INTO Clientes(DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes)"
    sql = sql & " VALUES ("
    sql = sql & " '" & Me.txtDatCadastro.Value & "'"
    sql = sql & " '" & Me.cboAtividade.Value & "'"
    sql = sql & " '" & Me.cboCliente.Value & "'"
    sql = sql & " '" & Me.cboPF.Value & "'"
    sql = sql & " '" & Me.cboPJ.Value & "'"
    sql = sql & " '" & Me.txtRazaoSocial.Value & "'"
    sql = sql & " '" & Me.txtNomeFantasia.Value & "'"
    sql = sql & " '" & Me.txtEndereço.Value & "'"
    sql = sql & " '" & Me.txtBairro.Value & "'"
    sql = sql & " '" & Me.cboUF.Value & "'"
    sql = sql & " '" & Me.cboCidade.Value & "'"
    sql = sql & " '" & Me.txtCep.Value & "'"
    sql = sql & " '" & Me.txtDDD.Value & "'"
    sql = sql & " '" & Me.txtTelefone.Value & "'"
    sql = sql & " '" & Me.txtCelular.Value & "'"
    sql = sql & " '" & Me.txtCnpjCpf.Value & "'"
    sql = sql & " '" & Me.txtInscEstadualRG.Value & "'"
    sql = sql & " '" & Me.txtContato.Value & "'"
    sql = sql & " '" & Me.txtEmail.Value & "'"
    sql = sql & " '" & Me.txtObservaçoes.Value & "'"
    sql = sql & " )"

    Set banco = New ADODB.Recordset
    cx.Conectar
    banco.Open sql, cx.Conn
    
    MsgBox "Cadastro efetuado com sucesso.", vbInformation, "Cadastro de Clientes"
    Set banco = Nothing
    cx.Desconectar
    
End Sub
Sub Alterar_Registro()

    'O registro a ser alterado nao pode conter aspas simples

    sql = "UPDATE clientes"
    sql = sql & " SET cliente = '" & Me.txtRazaoSocial & "'"
    sql = sql & ", Atividade = '" & Me.cboAtividade & "'"
    sql = sql & ", PF = '" & Me.cboPF & "'"
    sql = sql & ", PJ = '" & Me.cboPJ & "'"
    sql = sql & ", RazaoSocial = '" & Me.txtRazaoSocial & "'"
    sql = sql & ", NomeFantasia = '" & Me.txtNomeFantasia & "'"
    sql = sql & ", Endereço = '" & Me.txtEndereço & "'"
    sql = sql & ", Bairro = '" & Me.txtBairro & "'"
    sql = sql & ", UF = '" & Me.cboUF & "'"
    sql = sql & ", Cidade = '" & Me.cboCidade & "'"
    sql = sql & ", CEP = '" & Me.txtCep & "'"
    sql = sql & ", DDD = '" & Me.txtDDD & "'"
    sql = sql & ", Telefone = '" & Me.txtTelefone & "'"
    sql = sql & ", Celular = '" & Me.txtCelular & "'"
    sql = sql & ", CnpjCpf = '" & Me.txtCnpjCpf & "'"
    sql = sql & ", InscEstadualRG = '" & Me.txtInscEstadualRG & "'"
    sql = sql & ", Contato = '" & Me.txtContato & "'"
    sql = sql & ", Email = '" & Me.txtEmail & "'"
    sql = sql & ", Observaçoes = '" & Me.txtObservaçoes & "'"


    Set banco = New ADODB.Recordset
    cx.Conectar
    
    banco.Open sql, cx.Conn
    
    MsgBox "Alterado com sucesso.", vbInformation, "Cadastro de Fornecedores"
    Set banco = Nothing
    cx.Desconectar

End Sub

Private Sub btnCancelar_Click()
    
    btnOK.Enabled = False
    btnCancelar.Enabled = False
    UserForm_Initialize
    Call DesabilitaControles
    Call HabilitaBotoesAlteracao
    Call HabilitaBotoesNavegaçao
    lblMensagem.Caption = Empty
    
End Sub

Private Sub btnOK_Click()
    
    'Altera
    If optAlterar.Value Then
        Call Alterar_Registro
        lblMensagem.Caption = "Registro salvo com sucesso."
        
    End If
    
    'Novo
    If optNovo.Value Then
        Call Incluir_Registro
        btnUltimo_Click
        lblMensagem.Caption = "Registro salvo com sucesso."
    End If
    
    'Excluir
    If optExcluir.Value Then
        Dim result As VbMsgBoxResult
        result = MsgBox("Deseja excluir o cliente: " & Me.txtRazaoSocial & " ?", vbYesNo, "Confirmação")

        If result = vbYes Then
            sql = "DELETE FROM clientes"
            sql = sql & " WHERE codigo =  " & Me.txtID.Value
            Set banco = New ADODB.Recordset
            cx.Conectar
            banco.Open sql, cx.Conn
            Set banco = Nothing
            cx.Desconectar
            UserForm_Initialize
            lblMensagem.Caption = "Registro excluído com sucesso."
        Else
            btnCancelar_Click
        End If
    End If

    Call HabilitaBotoesAlteracao
    Call DesabilitaControles
    Call HabilitaBotoesNavegaçao
    
End Sub

Private Sub optAlterar_Click()
    
    If txtID.Text <> vbNullString And txtID.Text <> "" Then
        Call HabilitaControles
        Call DesabilitaBotoesAlteracao
        Call DesabilitaBotoesNavegaçao
        'dá o foco ao primeiro controle de dados
        txtRazaoSocial.SetFocus
    Else
        lblMensagem.Caption = "Não há registro a ser alterado"
    End If
    
End Sub

Private Sub optExcluir_Click()

    If txtID.Text <> vbNullString And txtID.Text <> "" Then
        Call DesabilitaBotoesAlteracao
        lblMensagem.Caption = "Modo de exclusão. Confira o dados do registro antes de excluí-lo."
    Else
        lblMensagem.Caption = "Não há registro a ser excluído."
    End If
End Sub

Private Sub optNovo_Click()
    Call LimpaControles
    Call DesabilitaBotoesAlteracao
    Call DesabilitaBotoesNavegaçao
    Call HabilitaControles
    Me.txtRazaoSocial.SetFocus
End Sub
Sub CarregaRegistros()

     With banco
      If Not IsNull(.Fields(0)) Then
        Me.txtID.Value = .Fields(0)
        Me.txtDatCadastro.Value = .Fields(1)
        Me.cboAtividade.Value = .Fields(2)
        Me.cboCliente.Value = .Fields(3)
        Me.cboPF.Value = .Fields(4)
        Me.cboPJ.Value = .Fields(5)
        Me.txtRazaoSocial.Value = .Fields(6)
        Me.txtNomeFantasia.Value = .Fields(7)
        Me.txtEndereço.Value = .Fields(8)
        Me.txtBairro.Value = .Fields(9)
        Me.cboUF.Value = .Fields(10)
        Me.cboCidade.Value = .Fields(11)
        Me.txtCep.Value = .Fields(12)
        Me.txtDDD.Value = .Fields(13)
        Me.txtTelefone.Value = .Fields(14)
        Me.txtCelular.Value = .Fields(15)
        Me.txtCnpjCpf.Value = .Fields(16)
        Me.txtInscEstadualRG.Value = .Fields(17)
        Me.txtContato.Value = .Fields(18)
        Me.txtEmail.Value = .Fields(19)
        Me.txtObservaçoes.Value = .Fields(20)
      End If
    
    End With
    lblIndice.Caption = Indice
    lblTotal.Caption = banco.RecordCount
    
End Sub

Private Sub btnAnterior_Click()
   
   On Error GoTo final
   
    sql = "SELECT ID, DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes FROM Clientes "
    Set banco = New ADODB.Recordset
    cx.Conectar
    banco.Open sql, cx.Conn, adOpenKeyset, adLockOptimistic
    
    banco.AbsolutePosition = Indice - 1
    Indice = banco.AbsolutePosition
    
    Call CarregaRegistros
    
final:
    Set banco = Nothing
    cx.Desconectar
    
End Sub

Private Sub btnPesquisar_Click()
    CliPesquisa.Show
End Sub

Private Sub btnPrimeiro_Click()
    
   On Error GoTo final
   
    sql = "SELECT id, DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes FROM Clientes "
    Set banco = New ADODB.Recordset
    cx.Conectar
    banco.Open sql, cx.Conn, adOpenKeyset, adLockOptimistic
    
    banco.AbsolutePosition = 1
    Indice = banco.AbsolutePosition
    
     Call CarregaRegistros
final:
    Set banco = Nothing
    cx.Desconectar

End Sub

Private Sub btnProximo_Click()

  On Error Resume Next
   
    sql = "SELECT id, DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes FROM Clientes "
    Set banco = New ADODB.Recordset
    cx.Conectar
    banco.Open sql, cx.Conn, adOpenKeyset, adLockOptimistic
    
   If lblIndice.Caption <> lblTotal.Caption Then
   
    banco.AbsolutePosition = Indice + 1
    Indice = banco.AbsolutePosition
   
    Call CarregaRegistros
     
   End If

    Set banco = Nothing
    cx.Desconectar
    Exit Sub
    
End Sub

Private Sub btnUltimo_Click()
  
   On Error GoTo final
   
    sql = "SELECT id, DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes FROM Clientes "
    Set banco = New ADODB.Recordset
    cx.Conectar
    banco.Open sql, cx.Conn, adOpenKeyset, adLockOptimistic
    
    banco.AbsolutePosition = banco.RecordCount
    Indice = banco.AbsolutePosition
    
     Call CarregaRegistros
    
final:
    Set banco = Nothing
    cx.Desconectar

End Sub

Private Sub UserForm_Initialize()
 
    sql = "SELECT ID, DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes FROM Clientes "
    Set banco = New ADODB.Recordset
    cx.Conectar
    banco.Open sql, cx.Conn, adOpenKeyset, adLockOptimistic
    
    Indice = banco.AbsolutePosition
    
    Call CarregaRegistros
     
    Call DesabilitaControles
    Call HabilitaBotoesAlteracao
    
    Set banco = Nothing
    cx.Desconectar
    
End Sub

Private Sub LimpaControles()
    Me.txtID.Text = ""
    Me.txtDatCadastro.Text = ""
    Me.cboAtividade.Text = ""
    Me.cboCliente.Text = ""
    Me.cboPF.Text = ""
    Me.cboPJ.Text = ""
    Me.txtRazaoSocial.Text = ""
    Me.txtNomeFantasia.Text = ""
    Me.txtEndereço.Text = ""
    Me.txtBairro.Text = ""
    Me.cboUF.Text = ""
    Me.cboCidade.Text = ""
    Me.txtCep.Text = ""
    Me.txtDDD.Text = ""
    Me.txtTelefone.Text = ""
    Me.txtCelular.Text = ""
    Me.txtCnpjCpf.Text = ""
    Me.txtInscEstadualRG.Text = ""
    Me.txtContato.Text = ""
    Me.txtEmail.Text = ""
    Me.txtObservaçoes.Text = ""
End Sub

Private Sub HabilitaControles()

   'Me.txtID.Locked = False
    Me.txtDatCadastro.Locked = False
    Me.cboAtividade.Locked = False
    Me.cboCliente.Locked = False
    Me.cboPF.Locked = False
    Me.cboPJ.Locked = False
    Me.txtRazaoSocial.Locked = False
    Me.txtNomeFantasia.Locked = False
    Me.txtEndereço.Locked = False
    Me.txtBairro.Locked = False
    Me.cboUF.Locked = False
    Me.cboCidade.Locked = False
    Me.txtCep.Locked = False
    Me.txtDDD.Locked = False
    Me.txtTelefone.Locked = False
    Me.txtCelular.Locked = False
    Me.txtCnpjCpf.Locked = False
    Me.txtInscEstadualRG.Locked = False
    Me.txtContato.Locked = False
    Me.txtEmail.Locked = False
    Me.txtObservaçoes.Locked = False

    Me.txtDatCadastro.BackColor = corEnabledTextBox
    Me.cboAtividade.BackColor = corEnabledTextBox
    Me.cboCliente.BackColor = corEnabledTextBox
    Me.cboPF.BackColor = corEnabledTextBox
    Me.cboPJ.BackColor = corEnabledTextBox
    Me.txtRazaoSocial.BackColor = corEnabledTextBox
    Me.txtNomeFantasia.BackColor = corEnabledTextBox
    Me.txtEndereço.BackColor = corEnabledTextBox
    Me.txtBairro.BackColor = corEnabledTextBox
    Me.cboUF.BackColor = corEnabledTextBox
    Me.cboCidade.BackColor = corEnabledTextBox
    Me.txtCep.BackColor = corEnabledTextBox
    Me.txtDDD.BackColor = corEnabledTextBox
    Me.txtTelefone.BackColor = corEnabledTextBox
    Me.txtCelular.BackColor = corEnabledTextBox
    Me.txtCnpjCpf.BackColor = corEnabledTextBox
    Me.txtInscEstadualRG.BackColor = corEnabledTextBox
    Me.txtContato.BackColor = corEnabledTextBox
    Me.txtEmail.BackColor = corEnabledTextBox
    Me.txtObservaçoes.BackColor = corEnabledTextBox

End Sub

Private Sub DesabilitaControles()

Me.txtID.Locked = True
    Me.txtDatCadastro.Locked = True
    Me.cboAtividade.Locked = True
    Me.cboCliente.Locked = True
    Me.cboPF.Locked = True
    Me.cboPJ.Locked = True
    Me.txtRazaoSocial.Locked = True
    Me.txtNomeFantasia.Locked = True
    Me.txtEndereço.Locked = True
    Me.txtBairro.Locked = True
    Me.cboUF.Locked = True
    Me.cboCidade.Locked = True
    Me.txtCep.Locked = True
    Me.txtDDD.Locked = True
    Me.txtTelefone.Locked = True
    Me.txtCelular.Locked = True
    Me.txtCnpjCpf.Locked = True
    Me.txtInscEstadualRG.Locked = True
    Me.txtContato.Locked = True
    Me.txtEmail.Locked = True
    Me.txtObservaçoes.Locked = True

    Me.txtDatCadastro.BackColor = corDisabledTextBox
    Me.cboAtividade.BackColor = corDisabledTextBox
    Me.cboCliente.BackColor = corDisabledTextBox
    Me.cboPF.BackColor = corDisabledTextBox
    Me.cboPJ.BackColor = corDisabledTextBox
    Me.txtRazaoSocial.BackColor = corDisabledTextBox
    Me.txtNomeFantasia.BackColor = corDisabledTextBox
    Me.txtEndereço.BackColor = corDisabledTextBox
    Me.txtBairro.BackColor = corDisabledTextBox
    Me.cboUF.BackColor = corDisabledTextBox
    Me.cboCidade.BackColor = corDisabledTextBox
    Me.txtCep.BackColor = corDisabledTextBox
    Me.txtDDD.BackColor = corDisabledTextBox
    Me.txtTelefone.BackColor = corDisabledTextBox
    Me.txtCelular.BackColor = corDisabledTextBox
    Me.txtCnpjCpf.BackColor = corDisabledTextBox
    Me.txtInscEstadualRG.BackColor = corDisabledTextBox
    Me.txtContato.BackColor = corDisabledTextBox
    Me.txtEmail.BackColor = corDisabledTextBox
    Me.txtObservaçoes.BackColor = corDisabledTextBox
End Sub

Private Sub HabilitaBotoesAlteracao()
'habilita os botões de alteração
    optAlterar.Enabled = True
    optExcluir.Enabled = True
    optNovo.Enabled = True
    btnPesquisar.Enabled = True
    btnOK.Enabled = False
    btnCancelar.Enabled = False

    'limpa os valores dos controles
    optAlterar.Value = False
    optExcluir.Value = False
    optNovo.Value = False
End Sub

Private Sub DesabilitaBotoesAlteracao()
'desabilita os botões de alteração
    optAlterar.Enabled = False
    optExcluir.Enabled = False
    optNovo.Enabled = False
    btnPesquisar.Enabled = False
    btnOK.Enabled = True
    btnCancelar.Enabled = True
End Sub

Private Sub HabilitaBotoesNavegaçao()
    
    btnPrimeiro.Enabled = True
    btnAnterior.Enabled = True
    btnProximo.Enabled = True
    btnUltimo.Enabled = True
End Sub

Private Sub DesabilitaBotoesNavegaçao()
    
    btnPrimeiro.Enabled = False
    btnAnterior.Enabled = False
    btnProximo.Enabled = False
    btnUltimo.Enabled = False
    
End Sub

Private Sub btnSair_Click()
    Unload Me
End Sub

FORMULÁRIO VBA PARA PESQUISA

Public ProcurarPor As String
Public OrdenarPor As String
Public Ordem As String

Sub cboOrdem_Change()
    
    Select Case cboOrdem.ListIndex
        Case 0
            Ordem = "DESC"
        Case 1
            Ordem = "ASC"
    End Select
    txtPesquisa_Change
    
End Sub

Private Sub cboOrdenarPor_Change()

    txtPesquisa_Change
    
End Sub

Private Sub chkPesquisa_Click()
    txtPesquisa_Change
End Sub

Private Sub lstv_Dblclick()
   
    With CliCadastro
        .sql = "SELECT ID, DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes FROM Clientes "
        .sql = .sql & " WHERE codigo = " & lstv.SelectedItem
        Set .banco = New ADODB.Recordset
        .cx.Conectar
        .banco.Open .sql, .cx.Conn, adOpenKeyset, adLockOptimistic
        
        Call .CarregaRegistros
        .Indice = Id
        .lblIndice.Caption = Id
        .lblTotal.Caption = Total
        
    Set .banco = Nothing
    .cx.Desconectar
    
    End With
    Unload Me
    
End Sub

Private Sub lstv_KeyPress(KeyAscii As Integer)
    
    lstv_Dblclick
    
End Sub

Private Sub txtPesquisa_Change()
    
    Dim cx As New ClasseConexao
    Dim banco As ADODB.Recordset
    Dim sql As String
    
    ProcurarPor = Me.cboPesquisarPor.Text
    OrdenarPor = Me.cboOrdenarPor.Text
    
    With Me.lstv
        .ListItems.Clear
        
        sql = "SELECT ID, DatCadastro, Atividade, Cliente, PF, PJ, RazaoSocial, NomeFantasia, Endereço, Bairro, UF, Cidade, CEP, DDD, Telefone, Celular, CnpjCpf, InscEstadualRG, Contato, Email, Observaçoes FROM Clientes "
        
        If Me.chkPesquisa.Value = True Then
            sql = sql & " WHERE " & ProcurarPor & " LIKE '%" & Me.txtPesquisa.Value & "%' ORDER BY " & OrdenarPor & " " & Ordem
        
        ElseIf Me.chkPesquisa.Value = False Then
            sql = sql & " WHERE " & ProcurarPor & " LIKE '" & Me.txtPesquisa.Value & "%' ORDER BY " & OrdenarPor & " " & Ordem
        End If
        
        Set banco = New ADODB.Recordset
        cx.Conectar
        
        banco.Open sql, cx.Conn, adOpenKeyset, adLockOptimistic
        
        Dim i As Integer
        For i = 0 To banco.RecordCount - 1
            If Not IsNull(banco(0)) Then
                .ListItems.Add 1, , banco(0)
                .ListItems(1).ListSubItems.Add 1, , banco(1)
                .ListItems(1).ListSubItems.Add 2, , banco(2)
                .ListItems(1).ListSubItems.Add 3, , banco(3)
                .ListItems(1).ListSubItems.Add 4, , banco(4)
                .ListItems(1).ListSubItems.Add 5, , banco(5)
                .ListItems(1).ListSubItems.Add 6, , banco(6)
                .ListItems(1).ListSubItems.Add 7, , banco(7)
                .ListItems(1).ListSubItems.Add 8, , banco(8)
                .ListItems(1).ListSubItems.Add 9, , banco(9)
                .ListItems(1).ListSubItems.Add 10, , banco(10)
                .ListItems(1).ListSubItems.Add 11, , banco(11)
                .ListItems(1).ListSubItems.Add 12, , banco(12)
                .ListItems(1).ListSubItems.Add 13, , banco(13)
                .ListItems(1).ListSubItems.Add 14, , banco(14)
                .ListItems(1).ListSubItems.Add 15, , banco(15)
                .ListItems(1).ListSubItems.Add 16, , banco(16)
                .ListItems(1).ListSubItems.Add 17, , banco(17)
                .ListItems(1).ListSubItems.Add 18, , banco(18)
                .ListItems(1).ListSubItems.Add 19, , banco(19)
                .ListItems(1).ListSubItems.Add 20, , banco(20)

            End If
            banco.MoveNext
        Next i
        Set banco = Nothing
        cx.Desconectar
    End With
    
    Me.StatusBar1.Panels(1).Text = "Total de Itens Localizados: " & Me.lstv.ListItems.Count
    
End Sub

Private Sub UserForm_Initialize()

    With cboPesquisarPor
        .AddItem "ID"
        .AddItem "DatCadastro"
        .AddItem "Atividade"
        .AddItem "Cliente"
        .AddItem "PF"
        .AddItem "PJ"
        .AddItem "RazaoSocial"
        .AddItem "NomeFantasia"
        .AddItem "Endereço"
        .AddItem "Bairro"
        .AddItem "UF"
        .AddItem "Cidade"
        .AddItem "Cep"
        .AddItem "DDD"
        .AddItem "Telefone"
        .AddItem "Celular"
        .AddItem "CnpjCpf"
        .AddItem "InscEstadualRG"
        .AddItem "Contato"
        .AddItem "Email"
        .AddItem "Observaçoes"
        .ListIndex = 1
    End With
    
    cboOrdenarPor.List = cboPesquisarPor.List
    cboOrdenarPor.ListIndex = 0
    With cboOrdem
        .AddItem "Crescente"
        .AddItem "Descrescente"
        .ListIndex = 0
    End With
    
    With Me.lstv
        
        .FullRowSelect = True
        .View = lvwReport
        .Gridlines = True
        .Font.Size = 10
        
        .ColumnHeaders.Add Text:="ID", Width:=50
        .ColumnHeaders.Add Text:="DatCadastro", Width:=70
        .ColumnHeaders.Add Text:="Atividade", Width:=100
        .ColumnHeaders.Add Text:="Cliente", Width:=50
        .ColumnHeaders.Add Text:="PF", Width:=40
        .ColumnHeaders.Add Text:="PJ", Width:=40
        .ColumnHeaders.Add Text:="RazaoSocial", Width:=180
        .ColumnHeaders.Add Text:="NomeFantasia", Width:=100
        .ColumnHeaders.Add Text:="Endereço", Width:=150
        .ColumnHeaders.Add Text:="Bairro", Width:=100
        .ColumnHeaders.Add Text:="UF", Width:=30
        .ColumnHeaders.Add Text:="Cidade", Width:=100
        .ColumnHeaders.Add Text:="CEP", Width:=50
        .ColumnHeaders.Add Text:="DDD", Width:=30
        .ColumnHeaders.Add Text:="Telefone", Width:=80
        .ColumnHeaders.Add Text:="Celular", Width:=80
        .ColumnHeaders.Add Text:="CnpjCpf", Width:=100
        .ColumnHeaders.Add Text:="InscEstadualRG", Width:=100
        .ColumnHeaders.Add Text:="Contato", Width:=100
        .ColumnHeaders.Add Text:="Email", Width:=120
        .ColumnHeaders.Add Text:="Observaçoes", Width:=150

    End With
    
    Me.StatusBar1.Panels(1).Text = "Total de Itens Localizados: " & Me.lstv.ListItems.Count
    
End Sub
Fico muito grato pela ajuda.

Abçs. e Deus no controle.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Mikel Silveira Fraga
Jedi
Jedi
Mensagens: 1173
Registrado em: Sex Mai 27, 2011 3:27 pm
Localização: Governador Valadares - MG
Contato:

Re: Ajuda Conexão VBA com Bando Access

Mensagem por Mikel Silveira Fraga »

Guedelha, bom dia e seja bem vindo ao fórum.

Vou deixar uma dica pra você sobre solicitação de ajuda. Quando se tem um código tão extenso e complexo, como o que você acabou de deixar, o ideal é enviar o modelo para realização dos testes.

Pelo que percebi, você enviou o código apenas do formulário, sendo que o erro pode estar sendo causado por outra parte do projeto, ou até mesmo, pelo banco de dados.

Para conseguir uma ajuda mais eficaz na resolução do seu problema, aconselho enviar o modelo do Excel e do Access que esta construindo, portando informações fictícias.

Tenha uma excelente semana e fique com Deus.


Avatar do usuário
Guedelha
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Dom Jul 08, 2018 5:02 pm

Re: Ajuda Conexão VBA com Bando Access

Mensagem por Guedelha »

Bom dia Mikel
Muito obrigado pela ajuda e dicas, e desculpe-me pelo o atraso no retorno.
Olha segui seus conselhos e encontrei os pontos de interrupções, contudo ao escrever o " sql = "INSERT INTO MovEstoque(seleção da campos)" a quantidade de informações selecionadas ficou muito longa e o VBA apresenta erro. Como posso quebrar a seleção em linhas para que o VBA execute o comando?
Segue em anexo os arquivos.

Desde já agradeço imensamente a ajuda e paciência com o novato.

Fique com Deus, pois ele é tudo neste mundo.
Anexos
CORREÇÕES - TITAN.rar
(844.19 KiB) Baixado 560 vezes


Wagner Morel
Manda bem
Manda bem
Mensagens: 107
Registrado em: Qua Nov 29, 2017 11:51 am
Localização: Fortaleza - CE

Re: Ajuda Conexão VBA com Bando Access

Mensagem por Wagner Morel »

Guedelha

Boa tarde!

Veja, abaixo, código que fiz em uma aplicação minha, relativo a inserção de registros no Banco de Dados em Access. É também uma aplicação com muitos campos e, portanto, tive que dividir o comando SQL para que o VBA pudesse aceitar e executar corretamente. Siga a mesma lógica que creio que dará certo para o seu programa.

Código: Selecionar todos

Private Sub Btn_Inserir_Click()
    ' Cria variável para armazenar comandos SQL
    Dim ComandoSQL As String
    'Cria variável para varrer todos os controles do formulário
    Dim Controle As Control
    'Cria a variável que armazenará o nome dos controles, formatados da forma que o SQL aceita como String
    Dim Valores As String
    
    'Comandos SQL para pegar cada um dos campos do BD
    ComandoSQL = "INSERT INTO Funcionarios (Matrícula, Nome, Telefone_Residencial, Celular, Celular2, "
    ComandoSQL = ComandoSQL & "Endereço_Residencial, Nome_Cônjuge, Celular_Cônjuge, Nome_Filhoa2, Celular_Filhoa2, Nome_Filhoa, "
    ComandoSQL = ComandoSQL & "Celular_Filhoa, Nome_Filhoa3, Celular_Filhoa3, Nome_Contato, Celular_Contato, Tipo_Contato, "
    ComandoSQL = ComandoSQL & "Nome_Contato2, Celular_Contato2, Tipo_Contato2, Tipo_Sanguíneo, Nome_Médico, Celular_Médico, "
    ComandoSQL = ComandoSQL & "Tem_CAMED, Problema_Saúde, Qual_Problema, Medicamento_Saúde, Doença_Congênita, "
    ComandoSQL = ComandoSQL & "Qual_Doença, Medicamentos_Congênitas, Tem_Hipertensão, Horário_Remédio, Medicamento_Hipertensão, "
    ComandoSQL = ComandoSQL & "Epilepsia, Medicamento_Epilepsia, Hemofílico, Medicamento_Hemofílico, Diabético, Medicamento_Diabético, Dependente_Insulina, "
    ComandoSQL = ComandoSQL & "Alergias, Tipos_Alergia, Alérgico_Medicamento, Medicamentos_Alérgicos, Restrição_Alimentar, "
    ComandoSQL = ComandoSQL & "Quais_Restrições, Internação_Cirurgica, Que_Cirurgias, Outras_Obserações, Nome_Mãe, "
    ComandoSQL = ComandoSQL & "Celular_Mãe, Nome_Pai, Celular_Pai) "
    
    
    Valores = "'" & Txt_Matrícula.Text & "', "
    Valores = Valores & "'" & Txt_Nome.Text & "', "
    Valores = Valores & "'" & Txt_Telefone.Text & "', "
    Valores = Valores & "'" & Txt_Celular.Text & "', "
    Valores = Valores & "'" & Txt_Celular2.Text & "', "
    Valores = Valores & "'" & Txt_Endereço.Text & "', "
    Valores = Valores & "'" & Txt_Cônjuge.Text & "', "
    Valores = Valores & "'" & Txt_CelularCônjuge.Text & "', "
    Valores = Valores & "'" & Txt_Filho2.Text & "', "
    Valores = Valores & "'" & Txt_CelularFilho2.Text & "', "
    Valores = Valores & "'" & Txt_Filho.Text & "', "
    Valores = Valores & "'" & Txt_CelularFilho.Text & "', "
    Valores = Valores & "'" & Txt_Filho3.Text & "', "
    Valores = Valores & "'" & Txt_CelularFilho3.Text & "', "
    Valores = Valores & "'" & Txt_Outros.Text & "', "
    Valores = Valores & "'" & Txt_CelularOutros.Text & "', "
    Valores = Valores & "'" & Cmb_TipoRelacionamento.Value & "', "
    Valores = Valores & "'" & Txt_Outros2.Text & "', "
    Valores = Valores & "'" & Txt_CelularOutros2.Text & "', "
    Valores = Valores & "'" & Cmb_TipoRelacionamento2.Value & "', "
    Valores = Valores & "'" & Cmb_TipoSanguíneo.Value & "', "
    Valores = Valores & "'" & Txt_Médico.Text & "', "
    Valores = Valores & "'" & Txt_CelularMédico.Text & "', "
    
    If Opt_CamedSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_CamedNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    If Opt_ProblemaSaúdeSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_ProblemaSaúdeNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_ProblemasDeSaúde.Text & "', "
    Valores = Valores & "'" & Txt_RemédiosProbSaúde.Text & "', "
    
    If Opt_DoençaCongênitaSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_DoençaCongênitaNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_DoençasCongênitas.Text & "', "
    Valores = Valores & "'" & Txt_RemédiosDoençasCongênitas.Text & "', "
    
    If Opt_HipertensãoSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_HipertensãoNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_HoraRemédio.Text & "', "
    Valores = Valores & "'" & Txt_RemédiosHipertensão.Text & "', "
    
    If Opt_EpilepsiaSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_EpilepsiaNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_RemédioEpilepsia.Text & "', "
    
    If Opt_HemofílicoSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_HemofílicoNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_RemédioHemofílico.Text & "', "
    
    If Opt_DiabéticoSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_DiabéticoNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_RemédioDiabético.Text & "', "
    
    If Opt_DependenteInsulinaSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_DependenteInsulinaNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    If Opt_AlergiasSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_AlergiasNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_TiposAlergia.Text & "', "
    
    If Opt_AlergiaMedicamentosSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_AlergiaMedicamentosNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_AlergiaMedicamentos.Text & "', "
    
    If Opt_RestriçõesAlimentarSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_RestriçõesAlimentarNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_RestriçõesAlimentar.Text & "', "
    
    If Opt_IntervençãoCirúrgicaSIM.Value = True Then
        Valores = Valores & "'Sim', "
    ElseIf Opt_IntervençãoCirúrgicaNÃO.Value = True Then
        Valores = Valores & "'Não', "
    End If
    
    Valores = Valores & "'" & Txt_IntervençãoCirúrgica.Text & "', "
    
    Valores = Valores & "'" & Txt_Observações.Text & "', "
    Valores = Valores & "'" & Txt_Mãe.Text & "', "
    Valores = Valores & "'" & Txt_CelularMãe.Text & "', "
    Valores = Valores & "'" & Txt_Pai.Text & "', "
    Valores = Valores & "'" & Txt_CelularPai.Text & "'"
    
    ComandoSQL = ComandoSQL & "VALUES (" & Valores & ")"
        
    'Chama a rotina que faz a conexão com o BD
    Call Conecta
    
    'Atribui a variável de Objeto de BD a execução dos comandos SQL
    'Set consulta = banco.OpenRecordset(ComandoSQL)
    banco.Execute (ComandoSQL)
        
    'Fecha o Recorset e a conexão com o BD
    banco.Close
        
    'Chama a rotina que desconecta do BD (libera variáveis objeto de BD)
    Call Desconecta
        
    'Exibe mensagem de sucesso na inclusão do registro
    MsgBox "Dados Inseridos com Sucesso!", vbDefaultButton1, "INSERÇÃO"
        
    '===================================================
    'Limpa todos os campos para permitir novas inserções
    '===================================================
    
    'Laço para percorrer cada um dos controles do UserForm
    For Each Controle In Frm_Inserir.Controls
        'Se o controle for um dos que serão salvos no BD
        If Left(Controle.Name, 5) <> "Label" And Left(Controle.Name, 5) <> "Frame" And Left(Controle.Name, 3) <> "Btn" Then
            'Se o controle for um botão de opção e o valor dele for FALSO
            If Left(Controle.Name, 3) <> "Opt" Then
                Controle.Value = ""
            End If
        End If
    Next
    
    Btn_Inserir.Enabled = False
        
    'Move a rolagem do formulário para o início (topo do mesmo)
    Frm_Inserir.Scroll (fmScrollActionLineUp)
    
    'Devolve o cursor para o campo Matrícula
    Txt_Matrícula.SetFocus
End Sub


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Guedelha
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Dom Jul 08, 2018 5:02 pm

Re: Ajuda Conexão VBA com Bando Access

Mensagem por Guedelha »

Boa noite!!

Wagner muito obrigado pela ajuda e tentarei adequar este código ao meu projeto.

Grato vou tentar.


Avatar do usuário
kedim43
Colaborador
Colaborador
Mensagens: 45
Registrado em: Dom Fev 05, 2012 3:12 pm
Localização: Goias
Contato:

Re: Ajuda Conexão VBA com Bando Access

Mensagem por kedim43 »

Boa noite. pelo que vi... há formas mais fáceis de se realizar esta interação... Vamos a Elas...!!!
Altere os campos de texto para sua aplicação. Não esqueça... Habilite o comando StatusBar

Conexão
Sub Conecta()

'Rotina para fazer a conexão com o Banco de Dados em Access
Set banco = OpenDatabase(ThisWorkbook.Path & "\Nome do Banco de Dados.mdb", False, False, "MS Access;PWD=Senha do Banco")

End Sub

Rotina para Registro
Sub Registrar() '--> Registrar Informações

resposta = MsgBox("Registrar informações?", 36, "Tool Time © 2018 - PCM NioBras | Todos os direitos reservados")

If resposta = (vbYes) Then

'Ação do Formulário

If Me.TextBox_Grupo.Text = "" Then
MsgBox ("Campo Funcionário Obrigatório!"), vbInformation, ("Tool Time © 2018 - PCM NioBras | Todos os direitos reservados")
Me.TextBox_Grupo.SetFocus
Exit Sub
End If

If Me.TextBox_Id.Text = "" Then
MsgBox ("Campo Id Obrigatório!"), vbInformation, ("Tool Time © 2018 - PCM NioBras | Todos os direitos reservados")
Me.TextBox_Grupo.SetFocus
Exit Sub
End If


'Cria variável que armazena os comandos SQL
Dim ComandoSQL As String


'Armazena na variável o comando que fará a consulta SQL no BD Access
ComandoSQL = "select * from Funcionario"
'Chama a rotina que faz a conexão com o BD
Call Conecta


'Atribui a variável de Objeto de BD a execução dos comandos SQL
Set consulta = banco.OpenRecordset(ComandoSQL)

'Enquanto consulta (variável objeto do BD)...
With consulta


'Abre o Recordset do BD para inserção
.AddNew

'Armazena em cada um dos campos do BD os valores constantes nas caixas de texto e combo do formulário
'.Fields("ID") = Me.TextBox_Codigo
.Fields("Funcionarios") = Me.TextBox_Grupo
.Fields("ID") = Me.TextBox_Id
.Fields("Grupo") = Me.TextBox_GTrabalho

'Efetiva a atualização do BD
.Update

End With

'Fecha o Recorset e a conexão com o BD
consulta.Close
banco.Close



'Chama a rotina que desconecta do BD (libera variáveis objeto de BD)
Call Desconecta

Me.TextBox_Grupo.Text = ""
Me.TextBox_Id.Text = ""
Me.TextBox_GTrabalho.tex = ""
Me.TextBox_Codigo.tex = ""

Me.TextBox_Grupo.SetFocus




'Abandona a subrotina
Exit Sub



End If

If resposta = vbNo Then

End If
End Sub

Rotina para Edição
Sub Alterar() '--> Alterar Informações

StatusBar1.Panels(7).Text = "Atualizando informações..."

'Ações do comando

resposta = MsgBox("Atualizar as informações?", 36, "Tool Time © 2018 - PCM NioBras | Todos os direitos reservados")

If resposta = (vbYes) Then

On Error GoTo TratErr



'Ação do Formulário

'Cria variável que armazena os comandos SQL
Dim ComandoSQL As String

'Armazena na variável o comando que fará a consulta SQL no BD Access
ComandoSQL = "select * from Tool_Time where Codigo like '" & Me.TextBox_Codigo & "' "

'Chama a rotina que faz a conexão ao Banco de Dados
Call Conecta

'Atribui a variável global do tipo Recorset, os comandos SQL que devem ser executados
Set consulta = banco.OpenRecordset(ComandoSQL)

'****Abre o Recordset do BD para edição
consulta.Edit

'Atribui cada valor dos controles aos respectivos campos existentes na tabela tabela_clientes


consulta("Id") = Me.Text_codigo.Text
consulta("Funcionario") = Me.TextBox_Funcionário.Text
consulta("Data") = Me.DTPicker_Data
consulta("Grupo") = Me.ComboBox_Grupo.Text
consulta("Desvio") = Me.ComboBox_Desvio.Text
consulta("Local") = Me.TextBox_Local.Text
consulta("Inicio") = Me.TextBox_Inicio.Text
consulta("Fim") = Me.TextBox_Fim.Text
consulta("Total") = Me.TextBox_Total.Text
consulta("Apontador") = Me.ComboBox_Observador.Text
consulta("Justificativa") = Me.TextBox_Justificativa.Text
consulta("Data_Apontamento") = Date



'Atualiza o Recordset do BD
consulta.Update

'Chama a rotina que libera as variáveis de objeto do BD
Call Desconecta




StatusBar1.Panels(11).Text = "...Informações atualizadas!"
StatusBar1.Panels(7).Text = "...Navegando no Sistema!"

Me.Text_codigo.SetFocus


TratErr:
If Err.Number <> 0 Then
Form_Menu.StatusBar1.Panels(11).Text = Err.Number & " - " & Err.Description
Form_Menu.StatusBar1.Panels(11).Text = " "
StatusBar1.Panels(11).Text = Err.Number & " - " & Err.Description
StatusBar1.Panels(7).Text = "...Navegando no Sistema!"

End If
Call Limpar

End If

If resposta = vbNo Then
StatusBar1.Panels(7).Text = "...Navegando no Sistema!"
End If
End Sub

Rotina para Exclusão
Sub Excluir() '--> Excluir Informações

StatusBar1.Panels(7).Text = "Excluindo informações..."

'Ações do comando

resposta = MsgBox("Excluir as informações?", 36, "Tool Time © 2018 - PCM NioBras | Todos os direitos reservados")

If resposta = (vbYes) Then

On Error GoTo TratErr

'Ação do Formulário

'Cria variável que armazena os comandos SQL
Dim ComandoSQL As String

'Armazena na variável o comando que fará a consulta SQL no BD Access
ComandoSQL = "select * from Tool_Time where Codigo like '" & Me.TextBox_Codigo & "' "

'Chama a rotina de conexão com o BD
Call Conecta

'Atribui a variável de onjeto de BD a execução dos comnados SQL
Set consulta = banco.OpenRecordset(ComandoSQL)

'Armazena a resposta do usuário
resposta = MsgBox("Você está prestes a excluir o registro selecionado! Confirma?", vbQuestion + vbYesNo, "Tool Time © 2018 - PCM NioBras | Todos os direitos reservados")

'Se o usuário responder SIM (quer excluir o registro)...
If resposta = vbYes Then

'Abre o Rescordset para exclusão de registros (apaga o registro atual)
consulta.Delete


'Armazena na variável o comando que fará a consulta SQL no BD Access
ComandoSQL = "select * from Tool_Time"

'Chama a rotina que faz a conexão com o BD
Call Conecta

'Atribui a variável objeto de BD a execução dos comandos SQL
Set consulta = banco.OpenRecordset(ComandoSQL)

'Tratamento de erro de acesso aos dados. Se houver erro, desvia o comando para o rótulo Sai
On Error Resume Next

'--->Ação abaixo



'Chama a rotina de desconexão com o BD (libera variáveis de objeto do BD)
Call Desconecta


Else 'Caso o usuário responda Não (não quer excluir o registro atual)...

'Chama a rotina de desconexão com o BD (libera variáveis de objeto do BD)
Call Desconecta

'Abandona a subrotina
Exit Sub
End If


StatusBar1.Panels(11).Text = "...Informações excluídas!"
StatusBar1.Panels(7).Text = "...Navegando no Sistema!"

Me.Text_codigo.SetFocus

TratErr:
Form_Menu.StatusBar1.Panels(11).Text = Err.Number & " - " & Err.Description
Form_Menu.StatusBar1.Panels(11).Text = " "
StatusBar1.Panels(11).Text = Err.Number & " - " & Err.Description
StatusBar1.Panels(7).Text = "...Navegando no Sistema!"

End If



If resposta = vbNo Then
StatusBar1.Panels(7).Text = "...Navegando no Sistema!"
End If
End Sub


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder