Anzeige
Archiv - Navigation
812to816
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
812to816
812to816
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro anhalten bis Dos Befehl beendet

Makro anhalten bis Dos Befehl beendet
24.10.2006 16:24:57
Reinhard
Hallo Wissende,
ich fand hier Code zum Anhalten und habe den implentiert. Aber er funktioniert nicht.
Wenn ich in Folge nach "pad" "*pad*" "pad" "*pad*" ... suche so wird mir immer das Ergebnis der letzten Suche ausgegeben, obwohl in Suchen.bat die neue Suche drinsteht und der Inhalt von Suchen.txt auch aktuell ist.
DoEvent hat da rgendwie keinen Einfluß.
Anscheinend wird der Open-Befehl ausgeführt bevor Dos beendet hat *mutmaß*
Kann mir wer helfen das hinzukriegen? Danke
Sub Suchen()
Dim S, Datei As String, Zeile As String, Zei As Long, Start, Meldung As String
On Error GoTo Fehler
Range("A:C").ClearContents
Application.ScreenUpdating = False
Meldung = "Gesuchten Dateinamen oder Teile davon eingeben" & Chr(13)
Meldung = Meldung & "Stellervertreterzeichen ist das " & Chr(34) & "*" & Chr(34) & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "pad" & Chr(34) & " wird nur die Datei namens " & Chr(34) & "pad" & Chr(34) & " gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*pad" & Chr(34) & " wird z.B.: Pad, Autopad , Notpad usw. gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "pad*" & Chr(34) & " wird z.B.: pad, pad.exe, padanton.txt gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*pad*" & Chr(34) & " wird dann z.B. gefunden pad, notepad.exe Bootspaddel.txt usw."
Datei = InputBox(Meldung)
If Datei = "" Then Exit Sub
[A1] = "Start"
[A2] = "Ende"
[A3] = "Diff"
Start = Timer
[b1] = Timer
If Dir("c:\test2/nul") = "" Then MkDir "c:\test2"
Close
Open "c:\test2\Suchen.bat" For Output As #1
Print #1, "echo %1"
Print #1, "dir c:\" & Datei & " /s/b/-p > c:\test2\Suchen.txt"
Close #1
S = Shell("c:\test2\Suchen.bat " & Datei)
Do While IsActive
DoEvents
Sleep 250
Loop
Open "c:\test2\Suchen.txt" For Input As #1
'MsgBox LOF(1)
While Not EOF(1)
Zei = Zei + 1
Line Input #1, Zeile
Cells(Zei, 3) = Zeile
Wend
Close
[b2] = Timer
[B3] = [b2] - [b1]
'MsgBox Timer - Start & "Sekunden"
Fehler:
Application.ScreenUpdating = True
End Sub

Gruß
Reinhard

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Hier die Frage nochmal mit komplettem Code
24.10.2006 16:27:44
Reinhard
Hallo Wissende,
ich fand hier Code zum Anhalten und habe den implentiert. Aber er funktioniert nicht.
Wenn ich in Folge nach "pad" "*pad*" "pad" "*pad*" ... suche so wird mir immer das
Ergebnis der letzten Suche ausgegeben, obwohl in Suchen.bat die neue Suche drinsteht und
der Inhalt von Suchen.txt auch aktuell ist.
DoEvent hat da rgendwie keinen Einfluß.
Anscheinend wird der Open-Befehl ausgeführt bevor Dos beendet hat *mutmaß*
Kann mir wer helfen das hinzukriegen? Danke
Option Explicit
'Quelle -ActiveVB.de
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As _
Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Const STILL_ACTIVE = &H103
Const PROCESS_ALL_ACCESS = &H1F0FFF
Dim S&
Private Function IsActive() As Boolean
Dim Handle&, ExitCode&
Handle = OpenProcess(PROCESS_ALL_ACCESS, False, S)
Call GetExitCodeProcess(Handle, ExitCode)
Call CloseHandle(Handle)
IsActive = IIf(ExitCode = STILL_ACTIVE, True, False)
End Function
Sub Suchen()
Dim S, Datei As String, Zeile As String, Zei As Long, Start, Meldung As String
On Error GoTo Fehler
Range("A:C").ClearContents
Application.ScreenUpdating = False
Meldung = "Gesuchten Dateinamen oder Teile davon eingeben" & Chr(13)
Meldung = Meldung & "Stellervertreterzeichen ist das " & Chr(34) & "*" & Chr(34) & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "pad" & Chr(34) & " wird nur die Datei namens " & Chr(34) & "pad" & Chr(34) & " gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*pad" & Chr(34) & " wird z.B.: Pad, Autopad , Notpad usw. gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "pad*" & Chr(34) & " wird z.B.: pad, pad.exe, padanton.txt gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*pad*" & Chr(34) & " wird dann z.B. gefunden pad, notepad.exe Bootspaddel.txt usw."
Datei = InputBox(Meldung)
If Datei = "" Then Exit Sub
[A1] = "Start"
[A2] = "Ende"
[A3] = "Diff"
Start = Timer
[b1] = Timer
If Dir("c:\test2/nul") = "" Then MkDir "c:\test2"
Close
Open "c:\test2\Suchen.bat" For Output As #1
Print #1, "echo %1"
Print #1, "dir c:\" & Datei & " /s/b/-p > c:\test2\Suchen.txt"
Close #1
S = Shell("c:\test2\Suchen.bat " & Datei)
Do While IsActive
DoEvents
Sleep 250
Loop
Open "c:\test2\Suchen.txt" For Input As #1
'MsgBox LOF(1)
While Not EOF(1)
Zei = Zei + 1
Line Input #1, Zeile
Cells(Zei, 3) = Zeile
Wend
Close
[b2] = Timer
[B3] = [b2] - [b1]
'MsgBox Timer - Start & "Sekunden"
Fehler:
Application.ScreenUpdating = True
End Sub

Gruß
Reinhard
Anzeige
AW: Hier die Frage nochmal mit komplettem Code
24.10.2006 16:43:22
yps
hi Reinhard,
hier wird auch gewartet bis DOS fertig ist
das kannst du bestimmt anpassen

Sub pruefen()
For i = 1 To 10 'die ersten 10 zeilen der spalte A werden als ip oder rechnernamen genommen
Rechner = Worksheets("Tabelle1").Cells(i, 1).Value
ShellAndWait ("CMD.EXE /c " & "ping " & Rechner & " > C:\Test.txt")
Close #1
Open "c:\Test.txt" For Input As #1
Do While Not EOF(1)
Input #1, Textzeile
If Left(Textzeile, 4) = "Antw" Then Exit Do
Loop
If Left(Textzeile, 4) <> "Antw" Then
Worksheets("Tabelle1").Cells(i, 2).Value = "Mist nicht erreichbar"
Else
Worksheets("Tabelle1").Cells(i, 2).Value = "Juchuu erreichbar"
End If
Close #1
Kill "c:\Test.txt"
Next i
End Sub


Function ShellAndWait(FileName As String)
Dim objScript
Set objScript = CreateObject("WScript.Shell")
ShellApp = objScript.Run(FileName, 1, True)
ShellAndWait = True
End Function
#
cu Micha
Anzeige
AW: Hier die Frage nochmal mit komplettem Code
24.10.2006 17:31:09
Reinhard
Hallo Micha,
Danke dir.
Wenn ich mich hier nicht mehr melde funktioniert es *annehm*
Gruß
Reinhard

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige