Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > it.comp.lang.visual-basic > #19751

Re: RIBA in formato xml iso 20022

Show all headers | View raw

Public xINIZIO As String 'Legge il file BONIF_XML_TESTATA
Public xXML As String    'Legge il file BONIF_XML_CORPO
Public xFINE As String   'Legge il file BONIF_XML_FINE
Public ContaBonifici As Integer
Public Dx(1 To 500, 1 To 50) As String
Public DxCod(1 To 500) As String
Public DxOrd(1 To 500) As Double
Public DollaroTOTALE As Double
Public R As Long
Public QuantiRec As Long
Dim T1 As String
Dim TTUTTO As String
Dim Dollari As String
Dim Adesso1 As String
Dim Adesso2 As String
Dim Quanti As String
Dim ContaDisp As Integer
Dim Distinta As String


Public Sub Fai_File_XML_Bonifici()
Dim R As Integer
Dim XML_testoFile As String
Dim XML_nomeFile As String
Adesso1 = Adesso
Adesso2 = AAAA_MM_GG(Date)
TotElFin = 0
STRINGA1 = ""
xINIZIO = TestoNetto(LeggiFileASCII(App.Path & "\BONIF_XML_TESTATA.TXT"))
xXML = TestoNetto(LeggiFileASCII(App.Path & "\BONIF_XML_CORPO.TXT"))
xFINE = TestoNetto(LeggiFileASCII(App.Path & "\BONIF_XML_FINE.TXT"))
TTUTTO = ""
If Esempio_Leggi_Bonifici_XML Then
    ContaDisp = 0
    For R = 1 To QuantiRec
        T1 = xXML
        ContaDisp = ContaDisp + 1
        For X = 10 To 50 'Dati di dettaglio
            If X = 30 Then
                X = X
            End If
            If Dx(R, X) = "//" Then GoTo FineR
            Dollari = "$" & Trim(Str(X)) & "$"
            T1 = Replace(T1, Dollari, Trim(Dx(R, X)))
        Next X
FineR:
        T1 = Replace(T1, "$NUMERODISP$", Trim(Str(ContaDisp)))
        TTUTTO = TTUTTO & T1
    Next R
Else
    'Errore
End If
TTUTTO = xINIZIO & vbCrLf & TTUTTO & xFINE
TTUTTO = Replace(TTUTTO, "$ADESSO1$", Adesso1)
TTUTTO = Replace(TTUTTO, "$ADESSO2$", Adesso2)
TTUTTO = Replace(TTUTTO, "$QUANTI$", QuantiRec)
For X = 3 To 9 'Dati generali
    If Dx(QuantiRec, X) = "//" Then GoTo FineFine
    Dollari = "$" & Trim(Str(X)) & "$"
    TTUTTO = Replace(TTUTTO, Dollari, Dx(QuantiRec, X))
Next X
FineFine:
TTUTTO = Replace(TTUTTO, "$TOT$", Str_Importo(DollaroTOTALE))
XML_nomeFile = App.Path & "\XML_BACK.XML"
ScriviFileASCII XML_nomeFile, TTUTTO
'Registra i bonifici come XML fatti
XML_testoFile = Compatta(TTUTTO)
XML_nomeFile = App.Path & "\BON_" & Adesso & ".XML"
ScriviFileASCII XML_nomeFile, XML_testoFile
Call MsgBox("Salvato file" _
            & vbCrLf & XML_nomeFile _
            , vbInformation, App.Title)
End Sub


Private Function Compatta(Testo1 As String) As String
Dim Testo2 As String
Dim Lines As Long
Dim L As Long
Testo1 = TestoNetto(Testo1)
Lines = MemoLines(Testo1)
For L = 1 To Lines
    Testo2 = Testo2 & Trim(MemoLine(Testo1, L))
Next L
Compatta = Testo2
End Function


