ToolTips

26/07/2016 - 15:50 von Lothar Geyer | Report spam
Ich habe mir vor langer Zeit ein Modul zum Erstellen von mehrzeiligen
Tooltips geladen. Wo ich das her habe, weiß ich aber nicht mehr.

Das funktioniert auch so weit ganz gut. Es hat nur einen Nachteil: die
Tooltips werden auch dann angezeigt, wenn das Control, für das ein
Tooltip angezeigt werden soll, im Hintergrund - also "unter" einer
anderen Maske - und daher nicht sichtbar ist.

Wie kann ich das abfragen, ob das Control sichtbar ist? Am besten wàre
natürlich, wenn ich auch feststellen könnte, ob eine bestimmte Zelle
eines Grids sichtbar ist.

In dem Modul wird das Tooltip-Fenster mit folgenden Befehlen erzeugt:

hWndTT = CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, "", _
WS_POPUP Or flags, CW_USEDEFAULT, CW_USEDEFAULT, _
CW_USEDEFAULT, CW_USEDEFAULT, frm.hwnd, 0, App.hInstance, _
ByVal 0&)

SetWindowPos hWndTT, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or _
SWP_NOSIZE Or SWP_NOACTIVATE

Lothar Geyer
 

Lesen sie die antworten

#1 Dieter Strassner
27/07/2016 - 09:27 | Warnen spam
hallo Lothar,


Ich habe mir vor langer Zeit ein Modul zum Erstellen von mehrzeiligen
Tooltips geladen. Wo ich das her habe, weiß ich aber nicht mehr.



vermutlch wo ich es auch her habe (Quellenangabe steht unten im
Sourcecode)


Das funktioniert auch so weit ganz gut. Es hat nur einen Nachteil: die
Tooltips werden auch dann angezeigt, wenn das Control, für das ein
Tooltip angezeigt werden soll, im Hintergrund - also "unter" einer
anderen Maske - und daher nicht sichtbar ist.

Wie kann ich das abfragen, ob das Control sichtbar ist? Am besten wàre
natürlich, wenn ich auch feststellen könnte, ob eine bestimmte Zelle
eines Grids sichtbar ist.



Das Problem kann ich nicht nachvollziehen. Sehe aber auf Anhieb auch
keine Stelle, in der das explizit abgefragt/behandelt wird.

Vergleich mal die Stelle in meiner Funktion "AddTool" mit deiner
Routine. Ich habe damals einen fehler korrigiert. Evtl. hàngt es damit
zusmammen. Die komplette Steuerung des Tooltip kann ich zwar auch online
stellen, die wirst Du aber nicht ohne weiteres verwenden können, da sie
sehr stark auf das Programm angepasst wurden.



Das ist meine Klasse clsToolTip:
______________________________________________

' *******************************************************
' ** **
' ** **
' ** Mehrzeiligen Tooltip anzeigen und verwalten **
' ** Autor: Copyright © 2000 Thomas Kabir **
' ** **
' ** **
' *******************************************************

' LEGENDE der Programmerweiterungen + Fehlerkorrekturen:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 17.11.2005 ds Balloon-ToolTip in Projekt aufgenommen
' 09.10.2014 ds Anzeigeproblem sobald der Manifester verwendet wurde,
sind behoben
' 09.10.2014 ds Umgestellt auf UniCode




' Noch Offen:
' ~~~~~~~~~~
' Einzeilige ToolTips werden noch ungünstig in 5-7 kurze
Zeilen umgebochen!





Option Explicit

Private hWndTT As Long
Private m_Enabled As Boolean
Private m_Icon As InfoTitleConstants
Private m_Title As String

Public Enum DelayTimeConstants
dtAutoPop = &H2
dtInitial = &H3
dtReShow = &H1
End Enum

Public Enum SetDelayTimeConstants
sdtAutoPop = &H2
sdtInitial = &H3
sdtReShow = &H1
sdtAutomatic = &H0
End Enum

Public Enum InfoTitleConstants
itNoIcon = 0
itInfoIcon = 1
itWarningIcon = 2
itErrorIcon = 3
End Enum

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type TOOLINFO
cbSize As Long
uFlags As Long
hWnd As Long
uId As Long
WinRect As RECT
hInst As Long
lpszText As String ' ToolTipText
lParam As Long
End Type

