wwbutton.ctl

FAT硬盘格式读写程序,希望能有所裨益.

   For i = Lower To Uper Step Steper
          rval = rval + (255 - R) / (He - 5)
          gval = gval + (255 - G) / (He - 5)                        '画XP渐变色
          bval = bval + (255 - B) / (He - 5)
          If rval > 255 Then rval = 255
          If gval > 255 Then gval = 255
          If bval > 255 Then bval = 255
          DrawLine 1, i, Wi - 1, i, RGB(rval, gval, bval)
   Next
End Sub
Private Sub DrawXPFrame(ByVal FrameColor As Long, ByVal PointColor As Long)
  
  DrawLine 2, 0, Wi - 2, 0, FrameColor
  DrawLine 2, He - 1, Wi - 2, He - 1, FrameColor
  DrawLine 0, 2, 0, He - 2, FrameColor                      '画XP外框和字
  DrawLine Wi - 1, 2, Wi - 1, He - 2, FrameColor
  mSetPixel 1, 1, PointColor
  mSetPixel 1, He - 2, PointColor
  mSetPixel Wi - 2, 1, PointColor
  mSetPixel Wi - 2, He - 2, PointColor
End Sub
Private Sub DrawMacOS(ByVal SaturatedColor As Long, ByVal FrameColor As Long, ByVal TingeColor As Long, ByVal mPercent As Integer, Optional isFill As Boolean = False)
  '画Mac OS 形状
  Dim i As Integer
  Dim RedColor As Long, BlueColor As Long, GreenColor As Long
  Dim RedColor1 As Long, BlueColor1 As Long, GreenColor1 As Long
  Dim rval As Single, gval As Single, bval As Single
  Dim Rcl As Single, Bcl As Single, Gcl As Single
  Dim rval1 As Single, gval1 As Single, bval1 As Single
  
    BlueColor1 = ((TingeColor \ &H10000) Mod &H100)
    GreenColor1 = ((TingeColor \ &H100) Mod &H100)
    RedColor1 = (TingeColor And &HFF)
    BlueColor = ((SaturatedColor \ &H10000) Mod &H100)
    GreenColor = ((SaturatedColor \ &H100) Mod &H100)
    RedColor = (SaturatedColor And &HFF)
    If isFill = False Then
       rval = RedColor
       gval = GreenColor
       bval = BlueColor
             Bcl = (BlueColor1 - BlueColor) / (He * mPercent / 100 - 1)
             Gcl = (GreenColor1 - GreenColor) / (He * mPercent / 100 - 1)
             Rcl = (RedColor1 - RedColor) / (He * mPercent / 100 - 1)
       For i = He * mPercent / 100 To 1 Step -1
             DrawLine 1, i, Wi - 1, i, RGB(rval, gval, bval)
             rval = rval + Rcl
             gval = gval + Gcl
             bval = bval + Bcl
             If rval > 255 Then rval = 255
             If rval < 0 Then rval = 0
             If gval > 255 Then gval = 255
             If gval < 0 Then gval = 0
             If bval > 255 Then bval = 255
             If bval < 0 Then bval = 0
        Next
          rval = rval - 2 * Rcl: rval1 = rval - 3 * Rcl
        gval = gval - 2 * Gcl: gval1 = gval - 3 * Gcl
        bval = bval - 2 * Bcl: bval1 = bval - 3 * Bcl
        For i = 0 To Wi - 4
             rval = 255 - i * (255 - RedColor1) \ (Wi - 10)
             gval = 255 - i * (255 - GreenColor1) \ (Wi - 10)         '画一条渐变亮色线
             bval = 255 - i * (255 - BlueColor1) \ (Wi - 10)
             If rval < 0 Then rval = 0
             If gval < 0 Then gval = 0
             If bval < 0 Then bval = 0
             mSetPixel i + 2, 1, RGB(rval, gval, bval)
        Next
        For i = 0 To Wi - Wi \ 3 - 2
             rval1 = 255 - i * (255 - RedColor1) \ (Wi - 2 * Wi \ 3 - 2)
             gval1 = 255 - i * (255 - GreenColor1) \ (Wi - 2 * Wi \ 3 - 2)        '画一条亮色线
             bval1 = 255 - i * (255 - BlueColor1) \ (Wi - 2 * Wi \ 3 - 2)
             If rval1 < 0 Then rval1 = 0
             If gval1 < 0 Then gval1 = 0
             If bval1 < 0 Then bval1 = 0
             mSetPixel i + 2, 2, RGB(rval1, gval1, bval1)
        Next
             Bcl = (BlueColor1 - BlueColor) / (He - He * mPercent / 100 - 4)      '
             Gcl = (GreenColor1 - GreenColor) / (He - He * mPercent / 100 - 4)    ''此段让颜色均匀变化
             Rcl = (RedColor1 - RedColor) / (He - He * mPercent / 100 - 4)
        DrawLine 1, He * mPercent / 100 + 1, Wi - 1, He * mPercent / 100 + 1, SaturatedColor
        DrawLine 1, He * mPercent / 100 + 2, Wi - 1, He * mPercent / 100 + 2, SaturatedColor
        rval = RedColor
        gval = GreenColor
        bval = BlueColor
        For i = He * mPercent / 100 + 3 To He - 4
               DrawLine 1, i, Wi - 1, i, RGB(rval, gval, bval)
               rval = rval + Rcl
               gval = gval + Gcl
               bval = bval + Bcl
               If rval > 255 Then rval = 255
               If rval < 0 Then rval = 0
               If gval > 255 Then gval = 255
               If gval < 0 Then gval = 0
               If bval > 255 Then bval = 255
               If bval < 0 Then bval = 0
        Next
        If He < 10 Then Exit Sub
        Bcl = GetPixel(UserControl.hdc, 2, He - 10)                 '借用Bcl为变量画线
        If Bcl < 0 Then Bcl = 0
        DrawLine 1, He - 9, Wi - 1, He - 9, Bcl
        DrawLine 1, He - 8, Wi - 1, He - 8, Bcl
        DrawLine 1, He * mPercent / 100 + 5, Wi - 1, He * mPercent / 100 + 5, SaturatedColor
        DrawLine 1, He - 3, Wi - 2, He - 3, Bcl
        DrawLine 1, He - 2, Wi - 2, He - 2, Bcl
   Else
       DrawRectangle 1, 1, Wi - 2, He - 2, SaturatedColor
   End If
   DrawXPFrame FrameColor, FrameColor
