mmform.pas

一套及时通讯的原码

    DrawFrameControl(DC, SrcRect, DFC_CAPTION, Flag);
    OffsetRect(SrcRect, -BtnWidth, 0);
    Dec(Rect.Right,BtnWidth);
  end;

   { Minimize button }
  if biMinimize in BI then
  begin
    if IsIconic(HookWnd)
      then Flag := DFCS_CAPTIONRESTORE
      else Flag := DFCS_CAPTIONMIN;

     { if it doesn't have min in style, then it shows up disabled }
    if Style and WS_MINIMIZEBOX = 0 then
      Flag := Flag or DFCS_INACTIVE;

    DrawFrameControl(DC, SrcRect, DFC_CAPTION, Flag);
    OffsetRect(SrcRect, -BtnWidth, 0);
    Dec(Rect.Right,BtnWidth);
  end;

   { Help button }
  if (biHelp in BI) then
  begin
    DrawFrameControl(DC, SrcRect, DFC_CAPTION, DFCS_CAPTIONHELP);
    Dec(Rect.Right,BtnWidth);
  end;
  Dec(Rect.Right, 3);
{$ENDIF}
end;

{-- TMMFormStyler -------------------------------------------------------------}
function TMMFormStyler.MeasureText(DC: HDC; R: TRect; Text: TMMCompanyText): integer;
var
  OldFont: HFont;
  P: ^string;
  S: String;
begin
   { Select in the required font for this text. }
   if Text.FFont.Handle <> 0 then
      OldFont := SelectObject(DC, Text.FFont.Handle)
   else
      OldFont := 0;
   try     { Measure the text making it left aligned, centered vertically, allowing no line breaks. }
      S := Text.FCaption + #0;
      P := @S[1];
      DrawText(DC, PChar(P), -1, R, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);
      Result := R.Right + WordSpacing - R.Left {-1};
   finally
      { Clean up all the drawing objects. }
      if OldFont <> 0 then SelectObject(DC, OldFont);
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
function TMMFormStyler.DrawCaption(Active: Boolean): TRect;
var
   DC,OrigDC     : HDC;
   rcText        : TRect;
   rcCaption     : TRect;
   rgbColorLeft  : TColor;
   rgbColorRight : TColor;
   rgbColorPlain : TColor;
   OldBmp        : HBitmap;
   Bmp           : HBitmap;
   TotalTextWidth: longint;
   SpaceForCompanyText : Boolean;
   SpaceForAppNameText : Boolean;
   NumColors     : longint;
   Shaded        : Boolean;

begin
   Result := Rect(0,0,0,0);
{$IFNDEF BUILD_ACTIVEX}
   if ((OwnerForm.BorderStyle = bsNone) and (not (csdesigning in ComponentState))) then
{$ELSE}
   if GetWindowLong(HookWnd, GWL_STYLE) and WS_BORDER = 0 then
{$ENDIF}
        exit;

   OrigDC := GetWindowDC(HookWnd);
   if OrigDC = 0 then exit;

   DC := CreateCompatibleDC(OrigDC);
   if DC = 0 then
   begin
      ReleaseDC(HookWnd, OrigDC);
      exit;
   end;

   rcText := GetTextRect;
   rcCaption := GetTextRect;
   if NewStyleControls then rcCaption := GetTitleBarRect;

   Bmp := CreateCompatibleBitmap(OrigDC, rcCaption.Right, rcCaption.Bottom);
   if Bmp = 0 then
   begin
      ReleaseDC(HookWnd, OrigDC);
      DeleteDC(DC);
      exit;
   end;
   OldBmp := SelectObject(DC, Bmp);
   try
      Result := rcCaption;

      if Active then
         rgbColorPlain := ColorToRGB(clActiveCaption)
      else
         rgbColorPlain := ColorToRGB(clInActiveCaption);

      if Active then
         rgbColorRight := ColorToRGB(ClrRightActive)
      else
         rgbColorRight := ColorToRGB(ClrRightInactive);

      if Active then
         rgbColorLeft  := ColorToRGB(ClrLeftActive)
      else
         rgbColorLeft  := ColorToRGB(ClrLeftInactive);

      case FOptions of
          goAlways : Shaded := True;
          goNever  : Shaded := False;
          goActive : Shaded := Active;
          goSmart  :
          begin
             NumColors := GetDeviceCaps(DC, BITSPIXEL);
             if Active then
                Shaded := NumColors >= 8
             else
                Shaded := NumColors > 8;
          end;
          else Shaded := False;
      end;

      if NewStyleControls then
      begin
         if Shaded then
            FillSolid(DC, rgbColorRight, rcCaption)
         else
            FillSolid(DC, rgbColorPlain, rcCaption);
      end;

      if Shaded then
         FillGradient(DC, rgbColorLeft, rgbColorRight, FNumColors, rcText)
      else
         FillSolid(DC, rgbColorPlain, rcText);

{$IFNDEF BUILD_ACTIVEX}
      if NewStyleControls then
         if (((biSystemMenu in OwnerForm.BorderIcons) and
             (OwnerForm.BorderStyle in [bsSingle, bsSizeable])) or
             (csDesigning in ComponentState)) then
{$ELSE}
      if NewStyleControls then
         if (GetWindowLong(HookWnd, GWL_STYLE) and WS_SYSMENU <> 0) and
            (GetWindowLong(HookWnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then
{$ENDIF}
            PaintMenuIcon(DC, rcText);

      if NewStyleControls then
         PaintCaptionButtons(DC, rcCaption);

      {------------------------------------------------------------------------}
      {Determine if there is sufficient space for the CompanyName text and the }
      {CompanyName text and the standard caption text to be all drawn onto the }
      {working Bitmap (i.e. the caption).  If not, is there enough room for    }
      {the AppName text and the standard caption?                              }
      {------------------------------------------------------------------------}
      FCaptionText.FCaption := FCaptionText.Caption; { safety - catches MDI changes }

      TotalTextWidth := MeasureText(DC,rcText,FCompanyText)*Ord(FCompanyText.Visible)
                                    + MeasureText(dc,rcText,FAppNameText) * ord(FAppNameText.Visible)
                                    + MeasureText(dc,rcText,FCaptionText) * ord(FCaptionText.Visible);

      SpaceForCompanyText := (TotalTextWidth < (rcText.Right - rcText.Left));

      if SpaceForCompanyText then
         SpaceForAppNameText := True { space for company ==> space for appname }
      else
      begin
         TotalTextWidth := MeasureText(DC,rcText,FAppNameText) * ord(FAppNameText.Visible)
                                       + MeasureText(dc,rcText,FCaptionText) * ord(FCaptionText.Visible);
         SpaceForAppNameText := (TotalTextWidth < (rcText.Right - rcText.Left));
      end;

      if not SpaceForAppNameText then
         TotalTextWidth := MeasureText(DC,rcText,FCaptionText);

      case FAlignment of
        taLeftJustify  : { do nothing at all - it is already setup for this default };
        taCenter       : if (TotalTextWidth < rcText.right - rcText.left) then
                             rcText.Left := rcText.left + ((rcText.right - rcText.left - TotalTextWidth) div 2);
        taRightJustify : if (TotalTextWidth < rcText.right - rcText.left) then
                             rcText.Left := rcText.left + (rcText.right - rcText.left - TotalTextWidth);
      end;

      {------------------------------------------------------------------------}
      { Actually draw the CompanyText, AppNameText, and CaptionText.           }
      {------------------------------------------------------------------------}
      if (SpaceForCompanyText and (FCompanyText.FCaption <> '') and (FCompanyText.FVisible)) then
          PaintCaptionText(DC, rcText, FCompanyText, Active);

      if ((SpaceForAppNameText) and (FAppNameText.FCaption <> '') and (FAppNameText.FVisible)) then
           PaintCaptionText(DC, rcText, FAppNameText, Active);

      { Truncate the window caption text, until it will fit into the caption bar.}
      if FCaptionText.FVisible then
         PaintCaptionText(DC, rcText, FCaptionText, Active);

      { copy from temp DC, onto the actual window Caption }
      BitBlt(OrigDC, Result.Left, Result.Top, Result.Right-Result.Left,
                     Result.Bottom-Result.Top,
             DC, Result.Left, Result.Top, SRCCOPY);

   finally
      { Clean up device context & free memory}{ Release the working bitmap resources }
      Bmp := SelectObject(DC, OldBmp);
      DeleteObject(Bmp);
      DeleteDC(DC);
      ReleaseDC(HookWnd, OrigDC);
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.SetAutoFontHeight(Font: TFont);
var
   FTextHeight    : longint;
   FSysTextHeight : longint;
   FTextMetrics   : TTextMetric;
   FSysTextMetrics: TTextMetric;
   WrkBMP         : TBitmap;

begin
   WrkBmp := TBitmap.Create;
   try
      WrkBmp.Width := 10;
      WrkBmp.Height := 10;
      WrkBMP.Canvas.Font.Assign(Font);
      GetTextMetrics(WrkBmp.Canvas.Handle, FTextMetrics);
      WrkBMP.Canvas.Font.Assign(FSystemFont);
      GetTextMetrics(WrkBmp.Canvas.Handle, FSysTextMetrics);
      FTextHeight := FTextMetrics.tmHeight - FTextMetrics.tmInternalLeading;
      FSysTextHeight := FSysTextMetrics.tmHeight - FSysTextMetrics.tmInternalLeading;
      Font.Height:= Font.Height + FTextHeight - FSysTextHeight;
      WrkBMP.Canvas.Font.Assign(Font);
      GetTextMetrics(WrkBmp.Canvas.Handle, FTextMetrics);
      FTextHeight := FTextMetrics.tmHeight - FTextMetrics.tmInternalLeading;
      if (FTextHeight > FSysTextHeight) then
          Font.Height := Font.Height + FTextHeight - FSysTextHeight;
   finally
       Wrkbmp.Free;
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.SetColors(index: integer; aValue: TColor);
begin
   case index of
       0: if (aValue = FClrLeftActive) then exit else FClrLeftActive := aValue;
       1: if (aValue = FClrLeftInActive) then exit else FClrLeftInActive := aValue;
       2: if (aValue = FClrRightActive) then exit else FClrRightActive := aValue;
       3: if (aValue = FClrRightInActive) then exit else FClrRightInActive := aValue;
   end;
   if csDesigning in ComponentState then UpdateCaption;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.SetOptions(aValue: TMMGradientOptions);
begin
   if (aValue <> FOptions) then
   begin
      FOptions := aValue;
      if csDesigning in ComponentState then UpdateCaption;
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.SetAlignment(aValue: TAlignment);
begin
   if (aValue <> FAlignment) then
   begin
      FAlignment := aValue;
      if csDesigning in ComponentState then UpdateCaption;
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.SetNumColors(aValue: TMMGradientColors);
begin
   if (aValue <> FNumColors) then
   begin
      FNumColors := aValue;
      if csDesigning in ComponentState then UpdateCaption;
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
function TMMFormStyler.HandleWMSetCursor(var Msg: TWMSetCursor): Boolean;
begin
   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
     begin
        Msg.Result := 0;
        inherited;
     end;
   end;
   Result := (Msg.Result = 1);
end;

{$IFDEF BUILD_ACTIVEX}
procedure TMMFormStyler.HookOwner;
var
  Styler: TMMFormStyler;
begin
  if Enabled and not (csDestroying in ComponentState) then
  begin
    Styler := FindStylerForWindow(HookWnd);
    if (Styler <> Self) and (Styler <> nil) then
    begin
      Enabled := False;
      exit; // raise Exception.Create(SSecondStyler);
    end;
    inherited;
    UpdateCaption;
  end;
end;

procedure TMMFormStyler.UnhookOwner;
var
  H: HWnd;
begin
  if FormOK then
  begin
    H := HookWnd;
    inherited;
    SetWindowText(H, PChar(FCaptionText.Caption));
    InvalidateRect(H, nil, False);
  end else
    inherited;
end;

procedure TMMFormStyler.CMEnabledChanged(var M: TMessage);
begin
  inherited;
  if Enabled then HookOwner else UnhookOwner;
  UpdateCaption;
end;
{$ENDIF}

end.