clsbutton.cls

酒店管理系统

    SetPixel DownDC, j, (bH - bEdge), sPix
Next j
'--------------CORNERS-----------------------
Corners:
'bRad = bRad + 1 'return the value to it's original settings
Dim rX As Integer
Dim rY As Integer
Dim lX As Integer
Dim lY As Integer
Dim rStep As Integer
'Top Left Corder
M = 0
For i = bRad To bRad + bEdge
    For j = 91 To 179
        rX = (i * Cos(j * (pi / 180))) + (bRad + bEdge)
        rY = -(i * Sin(j * (pi / 180))) + (bRad + bEdge)
        If lX <> rX Or lY <> rY Then
            If i = bRad Then
                sPix = Darken(GetPixel(picHDC, rX, rY), bLevel)
            Else
                sPix = Darken(GetPixel(picHDC, rX, rY), M * bLevel)
            End If
            fPix = GetPixel(conHDC, rX + bL, rY + bT)
            SetPixel DownDC, rX, rY, Blend(sPix, fPix, M)
        End If
        lX = rX
        lY = rY
    Next j
    M = M + (1 / (bEdge))
Next i
'Top Right Corder
M = 0
For i = bRad To bRad + bEdge
    S = 0
    For j = 91 To 179
        rX = -(i * Cos(j * (pi / 180))) + (bW - bRad - bEdge)
        rY = -(i * Sin(j * (pi / 180))) + (bRad + bEdge)
        If lX <> rX Or lY <> rY Then
            If j < 135 Then
                If i = bRad Then
                    sPix = Darken(GetPixel(picHDC, rX, rY), (1 - S) * bLevel)
                Else
                    sPix = Darken(GetPixel(picHDC, rX, rY), (M - S) * bLevel)
                End If
            Else
                If i = bRad Then
                    sPix = Brighten(GetPixel(picHDC, rX, rY), (1 - S) * bLevel)
                Else
                    sPix = Brighten(GetPixel(picHDC, rX, rY), (M - S) * bLevel)
                End If
            End If
            fPix = GetPixel(conHDC, rX + bL, rY + bT)
            SetPixel DownDC, rX, rY, Blend(sPix, fPix, M)
        End If
        If j < 135 Then
            S = S + (1 / 45)
        Else
            S = S - (1 / 45)
        End If
        lX = rX
        lY = rY

    Next j
    M = M + (1 / (bEdge))
Next i
'Bottom Left Corder
M = 0
For i = bRad To bRad + bEdge
    S = 0
    For j = 91 To 179
        rX = (i * Cos(j * (pi / 180))) + (bRad + bEdge)
        rY = (i * Sin(j * (pi / 180))) + (bH - bRad - bEdge)
        If lX <> rX Or lY <> rY Then
            If j > 135 Then
                If i = bRad Then
                    sPix = Darken(GetPixel(picHDC, rX, rY), (1 + S) * bLevel)
                Else
                    sPix = Darken(GetPixel(picHDC, rX, rY), (M + S) * bLevel)
                End If
            Else
                If i = bRad Then
                    sPix = Brighten(GetPixel(picHDC, rX, rY), (1 + S) * bLevel)
                Else
                    sPix = Brighten(GetPixel(picHDC, rX, rY), (M + S) * bLevel)
                End If
            End If
            fPix = GetPixel(conHDC, rX + bL, rY + bT)
            SetPixel DownDC, rX, rY, Blend(sPix, fPix, M)
        End If
        lX = rX
        lY = rY
        If j > 135 Then
            S = S + (1 / 45)
        Else
            S = S - (1 / 45)
        End If
    Next j
    M = M + (1 / (bEdge))
