ucverywellsstatusbarxp.ctl

显示XP效果的状态栏程序.希望能和大家一起学习

    Next i
    flgRedrawEnabled = True
    
    On Error GoTo 0

    Exit Sub


error_handler:

    MsgBox "Error [" + Err.Description + "] in 'UserControl_WriteProperties()', Modul 'ucVeryWellsStatusBarXP'", _
            vbExclamation, " Fehler "
    flgRedrawEnabled = True
    
End Sub

Private Sub UserControl_Resize()

    DrawStatusBar
    
End Sub

Private Sub GetPanelPictureSize(Index As Long, X As Long, Y As Long)
    
    If m_Panels(Index).PanelPicture Is Nothing Then
            
        Exit Sub
    End If
    
    With UserControl
        X = .ScaleX(m_Panels(Index).PanelPicture.Width, vbHimetric, .ScaleMode)
        Y = .ScaleY(m_Panels(Index).PanelPicture.Height, vbHimetric, .ScaleMode)
    End With
    
End Sub

Private Sub SizeByGripper(ByVal iHwnd As Long)
  
  ReleaseCapture
  SendMessage iHwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0

End Sub


Private Sub DrawTheText(DestDC As Long, sText As String, iTextLength As Long, rc As RECT, DTF As DrawTextFlags)
    
    DrawText DestDC, sText, iTextLength, rc, DTF

End Sub


Private Sub DrawVertGradient(lFromColor As Long, _
                                lToColor As Long, _
                                start_x As Long, _
                                wid As Long, _
                                start_y As Long, _
                                end_y As Long)
                                
    ' Fast draw gradient vertical lines
    
    Const PS_SOLID = 0
    
    Dim hgt             As Single
    Dim R               As Single
    Dim G               As Single
    Dim B               As Single
    Dim dR              As Single
    Dim dg              As Single
    Dim db              As Single
    Dim Y               As Single
    Dim end_r           As Single
    Dim end_g           As Single
    Dim end_b           As Single
    Dim lRight          As Long
    Dim bArray(1 To 4)  As Byte
    Dim pt              As POINTAPI
    Dim hPen            As Long
    Dim hPen1           As Long
    Dim dstDC           As Long
    
    Dim lOld            As Long
    
    lFromColor = OleToColor(lFromColor)
    CopyMemory bArray(1), lFromColor, 4
    R = bArray(1)
    G = bArray(2)
    B = bArray(3)
    
    lToColor = OleToColor(lToColor)
    CopyMemory bArray(1), lToColor, 4
    end_r = bArray(1)
    end_g = bArray(2)
    end_b = bArray(3)

    hgt = end_y - start_y
    If hgt = 0 Then
        hgt = 1
    End If
    
    dR = (end_r - R) / hgt
    dg = (end_g - G) / hgt
    db = (end_b - B) / hgt
    
    lRight = start_x + wid
    
    dstDC = UserControl.hDC
    
    With UserControl
        lOld = .ForeColor
        For Y = start_y To end_y
            .ForeColor = RGB(R, G, B)
            
            MoveToEx dstDC, start_x, Y, pt
            LineTo dstDC, lRight, Y
            
            R = R + dR
            G = G + dg
            B = B + db
    
        Next Y
        .ForeColor = lOld
    End With
    
End Sub


Private Function OleToColor(ByVal OleColor As OLE_COLOR) As Long

    If (OleColor And &H80000000) Then
        OleToColor = GetSysColor(OleColor And &HFF&)
    Else
        OleToColor = OleColor
    End If
        
End Function


