'以下在.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