xppbr.ctl

VB 设计的排课管理系统,轻松解决排课难的问题！

Private Function GetRGBColors(Color As Long) As RGB

Dim HexColor As String
        
    HexColor = String(6 - Len(Hex(Color)), "0") & Hex(Color)
    GetRGBColors.R = "&H" & Mid(HexColor, 5, 2) & "00"
    GetRGBColors.G = "&H" & Mid(HexColor, 3, 2) & "00"
    GetRGBColors.B = "&H" & Mid(HexColor, 1, 2) & "00"
End Function
'======================================================================

'======================================================================
'DRAWS A BORDER RECTANGLE AREA OF AN SPECIFIED COLOR
Private Sub DrawRectangle(ByRef BRect As RECT, ByVal Color As Long, ByVal HDC As Long)

Dim hBrush As Long
    
    hBrush = CreateSolidBrush(Color)
    FrameRect HDC, BRect, hBrush
    DeleteObject hBrush

End Sub
'======================================================================

'======================================================================
'BLENDS AN SPECIFIED COLOR TO GET XP COLOR LOOK
Private Function ShiftColorXP(ByVal MyColor As Long, ByVal Base As Long) As Long

    Dim R As Long, G As Long, B As Long, Delta As Long

    R = (MyColor And &HFF)
    G = ((MyColor \ &H100) Mod &H100)
    B = ((MyColor \ &H10000) Mod &H100)
    
    Delta = &HFF - Base

    B = Base + B * Delta \ &HFF
    G = Base + G * Delta \ &HFF
    R = Base + R * Delta \ &HFF

    If R > 255 Then R = 255
    If G > 255 Then G = 255
    If B > 255 Then B = 255

    ShiftColorXP = R + 256& * G + 65536 * B

End Function
'======================================================================

'======================================================================
'DRAWS A 2 COLOR GRADIENT AREA WITH A PREDEFINED DIRECTION
Private Sub DrawGradient( _
           ByVal cHdc As Long, _
           ByVal X As Long, _
           ByVal Y As Long, _
           ByVal X2 As Long, _
           ByVal Y2 As Long, _
           ByRef Color1 As RGB, _
           ByRef Color2 As RGB, _
           Optional Direction = 1)

    Dim Vert(1) As TRIVERTEX
    Dim gRect   As GRADIENT_RECT
   
    With Vert(0)
        .X = X
        .Y = Y
        .Red = Color1.R
        .Green = Color1.G
        .Blue = Color1.B
        .Alpha = 0&
    End With

    With Vert(1)
        .X = Vert(0).X + X2
        .Y = Vert(0).Y + Y2
        .Red = Color2.R
        .Green = Color2.G
        .Blue = Color2.B
        .Alpha = 0&
    End With

    gRect.UPPERLEFT = 1
    gRect.LOWERRIGHT = 0

    GradientFillRect cHdc, Vert(0), 2, gRect, 1, Direction

End Sub
'======================================================================

'======================================================================
'DRAWS A FILL RECTANGLE AREA OF AN SPECIFIED COLOR
Private Sub DrawFillRectangle(ByRef hRect As RECT, ByVal Color As Long, ByVal MyHdc As Long)

Dim hBrush As Long
 
   hBrush = CreateSolidBrush(GetLngColor(Color))
   FillRect MyHdc, hRect, hBrush
   DeleteObject hBrush

End Sub
'======================================================================

'======================================================================
'ROUNDS THE SELECTED WINDOW CORNERS
Private Sub RoundCorners(ByRef RcItem As RECT, ByVal m_hWnd As Long)

