ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE
Diese Seite wurde zuletzt aktualisiert am 09.11.1999

Diese Seite wurde zuletzt aktualisiert am 09.11.1999
Aktuell im ABOUT Visual Basic-MagazinGrundlagenwissen und TechnologienKnow How, Tipps und Tricks rund um Visual BasicAddIns für die Visual Basic-IDE und die VBA-IDEVBA-Programmierung in MS-Office und anderen AnwendungenScripting-Praxis für den Windows Scripting Host und das Scripting-ControlTools, Komponenten und Dienstleistungen des MarktesRessourcen für Programmierer (Bücher, Job-Börse)Dies&Das...

Themen und Stichwörter im ABOUT Visual Basic-Magazin
Code, Beispiele, Komponenten, Tools im Überblick, Shareware, Freeware
Ihre Service-Seite, Termine, Job-Börse
Melden Sie sich an, um in den vollen Genuss des ABOUT Visual Basic-Magazins zu kommen!
Informationen zur AVB-Web-Site, Kontakt und Impressum

Zurück...

Zurück...


Anzeige

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

Zurück zu "Wegen Überbreite unlesbar?" Zurück zum Text   


Komponenten-Übersicht

Zum Seitenanfang

Copyright © 1999 - 2017 Harald M. Genauck, ip-pro gmbh  /  Impressum

Zum Seitenanfang

Zurück...

Zurück...

Download Internet Explorer