explbtn.pas

地址档案管理系统

     FUndocked := False;
     FUndockable := True;
     FUndockThreshold := 10;
     FHideInactive := True;
     FRedockable := True;
end;

procedure TExplorerPopup.Loaded;
begin
     inherited Loaded;
     Visible := False;
end;

procedure TExplorerPopup.SetUndockable(value: Boolean);
begin
     if value <> FUndockable then
     begin
          FUndockable := value;
          Refresh;
     end;
end;

{ Adjusts the vertical position of the components of the popup }
procedure TExplorerPopup.ShiftControlsUpDown(offset: Integer);
var
  i: Integer;
begin
  Height := Height + offset;
  for i := 0 to ControlCount - 1 do
    Controls[i].Top := Controls[i].Top + offset;
end;

procedure TExplorerPopup.Paint;
begin
   with Canvas do
   begin
     Brush.Style := bsSolid;
     Brush.Color := clBtnFace;
     if not FUndocked then
       Pen.Style := psSolid
     else
       Pen.Style := psClear;
     Pen.Color := clBtnShadow;
    if not FUndocked then
      Rectangle(1, 1, Width-1, Height-1)
    else
      Rectangle(2, 2, Width-2, Height-2);
    if not FUndocked then
    begin
      Pen.Color := clBtnHighlight;
      MoveTo(1, Height - 2);
      LineTo(1, 1);
      LineTo(Width - 2, 1);
      Pen.Color := clBlack;
      MoveTo(Width - 1, 0);
      LineTo(Width - 1, Height-1);
      LineTo(0, Height-1);
    end;
  end;

  if FUndockable and (not FUndocked) and not (csDesigning in ComponentState) then
  begin
    with Canvas do
    begin
       if titleFocused then
        Brush.Color := clActiveCaption
        else
        Brush.Color := clInactiveCaption;
      Brush.Style := bsSolid;
      Pen.Style := psClear;
      Rectangle(4, 2, Width - 3, 10);
    end;
   end;
end;

procedure TExplorerPopup.WMLButtonUp(var msg: TWMLButtonUp);
begin
  clicked := False;
  MouseCapture := False;
end;

procedure TExplorerPopup.WMLButtonDown(var msg: TWMLButtonDown);
begin
  if (msg.XPos > 3) and (msg.YPos > 1) and (msg.YPos < 9) and (msg.XPos < Width - 3) then
  begin
    clicked := True;
    mousex := msg.XPos;
     mousey := msg.YPos;
     MouseCapture := True;
  end;
end;

{ Manage the undocking of the popup }
const SC_DRAGMOVE = $F012;
procedure TExplorerPopup.WMMouseMove(var msg: TWMMouseMove);
var
   f: TExplorerPopupForm;
   p: TPoint;
   dockedForm: TForm;