Next i
'Bottom right Corder
M = 0
For i = bRad To bRad + bEdge
    For j = 91 To 179
        rX = -(i * Cos(j * (pi / 180))) + (bW - bRad - bEdge)
        rY = (i * Sin(j * (pi / 180))) + (bH - bRad - bEdge)
        If lX <> rX Or lY <> rY Then
            If i = bRad Then
                sPix = Brighten(GetPixel(picHDC, rX, rY), bLevel)
            Else
                sPix = Brighten(GetPixel(picHDC, rX, rY), M * bLevel)
            End If
            fPix = GetPixel(conHDC, rX + bL, rY + bT)
            SetPixel DownDC, rX, rY, Blend(sPix, fPix, M)
        End If
        lX = rX
        lY = rY
    Next j
    M = M + (1 / (bEdge))
Next i
Set BContainer = Nothing
End Sub




Function InitButton(pTarget As PictureBox, lText As String, bRounded As Boolean, bLevel As Single, bEdge As Integer, bRad As Integer, Clear As Boolean) As Single
Dim dT As Single
Dim bW As Long
Dim bH As Long
dT = Timer()
pTarget.ScaleMode = vbPixels
pTarget.Container.ScaleMode = vbPixels
bW = pTarget.ScaleWidth - 1  'we subtract 1 to account for the missing border
bH = pTarget.ScaleHeight - 1
pWidth = bW + 1
pHeight = bH + 1
pHwnd = pTarget.hwnd
Set parentPic = pTarget
'--------------CREATE A REGION IF IT'S ROUNDED----------------------------
If bRounded Then
    Dim NewRGN As Long
    If bW = bH Then
        NewRGN = CreateEllipticRgn(0, 0, bW + 1, bH + 1)
    Else
        NewRGN = CreateEllipticRgn(0, 0, ((bRad + bEdge) * 2) + 1, ((bRad + bEdge) * 2) + 1)
        CombineRgn NewRGN, NewRGN, CreateEllipticRgn(bW + 1, bH + 1, (bW - 1) - ((bRad + bEdge) * 2), (bH - 1) - ((bRad + bEdge) * 2)), 2
        CombineRgn NewRGN, NewRGN, CreateEllipticRgn(0, bH + 1, ((bRad + bEdge) * 2) + 1, (bH - 1) - ((bRad + bEdge) * 2)), 2
        CombineRgn NewRGN, NewRGN, CreateEllipticRgn(bW + 1, 0, (bW - 1) - ((bRad + bEdge) * 2), ((bRad + bEdge) * 2) + 1), 2
        CombineRgn NewRGN, NewRGN, CreateRectRgn(0, (bRad + bEdge) + 1, bW + 1, bH - (bRad + bEdge)), 2
        CombineRgn NewRGN, NewRGN, CreateRectRgn((bRad + bEdge) + 1, 0, bW - (bRad + bEdge), bH + 1), 2
    End If
    SetWindowRgn pTarget.hwnd, NewRGN, True
    '-----------Get Images for rounded button
    DownDC = CreateDOWN(pTarget.hdc, bW, bH)
    InsetRound pTarget, bLevel, bEdge, bRad, Clear
    EmbossDown lText, 1, 1
    UpDC = CreateUP(pTarget.hdc, bW, bH)
    RaiseRound pTarget, bLevel, bEdge, bRad, Clear
    EmbossUp lText, -1, -1
Else
    DownDC = CreateDOWN(pTarget.hdc, bW, bH)
    InsetBevel pTarget, bLevel, bEdge, Clear
    EmbossDown lText, 1, 1
    UpDC = CreateUP(pTarget.hdc, bW, bH)
    RaiseBevel pTarget, bLevel, bEdge, Clear
    EmbossUp lText, -1, -1
End If
'--------------Paint the UP state-----------
StretchBlt pTarget.hdc, 0, 0, pTarget.ScaleWidth, pTarget.ScaleHeight, UpDC, 0, 0, UpWidth, UpHeight, vbSrcCopy
pTarget.Refresh
'---------------I wish I could use the a call back within a class!----
'---------------If I could I would hook the mouse down and MOuse up events of
'---------------the target picturebox to display the states
'TriggerButton
InitButton = Timer - dT
End Function




