Espero que este pequeño "truco" te sirva para dar el nuevo "look" de los botones de Office y VB5 a tus programas.
Este código sirve igualmente para VB4-16 como para 32 bits, no lo he probado con VB3, pero igualmente sirve, al menos si cambias la rutina del efecto 3D usando Parent en lugar de Container....El "truco" consiste en dibujar el botón cuando se está encima del botón, el ToolTip se hace mediante un label que se oculta cuando no lo necesitamos y que se muestra cuando estamos "encima" de uno de los botones.
Los botones son controles IMAGE y he usado para el ejemplo los gráficos que tengo para el ToolBar al estilo Windows95.
Estos gráficos puedes "fabricartelo" tu mismo, incluso te lo recomendaría, ya que son un "poco" pequeños y el efecto quedaría mejor si los bitmaps fuesen un poco más grandes. Pero para el ejemplo este, son válidos.Si quieres bajarte los gráficos, pulsa este link.
Para bajar los listados del ejemplo, pulsa en este otro (botones.zip 4.02 KB)
La rutina que hace el efecto 3D
Option Explicit '-------------------------------------------------- 'Efecto 3D (nueva versión) ( 5/Nov/94) ' Usando Container en lugar de Parent ( 3/Sep/96) '-------------------------------------------------- Global Const E3D_INSET = 1 Global Const E3D_RAISED = 2Sub Efecto3DN(QueEfecto As Integer, QueContenedor As Control, Optional QueControl) '------------------------------------------------------ 'Explicación de los parámetros a pasar: ' QueEfecto Puede tener los valores: E3D_INSET o E3D_RAISED (tipo botón) ' ( 9/Nov/94) Si QueEfecto > 10 DrawWidth=2... ' QueContenedor Si el contenedor es una Forma, se pondrá el mismo control, ' sino se pone el control contenedor de QueControl ' QueControl Control al que se le hará el efecto 3D ' (10/Nov/95) QueControl es opcional, usandose Quecontenedor '------------------------------------------------------ Dim X As Long, Y As Long Dim CurrentX As Integer, CurrentY As Integer Dim Color_Gris As Long, Color_Blanco As Long Dim Ltmp As Long Dim Bevel As Integer If IsMissing(QueControl) Then Set QueControl = QueContenedor End If Color_Gris = RGB(92, 92, 92) Color_Blanco = RGB(255, 255, 255) 'Ancho de la línea Bevel = 1 Do While QueEfecto > 10 QueEfecto = QueEfecto - 10 Bevel = Bevel + 1 Loop If QueEfecto = E3D_RAISED Then 'Estilo Command Ltmp = Color_Gris Color_Gris = Color_Blanco Color_Blanco = Ltmp End If X = Screen.TwipsPerPixelX Y = Screen.TwipsPerPixelY CurrentX = QueControl.Left - X CurrentY = QueControl.Top + QueControl.Height 'Si se dibuja un Frame... (13/Nov/94) If TypeOf QueControl Is Frame Then Y = Y - 120 End If If QueContenedor Is QueControl Then With QueControl .Container.DrawWidth = Bevel .Container.Line (CurrentX, CurrentY)-(CurrentX, CurrentY), Color_Gris .Container.Line -Step(0, -(.Height + Y)), Color_Gris .Container.Line -Step(.Width + X, 0), Color_Gris .Container.Line -Step(0, .Height + Y), Color_Blanco .Container.Line -Step(-(.Width + X), 0), Color_Blanco End With Else QueContenedor.DrawWidth = Bevel QueContenedor.Line (CurrentX, CurrentY)-(CurrentX, CurrentY), Color_Gris QueContenedor.Line -Step(0, -(QueControl.Height + Y)), Color_Gris QueContenedor.Line -Step(QueControl.Width + X, 0), Color_Gris QueContenedor.Line -Step(0, QueControl.Height + Y), Color_Blanco QueContenedor.Line -Step(-(QueControl.Width + X), 0), Color_Blanco End If End Sub
'----------------------------------------------------------------- 'Ejemplo para simular un toolbar al estilo de Office ( 5/Ago/97) '(c)Guillermo Som, 1997 '----------------------------------------------------------------- Option Explicit Dim nBoton As Integer 'Para controlar en que imagen se está Dim sTips() As String 'Nombres de los botones 'Constantes para lo botones Const cNuevo = 0 Const cAbrir = 1 Const cGuardar = 2 Const cCortar = 3 Const cCopiar = 4 Const cPegar = 5 Const cAcerca = 6 Const cSalir = 7 Private Sub Form_Load() ReDim sTips(0 To 7) sTips(0) = "Nuevo" sTips(1) = "Abrir" sTips(2) = "Guardar" sTips(3) = "Cortar" sTips(4) = "Copiar" sTips(5) = "Pegar" sTips(6) = "Acerca de" sTips(7) = "Salir" lblTip.Visible = False lblTip.Top = picTool.Height End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) QuitarBoton End Sub Private Sub imgTool_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) 'Si es el botón izquierdo... If Button = 1 Then 'Efecto de pulsado imgTool(Index).BorderStyle = 1 lblTip.Visible = False 'cargar la rutina correspondiente Accion Index 'quitar el efecto imgTool(Index).BorderStyle = 0 End If End Sub Private Sub imgTool_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If nBoton Then If nBoton <> Index + 1 Then picTool.Cls 'Borrar el efecto anterior Else 'Si estamos en el mismo botón, salir Exit Sub End If End If nBoton = Index + 1 'Dibujar el efecto "botón" Efecto3DN E3D_RAISED, picTool, imgTool(Index) lblStatus = "Está seleccionado el botón de " & sTips(Index) With lblTip .Caption = " " & sTips(Index) & " " .Left = imgTool(Index).Left .Visible = True End With End Sub Private Sub picTool_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) QuitarBoton End Sub Private Sub picTool_Resize() If WindowState <> vbMinimized Then 'Ajustar el tamaño de las líneas Line1(0).X2 = picTool.ScaleWidth Line1(1).X2 = Line1(0).X2 End If End Sub Private Sub mnuAcerca_Click() MsgBox "Programa de prueba de barra de botones al estilo Office 97" & vbCrLf & vbCrLf _ & "(c)Guillermo Som, 1997", vbInformation, "Pueba de botones" End Sub Private Sub mnuSalir_Click() Unload Me End End Sub 'Deberás poner en esta rutina tus propias acciones ' Private Sub Accion(Index As Integer) 'Según el índice, se ejecutará la acción correspondiente Select Case Index Case cNuevo 'Nuevo MsgBox "Has pulsado en " & sTips(Index) Case cAbrir 'Abrir MsgBox "Has pulsado en " & sTips(Index) Case cGuardar 'guardar MsgBox "Has pulsado en " & sTips(Index) Case cCortar 'Cortar MsgBox "Has pulsado en " & sTips(Index) Case cCopiar 'Copiar MsgBox "Has pulsado en " & sTips(Index) Case cPegar 'Pegar MsgBox "Has pulsado en " & sTips(Index) Case cAcerca mnuAcerca_Click Case cSalir 'Salir mnuSalir_Click End Select End Sub Private Sub QuitarBoton() 'Quitar el efecto del botón y el ToolTip If nBoton Then picTool.Cls End If nBoton = 0 lblStatus = "" lblTip.Visible = False End Sub
NUEVO:
He añadido otro ejemplo, usando una clase para simular el objeto que se pasa a la rutina de Efecto3D.
De esta forma se puede indicar un tamaño y posición diferente del que tiene el control Imagen usado para hacer de botón. Esto lo he hecho, porque los dibujos que tengo, están "justillos" y quedaba un poco "feos" al hacerle el efecto 3D.
También he añadido una nueva opción a la rutina Efecto3DN de forma que "quite" el efecto que antes se dibujó, con esto se consigue que no parpadee tanto la barra de botones al hacer CLS al picture contenedor.La clase contiene las propiedades que se manipulan dentro de la rutina de efecto tridimensional, además de incluir el ToolTip de cada botón.
Se pueden añadir más propiedades a la clase, por ejemplo el Picture que debe mostrar... es cuestión de buscarle la utilidad.Para bajar los listados del segundo ejemplo, pulsa en este link (botones2.zip 5.06 KB)
La rutina que hace el efecto 3D
La clase para simular el objeto
Option Explicit '-------------------------------------------------- 'Efecto 3D (nueva versión) ( 5/Nov/94) ' Usando Container en lugar de Parent ( 3/Sep/96) ' Revisado ( 6/Ago/97) '-------------------------------------------------- Global Const E3D_QUITAR = 0 Global Const E3D_INSET = 1 Global Const E3D_RAISED = 2 Sub Efecto3DN(QueEfecto As Integer, QueContenedor As Control, Optional QueControl) '------------------------------------------------------ 'Explicación de los parámetros a pasar: ' QueEfecto Puede tener los valores: E3D_INSET o E3D_RAISED (tipo botón) ' ( 9/Nov/94) Si QueEfecto > 10 DrawWidth=2... ' QueContenedor Si el contenedor es una Forma, se pondrá el mismo control, ' sino se pone el control contenedor de QueControl ' QueControl Control al que se le hará el efecto 3D ' (10/Nov/95) QueControl es opcional, usandose Quecontenedor '------------------------------------------------------ Dim X As Long, Y As Long Dim CurrentX As Integer, CurrentY As Integer Dim Color_Gris As Long, Color_Blanco As Long Dim Ltmp As Long Dim Bevel As Integer If IsMissing(QueControl) Then Set QueControl = QueContenedor End If Color_Gris = RGB(92, 92, 92) Color_Blanco = RGB(255, 255, 255) 'Ancho de la línea Bevel = 1 Do While QueEfecto > 10 QueEfecto = QueEfecto - 10 Bevel = Bevel + 1 Loop If QueEfecto = E3D_RAISED Then 'Estilo Command Ltmp = Color_Gris Color_Gris = Color_Blanco Color_Blanco = Ltmp ElseIf QueEfecto = E3D_QUITAR Then 'Quitar el dibujo ( 6/Ago/97) Color_Gris = QueControl.Container.BackColor Color_Blanco = QueControl.Container.BackColor End If X = Screen.TwipsPerPixelX Y = Screen.TwipsPerPixelY CurrentX = QueControl.Left - X CurrentY = QueControl.Top + QueControl.Height 'Si se dibuja un Frame... (13/Nov/94) If TypeOf QueControl Is Frame Then Y = Y - 120 End If If QueContenedor Is QueControl Then With QueControl .Container.DrawWidth = Bevel .Container.Line (CurrentX, CurrentY)-(CurrentX, CurrentY), Color_Gris .Container.Line -Step(0, -(.Height + Y)), Color_Gris .Container.Line -Step(.Width + X, 0), Color_Gris .Container.Line -Step(0, .Height + Y), Color_Blanco .Container.Line -Step(-(.Width + X), 0), Color_Blanco End With Else QueContenedor.DrawWidth = Bevel QueContenedor.Line (CurrentX, CurrentY)-(CurrentX, CurrentY), Color_Gris QueContenedor.Line -Step(0, -(QueControl.Height + Y)), Color_Gris QueContenedor.Line -Step(QueControl.Width + X, 0), Color_Gris QueContenedor.Line -Step(0, QueControl.Height + Y), Color_Blanco QueContenedor.Line -Step(-(QueControl.Width + X), 0), Color_Blanco End If End Sub
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "cControl" Attribute VB_Creatable = False Attribute VB_Exposed = False '-------------------------------------------------------------- 'Clase para usar con Efecto3DN ( 6/Ago/97) ' '(c)Guillermo Som, 1997 '-------------------------------------------------------------- Option Explicit 'Propiedades del objeto: Private objContainer As Object Private objParent As Object Private iLeft As Integer Private iTop As Integer Private iHeight As Integer Private iWidth As Integer Private sToolTip As String Public Property Get Parent() As Object Set Parent = objParent End Property Public Property Get Container() As Object 'Devuelve un puntero al objeto contenedor Set Container = objContainer End Property Public Property Set Parent(vNewParent As Object) Set objParent = vNewParent End Property Public Property Set Container(vNewContainer As Object) Set objContainer = vNewContainer End Property Public Property Get Width() As Variant Width = iWidth End Property Public Property Get Top() As Variant Top = iTop End Property Public Property Get ToolTip() As Variant ToolTip = sToolTip End Property Public Property Get Left() As Variant Left = iLeft End Property Public Property Get Height() As Variant Height = iHeight End Property Public Property Let Width(vNewWidth As Variant) iWidth = CInt(vNewWidth) End Property Public Property Let Top(vNewTop As Variant) iTop = CInt(vNewTop) End Property Public Property Let ToolTip(vNewTip As Variant) sToolTip = " " & CStr(vNewTip) & " " End Property Public Property Let Left(vNewLeft As Variant) iLeft = CInt(vNewLeft) End Property Public Property Let Height(vNewHeight As Variant) iHeight = CInt(vNewHeight) End Property
'----------------------------------------------------------------- 'Ejemplo para simular un toolbar al estilo de Office ( 5/Ago/97) 'Revisado con el uso de una clase y una colección ( 6/Ago/97) ' '(c)Guillermo Som, 1997 '----------------------------------------------------------------- Option Explicit Dim Botones As New Collection Dim nBoton As Integer 'Para controlar en que imagen se está 'Constantes para lo botones Const cNuevo = 0 Const cAbrir = 1 Const cGuardar = 2 Const cCortar = 3 Const cCopiar = 4 Const cPegar = 5 Const cAcerca = 6 Const cSalir = 7 Private Sub Form_Load() InicializarBotones Botones(1).ToolTip = "Nuevo" Botones(2).ToolTip = "Abrir" Botones(3).ToolTip = "Guardar" Botones(4).ToolTip = "Cortar" Botones(5).ToolTip = "Copiar" Botones(6).ToolTip = "Pegar" Botones(7).ToolTip = "Acerca de" Botones(8).ToolTip = "Salir" lblTip.Visible = False lblTip.Top = picTool.Height + picTool.Top + 60 End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) QuitarBoton End Sub Private Sub imgTool_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) 'Si es el botón izquierdo... If Button = 1 Then 'Efecto de pulsado imgTool(Index).BorderStyle = 1 lblTip.Visible = False 'cargar la rutina correspondiente Accion Index 'quitar el efecto imgTool(Index).BorderStyle = 0 End If End Sub Private Sub imgTool_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If nBoton Then If nBoton <> Index + 1 Then 'Borrar el efecto anterior Efecto3DN E3D_QUITAR, picTool, Botones(nBoton) Else 'Si estamos en el mismo botón, salir Exit Sub End If End If nBoton = Index + 1 'Dibujar el efecto "botón" Efecto3DN E3D_RAISED, picTool, Botones(nBoton) lblStatus = "Está seleccionado el botón de " & Botones(nBoton).ToolTip With lblTip .Caption = Botones(nBoton).ToolTip .Left = Botones(nBoton).Left + 60 .Visible = True End With End Sub Private Sub mnuAcerca_Click() MsgBox "Programa de prueba de barra de botones al estilo Office 97" & vbCrLf & vbCrLf & "(c)Guillermo Som, 1997", vbInformation, "Pueba de botones" End Sub Private Sub mnuSalir_Click() Unload Me End End Sub Private Sub picStatus_Resize() If WindowState <> vbMinimized Then lblStatus.Width = picStatus.ScaleWidth End If End Sub Private Sub picTool_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) QuitarBoton End Sub Private Sub Accion(Index As Integer) 'Según el índice, se ejecutará la acción correspondiente Select Case Index Case cNuevo 'Nuevo MsgBox "Has pulsado en " & Botones(Index).ToolTip Case cAbrir 'Abrir MsgBox "Has pulsado en " & Botones(Index).ToolTip Case cGuardar 'guardar MsgBox "Has pulsado en " & Botones(Index).ToolTip Case cCortar 'Cortar MsgBox "Has pulsado en " & Botones(Index).ToolTip Case cCopiar 'Copiar MsgBox "Has pulsado en " & Botones(Index).ToolTip Case cPegar 'Pegar MsgBox "Has pulsado en " & Botones(Index).ToolTip Case cAcerca mnuAcerca_Click Case cSalir 'Salir mnuSalir_Click End Select End Sub Private Sub picTool_Resize() If WindowState <> vbMinimized Then 'Ajustar el tamaño de las líneas Line1(0).X2 = picTool.ScaleWidth Line1(1).X2 = Line1(0).X2 End If End Sub Private Sub QuitarBoton() 'Quitar el efecto del botón y el ToolTip If nBoton Then 'borrar el efecto anterior Efecto3DN E3D_QUITAR, picTool, Botones(nBoton) End If nBoton = 0 lblStatus = "" lblTip.Visible = False End Sub Private Sub InicializarBotones() 'Inicializar los controles de las imagenes Dim i As Integer Dim mBoton As New cControl 'Hacer un bucle en todos los ImgTool For i = 0 To 7 Set mBoton = Nothing With mBoton Set .Container = imgTool(i).Container Set .Parent = imgTool(i).Parent 'Estas son las coordenadas para el efecto 3D .Left = imgTool(i).Left - 15 .Top = imgTool(i).Top - 15 .Width = imgTool(i).Width + 30 .Height = imgTool(i).Height + 30 'Añadir a la colección de botones Botones.Add mBoton End With Next End Sub