[Resolvido]excell para VB

Veja os possiveis casos que chequei... Te enviarei o arquivo e teste... retornando caso queira que modifique algo.


'Checo se o comprimento total do codigo ultrapasa 15 dígitos
If ComCodigo > 15 Then
MsgBox "Os dígitos não podem ser maiores que 15 dígitos!", vbCritical, "ERRO"
Me.txtNum = ""
Exit Sub
End If

'Checo se o o código se inicia com PT e o seu comprimento total do codigo ultrapasa 11 dígitos
If ComCodigo > 11 And StrPrefixo = "PT" Then
MsgBox "Os código para Portugal não podem ser maiores que 11 dígitos!", vbCritical, "ERRO"
Me.txtNum = ""
Exit Sub

End If

'Checo que o código se inicia com PT e possue 9 dígitos, caso positivo vai diretamente para validação
If StrPrefixo = "PT" And Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 9 Then GoTo Valida


'Checo para PT + 11 ou 10 ou 6 ou 5 caso positivo emite menssagem de erro
If StrPrefixo = "PT" And Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 11 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 10 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 8 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 6 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 5 Then
MsgBox "Os dígitos não podem conter apenas: " & Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) & " números ", vbCritical, "ERRO"
Me.txtNum = ""
Exit Sub
End If

'Checo se as primeiras 3 posições do código são do tipo texto, e se a mesma se inicia com PT e o comprimento para 6 ou 5
If IsNumeric(Mid(Me.txtNum, 1, 3)) = False And StrPrefixo <> "PT" And Len(Mid(Me.txtNum, 4, Len(Me.txtNum))) = 6 Or Len(Mid(Me.txtNum, 4, Len(Me.txtNum))) = 5 Then
MsgBox "Os dígitos para códigos estrabgeiros não podem conter apenas: " & Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) & " números ", vbCritical, "ERRO"
Me.txtNum = ""
Exit Sub
End If

'Checo se código total tem menos de 11 dígitos
If Len(Me.txtNum) < 11 Then MsgBox "Código com menos de 11 dígitos!", vbCritical, "ERRO": Exit Sub


https://dl.dropbox.com/u/26441349/jhp_3.rar

Teste todas as combinações possíveis de acordo com vossa utilização, qualquer sugestão apite.


Cumprimentos.

Faremos a tabela para caso se digite um numero com sigla estrangeira, se verifique se a mesma é valida...

Por favor, coloque a sigla e o nome do pais a frente.

Cumprimentos.

no caso atras a um erro o caso dos
PTS300300
e PT7300300 estes tao bem é o caso antigo

o pais a que pertencem nao e relevante

Teste novamente:

https://dl.dropbox.com/u/26441349/jhp_4.rar


Cumprimentos.

Uma pergunta... Está procurando aprender com os códigos ou estás apenas a buscar a solução pronta?


Saudações.

ja aprendi algumas coisas piloto mas e dificil a linguagem ando a procura de uma apostilha boa de VB mas tb isso fica dificil uma com exemplos praticos
esta ajuda esta a ser preciosa mas eu conseguir algo sozinho não devo conseguir pk nunca estudei este tipo de coisas
obrigado piloto pela ajuda dada

editado
ja percebi um pouco a mecanica eu ja programei em Texas instrument's nao sei que liguagem usa mas sei alguma coisa dela este aqui e similar pelo que ja vi
a parte
If , Then, else, end if e igual a mecanica isso eu percebo bem eu perco-me e na variaveis

este ultimo está perfecto piloto

obrigado piloto será o forum enumerado nos creditos e tu tambem este forum ta excelente ja aprendi bastante aqui

Não vais querer que implatemos as siglas?

coloque a sigla e o nome do pais a frente.
E ja o vou aplicar ao teu BD


Cumprimentos.

hum ok piloto
mas sinto que peço demais so isso mas vou por então
aqui vai então

PT - Portugal
BE - Bélgica
DK - Dinamarca
FR - França
DE - Alemanha
EL - Grécia
IE - Irlanda
IT - Itália
LU - Luxemburgo
NL - Paises Baixos
ES - Espanha
UK - Reino Unido
AT - Àutria
FI - Finlândia
SE - Suécia
CZ - Republica Checa
CY - Chipre
EE - Estónia
HU - Hungria
LV - Letónia
LT - Lituânia
MT - Malta
PL - Polónia
SI - Eslovénia
SK - Eslováquia
RO - Roménia

