usercontrol1.ctl

瑞星2007版升级起子VB源代码

'======================================================================

'======================================================================
'CONVERTION FUNCTION
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