none
descrição do código de banco de dados. RRS feed

  • Pergunta

  • Prezados colegas, não sou programados, sou apenas alguém que gosta de tentar aprender VBA.

    Estou aos poucos melhorando, aprendendo por comparação e testando modificações.

    Bom, há tempos que tento fazer um banco de dados em VBA, e já consigo realizar uma parte, a da inserção dos dados. Porém, na parte de pesquisa e alteração ainda não consigo. Eu encontrei um banco de dados aqui no site, tem um código que me parece não muito complicado, mas precisaria que alguem me dissesse o que cada linha faz exatamente e por quê?

    Alguém poderia me ajudar detalhadamente em linguagem não técnica?

    As coisas que descubro estou transcrevendo e fazendo um manual de linhas de código de VBA, mas para pessoas que como eu gosta, mas não tem base para fazer muitas coisas. 

    Alguém se dispõem?

    Segue código e vc pode selecionar um bloco e explicar se entender melhor.:

    Option Explicit
    
    Const colCodigo As Integer = 1
    Const colDescricao_da_Conta As Integer = 2
    Const coldata_vencimento As Integer = 3
    Const colvalor As Integer = 4
    Const coldata_pagto As Integer = 5
    Const colStatus As Integer = 6
    Const indiceMinimo As Byte = 2
    Const corDisabledTextBox As Long = -2147483633
    Const corEnabledTextBox As Long = -2147483643
    
    Private wscontas_a_pagar As Worksheet
    Private indiceRegistro As Long
    
    Private Sub btnCancelar_Click()
        btnOK.Enabled = False
        btnCancelar.Enabled = False
        Call DesabilitaControles
        Call CarregaDadosInicial
        Call HabilitaBotoesAlteracao
    End Sub
    
    Private Sub btnfechar_Click()
        Unload frmcontas_a_Pagar
    End Sub
    
    Private Sub btnimprimir_Click()
        curprtarea = ActiveSheet.PageSetup.PrintArea
        MyPrtArea = "B1:J10"
        ActiveSheet.PageSetup.PrintArea = MyPrtArea
        ActiveSheet.PrintOut
        ActiveSheet.PageSetup.PrintArea = curprtarea
    End Sub
    
    Private Sub btnOK_Click()
        Dim proximoId As Long
    
        'Altera
        If optAlterar.Value Then
            Call SalvaRegistro(CLng(txtCodigoConta.Text), indiceRegistro)
            lblMensagem.Caption = "Registro salvo com sucesso"
        End If
        'Novo
        If optNovo.Value Then
            proximoId = PegaProximoId
            'pega a próxima linha
            Dim proximoIndice As Long
            proximoIndice = wscontas_a_pagar.UsedRange.Rows.Count + 1
            Call SalvaRegistro(proximoId, proximoIndice)
            txtCodigoConta = proximoId
            lblMensagem.Caption = "Registro salvo com sucesso"
        End If
        'Excluir
        If optExcluir.Value Then
            Dim result As VbMsgBoxResult
            result = MsgBox("Deseja excluir o registro nº " & txtCodigoConta.Text & " ?", vbYesNo, "Confirmação")
    
            If result = vbYes Then
                wscontas_a_pagar.Range(wscontas_a_pagar.Cells(indiceRegistro, colCodigo), wscontas_a_pagar.Cells(indiceRegistro, colCodigo)).EntireRow.Delete
                Call CarregaDadosInicial
                lblMensagem.Caption = "Registro excluído com sucesso"
            End If
        End If
    
        Call HabilitaBotoesAlteracao
        Call DesabilitaControles
    
    End Sub
    
    Private Sub btnPesquisar_Click()
        frmPesqConta.Show
    End Sub
    Private Sub optAlterar_Click()
        If txtCodigoConta.Text <> vbNullString And txtCodigoConta.Text <> "" Then
            Call HabilitaControles
            Call DesabilitaBotoesAlteracao
            'dá o foco ao primeiro controle de dados
            txtDescricaoConta.SetFocus
        Else
            lblMensagem.Caption = "Não há registro a ser alterado"
        End If
    End Sub
    
    Private Sub optExcluir_Click()
        If txtCodigoConta.Text <> vbNullString And txtCodigoConta.Text <> "" Then
            Call DesabilitaBotoesAlteracao
            lblMensagem.Caption = "Modo de exclusão. Confira os 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 HabilitaControles
        Call DesabilitaBotoesAlteracao
        'dá o foco ao primeiro controle de dados
        txtDescricaoConta.SetFocus
    End Sub
    
    Private Sub Txtvalor_Exit(ByVal Cancel As MSForms.ReturnBoolean)
        txtvalor.Text = Format(txtvalor.Text, "#,##0.00")
    End Sub
    
    Private Sub UserForm_Initialize()
        Set wscontas_a_pagar = ThisWorkbook.Worksheets("Contas_a_Pagar")
        Call HabilitaBotoesAlteracao
        Call CarregaDadosInicial
        Call DesabilitaControles
       ' EscondeX Me
    '    lblcontaspagar = ThisWorkbook.Worksheets("empresa").Range("b2")
        cmbcondicao.AddItem "Pago"
        cmbcondicao.AddItem "A Pagar"
    End Sub
    Private Sub btnAnterior_Click()
        If indiceRegistro > indiceMinimo Then
            indiceRegistro = indiceRegistro - 1
        End If
        If indiceRegistro > 1 Then
            Call CarregaRegistro
        End If
    End Sub
    
    Private Sub btnPrimeiro_Click()
        indiceRegistro = indiceMinimo
        If indiceRegistro > 1 Then
            Call CarregaRegistro
        End If
    End Sub
    
    Private Sub btnProximo_Click()
        If indiceRegistro < wscontas_a_pagar.UsedRange.Rows.Count Then
            indiceRegistro = indiceRegistro + 1
        End If
        If indiceRegistro > 1 Then
            Call CarregaRegistro
        End If
    End Sub
    
    Private Sub btnUltimo_Click()
        indiceRegistro = wscontas_a_pagar.UsedRange.Rows.Count
        If indiceRegistro > 1 Then
            Call CarregaRegistro
        End If
    End Sub
    
    Private Sub CarregaDadosInicial()
        indiceRegistro = 2
        Call CarregaRegistro
    End Sub
    
    Private Sub CarregaRegistro()
    'carrega os dados do primeiro registro
        With wscontas_a_pagar
            If Not IsEmpty(.Cells(indiceRegistro, colDescricao_da_Conta)) Then
                Me.txtCodigoConta.Text = .Cells(indiceRegistro, colCodigo).Value
                Me.txtDescricaoConta.Text = .Cells(indiceRegistro, colDescricao_da_Conta).Value
                Me.txtvencimento.Text = .Cells(indiceRegistro, coldata_vencimento).Value
                Me.txtpagto = .Cells(indiceRegistro, coldata_pagto).Value
                Me.txtvalor.Text = .Cells(indiceRegistro, colvalor).Value
                cmbcondicao.Text = .Cells(indiceRegistro, colStatus).Value
            End If
        End With
    
        Call AtualizaRegistroCorrente
    End Sub
    
    Public Sub CarregaRegistroPorIndice(ByVal indice As Long)
    'carrega os dados do registro baseado no índice
        indiceRegistro = indice
    
        Call CarregaRegistro
    End Sub
    
    Private Sub SalvaRegistro(ByVal Id As Long, ByVal indice As Long)
        With wscontas_a_pagar
            .Cells(indice, colCodigo).Value = Id
            .Cells(indice, colDescricao_da_Conta).Value = Me.txtDescricaoConta.Text
            .Cells(indice, coldata_vencimento).Value = txtvencimento.Value
            .Cells(indice, coldata_pagto).Value = txtpagto.Value
            .Cells(indice, colvalor).Value = Me.txtvalor.Text
            .Cells(indice, colStatus).Value = cmbcondicao
        End With
    
        Call AtualizaRegistroCorrente
    End Sub
    
    Private Function PegaProximoId() As Long
        Dim rangeIds As Range
        'pega o range que se refere a toda a coluna do código (id)
        Set rangeIds = wscontas_a_pagar.Range(wscontas_a_pagar.Cells(indiceMinimo, colCodigo), wscontas_a_pagar.Cells(wscontas_a_pagar.UsedRange.Rows.Count, colCodigo))
        PegaProximoId = WorksheetFunction.Max(rangeIds) + 1
    End Function
    
    Private Sub AtualizaRegistroCorrente()
        lblNavigator.Caption = indiceRegistro - 1 & " de " & wscontas_a_pagar.UsedRange.Rows.Count - 1
        lblMensagem.Caption = ""
    End Sub
    
    Private Sub LimpaControles()
        Me.txtCodigoConta.Text = ""
        Me.txtDescricaoConta.Text = ""
        Me.txtvencimento.Text = ""
        Me.txtpagto.Text = ""
        Me.txtvalor.Text = ""
        cmbcondicao.Text = ""
        
    End Sub
    
    Private Sub HabilitaControles()
    'Me.txtCodigoConta.Locked = False
        Me.txtDescricaoConta.Locked = False
        
        Me.txtDescricaoConta.BackColor = corEnabledTextBox
        Me.txtvencimento.BackColor = corEnabledTextBox
        Me.txtpagto.BackColor = corEnabledTextBox
        Me.txtvalor.BackColor = corEnabledTextBox
        cmbcondicao.BackColor = corEnabledTextBox
    End Sub
    
    Private Sub DesabilitaControles()
    'Me.txtCodigoConta.Locked = True
        Me.txtDescricaoConta.Locked = True
        
        Me.txtDescricaoConta.BackColor = corDisabledTextBox
        Me.txtvencimento.BackColor = corDisabledTextBox
        Me.txtpagto.BackColor = corDisabledTextBox
        Me.txtvalor.BackColor = corDisabledTextBox
        cmbcondicao.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
    
    Public Function ProcuraIndiceRegistroPodId(ByVal Id As Long) As Long
        Dim i As Long
        Dim retorno As Long
        Dim encontrado As Boolean
    
        i = indiceMinimo
        With wscontas_a_pagar
            Do While Not IsEmpty(.Cells(i, colCodigo))
                If .Cells(i, colCodigo).Value = Id Then
                    retorno = i
                    encontrado = True
                    Exit Do
                End If
                i = i + 1
            Loop
        End With
    
        'caso não encontre o registro, retorna -1
        If Not encontrado Then
            retorno = -1
        End If
    
        ProcuraIndiceRegistroPodId = i
    End Function
    
    
    
    
    
    
    E outra parte na busca:
    
    
    
    
    
    Option Explicit
    
    'constantes para auxiliar na verificação do código
    Private Const Ascendente As Byte = 0
    Private Const Descendente As Byte = 1
    Private wscontas_a_pagar As Worksheet
    
    Private Sub btnfechar_Click()
        Unload frmPesqConta
    End Sub
    Private Sub btnfiltrar_Click()
    'Se os Campos Datas estiverem Vazios
    If txtdtinicio <> "" And txtdtfim <> "" Then
    
        Call PopulaListBox(txtdtinicio.Text, txtdtfim.Text)
        'Total Geral
        Dim lItem As Double
        Dim i As Double
        Dim x As Double
        Dim valor As Double
        Dim valor1 As Double
        Dim valor2 As Double
        lbltotal = 0
        lbltotal1 = 0
        lbltotal2 = 0
        lblmsg1 = ""
        lblmsg2 = ""
        Dim sPagam
        
        'Total GERAL
        'If lbltotal.Caption = "" Then lbltotal.Caption = 0
        
        'Preenche lblTotal com o TOTAL GERAL Pagos e A Pagar
            For lItem = 1 To lstLista.ListCount - 1
                valor = lstLista.List(lItem, 3) * 1
                lbltotal = (lbltotal.Caption) + (valor)
            Next
            lblMsg = "Total:"
            lbltotal = Format(lbltotal, "R$ #,##0.00")
            
        'Total A Pagar
        'If ["status"] = "Pago" Then lbltotal1.Caption = 0
        'lbltotal1.Caption = 0
        
         'Total A Pagar
            For x = 1 To lstLista.ListCount - 1
                'Captura o Valor na Coluna STATUS
                sPagam = lstLista.List(x, 5)
               'Se valor =  Pago
               If sPagam = "Pago" Then
                    valor1 = lstLista.List(x, 3) * 1
                    lbltotal1 = (lbltotal1.Caption) + (valor1)
                'Se Não valor = A Pagar
                Else: sPagam = "A Pagar"
                    valor2 = lstLista.List(x, 3) * 1
                    lbltotal2 = (lbltotal2.Caption) + (valor2)
                End If
                'End If
            Next
                
                'Eu ja deixaria estas mensagens direto nos Label, são desnecessárias
                'Evitando de ter carrega-las, seria umas linhas a menos na rotina
                lblmsg1 = "Total Pago:"
                lbltotal1 = Format(lbltotal1, "R$ #,##0.00")
                    lblmsg2 = "Total A Pagar:"
                    lbltotal2 = Format(lbltotal2, "R$ #,##0.00")
       
       ' If ["status"] = "A Pagar" Then lbltotal2.Caption = 0
       '     For i = 1 To lstLista.ListCount - 1
       '         valor2 = lstLista.List(i, 3) * 1
       '         lbltotal2 = (lbltotal2.Caption) + (valor2)
       '     Next
    Else
            MsgBox "Campos - Datas Inicial ou Final em branco !!!"
            'Limpa ListBox
            lstLista.Clear
     End If
    End Sub
    
    Private Sub lstLista_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        If lstLista.ListIndex > 0 Then
            Dim indiceRegistro As Long
            indiceRegistro = frmcontas_a_Pagar.ProcuraIndiceRegistroPodId(lstLista.List(lstLista.ListIndex, 0))
            If indiceRegistro <> -1 Then
                Call frmcontas_a_Pagar.CarregaRegistroPorIndice(indiceRegistro)
            End If
            Unload Me
        Else
            lblMensagens.Caption = "É preciso selecionar um item válido na lista"
        End If
    End Sub
    
    Private Sub UserForm_Initialize()
       ' EscondeX Me
        Call PopulaListBox(vbNullString, vbNullString)
        'cmbstatus.AddItem ""
        'cmbstatus.AddItem "Pago"
        'cmbstatus.AddItem "A Pagar"
        
    End Sub
    Private Sub PopulaListBox(ByVal txtdtinicio, txtdtfim)
    
        On Error GoTo TrataErro
    
        Dim conn As ADODB.Connection
        Dim rst As ADODB.Recordset
        Dim sql As String
        Dim sqlWhere As String
        Dim sqlOrderBy As String
        Dim i As Integer
        Dim campo As Field
        Dim myArray() As Variant
        
        Set conn = New ADODB.Connection
        With conn
            .Provider = "Microsoft.JET.OLEDB.4.0"
            .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
            .Open
        End With
    
        'sql = "SELECT * FROM [Contas_a_Pagar$]"
        
        sql = "Select * From [Contas_a_Pagar$] Where [DATA_VENCIMENTO] >= #" & Format(txtdtinicio, "mm/dd/yyyy") & "#   AND DATA_VENCIMENTO <= #" & Format(txtdtfim, "mm/dd/yyyy") & "#ORDER BY Status"
          
        'faz a união da string SQL com a cláusula WHERE
        If sqlWhere <> vbNullString Then
            sql = sql & " WHERE " & sqlWhere
        End If
    
        Set rst = New ADODB.Recordset
        With rst
            .ActiveConnection = conn
            .Open sql, conn, adOpenDynamic, _
                  adLockBatchOptimistic
        End With
    
        'pega o número de registros para atribuí-lo ao listbox
        lstLista.ColumnCount = rst.Fields.Count
        lstLista.ColumnWidths = "1 cm;4 cm;3 cm;2 cm;2 cm;2 cm;1"
    
        'coloca as linhas do RecordSet num Array, se houver linhas neste
        If Not rst.EOF And Not rst.BOF Then
            myArray = rst.GetRows
            'troca linhas por colunas no Array
            myArray = Array2DTranspose(myArray)
            'atribui o Array ao listbox
            lstLista.List = myArray
            'adiciona a linha de cabeçalho da coluna
            lstLista.AddItem , 0
            'preenche o cabeçalho
            For i = 0 To rst.Fields.Count - 1
                lstLista.List(0, i) = rst.Fields(i).Name
            Next i
            'seleciona o primeiro item da lista
            lstLista.ListIndex = 0
        Else
            lstLista.Clear
        End If
    
        'atualiza o label de mensagens
        If lstLista.ListCount <= 0 Then
            lblMensagens.Caption = lstLista.ListCount & " registros encontrados"
        Else
            lblMensagens.Caption = lstLista.ListCount - 1 & " registros encontrados"
        End If
    
        ' Fecha o conjunto de registros.
        Set rst = Nothing
        ' Fecha a conexão.
        conn.Close
    
    TrataSaida:
        Exit Sub
    TrataErro:
        Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
        Resume TrataSaida
    End Sub
    
    Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
    'NomeDoControle
        If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
            If sqlWhere <> vbNullString Then
                sqlWhere = sqlWhere & " AND"
            End If
            sqlWhere = sqlWhere & " " & NomeCampo & " LIKE '%" & Trim(Me.Controls(NomeControle).Text) & "%'"
        End If
    End Sub
    
    
    'Faz a transpasição de um array, transformando linhas em colunas
    Private Function Array2DTranspose(avValues As Variant) As Variant
        Dim lThisCol As Long, lThisRow As Long
        Dim lUb2 As Long, lLb2 As Long
        Dim lUb1 As Long, lLb1 As Long
        Dim avTransposed As Variant
    
        If IsArray(avValues) Then
            On Error GoTo ErrFailed
            lUb2 = UBound(avValues, 2)
            lLb2 = LBound(avValues, 2)
            lUb1 = UBound(avValues, 1)
            lLb1 = LBound(avValues, 1)
    
            ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
            For lThisCol = lLb1 To lUb1
                For lThisRow = lLb2 To lUb2
                    avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
                Next
            Next
        End If
    
        Array2DTranspose = avTransposed
        Exit Function
    
    ErrFailed:
        Debug.Print Err.Description
        Debug.Assert False
        Array2DTranspose = Empty
        Exit Function
        Resume
    End Function
    
    
    Agradeço a todos pelo auxílio e assim que estiver em condições coloco minhas anotações no forum.

    sexta-feira, 16 de setembro de 2011 22:20

