cpager.ctl

SmartMail外贸企业邮件管理,很不错的

    If (m_hWnd <> 0) Then
        ButtonState = SendMessageLong(m_hWnd, PGM_GETBUTTONSTATE, 0, eButton)
    End If
End Property

Public Property Get ButtonSize() As Long
    If (m_hWnd <> 0) Then
        ButtonSize = SendMessageLong(m_hWnd, PGM_GETBUTTONSIZE, 0, 0)
    End If
End Property
Public Property Let ButtonSize(ByVal lSize As Long)
    m_lButtonSize = lSize
    If (m_hWnd <> 0) Then
        SendMessageLong m_hWnd, PGM_SETBUTTONSIZE, 0, lSize
        PropertyChanged "ButtonSize"
    End If
End Property
Public Property Get BackColor() As OLE_COLOR
    BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal oColor As OLE_COLOR)
    If (oColor <> UserControl.BackColor) Then
        UserControl.BackColor = oColor
        If (m_hWnd <> 0) Then
            SendMessageLong m_hWnd, PGM_SETBKCOLOR, 0, TranslateColor(oColor)
        End If
        PropertyChanged "BackColor"
    End If
End Property
Public Property Get Position() As Long
    If (m_hWnd <> 0) Then
        Position = SendMessageLong(m_hWnd, PGM_GETPOS, 0, 0)
    Else
        Position = m_lPosition
    End If
End Property
Public Property Let Position(ByVal lPos As Long)
    If (lPos <> m_lPosition) Then
        m_lPosition = lPos
        If (m_hWnd <> 0) Then
            SendMessageLong m_hWnd, PGM_SETPOS, 0, lPos
        End If
        PropertyChanged "Position"
    End If
End Property

Public Property Get BorderStyle() As ECPGBorderStyle
Dim lStyle As Long
    ' Determine if Client Edge extended style is set:
    lStyle = GetWindowLong(UserControl.hWnd, GWL_EXSTYLE)
    If ((lStyle And WS_EX_CLIENTEDGE) = WS_EX_CLIENTEDGE) Then
        BorderStyle = PGFixedSingle
    End If
End Property
Public Property Let BorderStyle(ByVal eStyle As ECPGBorderStyle)
Dim lStyle As Long
Dim lNStyle As Long
    ' Get window extended style:
    lStyle = GetWindowLong(UserControl.hWnd, GWL_EXSTYLE)
    ' Ensure the ClientEdge bit is set correctly:
    If (eStyle = PGFixedSingle) Then
        lNStyle = lStyle Or WS_EX_CLIENTEDGE
    Else
        lNStyle = lStyle And Not WS_EX_CLIENTEDGE
    End If
    ' If this results in a change:
    If (lNStyle <> lStyle) Then
        ' Change the window style:
        SetWindowLong UserControl.hWnd, GWL_EXSTYLE, lNStyle
        ' Ensure the style 'takes':
        SetWindowPos UserControl.hWnd, 0, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
        ' Refresh the UserControl:
        UserControl.Refresh
        
        PropertyChanged "BorderStyle"
    End If
End Property


Public Property Get InternalBorderWidth() As Long
    If (m_hWnd <> 0) Then
        InternalBorderWidth = SendMessageLong(m_hWnd, PGM_GETBORDER, 0, 0)
    End If
End Property
Public Property Let InternalBorderWidth(ByVal lWidth As Long)
    If (lWidth <> InternalBorderWidth) Then
        If (m_hWnd <> 0) Then
            SendMessageLong m_hWnd, PGM_SETBORDER, 0, lWidth
        End If
        PropertyChanged "InternalBorderWidth"
    End If
End Property

Public Property Get DragDrop() As Boolean
    DragDrop = m_bDragDrop
End Property
Public Property Let DragDrop(ByVal bDragDrop As Boolean)
    If (m_bDragDrop <> bDragDrop) Then
        m_bDragDrop = bDragDrop
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "DragDrop"
    End If
End Property
Public Property Get AutoHScroll() As Boolean
    AutoHScroll = m_bAutoHScroll
