SHARE
TWEET

codice fiscale

metallaro1980 Jun 9th, 2018 (edited) 137 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
  98.   sommadispari = 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
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!
 
Top