lightedit.ctl

此源码为vb圣经编码

        m_SelStart = Len(NewText)
    End If
    Set pSite = WindowLessSite
    UpdateCaretPos pSite, CtlRect(pSite), True
    RaiseEvent Change
End Sub

Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer)
Dim HitResultPassed As VBRUN.HitResultConstants
    HitResultPassed = vbHitResultHit
    RaiseEvent HitTest(X, Y, HitResultPassed)
    HitResult = HitResultPassed
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
Dim fForceRepaint As Boolean
    If Button = vbLeftButton Then
        m_fHaveMouse = True
        Set m_CachedSite = WindowLessSite
        m_CachedRect = CtlRect(m_CachedSite)
        m_SelStart = SelectionFromPosition(m_CachedSite, m_CachedRect, X)
        fForceRepaint = CBool(m_SelLen)
        m_SelLen = 0
        UpdateCaretPos m_CachedSite, m_CachedRect, fForceRepaint
    End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
Dim iCurPos As Long
Dim NewSelLen As Long
    If m_fHaveMouse Then
        iCurPos = SelectionFromPosition(m_CachedSite, m_CachedRect, X)
        NewSelLen = iCurPos - m_SelStart
        If NewSelLen <> m_SelLen Then
            m_SelLen = NewSelLen
            UpdateCaretPos m_CachedSite, m_CachedRect, True
        End If
    End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
    If Button = vbLeftButton Then
        Set m_CachedSite = Nothing
        m_fHaveMouse = False
    End If
End Sub

Private Function SelectionFromPosition(pSite As IOleInPlaceSiteWindowless, PosRect As RECT, X As Single) As Integer
Dim Size As Size
Dim hDC As hDC
Dim iChar As Long
Dim hFontOld As Long
Dim pFont As IFont
Dim pString As Long
    If X <= 0 Then
        SelectionFromPosition = 0
    Else
        hDC = pSite.GetDC(PosRect, OLEDC_NODRAW)
        Set pFont = UserControl.Font
        hFontOld = SelectObject(hDC, pFont.hFont)
        If UnicodeSystem Then
            pString = StrPtr(m_Text)
            If m_LeftChar Then
                pString = VBoost.UAdd(pString, 2 * m_LeftChar)
            End If
            GetTextExtentExPointW hDC, pString, Len(m_Text) - m_LeftChar, X, iChar, ByVal 0&, Size
        Else
            If m_LeftChar Then
                GetTextExtentExPointA hDC, Mid$(m_Text, m_LeftChar + 1), Len(m_Text) - m_LeftChar, X, iChar, ByVal 0&, Size
            Else
                GetTextExtentExPointA hDC, m_Text, Len(m_Text), X, iChar, ByVal 0&, Size
            End If
        End If
        SelectObject hDC, hFontOld
        pSite.ReleaseDC hDC
        SelectionFromPosition = iChar + m_LeftChar
    End If
End Function

Private Sub UserControl_Paint()
Dim hDC As Long
Dim pSite As IOleInPlaceSiteWindowless
Dim PosRect As RECT
    If m_fSkipPaint Then Exit Sub

    'If we're transparent, then use the provided hDC
    'Otherwise, get our own for smoother drawing.
    If UserControl.BackStyle = 1 Then
        Set pSite = WindowLessSite
        PosRect = CtlRect(pSite)
        hDC = pSite.GetDC(PosRect, OLEDC_DEFAULT)
        DoPaint hDC, PosRect
        pSite.ReleaseDC hDC
    Else
        PosRect.Right = UserControl.ScaleWidth
        PosRect.Bottom = UserControl.ScaleHeight
        DoPaint UserControl.hDC, PosRect
    End If