End Sub


Private Sub mSetPixel(ByVal X As Long, ByVal Y As Long, ByVal Color As Long)
    Call SetPixelV(UserControl.hdc, X, Y, Color)
End Sub
'**************************************************************************
Private Sub DrawFocusR()                                           '画焦点框
    SetTextColor UserControl.hdc, cText
    DrawFocusRect UserControl.hdc, rc3
End Sub
Private Sub SetColors()

If MyColorType = 2 Then              'Custom
    cFace = BackC
    cText = ForeC
    cShadow = ShiftColor(cFace, -&H40)
    cLight = ShiftColor(cFace, &H1F)
    cHighLight = ShiftColor(cFace, &H2F) 'it should be 3F but it looks too lighter
    cDarkShadow = ShiftColor(cFace, -&HC0)

ElseIf MyColorType = 3 Then              'ForceStandard
    cFace = &HC0C0C0
    cShadow = &H808080
    cLight = &HDFDFDF
    cDarkShadow = &H0
    cHighLight = &HFFFFFF
    cText = &H0
Else
'if MyColorType is 1 or has not been set then use windows colors
    cFace = GetSysColor(COLOR_BTNFACE)
    cShadow = GetSysColor(COLOR_BTNSHADOW)
    cLight = GetSysColor(COLOR_BTNLIGHT)
    cDarkShadow = GetSysColor(COLOR_BTNDKSHADOW)
    cHighLight = GetSysColor(COLOR_BTNHIGHLIGHT)
    cText = ForeC                                              'GetSysColor(COLOR_BTNTEXT)

End If
End Sub

Private Sub MakeRegion()
'this function creates the regions to "cut" the UserControl
'so it will be transparent in certain areas

Dim rgn1 As Long, rgn2 As Long
    
    DeleteObject rgnNorm
    rgnNorm = CreateRectRgn(0, 0, Wi, He)
    rgn2 = CreateRectRgn(0, 0, 0, 0)
    
