lightedit.ctl

此源码为vb圣经编码

VERSION 5.00
Begin VB.UserControl LightEdit 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   ClientHeight    =   630
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2295
   ClipBehavior    =   0  'None
   HasDC           =   0   'False
   HitBehavior     =   0  'None
   KeyPreview      =   -1  'True
   MousePointer    =   3  'I-Beam
   ScaleHeight     =   42
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   153
   ToolboxBitmap   =   "LightEdit.ctx":0000
   Windowless      =   -1  'True
End
Attribute VB_Name = "LightEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'***************************************************************
Option Explicit
Implements OleTypes.IHookAccelerator
Implements OleTypes.IHookWindowlessMessage
Private m_IPAOHook As IPAOHook
Private m_WLSC As WindowlessSubclass
Private m_Hook As UnknownHook
Private Type HookData
    AggData(0) As AggregateData
    IIDs(0) As IID
End Type

Public Enum LightEditBackStyle
    Transparent
    Opaque
End Enum
Public Enum LightEditClipBehavior
    [Clip None]
    [Clip Use Region]
End Enum
Public Enum LightEditHitBehavior
    [Hit None]
    [Hit Use Region]
    [Hit Use Paint]
End Enum

Private Const vbNullString As String = "" 'Override vbNullString in this module to stop API blowups
Private m_fShowCaret As Boolean
Private m_fHaveFocus As Boolean
Private m_Text As String
Private m_SelStart As Integer
Private m_SelLen As Integer
Private m_LeftChar As Integer
Private m_fHaveMouse As Boolean   'Do we current have control of the mouse?
Private m_fSkipPaint As Boolean   'Don't do the paint event
Private m_CachedRect As RECT      'Cache for window rectangle when we own the mouse.
Private m_CachedSite As IOleInPlaceSiteWindowless

'Event Declarations:
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event Resize() 'MappingInfo=UserControl,UserControl,-1,Resize
Attribute Resize.VB_Description = "Occurs when a form is first displayed or the size of an object changes."
Event HitTest(X As Single, Y As Single, HitResult As VBRUN.HitResultConstants) 'MappingInfo=UserControl,UserControl,-1,HitTest
Event Change()

Private Sub IHookAccelerator_TranslateAccelerator(lpmsg As OleTypes.MSG, hrReturnCode As Long)
Dim plResult As LRESULT
Dim pIPOWL As IOleInPlaceObjectWindowless
    'Return code defaults to S_FALSE (1)
    With lpmsg
        If .message = WM_KEYDOWN Then
            Select Case .wParam And &HFFFF& 'LOWORD of wparam
                Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyHome, vbKeyEnd
                    Set pIPOWL = Me
                    hrReturnCode = pIPOWL.OnWindowMessage(.message, .wParam, .lParam, plResult)
            End Select
        End If
    End With
End Sub

Private Sub IHookWindowlessMessage_OnWindowMessage(ByVal fBefore As Boolean, ByVal uMsg As VBoostTypes.UINT, ByVal wParam As VBoostTypes.wParam, ByVal lParam As VBoostTypes.lParam, plResult As OleTypes.LRESULT, hrReturnCode As Long)
    Select Case uMsg
        Case WM_SETFOCUS
            m_fHaveFocus = True
            DisplayCaret
            OverrideActiveObject m_IPAOHook, Me
        Case WM_KILLFOCUS
            LoseCaret
            m_fHaveFocus = False
    End Select
End Sub

Private Sub UserControl_DblClick()
Dim pSite As IOleInPlaceSiteWindowless
Dim PosRect As RECT
    If m_SelStart = 0 And m_SelLen = Len(m_Text) Then Exit Sub
    m_SelStart = 0
    m_SelLen = Len(m_Text)
    Set pSite = WindowLessSite
    UpdateCaretPos pSite, CtlRect(pSite), True
End Sub

Private Sub UserControl_Initialize()
    m_Text = vbNullString
    If VBoost Is Nothing Then InitVBoost
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
    Select Case KeyCode
        Case vbKeyDelete
            If Shift = vbShiftMask Then
                If m_SelLen Then
                    'Cut
                    If DoCopy Then DeleteText False
                End If
            Else
                DeleteText False
            End If
        Case vbKeyUp, vbKeyRight
            MoveCursor 1, False, Shift And vbShiftMask
        Case vbKeyDown, vbKeyLeft
            MoveCursor -1, False, Shift And vbShiftMask
        Case vbKeyHome
            MoveCursor 0, True, Shift And vbShiftMask
        Case vbKeyEnd
            MoveCursor Len(m_Text), True, Shift And vbShiftMask
        Case vbKeyInsert
            If Shift = vbCtrlMask Then
                'Copy
                DoCopy
            ElseIf Shift = vbShiftMask Then
                'Paste
                On Error Resume Next
                InsertText Clipboard.GetText
                On Error GoTo 0
            End If
        Case vbKeyX
            If Shift = vbCtrlMask And CBool(m_SelLen) Then
                'Cut
                If DoCopy Then DeleteText False
            End If
        Case vbKeyC
            If Shift = vbCtrlMask Then
                'Copy
                DoCopy
            End If
        Case vbKeyV
            If Shift = vbCtrlMask Then
                'Paste
                On Error Resume Next
                InsertText Clipboard.GetText
                On Error GoTo 0
            End If
    End Select
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
    Select Case KeyAscii
        Case vbKeyBack
            DeleteText True
        Case Else
            If KeyAscii >= vbKeySpace Then InsertText Chr$(KeyAscii)
    End Select
