Calcolo codice fiscale in una query?

di il
20 risposte

20 Risposte - Pagina 2

  • Re: Calcolo codice fiscale in una query?

    willy55 ha scritto:


    L'algoritmo da te impiegato ha dei buchi che possono inficiarne la validità.
    Non gestisci i Comuni che hanno una denominazione che li identifica univocamente.
    Guarda ad esempio "CALLIANO" che possiamo trovare in Provincia di Trento (TN) con CodComune="B419" oppure nella Provincia di Asti (AT) CodComune="B418".
    Altro esempio "PEGLIO" che possiamo trovare in Provincia di Como (CO) CodComune="G415" ed in Provincia di Pesaro ed Urbino (PU) CodComune="G416" ma che tu hai codificato con la vecchia definizione per Pesaro (PS).
    Evidenzio che nel calcolo del codice fiscale, viene preso sempre il primo elemento della coppia (in base all'ordine in tabella).
    La tua tabella dei Comuni non è aggiornata con le variazioni apportate nel tempo, come nuove Provincie o Comuni sottoposti a fusioni o soppressi (esistenti nel passato in riferimento alla nascita).

    https://www.istat.it/it/archivio/6789#Elencodeicomunisoppressi-1

    Ho dato una occhiata al codice VBA da te allegato ma non lo hai adattato (come ti avevo suggerito, nella funzione DLookUp) e visto l'inconveniente (della mancata identificazione nei casi multipli della denominazione del Comune) consiglio, almeno, di adattarlo applicando nel criterio di ricerca entrambi gli elementi (Comune e Provincia); giusto per fornire un suggerimento pratico, qualcosa del genere:
    
    ' 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))
    
    GRAZIEEEEE TANTE. Ho scaricato la tavella comuni che mi hai linkato e ho aggiornato la mia, e ho adattato il codice VBA che mia hai postato. Funziona benissimo....
  • Re: Calcolo codice fiscale in una query?

    Scusate ma ho inviato erroneamente 2 volte
  • Re: Calcolo codice fiscale in una query?

    willy55 ha scritto:


    L'algoritmo da te impiegato ha dei buchi che possono inficiarne la validità.
    Non gestisci i Comuni che hanno una denominazione che li identifica univocamente.
    Guarda ad esempio "CALLIANO" che possiamo trovare in Provincia di Trento (TN) con CodComune="B419" oppure nella Provincia di Asti (AT) CodComune="B418".
    Altro esempio "PEGLIO" che possiamo trovare in Provincia di Como (CO) CodComune="G415" ed in Provincia di Pesaro ed Urbino (PU) CodComune="G416" ma che tu hai codificato con la vecchia definizione per Pesaro (PS).
    Evidenzio che nel calcolo del codice fiscale, viene preso sempre il primo elemento della coppia (in base all'ordine in tabella).
    La tua tabella dei Comuni non è aggiornata con le variazioni apportate nel tempo, come nuove Provincie o Comuni sottoposti a fusioni o soppressi (esistenti nel passato in riferimento alla nascita).

    https://www.istat.it/it/archivio/6789#Elencodeicomunisoppressi-1

    Ho dato una occhiata al codice VBA da te allegato ma non lo hai adattato (come ti avevo suggerito, nella funzione DLookUp) e visto l'inconveniente (della mancata identificazione nei casi multipli della denominazione del Comune) consiglio, almeno, di adattarlo applicando nel criterio di ricerca entrambi gli elementi (Comune e Provincia); giusto per fornire un suggerimento pratico, qualcosa del genere:
    
    ' 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))
    
    GRAZIE TANTISSIMO...ho scaricato la tabella comuni aggiornata che mi hai linkato, e ho sostituito in Dlookup il code VBA con il tuo suggerimento. Funziona benissimo
  • Re: Calcolo codice fiscale in una query?

    1
  • Re: Calcolo codice fiscale in una query?

    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
    
  • Re: Calcolo codice fiscale in una query?

    Ora mi metto, e li confronto e cerco di modificare il mio.. Grazie.
Devi accedere o registrarti per scrivere nel forum
20 risposte