jvbackgrounds.pas

East make Tray Icon in delphi

    TileModeChanged := (FMode = bmTile) or (Value = bmTile);
    FMode := Value;
    if TileModeChanged and ((FTileWidth <> Picture.Width) or (FTileHeight <> Picture.Height)) then
      PictureChanged(Self)
    else
      Changed;
  end;
end;

procedure TJvBackgroundImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

procedure TJvBackgroundImage.SetShift(Value: Integer);
begin
  if Value <> FShift then
  begin
    FShift := Value;
    FZigZag := False;
    if FMode = bmTile then
      Changed;
  end;
end;

procedure TJvBackgroundImage.SetShiftMode(Value: TJvBackgroundShiftMode);
begin
  if FShiftMode <> Value then
  begin
    FShiftMode := Value;
    if FMode = bmTile then
      Changed;
  end;
end;

procedure TJvBackgroundImage.SetTileWidth(Value: Integer);
begin
  if AutoSizeTile then
    Exit;
  if Value < Picture.Width then
    Value := Picture.Width;
  if Value <> FTileWidth then
  begin
    FTileWidth := Value;
    if Mode = bmTile then
      PictureChanged(Self);
  end;
end;

procedure TJvBackgroundImage.SetTileHeight(Value: Integer);
begin
  if AutoSizeTile then
    Exit;
  if Value < Picture.Height then
    Value := Picture.Height;
  if Value <> FTileHeight then
  begin
    FTileHeight := Value;
    if Mode = bmTile then
      PictureChanged(Self);
  end;
end;

procedure TJvBackgroundImage.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
    FTransparent := Value;
    PictureChanged(Self);
  end;
end;

procedure TJvBackgroundImage.SetTransparentColor(Value: TColor);
begin
  if Value <> FTransparentColor then
  begin
    if Value = clDefault then
      FTransparentMode := tmAuto
    else
      FTransparentMode := tmFixed;
    FTransparentColor := Value;
    if Transparent then
      UpdateWorkingBmp;
  end;
end;

procedure TJvBackgroundImage.SetTransparentMode(Value: TTransparentMode);
begin
  if Value <> FTransparentMode then
  begin
    if Value = tmAuto then
      SetTransparentColor(clDefault)
    else
      SetTransparentColor(GetTransparentColor);
  end;
end;

procedure TJvBackgroundImage.SetZigZag(Value: Boolean);
begin
  if Value <> FZigZag then
  begin
    FZigZag := Value;
    if FMode = bmTile then
      Changed;
  end;
end;

function TJvBackgroundImage.TransparentColorStored: Boolean;
begin
  Result := FTransparentMode = tmFixed;
end;

{
  TJvBackgroundImage.UpdateWorkingBmp
  Transparency: all except TJPEGImage
  GrayMapping: all except TIcon, TMetafile
}

procedure TJvBackgroundImage.UpdateWorkingBmp;
var
  X, Y: Integer;
  IsBitmap: Boolean;
  Bmp: TBitmap;
  MaskBmp: TBitmap;
  {$IFNDEF NO_JPEG}
  GrayscaleState: Boolean;
  {$ENDIF !NO_JPEG}
  {$IFNDEF NO_JPEG}
  IsJPEG: Boolean;
  {$ENDIF !NO_JPEG}
  IsTransparent: Boolean;
  IsTranspGraphic: Boolean;
  IsIcon: Boolean;
  SizeTailored: Boolean;

  procedure DrawGraphic(Graphic: TGraphic);
  begin
    with FWorkingBmp.Canvas do
    begin
      Brush.Color := TransparentColor;
      FillRect(Rect(0, 0, FTileWidth, FTileHeight));
      Draw(X, Y, Graphic);
    end;
  end;

  function CreateTransparentBmp(Graphic: TGraphic): TBitmap;
  var
    W, H: Integer;
  begin
    Result := TBitmap.Create;
    if IsBitmap then
      Result.Assign(Graphic)
    else
    begin
      W := Graphic.Width;
      H := Graphic.Height;
      Result.Width := W;
      Result.Height := H;
      with Result.Canvas do
      begin
        Brush.Color := TransparentColor;
        FillRect(Rect(0, 0, W, H));
        Draw(0, 0, Graphic);
      end;
    end;
  end;

