VB6 Quellcode ändern

Option Explicit
'Dieses Programm fügt in eine einzeilige XML-Datei Zeileinumbrüche ein  


Dim Speed As Long
Dim Rechnername As String
Dim ViewModus As Boolean
Dim Rechner As String
Dim SourceDir(1) As String
Dim TargetDir(1) As String
Dim Erledigt(1) As String

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As Any, ByVal lpParameters As Any, ByVal lpDirectory As Any, ByVal nShowCmd As Long) As Long  

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)  

Private Sub VerzeichnisAuslesen(i As Byte)
Dim v As Long
Dim cFile As String
    lstXMLsource(i).Clear
    v = 0
    cFile = Dir(SourceDir(i) & "*.XML") ' Alle Textdateien im Quellverzeichnis ausgeben  
    Do While cFile <> "" And v < 1000 ' Wiederholen bis cFile=""  
        lstXMLsource(i).AddItem (cFile)
        v = v + 1
        cFile = Dir ' Aufruf der Funktion ohne Parameter!!  
    Loop
    lblSource(i).Caption = SourceDir(i) & " - " & lstXMLsource(i).ListCount & " Dateien"  
    v = 0
    lstXMLtarget(i).Clear
    cFile = Dir(TargetDir(i) & "*.XML") ' Alle Textdateien im Zielverzeichnis ausgeben  
    Do While cFile <> "" And v < 1000 ' Wiederholen bis cFile=""  
        lstXMLtarget(i).AddItem (cFile)
        v = v + 1
        cFile = Dir ' Aufruf der Funktion ohne Parameter!!  
    Loop
    lblTarget(i).Caption = TargetDir(i) & " - " & lstXMLtarget(i).ListCount & " Dateien"  
    'lblAlt(i).Caption = "erledigt - " & lstXMLalt(i).ListCount & " Dateien"  
    v = 0
    lstXMLalt(i).Clear
    cFile = Dir(Erledigt(i) & "*.XML") ' Alle Textdateien im Zielverzeichnis ausgeben  
    Do While cFile <> "" And v < 1000 ' Wiederholen bis cFile=""  
        lstXMLalt(i).AddItem (cFile)
        v = v + 1
        cFile = Dir ' Aufruf der Funktion ohne Parameter!!  
    Loop
    lblAlt(i).Caption = Erledigt(i) & " - " & lstXMLalt(i).ListCount & " Dateien"  
    
End Sub

Private Sub VerzeichnisVergleichen(l As Byte)
Dim i As Long
Dim j As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim konvertiert As Boolean

konvertiert = False
    For i = 0 To lstXMLsource(l).ListCount - 1
        a = lstXMLsource(l).ListCount - 1
        b = lstXMLalt(l).ListCount - 1
        If b - a < a Then
            c = 0
        Else
            c = b - a
        End If
        For j = c To lstXMLalt(l).ListCount - 1
            If lstXMLsource(l).List(i) = lstXMLalt(l).List(j) Then konvertiert = True
        Next j
        If konvertiert = False Then
            XML_umwandeln lstXMLsource(l).List(i), l
            konvertiert = False
        Else
            konvertiert = False
        End If
    Next i
End Sub

Private Sub XML_umwandeln(XML_Datei As String, m As Byte)
Dim Datei2 As String
Dim Datei3 As String
Dim Datei4 As String
Dim Datei5 As String
Dim StrAusgabe As String
Dim StrA As String
Dim Erkennen As Boolean
Dim i As Long
Dim j As Long
Dim k As Byte
Dim l As Byte
Dim n As Byte
Dim Zust800 As Boolean
Dim Zeichen(10000000) As String

