Hallo Gerd,
ja aber dass 2 Zeilen zu 1 Zeile zusammengesetzt ist, kommt
vielleicht alle 100 Zeilen einmal vor, wenn überhaupt und
unser Programm übernimmt es genau so… das verstehst du
wirklich?
Ja, ich hab’s ja so geschrieben. 
Ich habe die Fehlerkorrektur jetzt mal eingebaut. Nachdem der Fehler so eindeutig beschrieben ist, war das nicht schwer.
Ich habe dazu einen kompletten Code von weiter oben kopiert und bearbeitet.
Bitte kopiere nicht den gesamten Code! Du hast inzwischen etwas geändert, nicht, daß Du das weg wirfst.
Ich markiere die geänderten Stellen fett, nur das sollst Du kopieren. Der restliche Code ist nur dazu da, daß Du weißt, was wo hin gehört.
Das sind zwei Stellen! Die einzelne Zeile, die die neue Prozedur aufruft, bitte nicht vergessen.
Gruß Rainer
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Dim objRS As ADODB.Recordset
Dim objConnection As ADODB.Connection
Dim Feld() As String
Dim Pfd() As String
Private Sub Befehl0\_Click()
Dim i As Integer
OpenDB
strSQL = "SELECT [Sds-task].\* FROM [Sds-task]"
OpenRS strSQL
Transfer "c:\server1\sds-task.lst"
Transfer "c:\server2\sds-task.lst"
Transfer "c:\server3\sds-task.lst"
Transfer "c:\server4\sds-task.lst"
objRS.Close
strSQL = "SELECT DISTINCT [Sds-task].[SDS-Typ], [Sds-task].[SDS-Name], [Sds-task].[CDS-ID], [Sds-task].Datum From [Sds-task] WHERE ((([Sds-task].[SDS-Typ]) Like 'allusers'));"
OpenRS strSQL
objRS.MoveFirst
ReDim Pfd(i)
While objRS.EOF = False
ReDim Preserve Pfd(i)
Pfd(i) = objRS("SDS-Name")
i = i + 1
objRS.Movenext
Wend
objRS.Close
objConnection.Close
Sync
End Sub
Private Sub Transfer(ByVal Datei As String)
Dim ff As Integer, Zl As String
Dim Fld() As String, i As Integer
ff = FreeFile
Open Datei For Input As #ff
While Not EOF(ff)
Line Input #ff, Zl
Fld = Split(Zl, " ")
objRS.AddNew
For i = 0 To 3
objRS(i) = Replace(Fld(i), """", "")
Next
objRS.Update
Wend
Close #ff
End Sub
Private Sub OpenDB()
Dim strSQL As String
Dim DB As String
DB = "c:\SDS.mdb"
Set objConnection = New ADODB.Connection
With objConnection
.CursorLocation = adUseClient
.Mode = adModeShareDenyNone
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = DB
.Open
End With
End Sub
Private Sub OpenRS(ByVal strSQL As String)
Set objRS = New ADODB.Recordset
With objRS
Set .ActiveConnection = objConnection
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Source = strSQL
Call .Open
End With
End Sub
Private Sub QuickSort(ByVal LB As Long, ByVal UB As Long)
Dim P1 As Long, P2 As Long, Ref As String, TEMP As String
P1 = LB
P2 = UB
Ref = Feld((P1 + P2) / 2)
Do
Do While (Feld(P1) Ref)
P2 = P2 - 1
Loop
If P1 P2)
If LB Zl Then
Tmp(n) = Feld(i)
n = n + 1
Zl = Feld(i)
End If
Next
ReDim Feld(n - 1)
For i = 0 To n - 1
Feld(i) = Tmp(i)
Next
End Sub
**Private Sub Repair()
Dim i As Long, Pos As Integer, Zl As String
For i = LBound(Feld) To UBound(Feld)
Zl = Feld(i)
Pos = InStr(1, Feld(i), """""")
If Pos 0 Then
Feld(i) = Left(Zl, Pos)
ReDim Preserve Feld(UBound(Feld) + 1)
Feld(UBound(Feld)) = Right(Zl, Len(Zl) - Pos)
End If
Next
End Sub**
Private Sub Sync()
Dim Txt As String, Daten As String
Dim i As Integer, c As Integer, ff As Integer, l As Long
Dim Server(3) As String, Pfad As String, Pos As Integer
Server(0) = "c:\Server1\"
Server(1) = "c:\Server2\"
Server(2) = "c:\Server3\"
Server(3) = "c:\Server4\"
ff = FreeFile
For i = LBound(Pfd) To UBound(Pfd)
Daten = ""
For c = 0 To 3
Pfad = Server(c) + Pfd(i) + ".yes"
If PathFileExists(Pfad) Then
l = FileLen(Pfad)
Txt = Space(l)
Open Pfad For Binary As #ff
Get #ff, , Txt
Close #ff
Daten = Daten + Txt
End If
Next
If Trim(Daten) "" Then
Feld = Split(Daten, vbCrLf)
**Repair**
QuickSort LBound(Feld), UBound(Feld)
Clean
Daten = Join(Feld, vbCrLf)
For c = 0 To 3
Pfad = Server(c) + Pfd(i) + ".yes"
Open Pfad For Output As #ff
Print #ff, Daten
Close #ff
Next
End If
Next
End Sub
