jvlookout.pas

East make Tray Icon in delphi

begin
  if FScrolling <> 0 then
    Exit;
  if (csReading in ComponentState) or (csLoading in ComponentState) or (csWriting in ComponentState) or
    (csDestroying in ComponentState) then
    Exit;
  { draw all owned controls }
  if ControlCount < 3 then
  begin
    if Assigned(FUpArrow) and Assigned(FDownArrow) then
    begin
      FUpArrow.Visible := False;
      FDownArrow.Visible := False;
    end;
    Exit;
  end;
  if FInScroll then
    Exit;
  R := GetClientRect;
  X := Width;
  ACount := GetButtonCount;
  if ACount = 0 then
    Exit;
  FButtons.Sort(Compare);
  FInScroll := True;
  for I := 0 to ACount - 1 do
  begin
    AControl := FButtons[I];
    if not AControl.Visible and not (csDesigning in ComponentState) then
      Continue;
    if AControl.Align <> alNone then
      AControl.Align := alNone;

    if I < FTopControl then
      AControl.Top := -(AControl.Height + 1) * (ACount - I)
    else
    if Start > Height then
      AControl.Top := (Height + 1) * (I + 1)
    else
    begin
      AControl.Top := Start + FMargin;
      Inc(Start, (AControl.Height + FMargin));
    end;

    if FAutoCenter and (AControl is TJvCustomLookOutButton) and
      (TJvCustomLookOutButton(AControl).ImageSize = isLarge) then
      AControl.Left := (X - AControl.Width) div 2;
  end;
  FInScroll := False;
end;

procedure TJvLookOutPage.CreateWnd;
var
  R: TRect;
begin
  inherited CreateWnd;
  R := GetClientRect;
  if not Assigned(FUpArrow) then
  begin
    FUpArrow := TJvUpArrowBtn.Create(nil);
    FUpArrow.Parent := Self;
  end;

  if not Assigned(FDownArrow) then
  begin
    FDownArrow := TJvDwnArrowBtn.Create(nil);
    FDownArrow.Parent := Self;
  end;

  with FUpArrow do
  begin
    Visible := False;
    SetBounds(R.Right - 23, R.Top + 25, 16, 16);
  end;

  with FDownArrow do
  begin
    Visible := False;
    SetBounds(R.Right - 23, R.Bottom - 23, 16, 16);
  end;

  if Assigned(Parent) and (Parent is TJvLookOut) then
  begin
    FManager := TJvLookOut(Parent);
    FOnCollapse := FManager.FOnCollapse;
  end;
  // (p3) fix to work with frames
  if GetParentForm(Self) <> nil then
  begin
    FUpArrow.SetZOrder(True);
    FDownArrow.SetZOrder(True);
  end;
end;

procedure TJvLookOutPage.Click;
begin
  if not Enabled then
    Exit;
  if Assigned(FOnCollapse) then
    FOnCollapse(Self);
  inherited Click;
end;

procedure TJvLookOutPage.EnabledChanged;
begin
  if not (Assigned(FUpArrow) or Assigned(FDownArrow)) then
    Exit;
  if not Enabled then
  begin
    FUpArrow.Enabled := False;
    FDownArrow.Enabled := False;
  end
  else
  begin
    FUpArrow.Enabled := True;
    FDownArrow.Enabled := True;
  end;
  inherited EnabledChanged;
  Refresh;
end;

function TJvLookOutPage.IsVisible(Control: TControl): Boolean;
var
  R: TRect;
begin
  Result := False;
  if Control = nil then
    Exit;
  R := GetClientRect;
  Result := (PtInRect(R, Point(R.Left + 1, Control.Top)) and
    PtInRect(R, Point(R.Left + 1, Control.Top + Control.Height)));
end;

procedure TJvLookOutPage.SetAutoRepeat(Value: Boolean);
begin
  if FAutoRepeat <> Value then
  begin
    FAutoRepeat := Value;
    if Assigned(FUpArrow) and Assigned(FDownArrow) then
    begin
      FUpArrow.AutoRepeat := FAutoRepeat;
      FDownArrow.AutoRepeat := FAutoRepeat;
    end;
  end;
end;

procedure TJvLookOutPage.SetHighlightFont(Value: TFont);
begin
  FHighlightFont.Assign(Value);
  if FHighlightFont <> Font then
    DrawTopButton;
end;

procedure TJvLookOutPage.SetButton(Index: Integer; Value: TJvLookOutButton);
begin
  FButtons[Index] := Value;
