Usuário com melhor resposta
descrição do código de banco de dados.

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.
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 SubObs: Caso algum comentário esteja errado por favor corrija para que possa aprender tbm
abrç
- Sugerido como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 23:00
- Marcado como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 23:00