Public Function Verificar_NPJ(NRCNPJ_ADQ As String)
Dim X, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14 As Integer
Dim B1, B2, B3, B4, B5, B6, B7, V, DV As Integer

'Seleção de números
X = Left(NRCNPJ_ADQ, 1) 'Primeiro caractere
X1 = Left(NRCNPJ_ADQ, 2) 'Dois caracteres
X2 = Left(NRCNPJ_ADQ, 3) 'Três caracteres
X3 = Left(NRCNPJ_ADQ, 4)
X4 = Left(NRCNPJ_ADQ, 5)
X5 = Left(NRCNPJ_ADQ, 6)
X6 = Left(NRCNPJ_ADQ, 7)
X7 = Left(NRCNPJ_ADQ, 8)
X8 = Left(NRCNPJ_ADQ, 9)
X9 = Left(NRCNPJ_ADQ, 10)
X10 = Left(NRCNPJ_ADQ, 11)
X11 = Left(NRCNPJ_ADQ, 12)
X12 = Left(NRCNPJ_ADQ, 13)
X13 = Left(NRCNPJ_ADQ, 14)

'Atribuindo Seleções

B1 = X
B2 = Right(X1, 1) 'Último caractere do X1
B3 = Right(X2, 1) 'Último caractere do X2
B4 = Right(X3, 1) 'Último caractere do X3
B5 = Right(X4, 1) 'Último caractere do X4
B6 = Right(X5, 1) 'Último caractere do X5
B7 = Right(X6, 1) 'Último caractere do X6
DV = Right(X7, 1) 'Último caractere do X7
O1 = Right(X8, 1) 'Último caractere do X8
O2 = Right(X9, 1) 'Último caractere do X9
O3 = Right(X10, 1) 'Último caractere do X10
O4 = Right(X11, 1) 'Último caractere do X11
C1 = Right(X12, 1) 'Último caractere do X12
C2 = Right(X13, 1) 'Último caractere do X13

'Calculo do dígito
Dim K1, K2, K3, K4, K5, K6, K7 As Integer

K1 = B1 * 2
K2 = B2 * 1
K3 = B3 * 2
K4 = B4 * 1
K5 = B5 * 2
K6 = B6 * 1
K7 = B7 * 2

'Atribuindo valores para o calculo do dígito
Dim T1, T2, t3, T4, T5, T6, T7, T8, T9, T10, T11, D1, D2 As Integer

If K1 < 10 Then
T1 = 0
Else
T1 = Left(K1, 1)
End If
T2 = Right(K1, 1)
t3 = K2

If K3 < 10 Then
T4 = 0
Else
T4 = Left(K3, 1)
End If
T5 = Right(K3, 1)
T6 = K4
If K5 < 10 Then
T7 = 0
Else
T7 = Left(K5, 1)
End If
T8 = Right(K5, 1)
T9 = K6

If K7 < 10 Then
T10 = 0
Else
T10 = Left(K7, 1)
End If
T11 = Right(K7, 1)
CALCULO = (Int(T1) + Int(T2) + Int(t3) + Int(T4) + Int(T5) + Int(T6) + Int(T7) + Int(T8) + Int(T9) + Int(T10) + Int(T11))
D1 = Right(CALCULO, 1)
D2 = Left(CALCULO, 1)
V = Int(D1)

If V <> 0 Then
V = ((Int(D2) + 1) * 10) - CALCULO
End If

'Calcular o Primeiro controle "C1"

TOTAL = ((O4 * 2) + (O3 * 3) + (O2 * 4) + (O1 * 5) + (DV * 6) + (B7 * 7) + (B6 * 8) + (B5 * 9) + (B4 * 2) + (B3 * 3) + (B2 * 4) + (B1 * 5))

RESTO = TOTAL Mod 11

If RESTO = 0 Or RESTO = 1 Then
C1 = 0
Else
C1 = 11 - RESTO
End If

'Calcular o Segundo controle "C2"
TOTAL1 = ((C1 * 2) + (O4 * 3) + (O3 * 4) + (O2 * 5) + (O1 * 6) + (DV * 7) + (B7 * 8) + (B6 * 9) + (B5 * 2) + (B4 * 3) + (B3 * 4) + (B2 * 5) + (B1 * 6))
RESTO1 = TOTAL1 Mod 11

If RESTO1 = 0 Or RESTO1 = 1 Then
C2 = 0
Else
C2 = 11 - RESTO1
End If
VLC1 = C1 & C2
If Right(NRCNPJ_ADQ, 2) <> VLC1 Then
Beep
MsgBox "CNPJ não confere", 16, "Atenção"
SendKeys "+{TAB}{DEL}"
End If

End Function

Public Function Verificar_CPF(Cpf As String)

Dim X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11 As String
Dim A, B, C, D, E, F, G, H, I, J, K As String
Dim TOTAL, R_Int1, Digito, Controle1, Controle2 As Integer
'Selecionando Números

X1 = Left(Cpf, 1)
X2 = Left(Cpf, 2)
X3 = Left(Cpf, 3)
X4 = Left(Cpf, 4)
X5 = Left(Cpf, 5)
X6 = Left(Cpf, 6)
X7 = Left(Cpf, 7)
X8 = Left(Cpf, 8)
X9 = Left(Cpf, 9)
X10 = Left(Cpf, 10)
X11 = Left(Cpf, 11)

'Atribuindo Números

A = Int(X1)
B = Int(Right(X2, 1))
C = Int(Right(X3, 1))
D = Int(Right(X4, 1))
E = Int(Right(X5, 1))
F = Int(Right(X6, 1))
G = Int(Right(X7, 1))
H = Int(Right(X8, 1))
I = Int(Right(X9, 1))
J = Int(Right(X10, 1))
K = Int(Right(X11, 1))

'Calculando o dígito

TOTAL = ((A * 3) + (B * 4) + (C * 5) + (D * 6) + (E * 7) + (F * 8) + (G * 9))
R_Int1 = Fix(TOTAL / 11) 'Pegando somente a parte inteira do TOTAL
R_Int1 = R_Int1 * 11
Digito = TOTAL - R_Int1

'Calculando o primeiro controle
TOTAL = ((A * 1) + (B * 2) + (C * 3) + (D * 4) + (E * 5) + (F * 6) + (G * 7) + (H * 8) + (I * 9))
R_Int1 = Fix(TOTAL / 11) 'Pegando somente a parte inteira do TOTAL
R_Int1 = R_Int1 * 11
Controle1 = TOTAL - R_Int1
If Controle1 = 10 Then
Controle1 = 0
End If

'Calculando o segundo controle
TOTAL = ((B * 1) + (C * 2) + (D * 3) + (E * 4) + (F * 5) + (G * 6) + (H * 7) + (I * 8) + (Controle1 * 9))
R_Int1 = Fix(TOTAL / 11) 'Pegando somente a parte inteira do TOTAL
R_Int1 = R_Int1 * 11
Controle2 = TOTAL - R_Int1
If Controle2 = 10 Then
Controle2 = 0
End If

If Right(Cpf, 2) <> Controle1 & Controle2 Then
Verificar_CPF = False
Else
Verificar_CPF = True
End If

End Function

Public Function Datilografar()
Dim Retorno
Retorno = PlaySound("C:\Windows\Media\Office97\Digitar.wav", 1, 1)

End Function

Abraço,
Flavio
www.spyderit.com.br