xpframe.ctl

XP风格浮动工具条 和苹果风格按钮控件

        TransImage = CopyImage(sPic.Handle, 0, PicW, PicH, ByVal 0&)
        DrawTransparentBitmap UserControl.hdc, dRect, TransImage, BMtR, PicW, PicH
    End If

End Sub


Private Sub DrawTransparentBitmap(lHDCdest As Long, destRect As RECT, _
                                  lBMPsource As Long, bmpRect As RECT, _
                                  ByVal bmpSizeX As Long, _
                                  ByVal bmpSizeY As Long)
    Const DSna = &H220326
    
    Dim lMask2Use As Long
    Dim bmpMask As Long, bmpMemory As Long, bmpColor As Long
    Dim bmpObjectOld As Long, bmpMemoryOld As Long, bmpColorOld As Long
    Dim lBackDC As Long, hWndDc As Long, lHDCsrc As Long, lMaskDC As Long, lHDCcolor As Long
    Dim bmpPointSizeX As Long, bmpPointSizeY As Long, SrcX As Long, SrcY As Long
    Dim lbmpSourceOld As Long

    Dim hPalOld As Long, hPalMem As Long

    hWndDc = GetDC(0&): If hWndDc = 0 Then Exit Sub
    lHDCsrc = CreateCompatibleDC(hWndDc)
    
    
    'SelectObject lHDCsrc, lBMPsource
    lbmpSourceOld = SelectObject(lHDCsrc, lBMPsource)
    
    SrcX = bmpSizeX
    SrcY = bmpSizeY

    bmpRect.Right = SrcX
    bmpRect.bottom = SrcY

    bmpPointSizeX = bmpSizeX
    bmpPointSizeY = bmpSizeY

    lMask2Use = ConvertColor(GetPixel(lHDCsrc, 0, 0))

    '
    lMaskDC = CreateCompatibleDC(hWndDc)
    lBackDC = CreateCompatibleDC(hWndDc)
    lHDCcolor = CreateCompatibleDC(hWndDc)

    bmpColor = CreateCompatibleBitmap(hWndDc, SrcX, SrcY)
    bmpMemory = CreateCompatibleBitmap(hWndDc, bmpPointSizeX, bmpPointSizeY)
    bmpMask = CreateBitmap(SrcX, SrcY, 1&, 1&, ByVal 0&)

    bmpColorOld = SelectObject(lHDCcolor, bmpColor)
    bmpMemoryOld = SelectObject(lBackDC, bmpMemory)
    bmpObjectOld = SelectObject(lMaskDC, bmpMask)

    ReleaseDC 0&, hWndDc

    '
    SetMapMode lBackDC, GetMapMode(lHDCdest)
    hPalMem = SelectPalette(lBackDC, 0, True)
    RealizePalette lBackDC

    BitBlt lBackDC, 0&, 0&, bmpPointSizeX, bmpPointSizeY, lHDCdest, destRect.Left, destRect.Top, vbSrcCopy

    hPalOld = SelectPalette(lHDCcolor, 0, True)
    RealizePalette lHDCcolor
    SetBkColor lHDCcolor, GetBkColor(lHDCsrc)
    SetTextColor lHDCcolor, GetTextColor(lHDCsrc)

    BitBlt lHDCcolor, 0&, 0&, SrcX, SrcY, lHDCsrc, bmpRect.Left, bmpRect.Top, vbSrcCopy

    SetBkColor lHDCcolor, lMask2Use
    SetTextColor lHDCcolor, vbWhite

    BitBlt lMaskDC, 0&, 0&, SrcX, SrcY, lHDCcolor, 0&, 0&, vbSrcCopy
    
    SetTextColor lHDCcolor, vbBlack
    SetBkColor lHDCcolor, vbWhite
    BitBlt lHDCcolor, 0, 0, SrcX, SrcY, lMaskDC, 0, 0, DSna

    StretchBlt lBackDC, 0, 0, bmpSizeX, bmpSizeY, lMaskDC, 0&, 0&, SrcX, SrcY, vbSrcAnd

    StretchBlt lBackDC, 0&, 0&, bmpSizeX, bmpSizeY, lHDCcolor, 0, 0, SrcX, SrcY, vbSrcPaint

    BitBlt lHDCdest, destRect.Left, destRect.Top, bmpPointSizeX, bmpPointSizeY, lBackDC, 0&, 0&, vbSrcCopy

    '--efface les bitmaps en m閙oires et les DC
    DeleteObject SelectObject(lHDCcolor, bmpColorOld)
    DeleteObject SelectObject(lMaskDC, bmpObjectOld)
    DeleteObject SelectObject(lBackDC, bmpMemoryOld)
    DeleteDC lBackDC
    DeleteDC lMaskDC
    DeleteDC lHDCcolor
    DeleteObject SelectObject(lHDCsrc, lbmpSourceOld)
    DeleteDC lHDCsrc
