Office: DTA nach SEPA

intimaul · 26. September 2012

Hallo,

da sich in 2014 das Lastschriftverfahren ändern wird, hätte ich gern gewußt ob das Modul AP_DTA(nutze ich z.Zt.) geändert wird oder etwas Neues gebaut wird um den SEPA-Ansprüchen gerecht zu werden.

:)

Scorefun · 28. September 2012

Diese Frage ist wohl eher an den Hersteller zu richten, oder?
Access-Paradies|AP-DTA

redround · 29. September 2012

alternativ kannst Du auch gerne einen 4stelligen Betrag in die Hand nehmen und es machen lassen ... und anschließend natürlich hier kostenlos veröffentlichen ;-)

earthbaer · 2. Januar 2014

Hallo,
ich habe selbst lange gesucht und nichts gefunden. Hier mein VBA Code um SEPA Sammelüberweisungen im XML Format zu erzeugen. Ich hoffe es kann jemand gebrauchen. Getestet mit Starmoney 9.0. Die IBAN Berechnung habe ich hier aus dem Forum.

!!! Keine Garantie !!!
!!! Benutzung auf eigene Gefahr !!!

Code:

Option Compare Database
'Verweis Microsoft XML V6.0 aktivieren

'Beispiel unter:
'Sepa SCT Beispiel Deutschland

Public fpath As String
Public Const namespace As String = "urn:sepade:xsd:pain.001.001.02"

Sub tst()

'createXML ("C:\xmlfolder\test.xml")
'addHeader "Test Mandant", 2, 5001.5
'addDebitor "Test Mandant", "DE83700202701234567890", "HYVEDEMMXXX"
'addTransaktion 66, "NO:0000019 SIEHE AVIS", "Sepa Test Inland", "DE67500691261234567890", "GENODE51ABO", 2500.75
'addTransaktion 67, "NO:0000019 SIEHE AVIS", "Sepa Test Inland", "DE81200700246542586520", "DEUTDE6F679", 2500.75
'openXml

'///////////IBAN////////////
Dim Tmp1
Tmp1 = GetIBAN("67852565", "1070630")
Debug.Print Tmp1
Debug.Print ValidateIBAN(Tmp1)

End Sub

Sub addTransaktion(lfdNr As Integer, Verwendungszweck As String, Name As String, IBAN As String, BIC As String, Betrag As Double)
Dim xmlFile As DOMDocument
Dim xmlPmtInf As IXMLDOMNode
Dim nodeInf As IXMLDOMNode
Dim nodeTmp As IXMLDOMNode
Dim nodeTmp2 As IXMLDOMNode
Dim nodeTmp3 As IXMLDOMNode
Dim attrTmp As IXMLDOMAttribute

'Prepare File
Set xmlFile = New DOMDocument
xmlFile.Load (SEPA.fpath)
Set xmlPmtInf = xmlFile.selectSingleNode("/Document/pain.001.001.02/PmtInf")

'Create nodeTrans Node
Set nodeTrans = xmlFile.createNode(1, "CdtTrfTxInf", SEPA.namespace)

'Prepare PmtId
Dim PmtId As String
PmtId = "Referenz: " & lfdNr

'Add PmtId Node
Set nodeTmp2 = xmlFile.createNode(1, "EndToEndId", SEPA.namespace)
nodeTmp2.Text = Left(PmtId, 35)
Set nodeTmp = xmlFile.createNode(1, "PmtId", SEPA.namespace)
nodeTmp.appendChild nodeTmp2
nodeTrans.appendChild nodeTmp

'Add InstdAmt Node
Set nodeTmp2 = xmlFile.createNode(1, "InstdAmt", SEPA.namespace)
nodeTmp2.Text = Replace(Replace(Betrag, ",", "."), ",", "")
Set attrTmp = xmlFile.createAttribute("Ccy")
attrTmp.nodeValue = "EUR"
nodeTmp2.Attributes.setNamedItem attrTmp
Set nodeTmp = xmlFile.createNode(1, "Amt", SEPA.namespace)
nodeTmp.appendChild nodeTmp2
nodeTrans.appendChild nodeTmp