Public Function Esempio_Leggi_Bonifici_XML() As Boolean
'Funzione che legge la tabella dei bonifici
'il campo x_ord contiene l'importo
'i campi X_3 / X_9 CONTENGONO DATI GENERALI
'i campi X_10 / X_37 CONTENGONO DATI DETTAGLIO DEL SINGOLO BONIFICO
Dim SelectSQL As String
Dim X As Integer
Dim RS As Recordset
DollaroTOTALE = 0
SelectSQL = "SELECT * FROM DETT1_XML WHERE X_48='//' AND X_49 = 'BONIFICO' 
ORDER BY X_50"
Set RS = PublicDB.OpenRecordset(SelectSQL)
If RS.RecordCount > 0 Then
    RS.MoveFirst
    RS.MoveLast
    QuantiRec = RS.RecordCount
    RS.MoveFirst
    For R = 1 To QuantiRec
        DxCod(R) = RS.fields(0)  '  1  X_COD    Testo   50
        DxOrd(R) = RS.fields(1)  '  2  X_ORD    Numero  8
        DollaroTOTALE = DollaroTOTALE + DxOrd(R)
        Dx(R, 3) = RS.fields(2)  '  3  X_3      Testo   50
        Dx(R, 4) = RS.fields(3)  '  4  X_4      Testo   50
        Dx(R, 5) = RS.fields(4)  '  5  X_5      Testo   50
        Dx(R, 6) = RS.fields(5)  '  6  X_6      Testo   50
        Dx(R, 7) = RS.fields(6)  '  7  X_7      Testo   50
        Dx(R, 8) = RS.fields(7)  '  8  X_8      Testo   50
        Dx(R, 9) = RS.fields(8)  '  9  X_9      Testo   50
        Dx(R, 10) = RS.fields(9) ' 10  X_10     Testo   50
        Dx(R, 11) = RS.fields(10) ' 11  X_11     Testo   50
        Dx(R, 12) = RS.fields(11) ' 12  X_12     Testo   50
        Dx(R, 13) = RS.fields(12) ' 13  X_13     Testo   50
        Dx(R, 14) = RS.fields(13) ' 14  X_14     Testo   50
        Dx(R, 15) = RS.fields(14) ' 15  X_15     Testo   50
        Dx(R, 16) = RS.fields(15) ' 16  X_16     Testo   50
        Dx(R, 17) = RS.fields(16) ' 17  X_17     Testo   50
        Dx(R, 18) = RS.fields(17) ' 18  X_18     Testo   50
        Dx(R, 19) = RS.fields(18) ' 19  X_19     Testo   50
        Dx(R, 20) = RS.fields(19) ' 20  X_20     Testo   50
        Dx(R, 21) = RS.fields(20) ' 21  X_21     Testo   50
        Dx(R, 22) = RS.fields(21) ' 22  X_22     Testo   50
        Dx(R, 23) = RS.fields(22) ' 23  X_23     Testo   50
        Dx(R, 24) = RS.fields(23) ' 24  X_24     Testo   50
        Dx(R, 25) = RS.fields(24) ' 25  X_25     Testo   50
        Dx(R, 26) = RS.fields(25) ' 26  X_26     Testo   50
        Dx(R, 27) = RS.fields(26) ' 27  X_27     Testo   50
        Dx(R, 28) = RS.fields(27) ' 28  X_28     Testo   50
        Dx(R, 29) = RS.fields(28) ' 29  X_29     Testo   50
        Dx(R, 30) = RS.fields(29) ' 30  X_30     Testo   50
        Dx(R, 31) = RS.fields(30) ' 31  X_31     Testo   50
        Dx(R, 32) = RS.fields(31) ' 32  X_32     Testo   50
        Dx(R, 33) = RS.fields(32) ' 33  X_33     Testo   50
        Dx(R, 34) = RS.fields(33) ' 34  X_34     Testo   50
        Dx(R, 35) = RS.fields(34) ' 35  X_35     Testo   50
        Dx(R, 36) = RS.fields(35) ' 36  X_36     Testo   50
        Dx(R, 37) = RS.fields(36) ' 37  X_37     Testo   50
        Dx(R, 38) = RS.fields(37) ' 38  X_38     Testo   50
        Dx(R, 39) = RS.fields(38) ' 39  X_39     Testo   50
        Dx(R, 40) = RS.fields(39) ' 40  X_40     Testo   50
        Dx(R, 41) = RS.fields(40) ' 41  X_41     Testo   50
        Dx(R, 42) = RS.fields(41) ' 42  X_42     Testo   50
        Dx(R, 43) = RS.fields(42) ' 43  X_43     Testo   50
        Dx(R, 44) = RS.fields(43) ' 44  X_44     Testo   50
        Dx(R, 45) = RS.fields(44) ' 45  X_45     Testo   50
        Dx(R, 46) = RS.fields(45) ' 46  X_46     Testo   50
        Dx(R, 47) = RS.fields(46) ' 46  X_47     Testo   50
        Dx(R, 48) = RS.fields(47) ' 47  X_48     Testo   50
        Dx(R, 49) = RS.fields(48) ' 48  X_49     Testo   50
        Dx(R, 50) = RS.fields(49) ' 49  X_50     Testo   50
        Dx(R, 50) = LL(Dx(R, 50), 14)
        For X = 3 To 45
            Dx(R, X) = UTF(Dx(R, X))
        Next X
        RS.MoveNext
    Next R
