精华区文章阅读

发信人: bloom (├┝┞┟┠┡┢┣), 信区: VB
标  题: 　TextBox模拟拖曳选取文字
发信站: 哈工大紫丁香 (2000年08月08日20:43:46 星期二), 转信

        　　　　　　　TextBox模拟拖曳选取文字

        　　我们知道Rich text或Word 或VB的程式撰写环境，可以将Mouse移到
Select起来的文字
        按Mouse左键做拖曳移动的功能，後来想，TextBox能不能做呢？这可真的
吃了不少苦头
        ，这个程式模拟其做法，但主要的精神是在於对TextBox的了解。

        　　首先，TextBox中当选取一段文字之後，我们只要按Mosue，便使
Select的区域失效，且
        可能进入另外的一个Select域，故第一件事是如何在有Select的区域时，
使这动作失效；
        的作法是在MouseUp时Check一下有没有选取文字，如果有，就使用
SubClass的技术，拦截
        Mouse的左键，所以当我们按左键时，不会再有选取文字又不见了的情况
。

        　　第二，我们没有按下Mouse，那如何得知Mouse所在的地方到底是
TextBox的哪个字呢，所幸
        有EM_CHARFROMPOS这个讯息可Send给textBox，其传回值的HiWord 得该字
元是在第几行
        0为base，LowWord是该字元在TextBox中的位置(含换行与LineFeed)，因
而我们可以单
        由MouseMove便得知何时Mouse要是箭号，何时是内定I形的Mouse。当然想
得知Mouse所在
        可以透过Mouse Event的X, Y座标，但是它们是以Twips为单位，而另外也
可以用GetCursorPos()
        来得知Mouse的位置，但这是相对於萤幕者，EMCHARFROMPOS的讯息需要的
是相对於TextBox
        的座标，有许多种方法可以完成这转换，但我选ScreenToClient()这个
API，比较直接。

        　　第叁，Caret如何隐藏呢？使用HideCaret可完成，但这个Function只
能呼叫一次，以便
        下回 ShowCaret()时可以将Caret Show出来，这是因为呼叫2次的
HideCaret时，也要呼
        叫2次的ShowCaret才能使Caret出现。另设定Caret的SetCaretPos() API
只是令Caret出现
        在什麽地，但如果您KeyIn任何字时，仍出现在原来之地方，而不是方才
设定之处，而
        要用EM_SETSEL的Message才能设定KeyIn的位置是Caret的位置。

        　　另有一个取得textbox中第charindex个字元，在textbox中Mouse的位
置(textbox的左上角为原点)
        pos = SendMessage(hwnd, EM_POSFROMCHAR, charindex, 0)
        my = pos \ 2 ^ 16 'Y座标
        mx = pos Mod 2 ^ 16 'X座标

        　　这个程式的重点便是上面所写的，其他是苦功

         '以下在.Bas
         '注:本程式之所以要用一个变数来存Caret是否被隐藏，原因是：当
HideCaret()呼叫N次
         '便得呼叫N次 ShowCaret()来复原，反之亦然，所以程式中，用一个变
数来确认Hide/Show
         '的动作只做一次
         Option Explicit

          Declare Function SetWindowLong Lib "user32" Alias
"SetWindowLongA" _
           (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As
Long) As Long
          Declare Function GetWindowLong Lib "user32" Alias
"GetWindowLongA" _
           (ByVal hwnd As Long, ByVal nIndex As Long) As Long
          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

          Public Const GWL_WNDPROC = (-4)
          Public Const WM_MOUSEMOVE = &H200
          Public Const WM_RBUTTONDOWN = &H204
          Public Const WM_LBUTTONDOWN = &H201
          Public Const WM_CUT = &H300
          Public Const WM_PASTE = &H302
          Public Const EM_POSFROMCHAR = 214
          Public Const EM_CHARFROMPOS = 215
          Public Const EM_SETSEL = &HB1
          Public Const EM_GETSEL = &HB0
          Public Const EM_SCROLL = &HB5
          Public Const EM_LINEFROMCHAR = &HC9
          Public Const EM_LINEINDEX = &HBB
          Public Const EM_LINESCROLL = &HB6

          Public Const SB_LINEDOWN = 1
          Public Const SB_LINEUP = 0

          Type POINTAPI
                 X As Long
                 Y As Long
          End Type
          Type RECT
                 Left As Long
                 Top As Long
                 Right As Long
                 Bottom As Long
         End Type
         Declare Function GetWindowRect Lib "user32" (ByVal hwnd As
Long, lpRect As RECT) As Long
         Declare Function GetClientRect Lib "user32" (ByVal hwnd As
Long, lpRect As RECT) As Long

         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
         Declare Function HideCaret Lib "user32" (ByVal hwnd As Long) As
Long
         Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As
