L'auteur
eric leissler
 France
Membre Simple
# 0000002784
enregistré le 06/03/2010
http://www.aumeric.fr
67 ans
LEISSLER Eric
85290 MORTAGNE SUR SEVRE
de la société AUMERIC LOGICIELS
 Fiche personnelle
 Note des membres
pas de note
|
Contributions > 01 - PRG : Programmation
VIREMENTS SEPA
# 0000000875
ajouté le 04/02/2014 18:16:25 et modifié le 04/02/2014
consulté 9874 fois
Niveau
initié
|
| Description |
|---|
| Bonjour à toutes et tous
Dans la même lignée que les Prélèvements, voici les virements, à partir d'un fichier ETEBAC ( VI_RE)
les virements correspondent au modèle pain.001.001.003
Bien sur, les iban et numéros siret sont dépersonnalisés !
Cordialement
Eric LEISSLER
AUMERIC LOGICIELS |
| Code source : |
|---|
*!* *******************************************
* AUMERIC - Fevrier 2014 -----
*REALISER UN FICHIER XML POUR LE VIREMENTS A LA NORME SEPA
*
* CE PROGRAMME UTILISE LES FONCTIONS DE MA CONTRIB
*http://www.atoutfox.org/articles.asp?ACTION=FCONSULTER&ID=0000000716
*POUR TRANSFORMER LES RIB EN IBAN DANS LE PRG LIB_RIBETIBAN
*
*
* LA TABLE BIC.DBF CONTIENT 933 CODE ETABLISSEMENT ET BIC
*
* Le but de ce programme est de lire un fichier ETEBAC et d'en faire un fichier xml
* à la norme SEPA
*
*
*
******************************************
*!* ouverture de la table des codes établissements et bic
Use bic Alias bic In 0
*!* creation de la classe
oxml= Createobject("xmlsepa")
*!* -- paramètres
*!* nom de l'organisme qui prélève
oxml.nom = "PRELEVE"
*!* nom du message ( doit être unique )
oxml.msgid="PRELEVE-SDD-"+Right(Alltrim(Str(Year(Date()))),2)+Padl(jourdelannee(Date()),3,"0")+"-002"
*!* Informations sur le prélèvement
oxml.infopaiement="VIREMENTS MOIS " +PADL(MONTH(DATE()),2,"0")
*!* N° siret de l'organisme qui prélève
oxml.siret = "1234567890123"
*!* Méthode de paiement
oxml.pmethode = "TRF"
*!* date d'échéance
oxml.date_ech= ALLTRIM(STR(YEAR(DATE())))+"-"+PADL(ALLTRIM(STR(MONTH(DATE()))),2,"0")+"-10"
*!* organisme crediteur
oxml.crediteur="PRELEVEUR"
*!* appel des methodes
oxml.lire_etebac_et_fait_etebac_dbf
oxml.faitlexml
Select bic
Use
*******************************************************************************************
#Define crlf Chr(13)+Chr(10)
Define Class xmlsepa As Custom
nom = ""
montant=""
nb_transactions=""
msgid=""
siret=""
lachaineduxml=""
infopaiement=""
pmethode=""
date_ech=""
crediteur=""
Procedure Init
Endproc
Procedure document_et_pain
oxml.lachaineduxml='<?xml version="1.0" encoding="UTF-8" standalone="no" ?>'+crlf+;
'<Document xmlns="urn:iso:std:iso:20022:tech:xsd:pain.001.001.03">'+crlf+;
'<CstmrCdtTrfInitn>'+crlf+ oxml.lachaineduxml
Endproc
Procedure findocument_et_pain
oxml.lachaineduxml= oxml.lachaineduxml+crlf+;
"</CstmrCdtTrfInitn>"+crlf+;
"</Document>"
Endproc
Procedure faitlexml
machaine = "<OrgId>"+crlf+;
"<Othr>"+crlf+;
"<Id>"+oxml.siret+"</Id>"+crlf+;
"</Othr>"+crlf+;
"</OrgId>"+crlf
machaine= "<Id>"+crlf+machaine+"</Id>"
machaine= "<InitgPty>"+crlf+"<Nm>"+oxml.nom+"</Nm>"+crlf+machaine+crlf+"</InitgPty>"
machaine =machaine+crlf+"</GrpHdr>"
machaine ="<CtrlSum>"+oxml.montant+"</CtrlSum>"+crlf+machaine
machaine = "<NbOfTxs>"+oxml.nb_transactions+"</NbOfTxs>"+crlf+machaine
machaine ="<CreDtTm>"+ Alltrim(Str(Year(Date())))+"-"+Padl(Alltrim(Str(Month(Date()))),2,"0")+"-"+Padl(Alltrim(Str(Day(Date()))),2,"0")+"T"+Time() +"</CreDtTm>"+crlf+machaine
machaine = "<MsgId>"+oxml.msgid+"</MsgId>"+crlf+machaine
machaine = '<GrpHdr>'+crlf+machaine
oxml.lachaineduxml=machaine
oxml.paiementinfo
*------------------- ON A FINI OU PRESQUE -------------------------
oxml.ecrire_le_fichier_xml
Endproc
Procedure paiementinfo
Local machaine
Local bic_cdt
Select etebac
Locate
iban_crediteur=Strtran( calculcleiban("FR",etebac.cetab +etebac.cguich +etebac.cpte+Alltrim(((clerib(etebac.cetab+ etebac.cguich+ etebac.cpte) ))))," ","")
Select bic
Set Order To etab
Seek etebac.cetab
If Found()
bic_cdt=bic.bic
Endif
Select etebac
Go 2
Do While Not Eof()
machaine = ;
"<PmtInf>" +crlf+;
"<PmtInfId>"+ oxml.infopaiement+"</PmtInfId>" +crlf+;
"<PmtMtd>"+oxml.pmethode+"</PmtMtd>"+crlf+;
"<NbOfTxs>1</NbOfTxs>"+ crlf+;
"<CtrlSum>"+ Alltrim(Str(Val(etebac.valeur)/100,15,2)) + "</CtrlSum>"+crlf+;
"<PmtTpInf>"+crlf+;
"<SvcLvl>"+crlf+;
"<Cd>SEPA</Cd> "+crlf+;
"</SvcLvl>"+crlf+;
"</PmtTpInf>"+crlf+;
"<ReqdExctnDt>"+oxml.date_ech+"</ReqdExctnDt>" +crlf+;
"<Dbtr>" +crlf+;
"<Nm>"+"ASSOCIATION PRELEVE"+"</Nm>" +crlf+;
"</Dbtr>" +crlf+;
"<DbtrAcct>"+crlf+;
"<Id>"+crlf+;
"<IBAN>"+"FR7600000000000000000000000"+"</IBAN> "+crlf+;
"</Id>"+crlf+;
"</DbtrAcct>"+crlf+;
"<DbtrAgt>"+crlf+;
"<FinInstnId>"+crlf+;
"<BIC>CMCIFR2A</BIC> "+crlf+;
"</FinInstnId>"+crlf+;
"</DbtrAgt>"+crlf+;
"<CdtTrfTxInf>"+crlf+;
"<PmtId>"+crlf+;
"<EndToEndId>VIREMENT " +PADL(MONTH(DATE()),2,"0") +"</EndToEndId> "+crlf+;
"</PmtId>"+crlf+;
"<Amt>"+crlf+;
'<InstdAmt Ccy="EUR">'+Alltrim(Str(Val(etebac.valeur)/100,15,2))+"</InstdAmt> "+crlf+;
"</Amt>"+crlf
oxml.lachaineduxml=oxml.lachaineduxml + machaine
*!* on passe au crédité de l'opération
machaine=""
machaine="<CdtrAgt>"+crlf+;
"<FinInstnId>"+crlf+;
"<BIC>"+CALCBIC()+"</BIC> "+crlf+;
"</FinInstnId>"+crlf+;
"</CdtrAgt>"+crlf+;
"<Cdtr>"+crlf+;
"<Nm>"+Alltrim(etebac.nom)+" "+Alltrim(etebac.prenom)++"</Nm> "+crlf+;
"</Cdtr>"+crlf+;
"<CdtrAcct>"+crlf+;
"<Id>"+crlf+;
"<IBAN>"+Strtran( calculcleiban("FR",etebac.cetab +etebac.cguich +etebac.cpte+Alltrim(((clerib(etebac.cetab+ etebac.cguich+ etebac.cpte) ))))," ","")+"</IBAN>"+crlf +;
"</Id>"+crlf+;
"</CdtrAcct>"+crlf+;
"<RmtInf>"+crlf+;
"<Ustrd>"+Alltrim(etebac.libelle)+"</Ustrd> "+crlf+;
"</RmtInf>"+crlf+;
"</CdtTrfTxInf>"+crlf
oxml.lachaineduxml=oxml.lachaineduxml + machaine
oxml.lachaineduxml=oxml.lachaineduxml + " </PmtInf>"+crlf
Select etebac
If Not Eof()
Skip
Else
Exit
Endif
Enddo
Endproc
Function calcbic
Local oldselect
oldselect=Select()
Local retour
Select bic
Set Order To etab
Seek etebac.cetab
If Found()
retour ==bic.bic
Else
msgbox("l'établissement "+etab.cteab + " n'a pas de bic connu ")
Endif
Select (oldselect)
Return retour
Endfunc
Procedure ecrire_le_fichier_xml
oxml.document_et_pain
oxml.findocument_et_pain
Strtofile(oxml.lachaineduxml,PUTFILE("Ecrire le fichier de virements","VIREMENT_SEPA.xml","xml"))
Endproc
Procedure lire_etebac_et_fait_etebac_dbf
Create Cursor etebac (nom c(13),;
prenom c(41),;
cguich c(5), ;
cpte c(11),;
valeur c(14),;
libelle c(30), ;
cetab c(5) ,;
bic c(11) ,;
iban c(34) )
m.ctampon=Space(500)
m.nfic=Fopen(Getfile( "","ouvrir le fichier VI_RE","Ouvrir"))
m.fin=Fseek(nfic,0,2)
m.deb=Fseek(nfic,0)
m.combien=0
m.montant=0
m.nbpaie=1
m.niveau=1
Point=0
Do While Point<=m.fin-m.deb AND niveau < 6
m.ctampon=Fread(m.nfic,162)
If Point<(fin-163)
m.nbpaie=m.nbpaie+1
m.niveau=m.niveau+1
Select etebac
Insert Into etebac (nom,prenom,cguich,cpte,valeur,libelle,cetab) ;
VALUES ;
( UPPER(Substr(m.ctampon,31,13)),;
UPPER(SUBSTR(m.ctampon,45,41)),;
SUBSTR(m.ctampon,87,5),;
UPPER(SUBSTR(m.ctampon,92,11)),;
SUBSTR(m.ctampon,105,14),;
UPPER(SUBSTR(m.ctampon,119,30)),;
SUBSTR(m.ctampon,150,5);
)
m.montant=Val(Substr(m.ctampon,104,17))/100
m.combien=m.combien+m.montant
Endif
Point=Point+162
ENDDO
=Fclose(m.nfic)
m.nbpaie=m.nbpaie-2
oxml.nb_transactions=Alltrim(Str(m.nbpaie))
oxml.montant= Alltrim(Str(m.combien,15,2))
Endproc
Enddefine
Function calcbic
Local oldselect
oldselect=Select()
Local retour
Select bic
Set Order To etab
Seek etebac.cetab
If Found()
retour =Alltrim(bic.bic)
Else
msgbox("l'établissement "+etab.cteab + " n'a pas de bic connu ")
Endif
Select (oldselect)
Return retour
Endfunc
Function jourdelannee
Parameter tdate
*isolate the year and convert it to a string
cYear = Right(Dtoc(tdate),2)
firstjan = Ctod("01/01/" + cYear)
*calculate the sequential number of the day
jday = tdate-firstjan+1
Return Alltrim(Str(jday))
Function lirenombre(sStr As Variant )
public sCaption As String
LOCAL in_i As Integer
LOCAL sString As String
LOCAL sCar As String
sString = CStr(sStr)
in_i = 1
Do While in_i <= Len(sString)
sCar = substr(sString, in_i, 1)
If Asc(sCar) < 48 Or Asc(sCar) > 57 Then
sString = substr(sString, 1, in_i) + substr(sString, in_i + 1, Len(sString))
in_i = in_i - 1
EndIf
in_i = in_i + 1
enddo
lirenombre = sString
RETURN lirenombre
EndFunc
Function lirenumerocompte(sStr As Variant)
LOCAL in_i As Integer
LOCAL sString As String
LOCAL iNb As Integer
LOCAL sCar As String
LOCAL sTemp As String
sString = CStr(sStr)
in_i = 1
Do While in_i <= Len(sString)
sTemp = substr(sString, in_i, 1)
If Asc(sTemp) < 48 Or Asc(sTemp) > 57 Then
If Asc(sTemp) >= 65 Or Asc(sTemp) <= 90 Then
iNb = Asc(sTemp) - 64
If iNb > 9 Then
iNb = iNb - 9
endif
If iNb > 9 Then
iNb = iNb - 8
endif
sCar = CStr(iNb)
sString = substr(sString, 1, in_i - 1) + sCar + substr(sString, in_i + 1, Len(sString))
Else
If Asc(sTemp) >= 97 Or Asc(sTemp) <= 122 Then
iNb = Asc(sTemp) - 96
If iNb > 9 Then
iNb = iNb - 9
endif
If iNb > 9 Then
iNb = iNb - 8
endif
sCar = CStr(iNb)
sString = substr(sString, 1, in_i - 1) + sCar + substr(sString, in_i + 1, Len(sString))
Else
sString = substr(sString, 1, in_i) + substr(sString, in_i + 1, Len(sString))
in_i = in_i - 1
EndIf
Endif
EndIf
in_i = in_i + 1
enddo
lirenumerocompte = sString
RETURN lirenumerocompte
EndFunc
Function lirenumeroiban(sStr As String)
LOCAL in_i As Integer
LOCAL sString As String
LOCAL sStringRes As String
LOCAL iNb As Integer
LOCAL sCar As String
LOCAL sTemp As String
sString = sStr
sStringRes = ""
in_i = 1
Do While in_i <= Len(sString)
sTemp = substr(sString, in_i, 1)
If Asc(sTemp) < 48 Or Asc(sTemp) > 57 Then
If Asc(sTemp) >= 65 Or Asc(sTemp) <= 90 Then
iNb = Asc(sTemp) - 55
sCar = CStr(iNb)
sStringRes = sStringRes + sCar
Else
If Asc(sTemp) >= 97 Or Asc(sTemp) <= 122 Then
iNb = Asc(sTemp) - 87
sCar = CStr(iNb)
sStringRes = sStringRes + sCar
Else
EndIf
EndIf
Else
sStringRes = sStringRes + substr(sString, in_i, 1)
EndIf
in_i = in_i + 1
ENDDO
lirenumeroiban = sStringRes
RETURN lirenumeroiban
EndFunc
Function Calculcleiban(sCodePays As String, sRib As String)
LOCAL tCodePays As String
LOCAL tRib As String
LOCAL tConcat As String
LOCAL in_i As Integer
LOCAL sRetenue As Variant
LOCAL sCle As Variant
LOCAL iNbInterm As Variant
LOCAL sStrInterm As Variant
LOCAL iCodeNum As Integer
LOCAL sCodeStr As String
LOCAL tIBAN As String
tRib = lirenumeroiban(sRib)
tCodePays = lirenumeroiban(sCodePays)
If Len(sCodePays) <> 2 Then
MESSAGEBOX("Le Code Pays n'a pas 2 lettres", vbCritical, Trim(sCaption))
Calculcleiban = ""
Exit Function
EndIf
tConcat = tRib + tCodePays + "00"
in_i = 1
sRetenue = ""
Do While in_i <= Len(tConcat)
sStrInterm = sRetenue + substr(tConcat, in_i, 9)
iNbInterm = INT(val(sStrInterm))
sCle = calculmodulo(iNbInterm, 97)
sRetenue = cstr(sCle)
in_i = in_i + 9
enddo
iCodeNum = 98 - calculmodulo(sCle, 97)
If iCodeNum < 10 Then
sCodeStr = "0" + ALLTRIM(STR(iCodeNum))
Else
sCodeStr = iCodeNum
EndIf
scodestr=cstr(sCodeStr )
tIBAN = sCodePays + sCodeStr + " " + substr(sRib, 1, 4)
tIBAN = tIBAN + " " + substr(sRib, 5, 4)
tIBAN = tIBAN + " " + substr(sRib, 9, 4)
tIBAN = tIBAN + " " + substr(sRib, 13, 4)
tIBAN = tIBAN + " " + substr(sRib, 17, 4)
tIBAN = tIBAN + " " + substr(sRib, 21, 3)
Calculcleiban = tIBAN
RETURN Calculcleiban
EndFunc
Function FormatRib(sCodeBanque As String, sCodeGuichet As String, sNoCompte As String, sCleRib As String)
LOCAL tCodeBanque As String
LOCAL tCodeGuichet As String
LOCAL tNoCompte As String
LOCAL tCleRib As String
LOCAL tCodeStr As String
LOCAL tRib As String
LOCAL iNbCleRib As Integer
tCodeBanque = lirenombre(sCodeBanque)
tCodeGuichet = lirenombre(sCodeGuichet)
tNoCompte = lirenumerocompte(sNoCompte)
tCleRib = lirenombre(sCleRib)
iNbCleRib = MOD(sCleRib,100)
If tCleRib < 10 Then
tCodeStr = "0" + iNbCleRib
Else
tCodeStr = iNbCleRib
EndIf
tRib = sCodeBanque + sCodeGuichet + sNoCompte + tCodeStr
FormatRib = tRib
RETURN formatrib
EndFunc
Function calculmodulo(x As Variant, y As Variant) As Variant
*!* calculmodulo = x - (Int(x / y) * y)
calculmodulo = MOD(x,y)
RETURN calculmodulo
ENDFUNC
FUNCTION cstr(truc)
IF VARTYPE(truc)=="N"
RETURN ALLTRIM(STR(truc))
ELSE
RETURN truc
endif
ENDFUNC
FUNCTION cvar(toto)
IF VARTYPE(toto)=="C"
RETURN VAL(toto)
ELSE
RETURN toto
ENDIF
endfunc
function clerib(nu_compte)
local premier,deuxieme,troisime,prerest,deuxrest,troisrest,valretour
***********************************************************************
* la fonction doit recevoir le numéro de compte en parametres
* 5 digits pour le code établissement
* 5 digits pour le code guichet
* 11 digits pour le numéro de compte soit 21 digits au total
* la clé rib est renvoyé par la fonction en numérique
*
* Pour les comptes CCP les lettres sont remplacées par des chiffres
* selon la convention ci_dessous
*
* A=1 j=1 b=2 k=2 etc..etc
*
*
*
*
*
*
***********************************************************************
* changement des lettres en chiffres grace à la fonction strtran
nu_compte=ChrTran(nu_compte,"AJBKSCLTDMUENVFOWGPXHQYIRZ","11222333444555666777888999")
* vérification du numéro de compte 21 digits en tout
if len(nu_compte)#21
em_message(" Numéro de compte non valide")
return "0"
endif
valretour="0"
* calcul de la clé
nu_compte=nu_compte+"00"
premier=substr(nu_compte,1,7)
deuxieme=substr(nu_compte,8,8)
troisieme=substr(nu_compte,16,8)
prerest=alltrim(str(mod(val(premier),97)))
deuxieme=prerest+deuxieme
deuxrest=alltrim(str(mod(val(deuxieme),97)))
troisieme=deuxrest+troisieme
troisrest=alltrim(str(mod(val(troisieme),97)))
valretour=97-val(troisrest)
valretour=alltrim(str(valretour))
return PADL(valretour,2,"0")
|
| Commentaires |
|---|
Aucun commentaire enregistré ...
|
|
|
|
Retour à la liste