'Add CdtrAgt Node
Set nodeTmp3 = xmlFile.createNode(1, "BIC", SEPA.namespace)
nodeTmp3.Text = BIC
Set nodeTmp2 = xmlFile.createNode(1, "FinInstnId", SEPA.namespace)
Set nodeTmp = xmlFile.createNode(1, "CdtrAgt", SEPA.namespace)
nodeTmp2.appendChild nodeTmp3
nodeTmp.appendChild nodeTmp2
nodeTrans.appendChild nodeTmp

'Add Cdtr Node
Set nodeTmp2 = xmlFile.createNode(1, "Nm", SEPA.namespace)
nodeTmp2.Text = Left(Name, 70)
Set nodeTmp = xmlFile.createNode(1, "Cdtr", SEPA.namespace)
nodeTmp.appendChild nodeTmp2
nodeTrans.appendChild nodeTmp

'Add CdtrAcct Node
Set nodeTmp3 = xmlFile.createNode(1, "IBAN", SEPA.namespace)
nodeTmp3.Text = IBAN
Set nodeTmp2 = xmlFile.createNode(1, "Id", SEPA.namespace)
Set nodeTmp = xmlFile.createNode(1, "CdtrAcct", SEPA.namespace)
nodeTmp2.appendChild nodeTmp3
nodeTmp.appendChild nodeTmp2
nodeTrans.appendChild nodeTmp

'Add RmtInf Node
Set nodeTmp2 = xmlFile.createNode(1, "Ustrd", SEPA.namespace)
nodeTmp2.Text = Verwendungszweck
Set nodeTmp = xmlFile.createNode(1, "RmtInf", SEPA.namespace)
nodeTmp.appendChild nodeTmp2
nodeTrans.appendChild nodeTmp

'Add CdtTrfTxInf to xmlPmtInf
xmlPmtInf.appendChild nodeTrans

xmlFile.Save (SEPA.fpath)

Set attrTmp = Nothing
Set nodeTmp3 = Nothing
Set nodeTmp2 = Nothing
Set nodeTmp = Nothing
Set nodeTrans = Nothing
Set xmlPmtInf = Nothing
Set xmlFile = Nothing

End Sub

Sub addDebitor(Auftraggeber As String, IBAN As String, BIC As String)
Dim xmlFile As DOMDocument
Dim xmlPain As IXMLDOMNode
Dim nodeInf As IXMLDOMNode
Dim nodeTmp As IXMLDOMNode
Dim nodeTmp2 As IXMLDOMNode
Dim nodeTmp3 As IXMLDOMNode

'Prepare File
Set xmlFile = New DOMDocument
xmlFile.Load (SEPA.fpath)
Set xmlPain = xmlFile.selectSingleNode("/Document/pain.001.001.02")

'Create PmtInf Node
Set nodeInf = xmlFile.createNode(1, "PmtInf", SEPA.namespace)

'Prepare PmtInfId
Dim PmtInfId As String
PmtInfId = Auftraggeber & " \ " & Format(Now, "yyyy-MM-dd")

'Add PmtInfId Node
Set nodeTmp = xmlFile.createNode(1, "PmtInfId", SEPA.namespace)
nodeTmp.Text = Left(PmtInfId, 35)
nodeInf.appendChild nodeTmp

'add PmtMtd Node
Set nodeTmp = xmlFile.createNode(1, "PmtMtd", SEPA.namespace)
nodeTmp.Text = "TRF"
nodeInf.appendChild nodeTmp

'Add PmtTpInf Node
Set nodeTmp3 = xmlFile.createNode(1, "Cd", SEPA.namespace)
nodeTmp3.Text = "SEPA"
Set nodeTmp2 = xmlFile.createNode(1, "SvcLvl", SEPA.namespace)
Set nodeTmp = xmlFile.createNode(1, "PmtTpInf", SEPA.namespace)
nodeTmp2.appendChild nodeTmp3
nodeTmp.appendChild nodeTmp2
nodeInf.appendChild nodeTmp

'Add ReqdExctnDt Node
Set nodeTmp = xmlFile.createNode(1, "ReqdExctnDt", SEPA.namespace)
nodeTmp.Text = "1999-01-01" 'Format(Now, "yyyy-MM-dd")
nodeInf.appendChild nodeTmp

