codice fiscale

Public Function CalcolaCodiceFiscale(nome As String, cognome As String, data As Date, Codice_Comune As String, Sesso As String) As String
  Dim letterecognome, letterenome As String
  Dim i, c As Integer
  Dim basta As Boolean
  Dim nc, nv As Integer
  Dim result As String
  Dim anno, mese, giorno As Integer
  Dim stanno, stmese, stgiorno As String
  Dim sommapari, sommadispari As Integer
  Dim sommatotale As Integer
  Dim resto As Integer
  Dim sttemp As String
  Dim ValoriPari As Integer[]
  Dim ValoriDispari As Integer[]
  Dim intero, IntCodice As Integer
  Dim ln As Integer

  If Sesso Not Like "[MF]" Then
    Return Null
  End If

  '[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]
  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]
  '[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]
  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]



  basta = False
  nc = 0
  nv = 0
  nome = Replace(nome, "'", "")
  nome = Replace(nome, " ", "")
  nome = Trim(nome)
  cognome = Trim(cognome)
  cognome = Replace(cognome, "'", "")
  cognome = Replace(cognome, " ", "")
  nome = UCase(nome)
  cognome = UCase(cognome)

  nome = AggiustaNomeCognome(nome)
  cognome = AggiustaNomeCognome(cognome)



  letterecognome = GetCarCognome(cognome)
  letterenome = GetCarNome(nome)

  result = letterecognome & letterenome

  anno = Year(data)
  stanno = NumeroToStringa(anno)
  stanno = Right(stanno, 2)
  mese = Month(data)
  Select Case mese
    Case 1
      stmese = "A"
    Case 2
      stmese = "B"
    Case 3
      stmese = "C"
    Case 4
      stmese = "D"
    Case 5
      stmese = "E"
    Case 6
      stmese = "H"
    Case 7
      stmese = "L"
    Case 8
      stmese = "M"
'PRST
    Case 9
      stmese = "P"
    Case 10
      stmese = "R"
    Case 11
      stmese = "S"
    Case 12
      stmese = "T"
  End Select


  giorno = Day(data)

  If sesso = "F" Then giorno = giorno + 40

  If giorno < 10 Then
    stgiorno = "0" & CStr(giorno)

  Else
    stgiorno = CStr(giorno)
  End If

  result = result & stanno & stmese & stgiorno & Codice_Comune

  sommapari = 0
  sommadispari = 0


  sommatotale = 0
  For i = 1 To 15
    intero = Asc(UCase(Mid(result, i, 1))) - Asc("0")
    If (i Mod 2) = 0 Then ' I è pari
      sommatotale = sommatotale + ValoriPari[intero]
    Else ' I è dispari
    sommatotale = sommatotale + ValoriDispari[intero]
    End If
  Next


  IntCodice = (sommatotale Mod 26) + Asc("A")


  result = result & Chr(IntCodice)

  Return result


End

Public Function NumeroToStringa(numero As Integer) As String

  Dim result As String
  Dim i As Integer
  Dim stnumero As String
  stnumero = CStr(numero)
  result = ""
  For i = 1 To Len(stnumero)
    result = result & Mid(stnumero, i, 1)

  Next


  Return result
End


Public Function AggiustaNomeCognome(stringa As String) As String
Dim ln As Integer
Dim i As Integer
    ln = Len(stringa)
  For i = 1 To ln
    If Mid(stringa, i, 1) Not Like "[ABCDEFGHILMNOPQRSTUVZWXYKJ]" Then
      Mid(stringa, i, 1) = ""
      ln = Len(stringa)
    End If
  Next

  Return stringa
End


Public Function GetConsonanti(stringa As String) As String
  Dim i As Integer
  Dim result As String
  For i = 1 To Len(stringa)
    If Mid(stringa, i, 1) Not Like "[AEIOU]" Then
      result &= Mid(stringa, i, 1)
    End If
  Next
  Return result

End


Public Function GetVocali(stringa As String) As String
  Dim i As Integer
  Dim result As String
  For i = 1 To Len(stringa)
    If Mid(stringa, i, 1) Like "[AEIOU]" Then
      result &= Mid(stringa, i, 1)
    End If
  Next
  Return result

End


Public Function GetCarCognome(cognome As String) As String
  Dim stcons, stvoc As String
  Dim result As String
  stcons = GetConsonanti(cognome)
  stvoc = GetVocali(cognome)

  If Len(stcons) >= 3 Then Return Left(stcons, 3)
  If Len(stcons) = 2 Then
    If Len(stvoc) = 0 Then
      result = stcons & "X"
      Return result
    End If
    If Len(stvoc) > 0 Then
      result = stcons & Mid(stvoc, 1, 1)
      Return result
    Endif
  Else If Len(stcons) = 1 Then
    If Len(stvoc) = 0 Then
      Return Null
    Else If Len(stvoc) = 1 Then
      result = stcons & stvoc & "X"
      Return Result
    Else If Len(stvoc) > 1 Then
      result = stcons & Mid(stvoc, 1, 2)
      Return result
    End If

  End If
End

Public Function GetCarNome(nome As String) As String
  Dim stcons, stvoc As String
  Dim result As String

  stcons = GetConsonanti(nome)
  stvoc = GetVocali(nome)

  If Len(stcons) >= 4 Then
    result = Mid(stcons, 1, 1) & Mid(stcons, 3, 1) & Mid(stcons, 4, 1)
    Return result
  Else If Len(stcons) = 3 Then
    result = stcons
    Return result
  Else If Len(stcons) = 2 Then
    If Len(stvoc) = 0 Then
     result = stcons & "X"
     Return result
    Else If Len(stvoc) >= 1
      result = stcons & Mid(stvoc, 1, 1)
      Return Result
    End If
  Else If Len(stcons) = 1 Then
    If Len(stvoc) = 0 Then
      Return Null
    Else If Len(stvoc) = 1 Then
      result = stcons & stvoc & "X"
      Return Result
    Else If Len(stvoc) > 1 Then
      result = stcons & Mid(stvoc, 1, 2)
      Return result
    End If
  End If



End