Sie sind aktuell nicht angemeldet.

Funktionen: Einloggen  |  Neu registrieren  |  Suchen

Dos
Autor: Hans
Datum: 19.11.01 14:54
Ich hab mal den Dos Aufruf ein wenig vebessert. Benötigt wird ein Textfeld ein Knopf und eine Listbox. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'zunächst die benötigten API-Deklarationen 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 WaitForSingleObject Lib _ "kernel32" (ByVal hHandle As Long, _ ByVal dwMilliseconds As Long) As Long Private Const INFINITE = &HFFFF Private Const SYNCHRONIZE = &H100000 'Warten bis Anwendung beendet Public Function AppStartAndWait(ByVal sFile As String, _ ByVal wStyle As VbAppWinStyle) 'Parameterbeschreibung 'sFile: Anwendung, die gestartet werden soll 'wStyle: Darstellungsart des Anwendungsfensters Dim lRetVal As Long Dim lHandle As Long Dim lRet As Long lRetVal = Shell(sFile, wStyle) If lRetVal <> 0 Then lHandle = OpenProcess(SYNCHRONIZE, 0, lRetVal) If lHandle <> 0 Then lRet = WaitForSingleObject(lHandle, INFINITE) CloseHandle (lHandle) End If End If End Function Private Sub Command1_Click() DoEvents List1.Clear Call AppStartAndWait("E:WINNTsystem32cmd.exe /c" & Text1.Text & " > C:TMPPing.TXT", vbHide) 'On Error GoTo FileError 'Do Until FileExists("C:TMPPing.TXT") = True ' Sleep 50 'Loop Dim Dateidaten Open "C:TMPPing.TXT" For Input As #1 ' Datei zum Einlesen öffnen. Do While Not EOF(1) ' Auf Dateiende abfragen. Line Input #1, Dateidaten ' Datenzeilen lesen. List1.AddItem Dateidaten ' Daten dem Listenfeld zuweisen. Loop Close #1 ' Datei schließen. Kill "C:TMPPing.TXT" If List1.List(n) = "" Then List1.AddItem "Befehl nicht gefunden." End If For m = 0 To List1.ListCount k = Replace(List1.List(m), "�", "ü") List1.List(m) = k k = "" k = Replace(List1.List(m), "”", "ö") List1.List(m) = k k = "" k = Replace(List1.List(m), "á", "ß") List1.List(m) = k k = "" k = Replace(List1.List(m), "„", "ä") List1.List(m) = k Next m Exit Sub 'FileError: ' If Timer - p < 20 Then 'Sekunden ' Resume ' Else ' MsgBox "Kein Kontakt!", vbInformation, "Fehler von Ping" ' End If End Sub Public Function FileExists(ByVal sFile As String) As Boolean 'Der Parameter sFile enthält den zu prüfenden Dateinamen Dim Size As Long On Local Error Resume Next Size = FileLen(sFile) FileExists = (Err = 0) On Local Error GoTo 0 End Function Public Function Replace(ByRef Text As String, _ ByRef sOld As String, ByRef sNew As String, _ Optional ByVal Start As Long = 1, _ Optional ByVal Count As Long = 2147483647, _ Optional ByVal Compare As _ VbCompareMethod = vbBinaryCompare) As String ' (c) Jost Schwider, VB-Tec.de If LenB(sOld) Then If Compare = vbBinaryCompare Then ReplaceBin Replace, Text, Text, _ sOld, sNew, Start, Count Else ReplaceBin Replace, Text, LCase$(Text), _ LCase$(sOld), sNew, Start, Count End If Else ' Suchstring ist leer: Replace = Text End If End Function Private Static Sub ReplaceBin(ByRef Result As String, _ ByRef Text As String, ByRef Search As String, _ ByRef sOld As String, ByRef sNew As String, _ ByVal Start As Long, ByVal Count As Long _ ) ' (c) Jost Schwider, VB-Tec.de Dim TextLen As Long Dim OldLen As Long Dim NewLen As Long Dim ReadPos As Long Dim WritePos As Long Dim CopyLen As Long Dim Buffer As String Dim BufferLen As Long Dim BufferPosNew As Long Dim BufferPosNext As Long ' Ersten Treffer bestimmen: If Start < 2 Then Start = InStrB(Search, sOld) Else Start = InStrB(Start + Start - 1, Search, sOld) End If If Start Then OldLen = LenB(sOld) NewLen = LenB(sNew) Select Case NewLen Case OldLen ' einfaches Überschreiben: Result = Text For Count = 1 To Count ' String "patchen": MidB$(Result, Start) = sNew ' Position aktualisieren: Start = InStrB(Start + OldLen, Search, sOld) If Start = 0 Then Exit Sub Next Count Exit Sub Case Is < OldLen ' Ergebnis wird kürzer: ' Buffer initialisieren: TextLen = LenB(Text) If TextLen > BufferLen Then Buffer = Text BufferLen = TextLen End If ' Ersetzen: ReadPos = 1 WritePos = 1 For Count = 1 To Count ' String "patchen": CopyLen = Start - ReadPos BufferPosNew = WritePos + CopyLen MidB$(Buffer, WritePos) = MidB$( _ Text, ReadPos, CopyLen) MidB$(Buffer, BufferPosNew) = sNew ' Positionen aktualisieren: WritePos = BufferPosNew + NewLen ReadPos = Start + OldLen Start = InStrB(ReadPos, Search, sOld) If Start = 0 Then Exit For Next Count ' Ergebnis zusammenbauen: If ReadPos > TextLen Then Result = LeftB$(Buffer, WritePos - 1) Else MidB$(Buffer, WritePos) = MidB$(Text, ReadPos) Result = LeftB$(Buffer, WritePos + _ LenB(Text) - ReadPos) End If Exit Sub Case Else ' Ergebnis wird länger: ' Buffer initialisieren: TextLen = LenB(Text) BufferPosNew = TextLen + NewLen If BufferPosNew > BufferLen Then Buffer = Space$(BufferPosNew) BufferLen = LenB(Buffer) End If ' Ersetzung: ReadPos = 1 WritePos = 1 For Count = 1 To Count ' Positionen berechnen: CopyLen = Start - ReadPos BufferPosNew = WritePos + CopyLen BufferPosNext = BufferPosNew + NewLen ' Ggf. Buffer vergrößern: If BufferPosNext > BufferLen Then Buffer = Buffer & Space$(BufferPosNext) BufferLen = LenB(Buffer) End If ' String "patchen": MidB$(Buffer, WritePos) = _ MidB$(Text, ReadPos, CopyLen) MidB$(Buffer, BufferPosNew) = sNew ' Positionen aktualisieren: WritePos = BufferPosNext ReadPos = Start + OldLen Start = InStrB(ReadPos, Search, sOld) If Start = 0 Then Exit For Next Count ' Ergebnis zusammenbauen: If ReadPos > TextLen Then Result = LeftB$(Buffer, WritePos - 1) Else BufferPosNext = WritePos + TextLen - ReadPos If BufferPosNext < BufferLen Then MidB$(Buffer, WritePos) = _ MidB$(Text, ReadPos) Result = LeftB$(Buffer, BufferPosNext) Else Result = LeftB$(Buffer, WritePos - 1) & _ MidB$(Text, ReadPos) End If End If Exit Sub End Select Else ' Kein Treffer: Result = Text End If End Sub Damit sollte das Dos Fenster nun kein Problem mehr sein

Dos

49

Hans

19.11.01 14:54

Sie sind nicht angemeldet! Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden. Einloggen  |  Neu registrieren

Funktionen:  Zum Thema  |  Gesamtübersicht

Suchen