Üç Boyutlu ve Rengarenk ProgressBar Yapımı.

- Bu döküman ve örnekte, VB6.0 da UserControl nesnesi kullanılarak
ProgressBar kontrolünün nasıl hazırlandığı incelenecek.
- ProgressBar'a özellikler ekleyip, ön ve arka plan renklerini
bu özellikler vasıtasıyla değiştireceğiz.
- Ayrıca event kullanımlarına ilişkin olarak, yapmakta olacağımız
kontrol nesnesine Click, MouseDown, MouseUp ve MouseMove olaylarını
ekleyeceğiz.



Hazırlık

Yapacağımız kontrol nesnesini EXE projesi içinde kullacağız.
Dilerseniz yeni bir ActiveControl projesinde OCX olarak
hazırlayabilirsiniz.

Öncelikle yeni bir EXE projesi açıp, projeye bir tane UserControl
ve iki tane Modul ekleyin. Ben, projede kullandığım objelere
aşağıdaki isimleri verdim. Döküman anlatımı süresince bu isimlerle
kullanacağım.


Form: Form1
UserControl: GBProgressBar
Module: mdlDrawing
Module: mdlRGBHSL


UserControl: GBProgressBar

UserControl nesnesinin ismini "GBProgressBar" olarak kullandık.
Bu kontrol nesnesi, Toolbar bölümünde varsayılan icon resmi
ile gözükecektir. Biz bu ikonu kendi hazırladığımız resimle
değiştireceğiz.

UserControl'un ScaleMode özelliğini pixel olarak tanımlayın ve AutoRedraw
özelliğini ise True yapın.

Mouse, Toolbardaki bu kontrol üzerine geldiğinde, hatırlatma
balonu çıkacak ve vermiş olduğunuz "GBProgressBar" ismi gözükecektir.

Toolbar'daki iconu değiştirmek için, UserControl nesnesinin "ToolboxBitmap"
özelliğine kendi hazırladığımız resmi seçeceğiz. Bu resim 16x15 pixel
boyutlarında olmalı ve "1, 15" koordinatlarındaki renk değeri maskeleme için
kullanılacaktır. Yani "x=1, y=15" koordinatlarındaki renk değeri siyah ise
bu resim içinde kullandığınız tüm siyah renkler maskelenecektir.

UserControl nesnesinin kod bölümüne geçelim ve bu kontrol içinde kullanacağımız
özellikleri saklayan değişkenleri tanımlayalım. Bu alanda "eProgressScrolling"
isimli bir enum olusturuyoruz. Enum ile ilgili açıklama dökümanın ilerleyen
bölümlerinde verilecektir.


' ProgressBar'ın görünüm değerleri
Public Enum eProgressScrolling
pbScrollingStandard = 0
pbScrollingSmooth = 1
End Enum


m_nScrolling = pbScrollingStandard
End Sub


Bir de "UserControl_InitProperties" olayı vardır.
Bu olay "UserControl_Initialize" dan sonra çalışır ve "Ambient" kullanımına
izin verir. Sadece yazmakta olduğumuz "UserControl" nesnesi herhangi bir
forma eklendiğinde çalışır.

örn: Kontrolü forma eklediğimizde, kontrolün arkaplan renginin, form ile
aynı olmasını istiyorsak. Bu bölüme aşağıdaki kodlar eklenebilir.


Private Sub UserControl_InitProperties()
'Bu işlem UserControl_Initialize da yapılamaz.
m_nBackColor = Ambient.BackColor
End Sub


Yukarıda tanımlanan değişkenleri UserControl dışından kullanabilmemiz için
kontrole özellikler eklememiz gerekmektedir.


Public Property Get FaceColor() As OLE_COLOR
FaceColor = m_nFaceColor
End Property
Public Property Let FaceColor(ByVal newVal As OLE_COLOR)
m_nFaceColor = newVal
Call DrawProgress
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = m_nBackColor
End Property
Public Property Let BackColor(ByVal newVal As OLE_COLOR)
m_nBackColor = newVal
Call DrawProgress
End Property
*
*
*


Her özelliği değiştirdiğiminde kontrolü "DrawProgress" alt programı
ile tekrar çiziyoruz.


Private Sub DrawProgress()
Dim nVal As Long

