vbAccelerator - Contents of code file: vbalProgressBar.ctl
VERSION 5.00
Begin VB.UserControl vbalProgressBar
ClientHeight = 450
ClientLeft = 0
ClientTop = 0
ClientWidth = 4800
ScaleHeight = 450
ScaleWidth = 4800
ToolboxBitmap = "vbalProgressBar.ctx":0000
Begin VB.PictureBox picBack
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 315
Left = 1140
ScaleHeight = 255
ScaleWidth = 375
TabIndex = 1
Top = 60
Visible = 0 'False
Width = 435
End
Begin VB.PictureBox picBar
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 315
Left = 1620
ScaleHeight = 255
ScaleWidth = 375
TabIndex = 0
Top = 60
Visible = 0 'False
Width = 435
End
End
Attribute VB_Name = "vbalProgressBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDc As Long, ByVal x As
Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As
Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As
Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDc As Long, ByVal
hRgn As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As
Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
As Long
Private Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As
RECT, ByVal hBrush As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
Long, ByVal y As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDc As Long, ByVal x As
Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDc As Long, ByVal x As
Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hDc As Long, qrc As RECT,
ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_SOFT = &H1000 ' For softer buttons
Private Const BF_FLAT = &H4000 ' For flat rather than 3D borders
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As
Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal
crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDc As Long, ByVal
crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal
nBkMode As Long) As Long
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Declare Function OpenThemeData Lib "uxtheme.dll" _
(ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" _
(ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal lHDC As Long, _
ByVal iPartId As Long, ByVal iStateId As Long, _
pRect As RECT, pClipRect As RECT) As Long
Private Declare Function GetThemeBackgroundContentRect Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal hDc As Long, _
ByVal iPartId As Long, ByVal iStateId As Long, _
pBoundingRect As RECT, pContentRect As RECT) As Long
Private Declare Function DrawThemeText Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal hDc As Long, ByVal iPartId As Long, _
ByVal iStateId As Long, ByVal pszText As Long, _
ByVal iCharCount As Long, ByVal dwTextFlag As Long, _
ByVal dwTextFlags2 As Long, pRect As RECT) As Long
Private Declare Function DrawThemeIcon Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal hDc As Long, ByVal iPartId As Long, _
ByVal iStateId As Long, pRect As RECT, _
ByVal himl As Long, ByVal iImageIndex As Long) As Long
Private Declare Function DrawThemeEdge Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal hDc As Long, ByVal iPartId As Long, _
ByVal iStateId As Long, pDestRect As RECT, _
ByVal uEdge As Long, ByVal uFlags As Long, _
pContentRect As RECT) As Long
Private Enum THEMESIZE
TS_MIN = 0 '// minimum size
TS_TRUE = 1 '// size without stretching
TS_DRAW = 2 ' // size that theme mgr will use to draw part
End Enum
Private Declare Function GetThemeInt Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal iPartId As Long, _
ByVal iStateId As Long, ByVal iPropId As Long, _
piVal As Long) As Long
Private Const PROGRESSCHUNKSIZE = 2411
Private Const PROGRESSSPACESIZE = 2412
Private Const S_OK = 0
Public Enum EVPRGAppearanceConstants
epbaFlat
epba3DThin
epba3D
End Enum
Public Enum EVPRGBorderStyleConstants
epbsNone
epbsInset
epbsRaised
End Enum
Public Enum EVPRGPictureModeConstants
epbpStretch
epbpTile
End Enum
Public Enum EVPRGHorizontalTextAlignConstants
epbthLeft
epbthCenter
epbthRight
End Enum
Public Enum EVPRGVerticalTextAlignConstants
epbtvTop
epbtvVCenter
epbtvBottom
End Enum
Private m_cMemDC As pcMemDC
Private m_hWnd As Long
Private m_eAppearance As EVPRGAppearanceConstants
Private m_eBorderStyle As EVPRGBorderStyleConstants
Private m_oForeColor As OLE_COLOR
Private m_oBarColor As OLE_COLOR
Private m_oBarForeColor As OLE_COLOR
Private m_eBarPictureMode As EVPRGPictureModeConstants
Private m_eBackPictureMode As EVPRGPictureModeConstants
Private m_lMin As Long
Private m_lMax As Long
Private m_lValue As Long
Private m_eTextAlignX As EVPRGHorizontalTextAlignConstants
Private m_eTextAlignY As EVPRGVerticalTextAlignConstants
Private m_bShowText As Boolean
Private m_sText As String
Private m_bSegments As Boolean
Private m_bXpStyle As Boolean
Public Event Draw( _
ByVal hDc As Long, _
ByVal lLeft As Long, _
ByVal lTop As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal bDoDefault As Boolean _
)
Public Property Get Segments() As Boolean
Attribute Segments.VB_Description = "Gets/sets whether the bar is split into
segments. Not applicable when XPStyle is set."
Segments = m_bSegments
End Property
Public Property Let Segments(ByVal bState As Boolean)
m_bSegments = bState
pDraw
PropertyChanged "Segments"
End Property
Public Property Get XpStyle() As Boolean
Attribute XpStyle.VB_Description = "Gets/sets whether the bar is displayed
using XP Visual Styles. Only valid on XP systems or above."
XpStyle = m_bXpStyle
End Property
Public Property Let XpStyle(ByVal bState As Boolean)
m_bXpStyle = bState
pDraw
PropertyChanged "XpStyle"
End Property
Public Property Get Text() As String
Attribute Text.VB_Description = "Gets/sets the text to display when ShowText is
set."
Text = m_sText
End Property
Public Property Let Text(ByVal sText As String)
m_sText = sText
pDraw
PropertyChanged "Text"
End Property
Public Property Get TextAlignX() As EVPRGHorizontalTextAlignConstants
Attribute TextAlignX.VB_Description = "Gets/sets the horizontal alignment of
the text."
TextAlignX = m_eTextAlignX
End Property
Public Property Let TextAlignX(ByVal eAlign As
EVPRGHorizontalTextAlignConstants)
m_eTextAlignX = eAlign
pDraw
PropertyChanged "TextAlignX"
End Property
Public Property Get TextAlignY() As EVPRGVerticalTextAlignConstants
Attribute TextAlignY.VB_Description = "Gets/sets the vertical alignment of the
text."
TextAlignY = m_eTextAlignY
End Property
Public Property Let TextAlignY(ByVal eAlign As EVPRGVerticalTextAlignConstants)
m_eTextAlignY = eAlign
pDraw
PropertyChanged "TextAlignY"
End Property
Public Property Get ShowText() As Boolean
Attribute ShowText.VB_Description = "Gets/sets whether text is shown over the
bar."
ShowText = m_bShowText
End Property
Public Property Let ShowText(ByVal bState As Boolean)
m_bShowText = bState
pDraw
PropertyChanged "ShowText"
End Property
Public Property Get Percent() As Double
Attribute Percent.VB_Description = "Gets the current progress bar percentage
complete."
Dim fPercent As Double
fPercent = (m_lValue - m_lMin) / (m_lMax - m_lMin)
If fPercent > 1# Then fPercent = 1#
If fPercent < 0# Then fPercent = 0#
Percent = fPercent * 100#
End Property
Public Property Get Min() As Long
Attribute Min.VB_Description = "Gets/sets the minimum value of the bar."
Min = m_lMin
End Property
Public Property Let Min(ByVal lMin As Long)
m_lMin = lMin
pDraw
PropertyChanged "Min"
End Property
Public Property Get Max() As Long
Attribute Max.VB_Description = "Gets/sets the maximum value of the bar."
Max = m_lMax
End Property
Public Property Let Max(ByVal lMax As Long)
m_lMax = lMax
pDraw
PropertyChanged "Max"
End Property
Public Property Get Value() As Long
Attribute Value.VB_Description = "Gets/sets the value of the bar."
Value = m_lValue
End Property
Public Property Let Value(ByVal lValue As Long)
m_lValue = lValue
pDraw
PropertyChanged "Value"
End Property
Public Property Get BorderStyle() As EVPRGBorderStyleConstants
Attribute BorderStyle.VB_Description = "Gets/sets the border style of the
control. Not applicable when using XPStyle."
BorderStyle = m_eBorderStyle
End Property
Public Property Let BorderStyle(ByVal eStyle As EVPRGBorderStyleConstants)
m_eBorderStyle = eStyle
pDraw
PropertyChanged "BorderStyle"
End Property
Public Property Get Appearance() As EVPRGAppearanceConstants
Attribute Appearance.VB_Description = "Gets/sets the border appearance of the
control. Not applicable when using XPStyle."
Appearance = m_eAppearance
End Property
Public Property Let Appearance(ByVal eAppearance As EVPRGAppearanceConstants)
m_eAppearance = eAppearance
pDraw
PropertyChanged "Appearance"
End Property
Private Sub pDraw()
Dim lHDC As Long
Dim lhDCU As Long
Dim bMem As Boolean
Dim tR As RECT, tBR As RECT, tSR As RECT, tWR As RECT, tXPR As RECT
Dim lWidth As Long, lHeight As Long
Dim lColor As Long
Dim hBr As Long
Dim hRgn As Long
Dim fPercent As Double
Dim bDrawText As Boolean
Dim hFntOld As Long
Dim iFnt As IFont
Dim i As Long
Dim lSegmentWidth As Long, lSegmentSpacing As Long
Dim bDrawnXpStyle As Boolean
Dim hTheme As Long
Dim hR As Long
Dim bDrawn As Boolean
Dim bDoDefault As Boolean
GetClientRect m_hWnd, tR
lWidth = Abs(tR.Right - tR.Left)
lHeight = Abs(tR.Bottom - tR.Top)
lhDCU = UserControl.hDc
lHDC = m_cMemDC.hDc(lWidth, lHeight)
If lHDC = 0 Then
lHDC = lhDCU
Else
bMem = True
End If
bDoDefault = True
RaiseEvent Draw(lHDC, tR.Left, tR.Top, lWidth, lHeight, bDoDefault)
If bDoDefault Then
' Draw background:
If pbPic(picBack) Then
If m_eBackPictureMode = epbpTile Then
TileArea lHDC, 0, 0, lWidth, lHeight, picBack.hDc,
picBack.ScaleWidth \ Screen.TwipsPerPixelX, picBack.ScaleHeight \
Screen.TwipsPerPixelY, 0, 0
Else
StretchBlt lHDC, 0, 0, lWidth, lHeight, picBack.hDc, 0, 0,
picBack.ScaleWidth \ Screen.TwipsPerPixelX, picBack.ScaleHeight \
Screen.TwipsPerPixelY, vbSrcCopy
End If
Else
If (m_bXpStyle) Then
On Error Resume Next
hTheme = OpenThemeData(hwnd, StrPtr("Progress"))
On Error GoTo 0
If (hTheme <> 0) Then
hR = GetThemeInt(hTheme, 0, 0, PROGRESSCHUNKSIZE, lSegmentWidth)
If (hR = S_OK) Then
hR = GetThemeInt(hTheme, 0, 0, PROGRESSSPACESIZE,
lSegmentSpacing)
If (hR = S_OK) Then
lSegmentWidth = lSegmentWidth + lSegmentSpacing
If (Width > Height) Then
hR = DrawThemeBackground(hTheme, lHDC, 1, 0, tR, tR)
Else
hR = DrawThemeBackground(hTheme, lHDC, 2, 0, tR, tR)
End If
If (hR = S_OK) Then
bDrawn = True
End If
End If
End If
End If
End If
If Not (bDrawn) Then
lColor = UserControl.BackColor
If lColor And &H80000000 Then
hBr = GetSysColorBrush(lColor And &H1F&)
Else
hBr = CreateSolidBrush(lColor)
End If
FillRect lHDC, tR, hBr
DeleteObject hBr
End If
End If
If (m_bSegments) And Not (bDrawn) Then
lSegmentWidth = 8
lSegmentSpacing = 2
End If
LSet tWR = tR
If m_eBorderStyle > epbsNone Then
If bDrawn Then
InflateRect tR, -1, -1
Else
If m_eAppearance = epba3D Then
InflateRect tR, -2, -2
Else
InflateRect tR, -1, -1
End If
End If
End If
If (m_bShowText) And Len(m_sText) > 0 Then
bDrawText = True
End If
If (bDrawText) And Not (bDrawn) Then
Set iFnt = UserControl.Font
hFntOld = SelectObject(lHDC, iFnt.hFont)
SetBkMode lHDC, TRANSPARENT
SetTextColor lHDC, TranslateColor(m_oForeColor)
DrawText lHDC, " " & m_sText & " ", -1, tR, DT_SINGLELINE Or
m_eTextAlignX Or m_eTextAlignY * 4
SelectObject lHDC, hFntOld
End If
' Draw bar:
' Get the bar rectangle:
LSet tBR = tR
fPercent = (m_lValue - m_lMin) / (m_lMax - m_lMin)
If fPercent > 1# Then fPercent = 1#
If fPercent < 0# Then fPercent = 0#
If Width > Height Then
tBR.Right = tR.Left + (tR.Right - tR.Left) * fPercent
If (m_bSegments Or bDrawn) Then
' Quantise bar:
tBR.Right = tBR.Right - ((tBR.Right - tBR.Left) Mod (lSegmentWidth
+ lSegmentSpacing))
'Debug.Assert ((tBR.Right - tBR.Left) Mod (lSegmentWidth +
lSegmentSpacing) = 0)
If tBR.Right < tR.Left Then
tBR.Right = tR.Left
End If
End If
Else
fPercent = 1# - fPercent
tBR.Top = tR.Top + (tR.Bottom - tR.Top) * fPercent
If (m_bSegments Or bDrawn) Then
' Quantise bar:
tBR.Top = tBR.Top - ((tBR.Top - tBR.Bottom) Mod (lSegmentWidth +
lSegmentSpacing))
If tBR.Top > tR.Bottom Then
tBR.Top = tR.Bottom
End If
End If
End If
If Not bDrawn Then
hRgn = CreateRectRgnIndirect(tBR)
SelectClipRgn lHDC, hRgn
End If
If pbPic(picBar) Then
If m_eBarPictureMode = epbpTile Then
TileArea lHDC, 0, tBR.Top, tBR.Right - tBR.Left, tBR.Bottom -
tBR.Top, picBar.hDc, picBar.ScaleWidth \ Screen.TwipsPerPixelX,
picBar.ScaleHeight \ Screen.TwipsPerPixelY, 0, 0
Else
StretchBlt lHDC, 0, 0, lWidth, lHeight, picBar.hDc, 0, 0,
picBar.ScaleWidth \ Screen.TwipsPerPixelX, picBar.ScaleHeight \
Screen.TwipsPerPixelY, vbSrcCopy
End If
Else
If bDrawn Then
LSet tXPR = tBR
InflateRect tXPR, -2, -2
tXPR.Right = tXPR.Right + 1
tXPR.Bottom = tXPR.Bottom + 1
If (Width > Height) Then
hR = DrawThemeBackground(hTheme, lHDC, 3, 0, tXPR, tXPR)
Else
hR = DrawThemeBackground(hTheme, lHDC, 4, 0, tXPR, tXPR)
End If
Else
lColor = m_oBarColor
If lColor And &H80000000 Then
hBr = GetSysColorBrush(lColor And &H1F&)
Else
hBr = CreateSolidBrush(lColor)
End If
FillRect lHDC, tBR, hBr
DeleteObject hBr
End If
End If
If m_bSegments And Not bDrawn Then
lColor = UserControl.BackColor
If lColor And &H80000000 Then
hBr = GetSysColorBrush(lColor And &H1F&)
Else
hBr = CreateSolidBrush(lColor)
End If
LSet tSR = tR
If Width > Height Then
For i = tBR.Left + lSegmentWidth To tBR.Right Step lSegmentWidth +
lSegmentSpacing
tSR.Left = i
tSR.Right = i + lSegmentSpacing
FillRect lHDC, tSR, hBr
Next i
Else
For i = tBR.Bottom To tBR.Top + lSegmentWidth Step -(lSegmentWidth
+ lSegmentSpacing)
tSR.Top = i
tSR.Bottom = i + lSegmentSpacing
FillRect lHDC, tSR, hBr
Next i
End If
DeleteObject hBr
End If
If bDrawText Then
Set iFnt = UserControl.Font
hFntOld = SelectObject(lHDC, iFnt.hFont)
If (bDrawn) Then
Dim rcContent As RECT
hR = GetThemeBackgroundContentRect(hTheme, _
lHDC, 0, 0, tR, rcContent)
hR = DrawThemeText(hTheme, lHDC, 0, 0, _
StrPtr(m_sText), -1, _
DT_SINGLELINE Or m_eTextAlignX Or m_eTextAlignY * 4, _
0, rcContent)
Else
SetBkMode lHDC, TRANSPARENT
SetTextColor lHDC, TranslateColor(m_oBarForeColor)
DrawText lHDC, " " & m_sText & " ", -1, _
tR, DT_SINGLELINE Or m_eTextAlignX Or m_eTextAlignY * 4
End If
SelectObject lHDC, hFntOld
End If
If Not bDrawn Then
SelectClipRgn lHDC, 0
DeleteObject hRgn
' Draw border:
Select Case m_eBorderStyle
Case epbsRaised
Select Case m_eAppearance
Case epbaFlat
Border lHDC, epbaFlat, tWR, True
Case epba3DThin
Border lHDC, epba3DThin, tR, True
Case epba3D
Border lHDC, epba3D, tWR, True
End Select
Case epbsInset
Select Case m_eAppearance
Case epbaFlat
Border lHDC, epbaFlat, tWR, False
Case epba3DThin
Border lHDC, epba3DThin, tWR, False
Case epba3D
Border lHDC, epba3D, tWR, False
End Select
End Select
End If
End If
' Swap memdc<->Screen
If bMem Then
m_cMemDC.Draw lhDCU, 0, 0, lWidth, lHeight
End If
If (hTheme) Then
CloseThemeData hTheme
End If
End Sub
Private Function pbPic(ByVal picThis As PictureBox) As Boolean
If Not (picThis.Picture Is Nothing) Then
If Not picThis.Picture.handle = 0 Then
pbPic = True
End If
End If
End Function
Private Sub Border( _
ByVal lHDC As Long, _
ByVal lStyle As Long, _
ByRef tR As RECT, _
ByVal bRaised As Boolean _
)
Dim hPenDark As Long, hPenLight As Long, hPenBlack As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI
Select Case lStyle
Case 0
hPenBlack = CreatePen(0, 1, 0)
hPenOld = SelectObject(lHDC, hPenBlack)
MoveToEx lHDC, tR.Left, tR.Top, tJunk
LineTo lHDC, tR.Right - 1, tR.Top
LineTo lHDC, tR.Right - 1, tR.Bottom - 1
LineTo lHDC, tR.Left, tR.Bottom - 1
LineTo lHDC, tR.Left, tR.Top
SelectObject lHDC, hPenOld
DeleteObject hPenBlack
Case 1
hPenDark = CreatePen(0, 1, GetSysColor(vbButtonShadow And &H1F&))
hPenLight = CreatePen(0, 1, GetSysColor(vb3DHighlight And &H1F&))
If bRaised Then
MoveToEx lHDC, tR.Left, tR.Bottom - 2, tJunk
hPenOld = SelectObject(lHDC, hPenLight)
LineTo lHDC, tR.Left, tR.Top
LineTo lHDC, tR.Right - 1, tR.Top
SelectObject lHDC, hPenOld
MoveToEx lHDC, tR.Right - 1, tR.Top, tJunk
hPenOld = SelectObject(lHDC, hPenDark)
LineTo lHDC, tR.Right - 1, tR.Bottom - 1
LineTo lHDC, tR.Left - 1, tR.Bottom - 1
SelectObject lHDC, hPenOld
Else
MoveToEx lHDC, tR.Left, tR.Bottom - 1, tJunk
hPenOld = SelectObject(lHDC, hPenDark)
LineTo lHDC, tR.Left, tR.Top
LineTo lHDC, tR.Right, tR.Top
SelectObject lHDC, hPenOld
MoveToEx lHDC, tR.Right - 1, tR.Top + 1, tJunk
hPenOld = SelectObject(lHDC, hPenLight)
LineTo lHDC, tR.Right - 1, tR.Bottom - 1
LineTo lHDC, tR.Left, tR.Bottom - 1
SelectObject lHDC, hPenOld
End If
DeleteObject hPenDark
DeleteObject hPenLight
Case 2
If bRaised Then
DrawEdge lHDC, tR, EDGE_RAISED, BF_RECT Or BF_SOFT
Else
DrawEdge lHDC, tR, EDGE_SUNKEN, BF_RECT Or BF_SOFT
End If
End Select
End Sub
Private Sub TileArea( _
ByVal hDc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
ByVal lSrcDC As Long, _
ByVal lBitmapW As Long, _
ByVal lBitmapH As Long, _
ByVal lSrcOffsetX As Long, _
ByVal lSrcOffsetY As Long _
)
Dim lSrcX As Long
Dim lSrcY As Long
Dim lSrcStartX As Long
Dim lSrcStartY As Long
Dim lSrcStartWidth As Long
Dim lSrcStartHeight As Long
Dim lDstX As Long
Dim lDstY As Long
Dim lDstWidth As Long
Dim lDstHeight As Long
lSrcStartX = ((x + lSrcOffsetX) Mod lBitmapW)
lSrcStartY = ((y + lSrcOffsetY) Mod lBitmapH)
lSrcStartWidth = (lBitmapW - lSrcStartX)
lSrcStartHeight = (lBitmapH - lSrcStartY)
lSrcX = lSrcStartX
lSrcY = lSrcStartY
lDstY = y
lDstHeight = lSrcStartHeight
Do While lDstY < (y + Height)
If (lDstY + lDstHeight) > (y + Height) Then
lDstHeight = y + Height - lDstY
End If
lDstWidth = lSrcStartWidth
lDstX = x
lSrcX = lSrcStartX
Do While lDstX < (x + Width)
If (lDstX + lDstWidth) > (x + Width) Then
lDstWidth = x + Width - lDstX
If (lDstWidth = 0) Then
lDstWidth = 4
End If
End If
'If (lDstWidth > Width) Then lDstWidth = Width
'If (lDstHeight > Height) Then lDstHeight = Height
BitBlt hDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDC, lSrcX,
lSrcY, vbSrcCopy
lDstX = lDstX + lDstWidth
lSrcX = 0
lDstWidth = lBitmapW
Loop
lDstY = lDstY + lDstHeight
lSrcY = 0
lDstHeight = lBitmapH
Loop
End Sub
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Gets/sets the back colour of the control.
Not applicable when using XPStyle."
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(oColor As OLE_COLOR)
UserControl.BackColor = oColor
pDraw
PropertyChanged "BackColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Gets/sets the colour of text which is
drawn over the background of the bar."
ForeColor = m_oForeColor
End Property
Public Property Let ForeColor(oColor As OLE_COLOR)
m_oForeColor = oColor
pDraw
PropertyChanged "ForeColor"
End Property
Public Property Get Font() As IFont
Attribute Font.VB_Description = "Gets/sets the font used to draw text on the
progress bar."
Set Font = UserControl.Font
End Property
Public Property Set Font(ByRef fnt As IFont)
Set UserControl.Font = fnt
pDraw
PropertyChanged "Font"
End Property
Public Property Let Font(ByRef fnt As IFont)
Set UserControl.Font = fnt
pDraw
PropertyChanged "Font"
End Property
Public Property Get BarColor() As OLE_COLOR
Attribute BarColor.VB_Description = "Gets/sets the colour of the progress bar.
Not applicable when using XPStyle."
BarColor = m_oBarColor
End Property
Public Property Let BarColor(oColor As OLE_COLOR)
m_oBarColor = oColor
pDraw
PropertyChanged "BarColor"
End Property
Public Property Get BarForeColor() As OLE_COLOR
Attribute BarForeColor.VB_Description = "Gets/sets the colour of text which is
drawn over the bar."
BarForeColor = m_oBarForeColor
End Property
Public Property Let BarForeColor(oColor As OLE_COLOR)
m_oBarForeColor = oColor
pDraw
PropertyChanged "BarForeColor"
End Property
Public Function ModifyBarPicture( _
Optional ByVal fLuminance As Double = 1, _
Optional ByVal fSaturation As Double = 1 _
)
Attribute ModifyBarPicture.VB_Description = "Applies image processing to the
bar picture, allowing you to adjust the luminance or saturation of the image."
If (pbPic(picBar)) Then
Dim cDib As New pcDibSection
cDib.CreateFromPicture picBar
cDib.ModifyHLS 1, fLuminance, fSaturation
cDib.PaintPicture picBar.hDc
End If
End Function
Public Function ModifyPicture( _
Optional ByVal fLuminance As Double = 1, _
Optional ByVal fSaturation As Double = 1 _
)
Attribute ModifyPicture.VB_Description = "Applies image processing to the
background picture, allowing you to adjust the luminance or saturation of the
image."
If (pbPic(picBack)) Then
Dim cDib As New pcDibSection
cDib.CreateFromPicture picBack
cDib.ModifyHLS 1, fLuminance, fSaturation
cDib.PaintPicture picBack.hDc
End If
End Function
Public Property Get BarPicture() As IPicture
Attribute BarPicture.VB_Description = "Gets/sets a picture to use as the bar in
the progress bar."
Set BarPicture = picBar.Picture
End Property
Public Property Let BarPicture(pic As IPicture)
pPicture pic, picBar
End Property
Public Property Set BarPicture(pic As IPicture)
pPicture pic, picBar
End Property
Public Property Get BarPictureMode() As EVPRGPictureModeConstants
Attribute BarPictureMode.VB_Description = "Gets/sets the drawing mode (stretch
or tile) applied when drawing the bar picture."
BarPictureMode = m_eBarPictureMode
End Property
Public Property Let BarPictureMode(ByVal eMode As EVPRGPictureModeConstants)
m_eBarPictureMode = eMode
pDraw
PropertyChanged "BarPictureMode"
End Property
Public Property Get BackPictureMode() As EVPRGPictureModeConstants
Attribute BackPictureMode.VB_Description = "Gets/sets the drawing mode (stretch
or tile) applied when drawing the background picture."
BackPictureMode = m_eBackPictureMode
End Property
Public Property Let BackPictureMode(ByVal eMode As EVPRGPictureModeConstants)
m_eBackPictureMode = eMode
pDraw
PropertyChanged "BackPictureMode"
End Property
Public Property Get Picture() As IPicture
Attribute Picture.VB_Description = "Gets/sets the picture shown in the
background of the progress bar control."
Set Picture = picBack.Picture
End Property
Public Property Let Picture(pic As IPicture)
pPicture pic, picBack
End Property
Public Property Set Picture(pic As IPicture)
pPicture pic, picBack
End Property
Private Sub pPicture(pic As IPicture, picStore As PictureBox)
Set picStore.Picture = pic
pDraw
PropertyChanged "Picture"
PropertyChanged "BarPicture"
End Sub
Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
Optional hPal As Long = 0) As Long
' Convert Automation color to Windows color
If OleTranslateColor(oClr, hPal, TranslateColor) Then
TranslateColor = CLR_INVALID
End If
End Function
Private Sub UserControl_Initialize()
Set m_cMemDC = New pcMemDC
m_eAppearance = epba3DThin
m_eBorderStyle = epbsInset
m_oBarColor = &H800000
m_oBarForeColor = &HFFFFFF
m_eBarPictureMode = epbpTile
m_eBackPictureMode = epbpTile
m_lMax = 100
m_eTextAlignX = epbthCenter
m_eTextAlignY = epbtvVCenter
End Sub
Private Sub UserControl_InitProperties()
m_hWnd = UserControl.hwnd
End Sub
Private Sub UserControl_Paint()
pDraw
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_hWnd = UserControl.hwnd
Picture = PropBag.ReadProperty("Picture", Nothing)
BackColor = PropBag.ReadProperty("BackColor", vbButtonFace)
ForeColor = PropBag.ReadProperty("ForeColor", vbWindowText)
Appearance = PropBag.ReadProperty("Appearance", epba3DThin)
BorderStyle = PropBag.ReadProperty("BorderStyle", epbsInset)
BarColor = PropBag.ReadProperty("BarColor", &H800000)
BarForeColor = PropBag.ReadProperty("BarForeColor", &HFFFFFF)
BarPicture = PropBag.ReadProperty("BarPicture", Nothing)
BarPictureMode = PropBag.ReadProperty("BarPictureMode", epbpTile)
BackPictureMode = PropBag.ReadProperty("BackPictureMode", epbpTile)
Min = PropBag.ReadProperty("Min", 0)
Max = PropBag.ReadProperty("Max", 100)
Value = PropBag.ReadProperty("Value", 0)
ShowText = PropBag.ReadProperty("ShowText", False)
TextAlignX = PropBag.ReadProperty("TextAlignX", epbthCenter)
TextAlignY = PropBag.ReadProperty("TextAlignY", epbtvVCenter)
Text = PropBag.ReadProperty("Text", "")
Font = PropBag.ReadProperty("Font", UserControl.Font)
Segments = PropBag.ReadProperty("Segments", False)
XpStyle = PropBag.ReadProperty("XpStyle", False)
End Sub
Private Sub UserControl_Resize()
pDraw
End Sub
Private Sub UserControl_Terminate()
Set m_cMemDC = Nothing
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "Picture", Picture, Nothing
PropBag.WriteProperty "BackColor", BackColor, vbButtonFace
PropBag.WriteProperty "ForeColor", ForeColor, vbWindowText
PropBag.WriteProperty "Appearance", Appearance, epba3DThin
PropBag.WriteProperty "BorderStyle", BorderStyle, epbsInset
PropBag.WriteProperty "BarColor", BarColor, &H800000
PropBag.WriteProperty "BarForeColor", BarForeColor, &HFFFFFF
PropBag.WriteProperty "BarPicture", BarPicture, Nothing
PropBag.WriteProperty "BarPictureMode", BarPictureMode, epbpTile
PropBag.WriteProperty "BackPictureMode", BackPictureMode, epbpTile
PropBag.WriteProperty "Min", Min, 0
PropBag.WriteProperty "Max", Max, 100
PropBag.WriteProperty "Value", Value, 0
PropBag.WriteProperty "ShowText", ShowText, False
PropBag.WriteProperty "TextAlignX", TextAlignX, epbthCenter
PropBag.WriteProperty "TextAlignY", TextAlignY, epbtvVCenter
PropBag.WriteProperty "Text", Text, ""
PropBag.WriteProperty "Font", Font
PropBag.WriteProperty "Segments", Segments, False
PropBag.WriteProperty "XpStyle", XpStyle, False
End Sub
|
|