Option Explicit
    Dim Datei As String
    Dim counter As Integer
    Dim input_v As String
    Dim i As Long
    Dim sMsg As String
    Dim RS As ADODB.Recordset
    Private Fnr As Long
    Private Fnr2 As Long
    Private Fnr3 As Long
    Private test As Long
    Private Cn As ADODB.Connection
 
 
Private Sub Form_Load()
 
    On Error GoTo ErrHandle
 
    Set Cn = New ADODB.Connection
    With Cn
        .Provider = "SQLOLEDB.1"
    '    SQL Server
        .Properties("Data Source") = "sql100"
    '    SQL Datenbank
        .Properties("Initial Catalog") = "sms_rz4"
    '    Useranmeldung
        .Properties("User ID") = "vb"
    '    Userpasswort
        .Properties("Password") = "1520"
    '   .Properties("Integrated Security") = "SSPI"
        .CursorLocation = adUseClient
        .Open
    End With
 
    Set RS = New ADODB.Recordset
    With RS
        Set .ActiveConnection = Cn
        .CursorLocation = adUseClient
        .CursorType = adOpenForwardOnly
        .LockType = adLockOptimistic
        .Source = "SELECT Resource_Names0 " & _
                  "FROM dbo.System_Resource_N_ARR " & _
                  "WHERE (Resource_Names0 LIKE '%x%') OR " & _
                        "(Resource_Names0 BETWEEN 's00' AND 's99') OR " & _
                        "(Resource_Names0 BETWEEN 'w00' AND 'w99') OR " & _
                        "(Resource_Names0 BETWEEN 'z00' AND 'z99');"
        .Open Options:=adCmdText
 
        sMsg = .GetString(adClipString, , ";", vbNewLine, vbNullString)
 
        .Close
    End With
    Set RS = Nothing
 
    If Len(sMsg) <> 0 Then
        i = FreeFile
        Open "d:\Abfrage.txt" For Binary Access Write As #i
        Put #i, , sMsg
        Close #i
    End If
 
Ende:
    If Not (RS Is Nothing) Then
        If RS.State = adStateOpen Then
            RS.Close
        End If
 
        Set RS = Nothing
    End If
 
    If Not (Cn Is Nothing) Then
        If Cn.State = adStateOpen Then
            Cn.Close
        End If
 
        Set Cn = Nothing
    End If
 
    Exit Sub
 
ErrHandle:
    sMsg = "Es sind Fehler aufgetreten: " & vbNewLine & vbNewLine
    With Cn
        For i = 0 To .Errors.Count - 1
            sMsg = sMsg & .Errors(i).Description & vbNewLine
        Next i
        .Errors.Clear
    End With
    MsgBox sMsg, vbCritical, "Datenbankfehler"
    Resume Ende
 
End Sub
 
Private Sub Timer1_Timer()
    If counter < 4 Then
    counter = counter + 1
Else
       If Not EOF(Fnr) Then
       '   EOF noch nicht erreicht, weitere Zeile aus der Datei auslesen
       Line Input #Fnr, input_v
 
 
       Text2.Text = input_v
 
       '   Abgearbeite Rechner anzeigen in einem Textfeld
       With Text3
       .SelStart = Len(.Text)
       .SelLength = 1
       .SelText = input_v & vbNewLine
       End With
 
       Shell ("C:\Windows\system32\xcopy" & _
         "\\zfpsrv2\f$\Kleines_datenbankmodell\klinik\*.* \\" & input_v & _
         "\c$\klinik\*.* /d/s/e/f/c/h/y")
 
       Else
       '   Dateiende erreicht
           Timer1.Enabled = False
           MsgBox "Fertig", vbOKOnly Or vbInformation
       End If
 
counter = 0
End If
End Sub
Private Sub CommandButton1_Click()
 
    On Error GoTo Fehler
    counter = 0
 
       ' Datei öffnen
       Fnr = FreeFile
       Datei = "d:\Abfrage.txt"
       Open Datei For Input As #Fnr
       ' Sekunden zwischen den Events
       Timer1.Interval = 30000
Ende:
    Exit Sub
 
Fehler:
    Fnr = 0
    Timer1.Enabled = False
 
    MsgBox "Es trat ein Fehler beim Öffnen der" & _
           " Datei auf!", vbOKOnly Or vbCritical, "Problem"
    Resume Ende
 
    End Sub
 
Private Sub Command1_Click()
    Unload Me
End Sub