minimaleditwl.ctl

VB圣经

VERSION 5.00
Begin VB.UserControl MinimalEditWL 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BackStyle       =   0  'Transparent
   ClientHeight    =   450
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1200
   ClipControls    =   0   'False
   HasDC           =   0   'False
   ScaleHeight     =   30
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   80
   ToolboxBitmap   =   "MinimalEditWL.ctx":0000
   Windowless      =   -1  'True
End
Attribute VB_Name = "MinimalEditWL"
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

'InPlaceActiveObject hooking
Implements OleTypes.IHookAccelerator
Private m_IPAOHook As IPAOHook

'OnWindowMessage hooking
Implements OleTypes.IHookWindowlessMessage
Private Type HookData
    AggData(0) As AggregateData
    IIDs(0) As IID
End Type
Private m_WLSC As WindowlessSubclass
Private m_Hook As UnknownHook

Private m_fDesign As Boolean

'SubClassData and window handle for created window
Private m_SubClassEdit As SubClassData
Private m_hWndEdit As Long

Private m_SubClassParent As SubClassData
Private m_hWndParent As Long

Friend Function WindowProcParent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_CTLCOLOREDIT
            'Bypass VB on this message, it doesn't let it drop through
            If lParam = m_hWndEdit Then
                WindowProcParent = DefWindowProc(hWnd, uMsg, wParam, lParam)
                Exit Function
            End If
    End Select
    WindowProcParent = CallWindowProc(m_SubClassParent.wndprocNext, hWnd, uMsg, wParam, lParam)
End Function

Friend Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_SETFOCUS
            'Get in-place frame and make sure it is set to our in-between
            'implementation of IOleInPlaceActiveObject in order to catch
            'TranslateAccelerator calls
            OverrideActiveObject m_IPAOHook, Me
        Case WM_MOUSEACTIVATE
            If GetFocus <> m_hWndEdit Then
                UserControl.SetFocus
                'SetFocusAPI UserControl.hWnd
                WindowProc = MA_NOACTIVATE
                Exit Function
            End If
    End Select
    WindowProc = CallWindowProc(m_SubClassEdit.wndprocNext, hWnd, uMsg, wParam, ByVal lParam)
End Function
Private Sub IHookAccelerator_TranslateAccelerator(lpmsg As OleTypes.MSG, hrReturnCode As Long)
    'hrReturnCode defaults to S_FALSE (1)
    With lpmsg
        If .message = WM_KEYDOWN Then
            Select Case LOWORD(lpmsg.wParam)
                Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
                    DoMsg .message, .wParam, .lParam
                    hrReturnCode = 0
            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)
    If uMsg = WM_SETFOCUS Then
        If m_hWndEdit Then SetFocusAPI m_hWndEdit
    End If
End Sub

Private Sub UserControl_AmbientChanged(PropertyName As String)
    If m_fDesign Then
        If PropertyName = "DisplayName" Then UserControl.Refresh
    End If
End Sub

Private Sub UserControl_InitProperties()
    InitializeMode
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    InitializeMode
End Sub

Private Sub UserControl_Terminate()
    If Not m_fDesign Then
        If m_hWndParent Then UnSubClass m_SubClassParent, m_hWndParent
        If m_hWndEdit Then UnSubClass m_SubClassEdit, m_hWndEdit
        m_hWndParent = 0
        m_hWndEdit = 0
    End If
End Sub

Private Sub UserControl_Paint()
Dim rct As RECT
    If m_fDesign Then
        With UserControl
            rct.Right = ScaleWidth
            rct.Bottom = ScaleHeight
            DrawEdge .hDC, rct, EDGE_SUNKEN, BF_RECT
            .CurrentX = 4
            .CurrentY = 2
            UserControl.Print .Ambient.DisplayName
        End With
    End If
End Sub

Private Sub UserControl_Resize()
    If m_hWndEdit Then
        With CtlRect(WindowLessSite)
            SetWindowPos m_hWndEdit, 0, .Left, .Top, .Right - .Left, .Bottom - .Top, SWP_NOZORDER Or SWP_NOACTIVATE
        End With
    End If
End Sub

Private Function DoMsg(ByVal uMsg As Long, Optional ByVal wParam As Long = 0, Optional ByVal lParam As Long = 0) As Long
    DoMsg = CallWindowProc(m_SubClassEdit.wndprocNext, m_hWndEdit, uMsg, wParam, lParam)
End Function

Private Sub NoPropertySheet()
    'To keep a property out of both the locals window and the
    'property sheet, check the 'Don't show in Property Browser'
    'attribute, available on the Advanced tab of the Tools/Procedure
    'Attributes dialog.  To stop the item from showing in the
    'property sheet, but still support it in the locals window,
    'use this approach.
    
    'If you stop on this error, then right click on the
    'code pane and choose Toggle/Break on Unhandled Errors.
    'You can set the default for this setting in the Tools/Options
    'dialog on the General tab.
    If m_fDesign Then Err.Raise 394 'GetNotSupported
End Sub

'Call at the top of a property Let to indicate that
'this property should be set only at design time.
Private Sub DesignTimeOnly()
    If Not m_fDesign Then Err.Raise 382
End Sub

Private Sub SetDesignMode()
    On Error Resume Next
    m_fDesign = Not Ambient.UserMode
    If Err Then m_fDesign = True
    On Error GoTo 0
End Sub

Private Sub InitializeMode()
Dim pFont As IFont
Dim rct As RECT
Dim HookData As HookData
    SetDesignMode
    If Not m_fDesign Then
        If m_hWndEdit Then Exit Sub
        InitializeIPAOHook m_IPAOHook, Me
        With UserControl
            rct = CtlRect(WindowLessSite)
            m_hWndEdit = CreateWindowEx(WS_EX_CLIENTEDGE, "EDIT", vbNullString, _
                       WS_CHILD Or WS_CLIPSIBLINGS Or WS_TABSTOP, rct.Left, rct.Top, rct.Right - rct.Left, rct.Bottom - rct.Top, UserControl.ContainerHwnd, 0, App.hInstance, ByVal 0&)
            If m_hWndEdit Then
                Set pFont = .Font
                SendMessage m_hWndEdit, WM_SETFONT, pFont.hFont, ByVal 1&
                SubClass m_SubClassEdit, m_hWndEdit, ObjPtr(Me), AddressOf RedirectEditProc
                m_hWndParent = UserControl.ContainerHwnd
                SubClass m_SubClassParent, m_hWndParent, ObjPtr(Me), AddressOf RedirectEditProcParent
                ShowWindow m_hWndEdit, SW_SHOW
            End If
            With HookData
                InitializeWindowlessSubclass m_WLSC, Me, nmNotifyAfter, .AggData(0), .IIDs(0), 0
                VBoost.AggregateUnknown Me, .AggData, .IIDs, m_Hook
            End With
        End With
    Else
        UserControl.BackStyle = 1 'Opaque
    End If
End Sub
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 = LenB(FrameInfo)
    pSite.GetWindowContext pFrame, pDoc, CtlRect, ClipRect, FrameInfo
End Function