gradform.pas

动态提示控件

          LogoRect.Left, CurrentLogo.Height, CurrentLogo.Canvas.Handle, 0, 0,
          SRCCOPY);

        // Now draw the caption stuff that needs a gradient:
        // caption buttons if logo is left-aligned, or icon
        // if logo is right-aligned.
        if LogoAlign <> laLeft then
        begin
          if ((biSystemMenu in BorderIcons) and
             (BorderStyle in [bsSingle, bsSizeable])) or
             (csDesigning in ComponentState) then
          // PaintMenuIcon will adjust the rect so that future drawing operations
          // happen in the right spot.
          PaintMenuIcon(DFS_HDC(BmpDC), R, Active);
        end
        else  // LogoAlign = laRight
          PaintCaptionButtons(DFS_HDC(BmpDC), R);

        if not LogoLayered then
          IntersectRect(R, R, GradientRect);

        // Done drawing the gradient, icon, caption buttons, and logo.
      end
      else
      begin
        if ((biSystemMenu in BorderIcons) and
           (BorderStyle in [bsSingle, bsSizeable])) or
           (csDesigning in ComponentState) then
          // PaintMenuIcon will adjust the rect so that future drawing operations
          // happen in the right spot.
          PaintMenuIcon(DFS_HDC(BmpDC), R, Active);

        PaintCaptionButtons(DFS_HDC(BmpDC), R); // Paint the min/max/help/close buttons.
      end;
    end;
    if assigned(FOnCaptionPaint) then
    begin
      BmpCanvas := TCanvas.Create;
      try
        BmpCanvas.Handle := BmpDC;
//        BmpCanvas.Font.handle := FCaptionFont.handle;
        BmpCanvas.Font := FCaptionFont;

        FOnCaptionPaint(Self, BmpCanvas, R);
      finally
        BmpCanvas.Free;
      end;
    end;
    PaintCaptionText(DFS_HDC(BmpDC), R, Active); // Paint the caption text.
    // Copy the gradient caption bar to the real DC.
    BitBlt(HDC(FormDC), Result.Left, Result.Top, W, H, BmpDC, 0, 0, SRCCOPY);
  finally
    // Clean up all the temporary drawing objects.
    SelectObject(BmpDC, OldBmp);
    DeleteObject(Bmp);
    DeleteDC(BmpDC);
  end;
end;

// Windows sends this message when the window has been activated or deactivated.
procedure TdfsGradientForm.WMNCActivate(var Msg: TWMNCActivate);
begin
  if not InhibitGradient then
  begin
    Msg.Result := 1;
    // I can't remember what the "bad things" were, and I can't find any problems
    // now if I don't call it.... If some new bug shows up, this is the first
    // place to look. 
{    if FormStyle in [fsMDIForm, fsMDIChild] then
      inherited; { Call inherited or bad things will happen with MDI }
    Draw(Msg.Active);
  end else
    inherited;
end;

// Windows sends this message whenever any part of the non-client area
// (caption, window border) needs repainting.
procedure TdfsGradientForm.WMNCPaint(var Msg: TMessage);
var
{$IFDEF DFS_COMPILER_4_UP}
  SaveWR, CR,
{$ENDIF}
  WR, R: TRect;
  DC: HDC;
  MyRgn: HRGN;
  DeleteRgn: boolean;
begin
  if not InhibitGradient then
  begin
    DeleteRgn := FALSE;
    // The region that needs painting is passed in WParam.  A region is a Windows
    // object used to describe the non-rectangular area used by a combination of
    // rectangles.  We have to typecast it because in Delphi 4 wParam is signed
    // and HRGN in unsigned.  It worked prior to D4 because they were both
    // signed.
    MyRgn := HRGN(Msg.wParam);
    DC := GetWindowDC(Handle);
    try
      GetWindowRect(Handle, WR);
      // Select the update region as the clipping region.  Clipping regions
      // guarantee that any painting done outside of the selected region is not
      // shown (thrown away).
      if SelectClipRgn(DC, MyRgn) = ERROR then
      begin
        // We got passed an invalid region.  Generally, this happens when the
        // window is first created or a MDI is minimized.  We'll create our own
        // region (the rectangle that makes up the entire window) and use that
        // instead.
        with WR do
          MyRgn := CreateRectRgn(Left, Top, Right, Bottom);
        SelectClipRgn(DC, MyRgn);
        DeleteRgn := TRUE;
      end;
      // Convert the clipping region coordinates from screen to client.
      OffsetClipRgn(DC, -WR.Left, -WR.Top);
      // Draw our gradient caption.
      R := DrawCaption(DFS_HDC(DC), IsActiveWindow);
      // Here's the trick.  DrawCaption returns the rectangle that we painted.
      // We now exclude that rectangle from the clipping region.  This guarantees
      // that any further painting that occurs will not happen in this rectangle.
      // That means that when we let the default painting for WM_NCPAINT occur,
      // it will not paint over our gradient. It only paints the stuff that we
      // didn't, like the window borders.
      ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);

