Um sistema de cadastro de clientes bem estruturado e eficiente é aquele que permite acelerar o cadastro, por exemplo, através da busca de informações em banco de dados na web. Nesse Post você verá como criar um Sistema de cadastro de clientes com consulta de CNPJ usando Excel VBA.
Nesse sistema teremos a presença do padrão JSON, que iremos utilizar para trazer as informações de CNPJ dos clientes tipo pessoa Jurídica. Em resumo, podemos que dizer que o JSON é um padrão para armazenamento e troca de informações entre sistemas extremamente rápido e leve.
Além da busca de dados de CNPJ, uma outra funcionalidade especifica desse sistema, é a criação de pastas em um local especifico e armazenamento de fotos dentro dessa pasta. Para isso iremos utilizar a Propriedade Application.FileDialog (Excel). Nesse caso, ao buscar uma imagem, o sistema irá identificar o endereço dessa imagem, e então copiar o arquivo para uma outra pasta já com o nome desejado. Caso a pasta de destino já exista, ele irá apenas copiar a imagem para dentro da pasta.
Private Sub NvImage_Click()
Dim Arquivo As Office.FileDialog
Dim ArqImag As String
'msoFileDialogFilePicker - Permite selecionar um arquivo
'msoFileDialogFolderPicker - Permite selecionar uma pasta
'msoFileDialogOpen - Permite abrir um arquivo
'msoFileDialogSaveAs - Permite salvar um arquivo
Set Arquivo = Application.FileDialog(msoFileDialogFilePicker)
With Arquivo
.Filters.Clear
.Title = "Selecione a Imagem desejada"
.Filters.Add "Formato JPEG", "*.jpg", 1
.AllowMultiSelect = False
If .Show = True Then
ArqImag = .SelectedItems(1)
imgCliente.Picture = LoadPicture(ArqImag)
End If
End With
txtImagem.Value = ArqImag
Set Arquivo = Nothing
End Sub
Private Sub DltImage_Click()
Dim DestArq As String
Dim Perg As String
Dim wbk As Workbook
Set wbk = Workbooks("CadastroClientes.xlsm")
If txtCodigo.Value = "" Then
MsgBox "Sem Imagem de Cliente para excluir!", vbExclamation, "Imagem vazia!"
Exit Sub
Else
Perg = MsgBox("Deseja realmente excluir o a imagem?", vbYesNo, "Excluir dados")
If Perg = vbYes Then
DestArq = wbk.Path & "\PicClientes\" & txtCodigo.Value & ".jpg"
Call ExcluiPicClientes(DestArq)
txtImagem.Value = ""
imgCliente.Picture = LoadPicture("")
imgClienteAlt.Picture = LoadPicture("")
End If
End If
Set wbk = Nothing
End Sub
Sub RegistrarDados()
Dim Data As Date
Dim Aniv As Date
Dim Dia As String
Dim Mes As String
Dim uval As Long
Dim ulin As Long
Dim wPlan As Worksheet
On Error Resume Next
Aniv = txtAniversario.Value
Dia = Format(Aniv, "dd")
Mes = Format(Aniv, "mmmm")
Call CadastroMd.UltimaLinha(ulin, uval)
Set wPlan = Planilha4
wPlan.Activate
With wPlan
.Cells(ulin, 1).Value = Format(txtCodigo.Value, "0")
.Cells(ulin, 2).Value = txtNome.Value
.Cells(ulin, 3).Value = txtCelular.Value
.Cells(ulin, 4).Value = cboPessoa.Value
.Cells(ulin, 5).Value = txtCpf.Value
.Cells(ulin, 6).Value = txtFantasia.Value
.Cells(ulin, 7).Value = txtRg.Value
.Cells(ulin, 8).Value = txtEmissao.Value
.Cells(ulin, 9).Value = cboUfEmissao.Value
.Cells(ulin, 10).Value = cboSexo.Value
.Cells(ulin, 11).Value = txtEndereco.Value
.Cells(ulin, 12).Value = txtNumero.Value
.Cells(ulin, 13).Value = txtBairro.Value
.Cells(ulin, 14).Value = txtCidade.Value
.Cells(ulin, 15).Value = cboUfLocal.Value
.Cells(ulin, 16).Value = txtCep.Value
.Cells(ulin, 17).Value = txtComplemento.Value
.Cells(ulin, 18).Value = txtTelefone.Value
.Cells(ulin, 19).Value = txtEmail.Value
.Cells(ulin, 20).Value = txtNascimento.Value
.Cells(ulin, 21).Value = Aniv
.Cells(ulin, 22).Value = Date
.Cells(ulin, 23).Value = Dia
.Cells(ulin, 24).Value = Mes
.Cells(ulin, 25).Value = txtProfissao.Value
.Cells(ulin, 26).Value = txtRenda.Value
.Cells(ulin, 27).Value = txtEmpresa.Value
.Cells(ulin, 28).Value = cboSituacao.Value
.Cells(ulin, 29).Value = txtLimite.Value
If CheckCrediario = True Then
.Cells(0, 31).Value = "Sim"
Else
.Cells(0, 31).Value = "Não"
End If
If CheckCheque = True Then
.Cells(0, 32).Value = "Sim"
Else
.Cells(0, 32).Value = "Não"
End If
If CheckVIP = True Then
.Cells(0, 33).Value = "Sim"
Else
.Cells(0, 33).Value = "Não"
End If
.Cells(0, 34).Value = txtFiliacao.Value
.Cells(0, 35).Value = cboEstadoCivil.Value
.Cells(0, 36).Value = txtConjuge.Value
.Cells(0, 37).Value = cboSexo2.Value
.Cells(0, 38).Value = txtRef1.Value
.Cells(0, 39).Value = txtRef2.Value
End With
Set wPlan = Nothing
End Sub
Sub BuscaDados(tpPessoa As String)
On Error Resume Next
Dim wbk As Workbook
Dim imgCli As String
Set wbk = Workbooks("CadastroClientes.xlsm")
With ActiveCell
txtCodigo.Value = .Value
txtNome.Value = .Offset(0, 1).Value
txtCelular.Value = .Offset(0, 2).Value
cboPessoa.Value = .Offset(0, 3).Value
tpPessoa = .Offset(0, 3).Value
txtCpf.Value = .Offset(0, 4).Value
txtFantasia.Value = .Offset(0, 5).Value
txtRg.Value = .Offset(0, 6).Value
txtEmissao.Value = .Offset(0, 7).Value
cboUfEmissao.Value = .Offset(0, 8).Value
cboSexo.Value = .Offset(0, 9).Value
txtEndereco.Value = .Offset(0, 10).Value
txtNumero.Value = .Offset(0, 11).Value
txtBairro.Value = .Offset(0, 12).Value
txtCidade.Value = .Offset(0, 13).Value
cboUfLocal.Value = .Offset(0, 14).Value
txtCep.Value = .Offset(0, 15).Value
txtComplemento.Value = .Offset(0, 16).Value
txtTelefone.Value = .Offset(0, 17).Value
txtEmail.Value = .Offset(0, 18).Value
txtNascimento.Value = .Offset(0, 19).Value
txtAniversario.Value = Format(.Offset(0, 20).Value, "dd/mm")
txtDataCadastro.Value = .Offset(0, 21).Value
txtProfissao.Value = .Offset(0, 24).Value
txtRenda.Value = .Offset(0, 25).Value
txtEmpresa.Value = .Offset(0, 26).Value
cboSituacao.Value = .Offset(0, 27).Value
txtLimite.Value = .Offset(0, 28).Value
txtUltCompra.Value = .Offset(0, 29).Value
If .Offset(0, 30).Value = "Sim" Then
CheckCrediario = True
Else
CheckCrediario = False
End If
If .Offset(0, 31).Value = "Sim" Then
CheckCheque = True
Else
CheckCheque = False
End If
If .Offset(0, 32).Value = "Sim" Then
CheckVIP = True
Else
CheckVIP = False
End If
txtFiliacao.Value = .Offset(0, 33).Value
cboEstadoCivil.Value = .Offset(0, 34).Value
txtConjuge.Value = .Offset(0, 35).Value
cboSexo2.Value = .Offset(0, 36).Value
txtRef1.Value = .Offset(0, 37).Value
txtRef2.Value = .Offset(0, 38).Value
imgCli = wbk.Path & "\PicClientes\" & .Value & ".jpg"
imgClienteBsc.Picture = LoadPicture(imgCli)
imgClienteAlt.Picture = LoadPicture(imgCli)
End With
End Sub
Sub RegistrarAlteracao()
Dim Data As Date
Dim Aniv As Date
Dim Dia As String
Dim Mes As String
On Error Resume Next
Aniv = txtAniversario.Value
Dia = Format(Aniv, "dd")
Mes = Format(Aniv, "mmmm")
With ActiveCell
' .Value = Format(txtCodigo.Value, "0")
.Offset(0, 1).Value = txtNome.Value
.Offset(0, 2).Value = txtCelular.Value
.Offset(0, 3).Value = cboPessoa.Value
.Offset(0, 4).Value = txtCpf.Value
.Offset(0, 5).Value = txtFantasia.Value
.Offset(0, 6).Value = txtRg.Value
.Offset(0, 7).Value = txtEmissao.Value
.Offset(0, 8).Value = cboUfEmissao.Value
.Offset(0, 9).Value = cboSexo.Value
.Offset(0, 10).Value = txtEndereco.Value
.Offset(0, 11).Value = txtNumero.Value
.Offset(0, 12).Value = txtBairro.Value
.Offset(0, 13).Value = txtCidade.Value
.Offset(0, 14).Value = cboUfLocal.Value
.Offset(0, 15).Value = txtCep.Value
.Offset(0, 16).Value = txtComplemento.Value
.Offset(0, 17).Value = txtTelefone.Value
.Offset(0, 18).Value = txtEmail.Value
.Offset(0, 19).Value = txtNascimento.Value
.Offset(0, 20).Value = Aniv
.Offset(0, 21).Value = Date
.Offset(0, 22).Value = Dia
.Offset(0, 23).Value = Mes
.Offset(0, 24).Value = txtProfissao.Value
.Offset(0, 25).Value = txtRenda.Value
.Offset(0, 26).Value = txtEmpresa.Value
.Offset(0, 27).Value = cboSituacao.Value
.Offset(0, 28).Value = txtLimite.Value
If CheckCrediario = True Then
.Offset(0, 30).Value = "Sim"
Else
.Offset(0, 30).Value = "Não"
End If
If CheckCheque = True Then
.Offset(0, 31).Value = "Sim"
Else
.Offset(0, 31).Value = "Não"
End If
If CheckVIP = True Then
.Offset(0, 32).Value = "Sim"
Else
.Offset(0, 32).Value = "Não"
End If
.Offset(0, 33).Value = txtFiliacao.Value
.Offset(0, 34).Value = cboEstadoCivil.Value
.Offset(0, 35).Value = txtConjuge.Value
.Offset(0, 36).Value = cboSexo2.Value
.Offset(0, 37).Value = txtRef1.Value
.Offset(0, 38).Value = txtRef2.Value
End With
End Sub
Sub BDados(Codigo As Long)
Dim wPlan As Worksheet
Dim R As Range
Dim img As String
Dim nmImg As String
Dim tpPessoa As String
Set wPlan = Planilha4
'Call LimparCampos
wPlan.Activate
With wPlan.Range("A:A")
Set R = .Find(Codigo, LookIn:=xlValues, LookAt:=xlWhole)
If Not R Is Nothing Then
R.Activate
R.Select
If tpPessoa = "Jurídica" Then
nmImg = "FormNo2"
Else
nmImg = "FormNo1"
End If
Call BuscaDados(tpPessoa)
Call SelecionaFundo(nmImg, img)
Else
MsgBox "Código não encontrado!", vbExclamation, "Pesquisa!"
End If
End With
End Sub
Boa tarde Marcelo. Cara, material simplesmente fantástico. Sucesso sempre!
Parabéns Marcelo! O conteúdo apresentado é realmente muito bom! Pena que eu não possa aproveitar tudo, pois meu office é o 2003 e não abre suas planilhas xlsm.
Você trabalha bem rápido e demonstra o domínio tanto da linguagem VBA, como dos aplicativos do Office.
Achei super interessante a possibilidade de se criar imagens em alta definição com o Power Point. Na verdade agora é que eu me liguei porque ele é realmente “Power”.
Seus códigos fontes são preciosos demais.
Muitos programadores preferem manter os códigos fontes em segredo, mas este parece não ser o seu caso, pois você não se importa de compartilhá-los conosco. Obrigado por isso.
Alias por falar nisto, teve um código no vídeo: ” https://www.youtube.com/watch?v=2cdjqdD_jGQ ” que eu não consegui visualizar. será que você podia compartilhá-lo.
‘Trata-se do Código do Módulo AjusteForm :
Public Sub TornaFormAjustavel(ByVal UF As Object)
Set Ufrm = UF
‘ Call Createmenu ‘Falta esta sub rotina
‘ Call StoreInitialMetrics’Falta esta sub rotina
‘Optional: maximize o formulário antes de mostrá-lo
‘=======
PostMessage hwnd, WS_SYSCOMMAND, SC_MAXIMIZE, 0
End Sub
Public Sub RedimensionarControles(Optional ByVal Dummey As Boolean)
Dim oCtrl As Control
End Sub
Trata-se do código para redimensionar os controles do formulário.
Será que você podia compartilhá-lo.
Se possível eis o meu e-mail: gpsoares01@hotmail.com
Obrigado.