设定Caret的大小与其所在的字元相同

来源:cww

这个程式我想很久了，一直缺临门一脚，原因出在GetDC()後所取得的hDc所用的字型是
系统内定的字型，而如果使用CreateFontIndirect()时，又不知lfWidth设定多少，後来
发现引用Stand OLE Type後，有一个IFont的Class，里面有Font的Handle，於是我们终於
可以取得hFont，而将之用SelectObject()设定给hDc；进而使用GetTextExtentPoint32
取得文字的高和宽。
最後使用CreateCaret()来设定我们想要的Caret的形状，并进而用ShowCaret()显示；

这里有一个有趣的问题，Caret是系统的物件，我们设定好它的形状後，当我们Keyin一
个字後，它会再变回原本的样子，这是因为TextBox在处理Caret是，Keyin一个字後，需
将Caret移动到该字的後面，而其内定的形状就是垂直的一条线(宽度固定)，所以系统又
将之变回去了，那我们能做的便是再把它变回来，而能放的位置便是於KeyUp 这个Event
，方不能在KeyPress或KeyDown，因为那个时候OS还没有将Caret设回去。

另外，这个副程式用在TextBox最好，用在Combo会有问题，因为Combo是由EditBox和
ListBox所组成，所以要设的是EditBox，但这要另外的程式将EditBox的hWnd取出。
详见 如何拦截ComboBox的mouse右键

'以下在.Bas
Type Size
        cx As Long
        cy As Long
End Type

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long

Declare Function CreateCaret Lib "user32" (ByVal hwnd As Long, ByVal hBitmap As Any, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As Long

Public Sub SetCaretShap(ctl As Control)
Dim iFnt As IFont
Dim hdc5 As Long
Dim sz As Size
Dim aChar As String, len5 As Long, width5 As Long, height5 As Long

Set iFnt = ctl.Font
hdc5 = GetDC(ctl.hwnd)
Call SelectObject(hdc5, iFnt.hFont)

aChar = Mid(ctl.Text, ctl.SelStart + 1, 1) '取Caret所在的字
If aChar = "" Then '可能是在text最後面，所以Caret所在位置没有字元
   If ctl.SelStart > 1 Then
      aChar = Mid(ctl.Text, ctl.SelStart, 1) '取Caret所在的前一个字元
   Else
      aChar = "x" '内定字元x
   End If
End If
len5 = LenB(StrConv(aChar, vbFromUnicode))
Call GetTextExtentPoint32(hdc5, aChar, len5, sz) '取得该字元的长、宽
width5 = sz.cx
height5 = sz.cy
Call ReleaseDC(ctl.hwnd, hdc5)

CreateCaret ctl.hwnd, vbNullString, width5, height5 '重新Create Caret
ShowCaret ctl.hwnd
End Sub

'以下在Form需要一个TextBox，更重要的是要在设定引用项目中选Stand OLE Type
'(OLE30.DLL)使之有 IFont之Class
Private Sub Text1_GotFocus()
Call SetCaretShap(Text1)
End Sub


Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
Call SetCaretShap(Text1)

End Sub