{$IFDEF DFS_COMPILER_4_UP}
      // Draw border if needed
      if BorderWidth > 0 then
      begin
        Windows.GetClientRect(Handle, CR);
        SaveWR := WR;
        MapWindowPoints(0, Handle, WR, 2);
        OffsetRect(CR, -WR.Left, -WR.Top);
        { Draw borders in non-client area }
        InflateRect(CR, BorderWidth, BorderWidth);
        WR := SaveWR;
        OffsetRect(WR, -WR.Left, -WR.Top);
        Windows.FillRect(DC, WR, Brush.Handle);
        WR := SaveWR;
      end;
{$ENDIF}

      // Convert coordinates back into screen-based.
      OffsetClipRgn(DC, WR.Left, WR.Top);
      // Get the region that is now described by the clipping region.
      GetClipRgn(DC, MyRgn);
      // Pass that region on to the default WM_NCPAINT handler.  Remember, we
      // excluded the rectangle that we painted, so Windows will not be able to
      // paint over what we did. Most gradient captions components just let
      // windows draw its stuff first, and then paint the gradient.  This results
      // in an irritating "flicker", caused by the area being painted normally,
      // and then painted over a second time by the gradient. We have to
      // typecast the wParam parameter because in Delphi 4 wParam is signed and
      // HRGN in unsigned.  It worked prior to D4 because they were both signed.
      Msg.Result := DefWindowProc(Handle, Msg.Msg, WPARAM(MyRgn), Msg.lParam);
    finally
      // If we had to create our own region, we have to clean it up.
      if DeleteRgn then
        DeleteObject(MyRgn);
      ReleaseDC(Handle, DC); // NEVER leave this hanging.
    end;
  end else
    inherited;
end;

// Windows sends this message if the user changes any of the system colors.
procedure TdfsGradientForm.WMSysColorChange(var Msg: TWMSysColorChange);
var
  x: integer;
begin
  // Did they change to 16-color mode?
  FSystemIs16Color := GetSystemColorBitDepth = 4;

  if not InhibitGradient then
  begin
    if FUsingDefaultGradientStopColor then
      FGradientStopColor := clActiveCaption;
    if FUsingDefaultGradientInactiveStopColor then
      FGradientInactiveStopColor := clInactiveCaption;
    CalculateColors;
    // This only goes to top-level windows so we have to feed it to MDI children
    if FormStyle = fsMDIForm then
    begin
      for x := 0 to MDIChildCount-1 do
        if MDIChildren[x] is TdfsGradientForm then
          TdfsGradientForm(MDIChildren[x]).WMSysColorChange(Msg);
    end;
  end;
  inherited;
end;

// The window has been resized.
procedure TdfsGradientForm.WMSize(var Msg: TWMSize);
begin
  inherited;
  if not InhibitGradient then
  begin
    // If the window was maximized or restored, we need to redraw so the right
    // caption button is painted.
    if (Msg.SizeType = SIZE_MAXIMIZED) or (Msg.SizeType = SIZE_RESTORED) then
      Draw(IsActiveWindow);
  end;
end;

