|
|
|
|
|
Code des Controls ListToolTip
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetClientRect Lib "User32" _
(ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "User32" _
(lpPoint As POINTAPI) As Long
Private Declare Function GetDesktopWindow Lib "User32" _
() As Long
Private Declare Function GetParent Lib "User32" _
(ByVal hWnd As Long) As Long
Private Declare Function GetWindowLong Lib "User32" _
Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) _
As Long
Private Declare Function GetWindowRect Lib "User32" _
(ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetParent Lib "User32" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowLong Lib "User32" _
Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Any) As Long
Private Declare Function SetWindowPos Lib "User32" _
(ByVal hWnd As Long, ByVal Order As Long, ByVal X As Long, _
ByVal Y As Long, ByVal cX As Long, ByVal cY As Long, _
ByVal Flags As Long) As Long
Private Declare Function WindowFromPoint Lib "User32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_TOOLWINDOW = &H80
Private Const LB_GETITEMHEIGHT = &H1A1
Private Const LB_ITEMFROMPOINT = &H1A9
Private Const SWP_NOACTIVATE = &H10
Private Const HWND_TOPMOST = -1
Private mParentWnd As Long
Private mDesktopWindow As Long
Private WithEvents eListBox As ListBox
Public Event InitDone(ByVal Success As Boolean)
Private pListBox As String
Private pNoButton As Boolean
Public Property Get ListBox() As String
zFindListBox
ListBox = pListBox
End Property
Public Property Let ListBox(ByVal New_ListBox As String)
If Ambient.UserMode Then
pListBox = New_ListBox
zSetListBoxControl
End If
End Property
Public Property Set ListBox(New_ListBox As Object)
Dim nSuccess As Boolean
If Ambient.UserMode Then
pListBox = ""
If TypeOf New_ListBox Is ListBox Then
With New_ListBox
If .Container Is Extender.Container Then
On Error Resume Next
Set eListBox = New_ListBox
nSuccess = Not (eListBox Is Nothing)
If nSuccess Then
pListBox = .Name
RaiseEvent InitDone(nSuccess)
Else
Set eListBox = Nothing
End If
Else
End If
End With
End If
End If
End Property
Public Property Get NoButton() As Boolean
NoButton = pNoButton
End Property
Public Property Let NoButton(ByVal New_NoButton As Boolean)
pNoButton = New_NoButton
PropertyChanged "NoButton"
End Property
Public Function FindListBox() As Object
zFindListBox
Set FindListBox = eListBox
End Function
Private Sub eListBox_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Dim nXPoint As Long
Dim nYPoint As Long
Dim nIndex As Long
Dim nItemHeight As Long
Dim nLeft As Long
Dim nTop As Long
Dim nWidth As Long
Dim nHeight As Long
Dim nTopOffset As Integer
Dim nLeftOffset As Integer
Dim nRect As RECT
Dim nToolTip As String
If Button Then
If pNoButton Then
zHideToolTip
Exit Sub
End If
End If
nXPoint = X / Screen.TwipsPerPixelX
nYPoint = Y / Screen.TwipsPerPixelY
With eListBox
nIndex = SendMessage(.hWnd, LB_ITEMFROMPOINT, 0, _
nYPoint * 65536 + nXPoint)
Select Case nIndex
Case 0 To .ListCount - 1
nToolTip = .List(nIndex)
Set UserControl.Font = .Font
nWidth = UserControl.TextWidth(nToolTip)
GetClientRect .hWnd, nRect
If nRect.Right - nRect.Left < nWidth Then
GetWindowRect .hWnd, nRect
If .Appearance = 1 Then '3D
nLeftOffset = 1
nTopOffset = 1
End If
nItemHeight = SendMessage(.hWnd, LB_GETITEMHEIGHT,0,0)
nTop = nRect.Top + (nIndex - .TopIndex) _
* nItemHeight + nTopOffset
nLeft = nRect.Left + nLeftOffset
With UserControl
nWidth = nWidth + .TextWidth(" ")
nHeight = .TextHeight("A") + 3
With Screen
If nLeft + nWidth > .Width \ .TwipsPerPixelX Then
nLeft = (.Width \ .TwipsPerPixelX) - nWidth
End If
If nTop + nHeight > .Height \ .TwipsPerPixelY Then
nTop = (.Height \ .TwipsPerPixelY) - nHeight
End If
End With
If GetParent(.hWnd) <> mDesktopWindow Then
SetParent .hWnd, mDesktopWindow
End If
SetWindowPos .hWnd, HWND_TOPMOST, nLeft, nTop, _
nWidth, nHeight, SWP_NOACTIVATE
.AutoRedraw = True
.Cls
UserControl.Line (0, 0)-Step(.ScaleWidth - 1, _
.ScaleHeight - 1), vbInfoText, B
.CurrentX = 3
.CurrentY = 1
UserControl.Print nToolTip
Extender.Visible = True
End With
tmrHide.Enabled = True
Else
zHideToolTip
End If
Case Else
zHideToolTip
End Select
End With
End Sub
Private Sub tmrSetListBox_Timer()
tmrSetListBox.Enabled = False
zSetListBoxControl
End Sub
Private Sub tmrHide_Timer()
Dim nPoint As POINTAPI
Dim nWnd As Long
GetCursorPos nPoint
nWnd = WindowFromPoint(nPoint.X, nPoint.Y)
Select Case nWnd
Case UserControl.hWnd, eListBox.hWnd
Case Else
zHideToolTip
End Select
End Sub
Private Sub UserControl_Paint()
If Not Ambient.UserMode Then
With UserControl
UserControl.Line (.ScaleWidth \ 2, 0)-Step(0, _
.ScaleHeight), vbBlue
UserControl.Line (0, .ScaleHeight \ 2)-Step(.ScaleWidth, _
0), vbBlue
UserControl.Line (0, 0)-(.ScaleWidth - 1, _
.ScaleHeight - 1), vbInfoText, B
End With
End If
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim nWindowLong As Long
pListBox = PropBag.ReadProperty("ListBox", "")
pNoButton = PropBag.ReadProperty("NoButton", False)
If Ambient.UserMode Then
With UserControl
nWindowLong = GetWindowLong(.hWnd, GWL_EXSTYLE)
nWindowLong = nWindowLong Or WS_EX_TOOLWINDOW
SetWindowLong .hWnd, GWL_EXSTYLE, nWindowLong
mParentWnd = GetParent(.hWnd)
.Enabled = False
End With
mDesktopWindow = GetDesktopWindow()
Extender.Visible = False
If Len(pListBox) Then
tmrSetListBox.Enabled = True
End If
End If
End Sub
Private Sub UserControl_Resize()
Static sInProc As Boolean
If sInProc Then
Exit Sub
Else
sInProc = True
End If
If Not Ambient.UserMode Then
With UserControl
.Size 1.5 * .TextHeight("A") * Screen.TwipsPerPixelX, _
1.5 * .TextHeight("A") * Screen.TwipsPerPixelY
End With
End If
sInProc = False
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "ListBox", pListBox, ""
PropBag.WriteProperty "NoButton", pNoButton, False
End Sub
Private Sub zHideToolTip()
tmrHide.Enabled = False
Extender.Visible = False
With UserControl
SetParent .hWnd, mParentWnd
.Cls
.AutoRedraw = False
End With
End Sub
Private Sub zFindListBox()
Dim nControl As Control
Dim nLeft As Single
Dim nTop As Single
If Not Ambient.UserMode Then
pListBox = ""
With Extender
nLeft = .Left + (.Width \ 2)
nTop = .Top + (.Height \ 2)
End With
On Error Resume Next
For Each nControl In UserControl.Parent.Controls
If TypeOf nControl Is ListBox Then
With nControl
If .Container Is Extender.Container Then
Select Case nLeft
Case .Left To .Left + .Width
Select Case nTop
Case .Top To .Top + .Height
If .Index < 0 Then
pListBox = .Name
If Ambient.UserMode Then
zSetListBoxControl
End If
Exit For
End If
End Select
End Select
End If
End With
End If
Next
Extender.ZOrder 0
End If
End Sub
Private Sub zSetListBoxControl()
Dim nControl As Control
Dim nSuccess As Boolean
Set eListBox = Nothing
On Error Resume Next
For Each nControl In UserControl.Parent.Controls
With nControl
If .Container Is Extender.Container Then
If .Name = pListBox Then
Set eListBox = nControl
nSuccess = Not (eListBox Is Nothing)
RaiseEvent InitDone(nSuccess)
If nSuccess Then
Exit For
End If
End If
End If
End With
Next
pListBox = ""
End Sub
|