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 SubEl 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 FunctionY 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 SubY eso es todo amigos, que lo disfrutes. Ya sabes si necesitas "aclaración" ¡que me lo preguntes!