moddrawingxp.bas

很好一套库存管理

    Dim hOldBitmap As Long
    Dim hmemDC As Long
    hmemDC& = CreateCompatibleDC(m_hDC&)
    hOldBitmap = SelectObject(hmemDC&, hBitmap&)
    Call PatBlt(hmemDC&, 0, 0, IMGwidth, IMGheight, WHITENESS)
    If (lImageType = CI_ICON And bForceTransparency < 2) Or bForceTransparency = 2 Then
        DrawState hmemDC&, 0, 0, lImageSmall, 0, 0, 0, 0, 0, lDrawType
    Else
        MakeTransparentBitmap lImageSmall, 0, 0, IMGwidth, IMGheight, , , lMask, hmemDC
    End If
    DeleteObject lImageSmall
'  // This seems to be required.
  Dim hOldBackColor As Long
  hOldBackColor& = SetBkColor(m_hDC&, RGB(255, 255, 255))
'  // Draw using hilite offset by (1,1), then shadow
  Dim hbrShadow As Long, hbrHilite As Long
  hbrShadow& = CreateSolidBrush(GetSysColor(COLOR_BTNSHADOW))
  hbrHilite& = CreateSolidBrush(GetSysColor(COLOR_BTNHIGHLIGHT))
  
  Dim hOldBrush As Long
  hOldBrush& = SelectObject(m_hDC&, hbrHilite&)

  Call BitBlt(m_hDC&, rt.Left + 1 + iOffset, rt.Top + 1 + yOffset, IMGwidth, IMGheight, hmemDC&, 0, 0, MAGICROP)
  Call SelectObject(m_hDC&, hbrShadow&)
  Call BitBlt(m_hDC&, rt.Left + iOffset, rt.Top + yOffset, IMGwidth, IMGheight, hmemDC&, 0, 0, MAGICROP)
  
  Call SelectObject(m_hDC&, hOldBrush&)
  Call SetBkColor(m_hDC&, hOldBackColor&)
  Call SelectObject(hmemDC&, hOldBitmap&)
  Call DeleteObject(hOldBrush&)
  Call DeleteObject(hbrHilite&)
  Call DeleteObject(hbrShadow&)
  Call DeleteObject(hOldBackColor&)
  Call DeleteObject(hOldBitmap&)
  Call DeleteObject(hBitmap&)
  Call DeleteDC(hmemDC&)
End If
End Sub

Private Sub MakeTransparentBitmap(imgHdl As Long, _
               ByVal xDest As Long, _
               ByVal yDest As Long, _
               ByVal Width As Long, _
               ByVal Height As Long, _
               Optional xSrc As Long = 0, _
               Optional ByVal ySrc As Long = 0, _
               Optional clrMask As OLE_COLOR = -1, _
               Optional destDC As Long = 0)