Private Function NZ(ZInput, Optional ZDefault) As Variant
On Error GoTo SkipIt:
If IsMissing(ZDefault) Then ZDefault = ""
If (IsNull(ZInput)) Or (ZInput = Empty) Or (ZInput = "") Then
    NZ = ZDefault
Else
    NZ = ZInput
End If
Exit Function
SkipIt:
NZ = ""
End Function



Private Function Brighten(RGBColor As Long, Percent As Single)
'Brightens a color by a decimal percent
Dim HSL As HSLCol, L As Long
    If Percent <= 0 Then
        Brighten = RGBColor
        Exit Function
    End If
    
    HSL = RGBtoHSL(RGBColor)
    L = HSL.Lum + (HSLMAX * Percent)
    If L > HSLMAX Then L = HSLMAX
    HSL.Lum = L
    Brighten = HSLtoRGB(HSL)
End Function
Private Function Darken(RGBColor As Long, Percent As Single)
'Darkens a color by a percent
Dim HSL As HSLCol, L As Long
    If Percent <= 0 Then
        Darken = RGBColor
        Exit Function
    End If
    
    HSL = RGBtoHSL(RGBColor)
    L = HSL.Lum - (HSLMAX * Percent)
    If L < 0 Then L = 0
    HSL.Lum = L
    Darken = HSLtoRGB(HSL)
End Function
Private Function Blend(RGB1 As Long, RGB2 As Long, Percent As Single) As Long
'blends two colors together by a certain percent (decimal percent)
Dim R As Integer, R1 As Integer, R2 As Integer, g As Integer, G1 As Integer, G2 As Integer, b As Integer, b1 As Integer, b2 As Integer
    
    If Percent >= 1 Then
        Blend = RGB2
        Exit Function
    ElseIf Percent <= 0 Then
        Blend = RGB1
        Exit Function
    End If
    
    R1 = RGBRed(RGB1)
    R2 = RGBRed(RGB2)
    G1 = RGBGreen(RGB1)
    G2 = RGBGreen(RGB2)
    b1 = RGBBlue(RGB1)
    b2 = RGBBlue(RGB2)
    
    R = ((R2 * Percent) + (R1 * (1 - Percent)))
    g = ((G2 * Percent) + (G1 * (1 - Percent)))
    b = ((b2 * Percent) + (b1 * (1 - Percent)))
    
    Blend = RGB(R, g, b)
End Function
Private Function iMax(a As Integer, b As Integer) _
    As Integer
'Return the Larger of two values
    iMax = IIf(a > b, a, b)
End Function

Private Function iMin(a As Integer, b As Integer) _
    As Integer
'Return the smaller of two values
    iMin = IIf(a < b, a, b)
End Function

Private Function RGBRed(RGBCol As Long) As Integer
If RGBCol = -1 Then Exit Function
'Return the Red component from an RGB Color
    RGBRed = RGBCol And &HFF
End Function

Private Function RGBGreen(RGBCol As Long) As Integer
If RGBCol = -1 Then Exit Function
'Return the Green component from an RGB Color
    RGBGreen = ((RGBCol And &H100FF00) / &H100)
End Function

Private Function RGBBlue(RGBCol As Long) As Integer
If RGBCol = -1 Then Exit Function
'Return the Blue component from an RGB Color
    RGBBlue = (RGBCol And &HFF0000) / &H10000