On Error GoTo EX
    StrAusgabe = ""  
    StrA = ""  
    Datei2 = SourceDir(m) & XML_Datei
    Datei3 = TargetDir(m) & XML_Datei
    Datei4 = Erledigt(m) & XML_Datei
    Datei5 = "C:\ErpInterface\COP.bat"  
    'lstXMLalt(m).AddItem (XML_Datei)  
    i = 0
    Zust800 = False
    Open Datei2 For Input As #2
        Do While Not EOF(2)    'Schleife bis Dateiende.  
           Line Input #2, Zeichen(i)
           i = i + 1
        Loop
    Close #2

    If i > 1 Then               'Wenn XML-Datei aus mehr als einer Zeile besteht, wird sie so wieder ausgegeben  
        'Open Datei3 For Output As #3  
        Open Datei4 For Output As #4
            For j = 0 To i
                'Print #3, Zeichen(j)  
                Print #4, Zeichen(j)
            Next j
        'Close #3  
        Close #4
    Else
        j = Len(Zeichen(0))
        If chk800.Value = 1 Then
            For i = 1 To j
                If Mid(Zeichen(0), i, 4) = "T" & Chr$(34) & ">8" Then  
                    Zust800 = True
                End If
            Next i
        End If
        Erkennen = True         '=> Suche nach einem neunen Erkennung String "<XYZ "  
        'If Zust800 = False Then Open Datei3 For Output As #3  
        Open Datei4 For Output As #4
        If Zust800 = True Then
            Print #4,
            Print #4,
            Print #4, "<! ! ! ! !         Pruefmittel, nicht importiert              ! ! ! ! !>"  
            Print #4,
            Print #4,
        End If
            For i = 1 To j
                StrAusgabe = StrAusgabe & Mid(Zeichen(0), i, 1)
                If Erkennen = True Then StrA = StrA & Mid(Zeichen(0), i, 1)
                If Mid(Zeichen(0), i, 1) = "<" Then  
                    StrA = ""  
                    Erkennen = True
                End If
                If Mid(Zeichen(0), i, 1) = " " Then  
                    k = Len(StrA)
                    Erkennen = False
                End If
                If Erkennen = False And Mid(Zeichen(0), i, 1) = "<" And Mid(Zeichen(0), i, 2) <> "</" Then  
                    Erkennen = True
                End If
     
                If i > 5 Then
                    If Mid(Zeichen(0), i - 1, 2) = "?>" _  
                       Or Mid(Zeichen(0), i, 2) = "><" And Mid(Zeichen(0), i + 2, 1) <> "/" _  
                       Or (Mid(Zeichen(0), i, 1) = ">" And Erkennen = True) _  
                       And (Mid(Zeichen(0), i - 5, 6) <> "sCode>" And i > 11) _  
                       And (Mid(Zeichen(0), i - 5, 6) <> "ssage>" And i > 11) Then  
                       If chkGew.Value = 1 And Left(StrAusgabe, 4) = "<gew" Then  
                        For n = 30 To 40
                            If Mid(StrAusgabe, n, 1) = "<" Then  
                                'alles ok, String kann ganz normal geschrieben werden  
                                'If Zust800 = False Then Print #3, StrAusgabe  
                                Print #4, StrAusgabe
                                Exit For
                            End If
                            If Mid(StrAusgabe, n, 1) = "E" Then  
                                'Gewicht wird auf NULL gesetzt  
                                '<gewicht FIELDNAME="NFT_FLO0">8.4E-05</gewicht>  
                                '123456789012345678901234567890  
                                'If Zust800 = False Then Print #3, "<gewicht FIELDNAME=" & Chr$(34) & "NFT_FLO0" & Chr$(34) & ">0</gewicht>"  
                                Print #4, "<gewicht FIELDNAME=" & Chr$(34) & "NFT_FLO0" & Chr$(34) & ">0</gewicht>"  
                                Exit For
                            End If
                        Next n
                       Else
                        'If Zust800 = False Then Print #3, StrAusgabe  
                        Print #4, StrAusgabe
                       End If
                        StrAusgabe = ""  
                        Erkennen = False
                    End If
                End If
            Next i
        'f Zust800 = False Then Close #3  
        Close #4
    End If
If Zust800 = False Then Shell "cmd /c copy " & Datei4 & " " & Datei3, vbHide  
Exit Sub
EX:
Close #2
'Close #3  
Close #4
End Sub

Private Sub cmdChangeDir_Click()
        If SourceDir(0) = Rechner & "\ErpInterface\PDMRequest\" Then  
            SourceDir(0) = Rechner & "\ErpInterface\ERPRequestResponse\"  
            TargetDir(0) = Rechner & "\ErpInterface\TSRequestResponse\"  
        Else
            SourceDir(0) = Rechner & "\ErpInterface\PDMRequest\"  
            TargetDir(0) = Rechner & "\ErpInterface\TSRequest\"  
        End If
        lblSource(0).Caption = SourceDir(0)
        lblTarget(0).Caption = TargetDir(0)
        lstXMLalt(0).Clear
        lstXMLsource(0).Clear
        lstXMLtarget(0).Clear
