jvbackgrounds.pas

East make Tray Icon in delphi

function GetClientBrush(AClient: TControl): TBrush;
begin
  if AClient is TWinControl then
    Result := TWinControl(AClient).Brush
  else
    Result := AClient.Parent.Brush;
end;

function IsMDIForm(Control: TControl): Boolean;
begin
  Result := False;
  if Assigned(Control) then
    if Control is TCustomForm then
      Result := TForm(Control).FormStyle = fsMDIForm;
end;

//=== { TJvBackgroundImage } =================================================

constructor TJvBackgroundImage.Create;
begin
  inherited Create;
  FCanvas := TCanvas.Create;
  FAutoSizeTile := True;
  FEnabled := True;
  FTransparentColor := clDefault;
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  HookMainWindow;
end;

destructor TJvBackgroundImage.Destroy;
begin
  UnhookMainWindow;
  FPicture.Free;
  FWorkingBmp.Free;
  FCanvas.Free;
  inherited Destroy;
end;

procedure TJvBackgroundImage.Assign(Source: TPersistent);
var
  Src: TJvBackgroundImage;
begin
  if Source is TJvBackgroundImage then
  begin
    Src := TJvBackgroundImage(Source);
    AutoSizeTile := Src.AutoSizeTile;
    Enabled := Src.Enabled;
    FitPictureSize := Src.FitPictureSize;
    GrayMapped := Src.GrayMapped;
    Mode := Src.Mode;
    Picture := Src.Picture;
    TileWidth := Src.TileWidth;
    TileHeight := Src.TileHeight;
    Transparent := Src.Transparent;
    TransparentColor := Src.TransparentColor;
    TransparentMode := Src.TransparentMode;
    Shift := Src.Shift;
    ShiftMode := Src.ShiftMode;
    ZigZag := Src.ZigZag;
  end
  else
    inherited Assign(Source);
end;

procedure TJvBackgroundImage.Changed;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

function TJvBackgroundImage.HandleWMEraseBkgnd(AClient: TWinControl; var Msg: TMessage): Boolean;
begin
  Result := FEnabled and FPictureValid;
  if Result then
  begin
    if not IsIconic(AClient.Handle) then
      if not TWinControlAccessProtected(AClient).FDoubleBuffered or (Msg.wParam = Msg.lParam) then
        DoEraseBackground(AClient,
          TWMEraseBkgnd(Msg).DC);
    Msg.Result := 1;
  end;
end;

function TJvBackgroundImage.HandleWMPaint(AClient: TWinControl; var Msg: TMessage): Boolean;
var
  DC, MemDC: HDC;
  MemBitmap, OldBitmap: HBITMAP;
  PS: TPaintStruct;
  ClientRect: TRect;
begin
  Result := False;
  if FEnabled and FPictureValid then
    if TWinControlAccessProtected(AClient).FDoubleBuffered and (TWMPaint(Msg).DC = 0) then
    begin
      DC := GetDC(HWND_DESKTOP);
      ClientRect := AClient.ClientRect;
      MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom);
      ReleaseDC(HWND_DESKTOP, DC);
      MemDC := CreateCompatibleDC(HDC_DESKTOP);
      OldBitmap := SelectObject(MemDC, MemBitmap);
      try
        DC := BeginPaint(AClient.Handle, PS);
        DoEraseBackground(AClient, MemDC);
        Msg.Result := AClient.Perform(WM_PAINT, MemDC, 0);
        BitBlt(DC, 0, 0, ClientRect.Right, ClientRect.Bottom, MemDC, 0, 0, SRCCOPY);
        EndPaint(AClient.Handle, PS);
      finally
        SelectObject(MemDC, OldBitmap);
        DeleteDC(MemDC);
        DeleteObject(MemBitmap);
      end;
      Result := True;
    end;
end;

procedure TJvBackgroundImage.TileGraphic(AClient: TControl; Graphic: TGraphic);
var
  I, J: Integer;
  iMin: Integer;
  FirstVisibleRow, S, OddShift: Integer;
  Left, Top, Width, Height: Integer;
  HorzOffset, VertOffset: Integer;
