Especial Shell

para 16 y 32 bits

Actualizado el 31-Oct-1997


Baja los listados de ejemplo para 16 y 32 bits (shell_2.zip 8.45 KB)

  1. Cómo saber si un programa ha finalizado (VB4 16 ó 32)
  2. Cómo saber si un programa ha finalizado (VB3)
  3. Obtener la etiqueta y número de serie del volumen en VB de 16 bits. También para 32 bits
  4. Usar Shell para ejecutar una orden del MS-DOS
  5. Esperar a que un programa termine (incluso si es de MS-DOS) (32 bits)

1.- Cómo saber si un programa ha finalizado (VB4 16 ó 32) (3/Mar)

La razón de "repetir" este truco, es porque parece que no queda demasiado claro. Por tanto voy a dar los ejemplos por separado, con la función en un módulo independiente y ejemplo de cómo usarlo.
Espero que ahora esté mejor explicado y puedas usarlo "sin complicaciones"

El tema consiste en lo siguiente, tenemos el procedimiento EjecutarPrograma, el cual recibe tres parámetros:
El Form que hace la llamada
El programa a ejecutar (
si es una orden del Command.com, te aconsejo que veas cómo hacerlo, en un truco que viene más abajo)
El nombre de la ventana que debemos chequear para poder cerrarla.

Ahora veamos el código, porque parece que también da pereza ver el contenido de los archivos de ejemplo.
El único inconveniente es que las páginas crecen y se hacen más lenta de cargar... bueno no importa cuando vea que tiene más KiloBytes de la cuenta, crearé otra página...


'---------------------------------------------------------------
'Shell_32.bas                                      ( 2/Mar/97)
'
'Módulo para comprobar si una tarea MS-DOS ha finalizado
'y cerrar la ventana asociada.
'Sirve tanto para VB4 o superior de 16 y 32 bits,
'si usas VB3 o anterior, usa el módulo Shell_16.bas
'
'Este código es de libre uso/distribución.
'---------------------------------------------------------------

'Declaraciones Generales
Option Explicit
Option Compare Text

