[推荐]TextBox模拟拖曳选取文字
<p>TextBox模拟拖曳选取文字 </p><p><br/>我们知道Rich text或Word 或VB的程式撰写环境，可以将Mouse移到Select起来的文字 按Mouse左键做拖曳移动的功能，後来想，TextBox能不能做呢？这可真的吃了不少苦头<br/>，这个程式模拟其做法，但主要的精神是在於对TextBox的了解。 <br/> 首先，TextBox中当选取一段文字之後，我们只要按Mosue，便使Select的区域失效，且 可能进入另外的一个Select域，故第一件事是如何在有Select的区域时，使这动作失效；<br/>的作法是在MouseUp时Check一下有没有选取文字，如果有，就使用SubClass的技术，拦截 Mouse的左键，所以当我们按左键时，不会再有选取文字又不见了的情况。</p><p> 第二，我们没有按下Mouse，那如何得知Mouse所在的地方到底是TextBox的哪个字呢，所幸 有EM_CHARFROMPOS这个讯息可Send给textBox，其传回值的HiWord 得该字元是在第几行<br/>0为base，LowWord是该字元在TextBox中的位置(含换行与LineFeed)，因而我们可以单 由MouseMove便得知何时Mouse要是箭号，何时是内定I形的Mouse。当然想得知Mouse所在<br/>可以透过Mouse Event的X, Y座标，但是它们是以Twips为单位，而另外也可以用GetCursorPos() 来得知Mouse的位置，但这是相对於萤幕者，EMCHARFROMPOS的讯息需要的是相对於TextBox<br/>的座标，有许多种方法可以完成这转换，但我选ScreenToClient()这个API，比较直接。 <br/> 第叁，Caret如何隐藏呢？使用HideCaret可完成，但这个Function只能呼叫一次，以便 下回 ShowCaret()时可以将Caret Show出来，这是因为呼叫2次的HideCaret时，也要呼<br/>叫2次的ShowCaret才能使Caret出现。另设定Caret的SetCaretPos() API只是令Caret出现 在什麽地，但如果您KeyIn任何字时，仍出现在原来之地方，而不是方才设定之处，而<br/>要用EM_SETSEL的Message才能设定KeyIn的位置是Caret的位置。</p><p> 另有一个取得textbox中第charindex个字元，在textbox中Mouse的位置(textbox的左上角为原点)<br/>pos = SendMessage(hwnd, EM_POSFROMCHAR, charindex, 0)<br/>my = pos \ 2 ^ 16 'Y座标<br/>mx = pos Mod 2 ^ 16 'X座标</p><p> 这个程式的重点便是上面所写的，其他是苦功</p><p>'以下在.Bas<br/>'注:本程式之所以要用一个变数来存Caret是否被隐藏，原因是：当HideCaret()呼叫N次<br/>'便得呼叫N次 ShowCaret()来复原，反之亦然，所以程式中，用一个变数来确认Hide/Show<br/>'的动作只做一次<br/>Option Explicit</p><p>Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _<br/>(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long<br/>Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _<br/>(ByVal hwnd As Long, ByVal nIndex As Long) As Long<br/>Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _<br/>(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, _<br/>ByVal wParam As Long, ByVal lParam As Long) As Long</p><p>Public Const GWL_WNDPROC = (-4)<br/>Public Const WM_MOUSEMOVE = &H200<br/>Public Const WM_RBUTTONDOWN = &H204<br/>Public Const WM_LBUTTONDOWN = &H201<br/>Public Const WM_CUT = &H300<br/>Public Const WM_PASTE = &H302<br/>Public Const EM_POSFROMCHAR = 214<br/>Public Const EM_CHARFROMPOS = 215<br/>Public Const EM_SETSEL = &HB1<br/>Public Const EM_GETSEL = &HB0<br/>Public Const EM_SCROLL = &HB5<br/>Public Const EM_LINEFROMCHAR = &HC9<br/>Public Const EM_LINEINDEX = &HBB<br/>Public Const EM_LINESCROLL = &HB6</p><p>Public Const SB_LINEDOWN = 1<br/>Public Const SB_LINEUP = 0</p><p>Type POINTAPI<br/>X As Long<br/>Y As Long<br/>End Type<br/>Type RECT<br/>Left As Long<br/>Top As Long<br/>Right As Long<br/>Bottom As Long<br/>End Type<br/>Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long<br/>Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long</p><p><br/>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<br/>Declare Function HideCaret Lib "user32" (ByVal hwnd As Long) As Long<br/>Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As Long<br/>Declare Function SetCaretPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long<br/>Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long<br/>Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long</p><p><br/>Private SelEnd As Long '存TextBox Mark起来的起点<br/>Private SelST As Long '存textBix Mark起来的终点<br/>Private CaretHide As Boolean '存Caret是否被隐藏<br/>Private CanPaste As Boolean '存是否处於可以Paste的状态<br/>Public preWinProc As Long<br/>'取得Mouse所在的字元在TextBox中的位置<br/>Public Function GetCharIndex(ByVal hwnd As Long, Optional CharLineNo As Long) As Long<br/>Dim mx As Integer, my As Integer<br/>Dim wParam As Long, lParam As Long<br/>Dim i As Long<br/>Dim pos As Long, pt As POINTAPI</p><p>Call GetCursorPos(pt) '取得相对Screen的Mouse之位置<br/>i = ScreenToClient(hwnd, pt) '将Mouse位置转换成相对於TextBox的位置<br/>mx = pt.X<br/>my = pt.Y<br/>If mx < 0 Then mx = 0<br/>If my < 0 Then my = 0<br/>lParam = mx + 2 ^ 16 * my<br/>wParam = 0<br/>i = SendMessage(hwnd, EM_CHARFROMPOS, 0, lParam)<br/>If Not IsMissing(CharLineNo) Then<br/>CharLineNo = i \ 2 ^ 16 '取得该字元是在第几行,0为base<br/>End If<br/>GetCharIndex = i Mod 2 ^ 16 '传回该字元是在textBox中的第几个字,0为base<br/>End Function</p><p>Public Sub SetCaretPosition(ByVal hwnd As Long)<br/>Dim mx As Long, my As Long, pos As Long<br/>Dim charindex As Long<br/>Dim pt As POINTAPI, i As Long<br/>Dim rect5 As RECT, rect6 As RECT<br/>charindex = GetCharIndex(hwnd)<br/>'取得textbox中第charindex个字元，在textbox中Mouse的位置(textbox的左上角为点<br/>pos = SendMessage(hwnd, EM_POSFROMCHAR, charindex, 0)<br/>my = pos \ 2 ^ 16<br/>mx = pos Mod 2 ^ 16<br/>'设定Caret出现的位置，但只是显示的位置，实际keyin进去的字出现的地方没因而更动<br/>Call SetCaretPos(mx, my)<br/>'取得Mouse所在之座标(Screen左上角为原点)<br/>Call GetCursorPos(pt)<br/>'取得TextBox的萤幕座标(Screen左上角为原点)<br/>Call GetWindowRect(hwnd, rect6)<br/>'取得TextBox可keyin字的区域大小(textBox左上角为原点)<br/>Call GetClientRect(hwnd, rect5)<br/>'取得textbox Client区域相对Screen的座标<br/>rect5.Left = rect6.Left<br/>rect5.Right = rect5.Right + rect6.Left<br/>rect5.Top = rect6.Top<br/>rect5.Bottom = rect5.Bottom + rect6.Top<br/>'Mouse移到四个边时，自动scroll，就算不必Scroll时也可呼叫，只是不会有作用<br/>If pt.Y <= rect5.Top + 3 Then<br/>i = SendMessage(hwnd, EM_SCROLL, SB_LINEUP, 0)<br/>End If<br/>If pt.Y >= rect5.Bottom - 3 Then<br/>Call SendMessage(hwnd, EM_SCROLL, SB_LINEDOWN, 0)<br/>End If<br/>If pt.X <= rect5.Left + 3 Then<br/>i = SendMessage(hwnd, EM_LINESCROLL, -1, 0)<br/>End If<br/>If pt.X >= rect5.Right - 3 Then<br/>Call SendMessage(hwnd, EM_LINESCROLL, 1, 0)<br/>End If<br/>End Sub</p><p>'设定Mouse的形状<br/>Public Sub SetMouseShap(hwnd As Long, ByVal Button As Integer)<br/>Dim charindex As Long<br/>Dim i As Long<br/>If preWinProc <> 0 Then<br/>If Button = 1 Then<br/>Screen.ActiveControl.MousePointer = 99<br/>Screen.ActiveControl.MouseIcon = LoadPicture("dragmove.cur")<br/>'请自行设定dragmove.cur的位置<br/>Call SetCaretPosition(hwnd)<br/>Exit Sub<br/>End If<br/>charindex = GetCharIndex(hwnd)<br/>'设定Mouse移过mark的区块时，Mouse变箭号<br/>If charindex >= SelST And charindex <= SelEnd Then<br/>If Button = 0 Then<br/>Screen.ActiveControl.MousePointer = 1<br/>End If<br/>Else<br/>Screen.ActiveControl.MousePointer = 0<br/>End If<br/>End If<br/>End Sub</p><p>Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _<br/>ByVal wParam As Long, ByVal lParam As Long) As Long<br/>'以下程式会截取mouse move，处理完後，再将之送往原来的Window Procedure<br/>Dim charindex As Long<br/>Dim i As Long<br/>If Msg = WM_LBUTTONDOWN Then<br/>If CaretHide Then<br/>Call ShowCaret(hwnd)<br/>CaretHide = False<br/>End If<br/>If SelEnd - SelST <> 0 Then<br/>charindex = GetCharIndex(hwnd)<br/>If charindex >= SelST And charindex <= SelEnd Then<br/>Call SetCaretPosition(hwnd)<br/>Screen.ActiveControl.MousePointer = 99<br/>Screen.ActiveControl.MouseIcon = LoadPicture("c:\tmp2\dragmove.cur")<br/>CanPaste = True<br/>Exit Function<br/>End If<br/>End If<br/>End If<br/>wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)<br/>End Function</p><p>Public Sub MoveText(ByVal hwnd As Long, CanFree As Boolean)<br/>Dim i As Long, sellen As Long, charindex As Long<br/>sellen = SelEnd - SelST<br/>'如果Caret落在mark起来之处则不处理<br/>charindex = GetCharIndex(hwnd)<br/>If charindex >= SelST And charindex <= SelEnd Then<br/>CanFree = False<br/>Exit Sub<br/>End If<br/>Call SendMessage(hwnd, WM_CUT, 0, 0) '将Mark起来的地方Cut掉<br/>Dim setpos As Long<br/>If charindex < SelST Then<br/>setpos = charindex<br/>Else<br/>If charindex > SelEnd Then setpos = charindex - sellen<br/>End If<br/>'设定Caret新位置，此时Keyin进去的字才真的会在此位置出现，使用SetCaretPos()则不行<br/>Call SendMessage(hwnd, EM_SETSEL, setpos, setpos)<br/>Call SendMessage(hwnd, WM_PASTE, 0, 0)</p><p>End Sub<br/>Public Sub SetHook(ByVal hwnd As Long, ByVal Button As Integer)<br/>Dim ret As Long<br/>Dim i As Long<br/>Dim charindex As Long<br/>If Button = 1 Then<br/>If Screen.ActiveControl.SelLength > 0 Then<br/>If preWinProc = 0 Then<br/>'记录原本的Window Procedure的位址<br/>preWinProc = GetWindowLong(hwnd, GWL_WNDPROC)<br/>ret = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf wndproc)<br/>Call HideCaret(hwnd)<br/>CaretHide = True<br/>CanPaste = False<br/>'取得Mark起来的区域之Start, End之Index，之所以不用Text.SelStart<br/>'与Text.SelLength来做的原因是：vb对之的度量是字元为单位，但API<br/>'的其他呼叫都以Byte为单位，我如此做，省得中间的转换<br/>i = SendMessage(hwnd, EM_GETSEL, 0, 0)<br/>SelEnd = i \ 2 ^ 16<br/>SelST = i Mod 2 ^ 16<br/>Else<br/>Dim CanFree As Boolean<br/>CanFree = True<br/>If CanPaste Then<br/>Call MoveText(hwnd, CanFree)<br/>End If<br/>If CanFree Then Call FreeHook(hwnd)<br/>End If<br/>Else<br/>If preWinProc <> 0 Then<br/>Call FreeHook(hwnd)<br/>End If<br/>End If<br/>End If<br/>End Sub<br/>Public Sub FreeHook(ByVal hwnd As Long)<br/>Dim ret As Long<br/>If preWinProc <> 0 Then<br/>ret = SetWindowLong(hwnd, GWL_WNDPROC, preWinProc)<br/>End If<br/>preWinProc = 0<br/>Screen.ActiveControl.MousePointer = 0<br/>If CaretHide Then<br/>Call ShowCaret(hwnd)<br/>CaretHide = False<br/>End If<br/>End Sub<br/>Public Sub GetCaretPos(ByVal hwnd5 As Long, lineno As Long, colno As Long)<br/>Dim i As Long, j As Long<br/>Dim lParam As Long, wParam As Long<br/>Dim k As Long<br/>i = SendMessage(hwnd5, EM_GETSEL, wParam, lParam)<br/>j = i / 2 ^ 16 '取得目前Caret所在前面有多少个byte<br/>lineno = SendMessage(hwnd5, EM_LINEFROMCHAR, j, 0) '取得前面有多少行<br/>lineno = lineno + 1<br/>k = SendMessage(hwnd5, EM_LINEINDEX, -1, 0)<br/>'取得目前caret所在行前面有多少个byte<br/>colno = j - k + 1<br/>End Sub<br/> </p><p>><br/>'以下在Form<br/>Private Sub Text1_LostFocus()<br/>Call FreeHook(Text1.hwnd)<br/>End Sub</p><p>Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)<br/>Call FreeHook(Text1.hwnd)<br/>End Sub</p><p>Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)<br/>Call SetMouseShap(Text1.hwnd, Button)<br/>End Sub</p><p>Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)<br/>Call SetHook(Text1.hwnd, Button)<br/>End Sub </p>[此贴子已经被作者于2007-1-27 9:39:40编辑过]
页:
[1]