End Sub
Private Sub MoveCursor(ByVal Distance As Integer, ByVal fAbsolute As Boolean, ByVal fExtendSelection As Boolean)
Dim SelStart As Long
Dim SelLen As Long
Dim TextLen As Long
Dim NewSelStart As Long
Dim NewSelLen As Long
Dim NewPos As Long
Dim CursorPos As Long
Dim pSite As IOleInPlaceSiteWindowless
Dim fNoUpdate As Boolean
Dim fForceRepaint As Boolean
    TextLen = Len(m_Text)
    If TextLen = 0 Then Exit Sub
    If fAbsolute Then
        If fExtendSelection Then
            NewSelStart = m_SelStart
            NewSelLen = Distance - m_SelStart
        Else
            NewSelStart = Distance
            NewSelLen = 0
        End If
    Else
        CursorPos = m_SelStart + m_SelLen + Distance
        If fExtendSelection Then
            If CursorPos < 0 Or CursorPos > TextLen Then Exit Sub
            NewSelStart = m_SelStart
            NewSelLen = m_SelLen + Distance
        Else
            If CursorPos < 0 Or CursorPos > TextLen Then
                NewSelStart = m_SelStart + m_SelLen
            Else
                NewSelStart = CursorPos
            End If
            NewSelLen = 0
        End If
    End If
    If NewSelStart <> m_SelStart Or NewSelLen <> m_SelLen Then
        fForceRepaint = m_SelLen <> NewSelLen
        m_SelStart = NewSelStart
        m_SelLen = NewSelLen
        Set pSite = WindowLessSite
        UpdateCaretPos pSite, CtlRect(pSite), fForceRepaint
    End If
End Sub
Private Sub DeleteText(ByVal fKillPrev As Boolean)
Dim SelStart As Long
Dim SelLen As Long
Dim TextLen As Long
Dim pSite As IOleInPlaceSiteWindowless
Dim fNoUpdate As Boolean
    TextLen = Len(m_Text)
    If TextLen Then
        'Normalize selection values
        NormalizeSelection SelStart, SelLen
        
        If SelLen Then
            'Just delete the selection, regardless of whether
            'we're killing the previous or next character.
            If SelStart Then
                'There is text before the selection
                If SelStart + SelLen = TextLen Then
                    m_Text = Left$(m_Text, SelStart)
                Else
                    m_Text = Left$(m_Text, SelStart) & Right$(m_Text, TextLen - SelStart - SelLen)
                End If
            ElseIf SelLen = TextLen Then
                'The whole item is selected
                m_Text = vbNullString
            Else
                'Text after selection only
                m_Text = Right$(m_Text, TextLen - SelStart - SelLen)
            End If
            m_SelStart = SelStart
        Else
            If fKillPrev Then
                If SelStart Then
                    If SelStart = 1 Then
                        m_Text = Mid$(m_Text, 2)
                    Else
                        m_Text = Left$(m_Text, SelStart - 1) & Right$(m_Text, TextLen - SelStart)
                    End If
                    m_SelStart = SelStart - 1
                Else
                    fNoUpdate = True
                End If
            Else
                If SelStart < TextLen Then
                    If SelStart = TextLen - 1 Then
                        m_Text = Left$(m_Text, SelStart)
                    Else
                        m_Text = Left$(m_Text, SelStart) & Right$(m_Text, TextLen - SelStart - 1)
                    End If
                Else
                    fNoUpdate = True
                End If
            End If
        End If
        m_SelLen = 0
        If Not fNoUpdate Then
            Set pSite = WindowLessSite
            UpdateCaretPos pSite, CtlRect(pSite), True
            RaiseEvent Change
        End If
    End If
End Sub
Private Sub InsertText(NewText As String)
Dim SelStart As Long
Dim SelLen As Long
Dim TextLen As Long
Dim pSite As IOleInPlaceSiteWindowless
    TextLen = Len(m_Text)
    LoseCaret
    If TextLen Then
        NormalizeSelection SelStart, SelLen
        If SelStart Then
            If SelLen Then
                If SelStart + SelLen = TextLen Then
                    m_Text = Left$(m_Text, SelStart) & NewText
                Else
                    m_Text = Left$(m_Text, SelStart) & NewText & Right$(m_Text, TextLen - SelStart - SelLen)
                End If
            Else
                m_Text = Left$(m_Text, SelStart) & NewText & Right$(m_Text, TextLen - SelStart)
            End If
        Else
            If SelLen Then
                m_Text = NewText & Right$(m_Text, TextLen - SelStart - SelLen)
            Else
                m_Text = NewText & m_Text
            End If
        End If
        m_SelStart = SelStart + Len(NewText)
        m_SelLen = 0
    Else
        m_Text = NewText
        m_SelLen = 0