Private Sub PaintTransparentPicture(ByVal hDCDest As Long, _
                                    ByVal picSource As Picture, _
                                    ByVal xDest As Long, _
                                    ByVal yDest As Long, _
                                    ByVal Width As Long, _
                                    ByVal Height As Long, _
                                    Optional ByVal xSrc As Long = 0, _
                                    Optional ByVal ySrc As Long = 0, _
                                    Optional ByVal clrMask As OLE_COLOR = 16711935, _
                                    Optional ByVal hPal As Long = 0)
                                    

    ' Purpose:  Draws a transparent bitmap to a DC.  The pixels of the passed
    '           bitmap that match the passed mask color will not be painted
    '           to the destination DC
    ' In:
    '   [hdcDest]
    '           Device context to paint the picture on
    '   [xDest]
    '           X coordinate of the upper left corner of the area that the
    '           picture is to be painted on. (in pixels)
    '   [yDest]
    '           Y coordinate of the upper left corner of the area that the
    '           picture is to be painted on. (in pixels)
    '   [Width]
    '           Width of picture area to paint in pixels.  Note: If this value
    '           is outrageous (i.e.: you passed a forms ScaleWidth in twips
    '           instead of the pictures' width in pixels), this procedure will
    '           attempt to create bitmaps that require outrageous
    '           amounts of memory.
    '   [Height]
    '           Height of picture area to paint in pixels.  Note: If this
    '           value is outrageous (i.e.: you passed a forms ScaleHeight in
    '           twips instead of the pictures' height in pixels), this
    '           procedure will attempt to create bitmaps that require
    '           outrageous amounts of memory.
    '   [picSource]
    '           Standard Picture object to be used as the image source
    '   [xSrc]
    '           X coordinate of the upper left corner of the area in the picture
    '           to use as the source. (in pixels)
    '           Ignored if picSource is an Icon.
    '   [ySrc]
    '           Y coordinate of the upper left corner of the area in the picture
    '           to use as the source. (in pixels)
    '           Ignored if picSource is an Icon.
    '   [clrMask]
    '           Color of pixels to be masked out
    '   [hPal]
    '           Handle of palette to select into the memory DC's used to create
    '           the painting effect.
    '           If not provided, a HalfTone palette is used.


    Dim hdcSrc          As Long         'hDC that the source bitmap is selected into
    Dim hbmMemSrcOld    As Long
    Dim hbmMemSrc       As Long
    Dim udtRect         As RECT
    Dim hbrMask         As Long
    Dim lMaskColor      As Long
    Dim hDCScreen       As Long
    Dim hPalOld         As Long
    
    
    ' Verify that the passed picture is a Bitmap
    If picSource Is Nothing Then
        
        Exit Sub
    End If

    If picSource.Type = vbPicTypeBitmap Then
        'Create halftone palette
        hDCScreen = GetDC(0&)
        m_hpalHalftone = CreateHalftonePalette(hDCScreen)
        ' Validate palette
        If hPal = 0 Then
            hPal = m_hpalHalftone
        End If
        hdcSrc = CreateCompatibleDC(hDCScreen)
        
        ' Select passed picture into an hDC
        hbmMemSrcOld = SelectObject(hdcSrc, picSource.handle)
        hPalOld = SelectPalette(hdcSrc, hPal, True)
        RealizePalette hdcSrc
        ' Draw the bitmap
        PaintTransparentDC hDCDest, xDest, yDest, Width, Height, hdcSrc, xSrc, ySrc, clrMask, hPal
        SelectObject hdcSrc, hbmMemSrcOld
    
        ' Clean up
        SelectPalette hdcSrc, hPalOld, True
        RealizePalette hdcSrc
        DeleteDC hdcSrc
        ReleaseDC 0&, hDCScreen
        DeleteObject m_hpalHalftone
    End If
        
End Sub