end;

function TJvLookOutPage.GetButton(Index: Integer): TJvLookOutButton;
begin
  Result := TJvLookOutButton(FButtons[Index]);
end;

function TJvLookOutPage.GetButtonCount: Integer;
begin
  Result := FButtons.Count;
end;

procedure TJvLookOutPage.SetAutoCenter(Value: Boolean);
begin
  if FAutoCenter <> Value then
  begin
    FAutoCenter := Value;
    if FAutoCenter then
      ScrollChildren(cHeight + 7 - FMargin);
  end;
end;

procedure TJvLookOutPage.SetMargin(Value: Integer);
begin
  if FMargin <> Value then
  begin
    FMargin := Value;
    Invalidate;
  end;
end;

procedure TJvLookOutPage.SetImageSize(Value: TJvImageSize);
var
  Msg: TMessage;
begin
  if FImageSize <> Value then
  begin
    FImageSize := Value;
    if csDesigning in ComponentState then
      SetParentImageSize(False);
    { notify children }
    Msg.Msg := CM_IMAGESIZECHANGED;
    Msg.WParam := Longint(Ord(FImageSize));
    Msg.LParam := Longint(Self);
    Msg.Result := 0;
    if Parent <> nil then
      Parent.Broadcast(Msg);
    Broadcast(Msg);
  end;
end;

procedure TJvLookOutPage.SetParentImageSize(Value: Boolean);
begin
  FParentImageSize := Value;
  if FParentImageSize and (FManager <> nil) then
    SetImageSize(FManager.ImageSize);
end;

procedure TJvLookOutPage.CMParentImageSizeChanged(var Msg: TMessage);
var
  Tmp: Boolean;
begin
  if (Msg.LParam <> Longint(Self)) and FParentImageSize then
  begin
    Tmp := FParentImageSize;
    SetImageSize(TJvImageSize(Msg.WParam));
    FParentImageSize := Tmp;
  end;
end;

procedure TJvLookOutPage.SetBitmap(Value: TBitmap);
begin
  FBitmap.Assign(Value);
  if FBitmap.Empty then
    ControlStyle := ControlStyle - [csOpaque]
  else
    ControlStyle := ControlStyle + [csOpaque];
  //  RecreateWnd;
  Invalidate;
end;

procedure TJvLookOutPage.SetCaption(Value: TCaption);
begin
  if FCaption <> Value then
  begin
    FCaption := Value;
    Invalidate;
  end;
end;

{ determine if arrows should be visible }

procedure TJvLookOutPage.CalcArrows;
var
  I: Integer;
  R: TRect;
  AList: TList;
begin
  if Assigned(FUpArrow) and Assigned(FDownArrow) then
  begin
    // (rom) needs constants instead of numbers
    if Height < 65 then
    begin
      //      FUpArrow.Visible := False;
      //      FDownArrow.Visible := False;
      FDownArrow.Top := FUpArrow.Top + 16;
      Exit;
    end;

    R := GetClientRect;
    FUpArrow.SetBounds(R.Right - 23, R.Top + 25, 16, 16);
    FDownArrow.SetBounds(R.Right - 23, R.Bottom - 23, 16, 16);
    AList := TList.Create;
    try
      for I := 0 to ControlCount - 1 do
      begin
        if (Controls[I] = FUpArrow) or (Controls[I] = FDownArrow) or (Controls[I] = FEdit) then
          Continue;

        if not Controls[I].Visible and not (csDesigning in ComponentState) then
          Continue;
        AList.Insert(AList.Count, Controls[I]);
      end;

      if AList.Count = 0 then
        Exit;
      AList.Sort(Compare);
      FDownArrow.Visible := not IsVisible(AList.Items[AList.Count - 1]);
      FUpArrow.Visible := not IsVisible(AList.Items[0]);
    finally
      AList.Free;
    end;
  end;
end;

procedure TJvLookOutPage.UpArrowClick(Sender: TObject);
begin
  if (FScrolling = 0) and (FTopControl > 0) then
    Dec(FTopControl);
end;

procedure TJvLookOutPage.DownArrowClick(Sender: TObject);
begin
  if (FScrolling = 0) and (FTopControl < ControlCount - 3) then
    Inc(FTopControl);
end;

procedure TJvLookOutPage.Paint;
begin
  if not FBitmap.Empty then
  begin
    ControlStyle := ControlStyle + [csOpaque];
    TileBitmap;
  end
  else
    ControlStyle := ControlStyle - [csOpaque];

  DrawTopButton;
  CalcArrows;
  ScrollChildren(cHeight + 7 - FMargin);
