modsubclasser.bas

AeroSuite--一组非常漂亮的VISTA控件集

        LoWord = DWord And &HFFFF&
     End If
End Function

Public Function HiWord(DWord As Long) As Long
' =====================================================================
' function to return the HiWord of a Long value
' =====================================================================
     HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

Public Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long
' =====================================================================
' function combines 2 Integers into a Long value
' =====================================================================
     MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

Public Sub TempDrawBorders(hDC As Long, wRgn As Long, cRgn As Long)

Const BDR_RAISEDINNER As Long = &H4
Const BDR_RAISEDOUTER As Long = &H1
Const BDR_SUNKENINNER As Long = &H8
Const BDR_SUNKENOUTER As Long = &H2

Const BF_MIDDLE As Long = &H800
Const BF_LEFT As Long = &H1
Const BF_TOP As Long = &H2
Const BF_RIGHT As Long = &H4
Const BF_BOTTOM As Long = &H8

Dim eRect As RECT
Dim edgeRgn As Long


GetRgnBox wRgn, eRect
edgeRgn = CreateRectRgnIndirect(eRect) '  copy the overall window region

OffsetRgn edgeRgn, -eRect.Left, -eRect.Top  ' offset to 0,0
'OffsetRgn cRgn, -eRect.Left, -eRect.Top     ' offset client area to 0,0

CombineRgn edgeRgn, edgeRgn, cRgn, 4   ' exclude the client region

' use it for clipping region to prevent painting over client area
SelectClipRgn hDC, edgeRgn
DeleteObject edgeRgn

' draw the rectangular borders
OffsetRect eRect, -eRect.Left, -eRect.Top
DrawEdge hDC, eRect, BDR_RAISEDINNER Or BDR_RAISEDOUTER, BF_BOTTOM Or BF_LEFT Or BF_RIGHT Or BF_TOP Or BF_MIDDLE

SelectClipRgn hDC, 0
'DeleteObject cRgn

End Sub


Public Function ResizeBitmap(cDC As Long, hBmp As Long, _
        newCx As Long, newCy As Long, _
        selectInto As Long, bResized As Boolean) As Long
        
Dim bmpInfo As BITMAP

If hBmp Then GetGDIObject hBmp, Len(bmpInfo), bmpInfo
If bmpInfo.bmHeight <> newCy Or bmpInfo.bmWidth <> newCx Then
    If hBmp Then DeleteObject hBmp
    hBmp = CreateCompatibleBitmap(cDC, newCx, newCy)
    bResized = True
End If
If selectInto Then ResizeBitmap = SelectObject(selectInto, hBmp)
End Function


Public Function ConvertVBSysColor(inColor As Long) As Long
' converts a vbSystemColor variable to a long color variable

' I've never seen the GetSysColor API return an error, but just in case...
On Error GoTo ExitRoutine
If inColor < 0 Then
    ConvertVBSysColor = GetSysColor(inColor And &HFF&)
Else
    ConvertVBSysColor = inColor
End If
ExitRoutine:
End Function

Public Sub GradientFill(ByVal FromColor As Long, ByVal ToColor As Long, _
    hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal Cx As Long, Cy As Long, _
    Optional ByVal Roughness As Byte)

' FromColor :: any valid RGB color or system color (i.e vbActiveTitleBar)
' ToColor :: any valid RGB color or system color (i.e vbInactiveTitleBar)
' hDC :: the DC to draw gradient on
' X :: left edge of gradient rectangle
' Y :: top edge of gradient rectangle
' to determine direction of gradient, pass Cx and/or Cy as follows
' Left>Right :: Cx is positive and right edge of gradient rectangle (i.e., Right)
' Right>Left :: Cx is negative and right edge of gradient rectangle (i.e., -Right)
' Bottom>Top :: Cy is negative and bottom edge of gradient rectangle (i.e., -Bottom)
' Top>Bottom :: Cx is negative & Cy is negative (i.e., -Right & -Bottom)
' Roughness :: 0=fine detail, 1-4 is lesser quality for larger rectangles
'               determines line thickness of 1,3,5,7 or 9

Dim bColor(0 To 3) As Byte, eColor(0 To 3) As Byte

'convert values like vbButtonFace to a proper RGB value
FromColor = ConvertVBSysColor(FromColor)
ToColor = ConvertVBSysColor(ToColor)

