Jul 02, 2012 at 14:40:27 (UTC)

5886

VB 6 Quellcode ersetzen

Würde gern VB 6 Quellcode durch neuen Code ersetzen, so dass das Programm wieder funktioniert.
Bitte dringend um Hilfe!

Würde gern den Quellcode ersetzen, mit gleicher Funktion, das Formular frmdeldir existiert nicht mehr !!

Weiß nicht mehr weiter, eigentlich müsste man die exe an 5 Stellen nur durch S18 (statt S05) ersetzen.
Das geht nicht (schon mit Hexeditor probiert.)
Es handelt sich um den folgenden VB 6 Code, der wegen dieser Stelle niccht kompiliert werden kann:

Hab es schon mit ausklammern probiert, aber dann löscht das Programm am Ende nicht die Verzeichnisse:

' 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

Please also mark the comments that contributed to the solution of the article

Content-Key: 187356

Url: https://administrator.de/contentid/187356

Printed on: April 26, 2024 at 09:04 o'clock

27 Comments

Latest comment

Hallo lordofremixes!

Es werden ja doch nur 6 "Checkbox"-Steuerelemente geprüft - die solltest Du ja auch im bestehenden Formular nachbauen können ...

... und falls ohnehin immer alle Löschvorgänge ausgeführt werden sollen, könntest Du auch einfach nur die Abfragen weglassen und jeweils nur den Teil nach "Then" verwenden.

Grüße
bastla

Hallo bastla,

auf dich hab ich gewartet!
Ok, , das bringt mich schon weiter.
Also ist es ein altes Formular das nicht mehr benötigt wird.

Kann man das so machen?
Habe 4 Listboxen namens:

lstXMLsource(0)
lstXMLsource(1)
lstXMLtarget(0)
lstXMLtarget(1)

wenn in diesen etwas "drin" ist, sollen die dazugehörigen Verzeichnisse auch gelöscht werden.
Kann man dies auch umsetzen? Z.B. so?

Private Sub VerzeichnisseLoeschen()
On Error GoTo EX
If lstXMLsource(0).Value = 1 Then Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide  
If lstXMLtarget(0).Value = 1 Then Shell "cmd /c del /Q " & TargetDir(0) & "*.*", vbHide  
If lstXMLsource(1).Value = 1 Then Shell "cmd /c del /Q " & SourceDir(1) & "*.*", vbHide  
If lstXMLtarget(1)).Value = 1 Then Shell "cmd /c del /Q " & TargetDir(1) & "*.*", vbHide  
Exit Sub
EX:
End Sub

Gruß
lordofremixes

Das Formular heißt übrigens frmXML2CRLF
So?

If frmXML2CRLF.lstXMLsource(0).Value = 1 Then Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide
If frmXML2CRLF.lstXMLtarget(0).Value = 1 Then Shell "cmd /c del /Q " & TargetDir(0) & "*.*", vbHide
If frmXML2CRLF.lstXMLsource(1).Value = 1 Then Shell "cmd /c del /Q " & SourceDir(1) & "*.*", vbHide
If frmXML2CRLF.lstXMLtarget(1)).Value = 1 Then Shell "cmd /c del /Q " & TargetDir(1) & "*.*", vbHide

?

Hallo lordofremixes!

Bei einer Listbox sollte das eher so aussehen:

If frmXML2CRLF.lstXMLsource(0).Text = "1" Then Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide

Grüße
bastla

Hallo,

wird ausprobiert!
Benötigt man die Anführungszeichen bei der 1 ?

Gruß
lordofremixes

Hallo lordofremixes!

Benötigt man die Anführungszeichen bei der 1 ?

Ich würde sie nicht brauchen, aber der VB6-Interpreter/-Compiler könnte meinen, dass eine Eigenschaft "Text" auch einen Eigenschaftswert mit dem Typ "Text" hat ...

Grüße
bastla

Hallo bastla,