Dim rgn1 As Long, rgn2 As Long, rgnNorm As Long
    
    rgnNorm = CreateRectRgn(0, 0, RcItem.Right, RcItem.Bottom)
    rgn2 = CreateRectRgn(0, 0, 0, 0)

        rgn1 = CreateRectRgn(0, 0, 2, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, RcItem.Bottom, 2, RcItem.Bottom - 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(RcItem.Right, 0, RcItem.Right - 2, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(RcItem.Right, RcItem.Bottom, RcItem.Right - 2, RcItem.Bottom - 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, RcItem.Bottom - 1, 1, RcItem.Bottom - 2)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(RcItem.Right, 1, RcItem.Right - 1, 2)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(RcItem.Right, RcItem.Bottom - 1, RcItem.Right - 1, RcItem.Bottom - 2)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        
        DeleteObject rgn1
        DeleteObject rgn2
        SetWindowRgn m_hWnd, rgnNorm, True
        DeleteObject rgnNorm
End Sub
'======================================================================

'======================================================================
'CHECKS-CREATES CORRECT DIMENSIONS OF THE TEMP DC
Private Function ThDC(Width As Long, Height As Long) As Long
   If m_ThDC = 0 Then
      If (Width > 0) And (Height > 0) Then
         pCreate Width, Height
      End If
   Else
      If Width > m_lWidth Or Height > m_lHeight Then
         pCreate Width, Height
      End If
   End If
   ThDC = m_ThDC
End Function
'======================================================================

'======================================================================
'CREATES THE TEMP DC
Private Sub pCreate(ByVal Width As Long, ByVal Height As Long)
Dim lhDCC As Long
   pDestroy
   lhDCC = CreateDC("DISPLAY", "", "", ByVal 0&)
   If Not (lhDCC = 0) Then
      m_ThDC = CreateCompatibleDC(lhDCC)
      If Not (m_ThDC = 0) Then
         m_hBmp = CreateCompatibleBitmap(lhDCC, Width, Height)
         If Not (m_hBmp = 0) Then
            m_hBmpOld = SelectObject(m_ThDC, m_hBmp)
            If Not (m_hBmpOld = 0) Then
               m_lWidth = Width
               m_lHeight = Height
               DeleteDC lhDCC
               Exit Sub
            End If
         End If
      End If
      DeleteDC lhDCC
      pDestroy
   End If
End Sub
'======================================================================

'======================================================================
'DRAWS THE TEMP DC
Public Sub pDraw( _
      ByVal HDC As Long, _
      Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, _
      Optional ByVal WidthSrc As Long = 0, Optional ByVal HeightSrc As Long = 0, _
      Optional ByVal xDst As Long = 0, Optional ByVal yDst As Long = 0 _
   )
   If WidthSrc <= 0 Then WidthSrc = m_lWidth
   If HeightSrc <= 0 Then HeightSrc = m_lHeight
   BitBlt HDC, xDst, yDst, WidthSrc, HeightSrc, m_ThDC, xSrc, ySrc, vbSrcCopy

End Sub
'======================================================================

'======================================================================
'DESTROYS THE TEMP DC
Private Sub pDestroy()
   If Not m_hBmpOld = 0 Then
      SelectObject m_ThDC, m_hBmpOld
      m_hBmpOld = 0
   End If
   If Not m_hBmp = 0 Then
      DeleteObject m_hBmp
      m_hBmp = 0
   End If
   If Not m_ThDC = 0 Then
      DeleteDC m_ThDC
      m_ThDC = 0
   End If
   m_lWidth = 0
   m_lHeight = 0
End Sub
'======================================================================


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'===========================================================================
'USER CONTROL EVENTS
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'===========================================================================

Private Sub UserControl_Initialize()
    
 
     Dim fnt As New StdFont
         fnt.Name = "Tahoma"
         fnt.Size = 8
         Set Font = fnt
    
     With UserControl
        .BackColor = vbWhite
        .ScaleMode = vbPixels
     End With
     
     '----------------------------------------------------------
     'Default Values
     HDC = UserControl.HDC
     hwnd = UserControl.hwnd
     m_Max = 100
     m_Min = 0
     m_Value = 0
     m_Orientation = ccOrientationHorizontal
     m_Scrolling = ccScrollingStandard
     m_Color = GetLngColor(vbHighlight)
     DrawProgressBar
     '----------------------------------------------------------

End Sub

Private Sub UserControl_Paint()

Dim cRect As RECT

 DrawProgressBar
 
 '-----------------------------------------------------------------------
 With UserControl
     GetClientRect .hwnd, cRect     'Round the Corners of the ProgressBar
     RoundCorners cRect, .hwnd
 End With
 '-----------------------------------------------------------------------
  
End Sub

Private Sub UserControl_Resize()
HDC = UserControl.HDC
End Sub

Private Sub UserControl_Terminate()
 pDestroy 'Destroy Temp DC
End Sub


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'===========================================================================
'USER CONTROL PROPERTIES
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'===========================================================================

Public Property Get Color() As OLE_COLOR
   Color = m_Color
End Property

Public Property Let Color(ByVal lColor As OLE_COLOR)
   m_Color = GetLngColor(lColor)
End Property

Public Property Get Font() As IFont
   Set Font = m_fnt
End Property

Public Property Set Font(ByRef fnt As IFont)
   Set m_fnt = fnt    'Defined By System but can change by user choice.(ADD Property!!)
End Property

Public Property Let Font(ByRef fnt As IFont)
   Set m_fnt = fnt
End Property

Public Property Get hwnd() As Long
   hwnd = m_hWnd
End Property

Public Property Let hwnd(ByVal chWnd As Long)
   m_hWnd = chWnd
End Property

Public Property Get HDC() As Long
   HDC = m_hDC
End Property

Public Property Let HDC(ByVal cHdc As Long)
   '=============================================
   'AntiFlick...Cleaner HDC
   m_hDC = ThDC(UserControl.ScaleWidth, UserControl.ScaleHeight)
   
   If m_hDC = 0 Then
      m_hDC = UserControl.HDC   'On Fail...Do it Normally
   Else
      m_MemDC = True
   End If
   '=============================================
End Property

Public Property Get Min() As Long
   Min = m_Min
End Property

Public Property Let Min(ByVal cMin As Long)
   m_Min = cMin
End Property

Public Property Get Max() As Long
   Max = m_Max
End Property

Public Property Let Max(ByVal cMax As Long)
   m_Max = cMax
End Property

Public Property Get Orientation() As cOrientation
   Orientation = m_Orientation
End Property

Public Property Let Orientation(ByVal cOrientation As cOrientation)
   m_Orientation = cOrientation
End Property

Public Property Get Scrolling() As cScrolling
   Scrolling = m_Scrolling
End Property

Public Property Let Scrolling(ByVal lScrolling As cScrolling)
   m_Scrolling = lScrolling
End Property

Public Property Get ShowText() As Boolean
   ShowText = m_ShowText
End Property

Public Property Let ShowText(ByVal bShowText As Boolean)
   m_ShowText = bShowText
   DrawProgressBar
End Property

Public Property Get Value() As Long
   Value = m_Value
End Property

Public Property Let Value(ByVal cValue As Long)
    m_Value = cValue
    DrawProgressBar
End Property

'=======================================================================================================================
' USERCONTROL READ PROPERTIES
'=======================================================================================================================

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

Color = PropBag.ReadProperty("Color", vbHighlight)
Max = PropBag.ReadProperty("Max", 100)
Min = PropBag.ReadProperty("Min", 0)
Orientation = PropBag.ReadProperty("Orientation", ccOrientationHorizontal)
Scrolling = PropBag.ReadProperty("Scrolling", ccScrollingStandard)
ShowText = PropBag.ReadProperty("ShowText", False)
Value = PropBag.ReadProperty("Value", 0)

End Sub

'=======================================================================================================================
' USERCONTROL WRITE PROPERTIES
'=======================================================================================================================

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
 
 Call PropBag.WriteProperty("Color", m_Color, vbHighlight)
 Call PropBag.WriteProperty("Max", m_Max, 100)
 Call PropBag.WriteProperty("Min", m_Min, 0)
 Call PropBag.WriteProperty("Orientation", m_Orientation, ccOrientationHorizontal)
 Call PropBag.WriteProperty("Scrolling", m_Scrolling, ccScrollingStandard)
 Call PropBag.WriteProperty("ShowText", m_ShowText, False)
 Call PropBag.WriteProperty("Value", m_Value, 0)

 End Sub