mmform.pas

一套及时通讯的原码

      with TMMFormStyler(ControlList[i]) do
{$IFNDEF BUILD_ACTIVEX}
      if ((OwnerForm.Handle = Wnd) or IsChild(OwnerForm.Handle, Wnd)) then
{$ELSE}
      if ((HookWnd = Wnd) or IsChild(HookWnd, Wnd)) then
{$ENDIF}
      begin
         Result := TMMFormStyler(ControlList[i]);
         Exit;
      end;
   end;
   Result := nil;
end;

{== TMMFormStyler =============================================================}
constructor TMMFormStyler.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);

{$IFNDEF BUILD_ACTIVEX}
   if (FindStylerForWindow(TForm(Owner).Handle) <> nil) then
      raise Exception.Create(SSecondStyler);
{$ELSE}
  // Oops! it's an early place to check for the neighbor...
{$ENDIF}

   FWindowActive  := True;  { assumption }
   FActiveDefined := False;
   FSystemFont := TFont.Create;
   try
      GetSystemFont(FSystemFont);
   except
      FSystemFont.Free;
      FSystemFont := nil;
      raise;
   end;
   FCompanyText := TMMCompanyText.Create(self);
   FAppNameText := TMMAppNameText.Create(self);
   FCaptionText := TMMCaptionText.Create(self);

   FClrLeftActive    := clBlack;
   FClrLeftInActive  := clBlack;
   FClrRightActive   := clActiveCaption;
   FClrRightInActive := clInActiveCaption;

   FAlignment        := taLeftJustify;
   FOptions          := goSmart;
   FNumColors        := 64;

   FHandle           := AllocateHwnd(HookAppWndProc);

   FRecreating       := False;

   HookOwner;

   AddStyler(Self);

{$IFNDEF BUILD_ACTIVEX}
   if (csdesigning in ComponentState) and not
      (csReadingState in OwnerForm.ControlState) then
     ChangeDesigning(True);
{$ENDIF}
end;

{-- TMMFormStyler -------------------------------------------------------------}
destructor TMMFormStyler.Destroy;
begin
   if FormOK then
     UnHookOwner;
   RemoveStyler(Self);

{$IFNDEF BUILD_ACTIVEX}
   { update caption if the parent form is not being destroyed }
   if (FCaptionText <> nil) and not
      (csDestroying in OwnerForm.ComponentState) then
   begin
      OwnerForm.Caption := FCaptionText.Caption;
      UpdateCaption;
   end;
{$ENDIF}

   if FAppNameText <> nil then FAppNameText.Free;
   if FCaptionText <> nil then FCaptionText.Free;
   if FCompanyText <> nil then FCompanyText.Free;
   if FSystemFont <> nil then FSystemFont.Free;

   if (FHandle <> 0) then DeallocateHwnd(FHandle);

   inherited Destroy;
end;

{$IFDEF BUILD_ACTIVEX}
function TMMFormStyler.GetOwnerCaption: string;
begin
  if HookWnd <> 0 then
  begin
    SetLength(Result, 255);
    GetWindowText(HookWnd, PChar(Result), 255);
    SetLength(Result, StrLen(PChar(Result)));
  end else
    Result := '';
end;
{$ENDIF}

procedure TMMFormStyler.ChangeDesigning(Value: Boolean);
begin
  if Value then
  begin
    { Set default fonts unless stored user settings are being loaded }
    FCompanyText.FCaption := 'SwiftSoft';
    FAppNameText.FCaption := 'MMTools -';
{$IFDEF BUILD_ACTIVEX}
    FCaptionText.FCaption := GetOwnerCaption;
{$ELSE}
    FCaptionText.FCaption := OwnerForm.Caption;
{$ENDIF}
    NewCaptionText;
    FCaptionText.SetFontKind_noRedraw(fkSystem);
    FAppNameText.SetFontkind_noRedraw(fkSystemB);  { system + bold }
    FCompanyText.SetFontkind_noRedraw(fkSystemBI); { system + bold + italic }
    DrawCaption(WindowIsActive);   { do the first-time draw }
  end;
  inherited;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.Loaded;