End Sub

Private Sub cmdDELA_Click(Index As Integer)
On Error GoTo EX
    If Index = 0 Then Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide  
    If Index = 1 Then Shell "cmd /c del /Q " & TargetDir(0) & "*.*", vbHide  
    If Index = 2 Then Shell "cmd /c del /Q " & Erledigt(0) & "*.*", vbHide  
    If Index = 3 Then Shell "cmd /c del /Q " & SourceDir(1) & "*.*", vbHide  
    If Index = 4 Then Shell "cmd /c del /Q " & TargetDir(1) & "*.*", vbHide  
    If Index = 5 Then Shell "cmd /c del /Q " & Erledigt(1) & "*.*", vbHide  
Exit Sub
EX:
End Sub

Private Sub cmdDELM_Click(Index As Integer)
    Dim i As Long
On Error GoTo EX
    If Index = 0 Then
        For i = 0 To lstXMLsource(0).ListCount - 1
            If lstXMLsource(0).Selected(i) Then
                lstXMLsource(0).RemoveItem (i)
                Shell "cmd /c del /Q " & SourceDir(0) & lstXMLsource(0).List(i)  
                Exit For
            End If
        Next i
    End If
    If Index = 1 Then
        For i = 0 To lstXMLtarget(0).ListCount - 1
            If lstXMLtarget(0).Selected(i) Then
                lstXMLtarget(0).RemoveItem (i)
                Shell "cmd /c del /Q " & TargetDir(0) & lstXMLtarget(0).List(i)  
                Exit For
            End If
        Next i
    End If
    If Index = 2 Then
        For i = 0 To lstXMLalt(0).ListCount - 1
            If lstXMLalt(0).Selected(i) Then
                lstXMLalt(0).RemoveItem (i)
                Shell "cmd /c del /Q " & Erledigt(0) & lstXMLalt(0).List(i)  
                Exit For
            End If
        Next i
    End If
    
    If Index = 3 Then
        For i = 0 To lstXMLsource(1).ListCount - 1
            If lstXMLsource(1).Selected(i) Then
                lstXMLsource(1).RemoveItem (i)
                Shell "cmd /c del /Q " & SourceDir(1) & lstXMLsource(1).List(i)  
                Exit For
            End If
        Next i
    End If
    If Index = 4 Then
        For i = 0 To lstXMLtarget(1).ListCount - 1
            If lstXMLtarget(1).Selected(i) Then
                lstXMLtarget(1).RemoveItem (i)
                Shell "cmd /c del /Q " & TargetDir(1) & lstXMLtarget(1).List(i)  
                Exit For
            End If
        Next i
    End If
    If Index = 5 Then
        For i = 0 To lstXMLalt(1).ListCount - 1
            If lstXMLalt(1).Selected(i) Then
                lstXMLalt(1).RemoveItem (i)
                Shell "cmd /c del /Q " & Erledigt(1) & lstXMLalt(1).List(i)  
                Exit For
            End If
        Next i
    End If
Exit Sub
EX:
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub VerzeichnisseLoeschen()
On Error GoTo EX
    If frmDelDir.chkDEL(0).Value = 1 Then Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide  
    If frmDelDir.chkDEL(1).Value = 1 Then Shell "cmd /c del /Q " & TargetDir(0) & "*.*", vbHide  
    If frmDelDir.chkDEL(2).Value = 1 Then Shell "cmd /c del /Q " & Erledigt(0) & "*.*", vbHide  
    If frmDelDir.chkDEL(3).Value = 1 Then Shell "cmd /c del /Q " & SourceDir(1) & "*.*", vbHide  
    If frmDelDir.chkDEL(4).Value = 1 Then Shell "cmd /c del /Q " & TargetDir(1) & "*.*", vbHide  
    If frmDelDir.chkDEL(5).Value = 1 Then Shell "cmd /c del /Q " & Erledigt(1) & "*.*", vbHide  
Exit Sub
EX:
End Sub

'Private Sub lstXMLalt_Click(Index As Integer)  
'Dim i As Long  
'Dim Datei As String  
'Dim Info As String  
'On Error GoTo EX  
'If Index = 0 Then  
'    For i = 0 To lstXMLalt(Index).ListCount - 1  
'        If lstXMLalt(Index).Selected(i) Then  
'            Datei = Left(lstXMLalt(Index).List(i), 40)  
'            Datei = Erledigt(Index) & Datei  
'        End If  
'    Next i  
'    Open Datei For Input As #2  
'        Do While Not EOF(2)    'Schleife bis Dateiende.  
'           Line Input #2, Info  
'        Loop  
'    Close #2  
'End If  
'Exit Sub  
'EX:  
'End Sub  

