TextBox模拟拖曳选取文字

中条山蜂蜜

中条山蜂蜜

2016-02-19 15:46

岁数大了,QQ也不闪了,微信也不响了,电话也不来了,但是图老师依旧坚持为大家推荐最精彩的内容,下面为大家精心准备的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)

(本文来源于图老师网站,更多请访问http://m.tulaoshi.com/bianchengyuyan/)

  my = pos 2 ^ 16 'Y座标

  mx = pos Mod 2 ^ 16 'X座标

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

  '以下在.Bas

  '注:本程式之所以要用一个变数来存Caret是否被隐藏,原因是:当HideCaret()呼叫N次

  '便得呼叫N次 ShowCaret()来复原,反之亦然,所以程式中,用一个变数来确认Hide/Show

  '的动作只做一次

  

Option ExplicitDeclare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongDeclare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As LongDeclare 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 LongPublic Const GWL_WNDPROC = (-4)Public Const WM_MOUSEMOVE = &H200Public Const WM_RBUTTONDOWN = &H204Public Const WM_LBUTTONDOWN = &H201Public Const WM_CUT = &H300Public Const WM_PASTE = &H302Public Const EM_POSFROMCHAR = 214Public Const EM_CHARFROMPOS = 215Public Const EM_SETSEL = &HB1Public Const EM_GETSEL = &HB0Public Const EM_SCROLL = &HB5Public Const EM_LINEFROMCHAR = &HC9Public Const EM_LINEINDEX = &HBBPublic Const EM_LINESCROLL = &HB6Public Const SB_LINEDOWN = 1Public Const SB_LINEUP = 0Type POINTAPI    X As Long    Y As LongEnd TypeType RECT    Left As Long    Top As Long    Right As Long    Bottom As LongEnd TypeDeclare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongDeclare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongDeclare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongDeclare Function HideCaret Lib "user32" (ByVal hwnd As Long) As LongDeclare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As LongDeclare Function SetCaretPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As LongDeclare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongDeclare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As LongPrivate 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 LongDim mx As Integer, my As IntegerDim wParam As Long, lParam As LongDim i As LongDim pos As Long, pt As POINTAPICall GetCursorPos(pt) '取得相对Screen的Mouse之位置i = ScreenToClient(hwnd, pt) '将Mouse位置转换成相对於TextBox的位置mx = pt.Xmy = pt.YIf mx  0 Then mx = 0If my  0 Then my = 0lParam = mx + 2 ^ 16 * mywParam = 0i = SendMessage(hwnd, EM_CHARFROMPOS, 0, lParam)If Not IsMissing(CharLineNo) Then  CharLineNo = i  2 ^ 16 '取得该字元是在第几行,0为baseEnd IfGetCharIndex = i Mod 2 ^ 16 '传回该字元是在textBox中的第几个字,0为baseEnd FunctionPublic 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 IfEnd Sub'设定Mouse的形状Public Sub SetMouseShap(hwnd As Long, ByVal Button As Integer)Dim charindex As LongDim i As LongIf 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 IfEnd IfEnd SubPublic Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _             ByVal wParam As Long, ByVal lParam As Long) As Long

  '以下程式会截取mouse move,处理完後,再将之送往原来的Window Procedure

(本文来源于图老师网站,更多请访问http://m.tulaoshi.com/bianchengyuyan/)

  

Dim charindex As LongDim i As LongIf 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:tmp2dragmove.cur")     CanPaste = True     Exit Function    End If  End IfEnd Ifwndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)End FunctionPublic Sub MoveText(ByVal hwnd As Long, CanFree As Boolean)Dim i As Long, sellen As Long, charindex As Longsellen = SelEnd - SelST'如果Caret落在mark起来之处则不处理charindex = GetCharIndex(hwnd)If charindex = SelST And charindex = SelEnd Then  CanFree = False  Exit SubEnd IfCall SendMessage(hwnd, WM_CUT, 0, 0) '将Mark起来的地方Cut掉Dim setpos As LongIf charindex  SelST Then  setpos = charindexElse  If charindex  SelEnd Then setpos = charindex - sellenEnd If'设定Caret新位置,此时Keyin进去的字才真的会在此位置出现,使用SetCaretPos()则不行Call SendMessage(hwnd, EM_SETSEL, setpos, setpos)Call SendMessage(hwnd, WM_PASTE, 0, 0)End SubPublic Sub SetHook(ByVal hwnd As Long, ByVal Button As Integer)Dim ret As LongDim i As LongDim charindex As LongIf 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 IfEnd IfEnd SubPublic Sub FreeHook(ByVal hwnd As Long)Dim ret As LongIf preWinProc  0 Then  ret = SetWindowLong(hwnd, GWL_WNDPROC, preWinProc)End IfpreWinProc = 0Screen.ActiveControl.MousePointer = 0If CaretHide Then  Call ShowCaret(hwnd)  CaretHide = FalseEnd IfEnd SubPublic Sub GetCaretPos(ByVal hwnd5 As Long, lineno As Long, colno As Long)Dim i As Long, j As LongDim lParam As Long, wParam As LongDim k As Longi = SendMessage(hwnd5, EM_GETSEL, wParam, lParam)j = i / 2 ^ 16 '取得目前Caret所在前面有多少个bytelineno = SendMessage(hwnd5, EM_LINEFROMCHAR, j, 0) '取得前面有多少行lineno = lineno + 1k = SendMessage(hwnd5, EM_LINEINDEX, -1, 0)'取得目前caret所在行前面有多少个bytecolno = j - k + 1End Sub'以下在FormPrivate Sub Text1_LostFocus()Call FreeHook(Text1.hwnd)End SubPrivate Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)Call FreeHook(Text1.hwnd)End SubPrivate Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Call SetMouseShap(Text1.hwnd, Button)End SubPrivate Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Call SetHook(Text1.hwnd, Button)End Sub

展开更多 50%)
分享

猜你喜欢

TextBox模拟拖曳选取文字

编程语言 网络编程
TextBox模拟拖曳选取文字

让鼠标进入TextBox时自动选定TextBox中之整串文字

编程语言 网络编程
让鼠标进入TextBox时自动选定TextBox中之整串文字

s8lol主宰符文怎么配

英雄联盟 网络游戏
s8lol主宰符文怎么配

实时编辑网页网页文字实时编辑如同TEXTBOX一般

Web开发
实时编辑网页网页文字实时编辑如同TEXTBOX一般

禁止在TextBox中输入

电脑网络
禁止在TextBox中输入

lol偷钱流符文搭配推荐

英雄联盟 网络游戏
lol偷钱流符文搭配推荐

javascript实现鼠标选取拖动或Ctrl选取拖动

Web开发
javascript实现鼠标选取拖动或Ctrl选取拖动

MySQL随机选取数据

编程语言 网络编程
MySQL随机选取数据

lolAD刺客新符文搭配推荐

英雄联盟
lolAD刺客新符文搭配推荐

让老系统换新装 WindowsXP用上Windows7的任务栏

让老系统换新装 WindowsXP用上Windows7的任务栏

正则表达式在网页处理中的应用

正则表达式在网页处理中的应用
下拉加载更多内容 ↓