End Property
Public Property Let AutoHScroll(ByVal bAutoHScroll As Boolean)
    If (m_bAutoHScroll <> bAutoHScroll) Then
        m_bAutoHScroll = bAutoHScroll
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "AutoHScroll"
    End If
End Property
Public Property Get Orientation() As ECPGOrientation
    Orientation = m_eOrientation
End Property
Public Property Let Orientation(ByVal eOrientation As ECPGOrientation)
    If (m_eOrientation <> eOrientation) Then
        m_eOrientation = eOrientation
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "Orientation"
    End If
End Property

Public Sub AddChildWindow(ByVal hWndA As Long)
Dim hWndTb As Long
Dim lButtons As Long
Dim rc As RECT
    ' Check for a VB toolbar:
    If (ClassName(hWndA) = "ToolbarWndClass") Then
        ' Make the toolbar flat:
        hWndTb = GetWindow(hWndA, GW_CHILD)
        pSetStyle hWndTb, TBSTYLE_FLAT, True
        ' Set the toolbar size:
        lButtons = SendMessageLong(hWndTb, TB_BUTTONCOUNT, 0, 0)
        If (lButtons > 0) Then
            SendMessage hWndTb, TB_GETITEMRECT, lButtons - 1, rc
            MoveWindow hWndTb, 0, 0, rc.Right, rc.Bottom, 1
        End If
    End If

    SetParent hWndA, m_hWnd
    SendMessageLong m_hWnd, PGM_SETCHILD, 0, hWndA
End Sub
Private Sub pSetStyle(ByVal lHwnd As Long, ByVal lStyleBit As Long, ByVal bState As Boolean)
Dim lStyle As Long
    lStyle = GetWindowLong(lHwnd, GWL_STYLE)
    If (bState) Then
        lStyle = lStyle Or lStyleBit
    Else
        lStyle = lStyle And Not lStyleBit
    End If
    SetWindowLong lHwnd, GWL_STYLE, lStyle
End Sub

Public Sub RecalcSize()
    SendMessageLong m_hWnd, PGM_RECALCSIZE, 0, 0
End Sub

Private Sub pInitialise()
Dim tICCEX As tagInitCommonControlsEx
Dim dwStyle As Long
    
    ' Ensure we don't already have UpDown control:
    pTerminate
    
    ' ENsure common controls are initialised for pagers:
    tICCEX.lngICC = ICC_PAGESCROLLER_CLASS
    tICCEX.lngSize = Len(tICCEX)
    InitCommonControlsEx tICCEX
    
    ' Create Pager Control:
    dwStyle = WS_VISIBLE Or WS_CHILD     'Or WS_BORDER
    dwStyle = dwStyle Or m_eOrientation
    If (m_bAutoHScroll) Then
        dwStyle = dwStyle Or PGS_AUTOSCROLL
    End If
    If (m_bDragDrop) Then
        dwStyle = dwStyle Or PGS_DRAGNDROP
    End If
    
    m_hWnd = CreateWindowEX(0, WC_PAGESCROLLER, "cVBPager", dwStyle, _
        0, 0, UserControl.ScaleWidth \ Screen.TwipsPerPixelX, UserControl.ScaleHeight \ Screen.TwipsPerPixelY, _
        UserControl.hWnd, 0, App.hInstance, UserControl.hWnd)
    Debug.Assert (m_hWnd <> 0)
    If (m_hWnd <> 0) Then
        If (UserControl.Ambient.UserMode) Then
            ' Attach Messages
            pAttachMessages
        End If
    End If
    
End Sub

Private Sub pTerminate()
    
    If (m_hWnd <> 0) Then
        ' Stop subclassing:
        pDetachMessages
        ' Destroy the window:
        ShowWindow m_hWnd, SW_HIDE
        SetParent m_hWnd, 0
        Debug.Print DestroyWindow(m_hWnd)
        m_hWnd = 0
    End If
    
End Sub
Private Sub pAttachMessages()
    AttachMessage Me, UserControl.hWnd, WM_NOTIFY
    m_emr = emrPreprocess
    m_bSubClassing = True
End Sub
Private Sub pDetachMessages()
    If (m_bSubClassing) Then
        DetachMessage Me, UserControl.hWnd, WM_NOTIFY
        m_bSubClassing = False
    End If