Private Declare Function CreateWindowEx Lib "user32" Alias
"CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long,
ByVal lpWindowName As Long, 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 Const WS_EX_TOPMOST = &H8&
Private Const TOOLTIPS_CLASS$ = "tooltips_class32"
Private Const WS_POPUP = &H80000000
Private Const CW_USEDEFAULT = &H80000000

Private Declare Function InitCommonControlsEx Lib "comctl32"
(lpInitCtrls As INITCOMMONCONTROLEXSTRUCT) As Long
Private Const ICC_WIN95_CLASSES = &HFF
Private Const ICC_BAR_CLASSES = &H4

Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long,
ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal
cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10

Private Declare Function SendMessage Lib "user32" Alias "SendMessageW"
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As
Any) As Long
Private Const WM_USER = &H400

Private Const TTM_ADDTOOL = WM_USER + 50
Private Const TTM_DELTOOL = WM_USER + 51
Private Const TTM_ENUMTOOLS = WM_USER + 58
Private Const TTM_HITTEST = WM_USER + 55
Private Const TTM_NEWTOOLRECT = WM_USER + 52
Private Const TTM_SETTITLE = WM_USER + 33
Private Const TTM_UPDATETIPTEXT = WM_USER + 57

Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_ADJUSTRECT = WM_USER + 31
Private Const TTM_GETTOOLCOUNT = WM_USER + 13
Private Const TTM_GETBUBBLESIZE = WM_USER + 30
Private Const TTM_GETDELAYTIME = WM_USER + 21
Private Const TTM_GETMARGIN = WM_USER + 27
Private Const TTM_GETMAXTIPWIDTH = WM_USER + 25
Private Const TTM_GETTIPBKCOLOR = WM_USER + 22
Private Const TTM_GETTIPTEXTCOLOR = WM_USER + 23
Private Const TTM_POP = WM_USER + 28
Private Const TTM_SETDELAYTIME = WM_USER + 3
Private Const TTM_SETMARGIN = WM_USER + 26
Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
Private Const TTM_SETTIPBKCOLOR = WM_USER + 19
Private Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
Private Const TTM_TRACKACTIVATE = WM_USER + 17
Private Const TTM_TRACKPOSITION = WM_USER + 18

Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long)
As Long
Private Const TTF_IDISHWND = &H1
Private Const TTF_SUBCLASS = &H10

Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias
"GetTextExtentPoint32W" (ByVal hdc As Long, ByVal lpString As Long,
ByVal cbString As Long, lpSize As Size) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(Destination As Any, Source As Any, ByVal Length As Long)

Public Enum TooltipFlagConstants
ttfAlwaysTip = &H1
ttfNoPrefix = &H2
ttfNoAnimate = &H10
ttfNoFade = &H20
ttfBalloon = &H40
End Enum

Public Enum ToolFlagConstants
tfCenterTip = &H2
tfRtlReading = &H4
tfTrack = &H20
tfAbsolute = &H80
tfTransparent = &H100
End Enum

Private Type INITCOMMONCONTROLEXSTRUCT
dwSize As Long
dwICC As Long
End Type

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Type TTHITTESTINFO
hWnd As Long
pt As POINTAPI
ti As TOOLINFO
End Type

Private Type OLECOLOR
RedOrSys As Byte
Green As Byte
Blue As Byte
Type As Byte
End Type
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long)
As Long
'
Const LWA_ALPHA = &H2&

Private Declare Function SetLayeredWindowAttributes Lib "user32" ( _
ByVal hWnd As Long, _
ByVal clrRef As Long, _
ByVal Alpha As Byte, _
ByVal flags As Long) As Long
'
Const GWL_STYLE = (-16)
Const GWL_USERDATA = (-21)
Const GWL_EXSTYLE = (-20)

Const WS_BORDER = &H800000
Const WS_EX_LAYERED = &H80000

