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 IntegerByVal ColorAreaColor As LongByVal ColorAreaSize As SingleByVal 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 ObjectByVal X As LongByVal Y As LongByVal Width As LongByVal Height As LongByRef PaletteNumber As IntegerByVal 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 LongByVal 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 LongByVal 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]