unit DesktopImage;

{------------------------------------------------------------------------------}
{              TImage that holds a current shot of your desktop.               }
{                                                                              }
{ version: 2.0                                                                 }
{                                                                              }
{ by: blert ( blert at blertdiscorporated dot com )                            }
{ by: Aaangel ( aaangel at aaangel dot net )                                    }
{ last update: Sep 10, 2019                                                     }
{                                                                              }
{ usage:                                                                       }
{  - Call GetDesktopColor to update the background color to the current color  }
{     of the the desktop background. (Function now automated)                  }
{  - Set GridSpace and GridLineColor.                                          }
{  - Set ShowGrid to toggle drawing of the grid.                               }
{  - Call RefreshDesktopImage to update to the current desktop image.          }
{    (no longer needed repaint overriden to do this automatically)             }
{  - Use Width, Height or Filename properties to get info about the wallpaper  }
{                                                                              }
{------------------------------------------------------------------------------}

{------------------------------------------------------------------------------}
{                              *** Change Log ***                              }
{                                                                              }
{   v1.0                                                                       }
{   - first incarnation                                                        }
{                                                                              }
{   v1.1                                                                       }
{   - added ShowGrid property                                                  }
{   - added GridSpace property                                                 }
{   - added GridLineColor property                                             }
{                                                                              }
{   v1.2 --> Upgrade by Aaangel                                                }
{   - added multi monitor supports                                             }
{   - component reads screen sizes on create                                   }
{   - created an enumerator for background instead of confusing numbers        }
{   - rewritten grid code to allow dots instead of lines                       }
{   - rewritten refreshdesktop procedure to work with stretch and tile modes   }
{   - added desktopcolor into the frame of the image, if any                   }
{   - overriden repaint procedure so the image updates automatically           }
{     (no more empty boxes in the middle of the image)                         }
{   - refreshdesktop procedure now creates on bitmap and writes on that        }
{     instead of merging several bitmaps (should work faster)                  }
{   - refreshdesktop procedure has been optimized and cleaned up               }
{                                                                              }
{   v1.3 --> Upgrade by Aaangel                                                }
{   - No longer saves the developers desktop into the exe file                 }
{                                                                              }
{   v1.4 --> Upgrade by Aaangel                                                }
{   - Now works with jpg desktop images (Vista Upgrade)                        }
{                                                                              }
{   v2.0 --> Win10 Upgrade by Blackstar                                        }
{   - Desktop dimension recalcuated to allow for multiple screens on top of    }
{     each other. Previous version would only calculate screen next to each    }
{     other as opposed to screen on top of one another                         }
{   - Now supports PNG (Using PNGImage)                                        }
{   - Will now crash with an error message not supporting desktop img format   }
{     (if the fileextesion is not JPG, PNG or BMP)                             }
{   - Now exports the wallpaper filename in the property filename              }                                        
{------------------------------------------------------------------------------}
// Note that Windows10 wallpaper style Fill and Span are working rather weird
// sometimes it will work and not at other times

interface

uses
  Windows, SysUtils, Classes, ExtCtrls, Registry, PNGImage, Graphics,
  Filter;

type
  TBackgroundStyle = (bsCenter, bsTile, bsStretch, bsFit, bsFill, bsSpan);
  TDesktopImage = class(TImage)
  private
    fFilename: string;
    fShowGrid: boolean;
    fGridLineColor: TColor;
    fShowDot: boolean;
    FGridSpaceX: integer;
    FGridSpaceY: integer;
    FStyle: TBackgroundStyle;
    procedure SetGridLineColor(const Value: TColor);
    procedure SetShowGrid(const Value: boolean);
    procedure SetShowDot(const Value: boolean);
    procedure SetGridSpaceX(const Value: integer);
    procedure SetGridSpaceY(const Value: integer);
    procedure SetGridSpace(const Value: Integer);
    function GetGridSpace: Integer;
    procedure BuildDesktopImage(bkStyle: TBackgroundStyle; DesktopImg: TBitmap; var OutPutBMP: TBitmap);
    Function CalculateRect(style: TBackGroundStyle; DesktopImg: TBitmap): TRect;
    function GetScaleToWidthRect(style: TBackGroundStyle; DesktopImg: TBitmap; CanCropHeight: Boolean): TRect;
    function GetScaleToHeightRect(style: TBackGroundStyle; DesktopImg: TBitmap; CanCropWidth: Boolean): TRect;
    { Private declarations }
  protected
    { Protected declarations }
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    procedure LoadDesktopSize;
    procedure RefreshDesktopImage;
    function GetDesktopColor: TColor;
    procedure Repaint; override;
    function StyleToStr(style: TBackgroundStyle): String;
  published
    { Published declarations }
    property ShowGrid: boolean read FShowGrid write SetShowGrid;
    property GridLineColor: TColor read FGridLineColor write SetGridLineColor;
    property GridSpaceX: integer read FGridSpaceX write SetGridSpaceX;
    property GridSpaceY: integer read FGridSpaceY write SetGridSpaceY;
    property GridSpace: Integer read GetGridSpace write SetGridSpace;
    Property ShowDot: boolean read fShowDot write SetShowDot;
    property Filename: string read fFilename;
    Property WallpaperStyle: TBackgroundStyle read fStyle;
  end;

