Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0353: Sichtbaren Teil der TextBox als String auslesen

VB 5/6-Tipp 0353: Sichtbaren Teil der TextBox als String auslesen

 von ActiveVB

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), SendMessageA (SendMessage), SetWindowLongA (SetWindowLong)

Download: Download des Beispielprojektes [5,62 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Textfeld "Text1"
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Beschriftungsfeld "Label7"
' Steuerelement: Beschriftungsfeld "Label6"
' Steuerelement: Beschriftungsfeld "Label8"
' Steuerelement: Beschriftungsfeld "Label5"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

Dim VisText$, VisLines&

Private Sub Form_Load()
  Dim FN%
       
    Call Init(Text1)
    FN = FreeFile
    Open App.Path & "\Bsp.txt" For Input As #FN
      Text1.Text = Input$(LOF(FN), FN)
    Close FN
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Call Terminate
End Sub

Private Sub Text1_Change()
  TopLine = -1
  Label8.Caption = GetVisibleText(Text1)
End Sub

Private Sub Timer1_Timer()
  Label8.Caption = GetVisibleText(Text1)
End Sub


    
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Private Declare Function CallWindowProc Lib "user32" Alias _
        "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal _
        hwnd As Long, ByVal MSG As Long, ByVal wParam As _
        Long, ByVal lParam 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 Declare Function SendMessage Lib "user32" Alias _
        "SendMessageA" (ByVal hwnd As Long, ByVal wMsg _
        As Long, ByVal wParam As Long, lParam As Any) _
        As Long
        
Const WM_HSCROLL = &H114
Const WM_VSCROLL = &H115

Const SB_BOTTOM = 7
Const SB_ENDSCROLL = 8
Const SB_LINELEFT = 0
Const SB_LINERIGHT = 1
Const SB_PAGELEFT = 2
Const SB_PAGERIGHT = 3
Const SB_THUMBPOSITION = 4
Const SB_THUMBTRACK = 5
Const SB_TOP = 6

Const GWL_WNDPROC = (-4&)

Const EM_GETFIRSTVISIBLELINE = &HCE
Const EM_GETRECT = &HB2

Const EM_GETLINE = &HC4
Const EM_GETLINECOUNT = &HBA
Const MAX_CHAR_PER_LINE = &H100

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

Public TopLine&
Public VisLines&

Dim PrevWndProc&
Dim TxtBox As TextBox
Dim DoFlag As Boolean

Private Function WndProc(ByVal hwnd As Long, ByVal MSG _
                         As Long, ByVal wParam As Long, _
                         ByVal lParam As Long) As Long
  Dim H&, Smsg$, V&
  
    If MSG = WM_HSCROLL Or MSG = WM_VSCROLL Then
        If (wParam And &HFFFF&) > &H7FFF Then
          H = (wParam And &HFFFF&) - &H10000
        Else
          H = wParam And &HFFFF&
        End If
        
        Select Case H
          Case SB_BOTTOM:        Smsg = "ENDSCROLL"
          Case SB_ENDSCROLL:     Smsg = "ENDSCROLL"
          Case SB_LINELEFT:      Smsg = "LINELEFT"
          Case SB_LINERIGHT:     Smsg = "LINERIGHT"
          Case SB_PAGELEFT:      Smsg = "PAGELEFT"
          Case SB_PAGERIGHT:     Smsg = "PAGERIGHT"
          Case SB_THUMBPOSITION: Smsg = "THUMBPOSITION"
          Case SB_THUMBTRACK:    Smsg = "THUMBTRACK"
          Case SB_TOP:           Smsg = "TOP"
        End Select
        V = wParam / &H10000
        
        With Form1
          If MSG = WM_HSCROLL Then
            If H = SB_THUMBTRACK Then .Label1 = V
            .Label2 = Smsg
          Else
            If H = SB_THUMBTRACK Then .Label5 = V
            .Label6 = Smsg
          End If
        End With
        
    End If
    WndProc = CallWindowProc(PrevWndProc, hwnd, MSG, _
                             wParam, lParam)
End Function

Public Sub Init(T As TextBox)
  Dim R As RECT
    
    Set TxtBox = T
    TopLine = -1
    Call SendMessage(TxtBox.hwnd, EM_GETRECT, 0&, R)
    VisLines = R.Bottom \ Form1.TextHeight("H") _
               / Screen.TwipsPerPixelY
    
    PrevWndProc = SetWindowLong(TxtBox.hwnd, GWL_WNDPROC, _
                              AddressOf WndProc)
End Sub

Public Sub Terminate()
  Call SetWindowLong(TxtBox.hwnd, GWL_WNDPROC, PrevWndProc)
End Sub

Public Function GetVisibleText(TBox As TextBox) As String
  Dim aa$, x&, NewTopline&
  Static LastTopLine&
  Static LastText$
  
    NewTopline = SendMessage(TBox.hwnd, EM_GETFIRSTVISIBLELINE, _
                             0&, ByVal 0&)
    If LastTopLine <> NewTopline Or TopLine = -1 Then
      If DoFlag Then DoFlag = False
      TopLine = NewTopline
      For x = TopLine To TopLine + VisLines
        aa = aa & GetLine(TBox.hwnd, x) & vbCrLf
      Next x
      LastText = aa
      LastTopLine = TopLine
    Else
      DoFlag = False
    End If
    
    GetVisibleText = LastText
End Function

Private Function GetLine(Thwnd&, ByVal Line&) As String
  Dim Lo%, Hi%, Result&, Buff$
    
    Lo = MAX_CHAR_PER_LINE And &HFF
    Hi = Int(MAX_CHAR_PER_LINE / &H100)
    Buff = Chr$(Lo) & Chr$(Hi) & Space$(MAX_CHAR_PER_LINE - 2)
    Result = SendMessage(Thwnd, EM_GETLINE, Line, ByVal Buff)
    GetLine = Left$(Buff, Result)
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------