关于文本框控件开发中遇到问题.......请高手进来帮忙好么>>>

Question

Private Sub UserControl_Terminate()
    '删除创建的 GDI 对象，释放资源。
    DeleteObject hrgnControl
    DeleteObject hbrFrame
    DeleteObject hbrFocus
    DeleteObject hbrHot
End SubPublic Property Get BackColor() As OLE_COLOR
    BackColor = txtTarget.BackColor
End PropertyPublic Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    txtTarget.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End PropertyPublic Property Get BorderStyle() As Integer
    BorderStyle = txtTarget.BorderStyle
End PropertyPublic Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    txtTarget.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End PropertyPrivate Sub txtTarget_Change()
    RaiseEvent Change
End SubPrivate Sub txtTarget_Click()
    RaiseEvent Click
    'blnNotOver = True
End SubPrivate Sub txtTarget_DblClick()
    RaiseEvent DblClick
End SubPublic Property Get Enabled() As Boolean
    Enabled = txtTarget.Enabled
End PropertyPublic Property Let Enabled(ByVal New_Enabled As Boolean)
    txtTarget.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End PropertyPublic Property Get Font() As Font
    Set Font = txtTarget.Font
End PropertyPublic Property Set Font(ByVal New_Font As Font)
    Set txtTarget.Font = New_Font
    Set UserControl.Font = New_Font
    intCharWidth = UserControl.TextWidth
    
    PropertyChanged "Font"
End PropertyPublic Property Get ForeColor() As OLE_COLOR
    ForeColor = txtTarget.ForeColor
End PropertyPublic Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    txtTarget.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End PropertyPublic Property Get hwnd() As Long
    hwnd = txtTarget.hwnd
End PropertyPrivate Sub txtTarget_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End SubPrivate Sub txtTarget_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End SubPrivate Sub txtTarget_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
    
End SubPublic Property Get Locked() As Boolean
    Locked = txtTarget.Locked
End PropertyPublic Property Let Locked(ByVal New_Locked As Boolean)
    txtTarget.Locked() = New_Locked
    PropertyChanged "Locked"
End PropertyPublic Property Get MaxLength() As Long
    MaxLength = txtTarget.MaxLength
End PropertyPublic Property Let MaxLength(ByVal New_MaxLength As Long)
    txtTarget.MaxLength() = New_MaxLength
    PropertyChanged "MaxLength"
End PropertyPublic Property Get MouseIcon() As Picture
    Set MouseIcon = txtTarget.MouseIcon
End PropertyPublic Property Set MouseIcon(ByVal New_MouseIcon As Picture)
    Set txtTarget.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"
End PropertyPrivate Sub txtTarget_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
        GetCaretPos ptCaretPos_Start
    End If
    RaiseEvent MouseDown(Button, Shift, x, y)
End SubPrivate Sub txtTarget_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lngSelStart As Long
    Dim lngSelEnd As Long
    Dim lngTmp As Long
    Dim intSelLength As Integer    If PtInRect(rcControl, x / 15, y / 15) Then
        
        If Button = vbLeftButton Then
            GetCaretPos ptCaretPos_End
            lngSelStart = ptCaretPos_Start.x / intCharWidth
            lngSelEnd = ptCaretPos_End.x / intCharWidth
            If lngSelStart > lngSelEnd Then
                lngTmp = lngSelStart
                lngSelStart = lngSelEnd
                lngSelEnd = lngTmp
            End If
            
            txtTarget.SelStart = lngSelStart
            txtTarget.SelLength = (lngSelEnd - lngSelStart)
        End If
        
        SetCapture txtTarget.hwnd
        If blnNotOver Then
            RaiseEvent MouseHover(Button, Shift, x, y)
            DrawFrame hbrHot
        Else
            RaiseEvent MouseMove(Button, Shift, x, y)
        End If
        blnNotOver = False
    Else
        ReleaseCapture
        RaiseEvent MouseLeave(Button, Shift)
        If blnHasFocus Then
            DrawFrame hbrFocus
        Else
            DrawFrame hbrFrame
        End If
        blnNotOver = True
    End If
