PDA

Archiv verlassen und diese Seite im Standarddesign anzeigen : [Source] eTIN berechnen



Lichter
23.09.2005, 16:51 / @660
Ist zwar brotlose Kunst, aber vielleicht interesseirt es jemanden.
Ist nicht mit Namen mit Umlauten oder Bindestrich getestet.



' Bitte nicht entfernen:Copyright Mörfi 09/2005 BA Pankow
' eTIN erzeugen
ar = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
arrg = array(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,0,1,2,3,4,5,6,7,8,9)
arru = array(0,1,0,5,7,9,13,15,17,19,21,2,4,18,20,11,3,6,8,12,14,16,10,22,23,24,25,1,0,5,7,9,13,15,17,19,21)
tit = "eTIN berechnen -- Mörfi 09/2005 BA Pankow"
y1 =""
do while not isdate(y1) ' solange in der Schleife bleiben, bis gültiges Datum eingegeben wurde
y1 = inputbox(zz & "Geburtsdatum (TT.MM.JJJJ):",tit,y1,,1000)
if len(y1) < 10 then y1 = " "
if not isdate(y1) then y1 = "Datumsformat TT.MM.JJJJ"
loop
d = cdate(y1)
d1 = day(d)
if len(d1) = 1 then d1 ="0" & d1 ' Zahl muss 2-stellig sein
d2 = month(d)
c2 = chr(d2+64) ' kennbuchstaben für den Monat ermittelt
d3 = year(d)
if d3 > 1000 then d3 = right(d3,2) ' wenn jahreszahl 4-stellig, dann nur die leztzen beiden Ziffern verwenden
y2 = UCASE(inputbox(zz & "Vorname:",tit,,,1000))
y2 = tausch(y2)
vname = y2
y2 = ""
y2 = UCASE(inputbox(zz & "Nachname:",tit,,,1000))
y2 = tausch(y2)
nname = y2
y2 = nname & vname & d3 & c2 & d1 ' verketten für Prüfziffernberechnung
x1 =0
b1 =0
x = 0
h1 =1
for i = 1 to len(y2) ' Beginn Prüfziffernermittlung
s1 = Mid(y2,i,1) ' jedes Zeichen separat gewichten
b1 = instr(1,ar,s1,1) ' Zuordnung der Gewichtung in der Tabelle ermitteln
if h1 = 1 then ' wenn zeichen an ungerader Position, dann verwende Tabelle arru
x1 = arru(b1)
h1 = 0
else ' wenn zeichen an gerader Position, dann verwende Tabelle arrg
x1 = arrg(b1)
h1 = 1
end if
x = x + x1 ' alle Gewichtungen addieren
next
a = x mod 26 ' Rest bei Modulo 26 ermitteln , damit kann die Prüfziffer A bis Z sein
p = chr(65 + a) ' Prüfziffer darstellen
msgbox nname & vname & d3 & c2 & d1 & p,16,tit

function tausch(y2)
y2 = Replace(y2,"-","")
y2 = Replace(y2," ","")
y2 = Replace(y2,"SCH","Y")
y2 = Replace(y2,"Ä","AE") ' ich mal davon aus, dass diese Buchstaben so aufgelöst werden müssen
y2 = Replace(y2,"Ö","OE")
y2 = Replace(y2,"Ü","UE")
y2 = Replace(y2,"ß","SS")
y3 = y2
y4 = ""
for i = len(y3) to 1 Step -1 ' Vokale in umgekehrter Reihenfolge speichern
y5 =mid(y3,i,1)
Select Case mid(y3,i,1)
Case "A" y4 = y4 + mid(y3,i,1)
Case "E" y4 = y4 + mid(y3,i,1)
Case "I" y4 = y4 + mid(y3,i,1)
Case "O" y4 = y4 + mid(y3,i,1)
Case "U" y4 = y4 + mid(y3,i,1)
End Select
next
y2 = Replace(y2,"A","")
y2 = Replace(y2,"E","")
y2 = Replace(y2,"I","")
y2 = Replace(y2,"O","")
y2 = Replace(y2,"U","")
if len(y2)>3 then
else
i1= 4 - len(y2)
for i =1 to i1
if len(y4)>= i then y2 = y2 + mid(y4,i,1) else y2 = y2 + "X" ' wenn kürzer als 4 Zeichen, dann auffüllen
next
end if
y2 = left(y2,4) ' es werden 4 Zeichen gebraucht
tausch = y2
end function