Msantam,
oltre a quanto suggerito da Alex, consiglio di rivedere il codice da te postato in quanto vi sono istruzioni non significative, altre che potrebbero essere raccolte (vista l'applicabilità in diversi punti) in una univoca funzione, inoltre si nota che l'applicativo è stato pensato con un altro linguaggio e quindi adattato al VBA, di Access, non sfruttando le potenzialità di questo.
Se può esserti utile ti riallego il tuo codice (con delle annotazioni di massima sulle porzioni di istruzioni) che magari puoi mettere a confronto con altri due applicativi disponibili sul web e scaricabili a questi link:
http://web.mclink.it/MC5884
che, seppure datati, possono esserti di aiuto a ricostruire la logica del calcolo del codice fiscale.
Option Compare Database
Option Explicit
Function CODFISC(Cognome, Nome, Sesso As String, Nascita As Date, Comune, Prov As String) As String
Dim Cog1, Cog2, Cog3, Nom1, Nom2, Nom3, Ses1, Nas3, Nas5 As String, Nas1, Nas2, Nas4, C, N As Integer
Dim Chk, LC1, LC2, CD, Pr As String, L As Integer
'GoTo INIZIO
INIZIO:
'Cognome
Cognome = StrConv(Cognome, vbUpperCase)
Cognome = Trim(Cognome)
C = Len(Cognome)
Cog2 = ""
Dim I
'Toglie gli spazi dal cognome e sostituisce vocali accentate
For I = 1 To C
Cog1 = Mid(Cognome, I, 1)
If Cog1 = Chr(32) Then Cog1 = ""
If Cog1 = "'" Then Cog1 = ""
If Cog1 = "-" Then Cog1 = ""
If Cog1 = "." Then Cog1 = ""
If Cog1 = "À" Then Cog1 = "A"
If Cog1 = "È" Then Cog1 = "E"
If Cog1 = "É" Then Cog1 = "E"
If Cog1 = "Ì" Then Cog1 = "I"
If Cog1 = "Ò" Then Cog1 = "O"
If Cog1 = "Ù" Then Cog1 = "U"
Cog2 = Cog2 + Cog1
Next I
Cognome = Cog2
'estrae le consonanti
Cog2 = ""
For I = 1 To C
Cog1 = Mid(Cognome, I, 1)
If Cog1 = "A" Then Cog1 = ""
If Cog1 = "E" Then Cog1 = ""
If Cog1 = "I" Then Cog1 = ""
If Cog1 = "O" Then Cog1 = ""
If Cog1 = "U" Then Cog1 = ""
Cog2 = Cog2 + Cog1
If Len(Cog2) > 2 Then I = C
Next I
Cog3 = Cog2
'estrae le vocali
Cog2 = ""
If Len(Cog3) = 3 Then GoTo NoVocali
For I = 1 To C
Cog1 = Mid(Cognome, I, 1)
If Cog1 = "B" Then Cog1 = ""
If Cog1 = "C" Then Cog1 = ""
If Cog1 = "D" Then Cog1 = ""
If Cog1 = "F" Then Cog1 = ""
If Cog1 = "G" Then Cog1 = ""
If Cog1 = "H" Then Cog1 = ""
If Cog1 = "J" Then Cog1 = ""
If Cog1 = "K" Then Cog1 = ""
If Cog1 = "L" Then Cog1 = ""
If Cog1 = "M" Then Cog1 = ""
If Cog1 = "N" Then Cog1 = ""
If Cog1 = "P" Then Cog1 = ""
If Cog1 = "Q" Then Cog1 = ""
If Cog1 = "R" Then Cog1 = ""
If Cog1 = "S" Then Cog1 = ""
If Cog1 = "T" Then Cog1 = ""
If Cog1 = "V" Then Cog1 = ""
If Cog1 = "W" Then Cog1 = ""
If Cog1 = "X" Then Cog1 = ""
If Cog1 = "Y" Then Cog1 = ""
If Cog1 = "Z" Then Cog1 = ""
Cog2 = Cog2 + Cog1
If Len(Cog2) > 2 Then I = C ' Uscita
Next I
Cog3 = Cog3 + Cog2
NoVocali:
Cog3 = Left(Cog3, 3)
If Len(Cog3) = 2 Then Cog3 = Cog3 + "X"
If Len(Cog3) = 1 Then Cog3 = Cog3 + "XX"
'Nome
Nome = StrConv(Nome, vbUpperCase)
Nome = Trim(Nome)
N = Len(Nome)
Nom2 = ""
'Toglie gli spazi dal nome e converte le vocali accentate
For I = 1 To N
Nom1 = Mid(Nome, I, 1)
If Nom1 = Chr(32) Then Nom1 = ""
If Nom1 = "'" Then Nom1 = ""
If Nom1 = "-" Then Nom1 = ""
If Nom1 = "." Then Nom1 = ""
If Nom1 = "À" Then Nom1 = "A"
If Nom1 = "È" Then Nom1 = "E"
If Nom1 = "É" Then Nom1 = "E"
If Nom1 = "Ì" Then Nom1 = "I"
If Nom1 = "Ò" Then Nom1 = "O"
If Nom1 = "Ù" Then Nom1 = "U"
Nom2 = Nom2 + Nom1
Next I
Nome = Nom2
'estrae le consonanti
Nom2 = ""
For I = 1 To N
Nom1 = Mid(Nome, I, 1)
' Toglie le vocali
If Nom1 = "A" Then Nom1 = ""
If Nom1 = "E" Then Nom1 = ""
If Nom1 = "I" Then Nom1 = ""
If Nom1 = "O" Then Nom1 = ""
If Nom1 = "U" Then Nom1 = ""
Nom2 = Nom2 + Nom1
If Len(Nom2) > 3 Then I = N ' Uscita
Next I
Nom3 = Nom2
If Len(Nom3) = 3 Then Nom3 = Nom3
If Len(Nom3) = 4 Then Nom3 = Left(Nom3, 1) + Right(Nom3, 2)
'estrae le vocali
Nom2 = ""
If Len(Nom3) = 3 Then GoTo NoVocaliNome
For I = 1 To C
Nom1 = Mid(Nome, I, 1)
If Nom1 = "B" Then Nom1 = ""
If Nom1 = "C" Then Nom1 = ""
If Nom1 = "D" Then Nom1 = ""
If Nom1 = "F" Then Nom1 = ""
If Nom1 = "G" Then Nom1 = ""
If Nom1 = "H" Then Nom1 = ""
If Nom1 = "J" Then Nom1 = ""
If Nom1 = "K" Then Nom1 = ""
If Nom1 = "L" Then Nom1 = ""
If Nom1 = "M" Then Nom1 = ""
If Nom1 = "N" Then Nom1 = ""
If Nom1 = "P" Then Nom1 = ""
If Nom1 = "Q" Then Nom1 = ""
If Nom1 = "R" Then Nom1 = ""
If Nom1 = "S" Then Nom1 = ""
If Nom1 = "T" Then Nom1 = ""
If Nom1 = "V" Then Nom1 = ""
If Nom1 = "W" Then Nom1 = ""
If Nom1 = "X" Then Nom1 = ""
If Nom1 = "Y" Then Nom1 = ""
If Nom1 = "Z" Then Nom1 = ""
Nom2 = Nom2 + Nom1
If Len(Nom2) > 2 Then I = C ' Uscita
Next I
Nom3 = Nom3 + Nom2
NoVocaliNome:
Nom3 = Left(Nom3, 3)
If Len(Nom3) = 2 Then Nom3 = Nom3 + "X"
If Len(Nom3) = 1 Then Nom3 = Nom3 + "XX"
'Anno di Nascita
Nas1 = Year(Nascita)
Nas1 = Right(Nas1, 2)
'Lettera del Mese
Nas2 = Month(Nascita)
If Nas2 = 1 Then Nas3 = "A"
If Nas2 = 2 Then Nas3 = "B"
If Nas2 = 3 Then Nas3 = "C"
If Nas2 = 4 Then Nas3 = "D"
If Nas2 = 5 Then Nas3 = "E"
If Nas2 = 6 Then Nas3 = "H"
If Nas2 = 7 Then Nas3 = "L"
If Nas2 = 8 Then Nas3 = "M"
If Nas2 = 9 Then Nas3 = "P"
If Nas2 = 10 Then Nas3 = "R"
If Nas2 = 11 Then Nas3 = "S"
If Nas2 = 12 Then Nas3 = "T"
'Giorno di nascita
Sesso = StrConv(Sesso, vbUpperCase)
Nas4 = Day(Nascita)
If Left(Sesso, 1) = "F" Then Nas4 = Nas4 + 40
Nas5 = Nas4
If Len(Nas5) = 1 Then Nas5 = "0" + Nas5
Dim LC
'Comune
Comune = StrConv(Comune, vbUpperCase)
C = Len(Comune)
If C > 18 Then C = 18
LC = Comune
Prov = StrConv(Prov, vbUpperCase)
Pr = Prov
'If Pr = "ROMA" Then Pr = "RM"
LC2 = ""
C = Len(Comune)
' Verifica lettere (vocali) accentate (ponendole senza accento)
For I = 1 To C
LC1 = Mid(Comune, I, 1)
If LC1 = Chr(32) Then LC1 = ""
If LC1 = "'" Then LC1 = ""
If LC1 = "-" Then LC1 = ""
If LC1 = "." Then LC1 = ""
If LC1 = "À" Then LC1 = "A"
If LC1 = "È" Then LC1 = "E"
If LC1 = "É" Then LC1 = "E"
If LC1 = "Ì" Then LC1 = "I"
If LC1 = "Ò" Then LC1 = "O"
If LC1 = "Ù" Then LC1 = "U"
LC2 = LC2 + LC1
Next I
LC = Comune
'Tabella codici comuni
LC1 = ""
L = Len(Comune)
' nel caso di città con l'apostrofo
' If LC1 = "" Then LC1 = DLookup("CodComune", "Comuni", "Comune=" & Chr(34) & LC & Chr(34))
' Ricerca il codice Belfiore (di 4 cifre in base a Comune/Stato di nascita) comprensiva della Provincia per distinguere fra occorrenze multiple
If LC1 = "" Then LC1 = DLookup("CodComune", "Comuni", "Comune=" & Chr(34) & LC & Chr(34) & " AND PV=" & Chr(34) & Pr & Chr(34))
CD = LC1
salto:
If (CD = "" Or IsNull(CD)) Then CD = "####"
' Controllo 16° carattere
CODFISC = Cog3 + Nom3 + Nas1 + Nas3 + Nas5 + CD
Chk = CHKFISC(CODFISC, 0)
CODFISC = CODFISC + Chk
If Cognome = "" Or Nome = "" Or Sesso = "" Or Comune = "" Or Prov = "" Then CODFISC = ""
Fine:
End Function
Function CHKFISC(Codice As String, S As Integer) As String
Dim C1, C2, C3 As String, C4, C5, C6, C7, C8, K As Integer
Codice = StrConv(Codice, vbUpperCase) 'Rende maiuscola la stringa
K = Len(Codice) 'Nr caratteri alfanumerici codice fiscale
C2 = ""
If K = 16 Then C2 = Right(Codice, 1) 'Considera il 16° carattere
If K = 16 Then K = 15
Dim MyCheck
MyCheck = Left(Codice, 6) Like "[A-Z][A-Z][A-Z][A-Z][A-Z][A-Z]"
If MyCheck = False Then CHKFISC = "Sbagliato": GoTo Fine
MyCheck = Mid(Codice, 7, 2) Like "##"
If MyCheck = False Then CHKFISC = "Sbagliato": GoTo Fine
MyCheck = Mid(Codice, 9, 1) Like "[A-Z]"
If MyCheck = False Then CHKFISC = "Sbagliato": GoTo Fine
MyCheck = Mid(Codice, 10, 2) Like "##"
If MyCheck = False Then CHKFISC = "Sbagliato": GoTo Fine
MyCheck = Mid(Codice, 12, 1) Like "[A-Z]"
If MyCheck = False Then CHKFISC = "Sbagliato": GoTo Fine
MyCheck = Mid(Codice, 13, 3) Like "###"
If MyCheck = False Then CHKFISC = "Sbagliato": GoTo Fine
If K < 15 And S <> 1 Then GoTo Fine
Dim I
'PARI
C5 = 0
For I = 2 To K Step 2
C1 = Mid(Codice, I, 1)
If C1 = "A" Or C1 = "0" Then C4 = 0
If C1 = "B" Or C1 = "1" Then C4 = 1
If C1 = "C" Or C1 = "2" Then C4 = 2
If C1 = "D" Or C1 = "3" Then C4 = 3
If C1 = "E" Or C1 = "4" Then C4 = 4
If C1 = "F" Or C1 = "5" Then C4 = 5
If C1 = "G" Or C1 = "6" Then C4 = 6
If C1 = "H" Or C1 = "7" Then C4 = 7
If C1 = "I" Or C1 = "8" Then C4 = 8
If C1 = "J" Or C1 = "9" Then C4 = 9
If C1 = "K" Then C4 = 10
If C1 = "L" Then C4 = 11
If C1 = "M" Then C4 = 12
If C1 = "N" Then C4 = 13
If C1 = "O" Then C4 = 14
If C1 = "P" Then C4 = 15
If C1 = "Q" Then C4 = 16
If C1 = "R" Then C4 = 17
If C1 = "S" Then C4 = 18
If C1 = "T" Then C4 = 19
If C1 = "U" Then C4 = 20
If C1 = "V" Then C4 = 21
If C1 = "W" Then C4 = 22
If C1 = "X" Then C4 = 23
If C1 = "Y" Then C4 = 24
If C1 = "Z" Then C4 = 25
C5 = C5 + C4
Next I
'DISPARI
C6 = 0
For I = 1 To K Step 2
C1 = Mid(Codice, I, 1)
If C1 = "A" Or C1 = "0" Then C4 = 1
If C1 = "B" Or C1 = "1" Then C4 = 0
If C1 = "C" Or C1 = "2" Then C4 = 5
If C1 = "D" Or C1 = "3" Then C4 = 7
If C1 = "E" Or C1 = "4" Then C4 = 9
If C1 = "F" Or C1 = "5" Then C4 = 13
If C1 = "G" Or C1 = "6" Then C4 = 15
If C1 = "H" Or C1 = "7" Then C4 = 17
If C1 = "I" Or C1 = "8" Then C4 = 19
If C1 = "J" Or C1 = "9" Then C4 = 21
If C1 = "K" Then C4 = 2
If C1 = "L" Then C4 = 4
If C1 = "M" Then C4 = 18
If C1 = "N" Then C4 = 20
If C1 = "O" Then C4 = 11
If C1 = "P" Then C4 = 3
If C1 = "Q" Then C4 = 6
If C1 = "R" Then C4 = 8
If C1 = "S" Then C4 = 12
If C1 = "T" Then C4 = 14
If C1 = "U" Then C4 = 16
If C1 = "V" Then C4 = 10
If C1 = "W" Then C4 = 22
If C1 = "X" Then C4 = 25
If C1 = "Y" Then C4 = 24
If C1 = "Z" Then C4 = 23
C6 = C6 + C4
Next I
C8 = (C5 + C6) / 26
C7 = (C5 + C6) - (Int(C8) * 26)
If C7 = 0 Then C3 = "A"
If C7 = 1 Then C3 = "B"
If C7 = 2 Then C3 = "C"
If C7 = 3 Then C3 = "D"
If C7 = 4 Then C3 = "E"
If C7 = 5 Then C3 = "F"
If C7 = 6 Then C3 = "G"
If C7 = 7 Then C3 = "H"
If C7 = 8 Then C3 = "I"
If C7 = 9 Then C3 = "J"
If C7 = 10 Then C3 = "K"
If C7 = 11 Then C3 = "L"
If C7 = 12 Then C3 = "M"
If C7 = 13 Then C3 = "N"
If C7 = 14 Then C3 = "O"
If C7 = 15 Then C3 = "P"
If C7 = 16 Then C3 = "Q"
If C7 = 17 Then C3 = "R"
If C7 = 18 Then C3 = "S"
If C7 = 19 Then C3 = "T"
If C7 = 20 Then C3 = "U"
If C7 = 21 Then C3 = "V"
If C7 = 22 Then C3 = "W"
If C7 = 23 Then C3 = "X"
If C7 = 24 Then C3 = "Y"
If C7 = 25 Then C3 = "Z"
If C2 = "" Then CHKFISC = C3
If C2 <> "" And C3 = C2 Then CHKFISC = "Esatto"
If C2 <> "" And C3 <> C2 Then CHKFISC = "Sbagliato"
Fine:
If S = 1 And CHKFISC = "Sbagliato" Then
MsgBox ("Il Codice Fiscale è errato")
CHKFISC = ""
Else
CHKFISC = CHKFISC
End If
If S = 1 And Len(Codice) <> 16 Then
MsgBox ("Ricontrollare il numero dei caratteri del Codice Fiscale")
CHKFISC = ""
Else
CHKFISC = CHKFISC
End If
If S = 1 Then CHKFISC = ""
End Function
Public Function CheckCF(ByVal sz_Codice As String) As Integer
Const ALF1 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const CIF1 = "0123456789"
Const ALF2 = "BAKPLCQDREVOSFTGUHMINJWZYX"
Const CIF2 = "10 2 3 4 5 6 7 8 9 "
Dim c_Char As String * 1
Dim c_Code As String * 1
Dim n_Count As Integer
Dim lcv As Integer
'----- Start
sz_Codice = Left(UCase(sz_Codice) + Space(16), 16)
For lcv = 2 To 14 Step 2
c_Char = Mid$(sz_Codice, lcv, 1)
Select Case c_Char
Case "0" To "9"
n_Count = n_Count + InStr(CIF1, c_Char)
Case "A" To "Z"
n_Count = n_Count + InStr(ALF1, c_Char)
End Select
Next lcv
For lcv = 1 To 15 Step 2
c_Char = Mid$(sz_Codice, lcv, 1)
Select Case c_Char
Case "0" To "9"
n_Count = n_Count + InStr(CIF2, c_Char)
Case "A" To "Z"
n_Count = n_Count + InStr(ALF2$, c_Char)
End Select
Next lcv
n_Count = 1 + ((n_Count - 15) Mod 26) + 64
c_Code = Chr$(n_Count)
c_Char = Mid$(sz_Codice, 16, 1)
If c_Code = c_Char Then
CheckCF = 0
Else
CheckCF = n_Count
End If
End Function
Option Compare Database
Option Explicit
' By:
' Domenico Statuto
' Night Eagle
' Marco Carnazzo
' Ettore Maronese (By -MES-)
'
' 04.07.98 Modificato per la ricerca interattiva sul database By A. Fasano - Matera
'
' Questo codice e' liberamente distribuibile/modificabile/utilizzabile
' Buon Lavoro.
'
' 20.06.00 Adattamento per MSAccess 97 - Federico Luciani
Public DB As Database
Public COMUNI As Recordset
Private Sub cmdElabora_Click()
Dim ctl As Control
For Each ctl In Me.Controls
If ctl.Tag = "x" Then
If IsNull(ctl) Or ctl = "" Then
MsgBox "Il campo " & Mid$(ctl.Name, 4) & " non può essere vuoto!"
Exit Sub
End If
End If
Next ctl
Me.txtCodiceFiscale = CalcoloCodFis(Me.txtCognome, Me.txtNome, CVDate(Me.txtDataNascita), Me.cboSesso, Trim(Me.txtCodiceComune))
End Sub
Private Sub cmdEsci_Click()
DoCmd.Close acForm, Me.Name
End Sub
Private Sub Comando18_Click()
Me.txtCodiceComune = ""
Me.txtCodiceFiscale = ""
Me.txtCognome = ""
Me.txtComune = ""
Me.txtDataNascita = ""
Me.txtNome = ""
Me.txtProvincia = ""
Me.txtCognome.SetFocus
End Sub
Private Sub Form_Load()
On Error GoTo ErrFas
Set DB = CurrentDb
Set COMUNI = DB.OpenRecordset("Comunifis")
COMUNI.Index = "COMUNI2L"
Exit Sub
ErrFas:
MsgBox ("FasMsg: " & Err.Number & " " & Err.Description)
Err.Clear
End Sub
Private Function CalcoloCodFis(ByVal Cognome$, ByVal Nome$, DataNascita As Date, Sesso$, Provincia$) As String
'Necessita la presenza di 7 textbox con i seguenti nomi:
'TxtCodFis, TxtCognome, TxtNome, TxtNatoAnno,
'TxtNatoMese, TxtNatoGiorno, TxtSesso.
'TxtSesso deve essere uguale a "F" oppure ad "M"
Dim Temp As String
Dim Vocali As String
Dim Consonanti As String
Dim I As Integer
Dim AppoNum As Long
Dim TempNum As Long
Dim TxtCodFis As String
TxtCodFis = ""
'
' RICAVO IL COGNOME (123)
'
Cognome$ = StrConv(Cognome$, vbUpperCase)
Vocali = ""
Consonanti = ""
For I = 1 To Len(Cognome$)
If InStr("AEIOU", Mid(Cognome$, I, 1)) Then
Vocali = Vocali + Mid(Cognome$, I, 1)
ElseIf InStr("BCDFGHJKLMNPQRSTVWXYZ", Mid(Cognome$, I, 1)) Then
Consonanti = Consonanti + Mid(Cognome$, I, 1)
Else
' E' uno spazio, un apostrfo o altro che non va considerato
End If
If Len(Consonanti) = 3 Then Exit For
Next
If Len(Consonanti) < 3 Then Consonanti = Consonanti + Left(Vocali, 3 - Len(Consonanti))
If Len(Consonanti) < 3 Then Consonanti = Consonanti + String(3 - Len(Consonanti), "X")
TxtCodFis = Consonanti
'
' RICAVO IL NOME (456)
'
Nome$ = StrConv(Nome$, vbUpperCase)
Vocali = ""
Consonanti = ""
For I = 1 To Len(Nome$)
If InStr("AEIOU", Mid(Nome$, I, 1)) Then
Vocali = Vocali + Mid(Nome$, I, 1)
ElseIf InStr("BCDFGHJKLMNPQRSTVWXYZ", Mid(Nome$, I, 1)) Then
Consonanti = Consonanti + Mid(Nome$, I, 1)
Else
' E' uno spazio, un apostrfo o altro che non va considerato
End If
Next I
If Len(Consonanti) >= 4 Then
' isolo la prima, terza e quarta consonante
Consonanti = Left$(Consonanti, 1) & Mid$(Consonanti, 3, 2)
ElseIf Len(Consonanti) = 3 Then
' Va bene cosi'
Else
' Aggiungo le vocali
Consonanti = Left$(Consonanti & Vocali, 3)
' se non basta, aggiungo le X
If Len(Consonanti) < 3 Then Consonanti = Left$(Consonanti & "XXX", 3)
End If
TxtCodFis = TxtCodFis & Consonanti
'
'Anno di nascita (78)
'
TxtCodFis = TxtCodFis + Right(Format$(Year(DataNascita), "0000"), 2)
'
'Mese di nascita(9)
'
TxtCodFis = TxtCodFis & Mid$("ABCDEHLMPRST", Month(DataNascita), 1)
'
'Giorno di nascita(0A)
'
If UCase(Sesso$) = "F" Then
TxtCodFis = TxtCodFis & Format$(Day(DataNascita) + 40, "00")
Else
TxtCodFis = TxtCodFis & Format$(Day(DataNascita), "00")
End If
'
'Località di nascita (BCDE)
'
TxtCodFis = TxtCodFis & Provincia$
'
'Ultima lettera (F)
'
'Controllo caratteri pari
TempNum = 0
I = 1
Do
' I DISPARI
AppoNum = InStr("B1A0KKPPLLC2QQD3RRE4VVOOSSF5TTG6UUH7MMI8NNJ9WWZZYYXX", Mid(TxtCodFis, I, 1))
TempNum = TempNum + ((AppoNum - 1) And &H7FFE) / 2
I = I + 1
If I > 15 Then Exit Do
' I PARI
AppoNum = InStr("A0B1C2D3E4F5G6H7I8J9KKLLMMNNOOPPQQRRSSTTUUVVWWXXYYZZ", Mid(TxtCodFis, I, 1))
TempNum = TempNum + ((AppoNum - 1) And &H7FFE) / 2
I = I + 1
Loop
TempNum = TempNum Mod 26
TxtCodFis = TxtCodFis & Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZ", TempNum + 1, 1)
' Ecco qui il codice bello finito
CalcoloCodFis = TxtCodFis
End Function
Private Sub Form_Unload(Cancel As Integer)
'COMUNI.Close
'Set DB = Nothing
'DoCmd.Quit acQuitSaveNone
End Sub
Private Sub txtCognome_KeyPress(KeyAscii As Integer)
Dim strCarattere As String
strCarattere = Chr(KeyAscii)
KeyAscii = Asc(UCase(strCarattere))
End Sub
Private Sub txtComune_Change()
Dim S As String
Dim T As String
Dim Colore As Long
On Error GoTo ErrFas
Colore = 0
T = Trim(Nz(Me.txtComune.Text, ""))
If T = "" Then
Me.txtComune.Tag = T
Exit Sub
End If
If Len(T) = 1 Then S = T
COMUNI.Seek ">=", T
If Not COMUNI.EOF And Not COMUNI.NoMatch Then
If UCase(T) = UCase(Mid(COMUNI!COMU_DESCR, 1, Len(T))) Then
If Len(T) > Len(Me.txtComune.Tag) Then
Me.txtComune = COMUNI!COMU_DESCR
Me.txtComune.SelStart = Len(T)
Me.txtComune.SelLength = Len(Me.txtComune) - (Len(T))
Me.txtProvincia = COMUNI!COMU_PROV
Me.txtCodiceComune = COMUNI!COMU_COD
End If
Else
If Me.txtComune.ForeColor = 0 Then MsgBox "Comune non in elenco"
Colore = &H80&
Me.txtProvincia = ""
Me.txtCodiceComune = ""
Me.txtComune.SetFocus
End If
End If
If Me.txtComune.ForeColor <> Colore Then Me.txtComune.ForeColor = Colore
Me.txtComune.Tag = T
Exit Sub
ErrFas:
MsgBox ("FasMsg: " & Err.Number & " " & Err.Description)
Err.Clear
End Sub
Private Sub txtNome_KeyPress(KeyAscii As Integer)
Dim strCarattere As String
strCarattere = Chr(KeyAscii)
KeyAscii = Asc(UCase(strCarattere))
End Sub
Tratto da demo 6.242 - Codice Fiscale e Anagrafica (negli esempi in area General)
http://web.mclink.it/MC5884
Option Compare Database
Option Explicit
Private zItems As New Collection
'---------------U s o -------------
' dim myCF as new clsCodiceFiscale
' scodfisc = mycf.getCodiceFiscale("cognome,nome,datanascita,sesso,codicecomune")
' boolean = myCF.isValid(codiceFiscale)
' string = myCf.calcolaK(codicefiscale15caratteri)
' string = myCf.getK(codicefiscale15caratteri)
' boolean = myCf.getNameFromCode(anagrafica,codicefiscale)
' sAnagrafica= mycf.Anagrafica
' ----------------------------------by Alessandro Cara--
Private Sub Class_Initialize()
zItems.Add "", "CF"
zItems.Add "", "Cognome"
zItems.Add "", "Nome"
zItems.Add "", "DataNascita"
zItems.Add "", "Sesso"
zItems.Add "", "Comune"
zItems.Add "", "K"
zItems.Add "", "Anagrafica"
zItems.Add "Comuni", "Tabella"
zItems.Add "Sigla", "AttrProvincia"
zItems.Add "DescComune", "AttrComune"
zItems.Add "CodiceCom", "AttrComuneCode"
zItems.Add "0-", "ErrorCode"
End Sub
Property Get CF() As String
CF = zItems("CF")
End Property
Property Let CF(pValue As String)
zItems.Remove "CF"
zItems.Add pValue, "CF"
End Property
Property Get Cognome() As String
Cognome = UCase(Replace(zItems("Cognome"), " ", ""))
End Property
Property Let Cognome(pValue As String)
zItems.Remove "Cognome"
zItems.Add pValue, "Cognome"
End Property
Property Get Nome() As String
Nome = UCase(Replace(zItems("Nome"), " ", ""))
End Property
Property Let Nome(pValue As String)
zItems.Remove "Nome"
zItems.Add pValue, "Nome"
End Property
Property Get Anagrafica() As String
Anagrafica = zItems("Anagrafica")
End Property
Property Let Anagrafica(pValue As String)
zItems.Remove "Anagrafica"
zItems.Add pValue, "Anagrafica"
End Property
Property Get DataNascita() As String
DataNascita = Replace(zItems("DataNascita"), "/", "")
End Property
Property Let DataNascita(pValue As String)
zItems.Remove "DataNascita"
zItems.Add pValue, "DataNascita"
End Property
Property Get Anno() As String
Anno = Right(Replace(zItems("DataNascita"), "/", ""), 2)
End Property
Property Get Mese() As String
Dim nMese As Long
nMese = Val(Mid(DataNascita, 3, 2))
Mese = Mid("ABCDEHLMPRST", nMese, 1)
End Property
Property Get Giorno() As String
If Sesso = "M" Then
Giorno = Left(DataNascita, 2)
Else
Giorno = Format(40 + Val(Left(DataNascita, 2)), "00")
End If
End Property
Property Get Sesso() As String
Sesso = UCase(zItems("Sesso"))
End Property
Property Let Sesso(pValue As String)
zItems.Remove "Sesso"
zItems.Add pValue, "Sesso"
End Property
Property Get Comune() As String
Comune = UCase(zItems("Comune"))
End Property
Property Let Comune(pValue As String)
zItems.Remove "Comune"
zItems.Add pValue, "Comune"
End Property
Property Get K() As String
K = zItems("K")
End Property
Property Let K(pValue As String)
zItems.Remove "K"
zItems.Add pValue, "K"
End Property
Property Get Tabella() As String
Tabella = zItems("Tabella")
End Property
Property Let Tabella(pValue As String)
zItems.Remove "Tabella"
zItems.Add pValue, "Tabella"
End Property
Property Get AttrComune() As String
AttrComune = zItems("AttrComune")
End Property
Property Let AttrComune(pValue As String)
zItems.Remove "AttrComune"
zItems.Add pValue, "AttrComune"
End Property
Property Get AttrProvincia() As String
AttrProvincia = zItems("AttrProvincia")
End Property
Property Let AttrProvincia(pValue As String)
zItems.Remove "AttrProvincia"
zItems.Add pValue, "AttrProvincia"
End Property
Property Get AttrComuneCode() As String
AttrComuneCode = zItems("AttrComuneCode")
End Property
Property Let AttrComuneCode(pValue As String)
zItems.Remove "AttrComuneCode"
zItems.Add pValue, "AttrComuneCode"
End Property
Property Get ErrorCode() As String
ErrorCode = zItems("ErrorCode")
End Property
Private Property Let ErrorCode(pValue As String)
zItems.Remove "ErrorCode"
zItems.Add pValue, "ErrorCode"
End Property
Function getCodiceFiscale(Optional pValue As Variant = "") As String
Dim aDati As Variant, sCodiceFiscale As String, sWh As String
Dim nComune As Long, aComune As Variant
On Error Resume Next
If pValue <> "" Then
aDati = Split(pValue, ",")
End If
If aDati(0) <> "" Then Cognome = Replace(aDati(0), "'", "")
If aDati(1) <> "" Then Nome = Replace(aDati(1), "'", "")
If aDati(2) <> "" Then DataNascita = aDati(2)
If aDati(3) <> "" Then Sesso = aDati(3)
If aDati(4) <> "" Then Comune = aDati(4)
nComune = Val(Mid(Comune, 2))
If nComune = 0 Then
aComune = Split(Comune, ";")
sWh = AttrComune & "='" & Replace(aComune(0), "'", "''") & "'"
If UBound(aComune) > 0 Then
sWh = sWh & " and " & AttrProvincia & "='" & aComune(1) & "'"
End If
Comune = DLookup(AttrComuneCode, Tabella, sWh)
End If
sCodiceFiscale = CalcolaCognome() & CalcolaNome() & CalcolaNascita() & Comune
sCodiceFiscale = sCodiceFiscale & CalcolaK(sCodiceFiscale)
If Len(sCodiceFiscale) < 16 Then sCodiceFiscale = "N.A."
CF = sCodiceFiscale
ErrorCode = Err.Number & "-" & Err.Description
getCodiceFiscale = sCodiceFiscale
End Function
Function formatCodiceFiscale(Optional pValue As Variant = "") As String
formatCodiceFiscale = Format(getCodiceFiscale(pValue), "@@@ @@@ @@@@@ @@@@ @")
End Function
Private Function CalcolaCognome() As String
CalcolaCognome = Left(Strip("Cognome", "AEIOU") & Strip("Cognome", "^AEIOU") & "XXX", 3)
End Function
Private Function CalcolaNome() As String
Dim sReturn As String
sReturn = Strip("Nome", "AEIOU")
If Len(sReturn) > 3 Then sReturn = Left(sReturn, 1) & Mid(sReturn, 3, 1) & Mid(sReturn, 4, 1)
CalcolaNome = Left(sReturn & Strip("Nome", "^AEIOU") & "XXX", 3)
End Function
Private Function Strip(pAttrib, pValue As String) As String
Dim sLocal As String, sType As Boolean
Dim sReturn As String, idx As Long
Dim sAttrib As String
sAttrib = UCase(Replace(zItems(pAttrib), " ", ""))
sLocal = pValue
If Left(pValue, 1) = "^" Then
sType = Not sType
sLocal = Mid(pValue, 2)
End If
For idx = 1 To Len(sAttrib)
If sType Then
If InStr(sLocal, Mid(sAttrib, idx, 1)) <> 0 Then sReturn = sReturn & Mid(sAttrib, idx, 1)
Else
If InStr(sLocal, Mid(sAttrib, idx, 1)) = 0 Then sReturn = sReturn & Mid(sAttrib, idx, 1)
End If
Next
Strip = sReturn
End Function
Private Function CalcolaNascita() As String
CalcolaNascita = Anno & Mese & Giorno
End Function
Private Function CalcolaK(pValue) As String
Dim idx As Long, i As Long, X As Long, Somma As Long, sCF As String
Dim Dispari As Variant
sCF = IIf(Len(pValue) > 15, Left(pValue, 15), pValue)
Dispari = Array(1, 0, 5, 7, 9, 13, 15, 17, 19, 21, 2, 4, 18, 20, 11, 3, 6, 8, 12, 14, 16, 10, 22, 25, 24, 23)
For i = 1 To Len(sCF)
X = Asc(Mid(pValue, i, 1))
idx = IIf(X < 65, X - 48, X - 65)
Somma = Somma + IIf(0 = i Mod 2, idx, Dispari(idx))
Next
K = Chr(Somma Mod 26 + 65)
CalcolaK = K
End Function
Function getNameFromCode(pAnag, pCode) As Boolean
Dim sAnag As String
Dim sCGN As String, sNME As String
Dim iPointer As Long, idx As Long
Dim nCGN As Long, nNME As Long
On Error Resume Next
CF = pCode
sAnag = " " & Replace(pAnag, "'", "")
iPointer = 1
Do Until iPointer = 0
idx = iPointer
iPointer = InStr(idx, sAnag, " ")
If iPointer <> 0 Then
Cognome = Mid(sAnag, iPointer + 1)
sCGN = CalcolaCognome()
If sCGN = Left(pCode, 3) Then
nCGN = iPointer + 1
Exit Do
Else
Cognome = Left(sAnag, iPointer)
sCGN = CalcolaCognome()
If sCGN = Left(pCode, 3) Then
nCGN = 2
Exit Do
Else
iPointer = iPointer + 1
End If
End If
End If
Loop
iPointer = 1
Do Until iPointer = 0
idx = iPointer
iPointer = InStr(idx, sAnag, " ")
If iPointer <> 0 Then
Nome = Mid(sAnag, iPointer + 1)
sNME = CalcolaNome()
If sNME = Mid(pCode, 4, 3) Then
nNME = iPointer + 1
Exit Do
Else
Nome = Left(sAnag, iPointer)
sNME = CalcolaNome()
If sNME = Mid(pCode, 4, 3) Then
nNME = 2
Exit Do
Else
iPointer = iPointer + 1
End If
End If
End If
Loop
If nCGN = 0 Or nNME = 0 Then
Anagrafica = "N.A."
ElseIf nCGN = nNME Then
Anagrafica = pAnag & "/"
ElseIf nNME > nCGN Then
Anagrafica = Mid(sAnag, nCGN, nNME - nCGN - 1) & "/" & Mid(sAnag, nNME)
getNameFromCode = True
Else
Anagrafica = Mid(sAnag, nCGN) & "/" & Mid(sAnag, nNME, nCGN - nNME)
getNameFromCode = True
End If
ErrorCode = Err.Number & "-" & Err.Description
End Function
Function isValid(pValue) As String
CalcolaK = Left(pValue, 15)
isValid = IIf(CF = pValue, True, False)
End Function
Function getK(pValue) As String
getK = CalcolaK(pValue)
End Function