end;

procedure TJvLookOutPage.DrawTopButton;
var
  R, R2: TRect;
  DC: HDC;
  FFlat, FPush: Boolean;
begin
  if MouseOver then
    Canvas.Font := FHighlightFont
  else
    Canvas.Font := Self.Font;

  Canvas.Brush.Color := clBtnFace;
  DC := Canvas.Handle;
  R := GetClientRect;

  { draw top button }
  R.Bottom := cHeight;
  Canvas.FillRect(R);
  FPush := FShowPressed and FDown;
  FFlat := Assigned(FManager) and (FManager.FFlatButtons);
  if FFlat then
  begin
    if FManager.ActivePage = Self then
    begin
      R2 := GetClientRect;
      R2.Top := R.Bottom;
      Frame3D(Canvas, R2, cl3DDkShadow, clBtnFace, 1);
    end;

    if FPush then
      Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1)
    else
    if MouseOver then
    begin
      Frame3D(Canvas, R, clBtnHighlight, cl3DDkShadow, 1);
      Frame3D(Canvas, R, clBtnFace, clBtnShadow, 1);
    end
    else
      Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1)
  end
  else
  begin
    if FPush then
    begin
      Frame3D(Canvas, R, cl3DDkShadow, clBtnHighlight, 1);
      Frame3D(Canvas, R, clBtnShadow, clBtnFace, 1);
    end
    else
    begin
      Frame3D(Canvas, R, clBtnHighlight, cl3DDkShadow, 1);
      Frame3D(Canvas, R, clBtnFace, clBtnShadow, 1);
    end;
  end;

  { draw top caption }
  R := GetClientRect;
  R.Bottom := cHeight;
  SetBkMode(DC, Windows.Transparent);
  if FCaption <> '' then
  begin
    if not Enabled then
    begin
      { draw disabled text }
      SetTextColor(DC, ColorToRGB(clBtnHighlight));
      OffsetRect(R, 1, 1);
      DrawText(DC, FCaption, Length(FCaption), R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
      OffsetRect(R, -1, -1);
      SetTextColor(DC, ColorToRGB(clBtnShadow));
    end
    else
      SetTextColor(DC, ColorToRGB(Canvas.Font.Color));
    if FShowPressed and FDown then
      OffsetRect(R, 1, 1);
    DrawText(DC, FCaption, Length(FCaption), R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
  end;
end;

procedure TJvLookOutPage.TileBitmap;
var
  X, Y, W, H: Longint;
  Dest, Source: TRect;
  Tmp: TBitmap;
begin
  if not FBitmap.Empty then
  begin
    with FBitmap do
    begin
      W := Width;
      H := Height;
    end;

    Tmp := TBitmap.Create;
    Tmp.Width := Width;
    Tmp.Height := Height;

    Y := 0;
    Source := Rect(0, 0, W, H);
    while Y < Height do
    begin
      X := 0;
      while X < Width do
      begin
        Dest := Rect(X, Y, X + W, Y + H);
        Tmp.Canvas.CopyRect(Dest, FBitmap.Canvas, Source);
        Inc(X, W);
      end;
      Inc(Y, H);
    end;
    Canvas.Draw(0, 0, Tmp);
    Tmp.Free;
  end;
end;

procedure TJvLookOutPage.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  R: TRect;
  Tmp: TPoint;
  {$IFDEF VCL}
  Msg: TMsg;
  {$ENDIF VCL}
begin
  inherited MouseDown(Button, Shift, X, Y);
  if Assigned(FPopUpMenu) and (Button = mbRight) then
  begin
    { calc where to put menu }
    Tmp := ClientToScreen(Point(X, Y));
    FPopUpMenu.PopupComponent := Self;
    FPopUpMenu.Popup(Tmp.X, Tmp.Y);
    {$IFDEF VCL}
    { wait 'til menu is Done }
    while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do
      {nothing};
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
     repeat
       Application.ProcessMessages;
     until not QWidget_isVisible(FPopUpMenu.Handle);
    {$ENDIF VisualCLX}
    FDown := False;
  end
  else
  begin
    R := GetClientRect;
    R.Bottom := cHeight;
    if PtInRect(R, Point(X, Y)) and (Button = mbLeft) then
    begin
      FDown := True;
      DrawTopButton;
    end;
  end;
end;

procedure TJvLookOutPage.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  R: TRect;
be