ToolTips Usando un Form en Access

Me comenta un amigo.... Es posible crear tooltips usando un Form en Access...?
 
Si, la respuesta es que si... Un poco laborioso pero posible.
 
Ya sabemos (y para los que no sabian) que para crear tooltips, tendriamos que recurrir a la Api
 
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, _
ByVal hInstance As Long, lpParam As Any) As Long
 
Pero para hacerlo usando un form, que nos sirva como ToolTips y que Ademas no sea como el predeterminado de Access (que solo acepta hasta 255 caracteres y ademas que solo nos presenta el Tips de forma lineal) Ojo el del "API CreateWindowEx" tambien hace lo mismo
 
 
 
Para hacerlo he usado varias APIs
 
 
 
 
 
 
** EL CODIGO **
Option Compare Database
Option Explicit
'***************************************************************
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&               Jefferson Jimenez (JJJT)                     &*
'&                 Cabimas - Venezuela                        &*
'&                    Junio - 2010                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'***************************************************************
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
 
Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * 32
End Type
Private Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type
Private Type POINTAPI
         X_Pos As Long
         Y_Pos As Long
End Type
'Declaramos las APIs necesarias para crear estos tooltips con Form
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" _
                                                            (ByVal hDC As Long, _
                                                            lpMetrics As TEXTMETRIC) As Long
Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" _
                                                            (lpLogFont As LOGFONT) As Long
Private Declare Function apiSelectObject Lib "gdi32" Alias "SelectObject" _
                                                            (ByVal hDC As Long, _
                                                            ByVal hObject As Long) As Long
                                                           
Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" _
                                                            (ByVal hObject As Long) As Long
                                                           
Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
                                                            (ByVal hDC As Long, _
                                                            ByVal nIndex As Long) As Long
Private Declare Function apiGetDC Lib "user32" Alias "GetDC" _
                                                            (ByVal hwnd As Long) As Long
Private Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" _
                                                            (ByVal hwnd As Long, _
                                                            ByVal hDC As Long) As Long
Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" _
                                                            (ByVal hDC As Long, _
                                                            ByVal lpStr As String, _
                                                            ByVal nCount As Long, _
                                                            lpRect As RECT, _
                                                            ByVal wFormat As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
                                                    (lpPoint As POINTAPI) As Long
Private Declare Function AbreFrmTool Lib "user32" Alias "MoveWindow" _
                                                            (ByVal hwnd As Long, _
                                                            ByVal X As Long, _
                                                            ByVal Y As Long, _
                                                            ByVal nWidth As Long, _
                                                            ByVal nHeight As Long, _
                                                            ByVal bRepaint As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _
                                                            ByVal nIDEvent As Long, _
                                                            ByVal uElapse As Long, _
                                                            ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, _
                                                            ByVal nIDEvent As Long) As Long
'Declaramos las variables
Dim VarTools                               As String
Dim CtlHeight                              As Long
Dim CtlWidth                               As Long
Dim frmHwnD1                               As Long
Dim ImgTool                                As String
Dim Color                                  As Long
Dim CtLSet                                 As Control
Dim frmX                                   As Long
Dim frmY                                   As Long
Dim FrmTools                               As Form
Const Ico                                  As String = "C:\WINDOWS\Web\*.gif"
Function AbreTool(frm As Form, _
                  ctl As Control, _
                  StrTool As String, _
                  Optional Duracion As Long = 3, _
                  Optional FTools As String = "ToolTips", _
                  Optional ImgIcono As String = Ico _
                  )
'Asigno valor a ciertas variables
VarTools = StrTool: Color = frm.Detalle.BackColor: ImgTool = ImgIcono
               'Busco las coordenadas del mouse
                Dim mouse As POINTAPI
                    GetCursorPos mouse
                      frmX = mouse.X_Pos + 1
                      frmY = mouse.Y_Pos + 1
 On Error Resume Next
     'Cargo el coontrol del MouseMove
      Set CtLSet = ctl
    'Al hacer click sobre el campo llamo la funcion que cierra el form ToolTips
           DestroyedFocus
          'Creo la  variable estatica del control sobre el que pasa el mouse
              Static CtlViejo As String
              'Si vuelvo a pasar el mouse sobre el mismo campo detengo la funcion
                  If CtlViejo = CtLSet.Name Then Exit Function
                  'Si todo esta bien abro el form
                     DoCmd.OpenForm FTools
               'Establezco el activo del ToolTips
             Set FrmTools = Forms.Item(FTools)
            'Cargo al campo TxtTools segun la cantidad del texto que le agregemos el ancho y alto del mismo
                  CargaTextHeightFrm
                 'Usando la API MoveWindow abro el form ToolTips situandolo segun las coordenadas del Mouse
                          Call AbreFrmTool(frmHwnD1, frmX, frmY, CtlWidth, CtlHeight, 1)
                      'Activo el Timer segun la duracion que le coloquemos, para cerrar el form ToolTips
                    SetTimer frmHwnD1, 0, Duracion * 1000, AddressOf TimerProc
           'Le cargo a la variable el control activo
     CtlViejo = CtLSet.Name
      'Asesino la Altura del control
    CtlHeight = 0
    'Asesino el Ancho del control
   CtlWidth = 0
 'Desactivo el control
ctl = Nothing
End Function
Function DestroyedFocus()
Dim CtlFocus As Control
         Set CtlFocus = Screen.ActiveControl 'Al activar (Click) el control del form hijo
        'detengo la funcion al comparar que se trate del mismo del CtlSet del form ToolTips
     If CtlFocus.Name = CtLSet.Name Then DoCmd.Close acForm, FrmTools.Name: Exit Function
  CtlFocus = Nothing 'Lo desactivo
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _
              ByVal uElapse As Long, ByVal lpTimerFunc As Long)
       KillTimer frmHwnD1, 0 'Al cumplir el tiempo asesino el timer
       DoCmd.Close acForm, FrmTools.Name 'Y de paso cierro el form ToolTips