// Windows would like to have a cursor displayed.  I know, you're wondering
// why the hell I care about this, aren't you?  Well, in the inherited handling
//  (default Windows processing) of this message, if the mouse is over a
// resizeable border section, Windows repaints the caption buttons.  Why?  I
// have absolutely no idea.  However, that's not the important part.  When it
// repaints those buttons, it also repaints the background around them in the
// last color it painted the caption in.  Now, usually this would just result
// in losing a few bands of the caption gradient, which 99.44% of all users
// would never notice.  However, because we don't always allow default
// processing of WM_NCACTIVATE, sometimes Windows doesn't have the right idea
// about which color is currently the background.  This cause the background to
// get painted in the wrong color sometimes, which 99.44% of all users *will*
// notice.  We fix it by setting the appropriate cursor and not allowing the
// default processing to occur.
procedure TdfsGradientForm.WMSetCursor(var Msg: TWMSetCursor);
begin
  if not InhibitGradient then
  begin
    // Tell Windows we handled the message
    Msg.Result := 1;
    // Load and display the correct cursor for the border area being hit
    case Msg.HitTest of
      HTTOP,
      HTBOTTOM:      SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENS)));
      HTLEFT,
      HTRIGHT:       SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZEWE)));
      HTTOPRIGHT,
      HTBOTTOMLEFT:  SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENESW)));
      HTTOPLEFT,
      HTBOTTOMRIGHT: SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENWSE)));
    else
      // Wasn't anything we cared about, so tell Windows we didn't handle it.
      Msg.Result := 0;
      inherited;
    end;
  end else
    inherited;
end;


procedure TdfsGradientForm.WMSetText(var Msg: TWMSetText);
var
  FlagSet: boolean;
  Wnd: HWND;
begin
  if (not InhibitGradient) then
  begin
    Wnd := 0;
    if ((FormStyle = fsMDIChild) and (WindowState = wsMaximized)) then
    begin
      // Need to cause main form's caption to be redrawn, not the MDI child.
      if Application.MainForm.HandleAllocated then
        Wnd := Application.MainForm.Handle;
    end else begin
      if HandleAllocated then
        Wnd := Handle;
    end;

    if (Wnd <> 0) and IsWindowVisible(Wnd) then
    begin
      FlagSet := TRUE;
      // No update region for the window.  changes won't be painted.
      SetWindowRgn(Wnd, CreateRectRgn(0, 0, 0, 0), FALSE);
    end else
      FlagSet := FALSE;

    // Normally, processing WM_SETTEXT would cause all sorts of flicker as it
    // changed the caption text of the window.  But, we've told it that the
    // update region for the window (the portion it is allowed to paint in) is
    // a NULL region (a rectangle equal to 0, 0, 0, 0).  So, the changes don't
    // have anywhere to paint now, so it is safe to call inherited at this
    // point.  After that, we'll restore the window region so that painting
    // can happen again.
    inherited;

    if FlagSet then
      // Reset region to normal.
      SetWindowRgn(Wnd, 0, FALSE);

    // Don't do it if it was called from .SetCaption
    if not EntrancyFlag then
      Caption := Msg.Text;
  end else
    inherited;
end;

procedure TdfsGradientForm.WMGetText(var Msg: TWMGetText);
begin
  if not InhibitGradient then
  begin
    StrLCopy(Msg.Text, PChar(FCaptionText), Msg.TextMax-1);
    Msg.Result := StrLen(Msg.Text)+1;
  end else
    inherited;
end;

procedure TdfsGradientForm.WMGetTextLength(var Msg: TWMGetTextLength);
begin
  if not InhibitGradient then
  begin
    Msg.Result := Length(FCaptionText);
  end else
    inherited;
end;

procedure TdfsGradientForm.WMSettingChange(var Msg: TMessage);
begin
  if not InhibitGradient then
  begin
    // User might have changed NC font.
    if Msg.wParam = SPI_SETNONCLIENTMETRICS then
      UpdateCaptionFont;
//**      CreateCaptionFontHandle;
  end;
  inherited;
end;

{: This procedure is used to paint the caption gradient.  It is normally
   called internally, but it can be used any time a repaint of the caption
   is needed. The <B>Active</B> parameter is used to indicate whether the
   caption should be painted as the active window or an inactive window. }
procedure TdfsGradientForm.Draw(Active: boolean);
var
  DC: HDC;
begin
  if csDestroying in ComponentState then exit;
  
  // Get the DC we need to paint in.  GetDC would only get the DC for the
  // client area, we need it for non-client area, too, so we use GetWindowDC.
  DC := GetWindowDC(Handle);
  try
    DrawCaption(DFS_HDC(DC), Active);
  finally
    ReleaseDC(Handle,