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
 |
|
Esta que sigue es del form de prueba.
 |
|
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: guiller@wcostasol.es
'==============================================================================
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!