End SubPublic Property Get MousePointer() As Integer
    MousePointer = txtTarget.MousePointer
End PropertyPublic Property Let MousePointer(ByVal New_MousePointer As Integer)
    txtTarget.MousePointer() = New_MousePointer
    PropertyChanged "MousePointer"
End PropertyPrivate Sub txtTarget_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    DrawFrame hbrFocus
    RaiseEvent MouseUp(Button, Shift, x, y)
End SubPublic Property Get MultiLine() As Boolean
    MultiLine = txtTarget.MultiLine
End PropertyPublic Property Get PasswordChar() As String
    PasswordChar = txtTarget.PasswordChar
End PropertyPublic Property Let PasswordChar(ByVal New_PasswordChar As String)
    txtTarget.PasswordChar() = New_PasswordChar
    PropertyChanged "PasswordChar"
End PropertyPublic Property Get SelLength() As Long
    SelLength = txtTarget.SelLength
End PropertyPublic Property Let SelLength(ByVal New_SelLength As Long)
    txtTarget.SelLength() = New_SelLength
    PropertyChanged "SelLength"
End PropertyPublic Property Get SelStart() As Long
    SelStart = txtTarget.SelStart
End PropertyPublic Property Let SelStart(ByVal New_SelStart As Long)
    txtTarget.SelStart() = New_SelStart
    PropertyChanged "SelStart"
End PropertyPublic Property Get SelText() As String
    SelText = txtTarget.SelText
End Property

Answer 1

Public Property Let SelText(ByVal New_SelText As String)
    txtTarget.SelText() = New_SelText
    PropertyChanged "SelText"
End PropertyPublic Property Get Text() As String
    Text = txtTarget.Text
End PropertyPublic Property Let Text(ByVal New_Text As String)
    txtTarget.Text() = New_Text
    PropertyChanged "Text"
End PropertyPublic Property Get ToolTipText() As String
    ToolTipText = txtTarget.ToolTipText
End PropertyPublic Property Let ToolTipText(ByVal New_ToolTipText As String)
    txtTarget.ToolTipText() = New_ToolTipText
    PropertyChanged "ToolTipText"
End PropertyPublic Property Get WhatsThisHelpID() As Long
    WhatsThisHelpID = txtTarget.WhatsThisHelpID
End PropertyPublic Property Let WhatsThisHelpID(ByVal New_WhatsThisHelpID As Long)
    txtTarget.WhatsThisHelpID() = New_WhatsThisHelpID
    PropertyChanged "WhatsThisHelpID"
End PropertyPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag)    txtTarget.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
    txtTarget.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    txtTarget.Enabled = PropBag.ReadProperty("Enabled", True)
    Set txtTarget.Font = PropBag.ReadProperty("Font", Ambient.Font)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    txtTarget.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
    txtTarget.Locked = PropBag.ReadProperty("Locked", False)
    txtTarget.MaxLength = PropBag.ReadProperty("MaxLength", 0)
    Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
    txtTarget.MousePointer = PropBag.ReadProperty("MousePointer", 0)
    'txtTarget.MultiLine = PropBag.ReadProperty("MultiLine", False)
    txtTarget.PasswordChar = PropBag.ReadProperty("PasswordChar", "")
    txtTarget.SelLength = PropBag.ReadProperty("SelLength", 0)
    txtTarget.SelStart = PropBag.ReadProperty("SelStart", 0)
    txtTarget.SelText = PropBag.ReadProperty("SelText", "")
    txtTarget.Text = PropBag.ReadProperty("Text", "")
    txtTarget.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
    txtTarget.WhatsThisHelpID = PropBag.ReadProperty("WhatsThisHelpID", 0)
    txtTarget.Alignment = PropBag.ReadProperty("Alignment", 0)
End SubPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag)    Call PropBag.WriteProperty("BackColor", txtTarget.BackColor, &H80000005)
    Call PropBag.WriteProperty("BorderStyle", txtTarget.BorderStyle, 1)
    Call PropBag.WriteProperty("Enabled", txtTarget.Enabled, True)
    Call PropBag.WriteProperty("Font", txtTarget.Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", txtTarget.ForeColor, &H80000008)
    Call PropBag.WriteProperty("Locked", txtTarget.Locked, False)
    Call PropBag.WriteProperty("MaxLength", txtTarget.MaxLength, 0)
    Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
    Call PropBag.WriteProperty("MousePointer", txtTarget.MousePointer, 0)
    'Call PropBag.WriteProperty("MultiLine", txtTarget.MultiLine, False)
    Call PropBag.WriteProperty("PasswordChar", txtTarget.PasswordChar, "")
    Call PropBag.WriteProperty("SelLength", txtTarget.SelLength, 0)
    Call PropBag.WriteProperty("SelStart", txtTarget.SelStart, 0)
    Call PropBag.WriteProperty("SelText", txtTarget.SelText, "")
    Call PropBag.WriteProperty("Text", txtTarget.Text, "")
    Call PropBag.WriteProperty("ToolTipText", txtTarget.ToolTipText, "")
    Call PropBag.WriteProperty("WhatsThisHelpID", txtTarget.WhatsThisHelpID, 0)
    Call PropBag.WriteProperty("Alignment", txtTarget.Alignment, 0)
End SubPublic Property Get Alignment() As Integer
    Alignment = txtTarget.Alignment
End PropertyPublic Property Let Alignment(ByVal New_Alignment As Integer)
    txtTarget.Alignment() = New_Alignment
    PropertyChanged "Alignment"
End PropertyPrivate Sub DrawFrame(ByVal hbrDraw As Long)
    Dim hdcText         As Long                 'TextBox的设备场景
    Dim hbrOld          As Long                 '设备场景中原来的刷子的句柄
    
    '获得设备场景
    hdcText = GetWindowDC(txtTarget.hwnd)    '将用于绘制边框的刷子选入设备场景
    hbrOld = SelectObject(hdcText, hbrDraw)    '绘制边框
    FrameRgn hdcText, hrgnControl, hbrDraw, FRAMEWIDTH, FRAMEWIDTH    '将用于绘制边框的刷子选出设备场景
    SelectObject hdcText, hbrOld    '释放设备场景
    ReleaseDC txtTarget.hwnd, hdcText
End Sub=======================
拷贝以上代码到一个Usercontrol中.问题是:
1.这个控件方到窗体上的时候.下边框总是太细.如果把控件放大后就没有问题了.
我想能否让控件边框始终都有相同大小的有颜色的那种边框
2.在这个控件上输入文本后.无法用鼠标选择文本...
因为问题紧急,源码都已经开放了...实在是急啊..大家帮帮忙好么?????????????
我会另外给分.1.

Answer 2

txtTarget的高度有其最小值，而自制控件的大小改变随Usercontrol的大小而变。当调整自制控件的高度时，txtTarget的高度跟着调整，但一旦小于其最小值，将会自动回复等于最小值。

Answer 3

注意单位换算，在txtTarget_MouseMove事件中以下两句改为
 
lngSelStart = ptCaretPos_Start.x * 567 / intCharWidth
lngSelEnd = ptCaretPos_End.x * 567 / intCharWidth试试

Answer 4

'第2个问题
'定义一个变量
dim xStart as singlePrivate Sub txtTarget_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
'        GetCaretPos ptCaretPos_Start '取消此句
        oX = x
    End If
    RaiseEvent MouseDown(Button, Shift, x, y)
End SubPrivate Sub txtTarget_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lngSelStart As Long
    Dim lngSelEnd As Long
    Dim lngTmp As Long
    Dim intSelLength As Integer    If PtInRect(rcControl, x / 15, y / 15) Then
        
        If Button = vbLeftButton Then
            GetCaretPos ptCaretPos_End
'**************************这样修改即可*****************            
            lngSelStart = xStart * 56.7 / intCharWidth
            lngSelEnd = x * 56.7 / intCharWidth
            
'            lngSelStart = ptCaretPos_Start.x / intCharWidth
'            lngSelEnd = ptCaretPos_End.x / intCharWidth
'*********************************************************
            If lngSelStart > lngSelEnd Then
                lngTmp = lngSelStart
                lngSelStart = lngSelEnd
                lngSelEnd = lngTmp
            End If
            
            txtTarget.SelStart = lngSelStart
            txtTarget.SelLength = (lngSelEnd - lngSelStart)
            Debug.Print lngSelStart, lngSelEnd
        End If
        
        SetCapture txtTarget.hwnd
        If blnNotOver Then
            RaiseEvent MouseHover(Button, Shift, x, y)
            DrawFrame hbrHot
        Else
            RaiseEvent MouseMove(Button, Shift, x, y)
        End If
        blnNotOver = False
    Else
        ReleaseCapture
        RaiseEvent MouseLeave(Button, Shift)
        If blnHasFocus Then
            DrawFrame hbrFocus
        Else
            DrawFrame hbrFrame
        End If
        blnNotOver = True
    End If
End Sub

Answer 5

Private Sub txtTarget_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
'        GetCaretPos ptCaretPos_Start '取消此句
        'oX = x    <=====这里写错了   *******************
        xStart=x  '<=====改为         *******************
    End If
    RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

Answer 6

happyVB(因为vb快乐) :对的，那里写错了，我太习惯用oX了

Answer 7

Private Sub txtTarget_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
'        GetCaretPos ptCaretPos_Start '取消此句
        oX = x
    End If
    RaiseEvent MouseDown(Button, Shift, x, y)
End SubPrivate Sub txtTarget_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lngSelStart As Long
    Dim lngSelEnd As Long
    Dim lngTmp As Long
    Dim intSelLength As Integer    If PtInRect(rcControl, x / 15, y / 15) Then
        
        If Button = vbLeftButton Then
            GetCaretPos ptCaretPos_End
'**************************这样修改即可*****************            
            lngSelStart = xStart * 56.7 / intCharWidth
            lngSelEnd = x * 56.7 / intCharWidth
            
'            lngSelStart = ptCaretPos_Start.x / intCharWidth
'            lngSelEnd = ptCaretPos_End.x / intCharWidth
'*********************************************************
            If lngSelStart > lngSelEnd Then
                lngTmp = lngSelStart
                lngSelStart = lngSelEnd
                lngSelEnd = lngTmp
            End If
            
            txtTarget.SelStart = lngSelStart
            txtTarget.SelLength = (lngSelEnd - lngSelStart)
            Debug.Print lngSelStart, lngSelEnd
        End If
        
        SetCapture txtTarget.hwnd
        If blnNotOver Then
            RaiseEvent MouseHover(Button, Shift, x, y)
            DrawFrame hbrHot
        Else
            RaiseEvent MouseMove(Button, Shift, x, y)
        End If
        blnNotOver = False
    Else
        ReleaseCapture
        RaiseEvent MouseLeave(Button, Shift)
        If blnHasFocus Then
            DrawFrame hbrFocus
        Else
            DrawFrame hbrFrame
        End If
        blnNotOver = True
    End If
End Sub 我这样改了.可是问题好像没有解决....
控件的底边还是比别的边细噢.
还有.无法用鼠标选择文本..

Answer 8

没错，我调试过了，只不过这里打错了：
Private Sub txtTarget_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
'        GetCaretPos ptCaretPos_Start '取消此句
'*****************************************************************
        'oX = x        <-------错了！！！！！！！！！11，改为：
        xStart=x  '<=====改为         *******************
'*****************************************************************
    End If
    RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

Answer 9

sorry
我一来没有ide环境，二来，我也没有时间，最近我只能每个星期上网n个小时(n<10)
sorry

Answer 10

sorry
我一来没有ide环境，二来，我也没有时间，最近我只能每个星期上网n个小时(n<10)
sorry

Answer 11

你可以根据 txtTarget的高度来限定UseControl 的高度，这样更符合VB的本意。如:
UserControl_Resize事件中：    Height = IIf(Height < TextHeight("a"), TextHeight("a"), Height)
    txtTarget.Move 0, 0, Width, Height