Select Case MyButtonType

    Case 1, 2, 3 'Windows XP and Mac
        rgn1 = CreateRectRgn(0, 0, 2, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, He, 2, He - 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, 0, Wi - 2, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, He, Wi - 2, He - 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, 1, 1, 2)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, He - 1, 1, He - 2)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, 1, Wi - 1, 2)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, He - 1, Wi - 1, He - 2)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1

End Select

DeleteObject rgn2
End Sub

Private Sub SetAccessKeys()
'设置访问键

Dim ampersandPos As Long

If Len(m_Caption) > 1 Then
    ampersandPos = InStr(1, m_Caption, "&", vbTextCompare)
    If (ampersandPos < Len(m_Caption)) And (ampersandPos > 0) Then
        If Mid(m_Caption, ampersandPos + 1, 1) <> "&" Then 'if text is sonething like && then no access key should be assigned, so continue searching
            UserControl.AccessKeys = LCase(Mid(m_Caption, ampersandPos + 1, 1))
        Else 'do only a second pass to find another ampersand character
            ampersandPos = InStr(ampersandPos + 2, m_Caption, "&", vbTextCompare)
            If Mid(m_Caption, ampersandPos + 1, 1) <> "&" Then
                UserControl.AccessKeys = LCase(Mid(m_Caption, ampersandPos + 1, 1))
            Else
                UserControl.AccessKeys = ""
            End If
        End If
    Else
        UserControl.AccessKeys = ""
    End If
Else
    UserControl.AccessKeys = ""
End If
End Sub

Private Function ShiftColor(ByVal Color As Long, ByVal Value As Long, Optional isXP As Boolean = False) As Long
'this function will add or remove a certain color
'quantity and return the result

Dim Red As Long, Blue As Long, Green As Long

If isXP = False Then
    Blue = ((Color \ &H10000) Mod &H100) + Value
Else
    Blue = ((Color \ &H10000) Mod &H100)
    Blue = Blue + ((Blue * Value) \ &HC0)
End If
Green = ((Color \ &H100) Mod &H100) + Value
Red = (Color And &HFF) + Value
    
    'check red
    If Red < 0 Then
        Red = 0
    ElseIf Red > 255 Then
        Red = 255
    End If
    'check green
    If Green < 0 Then
        Green = 0
    ElseIf Green > 255 Then
        Green = 255
    End If
    'check blue
    If Blue < 0 Then
        Blue = 0
    ElseIf Blue > 255 Then
        Blue = 255
    End If

ShiftColor = RGB(Red, Green, Blue)
End Function
Private Function ShiftColorCustom(ByVal Color As Long, ByVal Rcl As Long, ByVal Gcl As Long, ByVal Bcl As Long, ByVal Color1 As Long) As Long
Dim Red As Long, Blue As Long, Green As Long
Dim Red1 As Long, Blue1 As Long, Green1 As Long
'If isOnly = True Then
   Blue = ((Color \ &H10000) Mod &H100) + Bcl
   Green = ((Color \ &H100) Mod &H100) + Gcl
   Red = (Color And &HFF) + Rcl
   Blue1 = ((Color1 \ &H10000) Mod &H100)
   Green1 = ((Color1 \ &H100) Mod &H100)
   Red1 = (Color1 And &HFF)
    'check red
    If Red < 0 Then
        Red = 0
    ElseIf Red > Red1 Then
        Red = Red1
    End If
    'check green
    If Green < 0 Then
        Green = 0
    ElseIf Green > Green1 Then
        Green = Green1
    End If
    'check blue
    If Blue < 0 Then
        Blue = 0
    ElseIf Blue > Blue1 Then
        Blue = Blue1
    End If
'Else
    
'End If
ShiftColorCustom = RGB(Red, Green, Blue)
End Function



'**************************************************************************
'     timer事件处理鼠标移出
'＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Private Sub Timer1_Timer()
    Dim pnt As POINTAPI
    GetCursorPos pnt
    ScreenToClient UserControl.HWnd, pnt

    If pnt.X < UserControl.ScaleLeft Or _
       pnt.Y < UserControl.ScaleTop Or _
       pnt.X > (UserControl.ScaleLeft + UserControl.ScaleWidth) Or _
       pnt.Y > (UserControl.ScaleTop + UserControl.ScaleHeight) Then
       
        Timer1.Enabled = False
        RaiseEvent MouseOut
        disyellowrect = False
        Call Redraw(0, True)
    End If
End Sub