gradient.bas

金算盘软件代码

      'We don't let this happen in the WM_NCPAINT message,
      'which is called more often than NCACTIVATE.
      GradientCallback = CallWindowProc(OldGradProc, hwnd, wMsg, wParam, lParam)
      'Create memory DC to draw the titlebar in.
      tmpDC = GetWindowDC(GradhWnd)
      DrawDC = CreateCompatibleDC(tmpDC)
      NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
      OldBMP = SelectObject(DrawDC, NewBMP)
      With rcWnd
         hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
         SelectClipRgn tmpDC, hRgn
         OffsetClipRgn tmpDC, -.Left, -.Top
      End With
      'Find out what color the titlebar needs
      'to be...
      If wParam And GetParent(GradhWnd) = 0 Then
         DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
      ElseIf wParam = GradhWnd And GetParent(GradhWnd) <> 0 Then
         DrawGradient 0, GetSysColor(COLOR_INACTIVECAPTION)
      ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
         DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
      Else
         DrawGradient 0, GetSysColor(COLOR_INACTIVECAPTION)
      End If
      'Cleanup
      SelectObject DrawDC, OldBMP
      DeleteObject NewBMP
      DeleteDC DrawDC
      OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
      GetClipRgn tmpDC, hRgn
      ReleaseDC GradhWnd, tmpDC
      DeleteObject hRgn
      tmpDC = 0
      Exit Function

   Case WM_NCPAINT
      'Basically same as above.
      GetWindowRect GradhWnd, rcWnd
      tmpDC = GetWindowDC(GradhWnd)
      DrawDC = CreateCompatibleDC(tmpDC)
      NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
      OldBMP = SelectObject(DrawDC, NewBMP)
      With rcWnd
         hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
         SelectClipRgn tmpDC, hRgn
         OffsetClipRgn tmpDC, -.Left, -.Top
      End With
      'Get the color to paint the caption with.
      If GetActiveWindow() = GradhWnd Then
         DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
      ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
         DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
      Else
         DrawGradient 0, GetSysColor(COLOR_INACTIVECAPTION)
      End If
      'Cleanup
      SelectObject DrawDC, OldBMP
      DeleteObject NewBMP
      DeleteDC DrawDC
      OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
      GetClipRgn tmpDC, hRgn
      'Call the old proc. This will only
      'draw the titlebar's min/max/close buttons
      'because we told it not to do the rest (this
      'eliminates flicker.
      GradientCallback = CallWindowProc(OldGradProc, hwnd, WM_NCPAINT, hRgn, lParam)
      ReleaseDC GradhWnd, tmpDC
      DeleteObject hRgn
      tmpDC = 0
      Exit Function
   Case WM_SIZE
      'Whoa, we need to paint the caption.
      If hwnd = GradhWnd Then SendMessage GradhWnd, WM_NCPAINT, 0, 0
   End Select

   GradientCallback = CallWindowProc(OldGradProc, hwnd, wMsg, wParam, lParam)
   
End Function

Public Sub GradientForm(frm As Form)

   If OldGradProc <> 0 Then Exit Sub

   GradhWnd = frm.hwnd
   GradIcon = frm.Icon
   OldGradProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf GradientCallback)
   GradientGetCapsFont

End Sub

Public Sub GradientReleaseForm()

   If OldGradProc = 0 Or GradhWnd = 0 Then Exit Sub

   SetWindowLong GradhWnd, GWL_WNDPROC, OldGradProc
   OldGradProc = 0
   GradhWnd = 0

End Sub