Respostas

  • Boa noite eric

     

    Fiz alguns comentários nas primeiras linhas do código

    em uma nova oportunidade tentarei comentar mais algumas

    dica: marque pontos de interrupção no codigo e vai debugando linha a linha

    que assim vc vai ver o que cada linha está fazendo.

    para debugar linha a linha vc utiliza a tecla F8

     

     


    ' Cria variaveis constantes = elas nao podem ser modificadas durante a execução do codigo
    ' somente durante a criação do projeto.

    Const colCodigo As Integer = 1
    Const colDescricao_da_Conta As Integer = 2
    Const coldata_vencimento As Integer = 3
    Const colvalor As Integer = 4
    Const coldata_pagto As Integer = 5
    Const colStatus As Integer = 6
    Const indiceMinimo As Byte = 2
    Const corDisabledTextBox As Long = -2147483633
    Const corEnabledTextBox As Long = -2147483643

    Private wscontas_a_pagar As Worksheet
    Private indiceRegistro As Long

    Private Sub btnCancelar_Click()

        btnOK.Enabled = False ' desabilta o botão
        btnCancelar.Enabled = False ' desabilta o botão
        Call DesabilitaControles ' chama a função
        Call CarregaDadosInicial ' chama a função
        Call HabilitaBotoesAlteracao ' chama a função
    End Sub

    Private Sub btnfechar_Click()
        Unload frmcontas_a_Pagar ' Descarrega o formulário
    End Sub

    Private Sub btnimprimir_Click()
        curprtarea = ActiveSheet.PageSetup.PrintArea ' Armazena a variavel a area original de impressão da planilha
        MyPrtArea = "B1:J10" //Atribui a variavel a area q devera ser impressa
        ActiveSheet.PageSetup.PrintArea = MyPrtArea ' Define a area de impressão da planilha com os valores da segunda variavel
        ActiveSheet.PrintOut // Imprime
        ActiveSheet.PageSetup.PrintArea = curprtarea ' Define a area de impressão da planilha com os valores da primeira variavel
    End Sub

    Private Sub btnOK_Click()
        Dim proximoId As Long ' declara variavel

        'Altera
        If optAlterar.Value Then ' confere se o botão de opção esta marcado
            Call SalvaRegistro(CLng(txtCodigoConta.Text), indiceRegistro) ' chama a função passando 2 parametros para realização da operação
            lblMensagem.Caption = "Registro salvo com sucesso" ' modifica o texto de um rotulo
        End If
        'Novo
        If optNovo.Value Then ' confere se o botão de opção esta marcado
            proximoId = PegaProximoId ' atribui a variavel o valor de retorno da função
            'pega a próxima linha
            Dim proximoIndice As Long ' declara variavel
            proximoIndice = wscontas_a_pagar.UsedRange.Rows.Count + 1 ' atribui a variavel o valor do prox indice
            Call SalvaRegistro(proximoId, proximoIndice) ' chama a função passando 2 parametros para realização da operação
            txtCodigoConta = proximoId ' modifica o texto de uma caixa de texto
            lblMensagem.Caption = "Registro salvo com sucesso"' modifica o texto de um rotulo
        End If
        'Excluir
        If optExcluir.Value Then ' modifica o texto de um rotulo
            Dim result As VbMsgBoxResult ' declara variavel
            result = MsgBox("Deseja excluir o registro nº " & txtCodigoConta.Text & " ?", vbYesNo, "Confirmação")' exibe uma caixa de mensagem com os botoes de sim ou nao

            If result = vbYes Then ' confere se a opção clicada foi sim
                wscontas_a_pagar.Range(wscontas_a_pagar.Cells(indiceRegistro, colCodigo), wscontas_a_pagar.Cells(indiceRegistro, colCodigo)).EntireRow.Delete ' exclui o dado selecionado da planilha
                Call CarregaDadosInicial ' chama a função
                lblMensagem.Caption = "Registro excluído com sucesso" ' modifica o texto de um rotulo
            End If
        End If

        Call HabilitaBotoesAlteracao ' chama a função
        Call DesabilitaControles ' chama a função

    End Sub

     

    Obs: Caso algum comentário esteja errado por favor corrija para que possa aprender tbm

     

    abrç

    domingo, 18 de setembro de 2011 01:34