Else
    Esempio_Leggi_Bonifici_XML = False
    Exit Function
End If
Esempio_Leggi_Bonifici_XML = True
End Function


Public Function UTF(ByVal T As String) As String
'Attenzione il simbolo ° da errore
T = Replace(T, "&", "e") ' Asc(38)
T = Replace(T, "<", " ") ' Asc(60)
T = Replace(T, ">", " ") ' Asc(62)
T = Replace(T, Chr$(34), " ") ' Asc(34)
T = Replace(T, "'", " ") ' Asc(39)
T = Replace(T, """, " ") ' Asc(147)
T = Replace(T, """, " ") ' Asc(148)
T = Replace(T, "à", "a") ' Asc(224)
T = Replace(T, "á", "a") ' Asc(225)
T = Replace(T, "é", "e") ' Asc(233)
T = Replace(T, "è", "e") ' Asc(232)
T = Replace(T, "ì", "i") ' Asc(236)
T = Replace(T, "í", "i") ' Asc(237)
T = Replace(T, "ò", "o") ' Asc(242)
T = Replace(T, "ó", "o") ' Asc(243)
T = Replace(T, "ù", "u") ' Asc(249)
T = Replace(T, "ú", "u") ' Asc(250)
T = Replace(T, "°", " ") ' Asc(176)
T = Replace(T, "£", "L") ' Asc(163)
T = Replace(T, "?", "EUR") ' Asc(128)
T = Replace(T, "ç", "c") ' Asc(231)
T = Replace(T, "§", " ") ' Asc(167)
T = Replace(T, "Ø", "D.") ' Asc(216)
T = Replace(T, "z", "z") ' Asc(158)
T = Replace(T, "ö", "o") ' Asc(246)
T = Replace(T, "ß", "B") ' Asc(223)
T = Replace(T, "ä", "a") ' Asc(228)
T = Replace(T, "â", "a") ' Asc(226)
T = Replace(T, "Ñ", "N") ' Asc(209)
T = Replace(T, "Ö", "O") ' Asc(214)
T = Replace(T, "É", "E") ' Asc(201)
T = Replace(T, "Ü", "U") ' Asc(220)
T = Replace(T, "Ä", "A") ' Asc(196)
T = Replace(T, "Â", "A") ' Asc(194)
UTF = T
End Function


Function LeggiFileASCII(PathOrigine As String) As String
Dim sTextLine As String, lRestoFile As Long
Dim nFileOrigine As Integer
Dim lDimensioneFile As Long, lCounter As Long
Dim Testo As String
   On Error GoTo LeggiFileASCII_Error

nFileOrigine = FreeFile
Open PathOrigine For Binary As #nFileOrigine ' Apre il file.
' imposto variabili base
lCounter = 1
lDimensioneFile = LOF(nFileOrigine)
sTextLine = String(4000, ".") '
' restituisce la dimensione restante dopo tutti i
' blocchi di byte
lRestoFile = lDimensioneFile - Int(lDimensioneFile / 4000) * 4000
Do While Not EOF(nFileOrigine) ' Ripete fino alla fine del file.
     sTextLine = String(4000, ".") '
     If lCounter < Int(lDimensioneFile / 4000) * 4000 Then
         ' leggo e copio blocco dati
         ' BLOCCO INTERO
         Get #nFileOrigine, lCounter, sTextLine
         lCounter = lCounter + 4000
         Testo = Testo & sTextLine
     Else
        ' reimposto txtline sui bytes restanti
        ' BLOCCO ULTIMO PARZIALE
         sTextLine = String(lRestoFile, ".")
         Get #nFileOrigine, lCounter, sTextLine
         Testo = Testo & sTextLine
         Exit Do
     End If
Loop
If InStr(Testo, Chr(26)) > 0 Then 'Aggiunto per files creati con clipper
    Testo = Left(Testo, InStr(Testo, Chr(26)) - 1)
End If
Close #nFileOrigine    ' Chiude il file.
LeggiFileASCII = Testo

   On Error GoTo 0
   Exit Function

