按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
文章來源于領測軟件測試網 http://www.kjueaiud.com/