End Sub
'Esta es una funcion de Stephen Lebans
'Donde nos devuelve la Altura y Ahcho de un Control TextBox, segun los caracteres
'incluidos en él
'Claro la funcion original no es esta, pues la he depurado y ajustado a mis nececidades
'si deseas ver la funcion original en la pagina de Lebans puedes descargartela
'http://www.lebans.com/textwidth-height.htm
 Public Function fTextHeight(ctl As Control, _
                            Optional ByVal sText As String = "", _
                            Optional HeightTwips As Long = 0, _
                            Optional WidthTwips As Long = 0, _
                            Optional TotalLines As Long = 0, _
                            Optional TwipsPerPixel As Long = 0 _
                            ) As Long
 Dim hDC, lngDPI, newfont, oldfont, lngRet, lngLineSpacing, numLines, sngTemp1, sngTemp2 As Long
 Dim sRect As RECT: Dim myfont As LOGFONT: Dim tm As TEXTMETRIC: Dim strName As String
                          hDC = apiGetDC(0&)
  If TypeOf ctl Is TextBox Then
     sText = Nz(ctl.Value, vbNullString)
  End If
                         lngDPI = apiGetDeviceCaps(hDC, 90)
                         TwipsPerPixel = 1440 / lngDPI
     myfont.lfClipPrecision = 16
     myfont.lfOutPrecision = 7
     myfont.lfEscapement = 0
     myfont.lfFaceName = ctl.FontName & Chr$(0)
     myfont.lfWeight = ctl.FontWeight
     myfont.lfItalic = ctl.FontItalic
     myfont.lfUnderline = ctl.FontUnderline
     myfont.lfHeight = (ctl.FontSize / 72) * -lngDPI
                        newfont = apiCreateFontIndirect(myfont)
                        oldfont = apiSelectObject(hDC, newfont)
     sRect.Left = 0
     sRect.Top = 0
     sRect.Bottom = 0
     sRect.Right = (ctl.Width / (1440 / lngDPI)) - 10
lngRet = apiDrawText(hDC, sText, -1, sRect, &H400 Or &H0 Or &H0 Or &H10 Or &H200 Or &H2000& Or &H100)
      lngRet = GetTextMetrics(hDC, tm)
            lngRet = apiSelectObject(hDC, oldfont)
                 apiDeleteObject (newfont)
                        lngRet = apiReleaseDC(0&, hDC)
                                TotalLines = sRect.Bottom / (tm.tmHeight + tm.tmExternalLeading)
                         numLines = TotalLines
                 sRect.Bottom = (sRect.Bottom) * (1440 / lngDPI)
            HeightTwips = sRect.Bottom
      WidthTwips = sRect.Right * (1440 / lngDPI)