begin
  if FInUpdWorkingBmp then
    Exit;
  with FPicture do
    if Graphic <> nil then
    try
      FInUpdWorkingBmp := True;
      SizeTailored := False;
      X := 0;
      Y := 0;
      if FMode = bmTile then
      begin
        X := FTileWidth - Graphic.Width;
        Y := FTileHeight - Graphic.Height;
        SizeTailored := (X <> 0) or (Y <> 0);
        X := X div 2;
        Y := Y div 2;
      end;
      IsBitmap := (Graphic is TBitmap)
        // GIF goes as bitmap here
        {$IFDEF HANDLES_GIF} or (Graphic is TGIFImage) {$ENDIF};
      IsIcon := Graphic is TIcon;
      IsTranspGraphic := IsIcon or (Graphic is TMetafile);
      // if Graphic is transparent
      {$IFDEF NO_JPEG}
      IsTransparent := Transparent or IsTranspGraphic;
      {$ELSE}
      IsJPEG := Graphic is TJPEGImage;
      IsTransparent := (Transparent and not IsJPEG) or IsTranspGraphic;
      {$ENDIF NO_JPEG}
      if IsTransparent or FGrayMapped or SizeTailored then
      begin
        WorkingBmpNeeded;
        if IsTranspGraphic then
          with FWorkingBmp.Canvas do
          begin
            Brush.Color := TransparentColor;
            FillRect(Rect(0, 0, FTileWidth, FTileHeight));
            Draw(X, Y, Graphic);
          end
        else
        if IsTransparent then // and not IsTranspGraphic
        begin
          Bmp := CreateTransparentBmp(Graphic);
          try
            with TImageList.CreateSize(Graphic.Width, Graphic.Height) do
            try
              if FGrayMapped then
              begin
                MaskBmp := TBitmap.Create;
                with MaskBmp do
                try
                  Assign(Bmp);
                  Mask(GetTransparentColor);
                  MapGrays(Bmp, FPicture.Graphic);
                  Add(Bmp, MaskBmp);
                finally
                  Free;
                end;
              end
              else
                AddMasked(Bmp, GetTransparentColor);
              FWorkingBmp.HandleType := bmDDB; // otherwise eventually background color won't appear correctly
              with FWorkingBmp.Canvas do
              begin
                Brush.Color := TransparentColor;
                FillRect(Rect(0, 0, FTileWidth, FTileHeight));
              end;
              BkColor := ColorToRGB(TransparentColor);
              Draw(FWorkingBmp.Canvas, X, Y, 0);
            finally
              Free;
            end
          finally
            Bmp.Free;
          end
        end
        else
        if GrayMapped then // and not Transparent
        begin
          Bmp := TBitmap.Create;
          try
            {$IFNDEF NO_JPEG}
            if IsJPEG then
              with TJPEGImage(Graphic) do
              begin
                GrayscaleState := Grayscale;
                try
                  Grayscale := True;
                  Bmp.Assign(Graphic);
                finally
                  Grayscale := GrayscaleState;
                end;
              end;
            {$ENDIF !NO_JPEG}
            MapGrays(Bmp, FPicture.Graphic);
            DrawGraphic(Bmp);
          finally
            Bmp.Free;
          end
        end
        else // if SizeTailored
          DrawGraphic(Picture.Graphic);
        WorkingBmp.Transparent := Transparent;
        WorkingBmp.TransparentColor := TransparentColor;
        Changed;
        Exit;
      end;
    finally
      FInUpdWorkingBmp := False;
    end;
  FWorkingBmp.Free;
  FWorkingBmp := nil;
  Changed;
end;

procedure TJvBackgroundImage.WorkingBmpNeeded;
var
  W, H: Integer;
begin
  if FWorkingBmp = nil then
    FWorkingBmp := TBitmap.Create;
  if FMode = bmTile then
  begin
    W := FTileWidth;
    H := FTileHeight;
  end
  else
  begin
    W := FPicture.Graphic.Width;
    H := FPicture.Graphic.Height;
  end;
  FWorkingBmp.Width := W;
  FWorkingBmp.Height := H;
end;

class function TJvBackgroundImage.MainWindowHook(var Msg: TMessage): Boolean;
var
  I: Integer;