Private Function DrawGradient(ByVal Color1 As Long, ByVal Color2 As Long) As Long

   Dim i As Integer
   Dim DestWidth As Long, DestHeight As Long
   Dim StartPnt As Integer, EndPnt As Integer
   Dim PixelStep As Long, XBorder As Long
   Dim WndRect As RECT
   Dim OldFont As Long
   Dim fText As String
   
   On Error Resume Next
   
   GetWindowRect GradhWnd, WndRect
   With WndRect
      DestWidth = .Right - .Left
   End With

   'Get height of caption bar
   DestHeight = GetSystemMetrics(SM_CYCAPTION)
   'Get the text of the form's caption
   fText = Space$(255)
   Call GetWindowText(GradhWnd, fText, 255)
   fText = Trim$(fText)
   'Get the width of the border
   XBorder = GetSystemMetrics(SM_CXFRAME)
   'The width of the area we need to paint:
   DestWidth = DestWidth - (XBorder * 2) - (GetSystemMetrics(SM_CXSMSIZE) * 3) + 6
   'Where the painting begins:
   StartPnt = XBorder
   'Where the painting ends:
   EndPnt = XBorder + DestWidth - 4
   
   'How many steps do we need to
   'paint the titlebar?
   PixelStep = DestWidth \ 8
   ReDim Colors(PixelStep) As Long
   'Create gradient colors in the array
   GradateColors Colors(), Color1, Color2
   
   Dim rct As RECT
   Dim hBr As Long
   
   With rct
      .Top = XBorder
      .Left = XBorder
      .Right = XBorder + (DestWidth \ PixelStep)
      .Bottom = XBorder + DestHeight - 1
      For i = 0 To PixelStep - 1
         'Paint the titlebar in increments, increasing
         'the color index with each iteration.
         hBr = CreateSolidBrush(Colors(i))
         FillRect DrawDC, rct, hBr
         'Cleanup
         DeleteObject hBr
         'Prepare for the next iteration
         OffsetRect rct, (DestWidth \ PixelStep), 0
         If i = PixelStep - 2 Then .Right = EndPnt
      Next
      If GradIcon <> 0 Then 'Paint the icon
         'Move the caption text's start point over
         'to make room for the icon
         .Left = XBorder + GetSystemMetrics(SM_CXSMSIZE) + 2
         DrawIconEx DrawDC, XBorder + 1, XBorder + 1, GradIcon, GetSystemMetrics(SM_CXSMSIZE) - 2, GetSystemMetrics(SM_CYSMSIZE) - 2, ByVal 0&, ByVal 0&, 2
      Else
         'No icon
         .Left = XBorder
      End If
      'If getting the caption font failed, use the font
      'from the gradient caption form.
      If CaptionFont.lfHeight = 0 And tmpGradFont = 0 Then
         tmpGradFont = SendMessage(GradhWnd, WM_GETFONT, 0, 0)
      ElseIf tmpGradFont = 0 Then
         tmpGradFont = CreateFontIndirect(CaptionFont)
      End If
      OldFont = SelectObject(DrawDC, tmpGradFont)
      'This is like setting FontTransparent on a Form to True:
      SetBkMode DrawDC, 1
      'Use a white caption, since the background is black
      'on the left side
      SetTextColor DrawDC, RGB(255, 255, 255)
      .Left = .Left + 2
      .Right = .Right - 10
      'Draw the caption text
      DrawText DrawDC, fText, Len(fText) - 1, rct, DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_VCENTER
      'Cleanup
      SelectObject DrawDC, OldFont
      DeleteObject tmpGradFont
      tmpGradFont = 0
      
      .Left = XBorder
      .Right = .Right + 12
      If tmpDC <> 0 Then
         'Blit our work from the memory DC to the form's
         'window DC to finish the job.
          BitBlt tmpDC, .Left, .Top, .Right - .Left - 10, .Bottom - .Top, DrawDC, .Left, .Top, vbSrcCopy
         'Tell windows that we already painted most of
         'the titlebar.
         ExcludeClipRect tmpDC, XBorder, XBorder, .Right - .Left - 8, .Bottom - .Top + 4
      End If

   End With

End Function

Private Sub GradateColors(Colors() As Long, ByVal Color1 As Long, ByVal Color2 As Long)

   'Alright, I admit -- this routine was
   'taken from a VBPJ issue a few months back.

   Dim i As Integer
   Dim dblR As Double, dblG As Double, dblB As Double
   Dim addR As Double, addG As Double, addB As Double
   Dim bckR As Double, bckG As Double, bckB As Double
   
   dblR = CDbl(Color1 And &HFF)
   dblG = CDbl(Color1 And &HFF00&) / 255
   dblB = CDbl(Color1 And &HFF0000) / &HFF00&
   bckR = CDbl(Color2 And &HFF&)
   bckG = CDbl(Color2 And &HFF00&) / 255
   bckB = CDbl(Color2 And &HFF0000) / &HFF00&
   
   addR = (bckR - dblR) / UBound(Colors)
   addG = (bckG - dblG) / UBound(Colors)
   addB = (bckB - dblB) / UBound(Colors)
   
   For i = 0 To UBound(Colors)
      dblR = dblR + addR
      dblG = dblG + addG
      dblB = dblB + addB
      If dblR > 255 Then dblR = 255
      If dblG > 255 Then dblG = 255
      If dblB > 255 Then dblB = 255
      If dblR < 0 Then dblR = 0
      If dblG < 0 Then dblG = 0
      If dblG < 0 Then dblB = 0
      Colors(i) = RGB(dblR, dblG, dblB)
   Next

End Sub

Public Sub GradientGetCapsFont()

   'Tries to retrieve the Windows caption font
   'in the current Appearance scheme. Doesn't
   'seem to work all the time, so if anyone knows
   'why I'd appreciate being told.
   
   Dim NCM As NONCLIENTMETRICS
   Dim lfNew As LOGFONT
   
   NCM.cbSize = Len(NCM)
   Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, NCM, 0)
   
   If NCM.iCaptionHeight = 0 Then
      CaptionFont.lfHeight = 0
   Else
      CaptionFont = NCM.lfCaptionFont
   End If

End Sub