begin
  inherited Loaded;

  { some people have reported problems with TForm's position being poScreenCenter.
    this removes the problem (I believe - I've never replicated the problem so I
    can't test it). }

{$IFNDEF BUILD_ACTIVEX}
  if (HookWnd <> OwnerForm.Handle) then
  begin
     UnhookOwner;
     HookOwner;
  end;
{$ENDIF}
end;

{-- TMMFormStyler -------------------------------------------------------------}
function TMMFormStyler.WindowIsActive: Boolean;
begin
   if FActiveDefined then
   begin
      Result := FWindowActive;
      exit;
   end;

   Result := (HookWnd = GetActiveWindow);
   if Assigned(OwnerForm) and (OwnerForm.FormStyle = fsMDIChild) then
       if Application <> nil then
          if Application.Mainform <> nil then
             if OwnerForm = Application.Mainform.ActiveMDIChild then
                if Application.Mainform.HandleAllocated then
                   if Application.Mainform.Handle = GetActiveWindow then Result := True;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.PerformNCPaint(var AMsg: TMessage);
var
  R, WR : TRect;
  MyRgn : HRgn;
  DC : HDC;

begin
   R := DrawCaption(WindowIsActive);
   DC := GetWindowDC(HookWnd);
   GetWindowRect(HookWnd, WR);

   MyRgn := CreateRectRgnIndirect(WR);
   try
      if SelectClipRgn(DC, AMsg.wParam) = ERROR then
         SelectClipRgn(DC, MyRgn);
      OffsetClipRgn(DC, -WR.Left, -WR.Top);
      ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
      OffsetClipRgn(DC, WR.Left, WR.Top);
      GetClipRgn(DC, MyRgn);
      AMsg.Result := CallPrevWndProc(AMsg.Msg, MyRgn, AMsg.lParam);
   finally
      DeleteObject(MyRgn);
      ReleaseDC(HookWnd, DC);
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.PerformNCActivate(var AMsg: TMessage);
var
   R: TRect;
begin
   FWindowActive := TWMNCActivate(AMsg).Active;
   FActiveDefined := true;
   if (not NewStyleControls) then
       AMsg.Result := CallPrevWndProc(AMsg.Msg, AMsg.wParam, AMsg.lParam)
   else if Assigned(OwnerForm) and (OwnerForm.FormStyle = fsMDIChild) then { cover up hassles with minimized MDI children borders and button redrawing }
            AMsg.Result := CallPrevWndProc(AMsg.Msg, AMsg.wParam, AMsg.lParam);

   if Assigned(OwnerForm) and (OwnerForm.FormStyle = fsMDIForm) then
      if Application <> nil then
         if Application.Mainform <> nil then
            if Application.Mainform.ActiveMDIChild <> nil then
               PostMessage(Application.Mainform.ActiveMDIChild.Handle, WM_NCACTIVATE, longint(TWMNCActivate(AMsg).Active), 0);

   R := GetTitleBarRect;

   { cause a nc_Paint message to occur (immediately) }
   ReDrawWindow(HookWnd,@R,0,RDW_FRAME or RDW_INVALIDATE or RDW_UPDATENOW);

   AMsg.Result := 1;
   AMsg.wParam := 1;   { Tell windows that we have handled the message }
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.HookWndProc(var Message: TMessage);
begin
   if Message.Msg = WM_NCPAINT then
   begin
      PerformNCPaint(Message);
      exit;
   end; { NCPaint is handled for win32 }

   if Message.Msg = WM_NCACTIVATE then
   begin
      PerformNCActivate(Message);
      exit;
   end; { NCActivate is handled for win32 }

   if Message.Msg = WM_SETCURSOR then
   begin
      if HandleWMSetCursor(TWMSetCursor(Message)) then
      exit;
   end; { SetCursor is handled for win32 }

   if Message.Msg = WM_DESTROY then
   begin
      {Note: WM_DESTROY is trapped here when the form itself is destroyed,
       and whenever the RecreateWnd method of the form is called }
      if not (csDestroying in ComponentState) then
      begin
         { We must unhook the WindowProc, and then rehook it later }
         FRecreating := True;
         UnHookOwner;
         { Notify WordCap to rehook the form. A message must be posted so that this
           can be done once the form has completed the recreation process. }
         PostMessage(FHandle, MM_RecreateNotify, 0, Longint(Self));
         { don't exit.  Allow default processing to still occur }
      end;
   end;

   { now handle all other calls }
   inherited;

   if Message.Msg = WM_SETICON then DrawCaption(WindowIsActive);

   if ((Message.Msg = WM_DISPLAYCHANGE)  or
       (Message.Msg = WM_SysColorChange) or
       (Message.Msg = WM_WININICHANGE) or
       (Message.Msg = WM_SETTINGCHANGE)) then
   begin
      GetSystemFont(FSystemFont);  { update systemfont }
      FAppNameText.SetFontkind_noRedraw(FAppNameText.FFontkind);
      FCaptionText.SetFontKind_noRedraw(FCaptionText.FFontKind);
      FCompanyText.SetFontkind_noRedraw(FCompanyText.FFontkind);
      UpdateCaption;  {force a NC region redraw};
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.HookAppWndProc(var AMsg: TMessage);
begin
   if AMsg.Msg = MM_RecreateNotify then
   begin
      if AMsg.LParam <> longint(self) then exit;    { did the message come from this instance or another instance? }
      HookOwner;  { Rehook the form }
      if GetActiveWindow = HookWnd then FWindowActive := True;
      UpdateCaption;
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.UpdateCaption;
begin
   if FormOK then
   begin
      SetWindowPos(HookWnd, 0, 0, 0, 0, 0,
                   SWP_FRAMECHANGED or SWP_DRAWFRAME or
                   SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.GetSystemFont(Font: TFont);
var
  FNONCLIENTMETRICS : TNONCLIENTMETRICS;
begin
   Font.Handle := GetStockObject(SYSTEM_FONT);
   FNONCLIENTMETRICS.cbSize := Sizeof(TNONCLIENTMETRICS);
   if Boolean(SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0,
                                   @FNONCLIENTMETRICS, 0)) then
   begin
      { work now with FNonClientMetrics.lfCaptionFont }
      Font.Name := FNonClientMetrics.lfCaptionFont.lfFacename;
      if FNonClientMetrics.lfCaptionFont.lfHeight > 0 then
         Font.Size := FNonClientMetrics.lfCaptionFont.lfHeight
      else
         Font.Height := FNonClientMetrics.lfCaptionFont.lfHeight;

      Font.Style := [];
      if FNonClientMetrics.lfCaptionFont.lfItalic <> 0 then
         Font.Style := Font.Style + [fsItalic];
      if FNonClientMetrics.lfCaptionFont.lfWeight > FW_MEDIUM then
         Font.Style := Font.Style + [fsBold];
      Font.Pitch := fpDefault;
   end;
end;

{-- TMMFormStyler -------------------------------------------------------------}
procedure TMMFormStyler.NewCaptionText;
var
   temp: string;

begin
   LockWindowUpdate(HookWnd);
   temp := '';
   if FCompanyText.Visible then temp := temp + FCompanyText.FCaption;
   if FCompanyText.Visible and (FCompanyText.Caption <> '') and
      (FAppNameText.Visible or FCaptionText.Visible) then temp := temp + ' ';
   if FAppNameText.Visible then temp := temp + FAppNameText.FCaption;
   if FAppNameText.Visible and (FAppNameText.Caption <> '') and FCaptionText.Visible then temp := temp + ' ';
   if FCaptionText.Visible then temp := temp + FCaptionText.FCaption;
{$IFNDEF BUILD_ACTIVEX}
   OwnerForm.Caption := temp;
{$ELSE}
   SetWindowText(HookWnd, PChar(temp));
{$ENDIF}
   LockWindowUpdate(0);
end;

const
   // depends upon WS_EX_TOOLWINDOW
  smcCaptionY: array[Boolean] of Integer = (SM_CYCAPTION, SM_CYSMCAPTION);
  smcButtonX: array[Boolean] of Integer = (SM_CXSIZE, SM_CXSMSIZE);
  smcButtonY: array[Boolean] of Integer = (SM_CYSIZE, SM_CYSMSIZE);
   // depends upon WS_THICKFRAME
  smcFrameX: array[Boolean] of Integer = (SM_CXFIXEDFRAME, SM_CXSIZEFRAME);
  smcFrameY: array[Boolean] of Integer = (SM_CYFIXEDFRAME, SM_CYSIZEFRAME);

{-- TMMFormStyler -------------------------------------------------------------}
function TMMFormStyler.GetTitleBarRect: TRect;
var
  Style, ExStyle: Integer;
  SizeFrame, ToolWindow: Boolean;
begin
  Style := GetWindowLong(HookWnd, GWL_STYLE);
  ExStyle := GetWindowLong(HookWnd, GWL_EXSTYLE);

{$IFNDEF BUILD_ACTIVEX}
  if csDesigning in ComponentState then
  begin
    Style := WS_CAPTION or WS_THICKFRAME;
    ExStyle := 0;
  end;
{$ENDIF}

   { if we have no border style, then just set the rectangle empty. }