floatingwindow.pas

Floating Window.It is descendant of TCustomPanel. You can: - Drag on its title bar. - Set title ba

procedure TFloatingWindow.Hide;
begin
  inherited;
  isOverCloseButton := false;
  if Assigned(fOnHide) then fOnHide(self)
end;

procedure TFloatingWindow.Paint;
begin
  DrawNonClient;
  DrawClient;
end;

procedure TFloatingWindow.RotateFont(f: TFont; alpha: Integer);
var
  logFont: TLogFont;
begin
  alpha := alpha mod 360;
  if alpha < 0 then alpha := 360 + alpha;
  with logFont do
  begin
    lfHeight := f.Height;
    lfWidth := 0;
    lfEscapement := 10 * alpha;
    lfOrientation := 10 * alpha;
    if fsBold in f.Style then
      lfWeight := FW_BOLD
    else
      lfWeight := FW_NORMAL;
    lfItalic := Byte(fsItalic in f.Style);
    lfUnderline := Byte(fsUnderline in f.Style);
    lfStrikeOut := Byte(fsStrikeOut in f.Style);
    StrPCopy(lfFaceName, f.Name);
    lfCharSet := f.Charset;
    { Everything else as default }
    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    lfQuality := DEFAULT_QUALITY;
    case f.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
      else
        lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  f.Handle := CreateFontIndirect(logFont);
end;

procedure TFloatingWindow.SetCtl3D(Value: Boolean);
begin
  inherited Ctl3D := Value;
  RecreateWnd
end;

procedure TFloatingWindow.SetExpanded(const Value: Boolean);
begin
  if fExpanded <> Value then
  begin
    fExpanded := Value;
    if fTitleBarPosition = tbTop then
    begin
      if fExpanded then Height := saveHeight
      else begin
        saveHeight := Height;
        ClientHeight := 0
      end;
    end
    else begin //tbLeft
      if fExpanded then Width := saveHeight
      else begin
        saveHeight := Width;
        ClientWidth := 0
      end;
    end;
    if Assigned(fOnExpand) then fOnExpand(self)
  end
end;

procedure TFloatingWindow.SetShowButtons(const Value: Boolean);
begin
  if fShowButtons <> Value then
  begin
    fShowButtons := Value;
    Invalidate
  end
end;

procedure TFloatingWindow.SetTitleBarPosition(const Value: TTitleBarPosition);
begin
  if fTitleBarPosition <> Value  then
  begin
    fTitleBarPosition := value;
    if Height < 33 then Height := 33;
    if Width < 105 then Width := 105;
    RecreateWnd
  end
end;

procedure TFloatingWindow.Show;
begin
  inherited;
  if Assigned(fOnShow) then fOnShow(self)
end;

procedure TFloatingWindow.WMNCCalcSize(var msg: TMessage);
const
  arrOffsets: array[Boolean] of Integer = (-1, -2);
var
  r: PRect;
begin
  inherited;
  r := PRect(msg.LParam);
  if fTitleBarPosition = tbTop then
  begin
    Inc(r^.Top, CAPTION_WIDTH);
    InflateRect(r^, arrOffsets[Ctl3D], arrOffsets[Ctl3D])
  end
  else begin //tbLeft
    Inc(r^.Left, CAPTION_WIDTH);
    InflateRect(r^, arrOffsets[Ctl3D], arrOffsets[Ctl3D])
  end
end;

procedure TFloatingWindow.WMNCHitTest(var msg: TMessage);
var
  p: TPoint;
