Skip to content

Update apscMain.pas #1

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
jasonjac2 wants to merge 2 commits into
base: main
Choose a base branch
from
Open

Update apscMain.pas #1

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
daf7730
Update apscMain.pas
jasonjac2 Feb 20, 2021
98628ab
Added only saving changed images
jasonjac2 Mar 6, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
12 changes: 11 additions & 1 deletion source/PeriodicScreenCapture.dproj
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{E65FFA47-74A6-4269-A6A7-2FA04CE08699}</ProjectGuid>
<ProjectVersion>19.1</ProjectVersion>
<ProjectVersion>19.2</ProjectVersion>
<FrameworkType>VCL</FrameworkType>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
Expand Down Expand Up @@ -271,6 +271,16 @@
<Operation>1</Operation>
</Platform>
</DeployClass>
<DeployClass Name="Android_LauncherIcon192">
<Platform Name="Android">
<RemoteDir>res\drawable-xxxhdpi</RemoteDir>
<Operation>1</Operation>
</Platform>
<Platform Name="Android64">
<RemoteDir>res\drawable-xxxhdpi</RemoteDir>
<Operation>1</Operation>
</Platform>
</DeployClass>
<DeployClass Name="Android_LauncherIcon36">
<Platform Name="Android">
<RemoteDir>res\drawable-ldpi</RemoteDir>
Expand Down
32 changes: 23 additions & 9 deletions source/apscMain.dfm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,7 @@ object Form15: TForm15
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Label2: TLabel
object lblBackGropIntro: TLabel
Left = 0
Top = 41
Width = 616
Expand All @@ -26,7 +26,7 @@ object Form15: TForm15
Caption =
'Automatically captures when minimized.'#13#13'Icons from https://icons' +
'8.com/'#13#13'Program by Jim McKeeth'#13'Uses Konopka Signature Components' +
#13'and Delphi 10.4.1'
#13'and Delphi 10.4.2'#13#10
Layout = tlCenter
ExplicitLeft = 272
ExplicitTop = 200
Expand All @@ -41,8 +41,8 @@ object Form15: TForm15
Align = alClient
Proportional = True
Stretch = True
ExplicitLeft = -6
ExplicitTop = 40
ExplicitLeft = 219
ExplicitTop = 225
end
object Panel1: TRzPanel
Left = 0
Expand Down Expand Up @@ -105,11 +105,10 @@ object Form15: TForm15
end
end
object RzPanel3: TRzPanel
Left = 209
Left = 328
Top = 7
Width = 530
Width = 411
Height = 27
Align = alClient
BorderOuter = fsNone
Color = 15987699
Padding.Left = 7
Expand All @@ -123,13 +122,14 @@ object Form15: TForm15
Align = alLeft
Caption = 'Path'
Layout = tlCenter
ExplicitHeight = 13
ExplicitLeft = 98
ExplicitTop = -3
end
object RzButtonEdit1: TRzButtonEdit
AlignWithMargins = True
Left = 38
Top = 3
Width = 489
Width = 370
Height = 21
Text = ''
Align = alClient
Expand Down Expand Up @@ -182,8 +182,21 @@ object Form15: TForm15
AltBtnWidth = 26
ButtonWidth = 26
OnButtonClick = RzButtonEdit1ButtonClick
ExplicitLeft = 134
ExplicitTop = 7
ExplicitWidth = 400
end
end
object chkOnlyChanges: TCheckBox
Left = 215
Top = 12
Width = 97
Height = 17
Caption = 'Only Changes'
Checked = True
State = cbChecked
TabOrder = 3
end
end
object RzPanel1: TRzPanel
Left = 616
Expand All @@ -203,6 +216,7 @@ object Form15: TForm15
ItemHeight = 13
TabOrder = 0
OnClick = ListBox1Click
ExplicitTop = -1
end
end
object Timer1: TTimer
Expand Down
74 changes: 61 additions & 13 deletions source/apscMain.pas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,8 +28,9 @@ TForm15 = class(TForm)
RzPanel2: TRzPanel;
RzPanel3: TRzPanel;
ApplicationEvents1: TApplicationEvents;
Label2: TLabel;
lblBackGropIntro: TLabel;
Image1: TImage;
chkOnlyChanges: TCheckBox;
procedure ListBox1Click(Sender: TObject);
procedure RzButton1Click(Sender: TObject);
procedure RzSpinEdit1Change(Sender: TObject);
Expand All @@ -41,8 +42,10 @@ TForm15 = class(TForm)
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
FLastBitmap : TBitmap;
procedure Capture;
procedure Clear;
procedure SavePnG(vBmp: TBitmap; vWhen: TDateTime);
public
{ Public declarations }
end;
Expand All @@ -56,6 +59,33 @@ implementation