Long
         Declare Function SetCaretPos Lib "user32" (ByVal X As Long,
ByVal Y As Long) As Long
         Declare Function GetCursorPos Lib "user32" (lpPoint As
POINTAPI) As Long
         Declare Function ScreenToClient Lib "user32" (ByVal hwnd As
Long, lpPoint As POINTAPI) As Long

         Private SelEnd As Long '存TextBox Mark起来的起点
         Private SelST As Long  '存textBix Mark起来的终点
         Private CaretHide As Boolean '存Caret是否被隐藏
         Private CanPaste As Boolean '存是否处於可以Paste的状态
         Public preWinProc As Long
         '取得Mouse所在的字元在TextBox中的位置
         Public Function GetCharIndex(ByVal hwnd As Long, Optional
CharLineNo As Long) As Long
         Dim mx As Integer, my As Integer
         Dim wParam As Long, lParam As Long
         Dim i As Long
         Dim pos As Long, pt As POINTAPI

         Call GetCursorPos(pt)  '取得相对Screen的Mouse之位置
         i = ScreenToClient(hwnd, pt) '将Mouse位置转换成相对於TextBox的
位置
         mx = pt.X
         my = pt.Y
         If mx < 0 Then mx = 0
         If my < 0 Then my = 0
         lParam = mx + 2 ^ 16 * my
         wParam = 0
         i = SendMessage(hwnd, EM_CHARFROMPOS, 0, lParam)
         If Not IsMissing(CharLineNo) Then
            CharLineNo = i \ 2 ^ 16 '取得该字元是在第几行,0为base
         End If
         GetCharIndex = i Mod 2 ^ 16 '传回该字元是在textBox中的第几个字
,0为base
         End Function

         Public Sub SetCaretPosition(ByVal hwnd As Long)
            Dim mx As Long, my As Long, pos As Long
            Dim charindex As Long
            Dim pt As POINTAPI, i As Long
            Dim rect5 As RECT, rect6 As RECT
            charindex = GetCharIndex(hwnd)
            '取得textbox中第charindex个字元，在textbox中Mouse的位置
(textbox的左上角为点
            pos = SendMessage(hwnd, EM_POSFROMCHAR, charindex, 0)
            my = pos \ 2 ^ 16
            mx = pos Mod 2 ^ 16
            '设定Caret出现的位置，但只是显示的位置，实际keyin进去的字出
现的地方没因而更动
            Call SetCaretPos(mx, my)
            '取得Mouse所在之座标(Screen左上角为原点)
            Call GetCursorPos(pt)
            '取得TextBox的萤幕座标(Screen左上角为原点)
            Call GetWindowRect(hwnd, rect6)
            '取得TextBox可keyin字的区域大小(textBox左上角为原点)
            Call GetClientRect(hwnd, rect5)
            '取得textbox Client区域相对Screen的座标
            rect5.Left = rect6.Left
            rect5.Right = rect5.Right + rect6.Left
            rect5.Top = rect6.Top
            rect5.Bottom = rect5.Bottom + rect6.Top
            'Mouse移到四个边时，自动scroll，就算不必Scroll时也可呼叫，只
是不会有作用
            If pt.Y <= rect5.Top + 3 Then
               i = SendMessage(hwnd, EM_SCROLL, SB_LINEUP, 0)
            End If
            If pt.Y >= rect5.Bottom - 3 Then
               Call SendMessage(hwnd, EM_SCROLL, SB_LINEDOWN, 0)
            End If
            If pt.X <= rect5.Left + 3 Then
                i = SendMessage(hwnd, EM_LINESCROLL, -1, 0)
            End If
            If pt.X >= rect5.Right - 3 Then
                Call SendMessage(hwnd, EM_LINESCROLL, 1, 0)
            End If
         End Sub

         '设定Mouse的形状
         Public Sub SetMouseShap(hwnd As Long, ByVal Button As
Integer)
         Dim charindex As Long
         Dim i As Long
         If preWinProc <> 0 Then
            If Button = 1 Then
               Screen.ActiveControl.MousePointer = 99
               Screen.ActiveControl.MouseIcon = LoadPicture("dragmove.
cur")
               '请自行设定dragmove.cur的位置
               Call SetCaretPosition(hwnd)
               Exit Sub
            End If
           charindex = GetCharIndex(hwnd)
           '设定Mouse移过mark的区块时，Mouse变箭号
           If charindex >= SelST And charindex <= SelEnd Then
              If Button = 0 Then
                 Screen.ActiveControl.MousePointer = 1
              End If
           Else
              Screen.ActiveControl.MousePointer = 0
           End If
         End If
         End Sub

          Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long,
_
                                  ByVal wParam As Long, ByVal lParam
As Long) As Long
          '以下程式会截取mouse move，处理完後，再将之送往原来的Window
Procedure
          Dim charindex As Long
          Dim i As Long
          If Msg = WM_LBUTTONDOWN Then
             If CaretHide Then
                Call ShowCaret(hwnd)
                CaretHide = False
             End If
             If SelEnd - SelST <> 0 Then
                charindex = GetCharIndex(hwnd)
                If charindex >= SelST And charindex <= SelEnd Then
                   Call SetCaretPosition(hwnd)
                   Screen.ActiveControl.MousePointer = 99
                   Screen.ActiveControl.MouseIcon = LoadPicture("c:
\tmp2\dragmove.cur")
                   CanPaste = True
                   Exit Function
                End If
             End If
          End If
          wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam,
lParam)
         End Function

         Public Sub MoveText(ByVal hwnd As Long, CanFree As Boolean)
         Dim i As Long, sellen As Long, charindex As Long
         sellen = SelEnd - SelST
         '如果Caret落在mark起来之处则不处理
         charindex = GetCharIndex(hwnd)
         If charindex >= SelST And charindex <= SelEnd Then
            CanFree = False
            Exit Sub
         End If
         Call SendMessage(hwnd, WM_CUT, 0, 0) '将Mark起来的地方Cut掉
         Dim setpos As Long
         If charindex < SelST Then
            setpos = charindex
         Else
            If charindex > SelEnd Then setpos = charindex - sellen
         End If
         '设定Caret新位置，此时Keyin进去的字才真的会在此位置出现，使用
SetCaretPos()则不行
         Call SendMessage(hwnd, EM_SETSEL, setpos, setpos)
         Call SendMessage(hwnd, WM_PASTE, 0, 0)

         End Sub
         Public Sub SetHook(ByVal hwnd As Long, ByVal Button As
Integer)
          Dim ret As Long
          Dim i As Long
          Dim charindex As Long
          If Button = 1 Then
             If Screen.ActiveControl.SelLength > 0 Then
                If preWinProc = 0 Then
                   '记录原本的Window Procedure的位址
                   preWinProc = GetWindowLong(hwnd, GWL_WNDPROC)
                   ret = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf
wndproc)
                   Call HideCaret(hwnd)
                   CaretHide = True
                   CanPaste = False
                   '取得Mark起来的区域之Start, End之Index，之所以不用