' =====================================================================
' Borrowed and modified - creates a transparent bitmap
' =====================================================================

    Dim hdcSrc As Long
    Dim hbmMemSrcOld As Long
    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
    Const hPal As Long = 0
    
    On Error Resume Next
    hdcScreen = GetDC(0&)
    
    If destDC = 0 Then destDC = m_hDC
    hdcSrc = CreateCompatibleDC(hdcScreen)
    hbmMemSrcOld = SelectObject(hdcSrc, imgHdl)
    RealizePalette hdcSrc
    
    If clrMask < 0 Then clrMask = GetPixel(hdcSrc, 0, 0)
    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, destDC, 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 to 1
    'all pixels that match the background color of the source DC.
    'All other bits are set to 0.
    SetBkColor hdcColor, lMaskColor
    SetTextColor hdcColor, vbWhite
    BitBlt hdcMask, 0, 0, Width, Height, hdcColor, 0, 0, _
        vbSrcCopy
    'Paint the rest of the cover bitmap.
    '
    'What we want here is black at the transparent color,
    'and the original colors everywhere else.  To do this,
    'we first paint the original onto the cover (which we
    'already did), then we AND the inverse of the mask onto
    'that using the DSna ternary raster operation
    '(0x00220326 - see Win32 SDK reference, Appendix,
    '"Raster Operation Codes", "Ternary
    'Raster Operations", or search in MSDN for 00220326).
    'DSna [reverse polish] means "(not SRC) and DEST".
    '
    'When bitblt'ing from monochrome to color, Windows
    'transforms all white bits (1) to the background color
    'of the destination hdc.  All black (0)
    'bits are transformed to the foreground color.
    SetTextColor hdcColor, vbBlack
    SetBkColor hdcColor, vbWhite
    BitBlt hdcColor, 0, 0, Width, Height, hdcMask, 0, 0, DSna
    'Paint the Mask to the Screen buffer
    BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcMask, 0, 0, vbSrcAnd
    'Paint the Color to the Screen buffer
    BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcColor, 0, 0, vbSrcPaint
    'Copy the screen buffer to the screen
    BitBlt destDC, xDest, yDest, Width, Height, hdcScnBuffer, 0, 0, vbSrcCopy
    'All done!
    DeleteObject SelectObject(hdcColor, hbmColorOld)
    SelectPalette hdcColor, hPalOld, True
    RealizePalette hdcColor
    DeleteDC hdcColor
    DeleteObject SelectObject(hdcScnBuffer, hbmScnBufferOld)
    SelectPalette hdcScnBuffer, hPalBufferOld, True
    RealizePalette hdcScnBuffer
    DeleteDC hdcScnBuffer

    DeleteObject SelectObject(hdcMask, hbmMaskOld)
    DeleteDC hdcMask
    ReleaseDC 0&, hdcScreen
    
    SelectObject hdcSrc, hbmMemSrcOld
    RealizePalette hdcSrc
    DeleteDC hdcSrc
    ReleaseDC 0&, hdcScreen
    
End Sub

Public Sub SetMenuFont(bSet As Boolean, Optional hDC As Long, _
    Optional bReduced As Boolean = False, Optional otherFont As Long = 0)
' =====================================================================
'   This creates system menu fonts for the destination DC if needed
'   and either sets it or removes it from the DC
' =====================================================================

'   reference the current DC for all drawing
    If hDC Then m_hDC = hDC
    If bSet Then
        ' in order to set the font, we must first determine what it is
        If m_Font(0) = 0 And otherFont = 0 Then
            Dim ncm As NONCLIENTMETRICS, newFont As LOGFONT
            ncm.cbSize = Len(ncm)
            ' this will return the system font info along with other stuff
            SystemParametersInfo 41, 0, ncm, 0
            ' here we create a memory font based off of system menu font
            newFont = ncm.lfMenuFont
            m_Font(0) = CreateFontIndirect(newFont)
            ' now we are going to try to create a scalable font for
            ' separator bar text just in case the computer's menu font
            ' is not scalable. The following is a shortcut way of creating
            ' the font & I hope it works on all systems!
            newFont.lfFaceName = "Tahoma" & Chr$(0)
            newFont.lfCharSet = 1
            newFont.lfHeight = (7.5 * -20) / Screen.TwipsPerPixelY
            'newFont.lfHeight = newFont.lfHeight + 1
            m_Font(1) = CreateFontIndirect(newFont)
        End If
        ' add the font to the DC & keep reference to old font
        ' Calling routines responsbile for restoring original font
        ' with call back to this routine & a FALSE parameter
        If m_FontOld = 0 And otherFont = 0 Then
            m_FontOld = SelectObject(m_hDC, m_Font(Abs(CInt(bReduced))))
        Else
            If otherFont Then
                SelectObject m_hDC, otherFont
            Else
                SelectObject m_hDC, m_Font(Abs(CInt(bReduced)))
            End If
        End If
    Else
        ' Restoring old font
        If m_hDC = 0 Then Exit Sub
        SelectObject m_hDC, m_FontOld
    End If
End Sub

Public Sub DestroyMenuFont()
' =====================================================================
' Simply destroy the memory font to free up resources
' =====================================================================
    On Error Resume Next
    SelectObject m_hDC, m_FontOld
    DeleteObject m_Font(0)
    DeleteObject m_Font(1)
    m_Font(0) = 0
    m_Font(1) = 0
End Sub

Public Sub DoGradientBkg(lColor As Long, tRect As RECT, hwnd As Long)
'=======================================================================

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

