minimaledit.ctl

VB圣经

VERSION 5.00
Begin VB.UserControl MinimalEdit 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   ClientHeight    =   450
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1200
   ClipControls    =   0   'False
   ScaleHeight     =   30
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   80
   ToolboxBitmap   =   "MinimalEdit.ctx":0000
End
Attribute VB_Name = "MinimalEdit"
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
Private m_IPAOHook As IPAOHook

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
        'Special code to get the correct background color on the edit control
        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
    'Note: You can do something similar here without the parent window
    'subclass by calling SetFocusAPI m_hWndEdit in UserControl_GotFocus.
    'However, with the subclass, the focus will be set correctly on the
    'child window before you reach any of the events, and you will generally
    'need to handle other messages in the parent window anyway.
    WindowProcParent = CallWindowProc(m_SubClassParent.wndprocNext, hWnd, uMsg, wParam, lParam)
    If uMsg = WM_SETFOCUS Then SetFocusAPI m_hWndEdit
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
                SetFocusAPI m_hWndParent
                WindowProc = MA_NOACTIVATE
                Exit Function
            End If
    End Select
    WindowProc = CallWindowProc(m_SubClassEdit.wndprocNext, hWnd, uMsg, wParam, lParam)
End Function
Private Sub IHookAccelerator_TranslateAccelerator(lpmsg As OleTypes.MSG, hrReturnCode As Long)
    'Return code 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 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
            GetClientRect .hWnd, rct
            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
        SetWindowPos m_hWndEdit, 0, 0, 0, ScaleWidth, ScaleHeight, SWP_NOZORDER Or SWP_NOACTIVATE
    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
    SetDesignMode
    If Not m_fDesign Then
        If m_hWndEdit Then Exit Sub
        InitializeIPAOHook m_IPAOHook, Me
        With UserControl
            m_hWndEdit = CreateWindowEx(WS_EX_CLIENTEDGE, "EDIT", vbNullString, _
                       WS_CHILD Or WS_CLIPSIBLINGS Or WS_TABSTOP, 0, 0, .ScaleWidth, .ScaleHeight, .hWnd, 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 = .hWnd
                SubClass m_SubClassParent, m_hWndParent, ObjPtr(Me), AddressOf RedirectEditProcParent
                ShowWindow m_hWndEdit, SW_SHOW
            End If
        End With
    End If
End Sub