gsInput

Utilidad para simular una caja de diálogo personalizada y un InputBox

Actualizado el 22-Mar-97


Si quieres ver las versiones posteriores:
La del 28/Sep/1997 y la del 26/Dic/2001

Baja los listados y el ejemplo (VB4 para 16 ó 32 bits) (gsinput.zip 7.09 KB)


Esta utilidad es una revisión/mejora de gsConfirm.
Te permite además de hacer cuadros de diálogos al estilo de los de confirmación de Windows 95, crear unos inputbox personalizados con los iconos y botones de confirmación.

Para usarlo hay dos funciones que devuelven el botón pulsado, pero según sea una u otra hará la función de un MsgBox o un InputBox.

Boton = InputConfirm (Mensaje, Texto [ [, Botones_Icono] [, Caption] [, Icono_Programa] [, Icono_Numero] ] )
Boton = MsgConfirm (Mensaje [ [, Botones_Icono] [, Caption] [, Icono_Programa] [, Icono_Numero] ] )

Los parámetros son:

Mensaje:	Mensaje a mostrar en la caja de diálogo
Texto:		El texto a mostrar en la caja de texto
Botones_Icono:	Botones y tipo de icono a mostrar:
		    vbOk, vbYesNo, vbYesNoCancel, vbOkCancel, cSiATodo
		    a estos valores sumarle el icono a mostrar, igual que en MsgBox
Caption:	El caption de la caja de diálogo
Icono_Programa:	Si se quiere mostrar el icono de un programa, este será el path del programa
Icono_Numero:	El número del icono a mostrar del programa indicado, el primero es 0 (cero)

Este es el aspecto del form gsInput.frm: (frmConfirm)

frmConfirm
  • El Label1 aunque es un array, sólo hay un elemento.
  • Los iconos es un array de Image1(x)
  • El que tiene "mi icono" es un Picture1, para mostrar el icono del programa.
  • Los botones son un array de Command1(x)

Este es el form de prueba:

  Los botones "largos" son cmdPrueba(x)
  El botón de Salir: cmdSalir

Y ahora vamos a ver el código de gsInput.frm

'--------------------------------------------------
' gsInput.frm                           (22/Mar/97)
'
'© Guillermo Som Cerezo, 1996-97
'
'Basado en gsConfirm			(26/Jul/96)
'Revisado: 				( 5/Mar/97)
'Nueva versión: Simulación de InputBox  (22/Mar/97)
'
'Adaptado para 16 bits y puesto como utilidad separada.
'
'Función para "simular" una caja de diálogo... más o menos
'Necesita el módulo gsConfir.bas
'
'--------------------------------------------------
'Este código es de libre uso:
'No pido nada a cambio,
'   sólo que se "referencie" de dónde se ha "tomado"
'--------------------------------------------------

Option Explicit