begin
  if FUndockable and (not FUndocked) then
  begin
    if clicked or ((msg.XPos > 3) and (msg.YPos > 1) and (msg.YPos < 9) and (msg.XPos < Width - 3)) then
     begin
       if not titleFocused then
        begin
        with Canvas do
        begin
          Brush.Color := clActiveCaption;
          Brush.Style := bsSolid;
          Pen.Style := psClear;
          Rectangle(4, 2, Width - 3, 10);
        end
        end;
        titleFocused := True;
     end
     else if titleFocused then
     begin
      with Canvas do
      begin
        Brush.Color := clInactiveCaption;
        Brush.Style := bsSolid;
        Pen.Style := psClear;
        Rectangle(4, 2, Width - 3, 10);
      end;
        titleFocused := False;
     end;
     if clicked and
        (sqrt((msg.Xpos - mousex)*(msg.Xpos - mousex)+(msg.Ypos - mousey)*(msg.Ypos - mousey)) > FUndockThreshold) then
     begin
       clicked := False;
       if Assigned(FOnUndock) then
            FOnUndock(Self);
        Visible := False;
       MouseCapture := False;
         f := TExplorerPopupForm.CreateNew(Self);
         f.OnClose := FormClose;
       GetCursorPos(p);
         f.Left := p.x - Width div 2;
         f.Top := p.y - 5;
         f.topDock := Parent.Top;
         f.leftDock := Parent.Left;
         f.leftHome := False;
         f.redocked := False;
         f.checkRedock := FRedockable;
         f.hideInactive := FHideInactive;
         (Parent as TForm).Close;

         if FUndockable then
           ShiftControlsUpDown(-10);
         f.Caption := Caption;
         f.BorderIcons := [biSystemMenu];
         f.FormStyle := fsStayOnTop;
         f.Font.Assign(Font);
         Parent := f;
    {$IFNDEF WIN32}
         f.ClientWidth := Width + 4;
         f.BorderStyle := bsNone;
         f.ClientHeight := ClientHeight + 20;
         Top := 18;
         Left := 2;
     {$ELSE}
         f.ClientWidth := Width;
         f.BorderStyle := bsToolWindow;
         f.ClientHeight := ClientHeight;
        Top := 0;
         Left := 0;
     {$ENDIF}
         Visible := True;
         f.Show;

         (* Again set the client width to force it
           * (when the width is small, sometimes Delphi
           *  increases it (caption length ?))
           *)
    {$IFNDEF WIN32}
         f.ClientWidth := Width + 4;
     {$ELSE}
         f.ClientWidth := Width;
     {$ENDIF}
         FUndocked := True;

         SendMessage(f.Handle, WM_SYSCOMMAND, SC_DRAGMOVE, 0);

         if f.redocked then
         begin
        FUndocked := False;
        Visible := False;
           dockedForm := TForm.CreateNew(Self);
           if FUndockable then
           ShiftControlsUpDown(10);
         dockedForm.OnClose := DockedFormClose;
         dockedForm.FormStyle := fsStayOnTop;
         dockedForm.Font.Assign(Font);
         Parent := dockedForm;
         dockedForm.BorderStyle := bsNone;
        dockedForm.ClientWidth := Width;
        dockedForm.ClientHeight := Height;

         dockedForm.Left := f.leftDock;
         dockedForm.Top := f.topDock;
         Left := 0;
         Top := 0;

         dockedForm.Show;

        dockedForm.ClientWidth := Width;

        f.Free;
         Visible := True;
         FUndocked := False;
         titleFocused := False;
         dockedForm.Show;
         end
         else
           f.checkRedock := False;
     end;
  end;
end;

procedure TExplorerPopup.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     Action := caFree;
     Visible := False;
     Parent := oldParent;
     FUndocked := False;
     clicked := False;
end;

procedure TExplorerPopup.DockedFormClose(Sender: TObject; var Action: TCloseAction);
begin
     Action := caFree;
     Parent := oldParent;
end;

procedure TExplorerPopup.Open(btn: TControl);
var
  p, cPos: TPoint;
  Msg: TMsg;
  f: TForm;