Private Sub PaintTransparentDC(ByVal hDCDest As Long, _
                                    ByVal xDest As Long, _
                                    ByVal yDest As Long, _
                                    ByVal Width As Long, _
                                    ByVal Height As Long, _
                                    ByVal hdcSrc As Long, _
                                    Optional ByVal xSrc As Long = 0, _
                                    Optional ByVal ySrc As Long = 0, _
                                    Optional ByVal clrMask As OLE_COLOR = 16711935, _
                                    Optional ByVal hPal As Long = 0)
                                    
                                    
    ' Purpose:  Draws a transparent bitmap to a DC.  The pixels of the passed
    '           bitmap that match the passed mask color will not be painted
    '           to the destination DC
    '
    ' Called by:    PaintTransparentPicture()
    '
    ' In:
    '   [hdcDest]
    '           Device context to paint the picture on
    '   [xDest]
    '           X coordinate of the upper left corner of the area that the
    '           picture is to be painted on. (in pixels)
    '   [yDest]
    '           Y coordinate of the upper left corner of the area that the
    '           picture is to be painted on. (in pixels)
    '   [Width]
    '           Width of picture area to paint in pixels.  Note: If this value
    '           is outrageous (i.e.: you passed a forms ScaleWidth in twips
    '           instead of the pictures' width in pixels), this procedure will
    '           attempt to create bitmaps that require outrageous
    '           amounts of memory.
    '   [Height]
    '           Height of picture area to paint in pixels.  Note: If this
    '           value is outrageous (i.e.: you passed a forms ScaleHeight in
    '           twips instead of the pictures' height in pixels), this
    '           procedure will attempt to create bitmaps that require
    '           outrageous amounts of memory.
    '   [hdcSrc]
    '           Device context that contains the source picture
    '   [xSrc]
    '           X coordinate of the upper left corner of the area in the picture
    '           to use as the source. (in pixels)
    '   [ySrc]
    '           Y coordinate of the upper left corner of the area in the picture
    '           to use as the source. (in pixels)
    '   [clrMask]
    '           Color of pixels to be masked out
    '   [hPal]
    '           Handle of palette to select into the memory DC's used to create
    '           the painting effect.
    '           If not provided, a HalfTone palette is used.
                                    
                                    
                                    
    Dim hdcMask         As Long     ' hDC of the created mask image
    Dim hdcColor        As Long     ' hDC of the created color image
    Dim hbmMask         As Long     ' Bitmap handle to the mask image
    Dim hbmColor        As Long     ' Bitmap handle to the color image
    Dim hbmColorOld     As Long
    Dim hbmMaskOld      As Long
    Dim hPalOld         As Long
    Dim hDCScreen       As Long
    Dim hdcScnBuffer    As Long     ' Buffer to do all work on
    Dim hbmScnBuffer    As Long
    Dim hbmScnBufferOld As Long
    Dim hPalBufferOld   As Long
    Dim lMaskColor      As Long
    
    
    hDCScreen = GetDC(0&)
    ' Validate palette
    If hPal = 0 Then
        hPal = m_hpalHalftone
    End If
    OleTranslateColor clrMask, hPal, lMaskColor
    
    ' Create a color bitmap to server as a copy of the destination
    ' Do all work on this bitmap and then copy it back over the destination when it's done.
    hbmScnBuffer = CreateCompatibleBitmap(hDCScreen, Width, Height)
    ' Create DC for screen buffer
    hdcScnBuffer = CreateCompatibleDC(hDCScreen)
    hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
    hPalBufferOld = SelectPalette(hdcScnBuffer, hPal, True)
    RealizePalette hdcScnBuffer
    ' Copy the destination to the screen buffer
    BitBlt hdcScnBuffer, 0, 0, Width, Height, hDCDest, xDest, yDest, vbSrcCopy
    
    ' Create a (color) bitmap for the cover (can't use CompatibleBitmap with
    ' hdcSrc, because this will create a DIB section if the original bitmap is a DIB section)
    hbmColor = CreateCompatibleBitmap(hDCScreen, Width, Height)
    ' Now create a monochrome bitmap for the mask
    hbmMask = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
    ' First, blt the source bitmap onto the cover.  We do this first
    ' and then use it instead of the source bitmap
    ' because the source bitmap may be
    ' a DIB section, which behaves differently than a bitmap.
    ' (Specifically, copying from a DIB section to a monochrome bitmap
    ' does a nearest-color selection rather than painting based on the
    ' backcolor and forecolor.
    hdcColor = CreateCompatibleDC(hDCScreen)
    hbmColorOld = SelectObject(hdcColor, hbmColor)
    hPalOld = SelectPalette(hdcColor, hPal, True)
    RealizePalette hdcColor
    ' In case hdcSrc contains a monochrome bitmap, we must set the destination
    ' foreground/background colors according to those currently set in hdcSrc
    ' (because Windows will associate these colors with the two monochrome colors)
    SetBkColor hdcColor, GetBkColor(hdcSrc)
    SetTextColor hdcColor, GetTextColor(hdcSrc)
    BitBlt hdcColor, 0, 0, Width, Height, hdcSrc, xSrc, ySrc, vbSrcCopy
    ' Paint the mask.  What we want is white at the transparent color
    ' from the source, and black everywhere else.
    hdcMask = CreateCompatibleDC(hDCScreen)
    hbmMaskOld = SelectObject(hdcMask, hbmMask)

    ' When bitblt'ing from color to monochrome, Windows sets t