End Sub


Private Function ConvertColor(tColor As Long) As Long

' Converts VB color constants to real color values

    If tColor < 0 Then
        ConvertColor = GetSysColor(tColor And &HFF&)
    Else
        ConvertColor = tColor
    End If
End Function



'HeaderPictureSize
Public Property Get HeaderPictureSize() As Integer
Attribute HeaderPictureSize.VB_Description = "Gets/Sets header bar picture size"
Attribute HeaderPictureSize.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderPictureSize = m_HeaderPictureSize
End Property

Public Property Let HeaderPictureSize(ByVal NewIconSize As Integer)
    m_HeaderPictureSize = NewIconSize
    PropertyChanged "HeaderPictureSize"
    Call UserControl.Refresh
    Call DrawControl
End Property

'
'
'#Footer
'FooterText
Public Property Get FooterText() As String
Attribute FooterText.VB_Description = "Gets/Sets footer bar text"
Attribute FooterText.VB_ProcData.VB_Invoke_Property = ";Footer"
    FooterText = m_sFooterText
End Property

Public Property Let FooterText(ByVal sFooterText As String)
    m_sFooterText = sFooterText
    Call DrawControl
    Call UserControl.Refresh
    Call UserControl.PropertyChanged("FooterText")
End Property

'FooterTextFont
Public Property Get FooterTextFont() As Font
Attribute FooterTextFont.VB_Description = "Gets/Sets footer bar text font"
Attribute FooterTextFont.VB_ProcData.VB_Invoke_Property = ";Footer"
    Set FooterTextFont = m_fFooterTextFont
End Property

Public Property Set FooterTextFont(objFooterTextFont As Font)
    Set m_fFooterTextFont = objFooterTextFont
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("FooterTextFont")
End Property

'FooterTextAlign
Public Property Get FooterTextAlign() As TextAlign
Attribute FooterTextAlign.VB_Description = "Gets/Sets footer bar text alignment"
Attribute FooterTextAlign.VB_ProcData.VB_Invoke_Property = ";Footer"
    FooterTextAlign = m_eFooterTextAlign
End Property
Public Property Let FooterTextAlign(ByVal eFooterTextAlign As TextAlign)
    
    Select Case eFooterTextAlign
    Case xAlignLefttop
        ValFooterTextAlign = DT_LEFT Or DT_TOP Or DT_SINGLELINE
    Case xAlignLeftMiddle
        ValFooterTextAlign = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
    Case xAlignLeftBottom
        ValFooterTextAlign = DT_LEFT Or DT_BOTTOM Or DT_SINGLELINE
    Case xAlignRightTop
        ValFooterTextAlign = DT_RIGHT Or DT_TOP Or DT_SINGLELINE
    Case xAlignRightMiddle
        ValFooterTextAlign = DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE
    Case xAlignRightBottom
        ValFooterTextAlign = DT_RIGHT Or DT_BOTTOM Or DT_SINGLELINE
    Case xAlignCenterTop
        ValFooterTextAlign = DT_CENTER Or DT_TOP Or DT_SINGLELINE
    Case xAlignCenterMiddle
        ValFooterTextAlign = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
    Case xAlignCenterBottom
        ValFooterTextAlign = DT_CENTER Or DT_BOTTOM Or DT_SINGLELINE
    End Select
    m_eFooterTextAlign = eFooterTextAlign
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("FooterTextAlign")
End Property

'FooterTextColor
Public Property Get FooterTextColor() As OLE_COLOR
Attribute FooterTextColor.VB_Description = "Gets/Sets footer bar text color"
Attribute FooterTextColor.VB_ProcData.VB_Invoke_Property = ";Footer"
    FooterTextColor = m_oFooterTextColor
End Property
Public Property Let FooterTextColor(ByVal eFooterTextColor As OLE_COLOR)
    m_oFooterTextColor = eFooterTextColor
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("FooterTextColor")
End Property

'FooterSize
Public Property Get FooterSize() As FooterStyleSize
Attribute FooterSize.VB_Description = "Gets/Sets footer bar size"
Attribute FooterSize.VB_ProcData.VB_Invoke_Property = ";Footer"
    FooterSize = m_iFooterSize
End Property
Public Property Let FooterSize(ByVal eFooterSize As FooterStyleSize)
    m_iFooterSize = eFooterSize
    Call DrawControl
    Call UserControl.Refresh
    Call UserControl.PropertyChanged("FooterSize")
End Property

'FooterVisible
Public Property Get FooterVisible() As Boolean
Attribute FooterVisible.VB_Description = "Gets/Sets footer bar visibility"
Attribute FooterVisible.VB_ProcData.VB_Invoke_Property = ";Footer"
    FooterVisible = m_bFooterVisible
