,
,
, ToolTip.
-----------------------------------------------------------
ToolTip , .
,
,
.
.
Option Compare Database
Private Type tRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'-----------------------------
Private Type TToolInfo
cbSize As Long
uFlags As Long
hwnd As Long
uId As Long
rect As tRect
hinst As Long
lpszText As String
lParam As Long
End Type
'-----------------------------
Private Const WM_USER As Long = &H400
Private Const TTM_ADDTOOLA As Long = WM_USER + 4
Private Const TTM_TRACKACTIVATE As Long = WM_USER + 17
Private Const TTM_TRACKPOSITION As Long = WM_USER + 18
Private Const TTM_SETTITLE As Long = WM_USER + 32
Private Const TTS_NOPREFIX As Long = &H2
Private Const TTS_BALLOON As Long = &H40
Private Const TTF_TRACK As Long = &H20
Private Const TTI_INFO As Long = 1
Private Const TTS_CLOSE As Long = &H80
'-----------------------------
Private Const FTooltipClassName As String = "tooltips_class32"
Private FHandle As Long
Private FToolInfo As TToolInfo
Private Const GWL_WNDPROC = (-4)
Private Const GWL_HINSTANCE = (-6)
Private Const WS_EX_TOPMOST As Long = &H8&
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As tRect) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As tRect) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, lp As Any) As Long
'----------------------------------------
Private Sub 1_Click()
Dim hWndParent As Long
Dim hInstance As Long
Dim EditRect As tRect
Const TooltipText As String = " "
Const TooltipTitle As String = ""
' , tooltip
Call 1.SetFocus
hWndParent = GetFocus()
' tooltip'
hInstance = GetWindowLong(Application.hWndAccessApp, GWL_HINSTANCE)
FHandle = CreateWindowEx(WS_EX_TOPMOST, _
FTooltipClassName, 0&, _
TTS_NOPREFIX Or TTS_BALLOON Or TTS_CLOSE, _
0, 0, 0, 0, hWndParent, 0, hInstance, 0) ' Or TTS_CLOSE,
With FToolInfo
.cbSize = Len(FToolInfo)
.uFlags = TTF_TRACK
.hwnd = hWndParent
Call GetClientRect(.hwnd, .rect)
.rect.Top = 500
.rect.Bottom = .rect.Top + 100
.lpszText = TooltipText
End With
Call SendMessage(FHandle, TTM_ADDTOOLA, 0, FToolInfo)
Call SendMessage(FHandle, TTM_SETTITLE, TTI_INFO, ByVal TooltipTitle)
' tooltip
Call GetWindowRect(hWndParent, EditRect)
Call SendMessage(FHandle, TTM_TRACKPOSITION, 0, ByVal (EditRect.Left + 1) Or ((EditRect.Top + 1) * 65536))
Call SendMessage(FHandle, TTM_TRACKACTIVATE, True, FToolInfo)
End Sub
http://www.sql.ru/forum/1126745/tooltip-zakryt-programmno