procedure Register;

implementation

uses Math, forms, jpeg, Win32Dlg;

procedure Register;
begin
  RegisterComponents('blert Tools', [TDesktopImage]);
end;

{ TDesktopImage }

procedure TDesktopImage.repaint;
begin
  inherited;
  RefreshDesktopImage;
end;

procedure TDesktopImage.SetGridLineColor(const Value: TColor);
begin
  fGridLineColor := Value;
end;

procedure TDesktopImage.SetShowDot(const Value: boolean);
begin
  fShowDot := Value;
  RefreshDesktopImage;
end;

procedure TDesktopImage.SetShowGrid(const Value: boolean);
begin
  fShowGrid := Value;
  RefreshDesktopImage;
end;

function TDesktopImage.StyleToStr(style: TBackgroundStyle): String;
begin
 Result := 'Unknown';
 Case style of
  bsCenter: Result := 'Center';
  bsTile: Result := 'Tile';
  bsStretch: Result := 'Stretch';
  bsFit: Result := 'Fit';
  bsFill: Result := 'Fill';
  bsSpan: Result := 'Span';
 end;
end;

procedure TDesktopImage.SetGridSpaceX(const Value: integer);
begin
  FGridSpaceX := Value;
  RefreshDesktopImage;
end;

procedure TDesktopImage.SetGridSpaceY(const Value: integer);
begin
  FGridSpaceY := Value;
  RefreshDesktopImage;
end;

procedure TDesktopImage.SetGridSpace(const Value: Integer);
begin
 FGridSpaceX := Value;
 FGridSpaceY := Value;
 RefreshDesktopImage;
end;

function TDesktopImage.GetGridSpace: Integer;
begin
 Result := GridSpaceX;
end;

constructor TDesktopImage.Create(Owner: TComponent);
begin
  inherited;
  ShowGrid := false;
  GridLineColor := clGray;
  GridSpaceX := 60;
  GridSpaceY := 60;
  LoadDesktopSize;
end;

destructor TDesktopImage.Destroy;
begin

  inherited;
end;

function TDesktopImage.GetDesktopColor: TColor;
var
  reg: TRegistry;
  bkColor: shortstring;
  r, g, b: cardinal;
begin
  Result := clBlack;
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    if reg.OpenKey('\Control Panel\Colors', false) then
      begin
        bkColor := reg.ReadString('Background');
        reg.CloseKey;
        r := StrToInt(GetFilt(bkColor, 1, ' ', false));
        g := StrToInt(GetFilt(bkColor, 2, ' ', false));
        b := StrToInt(GetFilt(bkColor, 3, ' ', false));
        Result := RGB(r,g,b);
      end;
  finally
    FreeAndNil(reg);
  end;
end;

procedure TDesktopImage.LoadDesktopSize;
Var
 I: Integer;
 Screen: TScreen;
begin
  Screen := TScreen.Create(nil);

  // Attempt to Calc size (theory, as I don't own a multi monitor setup
  Width := 0;
  height := 0;
  For I := 0 to Screen.MonitorCount - 1 do begin
   If Screen.Monitors[I].Top = 0 then begin
    // If screen is topmost then add width to overall
    Width := Width + Screen.Monitors[I].Width;
   end;
   If Screen.Monitors[I].Left = 0 then begin
    // If screen is leftmost then add height to overall
    Height := Height + Screen.Monitors[I].Height;
   end;
  end;

  // Potential error correction
  if Width = 0 then begin
   Width := 0;
   For I := 0 to Screen.MonitorCount - 1 do begin
    Width := Width + Screen.Monitors[I].Width;
   end;
  End;
  If Height = 0 then begin
   // Defaulting to single monitor height
   height := Screen.Height;
  end;

  FreeAndnil(screen);

  // Routine is untested as I don't have a multimonitor setup
end;

Procedure TDesktopImage.RefreshDesktopImage;
var
  reg: TRegistry;
  bkImage: shortstring;
  tileBMP, bkBmp: TBitmap;
  Pic: TPicture;
  PNG: TPNGObject;
  bkStyle: TBackgroundStyle;
  s, t: string;
  x, y, gridX, gridY, i, j: integer;
  Handled: boolean;