Private Declare Function GetWindowLong Lib "user32" Alias
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal
dwNewLong As Long) As Long
'
Private m_byAlpha As Byte ' 09.10.2014 ds
Alpha-Blending für Balloon
'


Public Sub AddTool(ByRef Ctl As Control, _
ByRef CtlContainerhWnd As Long, _
ByRef flags As ToolFlagConstants, _
Optional ByRef Text As String)

Dim Info As TOOLINFO

If hWndTT <> 0 Then

Info.cbSize = Len(Info)
Info.uFlags = flags
If Not (flags And tfTrack) Then
Info.uFlags = Info.uFlags Or TTF_SUBCLASS
End If
Info.uFlags = Info.uFlags Or TTF_IDISHWND
'Info.hWnd = Ctl.Container.hWnd ' Orginal!!!!
'Info.hWnd = Ctl.hWnd ' damit lief Boollon-Tip, aber nicht altes
Format
Info.hWnd = CtlContainerhWnd
Info.hInst = App.hInstance
Info.uId = Ctl.hWnd
If Len(Text) > 0 Then
Info.lpszText = Text
End If
SendMessage hWndTT, TTM_ADDTOOL, 0, ByVal VarPtr(Info)

End If

End Sub

Public Sub Create(ByRef FormHwnd As Long, ByRef flags As
TooltipFlagConstants)

Dim InitCtrls As INITCOMMONCONTROLEXSTRUCT

InitCtrls.dwSize = Len(InitCtrls)
InitCtrls.dwICC = ICC_WIN95_CLASSES Or ICC_BAR_CLASSES Or 2 Or 8 '
2=TreeviewClass 8=???

Class_Terminate
m_Enabled = True
m_Icon = itNoIcon
m_Title = vbNullString

InitCommonControlsEx InitCtrls

hWndTT = CreateWindowEx(WS_EX_TOPMOST, StrPtr(TOOLTIPS_CLASS), 0,
WS_POPUP Or flags, _
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,
FormHwnd, 0, App.hInstance, ByVal 0&)

SetWindowPos hWndTT, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or
SWP_NOSIZE Or SWP_NOACTIVATE
End Sub


Public Sub DeleteTool(Ctl As Control)

Dim Info As TOOLINFO

If hWndTT <> 0 Then
Info = GetToolInfo(Ctl.hWnd)
If Info.cbSize <> 0 Then
SendMessage hWndTT, TTM_DELTOOL, 0, ByVal VarPtr(Info)
End If
End If

End Sub

Public Property Get Enabled() As Boolean

If hWndTT <> 0 Then
Enabled = m_Enabled
End If

End Property

Public Property Let Enabled(NewState As Boolean)

m_Enabled = NewState
If hWndTT <> 0 Then
SendMessage hWndTT, TTM_ACTIVATE, m_Enabled, ByVal 0&
End If

End Property

Public Function GetDelayTime(TimeMode As DelayTimeConstants) As Long

If hWndTT <> 0 Then
GetDelayTime = SendMessage(hWndTT, TTM_GETDELAYTIME, TimeMode, 0&)
End If

End Function

Public Property Get Icon() As InfoTitleConstants

If hWndTT <> 0 Then
Icon = m_Icon
End If

End Property

Public Function MakeLong(Int1 As Integer, Int2 As Integer) As Long

Dim Ints(1 To 2) As Integer

CopyMemory Ints(1), Int1, Len(Int1)
CopyMemory Ints(2), Int2, Len(Int2)
CopyMemory MakeLong, Ints(1), Len(MakeLong)

End Function

Public Sub SetTracking(Ctl As Control, Tracking As Boolean)

Dim Info As TOOLINFO

If hWndTT <> 0 Then

Info = GetToolInfo(Ctl.hWnd)
If Info.cbSize <> 0 Then
SendMessage hWndTT, TTM_TRACKACTIVATE, Tracking, ByVal VarPtr(Info)
End If

End If

End Sub

Public Sub SetTrackPosition(Ctl As Control, X As Integer, Y As Integer)

Dim Info As TOOLINFO

If hWndTT <> 0 Then

Info = GetToolInfo(Ctl.hWnd)
If Info.cbSize <> 0 Then
SendMessage hWndTT, TTM_TRACKPOSITION, 0, ByVal MakeLong(X, Y)
End If