LeggiFileASCII_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & _
        ") in procedure LeggiFileASCII of Modulo Proc_Memo"
End Function


Public Sub ScriviFileASCII(PathDestinazione As String, TestoFile As String)
    If Dir(PathDestinazione) <> "" Then Kill PathDestinazione
    Dim nFileDestinazione As Integer
    nFileDestinazione = FreeFile
    ' APRO  FILE DI DESTINAZIONE
    Open PathDestinazione For Binary Access Write As #nFileDestinazione ' 
Apre il file.
    Put #nFileDestinazione, , TestoFile
    Close #nFileDestinazione
End Sub


Public Function TestoNetto(ByVal TestoMemo As String) As String
Ricicla:
If Right(TestoMemo, 2) = vbCrLf Then
    TestoMemo = Left(TestoMemo, Len(TestoMemo) - 2)
    GoTo Ricicla
End If
TestoNetto = TestoMemo
End Function


Public Function MemoLines(ilTesto As String) As Single
' Ritorna il numero di righe in una stringa
Dim VarVariant As Variant
VarVariant = Split(ilTesto, vbCrLf)
MemoLines = (UBound(VarVariant) - LBound(VarVariant)) + 1
End Function


Public Function MemoLine(ilTesto As String, QualeRiga As Variant) As String
' Ritorna la stringa corrispondente alla riga voluta
If Len(ilTesto) < 1 Then
    MemoLine = ""
    Exit Function
End If
Dim VarVariant As Variant
VarVariant = Split(ilTesto, vbCrLf)
MemoLine = VarVariant(QualeRiga - 1)
End Function


Public Function Str_Importo(Impor As Double) As String
Dim Rit As String
If DoubleZero(Impor) Then
    Str_Importo = "0"
    Exit Function
End If
Rit = Trim(Vir(Impor, 15, 2))
If Right(Rit, 3) = ",00" Then
    Rit = Left(Rit, Len(Rit) - 3)
Else
    If Right(Rit, 1) = "0" Then
        Rit = Left(Rit, Len(Rit) - 1)
    End If
End If
Str_Importo = Replace(Rit, ",", ".")
End Function


Public Function AAAA_MM_GG(UnaData As Date) As String
Dim Rit As String
Rit = Format(UnaData, "yyyy/mm/dd")
AAAA_MM_GG = Replace(Rit, "/", "-")
End Function


Public Function Adesso() As String
Dim AA As String
AA = STRZero(Year(Date), 4)
Adesso = Right(AA, 2) & STRZero(Month(Date), 2) & STRZero(Day(Date), _
    2) & STRZero(Hour(Time()), 2) & STRZero(Minute(Time()), _
    2) & STRZero(Second(Time()), 2)
End Function

Back to it.comp.lang.visual-basic | Previous | Next — Previous in thread | Next in thread | Find similar

Thread

RIBA in formato xml iso 20022 sal21 <gss.italy@iol.it> - 2020-03-15 11:36 -0700
  Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-17 13:20 +0100
    Re: RIBA in formato xml iso 20022 RobertoA <amorosik@tiscalinet.it> - 2020-03-17 13:57 +0100
      Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-18 17:50 +0100
        Re: RIBA in formato xml iso 20022 sal21 <gss.italy@iol.it> - 2020-03-18 10:44 -0700
      Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 11:58 +0100
        Re: RIBA in formato xml iso 20022 RobertoA <amorosik@tiscalinet.it> - 2020-03-19 14:10 +0100
          Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 17:41 +0100
          Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-20 08:48 +0100
      Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 12:06 +0100
      Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 12:07 +0100
        Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 13:06 +0100
    Re: RIBA in formato xml iso 20022 sal21 <gss.italy@iol.it> - 2020-03-17 08:24 -0700
      Re: RIBA in formato xml iso 20022 Greg <greg@alicie.com> - 2020-03-17 20:44 +0100
  Re: RIBA in formato xml iso 20022 sal21 <gss.italy@iol.it> - 2020-03-17 14:38 -0700
    Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 11:53 +0100
    Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 18:25 +0100
      Re: RIBA in formato xml iso 20022 sal21 <gss.italy@iol.it> - 2020-03-19 13:32 -0700
    Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 18:25 +0100
    Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-19 18:26 +0100
    Re: RIBA in formato xml iso 20022 "Sauro" <vicchi@crsscala.it> - 2020-03-18 17:51 +0100

csiph-web