jvsecretpanel.pas

East make Tray Icon in delphi

  I: Integer;
  Flags: Longint;
begin
  if (Lines.Count = 0) or IsRectEmpty(FTxtRect) or not HandleAllocated then
    Exit;
  FMemoryImage.Canvas.Lock;
  try
    with FMemoryImage.Canvas do
    begin
      I := SaveDC(Handle);
      try
        {$IFDEF VisualCLX}
        Start;
        {$ENDIF VisualCLX}
        with FTxtRect do
          MoveWindowOrg(Handle, -Left, -Top);
        Brush.Color := Self.Color;
        PaintClient(FMemoryImage.Canvas, FPaintRect);
        {$IFDEF VisualCLX}
        Stop;
        {$ENDIF VisualCLX}
      finally
        RestoreDC(Handle, I);
        SetBkMode(Handle, Transparent);
      end;
    end;
    R := Bounds(0, 0, RectWidth(FTxtRect), RectHeight(FTxtRect));
    if FDirection = sdHorizontal then
    begin
      if IsRightToLeft then
      begin
        R.Right := R.Left + FScrollCnt;
        R.Left := R.Right - (FMaxScroll - RectWidth(FTxtRect));
      end
      else
      begin
        R.Left := R.Right - FScrollCnt;
        R.Right := R.Left + (FMaxScroll - RectWidth(FTxtRect));
      end;
    end
    else
    begin { sdVertical }
      R.Top := R.Bottom - FScrollCnt;
    end;
    R.Bottom := R.Top + FTxtDivider;
    Flags := DT_EXPANDTABS or Alignments[FAlignment] or DT_SINGLELINE or
      DT_NOCLIP or DT_NOPREFIX;
    Flags := DrawTextBiDiModeFlags(Flags);
    for I := FFirstLine to Lines.Count do
    begin
      if I = Lines.Count then
        StrCopy(STmp, ' ')
      else
        StrPLCopy(STmp, Lines[I], SizeOf(STmp) - 1);
      if R.Top >= RectHeight(FTxtRect) then
        Break
      else
      if R.Bottom > 0 then
      begin
        if FTextStyle <> bvNone then
        begin
          FMemoryImage.Canvas.Font.Color := clBtnHighlight;
          case FTextStyle of
            bvLowered:
              begin
                OffsetRect(R, 1, 1);
                DrawText(FMemoryImage.Canvas, STmp, -1, R, Flags);
                OffsetRect(R, -1, -1);
              end;
            bvRaised:
              begin
                OffsetRect(R, -1, -1);
                DrawText(FMemoryImage.Canvas, STmp, -1, R, Flags);
                OffsetRect(R, 1, 1);
              end;
          end;
          FMemoryImage.Canvas.Font.Color := Self.Font.Color;
          SetBkMode(FMemoryImage.Canvas.Handle, Transparent);
        end;
        DrawText(FMemoryImage.Canvas, STmp, -1, R, Flags);
      end;
      OffsetRect(R, 0, FTxtDivider);
    end;
    Canvas.Lock;
    try
      BitBlt(Canvas.Handle, FTxtRect.Left, FTxtRect.Top, FMemoryImage.Width,
        FMemoryImage.Height, FMemoryImage.Canvas.Handle, 0, 0, SRCCOPY);
      ValidateRect(Handle, @FTxtRect);
    finally
      Canvas.Unlock;
    end;
  finally
    FMemoryImage.Canvas.Unlock;
  end;
end;

procedure TJvSecretPanel.PaintClient(Canvas: TCanvas; Rect: TRect);
begin
  if Assigned(FOnPaintClient) then
    FOnPaintClient(Self, Canvas, Rect)
  else
    Canvas.FillRect(Rect);
end;

procedure TJvSecretPanel.Paint;
var
  Rect: TRect;
  TopColor, BottomColor: TColor;
  SaveIndex: Integer;

  procedure AdjustColors(Bevel: TPanelBevel);
  begin
    TopColor := clBtnHighlight;
    if Bevel = bvLowered then
      TopColor := clBtnShadow;
    BottomColor := clBtnShadow;
    if Bevel = bvLowered then
      BottomColor := clBtnHighlight;
  end;

begin
  Rect := GetClientRect;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, Rect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  end;
  SaveIndex := SaveDC(Canvas.Handle);
  try
    with Rect do
      IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom);
    Canvas.Brush.Color := Self.Color;
    PaintClient(Canvas, Rect);
  finally
    RestoreDC(Canvas.Handle, SaveIndex);
  end;
  if Active then
  begin
    PaintGlyph;
    {PaintText;}
  end;
end;

procedure TJvSecretPanel.StartPlay;
begin
  if Assigned(FOnStartPlay) then
    FOnStartPlay(Self);
end;

procedure TJvSecretPanel.StopPlay;
begin
  if Assigned(FOnStopPlay) then
    FOnStopPlay(Self);
end;

