xpframe.ctl

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

'======================================================================
'CREATES THE TEMP DC
Private Sub pCreate(ByVal Width As Long, ByVal Height As Long)
Dim lhDCC As Long
   pDestroy
   
   lhDCC = CreateDC("DISPLAY", "", "", ByVal 0&)
   If Not (lhDCC = 0) Then
      m_ThDC = CreateCompatibleDC(lhDCC)
      If Not (m_ThDC = 0) Then
         m_hBmp = CreateCompatibleBitmap(lhDCC, Width, Height)
         If Not (m_hBmp = 0) Then
            m_hBmpOld = SelectObject(m_ThDC, m_hBmp)
            If Not (m_hBmpOld = 0) Then
               m_lWidth = Width
               m_lHeight = Height
               DeleteDC lhDCC
               Exit Sub
            End If
         End If
      End If
      DeleteDC lhDCC
      pDestroy
   End If
End Sub
'======================================================================

'======================================================================
'CHECKS-CREATES CORRECT DIMENSIONS OF THE TEMP DC
Private Function ThDC(Width As Long, Height As Long) As Long
   If m_ThDC = 0 Then
      If (Width > 0) And (Height > 0) Then
         pCreate Width, Height
      End If
   Else
      If Width > m_lWidth Or Height > m_lHeight Then
         pCreate Width, Height
      End If
   End If
   ThDC = m_ThDC
End Function
'======================================================================

'======================================================================
'DESTROYS THE TEMP DC
Private Sub pDestroy()
   If Not m_hBmpOld = 0 Then
      SelectObject m_ThDC, m_hBmpOld
      m_hBmpOld = 0
   End If
   If Not m_hBmp = 0 Then
      DeleteObject m_hBmp
      m_hBmp = 0
   End If
   If Not m_ThDC = 0 Then
      DeleteDC m_ThDC
      m_ThDC = 0
   End If
   m_lWidth = 0
   m_lHeight = 0
End Sub
'====================================================================

Public Property Get hdc() As Long
   hdc = m_hDC
End Property
Public Property Let hdc(ByVal cHdc As Long)

   m_hDC = ThDC(UserControl.ScaleWidth, UserControl.ScaleHeight)
   
   If m_hDC = 0 Then
      m_hDC = UserControl.hdc
   Else
      m_MemDC = True
   End If

End Property
Public Property Get hWnd() As Long
   hWnd = m_hwnd
End Property
Public Property Let hWnd(ByVal chWnd As Long)
   m_hwnd = chWnd
End Property
Public Sub Expand()
    fExpandBar 1
End Sub
Public Sub Collapse()
    fExpandBar -1
End Sub
Public Sub OnTop()
    UserControl.Extender.zorder 0
End Sub
Public Sub closeMe()
    UserControl.Extender.visible = False
End Sub
Public Sub showMe()
    UserControl.Extender.visible = True
End Sub
Public Sub Refresh()
    UserControl.Refresh
    DrawControl
End Sub
Private Sub UserControl_GotFocus()
    If m_zOrder = True Then Me.OnTop
End Sub

Private Sub UserControl_Resize()
    hdc = UserControl.hdc
End Sub

Private Sub UserControl_Terminate()
If m_hRegion Then DeleteObject m_hRegion
If m_hRegionB Then DeleteObject m_hRegionB
    pDestroy
End Sub
Private Sub UserControl_Initialize()
    hWnd = UserControl.hWnd
    hdc = UserControl.hdc
End Sub
'end

'=Debut du code =======================================================================================================
'
'#Header
'HeaderText
Public Property Get HeaderText() As String
Attribute HeaderText.VB_Description = "Gets/Sets the header text"
Attribute HeaderText.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderText = m_sHeaderText
End Property

Public Property Let HeaderText(ByVal sHeaderText As String)
    m_sHeaderText = sHeaderText
    Label1.Caption = sHeaderText
    Label1.Refresh
    Call UserControl.PropertyChanged("HeaderText")
    Call UserControl.Refresh
    Call DrawControl
End Property

'HeaderTextFont
Public Property Get HeaderTextFont() As Font
Attribute HeaderTextFont.VB_Description = "Gets/Sets the header bar text font"
Attribute HeaderTextFont.VB_ProcData.VB_Invoke_Property = ";Header"
    Set HeaderTextFont = m_fHeaderTextFont
End Property

Public Property Set HeaderTextFont(objHeaderTextFont As Font)
    Set m_fHeaderTextFont = objHeaderTextFont
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderTextFont")
End Property

'HeaderTextAlign
Public Property Get HeaderTextAlign() As TextAlign
Attribute HeaderTextAlign.VB_Description = "Gets/Sets the header bar text alignment"
Attribute HeaderTextAlign.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderTextAlign = m_eHeaderTextAlign
End Property
Public Property Let HeaderTextAlign(ByVal eHeaderTextAlign As TextAlign)

    Select Case eHeaderTextAlign
    Case xAlignLefttop
        ValHeaderTextAlign = DT_LEFT Or DT_TOP Or DT_SINGLELINE
    Case xAlignLeftMiddle
        ValHeaderTextAlign = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
    Case xAlignLeftBottom
        ValHeaderTextAlign = DT_LEFT Or DT_BOTTOM Or DT_SINGLELINE
    Case xAlignRightTop
        ValHeaderTextAlign = DT_RIGHT Or DT_TOP Or DT_SINGLELINE
    Case xAlignRightMiddle
        ValHeaderTextAlign = DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE
    Case xAlignRightBottom
        ValHeaderTextAlign = DT_RIGHT Or DT_BOTTOM Or DT_SINGLELINE
    Case xAlignCenterTop
        ValHeaderTextAlign = DT_CENTER Or DT_TOP Or DT_SINGLELINE
    Case xAlignCenterMiddle
        ValHeaderTextAlign = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
    Case xAlignCenterBottom
        ValHeaderTextAlign = DT_CENTER Or DT_BOTTOM Or DT_SINGLELINE
    End Select
    m_eHeaderTextAlign = eHeaderTextAlign
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderTextAlign")

