# codice fiscale

Jun 9th, 2018
1,363
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
1. Public Function CalcolaCodiceFiscale(nome As String, cognome As String, data As Date, Codice_Comune As String, Sesso As String) As String
2.   Dim letterecognome, letterenome As String
3.   Dim i, c As Integer
4.   Dim basta As Boolean
5.   Dim nc, nv As Integer
6.   Dim result As String
7.   Dim anno, mese, giorno As Integer
8.   Dim stanno, stmese, stgiorno As String
9.   Dim sommapari, sommadispari As Integer
10.   Dim sommatotale As Integer
11.   Dim resto As Integer
12.   Dim sttemp As String
13.   Dim ValoriPari As Integer[]
14.   Dim ValoriDispari As Integer[]
15.   Dim intero, IntCodice As Integer
16.   Dim ln As Integer
17.
18.   If Sesso Not Like "[MF]" Then
19.     Return Null
20.   End If
21.
22.   '[0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]
23.   ValoriPari = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]
24.   '[1, 0, 5, 7, 9, 13, 15, 17, 19, 21, 0, 0, 0, 0, 0, 0, 0, 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]
25.   ValoriDispari = [1, 0, 5, 7, 9, 13, 15, 17, 19, 21, 0, 0, 0, 0, 0, 0, 0, 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]
26.
27.
28.
29.   basta = False
30.   nc = 0
31.   nv = 0
32.   nome = Replace(nome, "'", "")
33.   nome = Replace(nome, " ", "")
34.   nome = Trim(nome)
35.   cognome = Trim(cognome)
36.   cognome = Replace(cognome, "'", "")
37.   cognome = Replace(cognome, " ", "")
38.   nome = UCase(nome)
39.   cognome = UCase(cognome)
40.
41.   nome = AggiustaNomeCognome(nome)
42.   cognome = AggiustaNomeCognome(cognome)
43.
44.
45.
46.   letterecognome = GetCarCognome(cognome)
47.   letterenome = GetCarNome(nome)
48.
49.   result = letterecognome & letterenome
50.
51.   anno = Year(data)
52.   stanno = NumeroToStringa(anno)
53.   stanno = Right(stanno, 2)
54.   mese = Month(data)
55.   Select Case mese
56.     Case 1
57.       stmese = "A"
58.     Case 2
59.       stmese = "B"
60.     Case 3
61.       stmese = "C"
62.     Case 4
63.       stmese = "D"
64.     Case 5
65.       stmese = "E"
66.     Case 6
67.       stmese = "H"
68.     Case 7
69.       stmese = "L"
70.     Case 8
71.       stmese = "M"
72. 'PRST
73.     Case 9
74.       stmese = "P"
75.     Case 10
76.       stmese = "R"
77.     Case 11
78.       stmese = "S"
79.     Case 12
80.       stmese = "T"
81.   End Select
82.
83.
84.   giorno = Day(data)
85.
86.   If sesso = "F" Then giorno = giorno + 40
87.
88.   If giorno < 10 Then
89.     stgiorno = "0" & CStr(giorno)
90.
91.   Else
92.     stgiorno = CStr(giorno)
93.   End If
94.
95.   result = result & stanno & stmese & stgiorno & Codice_Comune
96.
97.   sommapari = 0
99.
100.
101.   sommatotale = 0
102.   For i = 1 To 15
103.     intero = Asc(UCase(Mid(result, i, 1))) - Asc("0")
104.     If (i Mod 2) = 0 Then ' I Ã¨ pari
105.       sommatotale = sommatotale + ValoriPari[intero]
106.     Else ' I Ã¨ dispari
107.     sommatotale = sommatotale + ValoriDispari[intero]
108.     End If
109.   Next
110.
111.
112.   IntCodice = (sommatotale Mod 26) + Asc("A")
113.
114.
115.   result = result & Chr(IntCodice)
116.
117.   Return result
118.
119.
120. End
121.
122. Public Function NumeroToStringa(numero As Integer) As String
123.
124.   Dim result As String
125.   Dim i As Integer
126.   Dim stnumero As String
127.   stnumero = CStr(numero)
128.   result = ""
129.   For i = 1 To Len(stnumero)
130.     result = result & Mid(stnumero, i, 1)
131.
132.   Next
133.
134.
135.   Return result
136. End
137.
138.
139. Public Function AggiustaNomeCognome(stringa As String) As String
140. Dim ln As Integer
141. Dim i As Integer
142.     ln = Len(stringa)
143.   For i = 1 To ln
144.     If Mid(stringa, i, 1) Not Like "[ABCDEFGHILMNOPQRSTUVZWXYKJ]" Then
145.       Mid(stringa, i, 1) = ""
146.       ln = Len(stringa)
147.     End If
148.   Next
149.
150.   Return stringa
151. End
152.
153.
154. Public Function GetConsonanti(stringa As String) As String
155.   Dim i As Integer
156.   Dim result As String
157.   For i = 1 To Len(stringa)
158.     If Mid(stringa, i, 1) Not Like "[AEIOU]" Then
159.       result &= Mid(stringa, i, 1)
160.     End If
161.   Next
162.   Return result
163.
164. End
165.
166.
167. Public Function GetVocali(stringa As String) As String
168.   Dim i As Integer
169.   Dim result As String
170.   For i = 1 To Len(stringa)
171.     If Mid(stringa, i, 1) Like "[AEIOU]" Then
172.       result &= Mid(stringa, i, 1)
173.     End If
174.   Next
175.   Return result
176.
177. End
178.
179.
180. Public Function GetCarCognome(cognome As String) As String
181.   Dim stcons, stvoc As String
182.   Dim result As String
183.   stcons = GetConsonanti(cognome)
184.   stvoc = GetVocali(cognome)
185.
186.   If Len(stcons) >= 3 Then Return Left(stcons, 3)
187.   If Len(stcons) = 2 Then
188.     If Len(stvoc) = 0 Then
189.       result = stcons & "X"
190.       Return result
191.     End If
192.     If Len(stvoc) > 0 Then
193.       result = stcons & Mid(stvoc, 1, 1)
194.       Return result
195.     Endif
196.   Else If Len(stcons) = 1 Then
197.     If Len(stvoc) = 0 Then
198.       Return Null
199.     Else If Len(stvoc) = 1 Then
200.       result = stcons & stvoc & "X"
201.       Return Result
202.     Else If Len(stvoc) > 1 Then
203.       result = stcons & Mid(stvoc, 1, 2)
204.       Return result
205.     End If
206.
207.   End If
208. End
209.
210. Public Function GetCarNome(nome As String) As String
211.   Dim stcons, stvoc As String
212.   Dim result As String
213.
214.   stcons = GetConsonanti(nome)
215.   stvoc = GetVocali(nome)
216.
217.   If Len(stcons) >= 4 Then
218.     result = Mid(stcons, 1, 1) & Mid(stcons, 3, 1) & Mid(stcons, 4, 1)
219.     Return result
220.   Else If Len(stcons) = 3 Then
221.     result = stcons
222.     Return result
223.   Else If Len(stcons) = 2 Then
224.     If Len(stvoc) = 0 Then
225.      result = stcons & "X"
226.      Return result
227.     Else If Len(stvoc) >= 1
228.       result = stcons & Mid(stvoc, 1, 1)
229.       Return Result
230.     End If
231.   Else If Len(stcons) = 1 Then
232.     If Len(stvoc) = 0 Then
233.       Return Null
234.     Else If Len(stvoc) = 1 Then
235.       result = stcons & stvoc & "X"
236.       Return Result
237.     Else If Len(stvoc) > 1 Then
238.       result = stcons & Mid(stvoc, 1, 2)
239.       Return result
240.     End If
241.   End If
242.
243.
244.
245. End