xpframe.ctl

磁盘FAT扇区数据读写操作 Ver 1.20(更新版)

                        DrawRectangle 1, 7, Wi - 1, He - 7, vbWhite, True
                        DrawRectangle 0, 6, Wi - 1, He - 7, RGB(128, 128, 128), True
                        mSetPixel Wi - 1, 6, vbWhite
                        mSetPixel 0, He - 1, vbWhite
                     Else
                        DrawRectangle 1, TextHeight \ 2 + 3, Wi - 1, He - TextHeight \ 2 - 3, vbWhite, True
                        DrawRectangle 0, TextHeight \ 2 + 2, Wi - 1, He - TextHeight \ 2 - 3, RGB(128, 128, 128), True
                        mSetPixel Wi - 1, TextHeight \ 2 + 2, vbWhite
                        mSetPixel 0, He - 1, vbWhite
                        DrawRectangle 8, 1, TextWidth + 2, TextHeight, cFace
                        rc.Left = 10: rc.Top = 3: rc.Right = TextWidth + 12: rc.Bottom = TextHeight + 3
                        SetTextColor .hdc, vbWhite
                        DrawText .hdc, m_Caption, -1, rc, DT_CENTERABS
                        rc.Left = 9: rc.Top = 2: rc.Right = TextWidth + 11: rc.Bottom = TextHeight + 2
                        SetTextColor .hdc, RGB(128, 128, 128)
                        DrawText .hdc, m_Caption, -1, rc, DT_CENTERABS
                     End If
                Case 2, 3
                     rc.Left = 8: rc.Top = 3: rc.Right = TextWidth + 10: rc.Bottom = TextHeight + 3
                     SetTextColor .hdc, RGB(180, 180, 180)
                     DrawText .hdc, m_Caption, -1, rc, DT_CENTERABS
         
                     rgbcolor = RGB(128, 128, 128)
                     DrawLine 0, TextHeight \ 2 + 4, 0, He - 2, rgbcolor          '画左线
                     DrawCorner 0, 0, 1, 1, rgbcolor                     '画左上角
                     DrawLine 2, TextHeight \ 2 + 2, 8, TextHeight \ 2 + 2, rgbcolor '画上线左
                     DrawLine TextWidth + 8, TextHeight \ 2 + 2, Wi - 2, TextHeight \ 2 + 2, rgbcolor '画上线右
                     DrawCorner Wi - 4, -1, 1, -1, rgbcolor             '画右上角
                     DrawLine Wi - 1, TextHeight \ 2 + 4, Wi - 1, He - 2, rgbcolor        '画右线
                     DrawCorner Wi - 4, He - TextHeight \ 2 - 5, 1, 1, rgbcolor             '画右下角
                     DrawLine Wi - 3, He - 1, 1, He - 1, rgbcolor               '画下线
                     DrawCorner 0, He - TextHeight \ 2 - 6, 1, -1, rgbcolor                 '画左下角
        End Select
End If
End With

End Sub

Private Sub DrawRectangle(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As Long, Optional OnlyBorder As Boolean = False)

Dim bRect As RECT
Dim hBrush As Long
Dim ret As Long

bRect.Left = X
bRect.Top = Y
bRect.Right = X + Width
bRect.Bottom = Y + Height

hBrush = CreateSolidBrush(Color)

If OnlyBorder = False Then
    ret = FillRect(UserControl.hdc, bRect, hBrush)
Else
    ret = FrameRect(UserControl.hdc, bRect, hBrush)
End If

ret = DeleteObject(hBrush)
End Sub

Private Sub DrawLine(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As Long)
Dim pt As POINTAPI

  UserControl.ForeColor = Color
  MoveToEx UserControl.hdc, X1, Y1, pt
  LineTo UserControl.hdc, X2, Y2

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 DrawCorner(ByVal iX As Long, ByVal iY As Long, ByVal iWay_x As Long, ByVal iWay_y As Long, ByVal Color As Long)
Dim i As Long
Dim ii As Long
       For ii = 0 To 1
           For i = 0 To 1  '画圆角
               mSetPixel 1 + iX + iWay_x * ii, iY + TextHeight \ 2 + 3 + i - iWay_y * ii, Color 'RGB(79, 97, 135)
           Next
        Next
End Sub
Private Sub SetColors()

If MyFrameType = [Windows Standard] Then
    cFace = BackC               'GetSysColor(COLOR_BTNFACE)
    cText = ForeC