begin
     Terminated := False;
     if Visible then
     begin
          if FUndocked then
             (Parent as TForm).Close
          else
              Exit;
     end;

     if Assigned(FOnOpen) then
       FOnOpen(Self);

     if FUndockable then
       ShiftControlsUpDown(10);

     oldParent := Parent;
     f := TForm.CreateNew(Self);
     f.OnClose := DockedFormClose;
     f.FormStyle := fsStayOnTop;
     f.Font.Assign(Font);
     Parent := f;
     f.BorderStyle := bsNone;
    f.ClientWidth := Width;
    f.ClientHeight := Height;

     p := Point(btn.Left, btn.Top);
     p := btn.Parent.ClientToScreen(p);
     p.y := p.y + btn.Height;

     (* Adjust with the screen limits *)
     if p.y + Height > Screen.Height then
       p.y := p.y - btn.Height - Height;
     if p.x + Width > Screen.Width then
       p.x := Screen.Width - Width;

     f.Left := p.x;
     f.Top := p.y;
     Left := 0;
     Top := 0;

     f.Show;

    f.ClientWidth := Width;
     Visible := True;
     FUndocked := False;
     titleFocused := False;

     while (not terminated) and (not FUndocked) do
     begin
       if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then
        begin
          if Msg.Message = WM_QUIT then
           begin
                 terminated := True;
             if not FUndocked then
               Close;
           end;
            if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_NCLBUTTONDOWN) then
           begin
             p := ClientToScreen(Point(0, 0));
               GetCursorPos(cPos);
              if (cpos.x < p.x) or (cpos.x > p.x + Width) or (cpos.y < p.y) or (cpos.y > p.y + Height) then
              begin
                 terminated := True;
             if not FUndocked then
               Close;
              end;
           end;
        end;
        Application.HandleMessage;
     end;
end;

procedure TExplorerPopup.Close;
begin
  if not Visible then
    Exit;
     if FUndocked then
          (Parent as TForm).Close
     else
     begin
          Visible := False;
         (Parent as TForm).Close;
          clicked := False;
          Terminated := True;
         if FUndockable then
             ShiftControlsUpDown(-10);
     end;
     if Assigned(FOnClose) then
       FOnClose(Self);
end;

procedure TExplorerPopup.CloseIfDocked;
begin
  if not FUndocked then
    Close;
end;

{
  *********************************************************
  *
  *  TExplorerButton implementation
  *
  *********************************************************
}

(* Thanks to Stefano Rustioni *)
procedure GetSystemVersion;
{$IFDEF WIN32}
var
   VersionInfo : TOsVersionInfo;
begin
  bool_Version95 := True;
  try
    VersionInfo.dwOSVersionInfoSize := sizeof (VersionInfo);
    GetVersionEx (VersionInfo);
    if (VersionInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) or
        ((VersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT)
        and (VersionInfo.dwMajorVersion >= 4)) then
      bool_Version95 := True
    else
      bool_Version95 := False;
    except
      bool_Version95 := True;
  end;
{$ELSE}
begin
  if LOWORD(GetVersion) <= 3 then
    bool_Version95 := False
  else
    bool_Version95 := True;
{$ENDIF}
end;

procedure CreatePattern;
var
  X, Y: Integer;
begin
  Pattern := TBitmap.Create;
  Pattern.Width := 8;
  Pattern.Height := 8;
  with Pattern.Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clBtnFace;
    FillRect(Rect(0, 0, Pattern.Width, Pattern.Height));
    for Y := 0 to 7 do
      for X := 0 to 7 do
      begin
        if (X mod 2) = (Y mod 2) then
          Pixels[X, Y] := clBtnHighlight;
      end;
  end;
end;

{$B-} (* Quick evaluation *)
(* Won't work properly in the case of 'text&' caption, but the one
   who defines such a caption has a really sick mind :)*)
function RemoveAmpersand(input: String): String;
var i: Integer;
begin
  Result := input;
  i := 1;
  while i < Length(Result) do
  begin
    if (Result[i] = '&') then
    begin
      if (Result[i+1] = '&') then
        Delete(Result, i + 1, 1)
      else
        Delete(Result, i, 1);
    end
    else
      Inc(i);
  end;
end;

(*
 * TExplorerButton implementation
 *)

constructor TExplorerButton.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);

  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChange;
  FNoFocusBitmap := TBitmap.Create;
  FNoFocusBitmap.OnChange := NoFocusBitmapChange;
  FDisabledBitmap := TBitmap.Create;
  FDisabledBitmap.OnChange := DisabledBitmapChange;
  IBitmap := TBitmap.Create;
   backBitmap := TBitmap.Create;

  ControlStyle := [csClickEvents, csCaptureMouse, csSetCaption, csDoubleClicks];
  Pushed := False;