xp_progressbar.ctl

主要功能：接收和发送短信

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

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

'======================================================================
'DRAWS A 2 COLOR GRADIENT AREA WITH A PREDEFINED DIRECTION
Public Sub DrawGradient(lEndColor As Long, lStartcolor As Long, ByVal X As Long, ByVal Y As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal hdc As Long, Optional bH As Boolean)
    On Error Resume Next
    
    ''Draw a Vertical Gradient in the current HDC
    Dim sR As Single, sG As Single, sB As Single
    Dim eR As Single, eG As Single, eB As Single
    Dim ni As Long
    
    lEndColor = GetLngColor(lEndColor)
    lStartcolor = GetLngColor(lStartcolor)

    sR = (lStartcolor And &HFF)
    sG = (lStartcolor \ &H100) And &HFF
    sB = (lStartcolor And &HFF0000) / &H10000
    eR = (lEndColor And &HFF)
    eG = (lEndColor \ &H100) And &HFF
    eB = (lEndColor And &HFF0000) / &H10000
    sR = (sR - eR) / IIf(bH, X2, Y2)
    sG = (sG - eG) / IIf(bH, X2, Y2)
    sB = (sB - eB) / IIf(bH, X2, Y2)
    
        
    For ni = 0 To IIf(bH, X2, Y2)
        
        If bH Then
            DrawLine X + ni, Y, X + ni, Y2, hdc, RGB(eR + (ni * sR), eG + (ni * sG), eB + (ni * sB))
        Else
            DrawLine X, Y + ni, X2, Y + ni, hdc, RGB(eR + (ni * sR), eG + (ni * sG), eB + (ni * sB))
        End If
        
    Next ni
End Sub
'======================================================================

'======================================================================
'BLENDS 2 COLORS WITH A PREDEFINED ALPHA VALUE
Private Function BlendColor(ByVal oColorFrom As OLE_COLOR, ByVal oColorTo As OLE_COLOR, Optional ByVal Alpha As Long = 128) As Long
Dim lCFrom As Long
Dim lCTo As Long
Dim lSrcR As Long
Dim lSrcG As Long
Dim lSrcB As Long
Dim lDstR As Long
Dim lDstG As Long
Dim lDstB As Long
   
   lCFrom = GetLngColor(oColorFrom)
   lCTo = GetLngColor(oColorTo)
   
   lSrcR = lCFrom And &HFF
   lSrcG = (lCFrom And &HFF00&) \ &H100&
   lSrcB = (lCFrom And &HFF0000) \ &H10000
   lDstR = lCTo And &HFF
   lDstG = (lCTo And &HFF00&) \ &H100&
   lDstB = (lCTo And &HFF0000) \ &H10000
   
   BlendColor = RGB( _
      ((lSrcR * Alpha) / 255) + ((lDstR * (255 - Alpha)) / 255), _
      ((lSrcG * Alpha) / 255) + ((lDstG * (255 - Alpha)) / 255), _
      ((lSrcB * Alpha) / 255) + ((lDstB * (255 - Alpha)) / 255) _
      )
      
End Function
'======================================================================

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

'======================================================================
'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()
 DrawProgressBar
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 Let BrushStyle(ByVal Style As BrushStyle)
   m_Brush = Style
End Property

Public Property Get Color() As OLE_COLOR
Attribute Color.VB_Description = "Returns/sets the color of the ProgressBar"
   Color = m_Color
End Property

Public Property Let Color(ByVal lColor As OLE_COLOR)
   m_Color = GetLngColor(lColor)
   DrawProgressBar
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 Image() As StdPicture
    If Nothing Is m_Picture Then Exit Property
    Set Image = m_Picture
End Property

Public Property Set Image(ByVal handle As StdPicture)
   Set m_Picture = handle
   PropertyChanged "Image"
   DrawProgressBar
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
   DrawProgressBar
End Property

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

Public Property Let Scrolling(ByVal lScrolling As cScrolling)
   m_Scrolling = lScrolling
   DrawProgressBar
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 / 100) * m_Max
End Property

Public Property Let Value(ByVal cValue As Long)
    m_Value = (cValue * 100) / m_Max
    DrawProgressBar
End Property

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

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim BrushStyle
BrushStyle = PropBag.ReadProperty("BrushStyle", 4)
Color = PropBag.ReadProperty("Color", vbHighlight)
Set m_Picture = PropBag.ReadProperty("Image", Nothing)
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("BrushStyle", m_Brush, 4)
 Call PropBag.WriteProperty("Color", m_Color, vbHighlight)
 Call PropBag.WriteProperty("Image", m_Picture, Nothing)
 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