begin
  with GetClientRect(AClient) do
  begin
    Width := Right;
    Height := Bottom;
  end;
  if IsMDIForm(AClient) then
  begin
    HorzOffset := FHorzOffset;
    VertOffset := FVertOffset;
  end
  else
    with GetVirtualClientRect(AClient) do
    begin
      HorzOffset := Left;
      VertOffset := Top;
    end;
  if FShiftMode = smRows then
  begin
    FirstVisibleRow := -VertOffset div FTileHeight;
    if VertOffset > 0 then
      Dec(FirstVisibleRow);
  end
  else
  begin
    FirstVisibleRow := -HorzOffset div FTileWidth;
    if HorzOffset > 0 then
      Dec(FirstVisibleRow);
  end;
  Left := TrimmedOffset(HorzOffset, FTileWidth);
  Top := TrimmedOffset(VertOffset, FTileHeight);
  Dec(Width, Left);
  Dec(Height, Top);

  OddShift := 0; // just to satisfy the compiler
  if FShiftMode = smRows then
  begin
    if FZigZag then
    begin
      OddShift := FTileWidth div 2;
      if Odd(FirstVisibleRow) then
        S := OddShift
      else
        S := 0;
    end
    else
    begin
      S := (FirstVisibleRow * FShift) mod FTileWidth;
      if S < 0 then
        Inc(S, FTileWidth);
    end;
    for J := 0 to (Height - 1) div FTileHeight do
    begin
      if S = 0 then
        iMin := 0
      else
        iMin := -1;
      for I := iMin to (Width - 1) div FTileWidth do
        Canvas.Draw(Left + I * FTileWidth + S, Top + J * FTileHeight, Graphic);
      if FZigZag then
        S := S xor OddShift
      else
      begin
        Inc(S, FShift);
        S := S mod FTileWidth;
      end;
    end;
  end
  else
  begin
    if FZigZag then
    begin
      OddShift := FTileHeight div 2;
      if Odd(FirstVisibleRow) then
        S := OddShift
      else
        S := 0;
    end
    else
    begin
      S := (FirstVisibleRow * FShift) mod FTileHeight;
      if S < 0 then
        Inc(S, FTileHeight);
    end;
    for I := 0 to (Width - 1) div FTileWidth do
    begin
      if S = 0 then
        iMin := 0
      else
        iMin := -1;
      for J := iMin to (Height - 1) div FTileHeight do
        Canvas.Draw(Left + I * FTileWidth, Top + J * FTileHeight + S, Graphic);
      if FZigZag then
        S := S xor OddShift
      else
      begin
        Inc(S, FShift);
        S := S mod FTileHeight;
      end;
    end;
  end;
end;

procedure TJvBackgroundImage.PaintGraphic(AClient: TControl; DC: HDC; Graphic: TGraphic);
var
  R, Rg: TRect;
  X, Y, W, H: Integer;
  SaveIndex: Integer;
  WindowStyle: DWORD;
  GraphW, GraphH: Integer;
  Factor, FactorVert: Single;
begin
  SaveIndex := SaveDC(DC);
  with Canvas do
  begin
    Handle := DC;
    if FMode = bmTile then
      TileGraphic(AClient, Graphic)
    else
    begin
      if IsMDIForm(AClient) then
      begin
        R := GetClientRect(AClient);
        // We don't want the background move
        // when scrollbars appear or disappear:
        WindowStyle := GetWindowLong(TForm(AClient).ClientHandle, GWL_STYLE);
        if (WindowStyle and WS_HSCROLL) <> 0 then
          Inc(R.Bottom, GetSystemMetrics(SM_CYHSCROLL));
        if (WindowStyle and WS_VSCROLL) <> 0 then
          Inc(R.Right, GetSystemMetrics(SM_CXVSCROLL));
      end
      else
        R := GetVirtualClientRect(AClient);
      W := R.Right - R.Left;
      H := R.Bottom - R.Top;
      GraphW := Graphic.Width;
      GraphH := Graphic.Height;
      if FFitPictureSize and not (FMode = bmStretch) then
      begin
        Factor := W / GraphW;
        FactorVert := H / GraphH;
        if FactorVert < Factor then
          Factor := FactorVert;
        GraphW := Round(Factor * GraphW);
        GraphH := Round(Factor * GraphH);
      end;
      Rg := Rect(0, 0, GraphW, GraphH);
      Brush := GetClientBrush(AClient);
      case FMode of
        bmCenter:
          begin
            X := R.Left + (W - GraphW) div 2;
            Y := R.Top + (H - GraphH) div 2;
            FillRect(Rect(R.Left, R.Top, R.Right, Y));
            FillRect(Rect(R.Left, Y, X, Y + GraphH));
            FillRect(Rect(X + GraphW, Y, R.Right, Y + GraphH));
            FillRect(Rect(R.Left, Y + GraphH, R.Right, R.Bottom));
            OffsetRect(Rg, X, Y);
          end;
        bmStretch:
          Rg := R;
        bmTopLeft:
          begin
            FillRect(Rect(R.Left + GraphW, R.Top, R.Right, R.Top + GraphH));
            FillRect(Rect(R.Left, R.Top + GraphH, R.Right, R.Bottom));
            OffsetRect(Rg, R.Left, R.Top);
          end;
        bmTopRight:
          begin
            FillRect(Rect(R.Left, R.Top, R.Right - GraphW, R.Top + GraphH));
            FillRect(Rect(R.Left, R.Top + GraphH, R.Right, R.Bottom));
            OffsetRect(Rg, R.Right - GraphW, R.Top);
          end;
        bmBottomLeft:
          begin
            FillRect(Rect(R.Left, R.Top, R.Right, R.Bottom - GraphH));
            FillRect(Rect(R.Left + GraphW, R.Bottom - GraphH, R.Right, R.Bottom));
            OffsetRect(Rg, R.Left, R.Bottom - GraphH);
          end;
        bmBottomRight:
          begin
            FillRect(Rect(R.Left, R.Top, R.Right, R.Bottom - GraphH));
            FillRect(Rect(R.Left, R.Bottom - GraphH, R.Right - GraphW, R.Bottom));
            OffsetRect(Rg, R.Right - GraphW, R.Bottom - GraphH);
          end;
        bmTop:
          begin
            X := R.Left + (W - GraphW) div 2;
            FillRect(Rect(R.Left, R.Top, X, GraphH));
            FillRect(Rect(X + GraphW, R.Top, R.Right, GraphH));
            FillRect(Rect(R.Left, R.Top + GraphH, R.Right, R.Bottom));
            OffsetRect(Rg, X, R.Top);
          end;
        bmLeft:
          begin
            Y := R.Top + (H - GraphH) div 2;
            FillRect(Rect(R.Left, R.Top, R.Right, Y));
            FillRect(Rect(R.Left + GraphW, Y, R.Right, Y + GraphH));
            FillRect(Rect(R.Left, Y + GraphH, R.Right, R.Bottom));
            OffsetRect(Rg, R.Left, Y);
          end;
        bmBottom:
          begin
            X := R.Left + (W - GraphW) div 2;
            Y := R.Bottom - GraphH;
            FillRect(Rect(R.Left, R.Top, R.Right, Y));
            FillRect(Rect(R.Left, Y, X, R.Bottom));
            FillRect(Rect(X + GraphW, Y, R.Right, R.Bottom));
            OffsetRect(Rg, X, Y);
          end;
        bmRight:
          begin
            X := R.Right - GraphW;
            Y := R.Top + (H - GraphH) div 2;
            FillRect(Rect(R.Left, R.Top, R.Right, Y));
            FillRect(Rect(R.Left, Y, X, Y + GraphH));
            FillRect(Rect(R.Left, Y + GraphH, R.Right, R.Bottom));
            OffsetRect(Rg, X, Y);
          end;
      end;
      StretchDraw(Rg, Graphic);
    end;
    Handle := 0;
  end;
  RestoreDC(DC, SaveIndex);
