ATOUTFOX
COMMUNAUTÉ FRANCOPHONE DES PROFESSIONNELS FOXPRO
Visual FoxPro : le développement durable

VIREMENTS SEPA   



L'auteur

eric leissler
France France
Membre Simple
# 0000002784
enregistré le 06/03/2010
http://www.aumeric.fr
68 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é 10280 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é ...

www.atoutfox.org - Site de la Communauté Francophone des Professionnels FoxPro - v3.4.0 - © 2004-2024.
Cette page est générée par un composant COM+ développé en Visual FoxPro 9.0-SP2-HF3