procedure TJvSecretPanel.TimerExpired(Sender: TObject);
begin
  if FScrollCnt < FMaxScroll then
  begin
    Inc(FScrollCnt);
    if Assigned(FMemoryImage) then
      PaintText;
  end
  else
  if Cycled then
  begin
    FScrollCnt := 0;
    if Assigned(FMemoryImage) then
      PaintText;
  end
  else
  begin
    FTimer.Synchronize(Stop);
  end;
end;

procedure TJvSecretPanel.UpdateMemoryImage;
var
  Metrics: TTextMetric;
  I: Integer;
begin
  if FMemoryImage = nil then
    FMemoryImage := TBitmap.Create;
  FMemoryImage.Canvas.Lock;
  try
    FFirstLine := 0;
    while (FFirstLine < Lines.Count) and (Trim(Lines[FFirstLine]) = '') do
      Inc(FFirstLine);
    Canvas.Font := Self.Font;
    GetTextMetrics(Canvas.Handle, Metrics);
    FTxtDivider := Metrics.tmHeight + Metrics.tmExternalLeading;
    if FTextStyle <> bvNone then
      Inc(FTxtDivider);
    RecalcDrawRect;
    if FDirection = sdHorizontal then
    begin
      FMaxScroll := 0;
      for I := FFirstLine to Lines.Count - 1 do
        FMaxScroll := Max(FMaxScroll, Canvas.TextWidth(Lines[I]));
      Inc(FMaxScroll, RectWidth(FTxtRect));
    end
    else
    begin { sdVertical }
      FMaxScroll := ((Lines.Count - FFirstLine) * FTxtDivider) +
        RectHeight(FTxtRect);
    end;
    FMemoryImage.Width := RectWidth(FTxtRect);
    FMemoryImage.Height := RectHeight(FTxtRect);
    with FMemoryImage.Canvas do
    begin
      Font := Self.Font;
      Brush.Color := Self.Color;
      SetBkMode(Handle, Transparent);
    end;
  finally
    FMemoryImage.Canvas.Unlock;
  end;
end;

function TJvSecretPanel.GetInterval: Cardinal;
begin
  Result := FTimer.Interval;
end;

procedure TJvSecretPanel.SetInterval(Value: Cardinal);
begin
  FTimer.Interval := Value;
end;

procedure TJvSecretPanel.Play;
begin
  SetActive(True);
end;

procedure TJvSecretPanel.Stop;
begin
  SetActive(False);
end;

procedure TJvSecretPanel.SetActive(Value: Boolean);
var
  I: Integer;
begin
  if Value <> FActive then
  begin
    FActive := Value;
    if FActive then
    begin
      FScrollCnt := 0;
      UpdateMemoryImage;
      try
        FTimer.Enabled := True;
        StartPlay;
      except
        FActive := False;
        FTimer.Enabled := False;
        raise;
      end;
    end
    else
    begin
      FMemoryImage.Canvas.Lock;
      { ensure that canvas is locked before timer is disabled }
      FTimer.Enabled := False;
      FScrollCnt := 0;
      FMemoryImage.Free;
      FMemoryImage := nil;
      StopPlay;
      if (csDesigning in ComponentState) and
          not (csDestroying in ComponentState) then
        {$IFDEF VCL}
        ValidParentForm(Self).Designer.Modified;
        {$ENDIF VCL}
        {$IFDEF VisualCLX}
        ValidParentForm(Self).DesignerHook.Modified;
        {$ENDIF VisualCLX}
    end;
    if not (csDestroying in ComponentState) then
      for I := 0 to Pred(ControlCount) do
      begin
        if FActive then
        begin
          if Controls[I].Visible then
            FHiddenList.Add(Controls[I]);
          if not (csDesigning in ComponentState) then
            Controls[I].Visible := False;
        end
        else
        if FHiddenList.IndexOf(Controls[I]) >= 0 then
        begin
          Controls[I].Visible := True;
          Controls[I].Invalidate;
          if csDesigning in ComponentState then
            Controls[I].Update;
        end;
      end;
    if not FActive then
      FHiddenList.Clear;
    Invalidate;
  end;
end;

procedure TJvSecretPanel.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    if Active then
      Invalidate;
  end;
end;

procedure TJvSecretPanel.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
end;

procedure TJvSecretPanel.SetDirection(Value: TScrollDirection);
begin
  if FDirection <> Value then
  begin
    FDirection := Value;
    if FActive then
    begin
      FScrollCnt := 0;
      UpdateMemoryImage;
      Invalidate;
    end;
  end;
end;

procedure TJvSecretPanel.SetTextStyle(Value: TPanelBevel);
begin
  if FTextStyle <> Value then
  begin
    FTextStyle := Value;
    if FActive then
    begin
      UpdateMemoryImage;
      Invalidate;
    end;
  end;
end;

procedure TJvSecretPanel.SetGlyphLayout(Value: TGlyphLayout);
begin
  if FGlyphLayout <> Value then
  begin
    FGlyphLayout := Value;
    if FActive then
    begin
      UpdateMemoryImage;
      Invalidate;
    end;
  end;
end;

function TJvSecretPanel.GetLines: TStrings;
begin
  Result := FLines;
end;

procedure TJvSecretPanel.SetLines(Value: TStrings);
begin
  FLines.Assign(Value);
end;

{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.