Este es el tipo de cosas que debes pensar que vas a tener que hacer, ¡hasta que lo necesites! Es decir, ejecutar algún comando de DOS/Símbolo del sistema y obtener el resultado en tu programa VBA.
Esta es una de esas cosas que siempre me ha sorprendido que Microsoft nunca nos haya dado directamente la posibilidad de hacer en VBA y que hayamos tenido que idear nuestra propia solución, ya que hay muchas, muchas razones/necesidades para hacerlo. Además, esto no es solo para ejecutar cosas como Dir, IPConfig, NSLookup, … sino que lo uso para ejecutar utilidades de línea de comandos, que es donde reside su verdadero poder, extendiéndose más allá de los comandos DOS.
Ahora bien, si buscas el tema en Google, encontrarás multitud de soluciones, soluciones API complejas, enviadas a archivos de texto y luego leyendo el archivo de texto… suficientes para darte dolores de cabeza.
Hoy pensé en compartir un par de enfoques simples que me han funcionado a lo largo de los años.
Usando Shell
'---------------------------------------------------------------------------------------
' Procedure : ReturnCmdOutput_01
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website :
' Purpose : Run a CMD command and return the resulting output
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) -
' Req'd Refs: None required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sCmd : Command to run and get the result of
' bDebug : Debug, output command string, execute in visible window
' Does not retrieve the result though!
'
' Usage:
' ~~~~~~
' ? ReturnCmdOutput_01("dir")
'
' ? ReturnCmdOutput_01("ipconfig /all")
'
' ? ReturnCmdOutput_01("nslookup /google.com")
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 Unknown
' 2 2024-06-18 Updated Header and Error Handler
' Added Debug option
'---------------------------------------------------------------------------------------
Function ReturnCmdOutput_01(ByVal sCmd As String, _
Optional bDebug As Boolean = False) As String
On Error GoTo Error_Handler
Dim iCounter As Long
Call Clipboard_Clear
If Not bDebug Then
sCmd = sCmd & "|clip"
Call Shell("cmd /c " & sCmd, vbHide)
Else
Debug.Print sCmd
Call Shell("cmd /k " & sCmd, vbNormalFocus)
End If
'Loop until we get the results
Do While iCounter "" Then Exit Do
DoEvents
iCounter = iCounter + 1
Loop
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: ReturnCmdOutput_01" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Functionque requiere 2 rutinas auxiliares del Portapapeles:
'---------------------------------------------------------------------------------------
' Procedure : Clipboard_GetText
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website :
' Purpose : Retrieve the clipboard value
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) -
' Req'd Refs: Late Binding -> none required
'
' Usage:
' ~~~~~~
' Debug.Print Clipboard_GetText
' sClipboardValue = Clipboard_GetText
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2020-11-25 Initial Public Release
'---------------------------------------------------------------------------------------
Public Function Clipboard_GetText() As String
On Error GoTo Error_Handler
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
Clipboard_GetText = .GetText
End With
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Clipboard_GetText" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
'---------------------------------------------------------------------------------------
' Procedure : Clipboard_Clear
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website :
' Purpose : Clear the clipboard
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) -
' Req'd Refs: Late Binding -> none required
'
' Usage:
' ~~~~~~
' Call Clipboard_Clear
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2020-11-25 Initial Public Release
'---------------------------------------------------------------------------------------
Public Function Clipboard_Clear() As Boolean
On Error GoTo Error_Handler
Dim WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "cmd.exe /c echo off | clip", 0, True
Clipboard_Clear = True
Error_Handler_Exit:
On Error Resume Next
Set WshShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Clipboard_Clear" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End FunctionComo se indica en el encabezado de la función, puedes usarla haciendo lo siguiente:
? ReturnCmdOutput_01("dir")? ReturnCmdOutput_01("cd c:\users\ && dir")? ReturnCmdOutput_01("ipconfig")? ReturnCmdOutput_01("some.exe")Uso de WScript.Shell
'---------------------------------------------------------------------------------------
' Procedure : ReturnCmdOutput_02
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website :
' Purpose : Run a CMD command and return the resulting output
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) -
' Req'd Refs: None required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sCmd : Command to run and get the result of
' bDebug : Debug, output command string, execute in visible window
' Does not retrieve the result though!
'
' Usage:
' ~~~~~~
' ? ReturnCmdOutput_02("cd c:\temp\ && dir")
'
' ? ReturnCmdOutput_02("ipconfig")
'
' ? ReturnCmdOutput_02("nslookup google.com")
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 Unknown
' 2 2024-06-18 Updated Header and Error Handler
' Added Debug option
'---------------------------------------------------------------------------------------
Public Function ReturnCmdOutput_02(ByVal sCmd As String, _
Optional bDebug As Boolean = False) As String
On Error GoTo Error_Handler
ReturnCmdOutput_02 = CreateObject("WScript.Shell"). _
Exec("cmd /c " & sCmd). _
StdOut.ReadAll
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: ReturnCmdOutput_02" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End FunctionO bien, otra versión de lo anterior. He dejado un código comentado para mostrar variaciones en caso de que pueda ayudar a algunos de ustedes a hacer cosas diferentes.
'---------------------------------------------------------------------------------------
' Procedure : ReturnCmdOutput_02
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website :
' Purpose : Run a CMD command and return the resulting output
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) -
' Req'd Refs: Early Binding -> Windows Script Host Object Model (wshom.ocx)
' Late Binding -> None
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sCmd : Command to run and get the result of
' Multiple commands use & or && or || ...
' bDebug : Debug, output command string, execute in visible window
' Does not retrieve the result though!
'
' Usage:
' ~~~~~~
' ? ReturnCmdOutput_02b("cd C:\Users\Daniel && dir")
' ? ReturnCmdOutput_02b("cd c:\ && dir")
' ? ReturnCmdOutput_02b("cd T:\Backups && T: && dir")
'
' ? ReturnCmdOutput_02b("ipconfig")
'
' ? ReturnCmdOutput_02b("nslookup google.com")
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2024-06-18 New version of existing function
'---------------------------------------------------------------------------------------
Public Function ReturnCmdOutput_02b(ByVal sCmd As String, _
Optional bDebug As Boolean = False) As String
On Error GoTo Error_Handler
#Const WSH_EarlyBind = False
#If WSH_EarlyBind = True Then
Dim oWshShell As IWshRuntimeLibrary.WshShell
Dim oWshExec As IWshRuntimeLibrary.WshExec
Dim oStdOut As IWshRuntimeLibrary.TextStream
Set oWshShell = New IWshRuntimeLibrary.WshShell
#Else
Dim oWshShell As Object
Dim oWshExec As Object
Dim oStdOut As Object
Set oWshShell = CreateObject("WScript.Shell")
#End If
' Dim sStdOutLine As String
Const WshRunning = 0 'Enum WshExecStatus
' Const WshFinished = 1 'Enum WshExecStatus
' Const WshFailed = 2 'Enum WshExecStatus
If Not bDebug Then
Set oWshExec = oWshShell.Exec("%comspec% /c " & sCmd)
While oWshExec.Status = WshRunning 'Could add a small pause?!
DoEvents
Wend
'Grab everything at once
ReturnCmdOutput_02b = oWshExec.StdOut.ReadAll
' 'Iterate over the output, line by line
' Set oStdOut = oWshExec.StdOut
' While Not oStdOut.AtEndOfStream
' sStdOutLine = oStdOut.ReadLine
' ReturnCmdOutput_02b = ReturnCmdOutput_02b & sStdOutLine & vbCrLf
' Wend
Else
Debug.Print sCmd
oWshShell.Run ("%comspec% /k " & sCmd)
End If
Error_Handler_Exit:
On Error Resume Next
Set oStdOut = Nothing
Set oWshExec = Nothing
Set oWshShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: ReturnCmdOutput_02b" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Functioncualquiera de los cuales puedes usar haciendo algo como:
? ReturnCmdOutput_02("cd c:\temp\ && dir")? ReturnCmdOutput_02("ipconfig")? ReturnCmdOutput_02("nslookup google.com")Entonces, antes de probar alguna ruta compleja de API, prueba una de estas primero, puede que te simplifique un poco la vida.
La ruta API
Si desea utilizar API, aquí solo hay dos posibilidades.
Concha y espera
Está Shell y Wait de Chip Pearson. Utilice el siguiente enlace para obtener una copia.
Concha y espera
La función Shell de VBA se puede utilizar para iniciar un programa externo o realizar cualquier operación para la que normalmente utilizaría el elemento Ejecutar del menú de inicio de Windows. La función Shell inicia el texto del comando y luego devuelve inmediatamente el control al código VBA que realiza la llamada; no espera a que finalice el comando utilizado en Shell…
Redirigir
Otro enfoque con el que me encontré
'Option Compare Database
Option Compare Text 'Critical!
Option Explicit
'
'
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Byte
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
'Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80
'Private Const STATUS_WAIT_0 As Long = &H0
'Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)
'Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)
'Private Const WAIT_TIMEOUT As Long = 258&
'Private Const WAIT_FAILED As Long = &HFFFFFFFF
Private Const WAIT_INFINITE As Long = (-1&)
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const SW_HIDE As Long = 0&
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoA" (lpStartupInfo As STARTUPINFO)
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Public Function Redirect(szBinaryPath As String, szCommandLn As String) As String
Dim tSA_CreatePipe As SECURITY_ATTRIBUTES
Dim tSA_CreateProcessPrc As SECURITY_ATTRIBUTES
Dim tSA_CreateProcessThrd As SECURITY_ATTRIBUTES
Dim tSA_CreateProcessPrcInfo As PROCESS_INFORMATION
Dim tStartupInfo As STARTUPINFO
Dim hRead As Long
Dim hWrite As Long
Dim bRead As Long
Dim abytBuff() As Byte
Dim lngResult As Long
Dim szFullCommand As String
Dim lngExitCode As Long
Dim lngSizeOf As Long
tSA_CreatePipe.nLength = Len(tSA_CreatePipe)
tSA_CreatePipe.lpSecurityDescriptor = 0&
tSA_CreatePipe.bInheritHandle = True
tSA_CreateProcessPrc.nLength = Len(tSA_CreateProcessPrc)
tSA_CreateProcessThrd.nLength = Len(tSA_CreateProcessThrd)
If (CreatePipe(hRead, hWrite, tSA_CreatePipe, 0&) 0&) Then
tStartupInfo.cb = Len(tStartupInfo)
GetStartupInfo tStartupInfo
With tStartupInfo
.hStdOutput = hWrite
.hStdError = hWrite
.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
.wShowWindow = SW_HIDE
End With
szFullCommand = """" & szBinaryPath & """" & " " & szCommandLn
lngResult = CreateProcess(0&, szFullCommand, tSA_CreateProcessPrc, tSA_CreateProcessThrd, True, 0&, ByVal 0&, vbNullString, tStartupInfo, tSA_CreateProcessPrcInfo)
If (lngResult 0&) Then
lngResult = WaitForSingleObject(tSA_CreateProcessPrcInfo.hProcess, WAIT_INFINITE)
lngSizeOf = GetFileSize(hRead, 0&)
If (lngSizeOf > 0) Then
ReDim abytBuff(lngSizeOf - 1)
If ReadFile(hRead, abytBuff(0), UBound(abytBuff) + 1, bRead, ByVal 0&) Then
Redirect = StrConv(abytBuff, vbUnicode)
End If
End If
Call GetExitCodeProcess(tSA_CreateProcessPrcInfo.hProcess, lngExitCode)
CloseHandle tSA_CreateProcessPrcInfo.hThread
CloseHandle tSA_CreateProcessPrcInfo.hProcess
If (lngExitCode 0&) Then Err.Raise vbObject + 1235&, "GetExitCodeProcess", "Non-zero Application exist code"
CloseHandle hWrite
CloseHandle hRead
Else
Err.Raise vbObject + 1236&, "CreateProcess", "CreateProcess Failed, Code: " & Err.LastDllError
End If
End If
End FunctionLuego creamos una función contenedora simple para llamarla:
Public Function ReturnCmdOutput_05(ByVal sBinary As String, _
Optional sCmd As String) As String
On Error GoTo Error_Handler
ReturnCmdOutput_05 = Redirect(sBinary, sCmd)
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: ReturnCmdOutput_05" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End FunctionLuego puedes llamarlo haciendo:
? ReturnCmdOutput_05("cmd", "/c cd c:\users\ && dir")? ReturnCmdOutput_05("cmd", "/c nslookup google.com")? ReturnCmdOutput_05("cmd", "/c ipconfig")¡Diablos! Incluso podemos usarlo para ejecutar comandos de PowerShell:
? ReturnCmdOutput_05("C:\Windows\system32\WindowsPowerShell\v1.0\PowerShell.exe", "get-WmiObject win32_logicaldisk | SELECT DeviceId, Size, FreeSpace")Necesito hacer algunas pruebas con mi enfoque actual, ¿quizás sea más eficiente?