Dim sColor As String, i As Integer, tmpSB As PictureBox, formID As Long
Dim R As Integer, B As Integer, G As Integer
Dim lColorStep As Long, lNewColor As Long

On Error GoTo GradientErrors
' we are going to create a picturebox to draw the gradient in
' tried drawing directly to hdc via MoveTo & LineTo APIs, but
' everytime, it failed -- maybe Win98, maybe my graphics card?
' This works though a little slower
formID = GetFormHandle(hwnd)
' create the picture box in memory
Set tmpSB = Forms(formID).Controls.Add("VB.PictureBox", "pic___tmp_s_b", Forms(formID))
With tmpSB
    ' set picturebox attributes
    .Visible = False
    .BorderStyle = 0
    .AutoRedraw = True
    .DrawMode = 13
    .DrawWidth = 1
    .Height = .ScaleY(tRect.Bottom, vbPixels, .ScaleMode)
    .Width = .ScaleX(tRect.Right, vbPixels, .ScaleMode)
    .ScaleMode = vbPixels
    lNewColor = lColor
    ' loop thru each line & color it
    For i = 1 To tRect.Bottom - 1
        ' this line is used to subtract/add colors
        ' for a more dramatic fade, increment the #2 below
        lColorStep = (2 / tRect.Bottom) * i
        ' modify the current color
        B = ((lNewColor \ &H10000) Mod &H100) - lColorStep
        G = ((lNewColor \ &H100) Mod &H100) - lColorStep
        R = (lNewColor And &HFF) - lColorStep
        ' ensure the Red, Green, Blue values are in acceptable ranges
        If R < 0 Then
            R = 0
        ElseIf R > 255 Then
            R = 255
        End If
        If G < 0 Then
            G = 0
        ElseIf G > 255 Then
            G = 255
        End If
        If B < 0 Then
            B = 0
        ElseIf B > 255 Then
            B = 255
        End If
        lNewColor = RGB(R, G, B)    ' cache the color & draw the line
        tmpSB.Line (0, i - 1)-(tRect.Right, i - 1), lNewColor, BF
    Next
    ' now that the gradient has been drawn, copy it to the menu panel
    BitBlt m_hDC, 0, 0, tRect.Right, tRect.Bottom, .hDC, 0, 0, vbSrcCopy
End With
GradientErrors:
On Error Resume Next
' clean up
Forms(formID).Controls.Remove "pic___tmp_s_b"
Set tmpSB = Nothing
End Sub

Public Sub DrawCheckMark(pRect As RECT, lColor As Long, _
    bdisabled As Boolean, Optional xtraOffset As Long = 0)
' =====================================================================
' Simple little check mark drawing, looks good 'nuf I think
' =====================================================================

Dim CurPen As Long, OldPen As Long
Dim dm As POINTAPI
Dim yOffset As Integer, xOffset As Integer
Dim x1 As Integer, X2 As Integer
Dim Y1 As Integer, Y2 As Integer

CurPen = GetPen(1, lColor)
OldPen = SelectObject(m_hDC, CurPen)

xOffset = 6 + xtraOffset
yOffset = pRect.Top + 6

' Here we are simply tracing the outline of a check box
' Created by opening a 8x8 bitmap editor and drawing a
' simple checkmark from left to right, bottom to top
MoveToEx m_hDC, 1 + xOffset, 4 + yOffset, dm
LineTo m_hDC, 2 + xOffset, 4 + yOffset
LineTo m_hDC, 2 + xOffset, 5 + yOffset
LineTo m_hDC, 3 + xOffset, 5 + yOffset
LineTo m_hDC, 3 + xOffset, 6 + yOffset
LineTo m_hDC, 4 + xOffset, 6 + yOffset
LineTo m_hDC, 4 + xOffset, 4 + yOffset
LineTo m_hDC, 5 + xOffset, 4 + yOffset
LineTo m_hDC, 5 + xOffset, 2 + yOffset
LineTo m_hDC, 6 + xOffset, 2 + yOffset
LineTo m_hDC, 6 + xOffset, 1 + yOffset
LineTo m_hDC, 7 + xOffset, 1 + yOffset
LineTo m_hDC, 7 + xOffset, 0 + yOffset

' replace original pen
SelectObject m_hDC, OldPen
DeleteObject CurPen
End Sub