'Declaraciones del API
#If Win32 Then
    Private Declare Function GetClassWord Lib "user32" _
            (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    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 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 GetClassWord Lib "User" _
            (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
    Private Declare Function ExtractIcon Lib "shell.dll" _
            (ByVal hInst As Integer, ByVal lpszExeFileName As String, ByVal nIconIndex 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

'Propiedad pública del form
Public BotonPulsado As Integer


Public Sub ExtraerIcono(sPrograma As String, queIcon As Long)
    'Cargar el icono del programa
    Dim myhInst As Long
    Dim hIcon As Long
    Dim i As Long
    Const GCW_HMODULE = (-16&)

    myhInst = GetClassWord(hWnd, GCW_HMODULE)
    hIcon = ExtractIcon(myhInst, sPrograma, queIcon)
    If hIcon Then
        Picture1.Picture = LoadPicture("")
        Picture1.AutoRedraw = -1
        i = DrawIcon(Picture1.hDC, 0, 0, hIcon)
        Picture1.Refresh
    Else
        Picture1.Visible = False
    End If
End Sub


Private Sub Command1_Click(Index As Integer)
    Select Case Index
    Case 0
        BotonPulsado = vbYes
    Case 1
        BotonPulsado = cSiATodo '8
    Case 2
        BotonPulsado = vbNo
    Case Else
        BotonPulsado = vbCancel
    End Select
    Hide
End Sub


Private Sub Form_Load()
    '
    BotonPulsado = 0
End Sub


Private Sub Form_Unload(Cancel As Integer)
    'Si se cierra sin pulsar botón, es como si se cancelara
    If BotonPulsado = 0 Then
        BotonPulsado = vbCancel
    End If
    Set frmConfirm = Nothing
End Sub

El siguiente código se debe introducir en el módulo gsInput.bas y es el que tiene las funciones que se usarán.

'--------------------------------------------------
'Módulo para función de confirmación    (22/Mar/97)
'
'© Guillermo Som Cerezo, 1996-97
'
'Basado en gsConfirm			(26/Jul/96)
'Revisado:				( 5/Mar/97)
'Nueva versión: Simulación de InputBox  (22/Mar/97)
'
'Adaptado para 16 bits y puesto como utilidad separada.
'
'Función para "simular" una caja de diálogo... más o menos
'Necesita el form gsInput.frm
'
'--------------------------------------------------
'Este código es de libre uso:
'No pido nada a cambio,
'   sólo que se "referencie" de dónde se ha "tomado"
'--------------------------------------------------

Option Explicit

'Constantes para el tipo
Global Const cSi = vbOK
Global Const cSiNo = vbYesNo
Global Const cSiNoCancelar = vbYesNoCancel
Global Const cSiCancelar = vbOKCancel
Global Const cSiATodo = 8
'Constantes para el botón pulsado
Global Const cBotonSi = vbYes          '6
Global Const cBotonNo = vbNo           '7
Global Const cBotonCancelar = vbCancel '2
Global Const cBotonSiATodo = 8         '8


Private Sub PosicionarControles(sEntrada As String, iTipo As Integer, sCaption As String, Optional vMostrarText)
    '----------------------------------------------
    ' Ajusta los controles a mostrar
    '----------------------------------------------
    Dim i As Integer
    Dim j As Integer
    Dim iQueBoton As Integer
    Dim fHeight As Integer
    Dim mIzq As Integer                 'La posición más a la izquierda
    Dim bMostrarText As Boolean
    
    If IsMissing(vMostrarText) Then
        bMostrarText = False
    Else
        bMostrarText = CBool(vMostrarText)
    End If
        
    iQueBoton = 0
    If iTipo >= 512 Then
        iQueBoton = 3
        iTipo = iTipo Mod 512
    ElseIf iTipo >= 256 Then
        iQueBoton = 2
        iTipo = iTipo Mod 256
    End If
    With frmConfirm
        If bMostrarText Then
            .Text1.Enabled = True
            .Text1.Visible = True
        Else
            .Text1.Enabled = False
            .Text1.Visible = False
        End If
        If iTipo And vbCritical Then
            .Image1(0).Picture = .Image1(1).Picture
            iTipo = iTipo - vbCritical
        ElseIf iTipo And vbQuestion Then
            .Image1(0).Picture = .Image1(2).Picture
            iTipo = iTipo - vbQuestion
        ElseIf iTipo And vbExclamation Then
            .Image1(0).Picture = .Image1(3).Picture
            iTipo = iTipo - vbExclamation
        ElseIf iTipo And vbInformation Then
            .Image1(0).Picture = .Image1(4).Picture
            iTipo = iTipo - vbInformation
        Else    'Exclamación por defecto
            .Image1(0).Picture = .Image1(3).Picture
        End If
        .Label1(0).Visible = True
        .Label1(0) = sEntrada
        fHeight = .Label1(0).Top + .Label1(0).Height + 1040
        If .Text1.Enabled Then
            fHeight = fHeight + 420
        End If
        If fHeight < 2500 Then
            fHeight = 2500
        End If
        .Height = fHeight
        If .Text1.Enabled Then
            .Text1.Top = fHeight - 1220
        End If
        .Command1(0).Top = fHeight - 800
        
        'Usar enabled en lugar de visible, ya que hasta que se haga el show
        'no serán realmente visibles
        For i = 1 To 3
            .Command1(i).Enabled = False
        Next
        .Command1(0).Visible = True
        'Seleccionar los botones a mostrar
        If iTipo = vbYesNo Then
            .Command1(2).Enabled = True
        ElseIf iTipo = vbYesNoCancel Then
            .Command1(2).Enabled = True
            .Command1(3).Enabled = True
        ElseIf iTipo = 8 Then
            .Command1(1).Enabled = True
            .Command1(2).Enabled = True
            .Command1(3).Enabled = True
        ElseIf iTipo = vbOKCancel Then
            .Command1(3).Enabled = True
            .Command1(0).Caption = "Aceptar"
        Else
            'Si sólo se muestra un botón...
            .Command1(0).Caption = "Aceptar"
        End If
        'Ajustar la localización, según los botones mostrados
        mIzq = 0
        For i = 3 To 0 Step -1
            .Command1(i).Top = .Command1(0).Top
            If .Command1(i).Enabled Then
                If mIzq = 0 Then
                    mIzq = .ScaleWidth - 1215
                Else
                    mIzq = mIzq - 1170
                End If
                .Command1(i).Left = mIzq
                .Command1(i).Visible = True
            Else
                .Command1(i).Visible = False
            End If
        Next
        'Centrar el form
        .Move (Screen.Width - .Width) \ 2, (Screen.Height - .Height) \ 2
        .Caption = sCaption
    End With
End Sub


Public Function InputConfirm(sEntrada As String, sTexto As String, Optional vTipo, Optional vCaption, Optional vPrograma, Optional vIcono) As Integer
    '----------------------------------------------
    ' Muestra la ventana de confirmación
    '----------------------------------------------
    'Según el valor de iTipo, se mostrará:
    '   Si es >  de 256, seleccionar No
    '   Si es => de 512, seleccionar Cancelar
    '   Aceptar                     vbOk
    '   Si, No                      vbYesNo
    '   Si, No, Cancelar            vbYesNoCancel
    '   Si, SiATodo, No, Cancelar   8
    'Tipo de icono a mostrar:
    '   Stop                    vbCritical      16
    '   Interrogación           vbQuestion      32
    '   Exclamación             vbExclamation   48
    '   Información             vbInformation   64
    '----------------------------------------------
    'El valor devuelto será:
    '   Si          vbYes
    '   SiATodo     8
    '   No          vbNo
    '   Cancelar    vbCancel
    '----------------------------------------------
    Dim i As Integer
    Dim j As Integer
    Dim iTipo As Integer
    Dim sCaption As String
    Dim sPrograma As String
    Dim lIcono As Long
    
    If IsMissing(vTipo) Then
        iTipo = vbOK
    Else
        iTipo = vTipo
    End If
    If IsMissing(vCaption) Then
        sCaption = ""
    Else
        sCaption = vCaption
    End If
    If IsMissing(vPrograma) Then
        sPrograma = ""
    Else
        sPrograma = vPrograma
    End If
    If IsMissing(vIcono) Then
        lIcono = 0&
    Else
        lIcono = vIcono
    End If
    
    If Len(sPrograma) = 0 Then
        frmConfirm!Picture1.Visible = False
    Else
        frmConfirm.ExtraerIcono sPrograma, lIcono
    End If
    
    frmConfirm!Text1 = sTexto
    
    PosicionarControles sEntrada, iTipo, sCaption, True
    '==========================================================================
    'Nota si falla el .Show vbModal usa éste código
    '
    'Do
    '   frmConfirm.Show
    '   DoEvents
    'Loop Until .BotonPulsado
    '
    frmConfirm.Show vbModal
    '==========================================================================
    sTexto = frmConfirm.Text1
    InputConfirm = frmConfirm.BotonPulsado
    
    Unload frmConfirm
    DoEvents
End Function


Public Function MsgConfirm(sEntrada As String, Optional vTipo, Optional vCaption, Optional vPrograma, Optional vIcono) As Integer
    '----------------------------------------------
    ' Muestra la ventana de confirmación
    '----------------------------------------------
    'Según el valor de iTipo, se mostrará:
    '   Si es >  de 256, seleccionar No
    '   Si es => de 512, seleccionar Cancelar
    '   Aceptar                     vbOk
    '   Si, No                      vbYesNo
    '   Si, No, Cancelar            vbYesNoCancel
    '   Si, SiATodo, No, Cancelar   8
    'Tipo de icono a mostrar:
    '   Stop                    vbCritical      16
    '   Interrogación           vbQuestion      32
    '   Exclamación             vbExclamation   48
    '   Información             vbInformation   64
    '----------------------------------------------
    'El valor devuelto será:
    '   Si          vbYes
    '   SiATodo     8
    '   No          vbNo
    '   Cancelar    vbCancel
    '----------------------------------------------
    Dim i As Integer
    Dim j As Integer
    Dim iTipo As Integer
    Dim sCaption As String
    Dim sPrograma As String
    Dim lIcono As Long
    
    If IsMissing(vTipo) Then
        iTipo = vbOK
    Else
        iTipo = vTipo
    End If
    If IsMissing(vCaption) Then
        sCaption = ""
    Else
        sCaption = vCaption
    End If
    If IsMissing(vPrograma) Then
        sPrograma = ""
    Else
        sPrograma = vPrograma
    End If
    If IsMissing(vIcono) Then
        lIcono = 0&
    Else
        lIcono = vIcono
    End If
    
    If Len(sPrograma) = 0 Then
        frmConfirm!Picture1.Visible = False
    Else
        frmConfirm.ExtraerIcono sPrograma, lIcono
    End If
        
    PosicionarControles sEntrada, iTipo, sCaption
    '==========================================================================
    'Nota si falla el .Show vbModal usa éste código
    '
    'Do
    '   frmConfirm.Show
    '   DoEvents
    'Loop Until .BotonPulsado
    '
    frmConfirm.Show vbModal
    '==========================================================================
    MsgConfirm = frmConfirm.BotonPulsado
    
    Unload frmConfirm
    DoEvents
End Function

Y para terminar el código del form de prueba, no es muy sofisticado, pero vale para que sepas cómo usar esta utilidad.

'----------------------------------------------------------
'Para probar gsInput                            (22/Mar/97)
'
'© Guillermo Som Cerezo, 1997
'----------------------------------------------------------
Option Explicit


Private Sub cmdPrueba_Click(Index As Integer)
    Dim sMsg As String
    Dim iValor As Integer
    Dim sTexto As String
    
    Select Case Index
    Case 0  'Si
        sMsg = "Pulsa SI para aceptar lo que sea..."
        iValor = MsgConfirm(sMsg)
    Case 1
        sMsg = "Pulsa Si, para aceptar" & vbCrLf & "No, para no aceptar..."
        iValor = MsgConfirm(sMsg, vbYesNo + vbQuestion)
    Case 6
        sMsg = "Pulsa Aceptar o Cancelar"
        iValor = MsgConfirm(sMsg, vbOKCancel + vbInformation)
    Case 2
        sMsg = "Pulsa Si, para aceptar" & vbCrLf & "No, para no aceptar" _
                & vbCrLf & "Cancelar, para cancelar..." & vbCrLf & " ¡Que original!"
        iValor = MsgConfirm(sMsg, vbYesNoCancel + vbCritical, "Prueba de gsConfirm")
    Case 3
        sMsg = "Esta es la Refinitiva..." & vbCrLf & vbCrLf & "Para que serán estos botones?"
        iValor = MsgConfirm(sMsg, cSiATodo + vbInformation, "Prueba de gsConfirm")
    Case 4
        sMsg = "¿Quieres borrar este programa?" & vbCrLf & vbCrLf & "Sólo es una prueba, así que no te preocupes," & vbCrLf & "que no se borrará..." & vbCrLf & "Además este es un comentario grande, para que veas de lo que es capaz" & vbCrLf & "esta 'rutinilla'"
        iValor = MsgConfirm(sMsg, vbYesNoCancel + vbQuestion, "Prueba de gsConfirm", "c:\Windows\Notepad.exe")
    Case 5      'Prueba al estilo InputBox
        sTexto = "Texto de entrada"
        sMsg = "Escribe el nombre de lo que quieras..." & vbCrLf & "Ya que esto es para probar el estilo InputBox"
        iValor = InputConfirm(sMsg, sTexto, vbYesNo + vbInformation, "Prueba de InputConfirm")
        If iValor = vbYes Then
            sMsg = "que SI!"
        ElseIf iValor = vbNo Then
            sMsg = "que NO!"
        End If
        MsgBox "Has escrito " & sTexto & vbCrLf & "y has pulsado: " & sMsg
        Exit Sub
    End Select
    
    'Mostrar el mensaje según el botón pulsado
    If iValor = vbYes Then
        sMsg = "SI o ACEPTAR"
    ElseIf iValor = vbNo Then
        sMsg = "NO"
    ElseIf iValor = vbCancel Then
        sMsg = "CANCELAR"
    ElseIf iValor = cSiATodo Then
        sMsg = "SI A TODO"
    End If
    MsgBox "Has pulsado en el botón: " & sMsg

End Sub


Private Sub cmdSalir_Click()
    Unload Me
    End
End Sub


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

Y eso es todo amigos, que lo disfrutes.


ir al índice