Private Sub lstXMLalt_DblClick(Index As Integer)
Dim i As Long
Dim Datei As String
On Error GoTo EX
For i = 0 To lstXMLalt(Index).ListCount - 1
    If lstXMLalt(Index).Selected(i) Then
        Datei = Left(lstXMLalt(Index).List(i), 40)
        ShellExecute Me.hWnd, "Open", Erledigt(Index) & Datei, "", App.Path, 1  
    End If
Next i
Exit Sub
EX:
End Sub

Private Sub lstXMLsource_dblClick(Index As Integer)
Dim i As Long
Dim Datei As String
On Error GoTo EX
For i = 0 To lstXMLsource(Index).ListCount - 1
    If lstXMLsource(Index).Selected(i) Then
        Datei = (Left(lstXMLsource(Index).List(i), 40))
        'ShellExecute Me.hWnd, "Open", SourceDir(Index) & lstXMLsource(Index).List(i), "", App.Path, 1  
        ShellExecute Me.hWnd, "Open", SourceDir(Index) & Datei, "", App.Path, 1  
        'MsgBox (SourceDir(Index) & Datei)  
    End If
Next i
Exit Sub
EX:
End Sub

Private Sub lstXMLtarget_dblClick(Index As Integer)
Dim i As Long
Dim Datei As String
On Error GoTo EX
For i = 0 To lstXMLtarget(Index).ListCount - 1
    If lstXMLtarget(Index).Selected(i) Then
        Datei = Left(lstXMLtarget(Index).List(i), 40)
        ShellExecute Me.hWnd, "Open", TargetDir(Index) & Datei, "", App.Path, 1  
    End If
Next i
Exit Sub
EX:
End Sub

Private Sub tmrXML_Timer()
    VerzeichnisAuslesen 0
    If ViewModus = False Then VerzeichnisVergleichen 0
    VerzeichnisAuslesen 1
    If ViewModus = False Then VerzeichnisVergleichen 1
End Sub

Private Sub Form_Load()
    
    ViewModus = False
    Rechnername = Environ("COMPUTERNAME")  

    'Rechnername = "S05"      'Zum Testen um S05 vorzuspielen  
    frmXML2CRLF.Caption = frmXML2CRLF.Caption & "    Rechner: " & Rechnername  
    
    If Command() = "v" Or Command() = "V" Or Rechnername <> "S05" Then  
        ViewModus = True
        MsgBox ("Das Programm läuft nur im View-Modus!")  
        frmXML2CRLF.Caption = frmXML2CRLF.Caption & "    ! View Modus !"  
        Speed = 10000    'Timer 10 Sekunden  
        txtSpeed.Text = Speed
    Else
        Speed = 2500    'Timer 2,5 Sekunden  
        txtSpeed.Text = Speed
        If App.PrevInstance = True And Rechnername = "S05" Then  
            'MsgBox ("Das Programm läuft nur im View-Modus!")  
            End
        End If
    End If
    
    Rechner = "C:"        'Zum Testen ohne Netz  
    'Rechner = "\\s05"    'Echteinstellung  
    
    SourceDir(0) = Rechner & "\ErpInterface\PDMRequest\"  
    TargetDir(0) = Rechner & "\ErpInterface\TSRequest\"  
    Erledigt(0) = Rechner & "\ErpInterface\OKRequest\"  
    SourceDir(1) = Rechner & "\ErpInterface\ERPRequestResponse\"  
    TargetDir(1) = Rechner & "\ErpInterface\TSRequestResponse\"  
    Erledigt(1) = Rechner & "\ErpInterface\OKRequestResponse\"  
    
    lblSource(0).Caption = SourceDir(0)
    lblTarget(0).Caption = TargetDir(0)
    lblSource(1).Caption = SourceDir(1)
    lblTarget(1).Caption = TargetDir(1)
    
'    If Command() = "d" Or Command() = "D" Or ViewModus = False Then  
'        frmXML2CRLF.Visible = True  
'        'VerzeichnisseLoeschen  
'    End If  
    tmrXML.Interval = Speed

End Sub