Text.SelStart
                   '与Text.SelLength来做的原因是：vb对之的度量是字元为单
位，但API
                   '的其他呼叫都以Byte为单位，我如此做，省得中间的转换
                   i = SendMessage(hwnd, EM_GETSEL, 0, 0)
                   SelEnd = i \ 2 ^ 16
                   SelST = i Mod 2 ^ 16
                Else
                 Dim CanFree As Boolean
                 CanFree = True
                 If CanPaste Then
                    Call MoveText(hwnd, CanFree)
                 End If
                 If CanFree Then Call FreeHook(hwnd)
                End If
             Else
                If preWinProc <> 0 Then
                   Call FreeHook(hwnd)
                End If
             End If
          End If
         End Sub
         Public Sub FreeHook(ByVal hwnd As Long)
         Dim ret As Long
         If preWinProc <> 0 Then
            ret = SetWindowLong(hwnd, GWL_WNDPROC, preWinProc)
         End If
         preWinProc = 0
         Screen.ActiveControl.MousePointer = 0
         If CaretHide Then
            Call ShowCaret(hwnd)
            CaretHide = False
         End If
         End Sub
         Public Sub GetCaretPos(ByVal hwnd5 As Long, lineno As Long,
colno As Long)
          Dim i As Long, j As Long
          Dim lParam As Long, wParam As Long
          Dim k As Long
          i = SendMessage(hwnd5, EM_GETSEL, wParam, lParam)
          j = i / 2 ^ 16  '取得目前Caret所在前面有多少个byte
          lineno = SendMessage(hwnd5, EM_LINEFROMCHAR, j, 0) '取得前面有
多少行
          lineno = lineno + 1
          k = SendMessage(hwnd5, EM_LINEINDEX, -1, 0)
          '取得目前caret所在行前面有多少个byte
          colno = j - k + 1
          End Sub

         '以下在Form
         Private Sub Text1_LostFocus()
         Call FreeHook(Text1.hwnd)
         End Sub

         Private Sub Text1_KeyDown(KeyCode As Integer, Shift As
Integer)
         Call FreeHook(Text1.hwnd)
         End Sub

         Private Sub Text1_MouseMove(Button As Integer, Shift As
Integer, X As Single, Y As Single)
           Call SetMouseShap(Text1.hwnd, Button)
         End Sub

         Private Sub Text1_MouseUp(Button As Integer, Shift As Integer,
X As Single, Y As Single)
           Call SetHook(Text1.hwnd, Button)
         End Sub




--
├┝┞┟┠┡┢┣ ※↑

※ 来源:·哈工大紫丁香 bbs.hit.edu.cn·[FROM: 202.118.170.205]

VB 版 (精华区)