UserControl.Cls
nVal = (UserControl.ScaleWidth - 4)
UserControl.BackColor = m_nBackColor
If Ambient.UserMode Then
nVal = ((UserControl.ScaleWidth - 4) / (m_nMax - m_nMin)) * (m_nValue - m_nMin)
End If
Call DrawDegrade(UserControl.hdc, 2, 2, nVal, (UserControl.ScaleHeight - 4), (UserControl.ScaleWidth - 4), m_nFaceColor, m_nScrolling)
Call DrawEdgeEx(UserControl.hdc, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight)
If UserControl.AutoRedraw Then UserControl.Refresh
End Sub


Yukarıdaki kodda "Ambient.UserMode" değeri, uygulama çalıştırıldığında
"True" olur. Normalde kontrol forma eklendiğinde "Value" değerini maximum
olarak gösterip, progress'in tamamını çizerek kullanıcıya göstermek
amacıyla kullanılmıştır. Kodu kullanırken daha net anlayacaksınız.

UserControl'ün tüm kodları aşağıda sunulmuştur.

' Author: Gökhan ERDOĞDU
' Date : 03.06.2009
' mail : gokhan_erdogdu@yahoo.com
' Copyright 2009 GBSoftware

Option Explicit

Public Enum eProgressScrolling
pbScrollingStandard = 0
pbScrollingSmooth = 1
End Enum

Dim m_nFaceColor As OLE_COLOR
Dim m_nBackColor As OLE_COLOR
Dim m_nMax As Long
Dim m_nMin As Long
Dim m_nValue As Long
Dim m_bEnabled As Boolean
Dim m_nScrolling As eProgressScrolling

Public Event Click()
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

Private Sub DrawProgress()
Dim nVal As Long

UserControl.Cls
nVal = (UserControl.ScaleWidth - 4)
UserControl.BackColor = m_nBackColor
If Ambient.UserMode Then
nVal = ((UserControl.ScaleWidth - 4) / (m_nMax - m_nMin)) * (m_nValue - m_nMin)
End If
Call DrawDegrade(UserControl.hdc, 2, 2, nVal, (UserControl.ScaleHeight - 4), (UserControl.ScaleWidth - 4), m_nFaceColor, m_nScrolling)
Call DrawEdgeEx(UserControl.hdc, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight)
If UserControl.AutoRedraw Then UserControl.Refresh
End Sub

Private Sub UserControl_Click()
If Not m_bEnabled Then Exit Sub
RaiseEvent Click
End Sub

