 |
|
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)
|
|
|
Este es el form de prueba:
 |
|
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.