begin
  inherited;
  if csDesigning in ComponentState then Exit;

  p := Point(msg.LParamLo, msg.LParamHi);
  p := ScreenToClient(p);
  if PtInRect(rCloseButton, p) then
  begin
    msg.Result := HTCLOSE;
    Exit;
  end
  else if PtInRect(rExpandButton, p) then
  begin
    msg.Result := HTREDUCE;
    Exit;
  end;

  if fTitleBarPosition = tbTop then
  begin
    if fSizeable then
    begin
      if p.y <= -CAPTION_WIDTH then
        if p.x < CAPTION_WIDTH then msg.Result := HTTOPLEFT
        else if p.x >= Width - CAPTION_WIDTH then msg.Result := HTTOPRIGHT
        else msg.Result := HTTOP
      else if p.y < 0 then
        msg.Result := HTCAPTION
      else if p.y >= ClientHeight then
        if p.x < CAPTION_WIDTH then msg.Result := HTBOTTOMLEFT
        else if p.x > Width - CAPTION_WIDTH then msg.Result := HTBOTTOMRIGHT
        else msg.Result := HTBOTTOM;

      if p.x <= 0 then
        if p.y < 0 then msg.Result := HTTOPLEFT
        else if p.y > ClientHeight - CAPTION_WIDTH then msg.Result := HTBOTTOMLEFT
        else msg.Result := HTLEFT
      else if p.x >= ClientWidth then
        if p.y < 0 then msg.Result := HTTOPRIGHT
        else if p.y > ClientHeight - CAPTION_WIDTH then msg.Result := HTBOTTOMRIGHT
        else msg.Result := HTRIGHT;
    end
    else if p.y < 0 then
      msg.Result := HTCAPTION
  end
  else begin //tbLeft
    if fSizeable then
    begin
      if p.x <= -CAPTION_WIDTH then
        if p.y < CAPTION_WIDTH then msg.Result := HTTOPLEFT
        else if p.y >= Height - CAPTION_WIDTH then msg.Result := HTBOTTOMLEFT
        else msg.Result := HTLEFT
      else if p.x < 0 then
        msg.Result := HTCAPTION
      else if p.x >= ClientWidth then
        if p.y < CAPTION_WIDTH then msg.Result := HTTOPRIGHT
        else if p.y > Height - CAPTION_WIDTH then msg.Result := HTBOTTOMRIGHT
        else msg.Result := HTRIGHT;

      if p.y <= 0 then
        if p.x < 0 then msg.Result := HTTOPLEFT
        else if p.x > ClientWidth - CAPTION_WIDTH then msg.Result := HTTOPRIGHT
        else msg.Result := HTTOP
      else if p.y >= ClientHeight then
        if p.x < 0 then msg.Result := HTBOTTOMLEFT
        else if p.x > ClientWidth - CAPTION_WIDTH then msg.Result := HTBOTTOMRIGHT
        else msg.Result := HTBOTTOM;
    end
    else if p.x < 0 then
      msg.Result := HTCAPTION
  end
end;

procedure TFloatingWindow.WMNCPaint(var msg: TMessage);
begin
  inherited;
  DrawNonClient
end;

procedure TFloatingWindow.WMWindowPosChanging(var msg: TWMWindowPosChanging);
const
  arrMinSize: array[Boolean] of Byte = (CAPTION_WIDTH + 2, CAPTION_WIDTH + 4);
begin
  inherited;
  if fTitleBarPosition = tbTop then
  begin
    if msg.WindowPos.cx < 105 then
      msg.WindowPos.cx := 105;
    if msg.WindowPos.cy < arrMinSize[Ctl3D] then
      msg.WindowPos.cy := arrMinSize[Ctl3D]
  end
  else begin //tbLeft
    if msg.WindowPos.cy < 33 then
      msg.WindowPos.cy := 33;
    if msg.WindowPos.cx < arrMinSize[Ctl3D] then
      msg.WindowPos.cx := arrMinSize[Ctl3D]
  end
end;

procedure TFloatingWindow.WndProc(var msg: TMessage);
var
  p: TPoint;
  b, needRedraw: Boolean;
begin
  case msg.Msg of
    WM_NCLBUTTONDBLCLK: Exit;
    WM_NCLBUTTONDOWN,
    WM_NCRBUTTONDOWN,
    WM_NCMBUTTONDOWN,
    WM_LBUTTONDOWN,
    WM_RBUTTONDOWN,
    WM_MBUTTONDOWN:
    begin
      if CanFocus then SetFocus;
      BringToFront;
      if msg.msg = WM_NCLBUTTONDOWN then
      begin
        p := Point(msg.LParamLo, msg.LParamHi);
        p := ScreenToClient(p);
        if PtInRect(rCloseButton, p) then Hide
        else if PtInRect(rExpandButton, p) then Expanded := not Expanded
      end;
    end;

    WM_NCMOUSEMOVE:
    begin
      p := Point(msg.LParamLo, msg.LParamHi);
      p := ScreenToClient(p);
      b := PtInRect(rCloseButton, p);
      needRedraw := false;
      if b <> isOverCloseButton then
      begin
        isOverCloseButton := b;
        if isOverCloseButton then isOverExpandButton := false;
        needRedraw := true;
      end;
      if not b then
      begin
        b := PtInRect(rExpandButton, p);
        if b <> isOverExpandButton then
        begin
          isOverExpandButton := b;
          if isOverExpandButton then isOverCloseButton := false;
          needRedraw := true;
        end;
      end;
      if needRedraw then DrawNonClient
    end;

    WM_MOUSEMOVE:
    begin
      if isOverCloseButton then
      begin
        isOverCloseButton := false;
        DrawNonClient
      end
      else if isOverExpandButton then
      begin
        isOverExpandButton := false;
        DrawNonClient
      end
    end;
  end;
  inherited;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TFloatingWindow]);
end;

end.