Visual Basic Üç Boyutlu ve Rengarenk ProgressBar Yapımı

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. Aşağıda anlattığımız projede kullandığımız objelere aşağıdaki isimleri verdik. Anlatım süresince bu isimleri kullanıcaz.
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 16×15 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
Dim m_nFaceColor As OLE_COLOR ‘ önplan rengi
Dim m_nBackColor As OLE_COLOR ‘ arkaplan rengi
Dim m_nMax As Long ‘ maximum progress değeri
Dim m_nMin As Long ‘ minimum progress değeri
Dim m_nValue As Long ‘ progress in çalışma anındaki değeri
Dim m_bEnabled As Boolean ‘ progress’in kullanılabilirlik değeri
Dim m_nScrolling As eProgressScrolling ‘ görünümü
İlk olarak, hazırladığımız UserControl’ü formunuza eklediğinizde
varsayılan değerleri “UserControl_Initialize” bölümünde belirtiyoruz.
Private Sub UserControl_Initialize()
m_nMax = 100
m_nFaceColor = vbGreen
m_nBackColor = vbButtonFace
m_nValue = 0
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.*******
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 : [email protected]
‘ 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.*******
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 : [email protected]
‘ 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 : [email protected]
‘ 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: ERDOĞDU
‘ Date : 01.01.2010
‘ mail :
‘ Copyright © 2010 GBSoftware
Option Explicit
Private Sub Form_Resize()
Me.Cls
Call DrawDegrade(Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Me.ScaleWidth, &HC0E0FF, pbScrollingSmooth)
Me.*******
End Sub
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