End Sub
Private Sub DoPaint(ByVal hDC As Long, PosRect As RECT)
Dim pFont As IFont
Dim hFontStart As Long
Dim TAStart As TAFlags
Dim TextColorStart As Long
Dim BkColorStart As Long
Dim BkModeStart As Long
Dim BkMode As Long
Dim pString As Long
Dim SelStart As Long
Dim SelLen As Long
Dim TextLen As Long

    'See if there's anything to do
    TextLen = Len(m_Text) - m_LeftChar
    If TextLen <= 0 Then Exit Sub
    
    'Clear out caret before painting
    If m_fShowCaret Then HideCaret UserControl.ContainerHwnd
    
    'Get font and background information
    Set pFont = UserControl.Font
    BkMode = BackStyle + 1
    
    'Select objects into the DC
    hFontStart = SelectObject(hDC, pFont.hFont)
    TAStart = SetTextAlign(hDC, TA_LEFT Or TA_UPDATECP)
    TextColorStart = SetTextColor(hDC, AdjustColor(ForeColor))
    BkColorStart = SetBkColor(hDC, AdjustColor(BackColor))
    BkModeStart = SetBkMode(hDC, BkMode)
    MoveToEx hDC, PosRect.Left, PosRect.Top
    
    'Initialize selection information
    NormalizeSelection SelStart, SelLen
    If SelStart < m_LeftChar Then
        If SelStart + SelLen > m_LeftChar Then
            SelLen = SelStart + SelLen - m_LeftChar
            SelStart = 0 'm_LeftChar
        End If
    Else
        SelStart = SelStart - m_LeftChar
        If SelStart = TextLen Then
            SelLen = 0
        Else
            SelLen = SelLen
        End If
    End If
    
    'Get the beginning of the string to draw
    pString = StrPtr(m_Text)
    If m_LeftChar Then
        pString = VBoost.UAdd(pString, 2 * m_LeftChar)
    End If
    
    If SelLen = 0 Then
        'Draw all of the text at once
        ExtTextOutW hDC, 0, 0, ETO_NONE, PosRect, pString, TextLen
    Else
        'Draw portion before the selection
        If SelStart > 0 Then
            ExtTextOutW hDC, 0, 0, ETO_NONE, PosRect, pString, SelStart
            pString = VBoost.UAdd(pString, 2 * SelStart)
        End If
        
        'Draw selection
        SetTextColor hDC, AdjustColor(vbHighlightText)
        SetBkColor hDC, AdjustColor(vbHighlight)
        SetBkMode hDC, APIOPAQUE
        ExtTextOutW hDC, 0, 0, ETO_NONE, PosRect, pString, SelLen
        
        'Draw portion after selection
        If SelStart + SelLen < TextLen Then
            SetTextColor hDC, AdjustColor(ForeColor)
            SetBkColor hDC, AdjustColor(BackColor)
            SetBkMode hDC, BkMode
            pString = VBoost.UAdd(pString, 2 * SelLen)
            ExtTextOutW hDC, 0, 0, ETO_NONE, PosRect, pString, TextLen - SelStart - SelLen
        End If
    End If
    
    'Restore DC settings
    SelectObject hDC, hFontStart
    SetTextAlign hDC, TAStart
    SetBkColor hDC, BkColorStart
    SetBkMode hDC, BkModeStart
    SetTextColor hDC, TextColorStart
    If m_fShowCaret Then ShowCaret UserControl.ContainerHwnd
End Sub
Private Function AdjustColor(ByVal StartColor As Long) As Long
    If StartColor And SysColorBit Then
        AdjustColor = GetSysColor(StartColor And SysColorMask)
    Else
        AdjustColor = StartColor
    End If
End Function
Private Function WindowLessSite() As IOleInPlaceSiteWindowless
Dim pOleObject As IOleObject
    Set pOleObject = Me
    Set WindowLessSite = pOleObject.GetClientSite
End Function
Private Function CtlRect(pSite As IOleInPlaceSiteWindowless) As RECT
Dim pFrame As IOleInPlaceFrame
Dim pDoc As IOleInPlaceUIWindow
Dim ClipRect As RECT
Dim FrameInfo As OLEINPLACEFRAMEINFO
    FrameInfo.cb = Len(FrameInfo)
    pSite.GetWindowContext pFrame, pDoc, CtlRect, ClipRect, FrameInfo