Boas Joel... eis ja aplicado aos teus forms...

1 - Renomeei campos na tabela para padronização de nomes e dados.
2 - Apliquei botões de navegação e listbox para pesquisa do bovino
3 - Icone de um boi (Podes tirar se quiser pois é meio cómico) Lol!!!
4 - Form para o cadastro das Siglas

A tabela com as siglas é utilizada da seguinte maneira:

'Verifico se a sigla existe para o país na tabela, se o retorno da contagem for = 0 emite menssagem e encerra a sub
If DCount("*", "tblCodPais", "CpSiglaPais = '" & StrPrefixo & "'") = 0 Then
   MsgBox "A SIgla do País >>>> " & StrPrefixo & " <<<< não está cadastrado, verifique!", vbCritical, "ERRO"
   Exit Sub
End If

https://dl.dropbox.com/u/26441349/livro%20de%20bovinos.rar

Ps. Gostaria de postar este exemplo na sala de repositório se nos permite.


Enjoy

claro piloto que podes a ajuda que me destes pode ficar disponivel para outros
agora vou aplicar uma macro tb no botao de gravar para que chek uma checkbox que vai tornar o registo inalterável mas isso eu ja vi por aqui vou tentar aplicar ao meu projecto

um grande obrigado
Joel Henriques
esse projecto vai ser readptado ao meu
ate porque a tabelas que nao podem ser mexidas pelo user so pelo admin mas tambem ja adaptei uma coisa de login com sucesso

Clique no ícone da maozinha verde na menssagem que o auxiliou.


O Fórum agradece o retorno.

Cumprimentos.

done piloto um grande obrigado

É isso ai... inté a próxima...

O Fórum agradece o Retorno.

sei que ja passou algum tempo e esse programita tem ajudado muito mesmo
acontece que apareceu um animal françes e ele dá erro
tou iniciando video aulas de um site "mabesi" mas ainda não cheguei tao a frente
acontece que para o nº FR4963709089 o programa da erro mas este nº está correcto:oops:  seria possivel isto considerar esse animal como certo??

cumprimentos e mais uma vez obrigado
Joel Henriques

conclui com uma pequena ajuda de pesquisa
e com um conhecimento de TIbasic que e a linguagem presente nas calculadoras TI83 que sabia

codigo

Código:



Private Sub btnVerifica_Click()
On Error GoTo trataerro
'***********************************************************************
'Rotina de verificação para número de registro de bovinos em Portugal
'Efetuada por Pelo Usuário PILOTO, do Fórum MáximoAccess
'Para Joel Henriques
'Em 31/10/2012
'***********************************************************************
Dim NumCodigo As Variant
Dim Num As Integer, NumTot As Integer, NumTot1 As Integer
Dim Result As Long, ResultMult As Long
Dim Digito As Long, DigitoAtual As Long
Dim StrPrefixo, strNumero As Long
Dim CompCodigo As Integer

'Carrego na variável o comprimento total do código
ComCodigo = Len(Me.txtNum)
StrPrefixo = Left(Me.txtNum, 2)

'Verifico se a sigla existe para o país na tabela
If DCount("*", "tblCodPais", "CpSiglaPais = '" & StrPrefixo & "'") = 0 Then
  MsgBox "A SIgla do País >>>> " & StrPrefixo & " <<<< não está cadastrado, verifique!", vbCritical, "ERRO"
  Exit Sub
End If
'Checo se o comprimento total do codigo ultrapasa 15 dígitos
If ComCodigo > 15 Then
  MsgBox "Os dígitos não podem ser maiores que 15 dígitos!", vbCritical, "ERRO"
  Me.txtNum = ""
Exit Sub
End If

'Checo se o o código se inicia com PT e o seu comprimento total do codigo ultrapasa 11 dígitos
If ComCodigo > 11 And StrPrefixo = "PT" Then
  MsgBox "Os código para Portugal não podem ser maiores que 11 dígitos!", vbCritical, "ERRO"
  Me.txtNum = ""
Exit Sub

End If

'Checo que o código se inicia com PT e possue 9 dígitos, caso positivo vai diretamente para validação
If StrPrefixo = "PT" And Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 9 Then GoTo Valida Else: GoTo final


