Validação de Código de Bovinos em Portugal

Em ajuda a um colega do Fórum....

Utiliza a rotina abaixo para proceder a determinadas somas buscando verificar ou mesmo encontrar o digito verificador para Bovinos em Portugal

Exemplo: PT216832811
Onde o número em vermelho é o dígito verificador

Código:


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.Cod_IdBov)
StrPrefixo = Left(Me.Cod_IdBov, 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.Cod_IdBov = ""
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.Cod_IdBov = ""
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.Cod_IdBov, 3, Len(Me.Cod_IdBov))) = 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.Cod_IdBov, 3, Len(Me.Cod_IdBov))) = 11 Or Len(Mid(Me.Cod_IdBov, 3, Len(Me.Cod_IdBov))) = 10 Or Len(Mid(Me.Cod_IdBov, 3, Len(Me.Cod_IdBov))) = 8 Or Len(Mid(Me.Cod_IdBov, 3, Len(Me.Cod_IdBov))) = 6 Or Len(Mid(Me.Cod_IdBov, 3, Len(Me.Cod_IdBov))) = 5 Then
    MsgBox "Os dígitos não podem conter apenas: " & Len(Mid(Me.Cod_IdBov, 3, Len(Me.Cod_IdBov))) & " números ", vbCritical, "ERRO"
    Me.Cod_IdBov = ""
    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.Cod_IdBov, 1, 3)) = False And StrPrefixo <> "PT" And Len(Mid(Me.Cod_IdBov, 4, Len(Me.Cod_IdBov))) = 6 Or Len(Mid(Me.Cod_IdBov, 4, Len(Me.Cod_IdBov))) = 5 Then
    MsgBox "Os dígitos para códigos estrangeiros não podem conter apenas: " & Len(Mid(Me.Cod_IdBov, 3, Len(Me.Cod_IdBov))) & " números ", vbCritical, "ERRO"
    Me.Cod_IdBov = ""
    Exit Sub
End If

'Checo se código total tem menos de 11 dígitos
If IsNumeric(Left(Me.Cod_IdBov, 3)) = False And StrPrefixo = "PT" And Len(CompCodigo) > 11 Then Exit Sub
If IsNumeric(Left(Me.Cod_IdBov, 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.Cod_IdBov, 4, 8)
'Carrego a posição referente ao digito verificador para checar se oonfere ao final o código
DigitoAtual = Mid(Me.Cod_IdBov, 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

If DigitoAtual <> Digito Then
    MsgBox "Numero inválido", vbCritical, "ERRO"
    Me.CpCod_Bovino = ""
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
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


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

Cumprimentos.

um abraço ai para o brasil