End Function
Private Sub UpdateCaretPos(pSite As IOleInPlaceSiteWindowless, PosRect As RECT, ByVal fForceRepaint As Boolean)
Dim hDC As Long
Dim Size As Size
Dim pFont As IFont
Dim OldFont As Long
Dim pString As Long
Dim CaretPos As Long
Dim TextLen As Long
Dim CaretRect As RECT
Dim hWndContainer As Long
Dim OverFlow As Long
Dim iRightChar As Long
Dim SizeRightChar As Size
Dim fTriedOverflow As Boolean
Dim LeftCharStart As Long
Dim fShowCaret As Boolean
    hWndContainer = UserControl.ContainerHwnd
    LeftCharStart = m_LeftChar
    If m_fShowCaret Then
        HideCaret hWndContainer
        m_fShowCaret = False
    End If
    fShowCaret = True
    pString = StrPtr(m_Text)
    CaretPos = m_SelStart + m_SelLen
    If m_LeftChar Then
        pString = VBoost.UAdd(pString, 2 * m_LeftChar)
        If CaretPos >= m_LeftChar Then
            CaretPos = CaretPos - m_LeftChar
        Else
            'Move 4 at a time
            m_LeftChar = CaretPos - 4
            If m_LeftChar < 0 Then m_LeftChar = 0
            pString = VBoost.UAdd(StrPtr(m_Text), 2 * m_LeftChar)
        End If
    End If
    
    'Get the textwidth from the DC
    hDC = pSite.GetDC(PosRect, OLEDC_NODRAW)
    Set pFont = UserControl.Font
    OldFont = SelectObject(hDC, pFont.hFont)
GetSize:
    If CaretPos = 0 Then
        GetTextExtentPoint32W hDC, pString, 1, Size
        Size.cx = 0
    Else
        GetTextExtentPoint32W hDC, pString, CaretPos, Size
    End If
    If Not fTriedOverflow Then
        OverFlow = Size.cx - (PosRect.Right - PosRect.Left + 1)
        If OverFlow > 0 Then
            If UnicodeSystem Then
                GetTextExtentExPointW hDC, pString, Len(m_Text) - m_LeftChar, PosRect.Right - PosRect.Left, iRightChar, ByVal 0&, SizeRightChar
            Else
                If m_LeftChar Then
                    GetTextExtentExPointA hDC, Mid$(m_Text, m_LeftChar + 1), Len(m_Text) - m_LeftChar, PosRect.Right - PosRect.Left, iRightChar, ByVal 0&, SizeRightChar
                Else
                    GetTextExtentExPointA hDC, m_Text, Len(m_Text) - m_LeftChar, PosRect.Right - PosRect.Left, iRightChar, ByVal 0&, SizeRightChar
                End If
            End If
            m_LeftChar = m_LeftChar + CaretPos - iRightChar + 4
            If m_LeftChar < 0 Then m_LeftChar = 0
            CaretPos = m_SelStart + m_SelLen - m_LeftChar
            If CaretPos < 0 Then CaretPos = 0
            pString = VBoost.UAdd(StrPtr(m_Text), 2 * m_LeftChar)
            fTriedOverflow = True
            GoTo GetSize
        End If
    End If
    SelectObject hDC, OldFont
    pSite.ReleaseDC hDC
    
    'Now, get a DC suitable for painting and paint the control,
    'but only if we're forced or we moved the string.
    If fForceRepaint Or LeftCharStart <> m_LeftChar Then
        m_fSkipPaint = True
        Cls
        m_fSkipPaint = False
        hDC = pSite.GetDC(PosRect, OLEDC_OFFSCREEN)
        DoPaint hDC, PosRect
        pSite.ReleaseDC hDC
    End If
    
    'See if this particular caret position is even visible.
    'It can either be scrolled off, which is unlikely due to
    'the previous checking, or it can be behind another
    'control in the zorder.
    CaretRect.Left = PosRect.Left + Size.cx
    CaretRect.Right = CaretRect.Left + 1
    CaretRect.Top = PosRect.Top
    CaretRect.Bottom = PosRect.Top + Size.cy
    If pSite.AdjustRect(CaretRect) = 1 Then
        'Don't turn on m_fShowCaret
    Else
        IntersectRect CaretRect, CaretRect, PosRect
        CreateCaret hWndContainer, 0, 0, CaretRect.Bottom - CaretRect.Top
        SetCaretPos PosRect.Left + Size.cx, PosRect.Top
        ShowCaret hWndContainer
        m_fShowCaret = True
    End If
End Sub
Private Sub LoseCaret()
    If m_fShowCaret Then
        m_fShowCaret = False
        HideCaret UserControl.ContainerHwnd
    End If
End Sub
Private Sub DisplayCaret()
Dim pSite As IOleInPlaceSiteWindowless
    Set pSite = WindowLessSite
    UpdateCaretPos pSite, CtlRect(pSite), False
End Sub
Private Function DoCopy() As Boolean
Dim strCopyText As String
Dim SelStart As Long
Dim SelLen As Long
    If m_SelLen Then
        NormalizeSelection SelStart, SelLen
        strCopyText = Mid$(m_Text, SelStart + 1, SelLen)
        DoCopy = True