'Checo para PT + 11 ou 10 ou 6 ou 5 caso positivo emite menssagem de erro
If StrPrefixo = "PT" And Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 11 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 10 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 8 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 6 Or Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) = 5 Then
    MsgBox "Os dígitos não podem conter apenas: " & Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) & " números ", vbCritical, "ERRO"
    Me.txtNum = ""
    Exit Sub
End If

'Checo se as primeiras 3 posições do código são do tipo texto, e se a mesma se inicia com PT e o comprimento para 6 ou 5
If IsNumeric(Mid(Me.txtNum, 1, 3)) = False And StrPrefixo <> "PT" And Len(Mid(Me.txtNum, 4, Len(Me.txtNum))) = 6 Or Len(Mid(Me.txtNum, 4, Len(Me.txtNum))) = 5 Then
    MsgBox "Os dígitos para códigos estrangeiros não podem conter apenas: " & Len(Mid(Me.txtNum, 3, Len(Me.txtNum))) & " números ", vbCritical, "ERRO"
    Me.txtNum = ""
    Exit Sub
End If

'Checo se código total tem menos de 11 dígitos
If IsNumeric(Left(Me.txtNum, 3)) = False And StrPrefixo = "PT" And Len(CompCodigo) > 11 Then Exit Sub
If IsNumeric(Left(Me.txtNum, 3)) = False And StrPrefixo <> "PT" And Len(CompCodigo) > 11 Then MsgBox "Código com menos de 11 dígitos!", vbCritical, "ERRO": Exit Sub
Exit Sub
Valida:
'Caso não ocorra algumas das hipóteses de erro acima, carrega na variável os numeros para checar o dígito verificador
NumCodigo = Mid(Me.txtNum, 4, 8)
'Carrego a posição referente ao digito verificador para checar se oonfere ao final o código
DigitoAtual = Mid(Me.txtNum, 3, 1)
'*********************************************************************************************************************
'Execução dos cálculos para o digito verificador
'Para a soma dos digitos na posição 2,4,6,8
For X = 2 To 8 Step 2
    Num = Mid(NumCodigo, X, 1)
    NumTot = NumTot + Num
Next X
   
'Para a soma  de todos os digitos
For X = 1 To 8
    Num = Mid(NumCodigo, X, 1)
    NumTot1 = NumTot1 + Num
Next X

Result = NumTot1 + NumTot
ResultMult = fncMult10(Result)
'*********************************************************************************************************************
'Comparação do digito contido no código digitado com o digito calculado
Digito = ResultMult - Result

Me.txtNumVal = Digito

If DigitoAtual <> Digito Then
    MsgBox "Numero inválido", vbCritical, "ERRO"
Else
    MsgBox "Numero correto", vbInformation, "VALIDO"
End If
Exit Sub

Exit_TrataErro:
    DoCmd.Hourglass False
    DoCmd.Echo True
 Exit Sub

trataerro:
If Err.Number = 13 Then
    MsgBox "O Dígito na posição " & X + 1 & " após a sigla, é do tipo texto", vbCritical, "ABORTANDO OPERAÇÃO"
    Exit Sub
Else
 DoCmd.Hourglass False
 DoCmd.Echo True
 MsgErro = "Erro # " & Str(Err.Number) & " gerado na " & Err.Source _
 & vbNewLine & vbNewLine & "Descrição: " & Err.Description _
 & vbNewLine & vbNewLine & "Por favor contate o Administrador de Sistema."
 MsgBox MsgErro, vbMsgBoxHelpButton + vbCritical, "Erro", Err.HelpFile, Err.HelpContext
 Resume Exit_TrataErro
final:
End If
End Sub

'***********************************************************************
'Rotina de verificação de multiplos de 10
'Efetuada por Pelo Usuário AVELINO, do Fórum MáximoAccess
'Para PILOTO
'***********************************************************************
Public Function fncMult10(Num As Long) As Long
Dim j As Byte
For j = 0 To 9
    If (Num + j) Mod 10 = 0 Then
        fncMult10 = Num + j
        Exit For
    End If
Next
End Function


pequena alteração ali na parte que vai validar os portugueses com 9 digitos acrescentei o "else" ou seja caso nao se verifique salta todo o codigo