'Add Dbtr Node
Set nodeTmp2 = xmlFile.createNode(1, "Nm", SEPA.namespace)
nodeTmp2.Text = Left(Auftraggeber, 70)
Set nodeTmp = xmlFile.createNode(1, "Dbtr", SEPA.namespace)
nodeTmp.appendChild nodeTmp2
nodeInf.appendChild nodeTmp

'Add DbtrAcct Node
Set nodeTmp3 = xmlFile.createNode(1, "IBAN", SEPA.namespace)
nodeTmp3.Text = IBAN
Set nodeTmp2 = xmlFile.createNode(1, "Id", SEPA.namespace)
Set nodeTmp = xmlFile.createNode(1, "DbtrAcct", SEPA.namespace)
nodeTmp2.appendChild nodeTmp3
nodeTmp.appendChild nodeTmp2
nodeInf.appendChild nodeTmp

'Add DbtrAgt Node
Set nodeTmp3 = xmlFile.createNode(1, "BIC", SEPA.namespace)
nodeTmp3.Text = BIC
Set nodeTmp2 = xmlFile.createNode(1, "FinInstnId", SEPA.namespace)
Set nodeTmp = xmlFile.createNode(1, "DbtrAgt", SEPA.namespace)
nodeTmp2.appendChild nodeTmp3
nodeTmp.appendChild nodeTmp2
nodeInf.appendChild nodeTmp

'Add ChrgBr Node
Set nodeTmp = xmlFile.createNode(1, "ChrgBr", SEPA.namespace)
nodeTmp.Text = "SLEV"
nodeInf.appendChild nodeTmp

'Add PmtInf to Pain
xmlPain.appendChild nodeInf

xmlFile.Save (SEPA.fpath)

Set nodeTmp3 = Nothing
Set nodeTmp2 = Nothing
Set nodeTmp = Nothing
Set nodeInf = Nothing
Set xmlPain = Nothing
Set xmlFile = Nothing

End Sub

Sub addHeader(Auftraggeber As String, nTransaktionen As Integer, sTransaktionen As Double)
Dim xmlFile As DOMDocument
Dim xmlPain As IXMLDOMNode
Dim nodeHdr As IXMLDOMNode
Dim nodeTmp As IXMLDOMNode
Dim nodeTmp2 As IXMLDOMNode

'Prepare File
Set xmlFile = New DOMDocument
xmlFile.Load (SEPA.fpath)
Set xmlPain = xmlFile.selectSingleNode("/Document/pain.001.001.02")

'Prepare MsgID
Dim MsgId As String
MsgId = "SEPA-File\" & Format(Now, "yyyy-MM-dd") & "\" & Format(Now, "HH:mm:ss")

'Create Header Node
Set nodeHdr = xmlFile.createNode(1, "GrpHdr", SEPA.namespace)

'Add MsgID Node
Set nodeTmp = xmlFile.createNode(1, "MsgId", SEPA.namespace)
nodeTmp.Text = Left(MsgId, 35)
nodeHdr.appendChild nodeTmp

'add CreDtTm Node
Set nodeTmp = xmlFile.createNode(1, "CreDtTm", SEPA.namespace)
nodeTmp.Text = Format(Now, "yyyy-MM-ddTHH:mm:ss")
nodeHdr.appendChild nodeTmp

'Add NbOfTxs Node
Set nodeTmp = xmlFile.createNode(1, "NbOfTxs", SEPA.namespace)
nodeTmp.Text = nTransaktionen
nodeHdr.appendChild nodeTmp

'Add CtrlSum Node
Set nodeTmp = xmlFile.createNode(1, "CtrlSum", SEPA.namespace)
nodeTmp.Text = Replace(Replace(sTransaktionen, ",", "."), ",", "")
nodeHdr.appendChild nodeTmp

'Add Grpg Node
Set nodeTmp = xmlFile.createNode(1, "Grpg", SEPA.namespace)
nodeTmp.Text = "GRPD"
nodeHdr.appendChild nodeTmp

'Add InitgPty Node
Set nodeTmp2 = xmlFile.createNode(1, "Nm", SEPA.namespace)
nodeTmp2.Text = Left(Auftraggeber, 70)
Set nodeTmp = xmlFile.createNode(1, "InitgPty", SEPA.namespace)
nodeTmp.appendChild nodeTmp2
nodeHdr.appendChild nodeTmp