End Function
Private Function HSLtoRGB(HueLumSat As HSLCol) As Long '***
'Converts HSL to a color value
    Dim R As Double, g As Double, b As Double
    Dim H As Double, L As Double, S As Double
    Dim Magic1 As Double, Magic2 As Double
    H = HueLumSat.Hue
    L = HueLumSat.Lum
    S = HueLumSat.Sat
    If CInt(S) = 0 Then
        R = (L * RGBMAX) / HSLMAX
        g = R
        b = R
    Else
        If L <= HSLMAX / 2 Then
            Magic2 = (L * (HSLMAX + S) + 0.5) / HSLMAX
        Else
            Magic2 = L + S - ((L * S) + 0.5) / HSLMAX
        End If
        Magic1 = 2 * L - Magic2
        R = (HuetoRGB(Magic1, Magic2, H + (HSLMAX / 3)) * RGBMAX + 0.5) / HSLMAX
        g = (HuetoRGB(Magic1, Magic2, H) * RGBMAX + 0.5) / HSLMAX
        b = (HuetoRGB(Magic1, Magic2, H - (HSLMAX / 3)) * RGBMAX + 0.5) / HSLMAX
    End If
    HSLtoRGB = RGB(CInt(R), CInt(g), CInt(b))
End Function

Private Function HuetoRGB(mag1 As Double, mag2 As Double, ByVal Hue As Double) As Double     '***
'Utility function for HSLtoRGB
    If Hue < 0 Then
        Hue = Hue + HSLMAX
    ElseIf Hue > HSLMAX Then
        Hue = Hue - HSLMAX
    End If
    Select Case Hue
        Case Is < (HSLMAX / 6)
            HuetoRGB = (mag1 + (((mag2 - mag1) * Hue + _
                (HSLMAX / 12)) / (HSLMAX / 6)))
        Case Is < (HSLMAX / 2)
            HuetoRGB = mag2
        Case Is < (HSLMAX * 2 / 3)
            HuetoRGB = (mag1 + (((mag2 - mag1) * _
                ((HSLMAX * 2 / 3) - Hue) + _
                (HSLMAX / 12)) / (HSLMAX / 6)))
        Case Else
            HuetoRGB = mag1
    End Select
End Function
Private Function RGBtoHSL(RGBCol As Long) As HSLCol '***
'Returns an HSLCol datatype containing Hue, Luminescence
'and Saturation; given an RGB Color value

Dim R As Integer, g As Integer, b As Integer
Dim cMax As Integer, cMin As Integer
Dim RDelta As Double, GDelta As Double, _
    BDelta As Double
Dim H As Double, S As Double, L As Double
Dim cMinus As Long, cPlus As Long
    
    R = RGBRed(RGBCol)
    g = RGBGreen(RGBCol)
    b = RGBBlue(RGBCol)
    
    cMax = iMax(iMax(R, g), b) 'Highest and lowest
    cMin = iMin(iMin(R, g), b) 'color values
    
    cMinus = cMax - cMin 'Used to simplify the
    cPlus = cMax + cMin  'calculations somewhat.
    
    'Calculate luminescence (lightness)
    L = ((cPlus * HSLMAX) + RGBMAX) / (2 * RGBMAX)
    
    If cMax = cMin Then 'achromatic (r=g=b, greyscale)
        S = 0 'Saturation 0 for greyscale
        H = UNDEFINED 'Hue undefined for greyscale
    Else
        'Calculate color saturation
        If L <= (HSLMAX / 2) Then
            S = ((cMinus * HSLMAX) + 0.5) / cPlus
        Else
            S = ((cMinus * HSLMAX) + 0.5) / (2 * RGBMAX - cPlus)
        End If
    
        'Calculate hue
        RDelta = (((cMax - R) * (HSLMAX / 6)) + 0.5) / cMinus
        GDelta = (((cMax - g) * (HSLMAX / 6)) + 0.5) / cMinus
        BDelta = (((cMax - b) * (HSLMAX / 6)) + 0.5) / cMinus
    
        Select Case cMax
            Case CLng(R)
                H = BDelta - GDelta
            Case CLng(g)
                H = (HSLMAX / 3) + RDelta - BDelta
            Case CLng(b)
                H = ((2 * HSLMAX) / 3) + GDelta - RDelta
        End Select
        
        If H < 0 Then H = H + HSLMAX
    End If
    
    RGBtoHSL.Hue = CInt(H)
    RGBtoHSL.Lum = CInt(L)