End Property
Public Property Let FooterVisible(ByVal bFooterVisible As Boolean)
    m_bFooterVisible = bFooterVisible
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("FooterVisible")
End Property

'HeaderPicVisible
Public Property Get HeaderPictureVisible() As Boolean
Attribute HeaderPictureVisible.VB_Description = "Gets/Sets header bar picture visibility"
Attribute HeaderPictureVisible.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderPictureVisible = m_HeaderPictureVisible
End Property
Public Property Let HeaderPictureVisible(ByVal visible As Boolean)
    m_HeaderPictureVisible = visible
    Call UserControl.PropertyChanged("HeaderPictureVisible")
    Call UserControl.Refresh
    Call DrawControl
End Property

'Classic XP Style
Public Property Get ClassicXPStyle() As Boolean
Attribute ClassicXPStyle.VB_Description = "Gets/Sets frame style"
Attribute ClassicXPStyle.VB_ProcData.VB_Invoke_Property = ";Basic"
    ClassicXPStyle = m_XPStyle
End Property
Public Property Let ClassicXPStyle(ByVal Style As Boolean)
    m_XPStyle = Style
    Call UserControl.PropertyChanged("ClassicXPStyle")
    Call UserControl.Refresh
    Call DrawControl
End Property
'    m_zOrder = PropBag.ReadProperty("ZOrderOnFocus", True)
'ContainerPicVisible
Public Property Get ZOrderOnFocus() As Boolean
Attribute ZOrderOnFocus.VB_Description = "Gets/Sets if control sets zorder on focus"
Attribute ZOrderOnFocus.VB_ProcData.VB_Invoke_Property = ";Basic"
    ZOrderOnFocus = m_zOrder
End Property
Public Property Let ZOrderOnFocus(ByVal zorder As Boolean)
    m_zOrder = zorder
    UserControl.Extender.zorder 0
    Call UserControl.PropertyChanged("ZOrderOnFocus")
    Call UserControl.Refresh
    Call DrawControl
End Property

'ContainerPicVisible
Public Property Get ContainerPictureVisible() As Boolean
Attribute ContainerPictureVisible.VB_Description = "Gets/Sets container picture visibility"
Attribute ContainerPictureVisible.VB_ProcData.VB_Invoke_Property = ";Container"
    ContainerPictureVisible = m_ContainerPictureVisible
End Property
Public Property Let ContainerPictureVisible(ByVal visible As Boolean)
    m_ContainerPictureVisible = visible
    Call UserControl.PropertyChanged("ContainerPictureVisible")
    Call UserControl.Refresh
    Call DrawControl
End Property

'Moveable
Public Property Get ContainerMoveable() As Boolean
Attribute ContainerMoveable.VB_Description = "Gets/Sets if control is moveable"
Attribute ContainerMoveable.VB_ProcData.VB_Invoke_Property = ";Basic"
    ContainerMoveable = m_Moveable
End Property
Public Property Let ContainerMoveable(ByVal visible As Boolean)
    m_Moveable = visible
    Call UserControl.PropertyChanged("ContainerMoveable")
    Call UserControl.Refresh
    Call DrawControl
End Property
'Resizable
Public Property Get ContainerResizable() As Boolean
Attribute ContainerResizable.VB_Description = "Gets/Sets if control is resizeable"
Attribute ContainerResizable.VB_ProcData.VB_Invoke_Property = ";Basic"
    ContainerResizable = m_Resize
End Property
Public Property Let ContainerResizable(ByVal visible As Boolean)
    m_Resize = visible
    If m_XPStyle = True Then m_Resize = False
    Call UserControl.PropertyChanged("ContainerResizable")
    Call UserControl.Refresh
    Call DrawControl
End Property
'FooterBackColor
Public Property Get FooterBackColor() As OLE_COLOR
Attribute FooterBackColor.VB_Description = "Gets/Sets footer back color"
Attribute FooterBackColor.VB_ProcData.VB_Invoke_Property = ";Footer"
    FooterBackColor = m_oFooterBackColor
End Property
Public Property Let FooterBackColor(ByVal objFooterBackColor As OLE_COLOR)
    m_oFooterBackColor = objFooterBackColor
    Call DrawControl
    Call UserControl.Refresh
    Call UserControl.PropertyChanged("FooterBackColor")
End Property

'FooterFadeColor
Public Property Get FooterFadeColor() As OLE_COLOR
Attribute FooterFadeColor.VB_Description = "Gets/Sets footer fade color"
Attribute FooterFadeColor.VB_ProcData.VB_Invoke_Property = ";Footer"
    FooterFadeColor = m_oFooterFadeColor
End Property
Public Property Let FooterFadeColor(ByVal objFooterFadeColor As OLE_COLOR)
    m_oFooterFadeColor = objFooterFadeColor
    Call DrawControl
    Call UserControl.Refresh
    Call UserControl.PropertyChanged("FooterFadeColor")