Ver Mensaje Individual
  #6 (permalink)  
Antiguo 22/02/2006, 21:25
LeandroA
 
Fecha de Ingreso: abril-2005
Mensajes: 351
Antigüedad: 19 años
Puntos: 3
Hola te paso un modulo (igual este trabaja con un .bat) pero te puedo hacegurar que es estable

Cita:
Private Declare Function GetShortPathName Lib _
"kernel32" Alias "GetShortPathNameA" (ByVal _
lpszLongPath As String, ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long

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 TerminateProcess Lib "kernel32" (ByVal _
hProcess As Long, ByVal uExitCode As Long) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) _
As Long

Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const PROCESS_TERMINATE = &H1
Private Const BUFFER_LENGTH = 512
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000

Public Function ShellDos(ByVal Cmd As String, Optional ByVal WorkingDir As String = ".", Optional ByVal STDIN As String = "") As String

Dim errflag As Long ' verwenden wir um der Fehlerbehandlungs-
' routine zu sagen, wo wir gerade sind

Dim Batfile$ ' Unser Batchfile
Dim DataFile$ ' Unser STDIN-DataFile
Dim ReplyFile$ ' Unsere Ausgabedatei
Dim t As Single ' Allgemeine Zeitabfrage
Dim l As Long ' Dateilänge
Dim Task As Long ' TaskID
Dim Result As Long ' Für Rückgabewerte aus API-Funktionen
Dim fno As Long ' Dateinummer
Dim TaskID As Long ' Task-ID des DOS-Fensters
Dim ProcID As Long ' Prozess-ID des DOS-Fensters
Dim TmpDir As String ' Temporärer Ordner
Dim tmp As String ' Temporärer String

TmpDir = String(BUFFER_LENGTH, 0)
l = GetTempPath(BUFFER_LENGTH, TmpDir)
TmpDir = Left(TmpDir, l)

ReplyFile = TmpDir & "DOSReply.txt"
DataFile = TmpDir & "DOSSTDIN.txt"

' Die Datei muss existieren, damit
' GetShortPathName Funktioniert.
fno = FreeFile
Open ReplyFile For Binary As fno: Close fno
Open DataFile For Binary As fno: Close fno
ReplyFile = ShortPath(ReplyFile)
DataFile = ShortPath(DataFile)

Cmd$ = Cmd$ & "<" & DataFile & " >" + ReplyFile
errflag = 1

' Damit das Ergebnis eindeutig ist, löschen wir erstmal die Datei
Kill ReplyFile

' Zunächst wird unser Befehl in die Batchdatei geschrieben.
Batfile$ = TmpDir & "Batch.bat"

Open Batfile$ For Output As #fno
Print #fno, RootFromPath(WorkingDir)
Print #fno, "cd " & WorkingDir
Print #fno, Cmd$
Close #fno
DoEvents

' DOS wird mit der Batchdatei aufgerufen
tmp = String(BUFFER_LENGTH, 0)
l = GetShortPathName(Batfile$, tmp, BUFFER_LENGTH)
Batfile$ = Left(tmp, l)
TaskID = Shell(Batfile$, vbHide)

DoEvents
errflag = 2

ProcID = OpenProcess(SYNCHRONIZE, False, TaskID)
Call WaitForSingleObject(ProcID, INFINITE)


terminate:
' Hier wird DOS beendet
Result = TerminateProcess(ProcID, 1&)
Result = CloseHandle(Task)

errflag = 3
l = FileLen(ReplyFile)
tmp = String(l, 0)
Open ReplyFile For Binary As fno
Get fno, , tmp
Close fno
' ANSI -> ASCII
Call OemToChar(tmp, tmp)
ShellDos = tmp


Kill Batfile
Kill ReplyFile
Kill DataFile

errflag = 4

Exit Function

err1:
Select Case Err

Case 53

Select Case errflag

Case 1
Resume Next
Case 3
ShellDos = "<ERROR>"
Exit Function
Case Else
GoTo err_else
End Select

Case Else

err_else:
MsgBox Error$

End Select
End Function

Private Function RootFromPath(ByVal Path As String) As String
RootFromPath = Mid(Path, 1, InStr(Path, ":"))
End Function

Private Function ShortPath(ByVal Path As String) As String
Dim tmp As String ' Temporärer String
Dim l As Long ' Länge des Strings

tmp = String(256, 0)
l = GetShortPathName(Path, tmp, Len(tmp))
ShortPath = Left(tmp, l)
End Function
y para llamarlo en un formulario pones un text1 un text2(multiline = true) y un command1

Cita:
Private Sub Command1_Click()
Text2 = ShellDos(Text1)
End Sub
Avisame si te sirve, un saludo