ToolTips Usando un Form en Access

Para hacerlo he usado varias APIs

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

** 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)