End If

End Sub

Public Property Get Title() As String

If hWndTT <> 0 Then
Title = m_Title
End If

End Property

Public Property Let Icon(NewIcon As InfoTitleConstants)

If hWndTT <> 0 Then
m_Icon = NewIcon
SendMessage hWndTT, TTM_SETTITLE, m_Icon, ByVal StrPtr(m_Title)
End If

End Property

Public Property Let Title(NewTitle As String)

If hWndTT <> 0 Then
m_Title = NewTitle
SendMessage hWndTT, TTM_SETTITLE, m_Icon, ByVal StrPtr(m_Title)
End If

End Property

Public Sub SetDelayTime(TimeMode As SetDelayTimeConstants, Time As Long)

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_SETDELAYTIME, TimeMode, ByVal Time
End If

End Sub

Public Sub HideTips()

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_POP, 0, ByVal 0&
End If

End Sub

Public Function HitTest(Ctl As Control, X As Long, Y As Long) As Boolean

Dim Info As TTHITTESTINFO

If hWndTT <> 0 Then
With Info
.hWnd = Ctl.hWnd
.pt.X = X
.pt.Y = Y
.ti.cbSize = Len(.ti)
End With
HitTest = (SendMessage(Ctl.hWnd, TTM_HITTEST, 0, ByVal
VarPtr(Info)) <> 0)
End If

End Function

Public Property Get MarginLeft() As Long

Dim Rct As RECT

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_GETMARGIN, 0, Rct
MarginLeft = Rct.Left
End If

End Property

Public Property Let MarginLeft(NewMargin As Long)

Dim Rct As RECT

If hWndTT <> 0 Then
With Rct
.Left = NewMargin
.Top = MarginTop
.Right = MarginRight
.Bottom = MarginBottom
End With
SendMessage hWndTT, TTM_SETMARGIN, 0, Rct
End If

End Property

Public Property Let MarginTop(NewMargin As Long)

Dim Rct As RECT

If hWndTT <> 0 Then
With Rct
.Left = MarginLeft
.Top = NewMargin
.Right = MarginRight
.Bottom = MarginBottom
End With
SendMessage hWndTT, TTM_SETMARGIN, 0, Rct
End If

End Property

Public Property Let MarginRight(NewMargin As Long)

Dim Rct As RECT

If hWndTT <> 0 Then
With Rct
.Left = MarginLeft
.Top = MarginTop
.Right = NewMargin
.Bottom = MarginBottom
End With
SendMessage hWndTT, TTM_SETMARGIN, 0, Rct
End If

End Property

Public Property Let MarginBottom(NewMargin As Long)

Dim Rct As RECT

If hWndTT <> 0 Then
With Rct
.Left = MarginLeft
.Top = MarginTop
.Right = MarginRight
.Bottom = NewMargin
End With
SendMessage hWndTT, TTM_SETMARGIN, 0, Rct
End If

End Property

Public Property Get MarginTop() As Long

Dim Rct As RECT

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_GETMARGIN, 0, Rct
MarginTop = Rct.Top
End If

End Property

Public Property Get MarginRight() As Long

Dim Rct As RECT

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_GETMARGIN, 0, Rct
MarginRight = Rct.Right
End If

End Property

Public Property Get MarginBottom() As Long

Dim Rct As RECT

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_GETMARGIN, 0, Rct
MarginBottom = Rct.Bottom
End If

End Property

Private Function GetToolInfo(ToolWnd As Long) As TOOLINFO

Dim N As Long, Info As TOOLINFO, Found As Boolean

If hWndTT <> 0 Then
Info.cbSize = Len(Info)

For N = 0 To ToolCount - 1
If SendMessage(hWndTT, TTM_ENUMTOOLS, N, ByVal VarPtr(Info)) <> 0
Then
If Info.uId = ToolWnd Then
Found = True
Exit For
End If
End If
Next N

If Found Then GetToolInfo = Info
End If

End Function

Public Function GetTooltipWidth(Ctl As Control) As Long

Dim TipSize As Long, Info As TOOLINFO

