Un regalino per tutti…
Function Codicefiscale(nome as string, cognome as string, data as string, sesso as string, comune as String) As String
Dim inome as string
dim icognome as string
dim icomune as string
dim controllo as string
dim temp As String
inome = ""
icognome = ""
icomune = ""
controllo = ""
temp = ""
Dim letteracod As String
'prendi le iniziali del nome
' ccc As int32 = 1
dim lungnome as integer
For lungnome = 1 To Len(nome)
temp = lowercase(Mid(nome, lungnome, 1))
Select Case temp
Case "b"
inome = inome + temp
Case "c"
inome = inome + temp
Case "d"
inome = inome + temp
Case "f"
inome = inome + temp
Case "g"
inome = inome + temp
Case "h"
inome = inome + temp
Case "j"
inome = inome + temp
Case "k"
inome = inome + temp
Case "l"
inome = inome + temp
Case "m"
inome = inome + temp
Case "n"
inome = inome + temp
Case "p"
inome = inome + temp
Case "q"
inome = inome + temp
Case "r"
inome = inome + temp
Case "s"
inome = inome + temp
Case "t"
inome = inome + temp
Case "v"
inome = inome + temp
Case "w"
inome = inome + temp
Case "x"
inome = inome + temp
Case "y"
inome = inome + temp
Case "z"
inome = inome + temp
End Select
Next
If Len(inome) >= 4 Then
temp = lowercase(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 lungnome = 1 To Len(nome)
letteracod = Mid(nome, lungnome, 1)
Select Case letteracod
Case "a"
inome = inome + "a"
Case "e"
inome = inome + "e"
Case "i"
inome = inome + "i"
Case "o"
inome = inome + "o"
Case "u"
inome = inome + "u"
End Select
Next
If Len(inome) > 3 Then
inome = Mid(inome, 1, 3)
ElseIf Len(inome) < 3 Then
For lungnome = Len(inome) To 3
inome = inome + "x"
Next
End If
End If
'prendi lettere del cognome
For lungnome = 1 To Len(cognome)
temp = lowercase(Mid(cognome, lungnome, 1))
Select Case temp
Case "b"
icognome = icognome + temp
Case "c"
icognome = icognome + temp
Case "d"
icognome = icognome + temp
Case "f"
icognome = icognome + temp
Case "g"
icognome = icognome + temp
Case "h"
icognome = icognome + temp
Case "j"
icognome = icognome + temp
Case "k"
icognome = icognome + temp
Case "l"
icognome = icognome + temp
Case "m"
icognome = icognome + temp
Case "n"
icognome = icognome + temp
Case "p"
icognome = icognome + temp
Case "q"
icognome = icognome + temp
Case "r"
icognome = icognome + temp
Case "s"
icognome = icognome + temp
Case "t"
icognome = icognome + temp
Case "v"
icognome = icognome + temp
Case "w"
icognome = icognome + temp
Case "x"
icognome = icognome + temp
Case "y"
icognome = icognome + temp
Case ("z")
icognome = 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 lungnome = 1 To Len(cognome)
letteracod = Mid(cognome, lungnome, 1)
Select Case letteracod
Case "a"
icognome = icognome + "a"
Case "e"
icognome = icognome + "e"
Case "i"
icognome = icognome + "i"
Case "o"
icognome = icognome + "o"
Case "u"
icognome = icognome + "u"
End Select
Next
If Len(icognome) > 3 Then
icognome = Mid(icognome, 1, 3)
ElseIf Len(icognome) < 3 Then
For lungnome = Len(icognome) To 3
icognome = icognome + "x"
Next
End If
End If
'calola le cifre della data
Dim idata, gg, mm, aa As String
' temp = data
' Dim tempn As string
dim detta() as string
detta() = split(data,"/")
gg = detta(0)
mm = detta(1)
aa = right(detta(2),2)
'gg = left(data,2)
'mm = mid(data,
'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
' MsgBox("TEMP" + temp)
Select Case mm
Case "01"
idata = idata + "a"
Case "02"
idata = idata +"b"
Case "03"
idata = idata +"c"
Case "04"
idata = idata +"d"
Case "05"
idata = idata +"e"
Case "06"
idata = idata +"h"
Case "07"
idata = idata +"l"
Case "08"
idata = idata +"m"
Case "09"
idata = idata +"p"
Case "10"
idata = idata +"r"
Case "11"
idata = idata +"s"
Case "12"
idata = idata +"t"
End Select
If sesso = "M" Then
idata = idata + gg
ElseIf sesso = "F" Then
idata = idata + str(val(gg) + 40)
End If
'codice parziale per calcolare ultima cifra
Dim parz As String
parz = lowercase(icognome + inome + idata + comune)
'trova il carattere di verificca
Dim d, p As String
Dim vdis, vpar As integer
For lungnome = 1 To 15 Step 2
d = Mid(parz, lungnome, 1)
Select Case d
Case "0"
vdis = vdis + 1
Case "1"
vdis = vdis + 0
Case "2"
vdis = vdis + 5
Case "3"
vdis = vdis + 7
Case "4"
vdis = vdis + 9
Case "5"
vdis = vdis + 13
Case "6"
vdis = vdis + 15
Case "7"
vdis = vdis +17
Case "8"
vdis = vdis + 19
Case "9"
vdis = vdis + 21
Case "a"
vdis = vdis + 1
Case "b"
vdis = vdis + 0
Case "c"
vdis = vdis + 5
Case "d"
vdis = vdis + 7
Case "e"
vdis = vdis + 9
Case "f"
vdis = vdis + 13
Case "g"
vdis = vdis + 15
Case "h"
vdis = vdis + 17
Case "i"
vdis = vdis + 19
Case "j"
vdis = vdis + 21
Case "k"
vdis = vdis + 2
Case "l"
vdis = vdis + 4
Case "m"
vdis = vdis + 18
Case "n"
vdis = vdis + 20
Case "o"
vdis = vdis + 11
Case "p"
vdis = vdis + 3
Case "q"
vdis = vdis + 6
Case "r"
vdis = vdis + 8
Case "s"
vdis = vdis + 12
Case "t"
vdis = vdis + 14
Case "u"
vdis = vdis + 16
Case "v"
vdis = vdis + 10
Case "w"
vdis = vdis + 22
Case "x"
vdis = vdis + 25
Case "y"
vdis = vdis + 24
Case "z"
vdis = vdis + 23
End Select
Next
For lungnome = 2 To 14 Step 2
p = Mid(parz, lungnome, 1)
Select Case p
Case "0"
vpar = vpar + 0
Case "1"
vpar = vpar + 1
Case "2"
vpar = vpar + 2
Case "3"
vpar = vpar + 3
Case "4"
vpar = vpar + 4
Case "5"
vpar = vpar + 5
Case "6"
vpar = vpar + 6
Case "7"
vpar = vpar + 7
Case "8"
vpar = vpar + 8
Case "9"
vpar = vpar + 9
Case "a"
vpar = vpar + 0
Case "b"
vpar = vpar + 1
Case "c"
vpar = vpar + 2
Case "d"
vpar = vpar + 3
Case "e"
vpar = vpar + 4
Case "f"
vpar = vpar + 5
Case "g"
vpar = vpar + 6
Case "h"
vpar = vpar + 7
Case "i"
vpar = vpar + 8
Case "j"
vpar = vpar + 9
Case "k"
vpar = vpar + 10
Case "l"
vpar = vpar + 11
Case "m"
vpar = vpar + 12
Case "n"
vpar = vpar + 13
Case "o"
vpar = vpar + 14
Case "p"
vpar = vpar + 15
Case "q"
vpar = vpar + 16
Case "r"
vpar = vpar + 17
Case "s"
vpar = vpar + 18
Case "t"
vpar = vpar + 19
Case "u"
vpar = vpar + 20
Case "v"
vpar = vpar + 21
Case "w"
vpar = vpar +22
Case "x"
vpar = vpar + 23
Case "y"
vpar = vpar + 24
Case "z"
vpar = vpar + 25
End Select
Next
Dim vdisparsomma As double
'somma dei valori ottenuti dal dispari e dal pari
vdisparsomma = vdis + vpar
'---------------------
' vdisparsomma = 148
'---------------------
'diviso 26, troviamo il resto
Dim restov As integer
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
dim Codicefiscale as String
codicefiscale = uppercase(parz + controllo)
return Codicefiscale
End Function
Attenzione il campo ‘comune’ il codice istat !