jvjvclutils.pas

East make Tray Icon in delphi

{$IFDEF VisualCLX}
type
  TIconAccessProtected = class(TIcon);

function Icon2Bitmap(Ico: TIcon): TBitmap;
begin
  Result := TBitmap.Create;
  TIconAccessProtected(Ico).AssignTo(Result);
end;

function Bitmap2Icon(Bmp: TBitmap): TIcon;
begin
  Result := TIcon.Create;
  Result.Assign(Bmp);
end;
{$ENDIF VisualCLX}

{$IFDEF VCL}

function IconToBitmap(Ico: HICON): TBitmap;
var
  Pic: TPicture;
begin
  Pic := TPicture.Create;
  try
    Pic.Icon.Handle := Ico;
    Result := TBitmap.Create;
    Result.Height := Pic.Icon.Height;
    Result.Width := Pic.Icon.Width;
    Result.Canvas.Draw(0, 0, Pic.Icon);
  finally
    Pic.Free;
  end;
end;

function IconToBitmap2(Ico: HICON; Size: Integer = 32;
  TransparentColor: TColor = clNone): TBitmap;
begin
  // (p3) this seems to generate "better" bitmaps...
  with TImageList.CreateSize(Size, Size) do
  try
    Masked := True;
    BkColor := TransparentColor;
    ImageList_AddIcon(Handle, Ico);
    Result := TBitmap.Create;
    Result.PixelFormat := pf24bit;
    if TransparentColor <> clNone then
      Result.TransparentColor := TransparentColor;
    Result.Transparent := TransparentColor <> clNone;
    GetBitmap(0, Result);
  finally
    Free;
  end;
end;

function IconToBitmap3(Ico: HICON; Size: Integer = 32;
  TransparentColor: TColor = clNone): TBitmap;
var
  Icon: TIcon;
  Tmp: TBitmap;
begin
  Icon := TIcon.Create;
  Tmp := TBitmap.Create;
  try
    Icon.Handle := CopyIcon(Ico);
    Result := TBitmap.Create;
    Result.Width := Icon.Width;
    Result.Height := Icon.Height;
    Result.PixelFormat := pf24bit;
    // fill the bitmap with the transparent color
    Result.Canvas.Brush.Color := TransparentColor;
    Result.Canvas.FillRect(Rect(0, 0, Result.Width, Result.Height));
    Result.Canvas.Draw(0, 0, Icon);
    Result.TransparentColor := TransparentColor;
    Tmp.Assign(Result);
    //    Result.Width := Size;
    //    Result.Height := Size;
    Result.Canvas.StretchDraw(Rect(0, 0, Result.Width, Result.Height), Tmp);
    Result.Transparent := True;
  finally
    Icon.Free;
    Tmp.Free;
  end;
end;
{$ENDIF VCL}

procedure RGBToHSV(R, G, B: Integer; var H, S, V: Integer);
{$IFDEF VCL}
var
  Delta: Integer;
  Min, Max: Integer;

  function GetMax(I, J, K: Integer): Integer;
  begin
    if J > I then
      I := J;
    if K > I then
      I := K;
    Result := I;
  end;

  function GetMin(I, J, K: Integer): Integer;
  begin
    if J < I then
      I := J;
    if K < I then
      I := K;
    Result := I;
  end;

begin
  Min := GetMin(R, G, B);
  Max := GetMax(R, G, B);
  V := Max;
  Delta := Max - Min;
  if Max = 0 then
    S := 0
  else
    S := (255 * Delta) div Max;
  if S = 0 then
    H := 0
  else
  begin
    if R = Max then
      H := (60 * (G - B)) div Delta
    else
    if G = Max then
      H := 120 + (60 * (B - R)) div Delta
    else
      H := 240 + (60 * (R - G)) div Delta;
    if H < 0 then
      H := H + 360;
  end;
end;
{$ENDIF VCL}
{$IFDEF VisualCLX}
var
  QC: QColorH;