' quick easy way to convert long to RGB values
CopyMemory bColor(0), FromColor, &H3
CopyMemory eColor(0), ToColor, &H3

Dim lPtIncr As Long ' counter in positive values only
Dim lPenSize As Long ' size of drawing pen
Dim lWxHx As Long   ' adjusted width/height of gradient rectangle
Dim lPoint As Long  ' loop variables
Dim lPtStart As Long, lPtEnd As Long, lPtStep As Long
' values to add/subtracted from RGB to show next gradient color
Dim ratioRed As Single, ratioGreen As Single, ratioBlue As Single
' memory DC variables
Dim hPen As Long, hOldPen As Long

' set a maximum value. I think CreatePen API tends to max out around 10
' This value will help determine the line width/size
If Roughness > 4 Then Roughness = 4
' ensure an odd number; even number sizes may not step right in a loop
Roughness = Roughness * 2 + 1

' Setup the loop variables
If Cy < 0 Then ' vertical
    If Cx < 0 Then ' vertical top to bottom
        lPtStart = Y
        lPtEnd = Abs(Cy)
        lPtStep = Roughness
    Else            ' vertical bottom to top
        lPtStart = Abs(Cy)
        lPtEnd = Y
        lPtStep = -Roughness
    End If
Else        ' horizontal
    If Cx < 0 Then ' horizontal right to left
        lPtStep = -Roughness
        lPtStart = Abs(Cx)
        lPtEnd = X
    Else                ' horizontal left to right
        lPtStep = Roughness
        lPtStart = X
        lPtEnd = Cx
    End If
End If

' calculate the width & add a buffer of 1 to prevent RGB overflow possibility
lWxHx = Abs(lPtEnd - lPtStart) + 1
' ensure we can draw at least a minimum amount of lines
If lWxHx < Roughness Then
    ' if not, make the step value either +1 or -1 depending on current pos/neg sign
    lPtStep = lPtStep / Abs(lPtStep)
Else
' tweak to prevent situation where last line may not be drawn
' To combat this, we simply add an extra loop
    lPtEnd = lPtEnd - lPtStep * (Abs(lPtStep) > 1)
End If

' calculate color step value
ratioRed = ((eColor(0) + 0 - bColor(0)) / lWxHx)
ratioGreen = ((eColor(1) + 0 - bColor(1)) / lWxHx)
ratioBlue = ((eColor(2) + 0 - bColor(2)) / lWxHx)

' cache vs using the ABS function in the loop -- less calculations
Cx = Abs(Cx)
lPenSize = Abs(lPtStep)

' It is faster to have 2 separate loops (1 for vertical & 1 for horizontal)
' than to use one loop and put an IF statement in there to identify
' direction of drawing. Difference could be 100's of "IFs" processed.

' select the first color; then enter loop.
hOldPen = SelectObject(hDC, CreatePen(0, lPenSize, FromColor))

' these loops are pretty much identical with the only big difference
' of shifting X,Y coords to draw a vertical line or a horizontal line
If Cy < 0 Then  ' vertical loop
    For lPoint = lPtStart To lPtEnd Step lPtStep
        MoveToEx hDC, X, lPoint, ByVal 0&
        LineTo hDC, Cx, lPoint
        DeleteObject SelectObject(hDC, CreatePen(0, lPenSize, RGB( _
            bColor(0) + lPtIncr * ratioRed, _
            bColor(1) + lPtIncr * ratioGreen, _
            bColor(2) + lPtIncr * ratioBlue)))
        lPtIncr = lPtIncr + lPenSize
    Next
Else        ' horizontal loop
    For lPoint = lPtStart To lPtEnd Step lPtStep
        MoveToEx hDC, lPoint, Y, ByVal 0&
        LineTo hDC, lPoint, Cy
        DeleteObject SelectObject(hDC, CreatePen(0, lPenSize, RGB( _
            bColor(0) + lPtIncr * ratioRed, _
            bColor(1) + lPtIncr * ratioGreen, _
            bColor(2) + lPtIncr * ratioBlue)))
        lPtIncr = lPtIncr + lPenSize
    Next
End If
' destroy the last pen created & replace with original DC pen
DeleteObject SelectObject(hDC, hOldPen)

End Sub

Public Function IsArrayEmpty(ByVal lArrayPointer As Long) As Boolean
  ' test to see if an array has been initialized
  ' Cannot be used on variants
  IsArrayEmpty = (lArrayPointer = -1)
End Function