begin
  Result := False;
  if Msg.Msg = WM_SYSCOLORCHANGE then
  begin
    UpdateSysColorGradation;
    for I := 0 to Hooked.Count - 1 do
      TJvBackgroundImage(Hooked[I]).SysColorChange;
  end;
end;

procedure TJvBackgroundImage.HookMainWindow;
begin
  if Hooked = nil then
  begin
    Hooked := TList.Create;
    Application.HookMainWindow(MainWindowHook);
  end;
  if Hooked.IndexOf(Self) = -1 then
    Hooked.Add(Self);
end;

procedure TJvBackgroundImage.UnhookMainWindow;
begin
  Hooked.Remove(Self);
  if Hooked.Count = 0 then
  begin
    Application.UnhookMainWindow(MainWindowHook);
    Hooked.Free;
    Hooked := nil;
  end;
end;

procedure TJvBackgroundImage.SysColorChange;
begin
  if FGrayMapped then
    UpdateWorkingBmp;
end;

procedure TJvBackgroundImage.SetGrayMapped(Value: Boolean);
begin
  if Value <> FGrayMapped then
  begin
    if Value then
      SysColorsNeeded;
    FGrayMapped := Value;
    UpdateWorkingBmp;
  end;
end;

//=== { TJvControlBackground } ===============================================

constructor TJvControlBackground.Create(AClient: TWinControl);
begin
  inherited Create;
  FClient := AClient;
end;

function TJvControlBackground.HookBeforeMessage(var Msg: TMessage): Boolean;
begin
  Result := False;
  if FEnabled then
    case Msg.Msg of
      WM_PAINT:
        Result := HandleWMPaint(FClient, Msg);
      WM_ERASEBKGND:
        Result := HandleWMEraseBkgnd(FClient, Msg);
    end;
end;

procedure TJvControlBackground.HookAfterMessage(var Msg: TMessage);
begin
  if FEnabled then
    case Msg.Msg of
      WM_SIZE:
        if not (FMode in [bmTile, bmTopLeft]) then
          FClient.Invalidate;
      WM_HSCROLL:
        if FMode <> bmTile then
          FClient.Invalidate;
      WM_VSCROLL:
        if FMode <> bmTile then
          FClient.Invalidate;
    end;
end;

//=== { TJvBackgroundClientLink } ============================================

constructor TJvBackgroundClientLink.Create(ABackground: TJvBackground;
  AClient: TWinControl);
begin
  inherited Create;
  FBackground := ABackground;
  FNewWndProc := MakeObjectInstance(MainWndProc);
  ForceClient(AClient);
  ClientInvalidate;
end;

destructor TJvBackgroundClientLink.Destroy;
begin
  UnhookClient;
  if Assigned(FNewWndProc) then
    FreeObjectInstance(FNewWndProc);
  inherited Destroy;
end;

procedure TJvBackgroundClientLink.ClientInvalidate;
begin
  if not (csReading in FBackground.ComponentState) and not (csDestroying in FClient.ComponentState) then
    InvalidateRect(ClientHandle, nil, True);
end;

function GetMDIClientScrollDelta(ClientHandle: HWND; ScrollBar: Integer;
  const Msg: TWMScroll): Integer;
var
  ScrollInfo: TScrollInfo;
  Delta, MaxChange: Integer;
begin
  ScrollInfo.cbSize := SizeOf(ScrollInfo);
  ScrollInfo.fMask := SIF_ALL;
  GetScrollInfo(ClientHandle, ScrollBar, ScrollInfo);
  Delta := 0;
  case Msg.ScrollCode of
    SB_LINELEFT:
      begin
        Delta := ScrollInfo.nPos - ScrollInfo.nMin;
        if Delta > ScrollLineSize then
          Delta := ScrollLineSize;
      end;
    SB_LINERIGHT:
      with ScrollInfo do
      begin
        Delta := nPage - 1;
        if Delta < 0 then
          Delta := 0;
        Delta := nPos - (nMax - Delta);
        if Delta < -ScrollLineSize then
          Delta := -ScrollLineSize;
      end;
    SB_PAGELEFT:
      with ScrollInfo do
      begin
        Delta := nPage - 1;
        if Delta < 0 then
          Delta := 0;
        if Delta > nPos - nMin then
          Delta := nPos - nMin;
      end;
    SB_PAGERIGHT:
      with ScrollInfo do
      begin
        Delta := nPage - 1;
        if Delta < 0 then