Private Sub UserControl_InitProperties()
m_nBackColor = Ambient.BackColor
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not m_bEnabled Then Exit Sub
RaiseEvent MouseDown(Button, Shift, x, y)
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not m_bEnabled Then Exit Sub
RaiseEvent MouseMove(Button, Shift, x, y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not m_bEnabled Then Exit Sub
RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

Private Sub UserControl_Initialize()
m_nMax = 100
m_nFaceColor = vbGreen
m_nBackColor = vbButtonFace
m_nValue = 0
m_nScrolling = pbScrollingStandard
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_nFaceColor = PropBag.ReadProperty("FaceColor", vbGreen)
m_nBackColor = PropBag.ReadProperty("BackColor", vbButtonFace)
m_nMax = PropBag.ReadProperty("Max", 100)
m_nMin = PropBag.ReadProperty("Min", 0)
m_nValue = m_nMin
m_nScrolling = PropBag.ReadProperty("Scrolling", pbScrollingStandard)
m_bEnabled = PropBag.ReadProperty("Enabled", True)
Call DrawProgress
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("FaceColor", m_nFaceColor)
Call PropBag.WriteProperty("BackColor", m_nBackColor)
Call PropBag.WriteProperty("Max", m_nMax)
Call PropBag.WriteProperty("Min", m_nMin)
Call PropBag.WriteProperty("Scrolling", m_nScrolling)
Call PropBag.WriteProperty("Enabled", m_bEnabled)
End Sub

Private Sub UserControl_Resize()
Call DrawProgress
End Sub

Public Property Get FaceColor() As OLE_COLOR
FaceColor = m_nFaceColor
End Property
Public Property Let FaceColor(ByVal newVal As OLE_COLOR)
m_nFaceColor = newVal
Call DrawProgress
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = m_nBackColor
End Property
Public Property Let BackColor(ByVal newVal As OLE_COLOR)
m_nBackColor = newVal
Call DrawProgress
End Property

Public Property Get Max() As Long
Max = m_nMax
End Property
Public Property Let Max(ByVal newVal As Long)
If newVal > m_nMin Then
m_nMax = newVal
If m_nValue > m_nMax Then m_nValue = m_nMax
Call DrawProgress
Else
VBA.Err.Raise 380, , "Invalid property value"
End If
End Property

Public Property Get Min() As Long
Min = m_nMin
End Property
Public Property Let Min(ByVal newVal As Long)
If newVal < m_nMax Then
m_nMin = newVal
If m_nValue < m_nMin Then m_nValue = m_nMin
Call DrawProgress
Else
VBA.Err.Raise 380, , "Invalid property value"
End If
End Property

Public Property Get Value() As Long
Value = m_nValue
End Property
Public Property Let Value(ByVal newVal As Long)
If newVal >= m_nMin And newVal <= m_nMax Then
m_nValue = newVal
Call DrawProgress
Else
VBA.Err.Raise 380, , "Invalid property value"
End If
End Property

Public Property Get Scrolling() As eProgressScrolling
Scrolling = m_nScrolling
End Property
Public Property Let Scrolling(ByVal newVal As eProgressScrolling)
m_nScrolling = newVal
Call DrawProgress
End Property

Public Property Get Enabled() As Boolean
Enabled = m_bEnabled
End Property
Public Property Let Enabled(ByVal newVal As Boolean)
m_bEnabled = newVal
Call DrawProgress
End Property


Module: mdlDrawing

Çizim işlemleri için kullandığımız fonksiyon ve api fonksiyonlarını
bu modülde tanımlıyoruz.

' Author: Gökhan ERDOĞDU
' Date : 03.06.2009
' mail : gokhan_erdogdu@yahoo.com
' Copyright 2009 GBSoftware

Option Explicit

Private Const MAX_LUMINANCE = &HA0
Private Const MIN_LUMINANCE = &H3C
Private Const PROGRESS_PIE_WIDTH = 6

Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8

Private Const BDR_OUTER = &H3
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA

Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER 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_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Private Const BF_DIAGONAL = &H10

' For diagonal lines, the BF_RECT flags specify the end point of the
' vector bounded by the rectangle parameter.
Private Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP _
Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM _
Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM _
Or BF_RIGHT)

Private Const BF_MIDDLE = &H800 ' Fill in the middle
Private Const BF_SOFT = &H1000 ' For softer buttons
Private Const BF_ADJUST = &H2000 ' Calculate the space left over
Private Const BF_FLAT = &H4000 ' For flat rather than 3D borders
Private Const BF_MONO = &H8000 ' For monochrome borders

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, _
qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Boolean

Private Declare Function SetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long, ByVal crColor As Long) As Long