End Sub
' Convert Automation color to Windows color
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
       TranslateColor = CLR_INVALID
    End If
End Function
Private Function ClassName(ByVal lHwnd As Long) As String
Dim lLen As Long
Dim sBuf As String
    lLen = 260
    sBuf = String$(lLen, 0)
    lLen = GetClassName(lHwnd, sBuf, lLen)
    If (lLen <> 0) Then
        ClassName = Left$(sBuf, lLen)
    End If
End Function

Private Property Let ISubclass_MsgResponse(ByVal RHS As SubClass.EMsgResponse)
    m_emr = RHS
End Property

Private Property Get ISubclass_MsgResponse() As SubClass.EMsgResponse
    ISubclass_MsgResponse = m_emr
End Property

Private Function ISubclass_WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tNMH As NMHDR
Dim tPGCS As NMPGCALCSIZE
Dim tPGS As NMPGSCROLLVB
Dim iDir As Long, iScroll As Long

    ' Process Messages:
    If (iMsg = WM_NOTIFY) Then
        CopyMemory tNMH, ByVal lParam, Len(tNMH)
        If (tNMH.hwndFrom = m_hWnd) Then
            Select Case tNMH.code
            Case PGN_CALCSIZE
                CopyMemory tPGCS, ByVal lParam, Len(tPGCS)
                Select Case tPGCS.dwFlag
                Case PGF_CALCWIDTH
                    RaiseEvent RequestSize(tPGCS.iWidth, 0)
                Case PGF_CALCHEIGHT
                    RaiseEvent RequestSize(0, tPGCS.iHeight)
                End Select
                CopyMemory ByVal lParam, tPGCS, Len(tPGCS)
            Case PGN_SCROLL
                ' Silly stuff with bytes - see declaration of NMPGSCROLL:
                CopyMemory tPGS, ByVal lParam, Len(tPGS)
                CopyMemory iDir, tPGS.bTheRest(18), 4
                CopyMemory iScroll, tPGS.bTheRest(30), 4
                'Debug.Print iDir, iScroll
                RaiseEvent Scroll(iDir, iScroll)
                CopyMemory tPGS.bTheRest(30), iScroll, 4
                CopyMemory ByVal lParam, tPGS, Len(tPGS)
            End Select
        End If
    End If
End Function

Private Sub UserControl_Initialize()
    Debug.Print "cPager:Initialize"
    m_eOrientation = PGHorizontal
    m_bDragDrop = False
    m_bAutoHScroll = False
End Sub

Private Sub UserControl_InitProperties()
    BorderStyle = PGFixedSingle
    pInitialise
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Orientation = PropBag.ReadProperty("Orientation", PGHorizontal)
    DragDrop = PropBag.ReadProperty("DragDrop", False)
    AutoHScroll = PropBag.ReadProperty("AutoHScroll", False)
    BorderStyle = PropBag.ReadProperty("BorderStyle", PGFixedSingle)
    pInitialise
    InternalBorderWidth = PropBag.ReadProperty("InternalBorderWidth", 0)
    Position = PropBag.ReadProperty("Position", 0)
    BackColor = PropBag.ReadProperty("BackColor", vbButtonFace)
End Sub

Private Sub UserControl_Resize()
    ' Resize:
    If (m_hWnd <> 0) Then
        MoveWindow m_hWnd, 0, 0, UserControl.ScaleWidth \ Screen.TwipsPerPixelX, UserControl.ScaleHeight \ Screen.TwipsPerPixelY, 1
    End If
End Sub

Private Sub UserControl_Terminate()
    pTerminate
    Debug.Print "cUpDown:Terminate"
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Orientation", Orientation, PGHorizontal
    PropBag.WriteProperty "DragDrop", DragDrop, False
    PropBag.WriteProperty "AutoHScroll", AutoHScroll, False
    PropBag.WriteProperty "BorderStyle", BorderStyle, PGFixedSingle
    PropBag.WriteProperty "InternalBorderWidth", InternalBorderWidth, 0
    PropBag.WriteProperty "Position", Position, 0
    PropBag.WriteProperty "BackColor", BackColor, vbButtonFace
    pTerminate
End Sub