BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CRuIBAN"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Class CRuIBAN
' Überprüft die IBAN und gibt zusätzlich die BIC und den Namen der Bank zurück
' Alternativ kann die Prüfziffer durch "??" ersetzt werden, dann liefert sie obige Daten
' mit der korrekten Prüfziffer
' Init
' Länderkennzeichen + Prüfzenziffer (z.B. "12" oder "??" + BLZ + Kontonummer
' Liefert
' ClassRuIban.IBAN
' .BIC
' .Name
' .Ort
' .Ok true/false
' Aufruf
' Dim RuIBAN As CRuIBAN
' Set RuIBAN = New CRuIBAN
' RuIBAN.InitiateProperties IBAN:="DE??370502990123456799"
' If RuIBAN.Ok = True Then
' Debug.Print (RuIBAN.IBAN)
' Debug.Print (RuIBAN.Bic)
' Debug.Print (RuIBAN.Name)
' Debug.Print (RuIBAN.Ort)
' Else
' Debug.Print ("IBAN ist fehlerhaft")
' End If
' Option Explicit
' Bankleitzahlendatei der Bundesbank
Const BankCodeFile As String = "BankCode.txt"
' Properties
Private m_IBAN As String
Private m_BIC As String
Private m_Name As String
Private m_Ort As String
Private m_Ok As Boolean
' Initiiert das Objekt
' Teilt die IBAN in ihre Bestandteile auf
' und prüft die IBAN
' Setzt Ok auf true oder false
Public Sub InitiateProperties(IBAN As String)
m_Ok = ISIBAN(IBAN)
If m_Ok = True Then
m_IBAN = IBAN
GetBank Mid(IBAN, 5, 8)
Else
m_IBAN = ""
m_BIC = ""
m_Name = ""
End If
End Sub
' Properties Public
Public Property Get IBAN() As String
IBAN = m_IBAN
End Property
Public Property Get Bic() As String
Bic = m_BIC
End Property
Public Property Get Name() As String
Name = m_Name
End Property
Public Property Get Ort() As String
Ort = m_Ort
End Property
Public Property Get Ok() As Boolean
Ok = m_Ok
End Property
' Properties Private
Private Property Let IBAN(value As String)
m_IBAN = value
End Property
Private Property Let Bic(value As String)
m_BIC = value
End Property
Private Property Let Name(value As String)
m_Name = value
End Property
Private Property Let Ort(value As String)
m_Ort = value
End Property
Private Property Let Ok(value As Boolean)
m_Ok = value
End Property
'Liefert True für korrekte IBAN, sonst false
Public Function ISIBAN(IBAN As String) As Boolean
Dim mysIBAN As String
Dim LaenderCode As String
Dim Pruefsumme As String
Dim BLZ As String
Dim Konto As String
Dim BLZ_Konto As String
Dim Umstellung As String
Dim sModulus As String
Dim Rest As Integer
Dim CreateIBAN As Boolean
'Leerzeichen entfernen
mysIBAN = Replace(IBAN, " ", "")
'Eine IBAN hat maximal 34 Stellen
If (Len(mysIBAN) > 34 Or Len(mysIBAN) < 5) Then GoTo Error_ISIBAN
LaenderCode = UCase(Left(mysIBAN, 2))
Pruefsumme = UCase(Mid(mysIBAN, 3, 2))
BLZ = UCase(Mid(mysIBAN, 5, 8))
Konto = UCase(Mid(mysIBAN, 13))
BLZ_Konto = BLZ + Right("000000000" + Konto, 10)
' ist Prüfsumme ok?
If IsNumeric(Pruefsumme) = False Then
' Wenn keine echte Prüfziffer, nur "??" ist erlaubt
If Pruefsumme <> "??" Then GoTo Error_ISIBAN
' IBAN soll erzeugt werden
CreateIBAN = True
Else
' IBAN soll nur geprüft werden
CreateIBAN = False
End If
' ist LänderCode ok?
' nur "DE" implementiert
If ISLaendercode(LaenderCode) = False Then GoTo Error_ISIBAN
' IBAN umstellen, BLZ und Konto nach vorne (ISO 3166)
Umstellung = BLZ_Konto + LaenderCode + "00"
' A..Z durch Zahlen 10-35 ersetzen
sModulus = IBANCleaner(Umstellung)
' Modulo 97-10 (ISO 7064)
Rest = 98 - Modulo(sModulus, 97)
If CreateIBAN = True Then
' "??" wird durch Pruefziffer (Rest) ersetzt
' Kontonummer wird auf 10 Stellen rechtsbündig gestetzt
IBAN = LaenderCode + Right("0" + CStr(Rest), 2) + BLZ_Konto
Else
' Pruefsumme nicht identisch, ERROR
If Right("0" + CStr(Rest), 2) <> Pruefsumme Then GoTo Error_ISIBAN
Error_ISIBAN
End If
ISIBAN = True
Exit_ISIBAN:
Exit Function
Error_ISIBAN:
ISIBAN = False
End Function
' Prüft auf den Ländercode
' hier nur DE, weil sonst auch andere Algorithen geändert werden müssen
Private Function ISLaendercode(code As String) As Boolean
'Der Code muss laut ISO 3166-1 ein 2-stelliger Ländercode aus Buchstaben sein.
If Len(code) <> 2 Then GoTo Error_ISLaendercode
code = UCase(code)
Dim Laendercodes As Variant
Laendercodes = Array("DE") ' oder "DE", "FR", ..
Dim I As Integer
For I = 0 To UBound(Laendercodes)
If Laendercodes(I) = code Then
ISLaendercode = True
Exit For
Else
ISLaendercode = False
End If
Next I
Exit_ISLaendercode:
Exit Function
Error_ISLaendercode:
ISLaendercode = False
End Function
'IBAN Cleaner
' Buchstaben durch Zahlen ersetzen
Private Function IBANCleaner(IBAN As String) As String
Dim replacewith As Integer
Dim sreplace As String
Dim I As Integer
For I = 65 To 90
replacewith = I - 64 + 9
sreplace = Chr(I)
IBAN = Replace(IBAN, CStr(sreplace), CStr(replacewith))
Next I
IBANCleaner = IBAN
End Function
' Modulo für lange Zahlen in 9-Blöcken
Private Function Modulo(sModulus As String, Divisor As Integer) As Integer
Dim sDividend As String
Dim Dividend As Long
Dim sDividendRest As String
Dim sRest As String
Dim Rest As Long
Dim I As Integer
' Anfang für den 1. Durchlauf
sRest = ""
sDividendRest = sModulus
' Bis zu 4 x durchlaufen
For I = 0 To 4
sDividend = Left(sRest + sDividendRest, 9)
Dividend = CLng(Val(sDividend))
Rest = Dividend Mod Divisor
' sDividendRest um (sDivident - sRest) vorne kürzen
sDividendRest = Mid(sRest + sDividendRest, 10)
' sRest neu
sRest = CStr(Rest)
' wenn sDividendRest = "" Schleife verlassen
If sDividendRest = "" Then Exit For
Next I
Modulo = Rest
End Function
' Setzt BIC und Bankname aus Bankleitzahlendatei der Bundesbank
Private Sub GetBank(BLZ As String)
Dim dataArray() As String
' Lese BankCode-Datei in Array
Open BankCodeFile For Input As #1
dataArray = Split(Input$(LOF(1), #1), vbLf)
Close #1
Dim I As Integer
Dim Pos As Integer
For I = 0 To UBound(dataArray)
' Finde BLZ
Pos = InStrRev(dataArray(I), BLZ)
If Pos > 0 Then
' setze BIC, Name und Ort der Bank
m_BIC = Mid(dataArray(I), 140, 11)
m_Name = Mid(dataArray(I), 108, 27)
m_Ort = Mid(dataArray(I), 73, 35)
Exit For
End If
Next I
End Sub