begin
  QC := QColor_create(R, G, B);
  QColor_getHsv(QC, @H, @S, @V);
  QColor_destroy(QC);
end;
{$ENDIF VisualCLX}

(* (rom) to be deleted. Use ScreenShot from JCL
{$IFDEF VCL}

function CaptureScreen(Rec: TRect): TBitmap;
const
  NumColors = 256;
var
  R: TRect;
  C: TCanvas;
  LP: PLogPalette;
  TmpPalette: HPALETTE;
  Size: Integer;
begin
  Result := TBitmap.Create;
  Result.Width := Rec.Right - Rec.Left;
  Result.Height := Rec.Bottom - Rec.Top;
  R := Rec;
  C := TCanvas.Create;
  try
    C.Handle := GetDC(HWND_DESKTOP);
    Result.Canvas.CopyRect(Rect(0, 0, Rec.Right - Rec.Left, Rec.Bottom -
      Rec.Top), C, R);
    Size := SizeOf(TLogPalette) + (Pred(NumColors) * SizeOf(TPaletteEntry));
    LP := AllocMem(Size);
    try
      LP^.palVersion := $300;
      LP^.palNumEntries := NumColors;
      GetSystemPaletteEntries(C.Handle, 0, NumColors, LP^.palPalEntry);
      TmpPalette := CreatePalette(LP^);
      Result.Palette := TmpPalette;
      DeleteObject(TmpPalette);
    finally
      FreeMem(LP, Size);
    end
  finally
    ReleaseDC(HWND_DESKTOP, C.Handle);
    C.Free;
  end;
end;

function CaptureScreen(IncludeTaskBar: Boolean): TBitmap;
var
  R: TRect;
begin
  if IncludeTaskBar then
    R := Rect(0, 0, Screen.Width, Screen.Height)
  else
    SystemParametersInfo(SPI_GETWORKAREA, 0, Pointer(@R), 0);
  Result := CaptureScreen(R);
end;

function CaptureScreen(WndHandle: Longword): TBitmap;
var
  R: TRect;
  WP: TWindowPlacement;
begin
  if GetWindowRect(WndHandle, R) then
  begin
    GetWindowPlacement(WndHandle, @WP);
    if IsIconic(WndHandle) then
      ShowWindow(WndHandle, SW_RESTORE);
    BringWindowToTop(WndHandle);
    Result := CaptureScreen(R);
    SetWindowPlacement(WndHandle, @WP);
  end
  else
    Result := nil;
end;
{$ENDIF VCL}
*)

{$IFDEF MSWINDOWS}

procedure SetWallpaper(const Path: string);
begin
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(Path), SPIF_UPDATEINIFILE);
end;

procedure SetWallpaper(const Path: string; Style: TJvWallpaperStyle);
begin
  with TRegistry.Create do
  begin
    OpenKey(RC_ControlRegistry, False);
    case Style of
      wpTile:
        begin
          WriteString(RC_TileWallpaper, '1');
          WriteString(RC_WallPaperStyle, '0');
        end;
      wpCenter:
        begin
          WriteString(RC_TileWallpaper, '0');
          WriteString(RC_WallPaperStyle, '0');
        end;
      wpStretch:
        begin
          WriteString(RC_TileWallpaper, '0');
          WriteString(RC_WallPaperStyle, '2');
        end;
    end;
    WriteString(RC_WallpaperRegistry, Path);
    Free;
  end;
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;

{$ENDIF MSWINDOWS}

procedure GetRBitmap(var Dest: TBitmap; const Source: TBitmap);
var
  I, J: Integer;
  Line: PJvRGBArray;
begin
  if not Assigned(Dest) then
    Dest := TBitmap.Create;
  Dest.Assign(Source);
  Dest.PixelFormat := pf24bit;
  for J := Dest.Height - 1 downto 0 do
  begin
    Line := Dest.ScanLine[J];
    for I := Dest.Width - 1 downto 0 do
    begin
      Line[I].rgbGreen := 0;
      Line[I].rgbBlue := 0;
    end;
  end;
  Dest.PixelFormat := Source.PixelFormat;
