xpframe.ctl

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

VERSION 5.00
Begin VB.UserControl WwXpFrame 
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BackColor       =   &H80000005&
   ClientHeight    =   3285
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4650
   ControlContainer=   -1  'True
   ScaleHeight     =   219
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   310
End
Attribute VB_Name = "WwXpFrame"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Type TRIVERTEX
    X                   As Long
    Y                   As Long
    Red                 As Integer
    Green               As Integer
    Blue                As Integer
    Alpha               As Integer
End Type

Private Type GRADIENT_RECT
    UpperLeft           As Long
    LowerRight          As Long
End Type
Private Declare Function GradientFill Lib "Msimg32.dll" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
'Private Const DT_LEFT = &H0
Private Const DT_CENTERABS = &H65                    'CENTERABS= &H65
Const DT_WORDBREAK = &H10
Const DT_CENTER = &H1

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Const RGN_DIFF = 4

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long

Public Enum FrameTypes
    [Windows Standard] = 1
    [XpFrame] = 2
    [Custom] = 3
End Enum

Public Enum XpFrameTypes
    [银色风格] = 1
    [翠色风格] = 2
    [蓝色风格] = 3
End Enum
Public Enum GradientDirectionEnum
    [Fill_None] = 0
    [Fill_Horizontal] = 1
'    [Fill_HorizontalMiddleOut] = 2
    [Fill_Vertical] = 2 '3
'    [Fill_VerticalMiddleOut] = 4

End Enum

Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_BTNDKSHADOW = 21
Private Const COLOR_BTNLIGHT = 22


'variables
Private MyFrameType As FrameTypes

Private MyXpFrameType As XpFrameTypes

Private He As Long
Private Wi As Long
'Dim allcount As Integer                       'caption字节总数
Private BackC As Long 'back color
Private ForeC As Long 'fore color
Private m_hWnd As Long
Private m_Caption As String     'current caption  变量
Private TextFont As StdFont 'current font

Private rc As RECT

Private LastButton As Byte        '
Private isEnabled As Boolean

Private cFace As Long, cText As Long

Private Te As String  '        保存状态，消除不必要的重画
Private TextHeight As Long                      '文字高度
Private TextWidth As Long                       '文字宽度
Dim rgbcolor As Long                            'Frame的圆角矩形的颜色
Dim m_FrameColor As Long                            'Frame的圆角矩形的颜色
Private m_GradientDirection As GradientDirectionEnum
Dim m_Caption3D As Boolean                          'caption 以3D 风格显示标志
'Private m_GradientBKColor As Boolean
Private m_BKEndColor As OLE_COLOR

Private Const GRADIENT_FILL_RECT_H      As Long = 0
Private Const GRADIENT_FILL_RECT_V      As Long = 1
'缺省属性值:
Const m_def_Caption3D = False
'Const m_def_GradientBKColor = False
Const m_def_Enabled = True
Const m_def_hWnd = 0
Const m_def_FrameType = [XpFrame]
Const m_def_XpFrameType = [银色风格]
Const m_def_GradientDirection = 0 ' [Fill_None]
Const m_def_Caption = "WwXpFrame"
Const m_def_BackColor = vbWhite
Const m_def_FrameColor = &HBFB8BF
Const m_def_BKEndColor = &HF1CBB1

'属性变量:
'Dim m_hWnd As Long
'事件声明:

Event Click()
Event DblClick()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,0
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
'Dim cP As New cPropPick
 
    BackC = New_BackColor
    Call SetColors
    Call Redraw(True)
    PropertyChanged "BackColor"
End Property
Public Property Get BackColor() As OLE_COLOR
    BackColor = BackC
End Property



'***********************************************************************************
'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,0
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = ForeC
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    ForeC = New_ForeColor
    Call SetColors
    Call Redraw(True)
    PropertyChanged "ForeColor"
End Property
Public Property Get FrameColor() As OLE_COLOR
    FrameColor = m_FrameColor
End Property

Public Property Let FrameColor(ByVal New_FrameColor As OLE_COLOR)
    m_FrameColor = New_FrameColor
    Call SetColors
    Call Redraw(True)
    PropertyChanged "FrameColor"
End Property

'**********************************************************************************
'**************************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get Enabled() As Boolean
    Enabled = isEnabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    isEnabled = New_Enabled
    Call SetColors
    Call Redraw(True)                                            '####(0, True)
    UserControl.Enabled = isEnabled
    PropertyChanged "Enabled"
End Property
Public Property Get Caption3D() As Boolean
    Caption3D = m_Caption3D
End Property

Public Property Let Caption3D(ByVal New_Caption3D As Boolean)
    m_Caption3D = New_Caption3D
    Call Redraw(True)
    PropertyChanged "Caption3D"
End Property
Public Property Get BKEndColor() As OLE_COLOR
    BKEndColor = m_BKEndColor
End Property

Public Property Let BKEndColor(ByVal New_BKEndColor As OLE_COLOR)
    m_BKEndColor = New_BKEndColor
    Call SetColors
    Call Redraw(True)
    PropertyChanged "BKEndColor"
End Property
'********************************************************************************

'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=6,0,0,0
Public Property Get Font() As StdFont
    Set Font = TextFont
End Property

Public Property Set Font(ByVal New_Font As StdFont)
With TextFont
      .Bold = New_Font.Bold
      .Italic = New_Font.Italic
      .Name = New_Font.Name
      .Size = New_Font.Size
End With
    Set TextFont = New_Font
    Set UserControl.Font = TextFont
    Call Redraw(True)                                          '####(0, True)
    PropertyChanged "Font"
End Property

'*********************************************************************************
Private Sub UserControl_Initialize()
Call SetColors

End Sub
'**********************************************************************************
'************************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get hwnd() As Long
    hwnd = m_hWnd
End Property
'
Public Property Let hwnd(ByVal New_hWnd As Long)
    If Ambient.UserMode = False Then Err.Raise 387