begin
  Handled := False;
  If (csDesigning in ComponentState) Then exit;
  LoadDesktopSize;
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    bkStyle := bsCenter;
    if reg.OpenKey('\Control Panel\Desktop', false) then
      begin
        bkImage := reg.ReadString('Wallpaper');
        fFilename := bkImage;
        t := reg.ReadString('TileWallpaper');
        s := reg.ReadString('WallpaperStyle');
         // From Windows 10 - WallpaperStyle = 10 (Fill), 6 (Fit), 2 (Stretch), 0 (Tile), 0 (Center)
        case StrToInt(s) of
         0: Begin
              If t = '1' then bkStyle := bsTile
               else bkStyle := bsCenter;
            End;
         2: bkStyle := bsStretch;
         6: bkStyle := bsFit;
         10: bkStyle := bsFill;
         22: bkStyle := bsSpan;
         else begin
          // Old style code
          if t = '1' then bkStyle := bstile
           else if s = '0' then bkStyle := bsCenter
            else bkStyle := bsStretch;
         end;
        end;
        FStyle := bkStyle;
        reg.CloseKey;
      end;
  finally
    FreeAndNil(reg);
  end;
  // create and fill with desktopcolor
  bkBmp := TBitmap.Create;
  bkBMP.Width := width;
  bkBMP.Height := height;
  bkBmp.Canvas.Brush.Color := GetDesktopColor;
  bkBMP.Canvas.Pen.color := bkbmp.canvas.Brush.Color;
  bkbmp.Canvas.FillRect(rect(0,0,width,height));
  if FileExists(bkImage) then begin
   // not used for tile, but I wanna keep the resources to a minimum, so I'm reusing it
   TileBMP := TBitMap.Create;
   if (uppercase(extractfileext(bkImage)) = '.JPG') or (uppercase(extractfileext(bkImage)) = '.JPEG') then begin
    Pic := TPicture.Create;
    Pic.LoadFromFile(bkImage);
    TileBMP.Width := Pic.Width;
    TileBMP.Height := Pic.Height;
    TileBMP.Canvas.Draw(0,0,Pic.Graphic);
    Handled := true;
   end;
  end;
  if (uppercase(extractfileext(bkimage)) = '.PNG') then begin
   PNG := TPNGObject.Create;
   PNG.LoadFromFile(bkimage);
   TileBMP.Width := PNG.Width;
   TileBMP.Height := PNG.Height;
   TileBMP.Canvas.Draw(0, 0, PNG);
   Handled := true;
  End;
  if (uppercase(extractfileext(bkimage)) = '.BMP') then begin
   TileBMP.LoadFromFile(bkImage);
   Handled := true;
  end;
  if not Handled then begin
   Error('ERROR!' + #13#10 + '------' + #13#10 + 'Unsupported Wallpaper graphics file format' + #13#10 +
         'Current Format = ' + extractfileext(bkimage) + #13#10 +
         'Supported formats are BMP, JPG && PNG');
   Application.Terminate;
  end;

  BuildDesktopImage(bkStyle, TileBMP, bkBmp);


  Freeandnil(Tilebmp);
  If ShowGrid then begin
   bkbmp.Canvas.Pen.Color := GridLineColor;
   gridX := bkBmp.Width div GridSpaceX;
   gridY := bkBmp.Height div GridSpaceY;
   If ShowDot then begin
    for X := 0 to gridX do begin
     For Y := 0 to GridY do begin
      bkbmp.Canvas.MoveTo(X * GridSpaceX, Y * GridSpaceY);
      bkbmp.Canvas.LineTo(X * GridSpaceX + 1, Y * GridSpaceY);
     end;
    end;
   end
    else
   begin
    j := GridSpaceX;
    for i := 0 to gridX do begin
     bkBmp.Canvas.MoveTo(j, 0);
     bkBmp.Canvas.LineTo(j, bkBmp.Height);
     Inc(j, GridSpaceX);
    end;
    j := GridSpaceY;
    for i := 0 to gridY do begin
     bkBmp.Canvas.MoveTo(0, j);
     bkBmp.Canvas.LineTo(bkBmp.Width, j);
     Inc(j, GridSpaceY);
    end;
   end;
  end;
  Picture.Graphic := bkBmp;
  FreeAndNil(bkBmp);
end;

procedure TDesktopImage.BuildDesktopImage(bkStyle: TBackgroundStyle;
  DesktopImg: TBitmap; var OutPutBMP: TBitmap);
var
 X, Y: Integer;
 graphic: TBitmap;
 ARect: TRect;