'Declaraciones del API de 16 y 32 bits (sólo para VB4 o superior)
#If Win32 Then
    Private Declare Function GetWindow Lib "user32" _
	(ByVal hWnd As Long, ByVal wCmd As Long) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
	(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" _
	(ByVal hWnd As Long) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
#Else
    Private Declare Function GetWindow Lib "User" _
	(ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer
    Private Declare Function GetWindowText Lib "User" _
	(ByVal hWnd As Integer, ByVal lpString As String, ByVal aint As Integer) As Integer
    Private Declare Function GetWindowTextLength Lib "User" _
	(ByVal hWnd As Integer) As Integer
    Private Declare Function IsWindowVisible Lib "User" (ByVal hWnd As Integer) As Integer
#End If
'Constantes para GetWindow
Const GW_HWNDFIRST = 0
Const GW_HWNDLAST = 1
Const GW_HWNDNEXT = 2
Const GW_HWNDPREV = 3
Const GW_OWNER = 4
Const GW_CHILD = 5



'Esta es la "madre" del cordero
Public Sub EjecutarPrograma(queForm As Form, quePrograma As String, queVentana As String)
    '----------------------------------------------------
    'Ejecuta el programa y espera a que termine
    'Parámetros:
    '   queForm     Nombre del formulario desde el que se hará la llamada
    '   quePrograma Programa a ejecutar con los parámetros necesarios
    '   queVentana  Nombre a comprobar en el caption de las ventanas abiertas
    '----------------------------------------------------
    #If Win32 Then
        Dim x As Long
    #Else
        Dim x As Integer
    #End If

    On Local Error Resume Next

    x = Shell(quePrograma, 1)
    If Err Then
        MsgBox "Se ha producido el siguiente error:" & vbCrLf & _
		"Err=" & Str$(Err) & " " & Error$
        Err = 0
        Exit Sub
    End If
    '
    'Dar tiempo a que se active...
    '
    Dim t As Long
    Dim nSeg As Integer

    t = Timer
    nSeg = 1    'Con un segundo suele ser suficiente
    'Esperar nSeg segundos
    Do While t + nSeg > Timer
        DoEvents
    Loop
    'Repetir el bucle mientras esté funcionando...
    Do While LeerTareas(queForm, queVentana)
        DoEvents
    Loop
End Sub



'Aunque esta también ayuda
Private Function LeerTareas(elForm As Form, sTarea As String) As Integer
    '--------------------------------------------------
    'Leer las tareas activas y comprobar si la especificada
    'está funcionando...
    'Parámetros:
    '   elForm  Form actual
    '   sTarea  Tarea a comprobar
    '--------------------------------------------------
    #If Win32 Then
        Dim CurrWnd As Long
        Dim Length As Long
        Dim hwndDlg As Long
    #Else
        Dim CurrWnd As Integer
        Dim Length As Integer
        Dim hwndDlg As Integer
    #End If
    '
    Dim ListItem As String
    Dim sTmp As String
    Dim Activada As Integer
    '
    '
    Activada = False

    'Con GW_HWNDFIRST, lee todas las ventanas
    hwndDlg = elForm.hWnd
    CurrWnd = GetWindow(hwndDlg, GW_HWNDFIRST)

    If CurrWnd Then
        Do While CurrWnd <> 0
            DoEvents
            If CurrWnd <> hwndDlg And IsWindowVisible(CurrWnd) _
				  And (hwndDlg <> GetWindow(CurrWnd, GW_OWNER)) Then
                Length = GetWindowTextLength(CurrWnd)
                ListItem = Space$(Length)
                Length = GetWindowText(CurrWnd, ListItem, Length + 1)
                If Length > 0 Then
                    'Comprobar si es la que queremos
                    sTmp = Trim$(ListItem)
                    If InStr(sTmp, sTarea) Then
                        If InStr(sTmp, "Finaliza") Then
                            'cerrar esa ventana
                            AppActivate sTmp
                            SendKeys "%{F4}", True
                            Activada = False
                        Else
                            Activada = True
                        End If
                        Exit Do
                    End If
                End If
            End If
            CurrWnd = GetWindow(CurrWnd, GW_HWNDNEXT)
        Loop
    End If
    LeerTareas = Activada
End Function

Bueno, ese era el código del módulo Shell_32.bas.
Ahora veamos el Form de Prueba.

'--------------------------------------------------
' Prueba para uso de Shell en Windows95/NT
'
' Autor:    Guillermo Som
' Fecha:    21/Dic/96
'--------------------------------------------------
Option Explicit
Option Compare Text
'Variables para los programas a cargar:
Dim sPrograma() As String   'Programas
Dim sIcono() As String      'Fichero de icono, dejarlo en blanco para usar el icono del programa
Dim sVentana() As String    'Caption a comprobar en las ventanas abiertas
'
'Declaraciones del API de 16 y 32 bits (sólo para VB4 o superior)
#If Win32 Then
    Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
    Private Declare Function GetClassWord Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
#Else
    Private Declare Function ExtractIcon Lib "Shell" (ByVal hInstance As Integer, ByVal pszExeName As String, ByVal hIcon As Integer) As Integer
    Private Declare Function GetClassWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
    Private Declare Function DrawIcon Lib "User" (ByVal hdc As Integer, ByVal x As Integer, ByVal y As Integer, ByVal hIcon As Integer) As Integer
#End If
'
Const GCW_HMODULE = (-16)


Private Sub Command1_Click(Index As Integer)
    'Ejecutar el programa indicado en sPrograma(Index)
    '
    Dim i As Integer

    LblEstado = "Ejecuntando " & sVentana(Index)
    'Desactivar los botones
    For i = 0 To 1
        Command1(i).Enabled = False
    Next
    DoEvents
    EjecutarPrograma Me, sPrograma(Index), sVentana(Index)

    're-activar los botones
    For i = 0 To 1
        Command1(i).Enabled = True
    Next
    LblEstado = ""
    DoEvents
End Sub


Private Sub CmdSalir_Click()
    Unload Me
    End
End Sub


Private Sub Form_Load()
    Dim sTmp As String

    LblEstado = ""

    sTmp = "Para comprobar el programa," & vbCrLf
    sTmp = sTmp & "pulsa en cualquiera de los botones." & vbCrLf
    sTmp = sTmp & "El primero carga Notepad," & vbCrLf
    sTmp = sTmp & "el segundo llama a pkzip ? " & vbCrLf
    sTmp = sTmp & "(si no tienes pkzip, usa otro programa que trabaje en MS-DOS)," & vbCrLf
    sTmp = sTmp & "cuando el programa termine, se indicará en la parte inferior."
    Label2 = sTmp
    sTmp = ""
    Show
    '---
    'Especificar aquí los programas a cargar...
    '
    ReDim sPrograma(1)
    ReDim sIcono(1)
    ReDim sVentana(1)
    '
    'Incluir en sPrograma los parámetros...
    '
    'El contenido de sVentana() será parte del caption
    'que la ventana vaya a tener...
    '
    'Ejemplo, Notepad siempre indica
    '   "Nombre_archivo - Bloc de notas"
    '
    'Primer programa:
    sPrograma(0) = "c:\windows\notepad.exe"
    sIcono(0) = ""
    sVentana(0) = "Bloc"
    '
    'Segundo programa:
    sPrograma(1) = "pkzip.exe -?"
    'Este icono se incluye en el archivo comprimido
    sIcono(1) = "pkzip.ico"
    sVentana(1) = "Pkzip"
    '
    Dim i As Integer
    For i = 0 To 1
        MostrarIcono sPrograma(i), sIcono(i), Picture1(i)
    Next
    '
End Sub


Private Sub Form_Unload(Cancel As Integer)
    Set FrmShell = Nothing
End Sub


Private Sub MostrarIcono(quePrograma As String, queIcono As String, queControl As Control)
    'Cargar el icono del programa
    '----------------------------------------------
    'Los parámetros son:
    '   quePrograma El path al programa
    '   queIcono    El path al icono o vacío si se usa el icono del programa
    '   queControl  El control en el que se pintará el icono, normalmente será un Picture
    '----------------------------------------------
    #If Win32 Then
        Dim elhInst As Long
        Dim hIcon As Long
        Dim i As Long
    #Else
        Dim elhInst As Integer
        Dim hIcon As Integer
        Dim i As Integer
    #End If

    elhInst = GetClassWord(hWnd, GCW_HMODULE)
    If Len(queIcono) = 0 Then
        queIcono = quePrograma
        'Si se quiere especificar un número determinado de icono dentro de un programa
        'cambiar el 0 por una variable que apunte al icono deseado
        '(empieza por 0)
        hIcon = ExtractIcon(elhInst, queIcono, 0)
        If hIcon Then
            queControl.Picture = LoadPicture("")
            queControl.AutoRedraw = -1
            i = DrawIcon(queControl.hdc, 0, 0, hIcon)
            queControl.Refresh
        End If
    Else
        queControl.Picture = LoadPicture(queIcono)
    End If
End Sub

Y ahora una "foto" del form de prueba.



 

2.- Cómo saber si un programa ha finalizado (VB3) (3/Mar)

Ahora viene el ejemplo de VB3.
En este he incluido un método para "convertir" una orden del DOS en un archivo BAT.
Después lo pondré explicado un poco más abajo.

Ahora veamos el contenido de Shell_16.bas:

'---------------------------------------------------------------
'Shell_16.bas                                      ( 2/Mar/97)
'
'Módulo para comprobar si una tarea MS-DOS ha finalizado
'y cerrar la ventana asociada.
'Sirve para VB3 o anterior,
'si usas VB4 o superior, usa el módulo Shell_32.bas
'
'Este código es de libre uso/distribución, facilitado por:
'Guillermo Som Cerezo
'Web:    http://guille.costasol.net
'Correo: <mensaje@elguille.info> o <mensaje@elguille.info>
'---------------------------------------------------------------
Option Explicit
Option Compare Text

Declare Function GetModuleUsage% Lib "Kernel" (ByVal hModule%)
Declare Function FindWindow% Lib "User" (ByVal lpClassName As Any, ByVal lpCaption As Any)


Sub EjecutarPrograma (quePrograma As String, queVentana As String)
    Dim x As Integer

    On Error Resume Next

    'Ejecutar minimizado y sin foco
    x = Shell(quePrograma, 6)
    If Err Then
        Exit Sub
    End If
    'Comprobar si aún está activa

    'ATENCIÓN, NO QUITAR EL DOEVENTS,
    'O SE QUEDARÁ COLGADO
    Do
        While GetModuleUsage(x) > 0
            DoEvents
            If FindWindow(0&, "Finalizado - " + queVentana) Then
                AppActivate "Finalizado - " + queVentana
                SendKeys "%{F4}", True
                Exit Do
            End If
        Wend
    Loop While x

End Sub

 

Ahora el módulo de prueba:

'----------------------------------------------------------
'Shell_16.Frm                                   ( 2/Mar/97)
'
'Prueba para ejecutar un programa y esperar a que termine
'también nos dice la etiqueta del volumen...
'
'----------------------------------------------------------
Option Explicit


Sub cmdAccion_Click ()
    'Comprobar la etiqueta del volumen y mostrarla

    Dim i As Integer
    Dim sUd As String
    Dim sProg As String
    Dim sFic As String
    Dim sTmp As String
    Dim Hallado As Integer
    Dim sVolumen As String
    Dim sNumSerie As String

    Label1(3).Caption = "Procesando la información..."
    DoEvents

    sUd = Trim$(Text1.Text)
    i = InStr(sUd, ":")
    If i = 0 Then
        MsgBox "Debes especificar una unidad de disco."
        Unload Me
        End
    End If
    sUd = Left$(sUd, i)
    sFic = sUd & "\Files.txt"
    'Fichero para ejecutar el comando DIR
    sProg = sUd & "\~Files.bat"
    sUd = sUd & "\*.*"

    i = FreeFile
    Open sProg For Output As i
    Print #i, "Dir " & sUd & " >" & sFic
    Close i

    EjecutarPrograma sProg, "~Files"
    'Ya ha finalizado...
    'Abrir el archivo sFic
    '
    If Len(Dir$(sFic)) Then
        'Abrirlo
        i = FreeFile
        Open sFic For Input As i
        Do While Not EOF(i)
            Line Input #i, sTmp
            If InStr(sTmp, "volume") Then
                Hallado = True
                sVolumen = sTmp
                If Not EOF(i) Then
                    Line Input #i, sNumSerie
                End If
                Exit Do
            End If
        Loop
        Close i
        If Hallado Then
            'Obtener la etiqueta y el número de serie
            UltimaPalabra sVolumen
            UltimaPalabra sNumSerie
            If Len(sVolumen) = 0 Then
                sVolumen = "No tiene etiqueta de volumen?"
            End If
            If (Len(sNumSerie) = 0 Or InStr(sNumSerie, "-") = 0) Then
                sNumSerie = "No tiene número de serie?"
            End If
            Label1(3).Caption = sVolumen & " - " & sNumSerie
            Label2(0).Caption = sVolumen
            Label2(1).Caption = sNumSerie
        Else
            Label1(3).Caption = "No se encuentra la etiqueta del volumen..."
        End If
    Else
        MsgBox "No se ha podido crear el fichero: " & sFic
    End If
    'Borrar los archivos
    If Len(Dir$(sProg)) Then
        Kill sProg
    End If
    If Len(Dir$(sFic)) Then
        Kill sFic
    End If
    Text1.SetFocus
End Sub


Sub cmdSalir_Click ()
    Unload Me
    End
End Sub


Sub Form_Unload (Cancel As Integer)
    Set Form1 = Nothing
End Sub


Sub UltimaPalabra (sFrase As String)
    'De la cadena sFrase obtiene la última palabra
    'Realmente lo que haya desde el último espacio

    Dim i As Integer
    Dim sPalabra As String

    'Buscar el último espacio
    sPalabra = ""
    'Asegurarnos de no encontrar espacios al final de la cadena
    sFrase = Trim$(sFrase)
    For i = Len(sFrase) To 1 Step -1
        If Mid$(sFrase, i, 1) = " " Then
            sPalabra = Mid$(sFrase, i + 1)
            Exit For
        End If
    Next
    sFrase = Trim$(sPalabra)
End Sub

Y para terminar, como es costumbre, una foto del formulario



 

3.- Obtener la etiqueta y número de serie del volumen en VB de 16 bits. (3/Mar)

Esto está sacado del ejemplo anterior, así que míralo y verás como hacerlo.
Lo pongo como truco separado, para que "lo encuentres" cuando lo busques. De nada. 8-)


 

4.- Usar Shell para ejecutar una orden del MS-DOS (3/Mar)

Esto está sacado del truco número 2, así que míralo y verás como hacerlo.
También lo pongo como truco separado, para que "lo encuentres" cuando lo busques. De nada otra vez. 8-)


 

ir al índice