fTextHeight = HeightTwips
End Function
'Ya esta es Vieja (verifico que algun archivo nombrado exista)
Function JJJT_ExisteDir(ByVal Ruta As String) As Boolean
  On Error Resume Next
        JJJT_ExisteDir = (GetAttr(Ruta) And vbNormal) = vbNormal
  Err.Clear
End Function
'Con esta funcion lo que hice fue asignarle la altura y ancho del textbox al form ToolTips
Sub CargaTextHeightFrm()
'Cargo las variables y busco el Hwnd del Form ToolTips
FrmTools.TxtTools = VarTools: frmHwnD1 = FrmTools.hwnd
'Comprueba exista el archivo imagen
If JJJT_ExisteDir(ImgTool) = True Then
        FrmTools.Img.Picture = ImgTool
     ElseIf JJJT_ExisteDir("C:\WINDOWS\Web\" & Dir(Ico)) = True Then
        FrmTools.Img.Picture = "C:\WINDOWS\Web\" & Dir(Ico)
     Else
        FrmTools.Img.Picture = ""
End If
           'Le doy el color de fondo al toolTips, segun se lo pase el Form Hijo
            FrmTools.Detalle.BackColor = Color
            'Establezco las variables para usar la funcion de Lebans
            Dim lngWidth As Long, lngHeight As Long, lngTotalLines As Long, lngRet As Long
            Dim lngTopMargin As Long
            lngTopMargin = 60
    'Segun la cantidad de caracteres busco abrir el form ToolTips que mas se le asemeje
 Select Case Len(VarTools)
            Case Is < 10
                lngRet = fTextHeight(FrmTools.TxtTools, , lngHeight, lngWidth, lngTotalLines)
                FrmTools.TxtTools.Height = lngHeight + lngTopMargin
                FrmTools.TxtTools.Width = 150 * Len(VarTools)
                CtlHeight = FrmTools.TxtTools.Height / 7.5
                CtlWidth = FrmTools.TxtTools.Width / 7.5
            Case Is < 30
                lngRet = fTextHeight(FrmTools.TxtTools, , lngHeight, lngWidth, lngTotalLines)
                FrmTools.TxtTools.Height = lngHeight + lngTopMargin
                FrmTools.TxtTools.Width = 120 * Len(VarTools)
                CtlHeight = FrmTools.TxtTools.Height / 7.5
                CtlWidth = FrmTools.TxtTools.Width / 7.5
            Case Is < 50
                lngRet = fTextHeight(FrmTools.TxtTools, , lngHeight, lngWidth, lngTotalLines)
                FrmTools.TxtTools.Height = lngHeight + lngTopMargin
                FrmTools.TxtTools.Width = 3500
                CtlHeight = FrmTools.TxtTools.Height / 10.5
                CtlWidth = FrmTools.TxtTools.Width / 10
            Case Is < 150
                lngRet = fTextHeight(FrmTools.TxtTools, , lngHeight, lngWidth, lngTotalLines)
                FrmTools.TxtTools.Height = lngHeight + lngTopMargin
                FrmTools.TxtTools.Width = 3500
                CtlHeight = FrmTools.TxtTools.Height / 12.3
                CtlWidth = FrmTools.TxtTools.Width / 11.85
            Case Is < 250
                lngRet = fTextHeight(FrmTools.TxtTools, , lngHeight, lngWidth, lngTotalLines)
                FrmTools.TxtTools.Height = lngHeight + lngTopMargin
                FrmTools.TxtTools.Width = 3500
                CtlHeight = FrmTools.TxtTools.Height / 13.6
                CtlWidth = FrmTools.TxtTools.Width / 11.85
            Case Is < 500
                lngRet = fTextHeight(FrmTools.TxtTools, , lngHeight, lngWidth, lngTotalLines)
                FrmTools.TxtTools.Height = lngHeight + lngTopMargin
                FrmTools.TxtTools.Width = 3500
                CtlHeight = FrmTools.TxtTools.Height / 14.6
                CtlWidth = FrmTools.TxtTools.Width / 11.85
            End Select
End Sub

 
SelectionFile type iconFile nameDescriptionSizeRevisionTimeUser
ċ
Descargar		 Descargue el Ejemplo   186 kb v. 1 23 jun. 2010 20:24 Jefferson Jimenez
Comments