gsConfirm
Utilidad para simular una caja de diálogo personalizada

Actualizado el 5-Mar-97
Baja los listados y el ejemplo (VB4 para 16 ó 32 bits) (gsconfir.zip 19.6 KB)
Nota: Échale un vistazo a la nueva versión


Esta utilidad la puedes usar cuando necesites crear un "cuadro de diálogo personalizado". Es decir algo como el MsgBox o los cuadros de confirmación de Windows 95

Vamos a ver los listados y unas pantallas de muestra, creo que no necesita demasiada explicación, así que... si tienes alguna duda, me lo preguntas y no hay problema. Consultame lo que quieras referente a esta "utilidad"

La primera "foto" es de gsConfir.frm

  • Los iconos es un array de Image1(x)
  • El que tiene "mi icono" es un Picture1
  • Los botones son un array de Command1(x)

Esta que sigue es del form de prueba.

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

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

'--------------------------------------------------
' gsConfir.frm                          (26/Jul/96)
'
'© Guillermo Som Cerezo, 1996-97
'
'Revisado:  ( 5/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 = 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 FrmConfirmar = Nothing
End Sub

El siguiente código se debe introducir en el módulo gsConfir.bas

'--------------------------------------------------
'Módulo para función de confirmación    (26/Jul/96)
'
'© Guillermo Som Cerezo, 1996-97
'
'Revisado:  ( 5/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

'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


Public Function PedirConfirmacion(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 iQueBoton As Integer
    Dim sPrograma As String
    Dim fHeight As Integer
    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
        FrmConfirmar!Picture1.Visible = False
    Else
        FrmConfirmar.ExtraerIcono sPrograma, lIcono
    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 FrmConfirmar
        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 + 240 + 800
        If fHeight < 2500 Then
            fHeight = 2500
        End If
        .Height = fHeight
        .Command1(0).Top = fHeight - 800
        
        'Seleccionar los botones a mostrar
        If iTipo = vbYesNo Then
            .Command1(0).Visible = True
            .Command1(2).Visible = True
        ElseIf iTipo = vbYesNoCancel Then
            .Command1(0).Visible = True
            .Command1(2).Visible = True
            .Command1(3).Visible = True
        ElseIf iTipo = 8 Then
            .Command1(0).Visible = True
            .Command1(1).Visible = True
            .Command1(2).Visible = True
            .Command1(3).Visible = True
        Else
            .Command1(0).Visible = True
        End If
        j = 0
        For i = 1 To 3
            .Command1(i).Top = .Command1(0).Top
            If .Command1(i).Visible Then
                .Command1(i).Left = .Command1(j).Left + .Command1(j).Width + 165
                j = i
            End If
        Next
        'Centrar el form
        .Move (Screen.Width - .Width) \ 2, (Screen.Height - .Height) \ 2
        .Caption = sCaption
        '==========================================================================
        'Nota si falla el .Show vbModal usa éste código
        '
        'Do
        '   .Show
        '   DoEvents
        'Loop Until .BotonPulsado
        '
        .Show vbModal
        '==========================================================================
        PedirConfirmacion = .BotonPulsado
    End With
    Unload FrmConfirmar
    DoEvents
    '==============================================================================
    'NOTAS PARA MEJORAR ESTA RUTINA
    '   Se podrían mover los botones, para acomodarlos si no se muestran todos
    '   Ajustar el contenido del/los mensajes a mostrar, cortando las cadenas largas.
    '   Hacer transparente el icono mostrado
    '   ... y las que se te ocurran, me las mandas a: [email protected]
    '==============================================================================
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 gsConfirm                      ( 5/Mar/97)
'
'© Guillermo Som Cerezo, 1997
'-------------------------------------------------------
Option Explicit


Private Sub cmdPrueba_Click(Index As Integer)
    Dim sMsg As String
    Dim iValor As Integer
    
    Select Case Index
    Case 0  'Si
        sMsg = "Pulsa SI para aceptar lo que sea..."
        iValor = PedirConfirmacion(sMsg)
    Case 1
        sMsg = "Pulsa Si, para aceptar" & vbCrLf & "No, para no aceptar..."
        iValor = PedirConfirmacion(sMsg, vbYesNo + vbQuestion)
    Case 2
        sMsg = "Pulsa Si, para aceptar" & vbCrLf & "No, para no aceptar" _
                & vbCrLf & "Cancelar, para cancelar..." & vbCrLf & " ¡Que original!"
        iValor = PedirConfirmacion(sMsg, vbYesNoCancel + vbCritical, "Prueba de gsConfirm")
    Case 3
        sMsg = "Esta es la Refinitiva..." & vbCrLf & vbCrLf & "Para que serán estos botones?"
        iValor = PedirConfirmacion(sMsg, 8 + 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 = PedirConfirmacion(sMsg, vbYesNoCancel + vbQuestion, "Prueba de gsConfirm", "c:\Windows\Notepad.exe")
        If iValor = vbYes Then
            sMsg = "que SI!"
        ElseIf iValor = vbNo Then
            sMsg = "que NO!"
        ElseIf iValor = vbCancel Then
            sMsg = "CANCELAR"
        End If
        MsgBox "Has seleccionado " & sMsg
    End Select
End Sub


Private Sub cmdSalir_Click()
    Unload Me
    End
End Sub


Private Sub Form_Unload(Cancel As Integer)
    'Me gusta siempre "liberar" la memoria ocupada.
    Set Form1 = Nothing
End Sub

Y eso es todo amigos, que lo disfrutes. Ya sabes si necesitas "aclaración" ¡que me lo preguntes!


ir al índice