• D
    User Attivo •

    Piccola funziona per il calcolo del codice fiscale

    Ragazzi non è granche che come funzione ma io la pubblico lo stesso potrebbe tornare utile a chiunque...

    Function codicefiscale(ByVal nome As String, ByVal cognome As String, ByVal data As String, ByVal sesso As String, ByVal comune As String) As String
    Dim inome, icognome, icomune, controllo, temp As String
    Dim letteracod As String
    'prendi le iniziali del nome
    Dim ccc As Long = 1
    For i = 1 To Len(nome)
    temp = LCase(Mid(nome, i, 1))
    Select Case temp
    Case "b"
    inome += temp
    Case "c"
    inome += temp
    Case "d"
    inome += temp
    Case "f"
    inome += temp
    Case "g"
    inome += temp
    Case "h"
    inome += temp
    Case "j"
    inome += temp
    Case "k"
    inome += temp
    Case "l"
    inome += temp
    Case "m"
    inome += temp
    Case "n"
    inome += temp
    Case "p"
    inome += temp
    Case "q"
    inome += temp
    Case "r"
    inome += temp
    Case "s"
    inome += temp
    Case "t"
    inome += temp
    Case "v"
    inome += temp
    Case "w"
    inome += temp
    Case "x"
    inome += temp
    Case "y"
    inome += temp
    Case "z"
    inome += temp
    End Select
    Next
    If Len(inome) >= 4 Then
    temp = LCase(inome)
    inome = Mid(temp, 1, 1) & Mid(temp, 3, 1) & Mid(temp, 4, 1)
    End If
    'controlla la lunghezza delle iniziali
    If Len(inome) > 3 Then
    inome = Mid(inome, 1, 3)
    ElseIf Len(inome) < 3 Then
    For i = 1 To Len(nome)
    letteracod = Mid(nome, i, 1)
    Select Case letteracod
    Case "a"
    inome += "a"
    Case "e"
    inome += "e"
    Case "i"
    inome += "i"
    Case "o"
    inome += "o"
    Case "u"
    inome += "u"
    End Select
    Next
    If Len(inome) > 3 Then
    inome = Mid(inome, 1, 3)
    ElseIf Len(inome) < 3 Then
    For i = Len(inome) To 3
    inome += "x"
    Next
    End If
    End If
    'prendi lettere del cognome
    For i = 1 To Len(cognome)
    temp = LCase(Mid(cognome, i, 1))
    Select Case temp
    Case "b"
    icognome += temp
    Case "c"
    icognome += temp
    Case "d"
    icognome += temp
    Case "f"
    icognome += temp
    Case "g"
    icognome += temp
    Case "h"
    icognome += temp
    Case "j"
    icognome += temp
    Case "k"
    icognome += temp
    Case "l"
    icognome += temp
    Case "m"
    icognome += temp
    Case "n"
    icognome += temp
    Case "p"
    icognome += temp
    Case "q"
    icognome += temp
    Case "r"
    icognome += temp
    Case "s"
    icognome += temp
    Case "t"
    icognome += temp
    Case "v"
    icognome += temp
    Case "w"
    icognome += temp
    Case "x"
    icognome += temp
    Case "y"
    icognome += temp
    Case ("z")
    icognome += temp
    End Select
    Next
    'controlla la lunghezza delle iniziali
    If Len(icognome) > 3 Then
    icognome = Mid(icognome, 1, 3)
    ElseIf Len(icognome) < 3 Then
    'minore di tre cifre prendi anche le vocali
    For i = 1 To Len(cognome)
    letteracod = Mid(cognome, i, 1)
    Select Case letteracod
    Case "a"
    icognome += "a"
    Case "e"
    icognome += "e"
    Case "i"
    icognome += "i"
    Case "o"
    icognome += "o"
    Case "u"
    icognome += "u"
    End Select
    Next
    If Len(icognome) > 3 Then
    icognome = Mid(icognome, 1, 3)
    ElseIf Len(icognome) < 3 Then
    For i = Len(icognome) To 3
    icognome += "x"
    Next
    End If
    End If
    'calola le cifre della data
    Dim idata, gg, mm, aa As String
    temp = data
    Dim tempn As Short
    tempn = InStr(temp, "/")
    gg = Mid(data, 1, tempn - 1)
    temp = Mid(data, 4)
    tempn = InStr(temp, "/")
    mm = Mid(temp, 1, tempn - 1)
    temp = Mid(temp, 4)
    aa = Mid(temp, 3)
    idata = aa
    Select Case mm
    Case "01"
    idata += "a"
    Case "02"
    idata += "b"
    Case "03"
    idata += "c"
    Case "04"
    idata += "d"
    Case "05"
    idata += "e"
    Case "06"
    idata += "h"
    Case "07"
    idata += "l"
    Case "08"
    idata += "m"
    Case "09"
    idata += "p"
    Case "10"
    idata += "r"
    Case "11"
    idata += "s"
    Case "12"
    idata += "t"
    End Select
    If sesso = "Maschio" Then
    idata += gg
    ElseIf sesso = "Femmina" Then
    idata += gg + 40
    End If
    'codice parziale per calcolare ultima cifra
    Dim parz As String
    parz = LCase(icognome & inome & idata & comune)
    'trova il carattere di verificca
    Dim d, p As String
    Dim vdis, vpar As Long
    For i = 1 To 15 Step 2
    d = Mid(parz, i, 1)
    Select Case d
    Case "0"
    vdis += 1
    Case "1"
    vdis += 0
    Case "2"
    vdis += 5
    Case "3"
    vdis += 7
    Case "4"
    vdis += 9
    Case "5"
    vdis += 13
    Case "6"
    vdis += 15
    Case "7"
    vdis += 17
    Case "8"
    vdis += 19
    Case "9"
    vdis += 21
    Case "a"
    vdis += 1
    Case "b"
    vdis += 0
    Case "c"
    vdis += 5
    Case "d"
    vdis += 7
    Case "e"
    vdis += 9
    Case "f"
    vdis += 13
    Case "g"
    vdis += 15
    Case "h"
    vdis += 17
    Case "i"
    vdis += 19
    Case "j"
    vdis += 21
    Case "k"
    vdis += 2
    Case "l"
    vdis += 4
    Case "m"
    vdis += 18
    Case "n"
    vdis += 20
    Case "o"
    vdis += 11
    Case "p"
    vdis += 3
    Case "q"
    vdis += 6
    Case "r"
    vdis += 8
    Case "s"
    vdis += 12
    Case "t"
    vdis += 14
    Case "u"
    vdis += 16
    Case "v"
    vdis += 10
    Case "w"
    vdis += 22
    Case "x"
    vdis += 25
    Case "y"
    vdis += 24
    Case "z"
    vdis += 23
    End Select
    Next
    For i = 2 To 14 Step 2
    p = Mid(parz, i, 1)
    Select Case p
    Case "0"
    vpar += 0
    Case "1"
    vpar += 1
    Case "2"
    vpar += 2
    Case "3"
    vpar += 3
    Case "4"
    vpar += 4
    Case "5"
    vpar += 5
    Case "6"
    vpar += 6
    Case "7"
    vpar += 7
    Case "8"
    vpar += 8
    Case "9"
    vpar += 9
    Case "a"
    vpar += 0
    Case "b"
    vpar += 1
    Case "c"
    vpar += 2
    Case "d"
    vpar += 3
    Case "e"
    vpar += 4
    Case "f"
    vpar += 5
    Case "g"
    vpar += 6
    Case "h"
    vpar += 7
    Case "i"
    vpar += 8
    Case "j"
    vpar += 9
    Case "k"
    vpar += 10
    Case "l"
    vpar += 11
    Case "m"
    vpar += 12
    Case "n"
    vpar += 13
    Case "o"
    vpar += 14
    Case "p"
    vpar += 15
    Case "q"
    vpar += 16
    Case "r"
    vpar += 17
    Case "s"
    vpar += 18
    Case "t"
    vpar += 19
    Case "u"
    vpar += 20
    Case "v"
    vpar += 21
    Case "w"
    vpar += 22
    Case "x"
    vpar += 23
    Case "y"
    vpar += 24
    Case "z"
    vpar += 25
    End Select
    Next
    Dim vdisparsomma As Long
    'somma dei valori ottenuti dal dispari e dal pari
    vdisparsomma = vdis + vpar
    '---------------------
    ' vdisparsomma = 148
    '---------------------
    'diviso 26, troviamo il resto
    Dim restov As Decimal
    restov = vdisparsomma Mod 26
    Select Case restov
    Case 0
    controllo = "a"
    Case 1
    controllo = "b"
    Case 2
    controllo = "c"
    Case 3
    controllo = "d"
    Case 4
    controllo = "e"
    Case 5
    controllo = "f"
    Case 6
    controllo = "g"
    Case 7
    controllo = "h"
    Case 8
    controllo = "i"
    Case 9
    controllo = "j"
    Case 10
    controllo = "k"
    Case 11
    controllo = "l"
    Case 12
    controllo = "m"
    Case 13
    controllo = "n"
    Case 14
    controllo = "o"
    Case 15
    controllo = "p"
    Case 16
    controllo = "q"
    Case 17
    controllo = "r"
    Case 18
    controllo = "s"
    Case 19
    controllo = "t"
    Case 20
    controllo = "u"
    Case 21
    controllo = "v"
    Case 22
    controllo = "w"
    Case 23
    controllo = "x"
    Case 24
    controllo = "y"
    Case 25
    controllo = "z"
    End Select
    'fai il codice fiscale
    codicefiscale = UCase(parz & controllo)
    End Function
    'fine
    'il calcolo del codice fiscale funziona correttamente

    la funziona fa parte di un programma che sto terminando per la gestione della vendita di olive da mensa... 🙂
    Essa serve per calcolare il codice fiscale di qualsiasi persone conoscendo il nome,cognome,data di nascita, luogo di nascita e sesso... 🙂

    0
  • D
    User Attivo •

    PS. La funziona è scritta in vb ma puo essere adattata per qualsiasi linguaggio

    0
Effettua l'accesso per rispondere