GFColorSlider/GFColorSlider.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = ‑1 'True
END
Attribute VB_Name = "GFColorSlidercls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'(c)2001, 2003, 2004 by Louis. Use to display the progress of a progress that consists of
'several smaller processes (i.e. scanning different drives).
'NOTE: the subs will not always verify passed values, so don't pass garbage.
'
Const Version As String = "v2.0" 'better graphics effects than in previous versions
'
'THIS CLASS‑MODULE IS PLUG‑IN CODE, DO NOT CHANGE!
'
'GFColorSliderStruct
Private Type GFColorSliderStruct
ColorAreaColor As Long
ColorAreaStartSize As Single 'sum of size of previous color areas
ColorAreaSize As Single
ColorAreaDescription As String
End Type
Dim GFColorSliderStructNumber As Integer
Dim GFColorSliderStructArray() As GFColorSliderStruct
Dim GFColorSliderColorAreaSizeTotal As Single 'total size of all color areas
'ColorSliderFrameStruct ‑ information to draw a Skin Engine‑like frame
Private Type ColorSliderFrameStruct
FrameColor As Long
FrameShadowColor As Long
End Type
Dim ColorSliderFrameStructVar As ColorSliderFrameStruct
'GFColorSlider_ShowProgress
Dim ProgressPercentageCurrent As Single 'also used in GFColorSlider_GetProgressCurrent
Dim ProgressPercentageOld As Single
Dim EffectsEnabledFlag As Boolean
Dim TempOld As Long
Private Sub Class_Initialize()
'on error resume next
ColorSliderFrameStructVar.FrameColor = 0 'preset
End Sub
'************************************INTERFACE SUBS*************************************
Public Sub GFColorSlider_Reset(ByRef GFColorSliderPicture As PictureBox)
'On Error Resume Next 'does not reset graphic, call before color areas are added
GFColorSliderStructNumber = 0 'reset
ReDim GFColorSliderStructArray(1 To 1) As GFColorSliderStruct 'reset
GFColorSliderColorAreaSizeTotal = 0 'reset
GFColorSliderPicture.Cls
End Sub
Public Sub GFColorSliderArea_Add(ByVal ColorAreaNumber As Integer, ByVal ColorAreaColor As Long, ByVal ColorAreaSize As Single, ByVal ColorAreaDescription As String)
'On Error Resume Next 'passed numbers must be coherent (1, 2, ...)
Dim ColorAreaSizeTotal As Single 'size of current area not in sum
Dim Temp As Long
'begin
If Not (GFColorSliderStructNumber = 32766) Then 'verify
If Not (ColorAreaNumber = (GFColorSliderStructNumber + 1)) Then
MsgBox "internal error in GFColorSliderArea_Add(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
GFColorSliderStructNumber = GFColorSliderStructNumber + 1
Else
Exit Sub 'error
End If
ReDim Preserve GFColorSliderStructArray(1 To GFColorSliderStructNumber) As GFColorSliderStruct
For Temp = 1 To GFColorSliderStructNumber ‑ 1
ColorAreaSizeTotal = ColorAreaSizeTotal + GFColorSliderStructArray(Temp).ColorAreaSize
Next Temp
GFColorSliderStructArray(GFColorSliderStructNumber).ColorAreaStartSize = ColorAreaSizeTotal
GFColorSliderStructArray(GFColorSliderStructNumber).ColorAreaSize = ColorAreaSize
GFColorSliderStructArray(GFColorSliderStructNumber).ColorAreaColor = ColorAreaColor
GFColorSliderStructArray(GFColorSliderStructNumber).ColorAreaDescription = ColorAreaDescription
ColorAreaSizeTotal = 0 'reset
For Temp = 1 To GFColorSliderStructNumber
ColorAreaSizeTotal = ColorAreaSizeTotal + GFColorSliderStructArray(Temp).ColorAreaSize
Next Temp
GFColorSliderColorAreaSizeTotal = ColorAreaSizeTotal
End Sub
Public Function GFColorSlider_GetProgressCurrent() As Single
'on error resume next 'returns the value that was passed to GFColorSlider_ShowProgress() or 0 by default
'NOTE: use the return value of this sub to easily redraw any GFColorSliderPicture.
GFColorSlider_GetProgressCurrent = ProgressPercentageCurrent
TempOld = ‑1 'reset to force redrawing color slider at next call of GFColorSlider_ShowProgress()
End Function
Public Sub GFColorSlider_ShowProgress(ByRef GFColorSliderPicture As PictureBox, ByVal ProgressPercentage As Single, Optional ByVal NoFrameFlag As Boolean = False)
'On Error Resume Next 'call when all color areas have been added, colored, sized and verified
Dim ColorAreaSizePointer As Single
Dim StructLoop As Integer
Dim Temp As Long
'verify
Select Case ProgressPercentage
Case Is < 0, Is > 100
MsgBox "internal error in GFColorSlider_ShowProgress(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End Select
For Temp = 1 To GFColorSliderPicture.ScaleWidth
'NOTE: the drawing loop is simulated to determine if any changes must be done on graphic.
If Not ((CSng(Temp) / CSng(GFColorSliderPicture.ScaleWidth) * 100!) < ProgressPercentage) Then
If Temp = TempOld Then
Exit Sub
Else
TempOld = True
Exit For
End If
End If
Next Temp
If ProgressPercentage < ProgressPercentageOld Then
ProgressPercentageCurrent = ProgressPercentage
ProgressPercentageOld = ProgressPercentage
GFColorSliderPicture.Cls 'reset
Else
ProgressPercentageCurrent = ProgressPercentage
ProgressPercentageOld = ProgressPercentage
End If
'preset
GFColorSliderPicture.AutoRedraw = True 'important
GFColorSliderPicture.ScaleMode = vbPixels 'important
'begin
For Temp = 3 To (GFColorSliderPicture.ScaleWidth ‑ 1)
ColorAreaSizePointer = CSng(Temp) / GFColorSliderPicture.ScaleWidth * GFColorSliderColorAreaSizeTotal
For StructLoop = 1 To GFColorSliderStructNumber
If (ColorAreaSizePointer >= GFColorSliderStructArray(StructLoop).ColorAreaStartSize) Then 'use '>' (compare to loop in sub above)
If Not (StructLoop = GFColorSliderStructNumber) Then
If Not (ColorAreaSizePointer < GFColorSliderStructArray(StructLoop + 1).ColorAreaStartSize) Then 'use '>' (compare to loop in sub above)
GoTo Jump:
End If
End If
'NOTE: do not draw stripes over frame.
If ((Temp + 1) Mod 2) = 0 Then 'add one to draw first stripe
GFColorSliderPicture.Line (Temp ‑ 1, 2)‑(Temp ‑ 1, GFColorSliderPicture.ScaleHeight ‑ 2), GFColor_ChangeBrightness(GFColorSliderStructArray(StructLoop).ColorAreaColor, ‑24 + (CSng(Temp) / GFColorSliderPicture.ScaleWidth) * 96)
End If
If (CSng(Temp) / CSng(GFColorSliderPicture.ScaleWidth) * 100!) < ProgressPercentage Then
If ((Temp + 0) Mod 2) = 0 Then
GFColorSliderPicture.Line (Temp ‑ 1, 2)‑(Temp ‑ 1, GFColorSliderPicture.ScaleHeight ‑ 2), GFColor_ChangeBrightness(GFColorSliderStructArray(StructLoop).ColorAreaColor, ‑48 + (CSng(Temp) / GFColorSliderPicture.ScaleWidth) * 96)
End If
Else
If TempOld = True Then TempOld = Temp 'where drawing begins
End If
Exit For
End If
Jump:
Next StructLoop
Next Temp
'
If NoFrameFlag = False Then
Call GFColorSliderFrame_Draw(GFColorSliderPicture)
End If
'
End Sub
Public Sub GFColorSlider_ShowAreaLegend(ByRef TargetObject As Object, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByRef PaletteNumber As Integer, ByVal RowNumber As Integer, Optional ByVal LineDistance As Long = 25, Optional ByVal RowDistance As Long = 150, Optional ByVal NoFrameFlag As Boolean = False)
'On Error Resume Next 'displays meaning of color areas; also copy commands of Testfrm to target project
Dim TargetObjectScaleModeUnchanged As Integer
Dim TargetObjectAutoRedrawUnchanged As Boolean
Dim LineNumberTotal As Integer
Dim PaletteNumberMax As Integer
Dim PaletteAreaNumber As Integer 'how many area descriptions can be displayed on in palette
Dim CurrentRow As Integer
Dim CurrentLine As Integer
Dim ForeColorUnchanged As Long
Dim XLoop As Integer
Dim YLoop As Integer
Dim StructLoop As Integer
'
'NOTE: this sub draws area descriptions into the rectangular area defined by X, Y, Width, Height,
'on TargetObject. If not all descriptions fit into this display area (height only), the descriptions related to the
'palette #PaletteNumber will be drawn. If a passed palette number is invalid, it will be set to the
'minimum/maximum possible value. Note that Height should be a multiple number of LineDistance.
'
'preset
CurrentLine = 1
CurrentRow = 1
TargetObjectScaleModeUnchanged = TargetObject.ScaleMode
TargetObject.ScaleMode = vbPixels
TargetObjectAutoRedrawUnchanged = TargetObject.AutoRedraw
TargetObject.AutoRedraw = True
TargetObject.Cls 'reset
'
LineNumberTotal = ‑Int(‑(GFColorSliderStructNumber / RowNumber))
If Not (Height Mod LineDistance = 0) Then
Height = Height ‑ (Height Mod LineDistance) 'see 'NOTE:'‑annotation above
End If
If Height < 1 Then Height = 1 'verify (important, if area legend area is too small)
PaletteNumberMax = ‑Int(‑(LineNumberTotal * LineDistance) / Height)
PaletteAreaNumber = (Height / LineDistance) * RowNumber
If (PaletteNumber < 1) Then
PaletteNumber = 1
End If
If (PaletteNumber > PaletteNumberMax) Then
PaletteNumber = PaletteNumberMax
End If
'begin
If (PaletteNumber) Then 'verify (important, tested)
For StructLoop = ((PaletteNumber ‑ 1) * PaletteAreaNumber + 1) To MIN(((PaletteNumber) * PaletteAreaNumber), GFColorSliderStructNumber)
'draw box
For XLoop = 1 To 10
For YLoop = 1 To 10
TargetObject.PSet (X + (CurrentRow ‑ 1) * RowDistance + XLoop, Y + (CurrentLine ‑ 1) * LineDistance + YLoop), _
GFColor_ChangeBrightness(GFColorSliderStructArray(StructLoop).ColorAreaColor, ‑((XLoop ‑ 5) * 3 + (YLoop ‑ 5) * 3))
Next YLoop
Next XLoop
TargetObject.Line (X + (CurrentRow ‑ 1) * RowDistance, Y + (CurrentLine ‑ 1) * LineDistance)‑ _
(X + (CurrentRow ‑ 1) * RowDistance + 10, Y + (CurrentLine ‑ 1) * LineDistance + 10), _
RGB(0, 0, 0), B
'print text shadow (if enabled) 'no! not readable
' If EffectsEnabledFlag = True Then
' ForeColorUnchanged = TargetObject.ForeColor
' TargetObject.ForeColor = GFColor_MixColor(ForeColorUnchanged, TargetObject.BackColor, 0.1!)
' TargetObject.CurrentX = 1 + X + (CurrentRow ‑ 1) * RowDistance + 12
' TargetObject.CurrentY = 1 + Y + (CurrentLine ‑ 1) * LineDistance + 0
' TargetObject.Print GFColorSliderStructArray(StructLoop).ColorAreaDescription
' TargetObject.ForeColor = ForeColorUnchanged
' End If
'print original text (always)
TargetObject.CurrentX = X + (CurrentRow ‑ 1) * RowDistance + 12
TargetObject.CurrentY = Y + (CurrentLine ‑ 1) * LineDistance + (10 ‑ TargetObject.TextHeight(" ")) / 2!
TargetObject.Print GFColorSliderStructArray(StructLoop).ColorAreaDescription
'end of printing text
CurrentRow = CurrentRow + 1
If CurrentRow > RowNumber Then
CurrentRow = 1
CurrentLine = CurrentLine + 1
End If
Next StructLoop
End If
'
If NoFrameFlag = False Then
Call GFColorSliderFrame_Draw(TargetObject)
End If
'
TargetObject.ScaleMode = TargetObjectScaleModeUnchanged
TargetObject.AutoRedraw = TargetObjectAutoRedrawUnchanged
End Sub
Public Sub GFColorSlider_Verify()
'on error resume next 'always call this sub when all color areas have been added
Dim SizeAdded As Single
Dim ColorAreaSizeTotal As Single
Dim StructLoop As Integer
'
'NOTE: this sub verifies EVERY color area is visible, even if it has the size 0.
'If an area has the size 0, it will be displayed as one line, no matter how large
'the other areas are (except all areas are 0). If all color areas have the size 0,
'they will all be displayed in the same size.
'
'begin
If Not (GFColorSliderColorAreaSizeTotal = 0) Then
For StructLoop = 1 To GFColorSliderStructNumber
If GFColorSliderStructArray(StructLoop).ColorAreaSize < _
(GFColorSliderColorAreaSizeTotal / 100!) Then
GFColorSliderStructArray(StructLoop).ColorAreaSize = _
(GFColorSliderColorAreaSizeTotal / 100!) 'one percent
SizeAdded = SizeAdded + (GFColorSliderColorAreaSizeTotal / 100!)
End If
Next StructLoop
Else
For StructLoop = 1 To GFColorSliderStructNumber
GFColorSliderStructArray(StructLoop).ColorAreaSize = 1
SizeAdded = SizeAdded + 1
Next StructLoop
End If
GFColorSliderColorAreaSizeTotal = GFColorSliderColorAreaSizeTotal + SizeAdded
For StructLoop = 1 To GFColorSliderStructNumber 'recalculate start size of areas
GFColorSliderStructArray(StructLoop).ColorAreaStartSize = ColorAreaSizeTotal
ColorAreaSizeTotal = ColorAreaSizeTotal + GFColorSliderStructArray(StructLoop).ColorAreaSize
Next StructLoop
End Sub
'NOTE: if the effects are enabled then there will be font shadow, 'linear gradiented'
'boxes and slider colors.
Public Property Let EffectsEnabled(ByVal EnabledFlag As Boolean)
'on error resume next
EffectsEnabledFlag = EnabledFlag
End Property
Public Property Set EffectsEnabled() As Boolean
'on error resume next
EffectsEnabled = EffectsEnabledFlag
End Property
'*********************************END OF INTERFACE SUBS*********************************
'**********************************COLOR SLIDER FRAME***********************************
Public Sub GFColorSliderFrame_SetColor(ByVal FrameColor As Long, ByVal FrameShadowColor As Long)
'on error resume next
'
'NOTE: this sub has been implemented for compatibility with the Skin Engine.
'The frame color of this class instance should be set to the frame color of the
'related ColorSliderPicture.
'
ColorSliderFrameStructVar.FrameColor = FrameColor
ColorSliderFrameStructVar.FrameShadowColor = FrameShadowColor
End Sub
Public Sub GFColorSliderFrame_Draw(ByRef TargetObject As Object)
'on error resume next 'draws a frame in the 'normal way' (not by drawing into the WindowDC)
Dim XMultiplier As Single
Dim YMultiplier As Single
'
'NOTE:
'original SE code setting frame line brightness: see SE code
'original code drawing frame: see SE code
'
'preset
If TargetObject.ScaleMode = vbTwips Then
XMultiplier = Screen.TwipsPerPixelX
YMultiplier = Screen.TwipsPerPixelY
Else
XMultiplier = 1!
YMultiplier = 1!
End If
'draw a frame like done in GFSkinEnginefrm.SE_DrawFrame()
TargetObject.Line (0, 0 * YMultiplier)‑(TargetObject.ScaleWidth ‑ 1 * XMultiplier, 0 * YMultiplier), 0 'GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, ‑66)
TargetObject.Line (0, 1 * YMultiplier)‑(TargetObject.ScaleWidth ‑ 2 * XMultiplier, 1 * YMultiplier), 0 'GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, ‑18)
'
TargetObject.Line (TargetObject.ScaleWidth ‑ 2 * XMultiplier, 1 * YMultiplier)‑(TargetObject.ScaleWidth ‑ 2 * XMultiplier, TargetObject.ScaleHeight), GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, 54)
TargetObject.Line (TargetObject.ScaleWidth ‑ 1 * XMultiplier, 0 * YMultiplier)‑(TargetObject.ScaleWidth ‑ 1 * XMultiplier, TargetObject.ScaleHeight), GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, 6)
'
TargetObject.Line (0, TargetObject.ScaleHeight ‑ 2 * YMultiplier)‑(TargetObject.ScaleWidth, TargetObject.ScaleHeight ‑ 2 * YMultiplier), GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, 6)
TargetObject.Line (0, TargetObject.ScaleHeight ‑ 1 * YMultiplier)‑(TargetObject.ScaleWidth, TargetObject.ScaleHeight ‑ 1 * YMultiplier), GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, 54)
'
TargetObject.Line (0 * XMultiplier, 2 * YMultiplier)‑(0 * XMultiplier, 0 * YMultiplier + TargetObject.ScaleHeight), 0 'GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, ‑66)
TargetObject.Line (1 * XMultiplier, 2 * YMultiplier)‑(1 * XMultiplier, ‑1 * YMultiplier + TargetObject.ScaleHeight), 0 'GFColor_ChangeBrightness(ColorSliderFrameStructVar.FrameColor, ‑18)
'
TargetObject.Refresh 'important
End Sub
'*******************************END OF COLOR SLIDER FRAME*******************************
'***********************************GENERAL FUNCTIONS***********************************
Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'On Error Resume Next
If Value1 < Value2 Then
MIN = Value1
Else
MIN = Value2
End If
End Function
'***END OF MODULE***
[END OF FILE]