begin

  Case bkstyle of
   bsCenter: begin
              X := (OutPutBMP.Width div 2) - (DesktopImg.Width div 2);
              Y := (OutPutBMP.height div 2) - (DesktopImg.Height div 2);
              OutPutBMP.Canvas.Draw(x, y, DesktopImg);
             end;
   bsStretch: Begin
               OutPutBMP.Canvas.StretchDraw(rect(0,0,width,height), DesktopImg);
              end;
   bsTile: begin
            for x := 0 to (Width div DesktopImg.Width) do begin
             for y := 0 to (Height div DesktopImg.Height) do begin
              OutPutBMP.Canvas.Draw(x * DesktopImg.Width, y * DesktopImg.Height, DesktopImg);
             end;
            end;
           end;
   else begin
    aRect := CalculateRect(bkStyle, DesktopImg);

    graphic := TBitMap.Create;
    graphic.Width := aRect.Right;
    graphic.Height := aRect.Bottom;

    graphic.Canvas.StretchDraw(Rect(0, 0, graphic.Width, graphic.Height), DesktopImg);

    OutPutBMP.Canvas.Draw(aRect.Left, aRect.Top, graphic);
    graphic.Free;
   end;
  end;

end;

function TDesktopImage.CalculateRect(style: TBackGroundStyle;
  DesktopImg: TBitmap): TRect;
begin
 // Here are my new findings in terms of functionality.
 // Monitor Size = 2560x1440
 //
 // Using an image .
 // Dimensions: 924x337 and a rotate 90 degrees version (337x924)
 //
 // Dimensions: 924x337
 // Fill: Scales the picture height to match the screen size. Width goes beyond screen on both sides.
 // Span: Span does the same as fill
 // Fit: Scales the picture width to match the screen size. Height doesn't go beyond borders
 //
 // Dimensions: 337x924
 // Fill: Scales the picture width to match the screen size. Height goes beyond screen on both sides
 // Span: It zooms in even further, and repositions the center placement. So fucking clue to be honest
 // Fit: Scales the picture height to match the screen size. Width doesn't go beyond borders
 //
 // Conclusions
 // Fill: Takes the smallest dimension of the image (width or height) and streches it to match the according screen dimension
 // Span: After testing with other dimensions it appears to
 //       Resize to match screen width
 // Fit: Takes the largest dimension of the image (width or height) and streches it to match the according screen dimension
 //
 // After some further testing Span appears to mostly do the same as fill, with the exception that it sometimes alters the
 // center position slightly. I will treat Span and Fill as the same as I cannot really spot an actual difference.

 //         6: bkStyle := bsFit;
 //        10: bkStyle := bsFill;
 //        22: bkStyle := bsSpan;


 // Can't see a difference between Fill and Span - Treating Span as Fill

 if Style = bsSpan then Style := bsFill;


 case style of
   bsFill: begin
            If DesktopImg.Width < DesktopImg.Height then begin
             Result := GetScaleToWidthRect(style, DesktopImg, True);
            end
             else
            begin
             Result := GetScaleToHeightRect(Style, DesktopImg, True);
            end;
           end;
   else
  begin
   // Fit
   If DesktopImg.Width < DesktopImg.Height then begin
    Result := GetScaleToHeightRect(style, DesktopImg, false);
   end
    else
   begin
    Result := GetScaleToWidthRect(style, DesktopImg, false);
   end;
  end;
 end;

end;

function TDesktopImage.GetScaleToHeightRect(style: TBackGroundStyle;
  DesktopImg: TBitmap; CanCropWidth: Boolean): TRect;
Var
 Ratio: Double;
 X, Y, W, H: Integer;
begin
 // Set H & W
 Ratio := DesktopImg.Width / DesktopImg.Height;
 H := Height;
 W := Round(H * Ratio);

 If (style = bsFill) and (W < Width) then begin
  Result := GetScaleToWidthRect(style, DesktopImg, true);
  exit;
 end;

 // Set X, Y
 X := (Width div 2) - (W div 2);
 Y := 0;

 // Check for cropping
 If (Not CanCropWidth) and (W > Width) then begin
  Result := GetScaleToWidthRect(Style, DesktopImg, true);
  Exit;
 end;

 // Set results
 Result.TopLeft := Point(X, Y);
 Result.BottomRight := Point(W, H);
end;

function TDesktopImage.GetScaleToWidthRect(style: TBackGroundStyle;
  DesktopImg: TBitmap; CanCropHeight: Boolean): TRect;
Var
 Ratio: Double;
 X, Y, W, H: Integer;
begin
 // Set H & W
 Ratio := DesktopImg.Height / DesktopImg.Width;
 W := Width;
 H := Round(W * Ratio);

 If (style = bsFill) and (H < Height) then begin
  Result := GetScaleToHeightRect(style, DesktopImg, true);
  exit;
 end;


 // Set X, Y
 X := 0;
 Y := (height div 2) - (H div 2);

 // Check for cropping
 If (Not CanCropHeight) and (H > Height) then begin
  Result := GetScaleToHeightRect(Style, DesktopImg, true);
  Exit;
 end;

 // Set results
 Result.TopLeft := Point(X, Y);
 Result.BottomRight := Point(W, H);
end;

end.