ElseIf MyFrameType = [Custom] Then
     cFace = BackC
     cText = ForeC
     rgbcolor = m_FrameColor
'    cFace = &HC0C0C0
'    cText = &H0
Else
       cText = ForeC                                              'GetSysColor(COLOR_BTNTEXT)
        If MyXpFrameType = [银色风格] Then
               cFace = BackC
               rgbcolor = RGB(191, 184, 191)
                
        ElseIf MyXpFrameType = [翠色风格] Or MyXpFrameType = [蓝色风格] Then
                 cFace = BackC
                 rgbcolor = RGB(209, 208, 190)
        Else
                 cFace = vbWhite
                 rgbcolor = RGB(191, 184, 191)
        End If

End If
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) 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


    Blue = ((Color \ &H10000) Mod &H100) + Value
    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 Sub FillGradient(ByVal hdc As Long, _
                         ByVal X As Long, _
                         ByVal Y As Long, _
                         ByVal Width As Long, _
                         ByVal Height As Long, _
                         ByVal Col1 As Long, _
                         ByVal Col2 As Long, _
                         ByVal GradientDirection As GradientDirectionEnum)
                         
Dim tmpCol  As Long
  
    ' Exit if needed
    If GradientDirection = Fill_None Then Exit Sub
    
    
    Select Case GradientDirection       '渐变方向
'        Case Fill_HorizontalMiddleOut
'             DrawGradient hDC, X, Y, X + Width / 2, Y + Height, Col1, Col2, False
'             DrawGradient hDC, X + Width / 2 - 1, Y, X + Width, Y + Height, Col2, Col1, False
'        Case Fill_VerticalMiddleOut
'             DrawGradient hDC, X, Y, X + Width, Y + Height / 2, Col1, Col2, True
'             DrawGradient hDC, X, Y + Height / 2 - 1, X + Width, Y + Height, Col2, Col1, True
        Case Fill_Horizontal
             DrawGradient hdc, X, Y, X + Width, Y + Height, Col1, Col2, False
        Case Fill_Vertical
             DrawGradient hdc, X, Y, X + Width, Y + Height, Col1, Col2, True
    End Select
    
End Sub
Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                               Optional hPal As Long = 0) As Long

    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = -1
    End If

End Function
'---绘渐变色子过程
Private Sub DrawGradient( _
                        ByVal m_MemoryDC As Long, _
                        ByVal LeftX As Long, _
                        ByVal TopY As Long, _
                        ByVal RightX As Long, _
                        ByVal BottomY As Long, _
                        ByVal clrFirst As OLE_COLOR, _
                        ByVal clrSecond As OLE_COLOR, _
                        Optional ByVal bVertical As Boolean)

  Dim pVert(0 To 1)   As TRIVERTEX
  Dim clr             As OLE_COLOR
  Dim pGradRect       As GRADIENT_RECT

    clr = TranslateColor(clrFirst)
    'clr = clrFirst
    With pVert(0)
        .X = LeftX
        .Y = TopY
        .Red = pvRed(clr)
        .Green = pvGreen(clr)
        .Blue = pvBlue(clr)
    End With
    clr = TranslateColor(clrSecond)
    'clr = clrSecond
    With pVert(1)
        .X = RightX
        .Y = BottomY
        .Red = pvRed(clr)
        .Green = pvGreen(clr)
        .Blue = pvBlue(clr)
    End With
    With pGradRect
        .UpperLeft = 0
        .LowerRight = 1
    End With
    GradientFill m_MemoryDC, pVert(0), 2, pGradRect, 1, _
                 IIf(Not bVertical, GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V)

End Sub
Private Function pvBlue(ByVal clr As OLE_COLOR) As Long

    pvBlue = ((clr \ &H10000) And &HFF) * &H100&
    If pvBlue >= &H8000& Then
        pvBlue = pvBlue - &H10000
    End If

End Function
Private Function pvGreen(ByVal clr As OLE_COLOR) As Long

    pvGreen = ((clr \ &H100) And &HFF) * &H100&
    If pvGreen >= &H8000& Then
        pvGreen = pvGreen - &H10000
    End If

End Function
Private Function pvRed(ByVal clr As OLE_COLOR) As Long

    pvRed = ((clr \ &H1) And &HFF) * &H100&
    If pvRed >= &H8000& Then
        pvRed = pvRed - &H10000
    End If

End Function