End Property

'HeaderTextColor
Public Property Get HeaderTextColor() As OLE_COLOR
Attribute HeaderTextColor.VB_Description = "Gets/Sets header bar text color"
Attribute HeaderTextColor.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderTextColor = m_oHeaderTextColor
End Property
Public Property Let HeaderTextColor(ByVal eHeaderTextColor As OLE_COLOR)
    m_oHeaderTextColor = eHeaderTextColor
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderTextColor")
End Property

'HeaderSize
Public Property Get HeaderSize() As HeaderFooterStyleSize
Attribute HeaderSize.VB_Description = "Gets/Sets the size of the header bar"
Attribute HeaderSize.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderSize = m_iHeaderSize
End Property
Public Property Let HeaderSize(ByVal eHeaderSize As HeaderFooterStyleSize)
    m_iHeaderSize = eHeaderSize
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderSize")
End Property

'HeaderVisible
Public Property Get Closeable() As Boolean
Attribute Closeable.VB_Description = "Gives control a close button"
Attribute Closeable.VB_ProcData.VB_Invoke_Property = ";Basic"
    Closeable = m_cClose
End Property
Public Property Let Closeable(ByVal closer As Boolean)
    m_cClose = closer
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("closeable")
End Property

'HeaderVisible
Public Property Get HeaderVisible() As Boolean
Attribute HeaderVisible.VB_Description = "Gets/Sets header bar visibility"
Attribute HeaderVisible.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderVisible = m_bHeaderVisible
End Property
Public Property Let HeaderVisible(ByVal bHeaderVisible As Boolean)
    m_bHeaderVisible = bHeaderVisible
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderVisible")
End Property

'HeaderBackColor
Public Property Get HeaderBackColor() As OLE_COLOR
Attribute HeaderBackColor.VB_Description = "Gets/Sets header bar back color"
Attribute HeaderBackColor.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderBackColor = m_oHeaderBackColor
End Property
Public Property Let HeaderBackColor(ByVal objHeaderBackColor As OLE_COLOR)
    m_oHeaderBackColor = objHeaderBackColor
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderBackColor")
End Property

'HeaderFadeColor
Public Property Get HeaderFadeColor() As OLE_COLOR
Attribute HeaderFadeColor.VB_Description = "Gets/Sets header bar fade color"
Attribute HeaderFadeColor.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderFadeColor = m_oHeaderFadeColor
End Property
Public Property Let HeaderFadeColor(ByVal objHeaderFadeColor As OLE_COLOR)
    m_oHeaderFadeColor = objHeaderFadeColor
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderFadeColor")
End Property

'HeaderFillStyle
Public Property Get HeaderFillStyle() As FillStyle
Attribute HeaderFillStyle.VB_Description = "Gets/Sets header bar fill style"
Attribute HeaderFillStyle.VB_ProcData.VB_Invoke_Property = ";Header"
    HeaderFillStyle = m_eHeaderFillStyle
End Property
Public Property Let HeaderFillStyle(ByVal eHeaderFillStyle As FillStyle)
    m_eHeaderFillStyle = eHeaderFillStyle
    Call UserControl.Refresh
    Call DrawControl
    Call UserControl.PropertyChanged("HeaderFillStyle")
End Property

'HeaderPicture
Public Property Set HeaderPicture(NewIcon As StdPicture)
    Set m_HeaderPicture = NewIcon
    PropertyChanged "HeaderPicture"
    Call UserControl.Refresh
    Call DrawControl
End Property
Public Property Get HeaderPicture() As StdPicture
Attribute HeaderPicture.VB_Description = "Gets/Sets header bar picture"
Attribute HeaderPicture.VB_ProcData.VB_Invoke_Property = ";Header"
    Set HeaderPicture = m_HeaderPicture
End Property


Private Sub DrawPicture(ByRef tP As RECT, sPic As StdPicture, Optional newSize As Long)
    Dim BMInf As BITMAP
    Dim ICInf As ICONINFO
    Dim dRect As RECT
    Dim BMtR As RECT
    Dim TransImage As Long
    Dim PicW As Long
    Dim PicH As Long

PicW = newSize: PicH = newSize
    '-- on recupere les dimensions des images
    If Not sPic Is Nothing Then
        Call GetObjectAPI(sPic.Handle, Len(BMInf), BMInf)
        If BMInf.bmBits = 0 Then
            Call GetIconInfo(sPic.Handle, ICInf)
            If ICInf.hbmColor <> 0 Then    '--il s'agit d'une icone
                Call GetObjectAPI(ICInf.hbmColor, Len(BMInf), BMInf)
                DeleteObject ICInf.hbmColor
                If ICInf.hbmMask <> 0 Then
                    DeleteObject ICInf.hbmMask
                End If
            End If
        End If
    End If

    dRect = tP

    If (sPic.Type = vbPicTypeIcon) Then
        '--cas d'une icone
        '--on dessine avec la taille pass en paramre
        DrawIconEx UserControl.hdc, dRect.Left, dRect.Top, sPic.Handle, PicW, PicH, 0, 0, &H3
    Else
        '--cas d'un bitmap
        '--on dessine l'image de toute sa taille