?? xpframe.ctl
字號(hào):
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")
?? 快捷鍵說(shuō)明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號(hào)
Ctrl + =
減小字號(hào)
Ctrl + -