If hWndTT <> 0 Then
Info = GetToolInfo(Ctl.hWnd)
If Info.cbSize <> 0 Then
TipSize = SendMessage(hWndTT, TTM_GETBUBBLESIZE, 0, ByVal
VarPtr(Info))
End If
GetTooltipWidth = LoWord(TipSize)
End If

End Function

Public Function GetTooltipHeight(Ctl As Control) As Long

Dim TipSize As Long, Info As TOOLINFO

If hWndTT <> 0 Then
Info = GetToolInfo(Ctl.hWnd)
If Info.cbSize <> 0 Then
TipSize = SendMessage(hWndTT, TTM_GETBUBBLESIZE, 0, ByVal
VarPtr(Info))
End If
GetTooltipHeight = HiWord(TipSize)
End If

End Function

Private Function LoWord(DWord As Long) As Integer

Dim Ints(1 To 2) As Integer

CopyMemory Ints(1), DWord, Len(DWord)
LoWord = Ints(1)

End Function

Private Function HiWord(DWord As Long) As Integer

Dim Ints(1 To 2) As Integer

CopyMemory Ints(1), DWord, Len(DWord)
HiWord = Ints(2)

End Function

Public Property Get MaxTipWidth() As Long

If hWndTT <> 0 Then
MaxTipWidth = SendMessage(hWndTT, TTM_GETMAXTIPWIDTH, 0, ByVal 0&)
End If

End Property

Public Property Let MaxTipWidth(NewWidth As Long)

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_SETMAXTIPWIDTH, 0, ByVal NewWidth
End If

End Property

Public Sub SetToolRect(Ctl As Control, Left As Long, Top As Long, Right
As Long, Bottom As Long)

Dim Info As TOOLINFO

If hWndTT <> 0 Then
Info = GetToolInfo(Ctl.hWnd)
With Info.WinRect
.Left = Left
.Top = Top
.Right = Right
.Bottom = Bottom
End With

If Info.cbSize <> 0 Then
SendMessage hWndTT, TTM_NEWTOOLRECT, 0, ByVal VarPtr(Info)
End If
End If

End Sub

Public Property Get ToolCount() As Long

If hWndTT <> 0 Then
ToolCount = SendMessage(hWndTT, TTM_GETTOOLCOUNT, 0, ByVal 0&)
End If

End Property

Public Property Get BackColor() As OLE_COLOR

If hWndTT <> 0 Then
BackColor = SendMessage(hWndTT, TTM_GETTIPBKCOLOR, 0, ByVal 0&)
End If

End Property

Public Property Let BackColor(NewColor As OLE_COLOR)

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_SETTIPBKCOLOR, WinColor(NewColor), ByVal 0&
End If

End Property

Public Sub SetTipText(Ctl As Control, NewText As String)

Dim Info As TOOLINFO

If hWndTT <> 0 Then
Info = GetToolInfo(Ctl.hWnd)
If Info.cbSize <> 0 Then
Info.lpszText = NewText
Info.cbSize = Len(Info)
SendMessage hWndTT, TTM_UPDATETIPTEXT, 0, ByVal VarPtr(Info)