uses System.IOUtils, Vcl.Imaging.pngimage, System.DateUtils;

//https://stackoverflow.com/questions/1352312/what-is-the-fastest-way-to-check-if-two-tbitmaps-are-the-same
function IsSameBitmap(Bitmap1, Bitmap2: TBitmap): Boolean;
var
Stream1, Stream2: TMemoryStream;
begin
// Assert((Bitmap1 <> nil) and (Bitmap2 <> nil), 'Params can''t be nil');
Result:= False;
if (Bitmap1 = nil) or (Bitmap2 = nil) then
Exit;
if (Bitmap1.Height <> Bitmap2.Height) or (Bitmap1.Width <> Bitmap2.Width) then
Exit;
Stream1:= TMemoryStream.Create;
try
Bitmap1.SaveToStream(Stream1);
Stream2:= TMemoryStream.Create;
try
Bitmap2.SaveToStream(Stream2);
if Stream1.Size = Stream2.Size Then
Result:= CompareMem(Stream1.Memory, Stream2.Memory, Stream1.Size);
finally
Stream2.Free;
end;
finally
Stream1.Free;
end;
end;

function ScreenShot: TBitmap;
begin
Result := TBitmap.Create;
Expand All @@ -81,12 +111,14 @@ function ScreenShot: TBitmap;

procedure TForm15.ApplicationEvents1Minimize(Sender: TObject);
begin
FLastBitmap:=nil;
Timer1.Enabled := True;
end;

procedure TForm15.ApplicationEvents1Restore(Sender: TObject);
begin
Timer1.Enabled := False;
FLastBitmap:=nil;
end;

procedure TForm15.Capture;
Expand All @@ -103,18 +135,17 @@ procedure TForm15.Capture;
var bmp := ScreenShot;
var when := Now;
ListBox1.Items.AddObject(TimeToStr(when), bmp);

Image1.Picture.Bitmap.Assign(bmp);
var png := TPngImage.Create;
try
png.Assign(bmp);

var fileName := Format('%.4d-%s.png',
[ListBox1.Items.Count,
FormatDateTime('hhmmss',when)]);
png.SaveToFile(TPath.Combine(RzButtonEdit1.Text, filename));
finally
png.Free;
end;
if chkOnlyChanges.Checked then
begin
if IsSameBitmap(bmp,FLastBitmap) then
SavePnG(bmp,when);
end
else
SavePnG(bmp,when);

FLastBitmap:=bmp;

finally
if Visible and (Self.WindowState <> wsMinimized) then
Expand All @@ -141,7 +172,8 @@ procedure TForm15.FormCreate(Sender: TObject);
RzButtonEdit1.ButtonGlyph);
var png := TPngImage.Create;
try
png.LoadFromFile('C:\Users\Jim\Documents\GitHub\Automatic-Periodic-Screen-Shot-Utility\icons\black\folder_96px.png');
var theImageFolder :=ExtractFilePath(Application.ExeName)+'..\..\..\icons\black\folder_96px.png';
png.LoadFromFile(theImageFolder);
RzButtonEdit1.ButtonGlyph.Assign(nil);
//RzButtonEdit1.ButtonGlyph.Assign(png);
RzButtonEdit1.ButtonGlyph.SetSize(16,16);
Expand All @@ -154,6 +186,7 @@ procedure TForm15.FormCreate(Sender: TObject);

procedure TForm15.Clear;
begin
FLastBitmap:=nil;
ListBox1.Items.BeginUpdate;
try
for var idx := 0 to pred(ListBox1.Items.Count) do
Expand Down Expand Up @@ -193,6 +226,21 @@ procedure TForm15.RzSpinEdit1Change(Sender: TObject);
Timer1.Interval := RzSpinEdit1.IntValue * 1000;
end;

procedure TForm15.SavePnG(vBmp: TBitmap; vWhen: TDateTime);
begin
var png := TPngImage.Create;
try
png.Assign(vbmp);

var fileName := Format('%.4d-%s.png',
[ListBox1.Items.Count,
FormatDateTime('hhmmss',vwhen)]);
png.SaveToFile(TPath.Combine(RzButtonEdit1.Text, filename));
finally
png.Free;
end;
end;

procedure TForm15.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
Expand Down