end;

procedure GetBBitmap(var Dest: TBitmap; const Source: TBitmap);
var
  I, J: Integer;
  Line: PJvRGBArray;
begin
  if not Assigned(Dest) then
    Dest := TBitmap.Create;
  Dest.Assign(Source);
  Dest.PixelFormat := pf24bit;
  for J := Dest.Height - 1 downto 0 do
  begin
    Line := Dest.ScanLine[J];
    for I := Dest.Width - 1 downto 0 do
    begin
      Line[I].rgbRed := 0;
      Line[I].rgbGreen := 0;
    end;
  end;
  Dest.PixelFormat := Source.PixelFormat;
end;

procedure GetGBitmap(var Dest: TBitmap; const Source: TBitmap);
var
  I, J: Integer;
  Line: PJvRGBArray;
begin
  if not Assigned(Dest) then
    Dest := TBitmap.Create;
  Dest.Assign(Source);
  Dest.PixelFormat := pf24bit;
  for J := Dest.Height - 1 downto 0 do
  begin
    Line := Dest.ScanLine[J];
    for I := Dest.Width - 1 downto 0 do
    begin
      Line[I].rgbRed := 0;
      Line[I].rgbBlue := 0;
    end;
  end;
  Dest.PixelFormat := Source.PixelFormat;
end;

procedure GetMonochromeBitmap(var Dest: TBitmap; const Source: TBitmap);
begin
  if not Assigned(Dest) then
    Dest := TBitmap.Create;
  Dest.Assign(Source);
  Dest.Monochrome := True;
end;

procedure GetHueBitmap(var Dest: TBitmap; const Source: TBitmap);
var
  I, J, H, S, V: Integer;
  Line: PJvRGBArray;
begin
  if not Assigned(Dest) then
    Dest := TBitmap.Create;
  Dest.Assign(Source);
  Dest.PixelFormat := pf24bit;
  for J := Dest.Height - 1 downto 0 do
  begin
    Line := Dest.ScanLine[J];
    for I := Dest.Width - 1 downto 0 do
      with Line[I] do
      begin
        RGBToHSV(rgbRed, rgbGreen, rgbBlue, H, S, V);
        rgbRed := H;
        rgbGreen := H;
        rgbBlue := H;
      end;
  end;
  Dest.PixelFormat := Source.PixelFormat;
end;

procedure GetSaturationBitmap(var Dest: TBitmap; const Source: TBitmap);
var
  I, J, H, S, V: Integer;
  Line: PJvRGBArray;
begin
  if not Assigned(Dest) then
    Dest := TBitmap.Create;
  Dest.Assign(Source);
  Dest.PixelFormat := pf24bit;
  for J := Dest.Height - 1 downto 0 do
  begin
    Line := Dest.ScanLine[J];
    for I := Dest.Width - 1 downto 0 do
      with Line[I] do
      begin
        RGBToHSV(rgbRed, rgbGreen, rgbBlue, H, S, V);
        rgbRed := S;
        rgbGreen := S;
        rgbBlue := S;
      end;
  end;
  Dest.PixelFormat := Source.PixelFormat;
end;

procedure GetValueBitmap(var Dest: TBitmap; const Source: TBitmap);
var
  I, J, H, S, V: Integer;
  Line: PJvRGBArray;
begin
  if not Assigned(Dest) then
    Dest := TBitmap.Create;
  Dest.Assign(Source);
  Dest.PixelFormat := pf24bit;
  for J := Dest.Height - 1 downto 0 do
  begin
    Line := Dest.ScanLine[J];
    for I := Dest.Width - 1 downto 0 do
      with Line[I] do
      begin
        RGBToHSV(rgbRed, rgbGreen, rgbBlue, H, S, V);
        rgbRed := V;
        rgbGreen := V;
        rgbBlue := V;
      end;
  end;