' Balloon durchscheinend anzeigen?
SetWindowLong hWndTT, GWL_EXSTYLE, GetWindowLong(hWndTT,
GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hWndTT, 0, m_byAlpha, LWA_ALPHA

End If
End If

End Sub

Public Property Let ForeColor(NewColor As OLE_COLOR)

If hWndTT <> 0 Then
SendMessage hWndTT, TTM_SETTIPTEXTCOLOR, WinColor(NewColor), ByVal 0&
End If

End Property

Private Function WinColor(VBColor As Long) As Long

Dim SysClr As OLECOLOR

CopyMemory SysClr, VBColor, Len(SysClr)
If SysClr.Type = &H80 Then 'It is a system color
'SysClr.RedOrSys is the index of the system color
WinColor = GetSysColor(SysClr.RedOrSys)
Else
WinColor = VBColor
End If

End Function

Public Property Get ForeColor() As OLE_COLOR

If hWndTT <> 0 Then
ForeColor = SendMessage(hWndTT, TTM_GETTIPTEXTCOLOR, 0, ByVal 0&)
End If

End Property

Public Function ToolTipWidthFromText(hdc As Long, Text As String) As Long

Dim Rct As RECT, Siz As Size

If hWndTT <> 0 Then
GetTextExtentPoint32 hdc, StrPtr(Text), LenB(Text), Siz
Rct.Right = Siz.cx
Rct.Bottom = Siz.cy
SendMessage hWndTT, TTM_ADJUSTRECT, True, Rct
ToolTipWidthFromText = (Rct.Right - Rct.Left)
End If

End Function


Public Function ToolTipHeightFromText(hdc As Long, Text As String) As Long

Dim Rct As RECT, Siz As Size

If hWndTT <> 0 Then
GetTextExtentPoint32 hdc, Text, LenB(Text), Siz
Rct.Right = Siz.cx
Rct.Bottom = Siz.cy
SendMessage hWndTT, TTM_ADJUSTRECT, True, Rct
ToolTipHeightFromText = (Rct.Bottom - Rct.Top)
End If

End Function

Public Function TextHeightFromToolTipHeight(hdc As Long, TextHeight As
Long) As Long

Dim Rct As RECT, Siz As Size

If hWndTT <> 0 Then
Rct.Bottom = TextHeight
SendMessage hWndTT, TTM_ADJUSTRECT, False, Rct
TextHeightFromToolTipHeight = (Rct.Bottom - Rct.Top)
End If

End Function

Public Function TextWidthFromToolTipWidth(hdc As Long, TextWidth As
Long) As Long

Dim Rct As RECT, Siz As Size

If hWndTT <> 0 Then
Rct.Right = TextWidth
SendMessage hWndTT, TTM_ADJUSTRECT, False, Rct
TextWidthFromToolTipWidth = (Rct.Right - Rct.Left)
End If

End Function


Public Property Let Alpha(ByVal newValue As Byte)

m_byAlpha = newValue

End Property

Public Property Get Alpha() As Byte

Alpha = m_byAlpha

End Property

Private Sub Class_Initialize()
m_byAlpha = 222
End Sub

Private Sub Class_Terminate()
If hWndTT <> 0 Then DestroyWindow hWndTT
End Sub

______________________________________________


Der Init der Klasse:


Friend Sub InitBalloonToolTip()
' Balloon-ToolTips-Klasse initialisieren

On Error GoTo ErrorHandler
With c_Tooltips
.Create UserControl.hWnd, IIf(booTTcomicStyle, ttfBalloon, 0)
.AddTool vsgPLAN, UserControl.hWnd, tfAbsolute, " "
.Enabled = True
.BackColor = vbInfoBackground
.ForeColor = vbInfoText
.Icon = itNoIcon ' ohne ICON!
.SetDelayTime sdtAutoPop, 30000 ' Anzeigedauer max 30.000 ms

.MarginLeft = 0 ' Ohne extra Rànder
.MarginTop = 0
.MarginRight = 0
.MarginBottom = 0
.Title = vbNullString ' Titel abhàngig von ItemTyp +
vsgPLAN.Cell
.Alpha = 245 ' fast ohne Alpha-Blending

'.MaxTipWidth = IIf(booTTmehrzeilig, 70, -1) ' mit
Zeilenumbruch, sonst Anzahl max.Zeichen/Zeile
.MaxTipWidth = 1000 ' 09.10.2014 ds Pixel statt Zeichen!!

'.TextWidthFromToolTipWidth vsgPLAN.hWnd, 2000
'.TextHeightFromToolTipHeight vsgPLAN.hWnd, 7000
'.SetDelayTime sdtInitial, [ms] ' Alle Verzögerungszeiten in
Millisekunden

End With
Exit Sub


Resume

ErrorHandler:
Const strModName As String = "InitBalloonToolTip."
Err.Raise Number:=Err.Number, _
Source:=strModName & Err.Source, _
Description:=Err.Description
End Sub




Viele Grüße - Dieter

EDV-Kommunikation Strassner e.K.
68623 Lampertheim
Internet: www.strassner.biz

Ähnliche fragen