Public Function DrawEdgeEx(ByVal nDC As Long, ByVal nX As Long, ByVal nY As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Boolean
Dim rc1 As RECT
rc1.Left = nX
rc1.Right = nX + nWidth
rc1.Top = nY
rc1.Bottom = nY + nHeight
DrawEdgeEx = DrawEdge(nDC, rc1, BDR_SUNKENOUTER, BF_RECT)
End Function

Public Sub DrawDegrade(ByVal nDC As Long, ByVal nX As Long, ByVal nY As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal nMaxWidth As Long, ByVal nColor As Long, ByVal nScrolling As eProgressScrolling)
If nWidth <= 0 Or nHeight <= 0 Then Exit Sub

Dim i As Long, j As Long, k As Long
Dim nPieWidth As Long
Dim nCntX As Long, nCntY As Long
Dim nLum As Long
Dim dScale As Double

nPieWidth = nHeight * 3 / 4
nCntX = nX + nWidth - 1
nCntY = nY + nHeight - 1
If nScrolling = pbScrollingStandard Then
dScale = (MAX_LUMINANCE - MIN_LUMINANCE) / nHeight
For i = nX To nCntX
If ((nX - i) Mod (nPieWidth + 1)) = 0 Then
For k = i To GetMin(i + nPieWidth - 1, nMaxWidth + 1)
For j = nY To nCntY
nLum = MIN_LUMINANCE + (nCntY - j) * dScale
Call SetPixel(nDC, k, j, GetAdjustLuma(nColor, nLum))
Next j
Next k
End If
Next i
Else
dScale = (MAX_LUMINANCE - MIN_LUMINANCE) / nHeight
For i = nX To nCntX
For j = nY To nCntY
nLum = MIN_LUMINANCE + (nCntY - j) * dScale
Call SetPixel(nDC, i, j, GetAdjustLuma(nColor, nLum))
Next j
Next i
End If
End Sub

Public Function GetMin(nVal1 As Long, nVal2 As Long) As Long
GetMin = VBA.IIf(nVal1 > nVal2, nVal2, nVal1)
End Function

Public Function GetMax(nVal1 As Long, nVal2 As Long) As Long
GetMax = VBA.IIf(nVal1 > nVal2, nVal1, nVal2)
End Function


Module: mdlRGBHSL

Renk için RGB, Hue, Luminance ve Saturation gibi değerleri kontrol ettiğimiz
api fonksiyonlarını bu modülde tanımlıyoruz.

' Author: Gökhan ERDOĞDU
' Date : 03.06.2009
' mail : gokhan_erdogdu@yahoo.com
' Copyright 2009 GBSoftware

Option Explicit

Public Type RGBQUAD
bB As Byte 'Blue
bG As Byte 'Green
bR As Byte 'Red
bA As Byte 'Alpha
End Type

Public Type tHSL
H As Long
S As Long
L As Long
End Type

Private Declare Function ColorAdjustLuma Lib "SHLWAPI.DLL" _
(ByVal clrRGB As Long, _
ByVal n As Long, _
ByVal fScale As Long) As Long


Private Declare Function ColorHLSToRGB Lib "SHLWAPI.DLL" _
(ByVal wHue As Long, _
ByVal wLuminance As Long, _
ByVal wSaturation As Long) As Long

Private Declare Sub ColorRGBToHLS Lib "SHLWAPI.DLL" _
(ByVal clrRGB As Long, _
ByRef wHue As Long, _
ByRef wLuminance As Long, _
ByRef wSaturation As Long)

Public Function Long2RGB(ByVal color1 As Long) As RGBQUAD
With Long2RGB
.bG = VBA.CByte((color1 - (color1 Mod 65536)) / 65535)
color1 = (color1 Mod 65535)

.bB = VBA.CByte((color1 - (color1 Mod 256)) / 255)
color1 = (color1 Mod 255)

.bR = VBA.CByte(color1)
End With
End Function

Public Function RGB2Long(rgb1 As RGBQUAD)
RGB2Long = VBA.RGB(rgb1.bR, rgb1.bG, rgb1.bB)
End Function

Public Function RGB2Grey(rgb1 As RGBQUAD) As Long
Dim nColor As Long
nColor = RGB2Long(rgb1)
RGB2Grey = Long2Grey(nColor)
End Function

Public Function Long2Grey(nColor As Long, Optional ByRef nLuminance As Long)
Dim HSL As tHSL
Call ColorRGBToHLS(nColor, HSL.H, HSL.L, HSL.S)
nLuminance = HSL.L
Long2Grey = (nLuminance * 65536 + nLuminance * 256 + nLuminance)
End Function

Public Function Long2HSL(nColor As Long) As tHSL
With Long2HSL
Call ColorRGBToHLS(nColor, .H, .L, .S)
End With
End Function

Public Function GetAdjustLuma(ByVal nColor As Long, ByVal newLuma As Long)
Dim hsl1 As tHSL
hsl1 = Long2HSL(nColor)
GetAdjustLuma = ColorHLSToRGB(hsl1.H, newLuma, hsl1.S)
End Function


Form: Form1

Hazırlamış olduğumuz ProgressBar'ı test ettiğimiz form objesinin
AutoRedraw özelliğini True ve ScaleMode özelliğini ise Pixel olarak
tanımlayın. Aşağıda forma ait kodlar sunulmuştur.

' Author: Gökhan ERDOĞDU
' Date : 03.06.2009
' mail : gokhan_erdogdu@yahoo.com
' Copyright 2009 GBSoftware


Private Sub Timer1_Timer()
Dim nVal As Long
Dim ctr1 As Variant

Randomize
For Each ctr1 In Me.Controls
If TypeName(ctr1) = "GBProgressBar" Then
nVal = ctr1.Value + (Rnd(999) * 5)
If nVal <= ctr1.Max Then ctr1.Value = nVal
End If
Next ctr1
End Sub