Pessoal,
Preciso de ajuda pra resolver isso. Estou há alguns dias neste projeto e não consigo resolver este de erro de compilação.
Segue o código todo:
Option Explicit
Const colCodFor As Integer = 1
Const colSituacao As Integer = 2
Const colRazao As Integer = 3
Const colAbertura As Integer = 4
Const colEncerramento As Integer = 5
Const colFantasia As Integer = 6
Const colGrupoFor As Integer = 7
Const colContato As Integer = 8
Const colCargoContato As Integer = 9
Const colCNPJ As Integer = 10
Const colIE As Integer = 11
Const colCPF As Integer = 12
Const colRG As Integer = 13
Const colCEP As String = 14
Const colEnd As Integer = 15
Const colNum As Integer = 16
Const colBairro As Integer = 17
Const colCidade As Integer = 18
Const colUF As Integer = 19
Const colFone1 As Integer = 20
Const colFone2 As Integer = 21
Const colEmail As Integer = 22
Const colObs As Integer = 23
Const indiceMinimo As Byte = 2
Const corDisabledTextBox As Long = -2147483633
Const corEnabledTextBox As Long = -2147483643
Private wsCadastro As Worksheet
Private indiceRegistro As Long
Private Sub btnPesquisar_Click()
frmPesquisaFornecedor.Show
End Sub
Private Sub btnSair_Click()
Unload Me
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 = wsCadastro.Range(wsCadastro.Cells(indiceMinimo, colCodFor), wsCadastro.Cells(wsCadastro.UsedRange.Rows.Count, colCodFor))
PegaProximoId = WorksheetFunction.Max(rangeIds) + 1
End Function
Private Sub AtualizaRegistroCorrente()
lblNavigator.Caption = indiceRegistro - 1 & " de " & wsCadastro.UsedRange.Rows.Count - 1
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 optAlterar_Click()
If txtCodFor.Text <> vbNullString And txtCodFor.Text <> "" Then
Call HabilitaControles
Call DesabilitaBotoesAlteracao
btnCancelar.Visible = True
'dá o foco ao primeiro controle de dados
txtRazao.SetFocus
Else
lblMensagem.Caption = "Não há registro a ser alterado"
End If
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 btnCancelar_Click()
btnCancelar.Enabled = False
Call DesabilitaControles
lblMensagem.Caption = ""
If optNovo.Value Then
Call CarregaDadosInicial
End If
Call HabilitaBotoesAlteracao
End Sub
Private Sub btnConfirmar_Click()
Dim proximoId As Long
'Altera
If optAlterar.Value Then
Call SalvaRegistro(CLng(txtCodFor.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 = wsCadastro.UsedRange.Rows.Count + 1
Call SalvaRegistro(proximoId, proximoIndice)
txtCodFor = proximoId
lblMensagem.Caption = "Registro salvo com sucesso"
End If
'Excluir
If optExcluir.Value Then
Dim result As VbMsgBoxResult
result = MsgBox("Deseja excluir o Fornecedor: " & txtRazao.Text & " ?", vbYesNo, "Confirmação")
If result = vbYes Then
wsCadastro.Range(wsCadastro.Cells(indiceRegistro, colCodFor), wsCadastro.Cells(indiceRegistro, colCodFor)).EntireRow.Delete
Call CarregaDadosInicial
lblMensagem.Caption = "Registro excluído com sucesso"
End If
End If
Call HabilitaBotoesAlteracao
Call DesabilitaControles
End Sub
Private Sub BtnPrimeiro_Click()
indiceRegistro = indiceMinimo
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub BtnProximo_Click()
If indiceRegistro < wsCadastro.UsedRange.Rows.Count Then
indiceRegistro = indiceRegistro + 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub BtnUltimo_Click()
indiceRegistro = wsCadastro.UsedRange.Rows.Count
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub optExcluir_Click()
If txtCodFor.Text <> vbNullString And txtCodFor.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 HabilitaControles
Call DesabilitaBotoesAlteracao
'dá o foco ao primeiro controle de dados
txtRazao.SetFocus
End Sub
Private Sub txtEncerramento_Change()
'Formata : dd/mm/aa
If Len(txtEncerramento) = 2 Or Len(txtEncerramento) = 5 Then
txtEncerramento.Text = txtEncerramento.Text & "/"
SendKeys "{End}", True
End If
End Sub
Private Sub txtCPF_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8, 48 To 57
Me.txtCPF.MaxLength = 14 ' Quantidade máxima de caracteres no textbox CNPJ
If Len(txtCPF) = 3 Then txtCPF = txtCPF + "."
If Len(txtCPF) = 7 Then txtCPF = txtCPF + "."
If Len(txtCPF) = 11 Then txtCPF = txtCPF + "-"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub txtCNPJ_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8, 48 To 57
Me.txtCNPJ.MaxLength = 18 ' Quantidade máxima de caracteres no textbox CNPJ
If Len(txtCNPJ) = 2 Then txtCNPJ = txtCNPJ + "."
If Len(txtCNPJ) = 6 Then txtCNPJ = txtCNPJ + "."
If Len(txtCNPJ) = 10 Then txtCNPJ = txtCNPJ + "/"
If Len(txtCNPJ) = 15 Then txtCNPJ = txtCNPJ + "-"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub txtIE_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8, 48 To 57
Me.txtIE.MaxLength = 12 ' Quantidade máxima de caracteres no textbox IE
If Len(txtIE) = 2 Then txtIE = txtIE + "."
If Len(txtIE) = 6 Then txtIE = txtIE + "."
If Len(txtIE) = 10 Then txtIE = txtIE + "-"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub txtFone1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Len(txtFone1) = 0 Then
txtFone1.Text = "("
End If
If Len(txtFone1) = 3 Then
txtFone1.Text = txtFone1 & ") "
End If
If Len(txtFone1) = 9 Then
txtFone1.Text = txtFone1 & " - "
End If
End Sub
Private Sub txtFone2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Len(txtFone2) = 0 Then
txtFone2.Text = "("
End If
If Len(txtFone2) = 3 Then
txtFone2.Text = txtFone2 & ") "
End If
If Len(txtFone2) = 10 Then
txtFone2.Text = txtFone2 & " - "
End If
End Sub
Private Sub txtAbertura_Change()
'Formata : dd/mm/aa
If Len(txtAbertura) = 2 Or Len(txtAbertura) = 5 Then
txtAbertura.Text = txtAbertura.Text & "/"
SendKeys "{End}", True
End If
End Sub
Private Sub UserForm_Initialize()
Set wsCadastro = ThisWorkbook.Worksheets("Fornecedor")
Call HabilitaBotoesAlteracao
Call CarregaDadosInicial
Call DesabilitaControles
txtRazao.SetFocus
End Sub
Private Sub CarregaDadosInicial()
indiceRegistro = 2
Call CarregaRegistro
lblMensagem.Caption = ""
End Sub
Private Sub CarregaRegistro()
'carrega os dados do primeiro registro
With wsCadastro
If Not IsEmpty(.Cells(indiceRegistro, colCodFor)) Then
Me.txtCodFor.Text = .Cells(indiceRegistro, colCodFor).Value
Me.txtRazao.Text = .Cells(indiceRegistro, colRazao).Value
Me.txtAbertura.Text = .Cells(indiceRegistro, colAbertura).Value
Me.txtFantasia.Text = .Cells(indiceRegistro, colFantasia).Value
Me.txtGrupoFor.Text = .Cells(indiceRegistro, colGrupoFor).Value
Me.txtCPF.Text = .Cells(indiceRegistro, colCPF).Value
Me.txtCNPJ.Text = .Cells(indiceRegistro, colCNPJ).Value
Me.txtRG.Text = .Cells(indiceRegistro, colRG).Value
Me.txtContato.Text = .Cells(indiceRegistro, colContato).Value
Me.txtIE.Text = .Cells(indiceRegistro, colIE).Value
Me.txtCargoContato.Text = .Cells(indiceRegistro, colCargoContato).Value
Me.txtCEP.Text = .Cells(indiceRegistro, colCEP).Value
Me.txtEnd.Text = .Cells(indiceRegistro, colEnd).Value
Me.txtNum.Text = .Cells(indiceRegistro, colNum).Value
Me.txtBairro.Text = .Cells(indiceRegistro, colBairro).Value
Me.txtUF.Text = .Cells(indiceRegistro, colUF).Value
Me.txtCidade.Text = .Cells(indiceRegistro, colCidade).Value
Me.txtFone1.Text = .Cells(indiceRegistro, colFone1).Value
Me.txtFone2.Text = .Cells(indiceRegistro, colFone2).Value
Me.txtSituacao.Text = .Cells(indiceRegistro, colSituacao).Value
Me.txtEmail.Text = .Cells(indiceRegistro, colEmail).Value
Me.txtObs.Text = .Cells(indiceRegistro, colObs).Value
End If
End With
Call AtualizaRegistroCorrente
End Sub
Private Sub SalvaRegistro(ByVal id As Long, ByVal indice As Long)
With wsCadastro
.Cells(indice, colCodFor).Value = id
.Cells(indice, colRazao).Value = Me.txtRazao.Text
.Cells(indice, colAbertura).Value = Format(Me.txtAbertura.Text, "mm/dd/yyyy")
.Cells(indice, colFantasia).Value = Me.txtFantasia.Text
.Cells(indice, colGrupoFor).Value = Me.txtGrupoFor.Text
.Cells(indice, colCPF).Value = Me.txtCPF.Text
.Cells(indice, colCNPJ).Value = Me.txtCNPJ.Text
.Cells(indice, colRG).Value = Me.txtRG.Text
.Cells(indice, colEncerramento).Value = Format(Me.txtEncerramento.Text, "mm/dd/yyyy")
.Cells(indice, colContato).Value = Me.txtContato.Text
.Cells(indice, colIE).Value = Me.txtIE.Text
.Cells(indice, colCargoContato).Value = Me.txtCargoContato.Text
.Cells(indice, colCEP).Value = Me.txtCEP.Text
.Cells(indice, colEnd).Value = Me.txtEnd.Text
.Cells(indice, colNum).Value = Me.txtNum.Text
.Cells(indice, colBairro).Value = Me.txtBairro.Text
.Cells(indice, colUF).Value = Me.txtUF.Text
.Cells(indice, colCidade).Value = Me.txtCidade.Text
.Cells(indice, colFone1).Value = Me.txtFone1.Text
.Cells(indice, colFone2).Value = Me.txtFone2.Text
.Cells(indice, colSituacao).Value = Me.txtSituacao.Text
.Cells(indice, colEmail).Value = Me.txtEmail.Text
.Cells(indice, colObs).Value = Me.txtObs.Text
End With
Call AtualizaRegistroCorrente
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 wsCadastro
Do While Not IsEmpty(.Cells(i, colCodFor))
If .Cells(i, colCodFor).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
Private Sub LimpaControles()
Me.txtCodFor.Text = ""
Me.txtRazao.Text = ""
Me.txtAbertura.Text = ""
Me.txtFantasia.Text = ""
Me.txtGrupoFor.Text = ""
Me.txtCPF.Text = ""
Me.txtCNPJ.Text = ""
Me.txtRG.Text = ""
Me.txtEncerramento.Text = ""
Me.txtContato.Text = ""
Me.txtIE.Text = ""
Me.txtCargoContato.Text = ""
Me.txtCEP.Text = ""
Me.txtEnd.Text = ""
Me.txtNum.Text = ""
Me.txtBairro.Text = ""
Me.txtUF.Text = ""
Me.txtCidade.Text = ""
Me.txtFone1.Text = ""
Me.txtFone2.Text = ""
Me.txtSituacao.Text = ""
Me.txtEmail.Text = ""
Me.txtObs.Text = ""
End Sub
Private Sub HabilitaControles()
'Me.txtCodFor.Locked = False
Me.txtRazao.Locked = False
Me.txtAbertura.Locked = False
Me.txtFantasia.Locked = False
Me.txtGrupoFor.Locked = False
Me.txtCPF.Locked = False
Me.txtCNPJ.Locked = False
Me.txtRG.Locked = False
Me.txtEncerramento.Locked = False
Me.txtContato.Locked = False
Me.txtIE.Locked = False
Me.txtCargoContato.Locked = False
Me.txtCEP.Locked = False
Me.txtEnd.Locked = False
Me.txtNum.Locked = False
Me.txtBairro.Locked = False
Me.txtUF.Locked = False
Me.txtCidade.Locked = False
Me.txtFone1.Locked = False
Me.txtFone2.Locked = False
Me.txtSituacao.Locked = False
Me.txtEmail.Locked = False
Me.txtObs.Locked = False
'Me.txtCodFor.Text = corEnabledTextBox
Me.txtRazao.BackColor = corEnabledTextBox
Me.txtAbertura.BackColor = corEnabledTextBox
Me.txtFantasia.BackColor = corEnabledTextBox
Me.txtGrupoFor.BackColor = corEnabledTextBox
Me.txtCPF.BackColor = corEnabledTextBox
Me.txtCNPJ.BackColor = corEnabledTextBox
Me.txtRG.BackColor = corEnabledTextBox
Me.txtEncerramento.BackColor = corEnabledTextBox
Me.txtContato.BackColor = corEnabledTextBox
Me.txtIE.BackColor = corEnabledTextBox
Me.txtCargoContato.BackColor = corEnabledTextBox
Me.txtCEP.BackColor = corEnabledTextBox
Me.txtEnd.BackColor = corEnabledTextBox
Me.txtNum.BackColor = corEnabledTextBox
Me.txtBairro.BackColor = corEnabledTextBox
Me.txtUF.BackColor = corEnabledTextBox
Me.txtCidade.BackColor = corEnabledTextBox
Me.txtFone1.BackColor = corEnabledTextBox
Me.txtFone2.BackColor = corEnabledTextBox
Me.txtSituacao.BackColor = corEnabledTextBox
Me.txtEmail.BackColor = corEnabledTextBox
Me.txtObs.BackColor = corEnabledTextBox
End Sub
Private Sub DesabilitaControles()
Me.txtCodFor.Locked = True
Me.txtRazao.Locked = True
Me.txtAbertura.Locked = True
Me.txtFantasia.Locked = True
Me.txtGrupoFor.Locked = True
Me.txtCPF.Locked = True
Me.txtCNPJ.Locked = True
Me.txtRG.Locked = True
Me.txtEncerramento.Locked = True
Me.txtContato.Locked = True
Me.txtIE.Locked = True
Me.txtCargoContato.Locked = True
Me.txtCEP.Locked = True
Me.txtEnd.Locked = True
Me.txtNum.Locked = True
Me.txtBairro.Locked = True
Me.txtUF.Locked = True
Me.txtCidade.Locked = True
Me.txtFone1.Locked = True
Me.txtFone2.Locked = True
Me.txtSituacao.Locked = True
Me.txtEmail.Locked = True
Me.txtObs.Locked = True
'Me.txtCodFor.Text = corDisabledTextBox
Me.txtRazao.BackColor = corDisabledTextBox
Me.txtAbertura.BackColor = corDisabledTextBox
Me.txtFantasia.BackColor = corDisabledTextBox
Me.txtGrupoFor.BackColor = corDisabledTextBox
Me.txtCPF.BackColor = corDisabledTextBox
Me.txtCNPJ.BackColor = corDisabledTextBox
Me.txtRG.BackColor = corDisabledTextBox
Me.txtEncerramento.BackColor = corDisabledTextBox
Me.txtContato.BackColor = corDisabledTextBox
Me.txtIE.BackColor = corDisabledTextBox
Me.txtCargoContato.BackColor = corDisabledTextBox
Me.txtCEP.BackColor = corDisabledTextBox
Me.txtEnd.BackColor = corDisabledTextBox
Me.txtNum.BackColor = corDisabledTextBox
Me.txtBairro.BackColor = corDisabledTextBox
Me.txtUF.BackColor = corDisabledTextBox
Me.txtCidade.BackColor = corDisabledTextBox
Me.txtFone1.BackColor = corDisabledTextBox
Me.txtFone2.BackColor = corDisabledTextBox
Me.txtSituacao.BackColor = corDisabledTextBox
Me.txtEmail.BackColor = corDisabledTextBox
Me.txtObs.BackColor = corDisabledTextBox
End Sub
Private Sub DesabilitaBotoesAlteracao()
'desabilita os botões de alteração
optAlterar.Enabled = False
optExcluir.Enabled = False
optNovo.Enabled = False
End Sub
Private Sub HabilitaBotoesAlteracao()
'habilita os botões de alteração
optAlterar.Enabled = True
optExcluir.Enabled = True
optNovo.Enabled = True
btnConfirmar.Enabled = True
btnCancelar.Enabled = True
btnPesquisar.Enabled = True
' limpa os valores dos controles
optAlterar.Value = False
optExcluir.Value = False
optNovo.Value = False
End Sub
'CEP
Private Sub txtCEP_Change()
txtCEP.MaxLength = 9
'Formata Numero automático ao digitar
If Len(txtCEP) = 5 Or Len(txtCEP) = 5 Then
txtCEP.Text = txtCEP.Text & "-"
SendKeys "{End}", True
End If
End Sub
Private Sub txtCEP_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'para permitir que apenas números sejam digitados
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub
Private Sub VerificartxtCEP()
'
' Exemplo de utilização
'
Dim resultado
Dim Texto As String
resultado = busca_txtCEP(Me.txtCEP)
Dim i As Integer
Dim X As String
For i = 0 To 14
X = X & Chr(13) & resultado(i)
Next
Select Case resultado(2)
Case "0" 'CEP NÃO LOCALIZADO
Me.lblCepMsg.Caption = Replace(resultado(4), "sucesso - ", "")
Me.lblCepMsg.Caption = Replace(lblCepMsg.Caption, "%E3", "ã")
Case "1" 'CEP LOCALIZADO
Me.txtEnd = resultado(12) & " " & resultado(14)
Me.txtBairro = resultado(10)
Me.txtCidade = resultado(![Cool](https://2img.net/i/fa/i/smiles/icon_cool.gif)
Me.txtUF = resultado(6)
Case Else
End Select
End Sub
Private Sub txtCEP_AfterUpdate()
Call VerificartxtCEP
On Error Resume Next
If Not IsNull(Me.txtEnd) Or Not IsNull(Me.txtBairro) Or Not IsNull(Me.txtCidade) Then
Me.txtEnd = Replace(Me.txtEnd, "%E1", "á")
Me.txtEnd = Replace(Me.txtEnd, "%E2", "â")
Me.txtEnd = Replace(Me.txtEnd, "%E3", "ã")
Me.txtEnd = Replace(Me.txtEnd, "%E7", "ç")
Me.txtEnd = Replace(Me.txtEnd, "%E9", "é")
Me.txtEnd = Replace(Me.txtEnd, "%EA", "ê")
Me.txtEnd = Replace(Me.txtEnd, "%ED", "í")
Me.txtEnd = Replace(Me.txtEnd, "%F3", "ó")
Me.txtEnd = Replace(Me.txtEnd, "%F4", "ô")
Me.txtEnd = Replace(Me.txtEnd, "%F5", "õ")
Me.txtEnd = Replace(Me.txtEnd, "%FA", "ú")
Me.txtBairro = Replace(Me.txtBairro, "%E1", "á")
Me.txtBairro = Replace(Me.txtBairro, "%E2", "â")
Me.txtBairro = Replace(Me.txtBairro, "%E3", "ã")
Me.txtBairro = Replace(Me.txtBairro, "%E7", "ç")
Me.txtBairro = Replace(Me.txtBairro, "%E9", "é")
Me.txtBairro = Replace(Me.txtBairro, "%EA", "ê")
Me.txtBairro = Replace(Me.txtBairro, "%ED", "í")
Me.txtBairro = Replace(Me.txtBairro, "%F3", "ó")
Me.txtBairro = Replace(Me.txtBairro, "%F4", "ô")
Me.txtBairro = Replace(Me.txtBairro, "%F5", "õ")
Me.txtBairro = Replace(Me.txtBairro, "%FA", "ú")
Me.txtCidade = Replace(Me.txtCidade, "%E1", "á")
Me.txtCidade = Replace(Me.txtCidade, "%E2", "â")
Me.txtCidade = Replace(Me.txtCidade, "%E3", "ã")
Me.txtCidade = Replace(Me.txtCidade, "%E7", "ç")
Me.txtCidade = Replace(Me.txtCidade, "%E9", "é")
Me.txtCidade = Replace(Me.txtCidade, "%EA", "ê")
Me.txtCidade = Replace(Me.txtCidade, "%ED", "í")
Me.txtCidade = Replace(Me.txtCidade, "%F3", "ó")
Me.txtCidade = Replace(Me.txtCidade, "%F4", "ô")
Me.txtCidade = Replace(Me.txtCidade, "%F5", "õ")
Me.txtCidade = Replace(Me.txtCidade, "%FA", "ú")
End If
End Sub
Function busca_txtCEP()
Url = "http://republicavirtual.com.br/web_cep.php?cep=" & txtCEP & "&formato=query_string"
'TROQUEI ServerXMLHTTP POR XMLHTTP E AGORA FUNCIONA CORRETAMENTE
'Set XMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", Url, False
XMLHTTP.Send ""
xmlhttp_resultado = XMLHTTP.responseText
Set XMLHTTP = Nothing
arr_resultado = Split(xmlhttp_resultado, "&")
Dim resultado(7)
For i = LBound(arr_resultado) To UBound(arr_resultado)
resultado(i) = arr_resultado(i)
Next
arr = Split(Join(resultado, "="), "=")
Dim arr_2(14)
For i = LBound(arr) To UBound(arr)
arr_2(i) = Replace(arr(i), "+", " ")
Next
busca_cep = arr_2
End Function
Preciso de ajuda pra resolver isso. Estou há alguns dias neste projeto e não consigo resolver este de erro de compilação.
Segue o código todo:
Option Explicit
Const colCodFor As Integer = 1
Const colSituacao As Integer = 2
Const colRazao As Integer = 3
Const colAbertura As Integer = 4
Const colEncerramento As Integer = 5
Const colFantasia As Integer = 6
Const colGrupoFor As Integer = 7
Const colContato As Integer = 8
Const colCargoContato As Integer = 9
Const colCNPJ As Integer = 10
Const colIE As Integer = 11
Const colCPF As Integer = 12
Const colRG As Integer = 13
Const colCEP As String = 14
Const colEnd As Integer = 15
Const colNum As Integer = 16
Const colBairro As Integer = 17
Const colCidade As Integer = 18
Const colUF As Integer = 19
Const colFone1 As Integer = 20
Const colFone2 As Integer = 21
Const colEmail As Integer = 22
Const colObs As Integer = 23
Const indiceMinimo As Byte = 2
Const corDisabledTextBox As Long = -2147483633
Const corEnabledTextBox As Long = -2147483643
Private wsCadastro As Worksheet
Private indiceRegistro As Long
Private Sub btnPesquisar_Click()
frmPesquisaFornecedor.Show
End Sub
Private Sub btnSair_Click()
Unload Me
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 = wsCadastro.Range(wsCadastro.Cells(indiceMinimo, colCodFor), wsCadastro.Cells(wsCadastro.UsedRange.Rows.Count, colCodFor))
PegaProximoId = WorksheetFunction.Max(rangeIds) + 1
End Function
Private Sub AtualizaRegistroCorrente()
lblNavigator.Caption = indiceRegistro - 1 & " de " & wsCadastro.UsedRange.Rows.Count - 1
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 optAlterar_Click()
If txtCodFor.Text <> vbNullString And txtCodFor.Text <> "" Then
Call HabilitaControles
Call DesabilitaBotoesAlteracao
btnCancelar.Visible = True
'dá o foco ao primeiro controle de dados
txtRazao.SetFocus
Else
lblMensagem.Caption = "Não há registro a ser alterado"
End If
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 btnCancelar_Click()
btnCancelar.Enabled = False
Call DesabilitaControles
lblMensagem.Caption = ""
If optNovo.Value Then
Call CarregaDadosInicial
End If
Call HabilitaBotoesAlteracao
End Sub
Private Sub btnConfirmar_Click()
Dim proximoId As Long
'Altera
If optAlterar.Value Then
Call SalvaRegistro(CLng(txtCodFor.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 = wsCadastro.UsedRange.Rows.Count + 1
Call SalvaRegistro(proximoId, proximoIndice)
txtCodFor = proximoId
lblMensagem.Caption = "Registro salvo com sucesso"
End If
'Excluir
If optExcluir.Value Then
Dim result As VbMsgBoxResult
result = MsgBox("Deseja excluir o Fornecedor: " & txtRazao.Text & " ?", vbYesNo, "Confirmação")
If result = vbYes Then
wsCadastro.Range(wsCadastro.Cells(indiceRegistro, colCodFor), wsCadastro.Cells(indiceRegistro, colCodFor)).EntireRow.Delete
Call CarregaDadosInicial
lblMensagem.Caption = "Registro excluído com sucesso"
End If
End If
Call HabilitaBotoesAlteracao
Call DesabilitaControles
End Sub
Private Sub BtnPrimeiro_Click()
indiceRegistro = indiceMinimo
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub BtnProximo_Click()
If indiceRegistro < wsCadastro.UsedRange.Rows.Count Then
indiceRegistro = indiceRegistro + 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub BtnUltimo_Click()
indiceRegistro = wsCadastro.UsedRange.Rows.Count
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub optExcluir_Click()
If txtCodFor.Text <> vbNullString And txtCodFor.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 HabilitaControles
Call DesabilitaBotoesAlteracao
'dá o foco ao primeiro controle de dados
txtRazao.SetFocus
End Sub
Private Sub txtEncerramento_Change()
'Formata : dd/mm/aa
If Len(txtEncerramento) = 2 Or Len(txtEncerramento) = 5 Then
txtEncerramento.Text = txtEncerramento.Text & "/"
SendKeys "{End}", True
End If
End Sub
Private Sub txtCPF_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8, 48 To 57
Me.txtCPF.MaxLength = 14 ' Quantidade máxima de caracteres no textbox CNPJ
If Len(txtCPF) = 3 Then txtCPF = txtCPF + "."
If Len(txtCPF) = 7 Then txtCPF = txtCPF + "."
If Len(txtCPF) = 11 Then txtCPF = txtCPF + "-"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub txtCNPJ_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8, 48 To 57
Me.txtCNPJ.MaxLength = 18 ' Quantidade máxima de caracteres no textbox CNPJ
If Len(txtCNPJ) = 2 Then txtCNPJ = txtCNPJ + "."
If Len(txtCNPJ) = 6 Then txtCNPJ = txtCNPJ + "."
If Len(txtCNPJ) = 10 Then txtCNPJ = txtCNPJ + "/"
If Len(txtCNPJ) = 15 Then txtCNPJ = txtCNPJ + "-"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub txtIE_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8, 48 To 57
Me.txtIE.MaxLength = 12 ' Quantidade máxima de caracteres no textbox IE
If Len(txtIE) = 2 Then txtIE = txtIE + "."
If Len(txtIE) = 6 Then txtIE = txtIE + "."
If Len(txtIE) = 10 Then txtIE = txtIE + "-"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub txtFone1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Len(txtFone1) = 0 Then
txtFone1.Text = "("
End If
If Len(txtFone1) = 3 Then
txtFone1.Text = txtFone1 & ") "
End If
If Len(txtFone1) = 9 Then
txtFone1.Text = txtFone1 & " - "
End If
End Sub
Private Sub txtFone2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Len(txtFone2) = 0 Then
txtFone2.Text = "("
End If
If Len(txtFone2) = 3 Then
txtFone2.Text = txtFone2 & ") "
End If
If Len(txtFone2) = 10 Then
txtFone2.Text = txtFone2 & " - "
End If
End Sub
Private Sub txtAbertura_Change()
'Formata : dd/mm/aa
If Len(txtAbertura) = 2 Or Len(txtAbertura) = 5 Then
txtAbertura.Text = txtAbertura.Text & "/"
SendKeys "{End}", True
End If
End Sub
Private Sub UserForm_Initialize()
Set wsCadastro = ThisWorkbook.Worksheets("Fornecedor")
Call HabilitaBotoesAlteracao
Call CarregaDadosInicial
Call DesabilitaControles
txtRazao.SetFocus
End Sub
Private Sub CarregaDadosInicial()
indiceRegistro = 2
Call CarregaRegistro
lblMensagem.Caption = ""
End Sub
Private Sub CarregaRegistro()
'carrega os dados do primeiro registro
With wsCadastro
If Not IsEmpty(.Cells(indiceRegistro, colCodFor)) Then
Me.txtCodFor.Text = .Cells(indiceRegistro, colCodFor).Value
Me.txtRazao.Text = .Cells(indiceRegistro, colRazao).Value
Me.txtAbertura.Text = .Cells(indiceRegistro, colAbertura).Value
Me.txtFantasia.Text = .Cells(indiceRegistro, colFantasia).Value
Me.txtGrupoFor.Text = .Cells(indiceRegistro, colGrupoFor).Value
Me.txtCPF.Text = .Cells(indiceRegistro, colCPF).Value
Me.txtCNPJ.Text = .Cells(indiceRegistro, colCNPJ).Value
Me.txtRG.Text = .Cells(indiceRegistro, colRG).Value
Me.txtContato.Text = .Cells(indiceRegistro, colContato).Value
Me.txtIE.Text = .Cells(indiceRegistro, colIE).Value
Me.txtCargoContato.Text = .Cells(indiceRegistro, colCargoContato).Value
Me.txtCEP.Text = .Cells(indiceRegistro, colCEP).Value
Me.txtEnd.Text = .Cells(indiceRegistro, colEnd).Value
Me.txtNum.Text = .Cells(indiceRegistro, colNum).Value
Me.txtBairro.Text = .Cells(indiceRegistro, colBairro).Value
Me.txtUF.Text = .Cells(indiceRegistro, colUF).Value
Me.txtCidade.Text = .Cells(indiceRegistro, colCidade).Value
Me.txtFone1.Text = .Cells(indiceRegistro, colFone1).Value
Me.txtFone2.Text = .Cells(indiceRegistro, colFone2).Value
Me.txtSituacao.Text = .Cells(indiceRegistro, colSituacao).Value
Me.txtEmail.Text = .Cells(indiceRegistro, colEmail).Value
Me.txtObs.Text = .Cells(indiceRegistro, colObs).Value
End If
End With
Call AtualizaRegistroCorrente
End Sub
Private Sub SalvaRegistro(ByVal id As Long, ByVal indice As Long)
With wsCadastro
.Cells(indice, colCodFor).Value = id
.Cells(indice, colRazao).Value = Me.txtRazao.Text
.Cells(indice, colAbertura).Value = Format(Me.txtAbertura.Text, "mm/dd/yyyy")
.Cells(indice, colFantasia).Value = Me.txtFantasia.Text
.Cells(indice, colGrupoFor).Value = Me.txtGrupoFor.Text
.Cells(indice, colCPF).Value = Me.txtCPF.Text
.Cells(indice, colCNPJ).Value = Me.txtCNPJ.Text
.Cells(indice, colRG).Value = Me.txtRG.Text
.Cells(indice, colEncerramento).Value = Format(Me.txtEncerramento.Text, "mm/dd/yyyy")
.Cells(indice, colContato).Value = Me.txtContato.Text
.Cells(indice, colIE).Value = Me.txtIE.Text
.Cells(indice, colCargoContato).Value = Me.txtCargoContato.Text
.Cells(indice, colCEP).Value = Me.txtCEP.Text
.Cells(indice, colEnd).Value = Me.txtEnd.Text
.Cells(indice, colNum).Value = Me.txtNum.Text
.Cells(indice, colBairro).Value = Me.txtBairro.Text
.Cells(indice, colUF).Value = Me.txtUF.Text
.Cells(indice, colCidade).Value = Me.txtCidade.Text
.Cells(indice, colFone1).Value = Me.txtFone1.Text
.Cells(indice, colFone2).Value = Me.txtFone2.Text
.Cells(indice, colSituacao).Value = Me.txtSituacao.Text
.Cells(indice, colEmail).Value = Me.txtEmail.Text
.Cells(indice, colObs).Value = Me.txtObs.Text
End With
Call AtualizaRegistroCorrente
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 wsCadastro
Do While Not IsEmpty(.Cells(i, colCodFor))
If .Cells(i, colCodFor).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
Private Sub LimpaControles()
Me.txtCodFor.Text = ""
Me.txtRazao.Text = ""
Me.txtAbertura.Text = ""
Me.txtFantasia.Text = ""
Me.txtGrupoFor.Text = ""
Me.txtCPF.Text = ""
Me.txtCNPJ.Text = ""
Me.txtRG.Text = ""
Me.txtEncerramento.Text = ""
Me.txtContato.Text = ""
Me.txtIE.Text = ""
Me.txtCargoContato.Text = ""
Me.txtCEP.Text = ""
Me.txtEnd.Text = ""
Me.txtNum.Text = ""
Me.txtBairro.Text = ""
Me.txtUF.Text = ""
Me.txtCidade.Text = ""
Me.txtFone1.Text = ""
Me.txtFone2.Text = ""
Me.txtSituacao.Text = ""
Me.txtEmail.Text = ""
Me.txtObs.Text = ""
End Sub
Private Sub HabilitaControles()
'Me.txtCodFor.Locked = False
Me.txtRazao.Locked = False
Me.txtAbertura.Locked = False
Me.txtFantasia.Locked = False
Me.txtGrupoFor.Locked = False
Me.txtCPF.Locked = False
Me.txtCNPJ.Locked = False
Me.txtRG.Locked = False
Me.txtEncerramento.Locked = False
Me.txtContato.Locked = False
Me.txtIE.Locked = False
Me.txtCargoContato.Locked = False
Me.txtCEP.Locked = False
Me.txtEnd.Locked = False
Me.txtNum.Locked = False
Me.txtBairro.Locked = False
Me.txtUF.Locked = False
Me.txtCidade.Locked = False
Me.txtFone1.Locked = False
Me.txtFone2.Locked = False
Me.txtSituacao.Locked = False
Me.txtEmail.Locked = False
Me.txtObs.Locked = False
'Me.txtCodFor.Text = corEnabledTextBox
Me.txtRazao.BackColor = corEnabledTextBox
Me.txtAbertura.BackColor = corEnabledTextBox
Me.txtFantasia.BackColor = corEnabledTextBox
Me.txtGrupoFor.BackColor = corEnabledTextBox
Me.txtCPF.BackColor = corEnabledTextBox
Me.txtCNPJ.BackColor = corEnabledTextBox
Me.txtRG.BackColor = corEnabledTextBox
Me.txtEncerramento.BackColor = corEnabledTextBox
Me.txtContato.BackColor = corEnabledTextBox
Me.txtIE.BackColor = corEnabledTextBox
Me.txtCargoContato.BackColor = corEnabledTextBox
Me.txtCEP.BackColor = corEnabledTextBox
Me.txtEnd.BackColor = corEnabledTextBox
Me.txtNum.BackColor = corEnabledTextBox
Me.txtBairro.BackColor = corEnabledTextBox
Me.txtUF.BackColor = corEnabledTextBox
Me.txtCidade.BackColor = corEnabledTextBox
Me.txtFone1.BackColor = corEnabledTextBox
Me.txtFone2.BackColor = corEnabledTextBox
Me.txtSituacao.BackColor = corEnabledTextBox
Me.txtEmail.BackColor = corEnabledTextBox
Me.txtObs.BackColor = corEnabledTextBox
End Sub
Private Sub DesabilitaControles()
Me.txtCodFor.Locked = True
Me.txtRazao.Locked = True
Me.txtAbertura.Locked = True
Me.txtFantasia.Locked = True
Me.txtGrupoFor.Locked = True
Me.txtCPF.Locked = True
Me.txtCNPJ.Locked = True
Me.txtRG.Locked = True
Me.txtEncerramento.Locked = True
Me.txtContato.Locked = True
Me.txtIE.Locked = True
Me.txtCargoContato.Locked = True
Me.txtCEP.Locked = True
Me.txtEnd.Locked = True
Me.txtNum.Locked = True
Me.txtBairro.Locked = True
Me.txtUF.Locked = True
Me.txtCidade.Locked = True
Me.txtFone1.Locked = True
Me.txtFone2.Locked = True
Me.txtSituacao.Locked = True
Me.txtEmail.Locked = True
Me.txtObs.Locked = True
'Me.txtCodFor.Text = corDisabledTextBox
Me.txtRazao.BackColor = corDisabledTextBox
Me.txtAbertura.BackColor = corDisabledTextBox
Me.txtFantasia.BackColor = corDisabledTextBox
Me.txtGrupoFor.BackColor = corDisabledTextBox
Me.txtCPF.BackColor = corDisabledTextBox
Me.txtCNPJ.BackColor = corDisabledTextBox
Me.txtRG.BackColor = corDisabledTextBox
Me.txtEncerramento.BackColor = corDisabledTextBox
Me.txtContato.BackColor = corDisabledTextBox
Me.txtIE.BackColor = corDisabledTextBox
Me.txtCargoContato.BackColor = corDisabledTextBox
Me.txtCEP.BackColor = corDisabledTextBox
Me.txtEnd.BackColor = corDisabledTextBox
Me.txtNum.BackColor = corDisabledTextBox
Me.txtBairro.BackColor = corDisabledTextBox
Me.txtUF.BackColor = corDisabledTextBox
Me.txtCidade.BackColor = corDisabledTextBox
Me.txtFone1.BackColor = corDisabledTextBox
Me.txtFone2.BackColor = corDisabledTextBox
Me.txtSituacao.BackColor = corDisabledTextBox
Me.txtEmail.BackColor = corDisabledTextBox
Me.txtObs.BackColor = corDisabledTextBox
End Sub
Private Sub DesabilitaBotoesAlteracao()
'desabilita os botões de alteração
optAlterar.Enabled = False
optExcluir.Enabled = False
optNovo.Enabled = False
End Sub
Private Sub HabilitaBotoesAlteracao()
'habilita os botões de alteração
optAlterar.Enabled = True
optExcluir.Enabled = True
optNovo.Enabled = True
btnConfirmar.Enabled = True
btnCancelar.Enabled = True
btnPesquisar.Enabled = True
' limpa os valores dos controles
optAlterar.Value = False
optExcluir.Value = False
optNovo.Value = False
End Sub
'CEP
Private Sub txtCEP_Change()
txtCEP.MaxLength = 9
'Formata Numero automático ao digitar
If Len(txtCEP) = 5 Or Len(txtCEP) = 5 Then
txtCEP.Text = txtCEP.Text & "-"
SendKeys "{End}", True
End If
End Sub
Private Sub txtCEP_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'para permitir que apenas números sejam digitados
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub
Private Sub VerificartxtCEP()
'
' Exemplo de utilização
'
Dim resultado
Dim Texto As String
resultado = busca_txtCEP(Me.txtCEP)
Dim i As Integer
Dim X As String
For i = 0 To 14
X = X & Chr(13) & resultado(i)
Next
Select Case resultado(2)
Case "0" 'CEP NÃO LOCALIZADO
Me.lblCepMsg.Caption = Replace(resultado(4), "sucesso - ", "")
Me.lblCepMsg.Caption = Replace(lblCepMsg.Caption, "%E3", "ã")
Case "1" 'CEP LOCALIZADO
Me.txtEnd = resultado(12) & " " & resultado(14)
Me.txtBairro = resultado(10)
Me.txtCidade = resultado(
![Cool](https://2img.net/i/fa/i/smiles/icon_cool.gif)
Me.txtUF = resultado(6)
Case Else
End Select
End Sub
Private Sub txtCEP_AfterUpdate()
Call VerificartxtCEP
On Error Resume Next
If Not IsNull(Me.txtEnd) Or Not IsNull(Me.txtBairro) Or Not IsNull(Me.txtCidade) Then
Me.txtEnd = Replace(Me.txtEnd, "%E1", "á")
Me.txtEnd = Replace(Me.txtEnd, "%E2", "â")
Me.txtEnd = Replace(Me.txtEnd, "%E3", "ã")
Me.txtEnd = Replace(Me.txtEnd, "%E7", "ç")
Me.txtEnd = Replace(Me.txtEnd, "%E9", "é")
Me.txtEnd = Replace(Me.txtEnd, "%EA", "ê")
Me.txtEnd = Replace(Me.txtEnd, "%ED", "í")
Me.txtEnd = Replace(Me.txtEnd, "%F3", "ó")
Me.txtEnd = Replace(Me.txtEnd, "%F4", "ô")
Me.txtEnd = Replace(Me.txtEnd, "%F5", "õ")
Me.txtEnd = Replace(Me.txtEnd, "%FA", "ú")
Me.txtBairro = Replace(Me.txtBairro, "%E1", "á")
Me.txtBairro = Replace(Me.txtBairro, "%E2", "â")
Me.txtBairro = Replace(Me.txtBairro, "%E3", "ã")
Me.txtBairro = Replace(Me.txtBairro, "%E7", "ç")
Me.txtBairro = Replace(Me.txtBairro, "%E9", "é")
Me.txtBairro = Replace(Me.txtBairro, "%EA", "ê")
Me.txtBairro = Replace(Me.txtBairro, "%ED", "í")
Me.txtBairro = Replace(Me.txtBairro, "%F3", "ó")
Me.txtBairro = Replace(Me.txtBairro, "%F4", "ô")
Me.txtBairro = Replace(Me.txtBairro, "%F5", "õ")
Me.txtBairro = Replace(Me.txtBairro, "%FA", "ú")
Me.txtCidade = Replace(Me.txtCidade, "%E1", "á")
Me.txtCidade = Replace(Me.txtCidade, "%E2", "â")
Me.txtCidade = Replace(Me.txtCidade, "%E3", "ã")
Me.txtCidade = Replace(Me.txtCidade, "%E7", "ç")
Me.txtCidade = Replace(Me.txtCidade, "%E9", "é")
Me.txtCidade = Replace(Me.txtCidade, "%EA", "ê")
Me.txtCidade = Replace(Me.txtCidade, "%ED", "í")
Me.txtCidade = Replace(Me.txtCidade, "%F3", "ó")
Me.txtCidade = Replace(Me.txtCidade, "%F4", "ô")
Me.txtCidade = Replace(Me.txtCidade, "%F5", "õ")
Me.txtCidade = Replace(Me.txtCidade, "%FA", "ú")
End If
End Sub
Function busca_txtCEP()
Url = "http://republicavirtual.com.br/web_cep.php?cep=" & txtCEP & "&formato=query_string"
'TROQUEI ServerXMLHTTP POR XMLHTTP E AGORA FUNCIONA CORRETAMENTE
'Set XMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", Url, False
XMLHTTP.Send ""
xmlhttp_resultado = XMLHTTP.responseText
Set XMLHTTP = Nothing
arr_resultado = Split(xmlhttp_resultado, "&")
Dim resultado(7)
For i = LBound(arr_resultado) To UBound(arr_resultado)
resultado(i) = arr_resultado(i)
Next
arr = Split(Join(resultado, "="), "=")
Dim arr_2(14)
For i = LBound(arr) To UBound(arr)
arr_2(i) = Replace(arr(i), "+", " ")
Next
busca_cep = arr_2
End Function