kompilieren geht, aber die Datei wird nicht gelöscht obwohl in der Listbox noch eine steht und auch im Ordner..
Ich glaube es liegt an der Reihenfolge des Codes?
Kann ich mal den letzten Teil des Quellcodes posten oder den ganzen?
Vielleicht siehst du gleich was da nicht stimmt...

Gruß
lordofremixes

Hallo lordofremixes!

obwohl in der Listbox noch eine steht und auch im Ordner..

Dem Satz fehlt etwas Entscheidendes ...

Quellcode posten sollte nicht verkehrt sein ...

Grüße
bastla

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 frmXML2CRLF.lstXMLsource(0).Text = "1" Then Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide  
If frmXML2CRLF.lstXMLtarget(0).Text = "1" Then Shell "cmd /c del /Q " & TargetDir(0) & "*.*", vbHide  
If frmXML2CRLF.lstXMLsource(1).Text = "1" Then Shell "cmd /c del /Q " & SourceDir(1) & "*.*", vbHide  
If frmXML2CRLF.lstXMLtarget(1).Text = "1" Then Shell "cmd /c del /Q " & TargetDir(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 = "S18"      'Zum Testen um S18 vorzuspielen  
    frmXML2CRLF.Caption = frmXML2CRLF.Caption & "    Rechner: " & Rechnername  
    
    If Command() = "v" Or Command() = "V" Or Rechnername <> "S18" 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 = "S18" Then  
            'MsgBox ("Das Programm läuft nur im View-Modus!")  
            End
        End If
    End If
    
    Rechner = "C:"        'Zum Testen ohne Netz  
    'Rechner = "\\S18"    '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

Hallo bastla,

noch eine xml datei steht und auch im Ordner!
Wenn du ein Bild vom Formular brauchst, würd ich dir ne pm schicken..

Gruß
lordofremixes

Hallo lordofremixes!

Wenn in der Listbox nicht "1" steht, ist es wenig sinnvoll, per "If" danach zu fragen - dann würde sich eher etwas in der Art anbieten:

If frmXML2CRLF.lstXMLsource(0).Text <> "" Then Shell "cmd /c del /Q " & frmXML2CRLF.lstXMLsource(0).Text, vbHide

Grüße
bastla

Hallo bastla,

genauso eingefügt. Aber in der Listbox steht noch die xml Datei, und im dazugehörigen Verzeichnis auch!

Das ist der angepasste Code.

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

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 frmXML2CRLF.lstXMLsource(0).Text <> "" Then Shell "cmd /c del /Q " & frmXML2CRLF.lstXMLsource(0).Text, vbHide  
 If frmXML2CRLF.lstXMLtarget(0).Text <> "" Then Shell "cmd /c del /Q " & frmXML2CRLF.lstXMLtarget(0).Text, vbHide  
 If frmXML2CRLF.lstXMLsource(1).Text <> "" Then Shell "cmd /c del /Q " & frmXML2CRLF.lstXMLsource(1).Text, vbHide  
 If frmXML2CRLF.lstXMLtarget(1).Text <> "" Then Shell "cmd /c del /Q " & frmXML2CRLF.lstXMLtarget(1).Text, 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 = "S18"      'Zum Testen um S18 vorzuspielen  
    frmXML2CRLF.Caption = frmXML2CRLF.Caption & "    Rechner: " & Rechnername  
    
    If Command() = "v" Or Command() = "V" Or Rechnername <> "S18" 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 = "S18" Then  
            'MsgBox ("Das Programm läuft nur im View-Modus!")  
            End
        End If
    End If
    
    Rechner = "C:"        'Zum Testen ohne Netz  
    'Rechner = "\\S18"    '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

Gruß
lordofremixes

Zitat von @bastla:

Hallo lordofremixes!

Wenn in der Listbox nicht "1" steht, ist es wenig sinnvoll, per "If" danach zu fragen - dann würde
sich eher etwas in der Art anbieten:

If frmXML2CRLF.lstXMLsource(0).Text <> "" Then Shell "cmd /c del /Q "
> & frmXML2CRLF.lstXMLsource(0).Text, vbHide
> 

Grüße
bastla

Macht Sinn!

Hallo lordofremixes!

Soferne in der Listbox nur der Name der Datei steht, müsste auch noch der Pfad rein - etwa:

If frmXML2CRLF.lstXMLsource(0).Text <> "" Then Shell "cmd /c del /Q " & SourceDir(0) & frmXML2CRLF.lstXMLsource(0).Text, vbHide

- abgesehen davon sehe ich beim Überfliegen des Codes keinen Aufruf von "VerzeichnisseLoeschen()" ...

Grüße
bastla

Hallo bastla,

werd ich sofort ausprobieren.
Ganz unten , ausgeklammert?
Hab mich schon gefragt warum das ganz unten ausgeklammert steht..

Gruß
lordofremixes

Hallo bastla,

Private Sub VerzeichnisseLoeschen()
Oder wird hier nur gesagt, dass es nur eine private Prozedur ist, die nur in dem Modul sichtbar ist, in dem sie steht?

Und wenn ja, wo muss der Aufruf dann stattfinden?

Gruß
lordofremixes

Hallo bastla!

genauso angepasst, versucht einen Aufruf ganz unten im Programm "VerzeichnisseLoeschen()" zu machen, Name in Listbox noch da, und Verzeichnis auch noch voll...

Gruß
lordofremixes

Hallo lordofremixes!

versucht einen Aufruf ganz unten im Programm "VerzeichnisseLoeschen()" zu machen

Soferne Du die Zeile 419 meinst, müsste natürlich noch der Apostroph am Anfang weg ...

Name in Listbox noch da

Da es keine "DirListBox" ist (und auch die müsste aktualisiert werden), überrascht das auch nicht weiter - wie ein Entfernen aus der Liste geht, siehst Du im "Sub cmdDELM_Click" ...

Um zu testen, ob ein bestimmtes Sub überhaupt aufgerufen wird, kannst Du übrigens als einfachste Möglichkeit eine Zeile der Art

MsgBox "Bin jetzt im Sub xyz"

gleich am Anfang (nach "Sub ...") verwenden (soferne Du die Debugging-Möglichkeiten der IDE nicht kennst) ...

Grüße
bastla

Hallo bastla,

den Aufruf habe ich unten gemacht. Es kommt Compile Error, Syntax Error..
genauso hab ichs drin:

    Rechner = "C:"        'Zum Testen ohne Netz  
    'Rechner = "\\S18"    '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

Dadurch kann ich auch den Aufruf MsgBox (in welchem Sub ich bin) nicht aufrufen.
Und muss ich, um die Dateien in der ListBox zu löschen so vorgehen:

Private Sub VerzeichnisseLoeschen(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 

?

Nochmal der ganze Code wie ich ihn jetzt gemacht hab:

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 frmXML2CRLF.lstXMLsource(0).Text <> "" Then Shell "cmd /c del /Q " & SourceDir(0) & frmXML2CRLF.lstXMLsource(0).Text, 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 = "S18"      'Zum Testen um S18 vorzuspielen  
    frmXML2CRLF.Caption = frmXML2CRLF.Caption & "    Rechner: " & Rechnername  
    
    If Command() = "v" Or Command() = "V" Or Rechnername <> "S18" 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 = "S18" Then  
            'MsgBox ("Das Programm läuft nur im View-Modus!")  
            End
        End If
    End If
    
    Rechner = "C:"        'Zum Testen ohne Netz  
    'Rechner = "\\S18"    '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

Gruß
lordofremixes

Hallo lordofremixes!

Lass beim Aufruf die Klammern weg ...

Und muss ich, um die Dateien in der ListBox zu löschen so vorgehen:

Ich hatte "Sub cmdDELM_Click" geschrieben - dort ist die Zeile

lstXMLsource(0).RemoveItem (i)

für das Entfernen des Eintrags aus der ListBox zuständig, wobei der aktuell gewählte Eintrag per

lstXMLsource(0).RemoveItem(ListIndex)

zu entfernen wäre (siehe dazu zB die Übersicht in Using ListBox and ComboBox Controls In Visual Basic 6) ...

Grüße
bastla

Hallo bastla,

heißt das ich benötige einen Sub für das Löschen der Listboxeinträge und einen für das Löschen der Dateien im Verzeichnis?
Und wieso muss das per Click Befehl gemacht werden? Das soll doch automatisch stattfinden, wenn die Dateien abgearbeitet sind?

Ich blick grad nichts mehr

heißt das den befehl lstXMLsource(0).RemoveItem (i) unter
Private Sub VerzeichnisseLoeschen()
On Error GoTo EX
lstXMLsource(0).RemoveItem (i)

Exit Sub
EX:
End Sub

Sorry dass ich so dooof bin!

Gruß
lordofremixes

Ich hab den Code jetzt so oft geändert, dass er glaub vorne und hinten nicht mehr stimmt.
Macht es was aus, wenn ich ihn wieder so öffne, dass er so wie vor ca. 6 Stunden war?
Oder ist dann die ganze Arbeit (wenn man das so nennen kann) dahin?

Hallo lordofremixes!

Macht es was aus, wenn ich ihn wieder so öffne, dass er so wie vor ca. 6 Stunden war?

Im Gegenteil - eigentlich ging es in der Ausgangsversion ja darum, ganze Ordnerinhalte (wenn die entsprechende CheckBox im inzwischen fehlenden Formular aktiviert war) zu löschen - insofern sollte es ja, wenn das Programm ansonsten funktioniert, tatsächlich genügen, wie schon am Anfang vorgeschlagen, die Auswertung dieser CheckBoxes einfach wegzulassen ...

Grüße
bastla

Lass beim Aufruf die Klammern weg ...

Das Kompilieren hat geklappt!!

Gruß
lordofremixes

Hallo lordofremixes!

Nochmals der Hinweis: "VerzeichnisseLoeschen" ist eigentlich gedacht, den Inhalt ganzer Ordner zu löschen - insofern solltest Du es nochmals mit der Ausgangsversion versuchen und ggf einfach anstatt

If frmDelDir.chkDEL(0).Value = 1 Then Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide

nur

Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide

schreiben - das Löschen einzelner Dateien sollte durch "cmdDELM_Click" erledigt werden ...

Grüße
bastla

Hallo bastla,

genauso gemacht , also alles resettet, Programm läuft wieder.

Also wie heute schon einmal probiert, den Code ersetzt:

Private Sub VerzeichnisseLoeschen()
 On Error GoTo EX
 Shell "cmd /c del /Q " & SourceDir(0) & "*.*", vbHide  
 Shell "cmd /c del /Q " & TargetDir(0) & "*.*", vbHide  
 Shell "cmd /c del /Q " & SourceDir(1) & "*.*", vbHide  
 Shell "cmd /c del /Q " & TargetDir(1) & "*.*", vbHide  

 Exit Sub
EX:
 End Sub

und unten im Programm
VerzeichnisseLoeschen

Ergebnis:
Programm wandelt die xml Datei um, aber im Verzeichnis wird nichts gelöscht und in der Listbox steht sie auch noch drin.

Gruß
lordofremixes

Nix für ungut, aber was für nen Krampf tust du dir hier gerade eigentlich an?
die VB-Api bietet eigenene Befehle fürs löschen an. such mal nach FSO(filesystemobjects)

http://www.freevbcode.com/ShowCode.asp?ID=1155

German Question VB for Applications Development

VB 6 Quellcode ersetzen

Würde gern VB 6 Quellcode durch neuen Code ersetzen, so dass das Programm wieder funktioniert.Bitte dringend um Hilfe!

Würde gern VB 6 Quellcode durch neuen Code ersetzen, so dass das Programm wieder funktioniert.
Bitte dringend um Hilfe!