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: <[email protected]> o <[email protected]>
'---------------------------------------------------------------
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-)

---