'Add Header to Pain
xmlPain.appendChild nodeHdr

xmlFile.Save (SEPA.fpath)

Set nodeTmp2 = Nothing
Set nodeTmp = Nothing
Set nodeHdr = Nothing
Set xmlPain = Nothing
Set xmlFile = Nothing

End Sub

Sub createXML(pfad As String)
Dim xmlFile As DOMDocument
Dim xmlDoc As IXMLDOMElement
Dim xmlPain As IXMLDOMNode
Dim attrDoc1 As IXMLDOMAttribute
Dim attrDoc2 As IXMLDOMAttribute
Dim attrDoc3 As IXMLDOMAttribute

SEPA.fpath = pfad

Set xmlFile = New DOMDocument
xmlFile.appendChild xmlFile.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")

Set xmlDoc = xmlFile.appendChild(xmlFile.createElement("Document"))
Set xmlPain = xmlFile.createNode(1, "pain.001.001.02", namespace)

xmlDoc.appendChild xmlPain

'Set Document Attrib 1
Set attrDoc1 = xmlFile.createAttribute("xmlns")
attrDoc1.nodeValue = "urn:sepade:xsd:pain.001.001.02"
xmlDoc.setAttributeNode attrDoc1

'Set Document Attrib 2
Set attrDoc2 = xmlFile.createAttribute("xmlns:xsi")
attrDoc2.nodeValue = "http://www.w3.org/2001/XMLSchema-instance"
xmlDoc.setAttributeNode attrDoc2

'Set Document Attrib 3
Set attrDoc3 = xmlFile.createAttribute("xsi:schemaLocation")
attrDoc3.nodeValue = "urn:sepade:xsd:pain.001.001.02 pain.001.001.02.xsd"
xmlDoc.setAttributeNode attrDoc3

xmlFile.Save (SEPA.fpath)

Set attrDoc1 = Nothing
Set attrDoc2 = Nothing
Set attrDoc3 = Nothing
Set xmlPain = Nothing
Set xmlDoc = Nothing
Set xmlFile = Nothing

End Sub

Sub openXml()
Application.FollowHyperlink SEPA.fpath
End Sub

'//////////////////////IBAN///////////////////////////////

Public Function GetIBAN(ByVal Bankleitzahl As String, _
ByVal Kontonummer As String, _
Optional ByVal LaenderKennzeichen As String = "DE", _
Optional ByVal InBloecken As Boolean = False) As String
'Erstellt aus den gegebenen Argumenten den Passenden IBAN-Code und Giebt diesen zurück
Dim Rtn As String
Dim LKTmp As String
Dim BBAN As String
Dim PZ As String
Dim PrfZif As String
On Error GoTo ErrHdl

'check
If Len(Bankleitzahl) 8 Then
Call MsgBox("Bankleitzahl inkorrekt!")
GoTo ExitDooR
ElseIf Len(Kontonummer) < 4 Then
Call MsgBox("kontonummer inkorrekt!")
GoTo ExitDooR
ElseIf Len(LaenderKennzeichen) 2 Then
Call MsgBox("Länderkürzel inkorrekt!")
GoTo ExitDooR
End If

'Kontonummer = Left(Kontonummer & String(10, "0"), 10)
Kontonummer = Right(String(10, "0") & Kontonummer, 10)
LKTmp = AlphabetPositionOfCharacter(LaenderKennzeichen)
BBAN = Bankleitzahl & Kontonummer
PZ = 98 - GetMod(BBAN & LKTmp & "00")
PrfZif = Right("00" & PZ, 2)
Rtn = LaenderKennzeichen & PrfZif & BBAN

If InBloecken Then
BBAN = Rtn
Rtn = ""
While Len(BBAN) > 0
Rtn = Rtn & " " & Mid(BBAN, 1, 4)
BBAN = Mid(BBAN, 5)
Wend
Rtn = Trim(Rtn)
End If

ExitDooR:
GetIBAN = Rtn
Exit Function
ErrHdl:
MsgBox "Fehler N°: " & Err.Number & vbCrLf & vbCrLf & "Fehlerbeschreibugn:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
"In:" & vbCrLf & " Procedur: GetIBAN" & vbCrLf & " ModulTyp: Modul" & vbCrLf & " ModulName: MOD_IBAN_Berechnung", _
vbCritical, "Fehler in ""VerifyLoginRight"""
Resume ExitDooR
End Function
'

