Gruppe
Datei
Problem
Eine in Zelle B1 stehende Anwendung soll auf dem aktiven Laufwerk gesucht werden.
StandardModule: basMain
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const WAIT_TIMEOUT = &H102&
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Sub DOSShell()
Application.ScreenUpdating = False
On Error Resume Next
ChDrive "c"
ChDir "c:\"
On Error GoTo 0
ShellAndWait ("command.com /c dir/s/b " & _
Range("B1").Value & " >" & _
Application.DefaultFilePath & "\dirliste.txt")
Workbooks.Open Application.DefaultFilePath & "\dirliste.txt"
If IsEmpty(Range("A1")) Then
Beep
MsgBox "AcrobatReader wurde nicht gefunden!"
Else
MsgBox "Pfad: " & Range("A1").Value
End If
ActiveWorkbook.Close savechanges:=False
End Sub
Sub ShellAndWait(strEXE As String)
Dim ProcessID As Long
Dim hProcess As Long
Dim RetVal As Long
ProcessID = Shell(strEXE, vbHide)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessID)
Do
DoEvents
RetVal = WaitForSingleObject(hProcess, 50)
Loop Until RetVal <> WAIT_TIMEOUT
End Sub