Newsgroup: it.comp.appl.access
Titolo: conversione calcolo CF 97>2000

lessi su una news del gruppo che qualcuno è riuscito a convertire il codice
del calcolo Codice Fiscale che si trova sul sito comune, da access 97 a
2000, ma non riesco più a trovarlo, mi aiutate a trovarlo o potete postare
il nuovo codice?
grazie

 ha scritto nel messaggio
news:_tZW6.7079$nG2.1...@news1.tin.it...

Non ero io .. comunque a me funziona in access 2000 fatto cosi' .. e sono
partito da quello del sito comune .. in piu' ci ho messo il calcolo alla
rovescia :)
Private Sub cmdElabora_Click()
    Dim ctl As Control
    For Each ctl In Me.Controls
        If ctl.Tag = "x" Then
            If IsNull(ctl) Or ctl = "" Then
                MsgBox "Il campo " & Mid$(
ctl.name
, 4) & " non può essere
vuoto!"
                Exit Sub
            End If
        End If
    Next ctl
    Me.txtCodiceFiscale = CalcoloCodFis(Me.txtCognome, Me.txtNome,
CVDate(Me.txtDataNascita), Me.cboSesso, Trim(Me.txtCodiceComune))
End Sub
Private Function CalcoloCodFis(ByVal Cognome$, ByVal Nome$, DataNascita As
Date, sesso$, Provincia$) As String
    Dim Temp        As String
    Dim Vocali      As String
    Dim Consonanti  As String
    Dim i           As Integer
    Dim AppoNum     As Long
    Dim TempNum     As Long
    Dim TxtCodFis   As String
    TxtCodFis = ""
    ' RICAVO IL COGNOME (123)
    Cognome$ = StrConv(Cognome$, vbUpperCase)
    Vocali = ""
    Consonanti = ""
    For i = 1 To Len(Cognome$)
        If InStr("AEIOU", Mid(Cognome$, i, 1)) Then
            Vocali = Vocali + Mid(Cognome$, i, 1)
        ElseIf InStr("BCDFGHJKLMNPQRSTVWXYZ", Mid(Cognome$, i, 1)) Then
            Consonanti = Consonanti + Mid(Cognome$, i, 1)
        Else
            ' E' uno spazio, un apostrfo o altro che non va considerato
        End If
       If Len(Consonanti) = 3 Then Exit For
    Next
    If Len(Consonanti) < 3 Then Consonanti = Consonanti + Left(Vocali, 3 -
Len(Consonanti))
    If Len(Consonanti) < 3 Then Consonanti = Consonanti + String(3 -
Len(Consonanti), "X")
    TxtCodFis = Consonanti
    ' RICAVO IL NOME (456)
    Nome$ = StrConv(Nome$, vbUpperCase)
    Vocali = ""
    Consonanti = ""
    For i = 1 To Len(Nome$)
        If InStr("AEIOU", Mid(Nome$, i, 1)) Then
            Vocali = Vocali + Mid(Nome$, i, 1)
        ElseIf InStr("BCDFGHJKLMNPQRSTVWXYZ", Mid(Nome$, i, 1)) Then
            Consonanti = Consonanti + Mid(Nome$, i, 1)
        Else
            ' E' uno spazio, un apostrfo o altro che non va considerato
        End If
    Next i
    If Len(Consonanti) >= 4 Then
        ' isolo la prima, terza e quarta consonante
        Consonanti = Left$(Consonanti, 1) & Mid$(Consonanti, 3, 2)
    ElseIf Len(Consonanti) = 3 Then
        ' Va bene cosi'
    Else
        ' Aggiungo le vocali
        Consonanti = Left$(Consonanti & Vocali, 3)
        ' se non basta, aggiungo le X
        If Len(Consonanti) < 3 Then Consonanti = Left$(Consonanti & "XXX",
3)
    End If
    TxtCodFis = TxtCodFis & Consonanti
    'Anno di nascita (78)
    TxtCodFis = TxtCodFis + Right(Format$(Year(DataNascita), "0000"), 2)
    'Mese di nascita(9)
    TxtCodFis = TxtCodFis & Mid$("ABCDEHLMPRST", Month(DataNascita), 1)
    'Giorno di nascita(0A)
    If UCase(sesso$) = "F" Then
        TxtCodFis = TxtCodFis & Format$(Day(DataNascita) + 40, "00")
    Else
        TxtCodFis = TxtCodFis & Format$(Day(DataNascita), "00")
    End If
    'Località di nascita (BCDE)
    TxtCodFis = TxtCodFis & Provincia$
    'Ultima lettera (F)
    'Controllo caratteri pari
    TempNum = 0
    i = 1
    Do
        ' I DISPARI
        AppoNum =
InStr("B1A0KKPPLLC2QQD3RRE4VVOOSSF5TTG6UUH7MMI8NNJ9WWZZYYXX", Mid(TxtCodFis,
i, 1))
        TempNum = TempNum + ((AppoNum - 1) And &H7FFE) / 2
        i = i + 1
        If i > 15 Then Exit Do
        ' I PARI
        AppoNum =
InStr("A0B1C2D3E4F5G6H7I8J9KKLLMMNNOOPPQQRRSSTTUUVVWWXXYYZZ", Mid(TxtCodFis,
i, 1))
        TempNum = TempNum + ((AppoNum - 1) And &H7FFE) / 2
        i = i + 1
    Loop
    TempNum = TempNum Mod 26
    TxtCodFis = TxtCodFis & Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZ", TempNum + 1,
1)
    ' Ecco qui il codice bello finito
    CalcoloCodFis = TxtCodFis
End Function
Private Sub txtCognome_KeyPress(KeyAscii As Integer)
    Dim strCarattere As String
    strCarattere = Chr(KeyAscii)
    KeyAscii = Asc(UCase(strCarattere))
End Sub
Private Sub txtNome_KeyPress(KeyAscii As Integer)
    Dim strCarattere As String
    strCarattere = Chr(KeyAscii)
    KeyAscii = Asc(UCase(strCarattere))
End Sub
Private Sub txtComune_AfterUpdate()
    Dim s, T As String
    Dim Colore As Long
    Dim COMUNI, codcomune, CODPROV As String
    Colore = 0
    On Error GoTo ErrFas
    COMUNI = Me.txtComune
    CODPROV = Me.txtComune.Column(2)
    codcomune = Me.txtComune.Column(1)
    Me.txtProvincia = CODPROV
    Me.txtCodiceComune = codcomune
    Me.txtComune = COMUNI
    T = Trim(Nz(Me.txtComune.Text, ""))
    If T = "" Then
        Me.txtComune.Tag = T
        Exit Sub
    End If
    If Len(T) = 1 Then s = T
    If Me.txtComune <> "" Then
      If UCase(T) = UCase(Mid(COMUNI, 1, Len(T))) Then
        If Len(T) > Len(Me.txtComune.Tag) Then
            Me.txtComune.SelStart = Len(T)
            Me.txtComune.SelLength = Len(Me.txtComune) - (Len(T))
        End If
    End If
    If Me.txtComune.ForeColor <> Colore Then Me.txtComune.ForeColor = Colore
    Me.txtComune.Tag = T
Exit Sub
ErrFas:
        If Me.txtComune.ForeColor = 0 Then MsgBox "Comune non in elenco"
        Colore = &H80&
        Me.txtProvincia = ""
        Me.txtCodiceComune = ""
        Me.txtComune.SetFocus
        End If
    Err.Clear
End Sub
Private Sub stampa_Click()
On Error GoTo Err_stampa_Click
    Dim stDocName As String
    stDocName = "Codice Fiscale"
    DoCmd.OpenReport stDocName, acPreview
Exit_stampa_Click:
    Exit Sub
Err_stampa_Click:
    MsgBox Err.description
    Resume Exit_stampa_Click
End Sub
Private Sub contrario_Click()
    Dim rec As Recordset
    Dim strsql As String
    Dim appoggio, anno, mese, giorno, sesso As String
    If Me.txtCodiceFiscale = "" Or IsNull(Me.txtCodiceFiscale) Then
        MsgBox "Impossibile proseguire! Inserire un codice fiscale nel campo
Giallo!"
        Exit Sub
    Else
        Me.txtCognome = Left(Me.txtCodiceFiscale, 3)
        Me.txtNome = Mid(Me.txtCodiceFiscale, 4, 3)
        appoggio = Mid(Me.txtCodiceFiscale, 12, 4)
        strsql = "select * from T_Comuni_CF where COMU_COD='" & appoggio &
"';"
        Set rec = CurrentDb.OpenRecordset(strsql)
        Me.txtComune = rec![Citta]
        Me.txtProvincia = rec![COMU_PROV]
        rec.Close
        Me.txtCodiceComune = appoggio
        If Mid(Me.txtCodiceFiscale, 7, 2) > 30 Then
            anno = "19" & Mid(Me.txtCodiceFiscale, 7, 2)
        Else
            anno = "20" & Mid(Me.txtCodiceFiscale, 7, 2)
        End If
        mese = Mid(Me.txtCodiceFiscale, 9, 1)
        If mese = "A" Then mese = "01"
        If mese = "B" Then mese = "02"
        If mese = "C" Then mese = "03"
        If mese = "D" Then mese = "04"
        If mese = "E" Then mese = "05"
        If mese = "H" Then mese = "06"
        If mese = "L" Then mese = "07"
        If mese = "M" Then mese = "08"
        If mese = "P" Then mese = "09"
        If mese = "R" Then mese = "10"
        If mese = "S" Then mese = "11"
        If mese = "T" Then mese = "12"
        If Mid(Me.txtCodiceFiscale, 10, 2) > 40 Then
            sesso = "F"
            giorno = str(Mid(Me.txtCodiceFiscale, 10, 2) - 40)
        Else
            sesso = "M"
            giorno = Mid(Me.txtCodiceFiscale, 10, 2)
        End If
        Me.txtDataNascita = CDate(giorno & "/" & mese & "/" & anno)
        Me.cboSesso = sesso
    End If
End Sub