Private Function AlphabetPositionOfCharacter(ByVal LaenderKennzeichen As String) As String
'Gibt die Position des Buchstaben im Alphabet zurück (Umlaute werden nicht berücksichtigt!)
Dim Rtn As String
Dim Idx As Long
Dim Tmp As String * 1
On Error GoTo ErrHdl

Rtn = ""
For Idx = 1 To Len(LaenderKennzeichen)
Tmp = Mid(LaenderKennzeichen, Idx, 1)
Rtn = Rtn & (Asc(UCase(Tmp)) - 64 + 9)
Next Idx

ExitDooR:
AlphabetPositionOfCharacter = Rtn
Exit Function
ErrHdl:
MsgBox "Fehler N°: " & Err.Number & vbCrLf & vbCrLf & "Fehlerbeschreibugn:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
"In:" & vbCrLf & " Procedur: AlphabetPositionOfCharacter" & vbCrLf & " ModulTyp: Modul" & vbCrLf & " ModulName: MOD_IBAN_Berechnung", _
vbCritical, "Fehler in ""VerifyLoginRight"""
Resume ExitDooR
End Function
'

Private Function GetMod(ByVal BBAN As String) As String
'Ermittelt den Modulo 97 Wert aus dem BBAN da Mod nicht mit zahlen > long arbeiten kann
Dim Rtn As String
Dim Tmp As String
On Error GoTo ErrHdl

'zerlegen der großen Zahl und berechung in einzelschritten
Rtn = ""
While Len(BBAN) > 0
BBAN = Rtn & BBAN
Tmp = Left(BBAN, 9)
BBAN = Mid(BBAN, Len(Tmp) + 1)
Rtn = (Tmp) Mod 97
Wend

ExitDooR:
GetMod = Rtn
Exit Function
ErrHdl:
MsgBox "Fehler N°: " & Err.Number & vbCrLf & vbCrLf & "Fehlerbeschreibugn:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
"In:" & vbCrLf & " Procedur: GetMod" & vbCrLf & " ModulTyp: Modul" & vbCrLf & " ModulName: MOD_IBAN_Berechnung", _
vbCritical, "Fehler in ""VerifyLoginRight"""
Resume ExitDooR
End Function
'

Public Function ValidateIBAN(ByVal IBAN As String) As Boolean
'Prüft IBAN anhand der Prüfziffer
Dim Tmp As String
On Error GoTo ErrHdl

Tmp = Left(IBAN, 2)
Tmp = AlphabetPositionOfCharacter(Tmp)
Tmp = Mid(IBAN, 5) & Tmp & Mid(IBAN, 3, 2)
Tmp = GetMod(Tmp)
ValidateIBAN = (Tmp = "1")
ExitDooR:
Exit Function
ErrHdl:
MsgBox "Fehler N°: " & Err.Number & vbCrLf & vbCrLf & "Fehlerbeschreibugn:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
"In:" & vbCrLf & " Procedur: ValidateIBAN" & vbCrLf & " ModulTyp: Modul" & vbCrLf & " ModulName: MOD_IBAN_Berechnung", _
vbCritical, "Fehler in ""VerifyLoginRight"""
Resume ExitDooR
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Leiwenwiek · 26. März 2014

Hallo Earth Bär,

vielen Dank für das Script.

Ich habe es ausprobiert und es funktioniert sehr gut.
Allerdings musste ich einige Variablen umbenennen. Aus 'SEPA.irgendwas' wurde 'irgendwas'. Ansonsten kam der Fehler 424.

Es wird eine SEPA-Sammelüberweisung erzeugt.
Die Verknüpfung mit den Daten in meiner Tabelle bekomme ich hin.

Haben Sie eine Idee was verändert werden muss, um damit eine SEPA Terminüberweisung zu erzeugen?

Office: DTA nach SEPA

DTA nach SEPA

DTA nach SEPA

DTA nach SEPA

DTA nach SEPA - Similar Threads - DTA SEPA

SEPA Sammelüberweisung per VBA

SEPA-Lastschriften generieren