end;

function TJvBackgroundImage.DoEraseBackground(AClient: TWinControl; DC: HDC): Boolean;
var
  Graphic: TGraphic;
  Bmp: TBitmap;
begin
  Result := FPictureValid and AClient.HandleAllocated;
  if Result then
  begin
    Bmp := nil;
    try
      Graphic := FWorkingBmp;
      if Graphic = nil then
        Graphic := FPicture.Graphic
      else
      if Transparent then
      begin
        Bmp := TBitmap.Create;
        Bmp.Assign(Graphic);
        Bmp.Canvas.Brush := GetClientBrush(AClient);
        Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
        Bmp.Canvas.Draw(0, 0, Graphic);
        Bmp.Transparent := False;
        Graphic := Bmp;
      end;
      PaintGraphic(AClient, DC, Graphic);
    finally
      Bmp.Free;
    end;
  end;
end;

function TJvBackgroundImage.GetTransparentColor: TColor;
var
  Bmp: TBitmap;
begin
  Bmp := nil;
  if FTransparentColor = clDefault then
    {$IFDEF HANDLES_GIF}
    if FPicture.Graphic is TGIFImage then
      Bmp := TGIFImage(FPicture.Graphic).Bitmap
    else
    {$ENDIF HANDLES_GIF}
    if FPicture.Graphic is TBitmap then
      Bmp := TBitmap(FPicture.Graphic);
  if Assigned(Bmp) then
  begin
    if Bmp.Monochrome then
      Result := clWhite
    else
      Result := Bmp.Canvas.Pixels[0, Bmp.Height - 1];
  end
  else
    Result := ColorToRGB(FTransparentColor);
  Result := Result or $02000000;
end;

procedure TJvBackgroundImage.PictureChanged(Sender: TObject);
begin
  if FInUpdWorkingBmp then
    Exit;
  FPictureValid := (FPicture.Width > 0) and (FPicture.Height > 0);
  if (FTileWidth < Picture.Width) or (FTileHeight < Picture.Height) or (AutoSizeTile and FPictureValid) then
  begin
    FTileWidth := Picture.Width;
    FTileHeight := Picture.Height;
  end;
  with Picture do
    if Graphic <> nil then
      Graphic.Transparent := FTransparent;
  UpdateWorkingBmp;
end;

procedure TJvBackgroundImage.SetAutoSizeTile(Value: Boolean);
begin
  if FAutoSizeTile <> Value then
  begin
    FAutoSizeTile := Value;
    if Mode = bmTile then
      if (TileWidth <> Picture.Width) or (TileHeight <> Picture.Height) then
        PictureChanged(Self);
  end;
end;

procedure TJvBackgroundImage.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    Changed;
  end;
end;

procedure TJvBackgroundImage.SetFitPictureSize(Value: Boolean);
begin
  if FFitPictureSize <> Value then
  begin
    FFitPictureSize := Value;
    if not (FMode in [bmTile, bmStretch]) then
      Changed;
  end;
end;

procedure TJvBackgroundImage.SetMode(Value: TJvBackgroundMode);
var
  TileModeChanged: Boolean;
begin
  if Value <> FMode then
  begin