pascal
1{ Picture Organizer (PicOrg) is a free open source Directory rename
2 tool created by Theo Langstraat and licensed under GNU/GPL.
3
4 @version
5 1.0.0.0 (February 9 2023)
6 1.1.0.0 (December 9 2023) Status form added
7
8 @copyright
9 Copyright (C) 2023 Theo Langstraat *) }
10
11unit MainForm;
12
13interface
14
15uses
16 DB,
17 FireDAC.Comp.Client, FireDAC.Stan.Intf, FireDAC.Stan.Param,
18 FireDAC.Stan.Error,
19 FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf, FireDAC.Comp.DataSet,
20 FireDAC.Stan.Option,
21 System.Classes, System.Generics.Collections, System.IniFiles, System.IOUtils,
22 System.JSON, System.JSON.Readers, System.JSON.Types, System.UITypes,
23 System.StrUtils, System.SysUtils, System.Variants, System.Win.Registry,
24 Vcl.ComCtrls, Vcl.Controls, Vcl.DBCtrls, Vcl.DBGrids, Vcl.Dialogs,
25 Vcl.ExtCtrls,
26 Vcl.ExtDlgs, Vcl.FileCtrl, Vcl.Forms, Vcl.Grids, Vcl.StdCtrls,
27 Winapi.Messages, Winapi.ShlObj, Winapi.Windows, Vcl.OleCtrls, SHDocVw,
28 StatusForm, Util, TL.Components, SettingsForm, Vcl.Buttons;
29
30type
31 TfrmMain = class(TForm)
32 btnDestinationDir: TButton;
33 btnExecute: TButton;
34 btnSourceDir: TButton;
35 btnStart: TButton;
36 FileOpenDialog: TFileOpenDialog;
37 gbSettings: TGroupBox;
38 lblDestinationDir: TLabel;
39 lblSourceDir: TLabel;
40 lvError: TListView;
41 OpenPictureDialog: TOpenPictureDialog;
42 pnlBottom: TPanel;
43 pnlButtons: TPanel;
44 pnlDetails: TPanel;
45 pnlError: TPanel;
46 pnlLists: TPanel;
47 pnlMain: TPanel;
48 pnlTop: TPanel;
49 StatusBar: TStatusBar;
50 tblImageProperties: TFDMemTable;
51 // Much faster then ListView in Report modus if more then 3000 items
52 tblImagePropertiesSourceFile: TStringField; // tblImageProperties.Fields[0]
53 tblImagePropertiesFileModifyDate: TStringField;
54 // tblImageProperties.Fields[1]
55 tblImagePropertiesFileCreateDate: TStringField;
56 // tblImageProperties.Fields[2]
57 tblImagePropertiesDateTimeOriginal: TStringField;
58 // tblImageProperties.Fields[3]
59 tblImagePropertiesOriginalDate: TStringField;
60 // tblImageProperties.Fields[4]
61 tblImagePropertiesOriginalYear: TStringField;
62 // tblImageProperties.Fields[5]
63 tblImagePropertiesDirectory: TStringField; // tblImageProperties.Fields[6]
64 tblImagePropertiesDestinationFile: TStringField;
65 // tblImageProperties.Fields[7]
66 tblImagePropertiesDuplicate: TStringField; // tblImageProperties.Fields[8]
67
68 lblSourceFile: TLabel;
69 lblFileModifyDate: TLabel;
70 lblFileCreateDate: TLabel;
71 lblDateTimeOriginal: TLabel;
72 lblOriginalDate: TLabel;
73 lblOriginalYear: TLabel;
74 lblDirectory: TLabel;
75 lblDestinationFile: TLabel;
76 lblDuplicate: TLabel;
77
78 dbgImageProperties: TDBGrid;
79 dbNavigator: TDBNavigator;
80 dsImageProperties: TDataSource;
81
82 dbtSourceFile: TDBText;
83 dbtFileModifyDate: TDBText;
84 dbtFileCreateDate: TDBText;
85 dbtDateTimeOriginal: TDBText;
86 dbtOriginalDate: TDBText;
87 dbtOriginalYear: TDBText;
88 dbtDirectory: TDBText;
89 dbtDestinationFile: TDBText;
90 dbtDuplicate: TDBText;
91 rgFileAction: TRadioGroup;
92 Button2: TButton;
93 function GetFileType(FileName: string): TFileType;
94 function OpenIniFileInstance: TCustomIniFile;
95 procedure btnDestinationDirClick(Sender: TObject);
96 procedure btnExecuteClick(Sender: TObject);
97 procedure btnSourceDirClick(Sender: TObject);
98 procedure btnStartClick(Sender: TObject);
99 procedure FormClose(Sender: TObject; var Action: TCloseAction);
100 procedure FormCreate(Sender: TObject);
101 procedure LoadConfig;
102 procedure lvErrorResize(Sender: TObject);
103 procedure SaveConfig;
104 function Scan(Path: string): TFunctionResult;
105 procedure rgFileActionClick(Sender: TObject);
106 procedure FormResize(Sender: TObject);
107 procedure Button2Click(Sender: TObject);
108 private
109 { Private declarations }
110 SourceDir: string;
111 DestinationDir: string;
112
113 FileCounter: integer;
114 TotalFilesDetected: integer;
115
116 State: TState;
117
118 file_list: TStringlist;
119 ImageExt, RawExt, WebExt, VideoExt, RemoveExt, OtherExt: string;
120 ImageDir, RawDir, WebDir, VideoDir, RemoveDir, NoEXIFDir, OtherDir: string;
121 duplicatesDir: string;
122 Sr: TStringReader;
123 Reader: TJsonTextReader; // Fastest JSON implementation
124 function CountFilesInFolder(Path: string): integer;
125 function CreateDestName(SourceFile, OriginalDate, OriginalYear,
126 Directory: string): string;
127 function GetWhatsAppDate(FileName: string): string;
128 procedure CreateReader(Str: string);
129 function GetExifData: TFunctionResult;
130 procedure RestructureDirectory;
131 public
132 { Public declarations }
133 end;
134
135var
136 frmMain: TfrmMain;
137 frmStatus: TfrmStatus;
138 FileListName: string;
139
140implementation
141
142{$R *.dfm}
143
144uses
145 ExifTool;
146
147procedure TfrmMain.CreateReader(Str: string);
148begin
149 if Reader <> nil then
150 Reader.Free;
151 if Sr <> nil then
152 Sr.Free;
153 Sr := TStringReader.Create(Str);
154 Reader := TJsonTextReader.Create(Sr);
155end;
156
157function TfrmMain.OpenIniFileInstance: TCustomIniFile;
158begin
159 { HKEY_CURRENT_USER\Software\... }
160 Result := TRegistryIniFile.Create('Software\Langstraat\' + Application.Title);
161end;
162
163function GetSpecialFolderPath(CSIDLFolder: integer): string;
164var
165 FilePath: array [0 .. MAX_PATH] of char;
166begin
167 SHGetFolderPath(0, CSIDLFolder, 0, 0, FilePath);
168 Result := FilePath;
169end;
170
171procedure TfrmMain.SaveConfig;
172var
173 ConfigFile: TCustomIniFile;
174begin
175 ConfigFile := OpenIniFileInstance();
176 with ConfigFile do
177 try
178 WriteString('general', 'Copyright', 'Theo Langstraat - 2024');
179 WriteString('general', 'Version', '1.2');
180 WriteString('general', 'Date', '7-5-2024');
181
182 WriteString('locations', 'SourceDir', SourceDir);
183 WriteString('locations', 'DestinationBaseDir', DestinationDir);
184 WriteString('locations', 'ImageDir', ImageDir);
185 WriteString('locations', 'RawDir', RawDir);
186 WriteString('locations', 'WebDir', WebDir);
187 WriteString('locations', 'VideoDir', VideoDir);
188 WriteString('locations', 'RemoveDir', RemoveDir);
189 WriteString('locations', 'NoEXIFDir', NoEXIFDir);
190 WriteString('locations', 'OtherDir', OtherDir);
191 WriteString('locations', 'DuplicatesDir', duplicatesDir);
192
193 WriteString('filetypes', 'image', ImageExt);
194 WriteString('filetypes', 'raw', RawExt);
195 WriteString('filetypes', 'web', WebExt);
196 WriteString('filetypes', 'video', VideoExt);
197 WriteString('filetypes', 'remove', RemoveExt);
198 WriteString('filetypes', 'other', OtherExt);
199
200 if WindowState <> wsMaximized then
201 begin
202 WriteInteger('frmMain', 'Top', frmMain.Top);
203 WriteInteger('frmMain', 'Left', frmMain.Left);
204 WriteInteger('frmMain', 'Height', frmMain.Height);
205 WriteInteger('frmMain', 'Width', frmMain.Width);
206 end;
207 WriteBool('frmMain', 'WindowState', WindowState = wsMaximized);
208 WriteDateTime('general', 'LastRun', Now);
209 WriteInteger('fileaction', 'Action', rgFileAction.ItemIndex);
210 finally
211 Free;
212 end;
213end;
214
215procedure TfrmMain.LoadConfig;
216var
217 ConfigFile: TCustomIniFile;
218begin
219 ConfigFile := OpenIniFileInstance();
220 with ConfigFile do
221 try
222 SourceDir := ReadString('locations', 'SourceDir',
223 GetSpecialFolderPath(CSIDL_MYPICTURES));
224 DestinationDir := ReadString('locations', 'DestinationBaseDir',
225 DestinationDir);
226
227 ImageDir := ReadString('locations', 'ImageDir', '\01 - image');
228 RawDir := ReadString('locations', 'RawDir', '\02 - raw');
229 VideoDir := ReadString('locations', 'VideoDir', '\03 - video');
230 WebDir := ReadString('locations', 'WebDir', '\04 - web');
231 duplicatesDir := ReadString('locations', 'DuplicatesDir',
232 '\05 - duplicates');
233
234 NoEXIFDir := ReadString('locations', 'NoEXIFDir', '\06 - noexif');
235 OtherDir := ReadString('locations', 'OtherDir', '\07 - other');
236 RemoveDir := ReadString('locations', 'RemoveDir', '\08 - remove');
237
238 ImageExt := ReadString('filetypes', 'image', ImageExt).ToLower;
239 RawExt := ReadString('filetypes', 'raw', RawExt).ToLower;
240 WebExt := ReadString('filetypes', 'web', WebExt).ToLower;
241 VideoExt := ReadString('filetypes', 'video', VideoExt).ToLower;
242 RemoveExt := ReadString('filetypes', 'remove', RemoveExt).ToLower;
243 OtherExt := ReadString('filetypes', 'other', OtherExt).ToLower;
244
245 frmMain.Top := ReadInteger('frmMain', 'Top', frmMain.Top);
246 frmMain.Left := ReadInteger('frmMain', 'Left', frmMain.Left);
247 frmMain.Height := ReadInteger('frmMain', 'Height', frmMain.Height);
248 frmMain.Width := ReadInteger('frmMain', 'Width', frmMain.Width);
249
250 case ReadBool('frmMain', 'WindowState', WindowState = wsMaximized) of
251 true:
252 WindowState := wsMaximized;
253 false:
254 WindowState := wsNormal;
255 end;
256
257 rgFileAction.ItemIndex := ReadInteger('fileaction', 'Action', 1);
258
259 finally
260 Free;
261 end;
262end;
263
264procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
265begin
266 SaveConfig;
267 if frmStatus <> nil then
268 frmStatus.Free;
269 if file_list <> nil then
270 file_list.Free;
271end;
272
273procedure TfrmMain.FormCreate(Sender: TObject);
274var
275 Col: TListColumn;
276begin
277 btnExecute.Enabled := false;
278 lvError.Clear;
279 lvError.Columns.Clear;
280 Col := lvError.Columns.Add;
281 Col.Caption := StrMessagesFromEXIFTo;
282 Col.Alignment := taLeftJustify;
283 Col.Width := frmMain.Width - 10;
284
285 file_list := TStringlist.Create;
286 frmStatus := TfrmStatus.Create(Self);
287
288 { Default filters }
289 ImageExt := '.jpeg .JPG .tif .tiff';
290 RawExt := '.afphoto .CR2 .CR3 .CRW .dng .psd';
291 WebExt := '.bmp .png';
292 VideoExt := '.MOV .mp4';
293 RemoveExt := '.info .ini .json .mxc3 .pp2 .pp3 .THM .url .xml .xmp';
294 OtherExt := '.AAE .bib .BridgeSort .CTG .dat .docx .pdf';
295 LoadConfig;
296
297 TotalFilesDetected := CountFilesInFolder(SourceDir);
298 lblSourceDir.Caption := 'Number of Files: ' + IntToStr(TotalFilesDetected) +
299 ' - ' + SourceDir;
300 lblDestinationDir.Caption := DestinationDir;
301 rgFileActionClick(Sender);
302
303 Self.Caption := 'Picture directory organizer ' +
304 TL.Components.Folder.AppVersion + ' - © 2024 Theo Langstraat';
305end;
306
307procedure TfrmMain.FormResize(Sender: TObject);
308var
309 i, j: integer;
310begin
311 j := 0;
312 for i := 0 to 8 do // Calculate total fixed width for first 0..8 panels
313 j := j + StatusBar.Panels[i].Width;
314 StatusBar.Panels[9].Width := StatusBar.Width - j;
315 // Calculate remaining width for panel 9 comprising the File name in progress
316end;
317
318function TfrmMain.CountFilesInFolder(Path: string): integer;
319var
320 c: integer;
321
322 procedure CountFiles(Path: string);
323 const
324 Success: integer = 0;
325 var
326 f: TSearchRec;
327 begin
328 if FindFirst(Path + '\*.*', faAnyFile, f) = Success then
329 begin
330 repeat // until FindNext(f) <> Success
331 if (f.Attr and faDirectory) <> 0 then
332 begin // is directory
333 if (f.Name[1] <> '.') then // not current or parent directory
334 CountFiles(Path + '\' + f.Name); // recurses all sub-directories
335 end // f.attr = faDirectory
336 else // // is not directory
337 Inc(c);
338 until FindNext(f) <> Success;
339 System.SysUtils.FindClose(f);
340 end; // FindFirst(Path + '\*.*', faDirectory, f) = Success
341 end;
342
343begin
344 c := 0;
345 CountFiles(Path);
346 Result := c;
347end;
348
349procedure TfrmMain.btnSourceDirClick(Sender: TObject);
350begin
351 with FileOpenDialog do
352 begin
353 DefaultFolder := SourceDir;
354 Options := [fdoPickFolders];
355 if Execute then
356 begin
357 SourceDir := FileName;
358 TotalFilesDetected := CountFilesInFolder(SourceDir);
359 lblSourceDir.Caption := 'Number of Files: ' + IntToStr(TotalFilesDetected)
360 + ' - ' + SourceDir;
361 end;
362 end;
363 SaveConfig;
364end;
365
366procedure TfrmMain.btnDestinationDirClick(Sender: TObject);
367begin
368 with FileOpenDialog do
369 begin
370 DefaultFolder := DestinationDir;
371 Options := [fdoPickFolders];
372 if Execute then
373 begin
374 DestinationDir := FileName;
375 lblDestinationDir.Caption := DestinationDir;
376 end;
377 end;
378 SaveConfig;
379end;
380
381procedure TfrmMain.btnStartClick(Sender: TObject);
382begin
383 State := stInit;
384 while State <> stCompleted do
385 begin
386 case State of // State Machine
387
388 stInit:
389 begin
390 frmMain.Enabled := false;
391 btnExecute.Enabled := false;
392 { Selection of the desired EXIF fields are put in the first lines of the file_list.args file }
393 file_list.Clear;
394 file_list.Add('-SourceFile');
395 file_list.Add('-FileModifyDate');
396 file_list.Add('-FileCreateDate');
397 file_list.Add('-DateTimeOriginal');
398 FileCounter := 0;
399 { clear all values in Statusbar.Panels }
400 for var i := 0 to StatusBar.Panels.Count - 1 do
401 if Odd(i) then // odd Panels are values, even Panels are fixed texts
402 StatusBar.Panels[i].Text := '';
403 { Clear MemTable }
404 tblImageProperties.Active := false;
405 tblImageProperties.Active := true;
406 lvError.Clear;
407 FileCounter := 0;
408 frmStatus.FilesMoved := 0;
409 frmStatus.DuplicateFiles := 0;
410 frmStatus.FilesProcessed := FileCounter;
411 frmStatus.FilesDetected := TotalFilesDetected;
412 frmStatus.TotalFilesDetected := TotalFilesDetected;
413 frmStatus.Cancel := false;
414 frmStatus.btnOk.Enabled := false;
415 frmStatus.btnCancel.Enabled := true;
416 frmStatus.Caption := 'Scanning...';
417 frmStatus.Show;
418 State := stScan;
419 end;
420
421 stScan:
422 begin
423 frmStatus.State := State;
424
425 case Scan(SourceDir) of // starting directory for Scan
426
427 frOk:
428 begin
429 frmStatus.FilesProcessed := FileCounter;
430 State := stGetExif
431 end;
432
433 frCancel:
434 State := stCancel;
435
436 frError:
437 begin
438 MessageDlg(SourceDir + StrNoFilesFoundIn, mtInformation,
439 [mbOk], 0, mbOk);
440 State := stCancel;
441 end;
442
443 end;
444
445 end;
446
447 stGetExif:
448 begin
449 frmStatus.State := State;
450 if file_list.Count > 4 then // something to process?
451 begin
452 Application.ProcessMessages;
453 { EXIFTool works not well with ANSI charset therefore we use UTF8 file_list.args file }
454 file_list.SaveToFile(FileListName, TEncoding.UTF8);
455 GetExifData;
456 btnExecute.Enabled := true;
457 end
458 else // ' not found or folder is empty.'
459 MessageDlg(SourceDir + StrNoFilesFoundIn, mtInformation,
460 [mbOk], 0, mbOk);
461 if not frmStatus.Cancel then
462 State := stCompleting
463 else
464 State := stCancel;
465 end;
466
467 stCompleting:
468 begin
469 State := stCompleted;
470 frmStatus.State := State;
471 frmStatus.ProcessingFile := '';
472 frmStatus.btnOk.Enabled := true;
473 frmStatus.btnCancel.Enabled := false;
474 frmStatus.Hide;
475 frmStatus.ShowModal;
476 frmStatus.Hide;
477 frmMain.Enabled := true;
478 frmMain.SetFocus;
479 end;
480
481 stCancel:
482 begin
483 State := stCompleted;
484 { clear all values in Statusbar.Panels }
485 for var i := 0 to StatusBar.Panels.Count - 1 do
486 if Odd(i) then // odd Panels are values, even Panels are fixed texts
487 StatusBar.Panels[i].Text := '';
488 frmStatus.State := State;
489 frmStatus.btnOk.Enabled := true;
490 frmStatus.Hide;
491 frmMain.Enabled := true;
492 frmMain.SetFocus;
493 end;
494
495 stCompleted:
496 ;
497
498 end; // State Machine
499 Application.ProcessMessages;
500 end;
501 State := stNone;
502end;
503
504procedure TfrmMain.Button2Click(Sender: TObject);
505// ImageExt, RawExt, WebExt, VideoExt, RemoveExt, OtherExt: string;
506// ImageDir, RawDir, WebDir, VideoDir, RemoveDir, NoEXIFDir, OtherDir: string;
507
508begin
509 frmSettings.LabeledEdit1.Text := ImageExt;
510 frmSettings.LabeledEdit2.Text := RawExt;
511 frmSettings.LabeledEdit3.Text := VideoExt;
512 frmSettings.LabeledEdit4.Text := WebExt;
513 frmSettings.LabeledEdit5.Text := OtherExt;
514 frmSettings.LabeledEdit6.Text := RemoveExt;
515
516 frmSettings.LabeledEdit7.Text := ImageDir;
517 frmSettings.LabeledEdit8.Text := RawDir;
518 frmSettings.LabeledEdit9.Text := VideoDir;
519 frmSettings.LabeledEdit10.Text := WebDir;
520 frmSettings.LabeledEdit11.Text := OtherDir;
521 frmSettings.LabeledEdit12.Text := RemoveDir;
522 frmSettings.LabeledEdit13.Text := duplicatesDir;
523
524 if frmSettings.ShowModal = mrOk then
525 begin
526 ImageExt := frmSettings.LabeledEdit1.Text;
527 RawExt := frmSettings.LabeledEdit2.Text;
528 VideoExt := frmSettings.LabeledEdit3.Text;
529 WebExt := frmSettings.LabeledEdit4.Text;
530 OtherExt := frmSettings.LabeledEdit5.Text;
531 RemoveExt := frmSettings.LabeledEdit6.Text;
532
533 ImageDir := frmSettings.LabeledEdit7.Text;
534 RawDir := frmSettings.LabeledEdit8.Text;
535 VideoDir := frmSettings.LabeledEdit9.Text;
536 WebDir := frmSettings.LabeledEdit10.Text;
537 OtherDir := frmSettings.LabeledEdit11.Text;
538 RemoveDir := frmSettings.LabeledEdit12.Text;
539 duplicatesDir := frmSettings.LabeledEdit13.Text;
540
541 SaveConfig;
542 end;
543
544end;
545
546procedure TfrmMain.btnExecuteClick(Sender: TObject);
547begin
548 frmMain.Enabled := false;
549 frmStatus.Show;
550 frmStatus.btnOk.Enabled := false;
551
552 RestructureDirectory;
553 btnExecute.Enabled := false;
554
555 State := stCompleted;
556 frmStatus.State := State;
557 frmStatus.ProcessingFile := '';
558 frmStatus.btnOk.Enabled := true;
559 frmStatus.btnCancel.Enabled := false;
560 frmStatus.Hide;
561 frmStatus.ShowModal;
562 frmStatus.Hide;
563 frmMain.Enabled := true;
564 frmMain.SetFocus;
565end;
566
567function TfrmMain.GetWhatsAppDate(FileName: string): string;
568var
569 Str: string;
570 Splitted: TArray<String>;
571 Prefix, ImageDate, ImageName: string;
572begin
573 { WhatsApp Filename Format: IMG-YYYYMMDD-WAXXXX.jpg
574 Where YYYY is year, MM is month and DD is day.
575 The WAXXXX just increments by one for every image taken on the same day, ex. WA0000, WA0001, etc. }
576 Result := '';
577 Str := ExtractFileName(FileName);
578 Splitted := Str.Split(['-'], 3);
579 If Length(Splitted) = 3 then
580 begin
581 Prefix := Splitted[0];
582 ImageDate := Splitted[1];
583 ImageName := Splitted[2];
584 if (Prefix.ToUpper.StartsWith('IMG')) and
585 (ImageName.ToUpper.StartsWith('WA')) then
586 Result := ImageDate.Substring(0, 4) + '-' + ImageDate.Substring(4, 2) +
587 '-' + ImageDate.Substring(6, 2)
588 end;
589end;
590
591function TfrmMain.GetFileType(FileName: string): TFileType;
592var
593 FileExt: string;
594begin
595 FileExt := ExtractFileExt(FileName).ToLower;
596 if ImageExt.Contains(FileExt) then
597 Result := ftImage
598 else if RawExt.Contains(FileExt) then
599 Result := ftRaw
600 else if VideoExt.Contains(FileExt) then
601 Result := ftVideo
602 else if WebExt.Contains(FileExt) then
603 Result := ftWeb
604 else if RemoveExt.Contains(FileExt) then
605 Result := ftRemove
606 else if OtherExt.Contains(FileExt) then
607 Result := ftOther
608 else
609 Result := ftNone;
610end;
611
612procedure TfrmMain.lvErrorResize(Sender: TObject);
613begin
614 lvError.Columns[0].Width := frmMain.Width - 10;
615end;
616
617function TfrmMain.CreateDestName(SourceFile, OriginalDate, OriginalYear,
618 Directory: string): string;
619var
620 DestFileName: string;
621 PartialFileName: string;
622begin
623 { all extensions in lowercase and use jpg as uniform file extension for all jpeg images }
624 DestFileName := ChangeFileExt(SourceFile, ExtractFileExt(SourceFile)
625 .ToLower.Replace('jpeg', 'jpg'));
626 if not OriginalYear.IsEmpty then // Shot date is available
627 begin
628 PartialFileName := '\' + Directory + '\' + OriginalYear + '\' + OriginalDate
629 + '\' + ExtractFileName(DestFileName);
630 Case GetFileType(SourceFile) of
631 ftUndefined:
632 DestFileName := '';
633 ftImage:
634 DestFileName := DestinationDir + ImageDir + PartialFileName;
635 ftRaw:
636 DestFileName := DestinationDir + RawDir + PartialFileName;
637 ftVideo:
638 DestFileName := DestinationDir + VideoDir + PartialFileName;
639 ftWeb:
640 DestFileName := DestinationDir + WebDir + PartialFileName;
641 ftRemove:
642 DestFileName := DestinationDir + RemoveDir + PartialFileName;
643 ftOther:
644 DestFileName := DestinationDir + OtherDir + PartialFileName;
645 ftNone:
646 DestFileName := DestinationDir + OtherDir + PartialFileName;
647 End
648 end
649 else
650 Case GetFileType(SourceFile) of
651 ftUndefined:
652 DestFileName := '';
653 ftImage:
654 DestFileName := DestinationDir + NoEXIFDir + '\' +
655 ExtractFileName(DestFileName);
656 ftRaw:
657 DestFileName := DestinationDir + NoEXIFDir + '\' +
658 ExtractFileName(DestFileName);
659 ftVideo:
660 DestFileName := DestinationDir + NoEXIFDir + '\' +
661 ExtractFileName(DestFileName);
662 ftWeb:
663 DestFileName := DestinationDir + NoEXIFDir + '\' +
664 ExtractFileName(DestFileName);
665 ftRemove:
666 DestFileName := DestinationDir + RemoveDir + '\' +
667 ExtractFileName(DestFileName);
668 ftOther:
669 DestFileName := DestinationDir + OtherDir + '\' +
670 ExtractFileName(DestFileName);
671 ftNone:
672 DestFileName := DestinationDir + OtherDir + '\' +
673 ExtractFileName(DestFileName);
674 End;
675 Result := DestFileName;
676end;
677
678function TfrmMain.GetExifData: TFunctionResult;
679var
680 cmd: string;
681 Itm: TListItem;
682 Output, Errors: TStringlist;
683 c: integer;
684 p: string;
685
686begin
687 Output := TStringlist.Create;
688 Errors := TStringlist.Create;
689 c := -1;
690
691 { EXIFTool works not well with ANSI charset therefore we use UTF8 in file_list.args file
692 Selection of the desired EXIF fields is done in btnStartClick and
693 put in the first lines of the file_list.args file }
694 cmd := 'exiftool ' + // exiftool.exe
695 '-d "%Y-%m-%d" ' + // datetimeformat YYYY-MM-DD
696 '-j ' + // JSON output
697 '-fast2 ' + // most efficient for our goal
698 '-charset FileName=UTF8 ' +
699 // Filenames in arguments filelist in UTF8 encoding
700 '-@ ' + FileListName.QuotedString('"');
701 // Arguments filelist including fields to select
702
703 Result := ExecuteExifTool(cmd, Output, Errors);
704
705 case Result of
706
707 frOk:
708 begin
709
710 if Errors.Count > 0 then
711 for var i := 0 to Errors.Count - 1 do
712 begin
713 Itm := lvError.Items.Add;
714 Itm.Caption := UTF8ToString(RawByteString(Errors[i]));
715 end;
716
717 if Output.Count > 0 then
718 begin
719
720 CreateReader(UTF8ToString(RawByteString(Output.Text)));
721 tblImageProperties.DisableControls;
722 while Reader.read do
723 case Reader.TokenType of
724
725 TJsonToken.startobject:
726 tblImageProperties.Append;
727
728 TJsonToken.StartArray:
729 ;
730
731 TJsonToken.PropertyName:
732 begin
733 p := Reader.Value.ToString;
734 if p = 'SourceFile' then
735 c := 0; // tblImageProperties.Fields[0]
736 if p = 'FileModifyDate' then
737 c := 1; // tblImageProperties.Fields[1]
738 if p = 'FileCreateDate' then
739 c := 2; // tblImageProperties.Fields[2]
740 if p = 'DateTimeOriginal' then
741 c := 3; // tblImageProperties.Fields[3]
742 end; // TJsonToken.PropertyName
743
744 TJsonToken.String:
745 begin
746 tblImageProperties.edit;
747 case c of
748 // EXIFTool uses Unix style path names
749 0:
750 tblImageProperties.Fields[c].AsString :=
751 Reader.Value.ToString.Replace('/', '\');
752 1 .. 3:
753 tblImageProperties.Fields[c].AsString :=
754 Reader.Value.ToString;
755 end;
756 end; // TJsonToken.String
757
758 TJsonToken.Integer:
759 ;
760 TJsonToken.Float:
761 ;
762 TJsonToken.Boolean:
763 ;
764 TJsonToken.Null:
765 ;
766 TJsonToken.EndArray:
767 ;
768
769 TJsonToken.EndObject:
770 begin
771 tblImageProperties.edit;
772 { EXIF data value for DateTimeOriginal available? }
773 if not tblImagePropertiesDateTimeOriginal.AsString.IsEmpty
774 then
775 tblImagePropertiesOriginalDate.AsString :=
776 tblImagePropertiesDateTimeOriginal.AsString
777 else
778 begin
779 { WhatsApp image }
780 tblImagePropertiesOriginalDate.AsString :=
781 GetWhatsAppDate(tblImagePropertiesSourceFile.AsString);
782 if tblImagePropertiesOriginalDate.AsString.IsEmpty then
783 // No WhatsApp Image
784 { then use FileCreateDate, not very accurate but better then nothing. }
785 tblImagePropertiesOriginalDate.AsString :=
786 tblImagePropertiesFileCreateDate.AsString;
787 end;
788
789 tblImagePropertiesOriginalYear.AsString :=
790 tblImagePropertiesOriginalDate.AsString.Substring(0, 4);
791
792 tblImagePropertiesDirectory.AsString := // yyy0-yyy9
793 tblImagePropertiesOriginalYear.AsString.Substring(0, 3) +
794 '0' + '-' + tblImagePropertiesOriginalYear.AsString.
795 Substring(0, 3) + '9';
796
797 tblImagePropertiesDestinationFile.AsString :=
798 CreateDestName(tblImagePropertiesSourceFile.AsString,
799 tblImagePropertiesOriginalDate.AsString,
800 tblImagePropertiesOriginalYear.AsString,
801 tblImagePropertiesDirectory.AsString);
802
803 end; // TJsonToken.EndObject
804 end; // case Reader.TokenType
805 tblImageProperties.EnableControls;
806 end // if Output.Count > 0
807 end; // case Result = frOk
808
809 frError:
810 ShowMessage('exiftool.exe not found!?');
811
812 frCancel:
813 ;
814 end; // case Result
815end;
816
817procedure TfrmMain.RestructureDirectory;
818var
819 i: integer;
820 DuplicateFiles: integer;
821 Guid: TGUID;
822 AltDestFileName: string;
823begin
824 CreateGUID(Guid); // DirectoryName for duplicate files in BaseDir\duplicates
825 DuplicateFiles := 0;
826 i := 0;
827 StatusBar.Panels[5].Text := i.ToString;
828 StatusBar.Panels[9].Text := '';
829
830 frmStatus.FilesMoved := i;
831 frmStatus.ProcessingFile := '';
832 frmStatus.State := stRestructure;
833 frmStatus.btnCancel.Enabled := true;
834 case rgFileAction.ItemIndex of
835 0:
836 frmStatus.Caption := 'Performing file moving...';
837 1:
838 frmStatus.Caption := 'Performing File Copying...';
839 end;
840
841 Application.ProcessMessages;
842 tblImageProperties.First;
843 while not tblImageProperties.eof and not frmStatus.Cancel do
844 begin
845 Inc(i);
846 StatusBar.Panels[5].Text := i.ToString;
847 StatusBar.Panels[9].Text :=
848 TruncateFileName(tblImagePropertiesSourceFile.AsString,
849 StatusBar.Panels[9].Width div 9);
850
851 frmStatus.FilesMoved := i;
852 frmStatus.ProcessingFile := tblImagePropertiesSourceFile.AsString;
853 frmStatus.Progress := i;
854
855 // Creates a new directory, including the creation of parent directories as needed
856 if not System.SysUtils.ForceDirectories
857 (ExtractFilePath(tblImagePropertiesDestinationFile.AsString)) then
858 raise Exception.Create
859 (ExtractFilePath(tblImagePropertiesDestinationFile.AsString));
860 if not FileExists(tblImagePropertiesDestinationFile.AsString) then
861 case rgFileAction.ItemIndex of
862 0:
863 TFile.Move(tblImagePropertiesSourceFile.AsString,
864 tblImagePropertiesDestinationFile.AsString);
865 1:
866 TFile.Copy(tblImagePropertiesSourceFile.AsString,
867 tblImagePropertiesDestinationFile.AsString);
868 end
869 else
870 begin
871 Inc(DuplicateFiles);
872 StatusBar.Panels[7].Text := DuplicateFiles.ToString;
873
874 frmStatus.DuplicateFiles := DuplicateFiles;
875
876 AltDestFileName := DestinationDir + duplicatesDir + '\' +
877 GUIDToString(Guid) + '\' + Format('%.5d-', [DuplicateFiles]) +
878 ExtractFileName(tblImagePropertiesDestinationFile.AsString);
879 if not System.SysUtils.ForceDirectories(ExtractFilePath(AltDestFileName))
880 then
881 raise Exception.Create(ExtractFilePath(AltDestFileName));
882
883 case rgFileAction.ItemIndex of
884 0:
885 TFile.Move(tblImagePropertiesSourceFile.AsString, AltDestFileName);
886 1:
887 TFile.Copy(tblImagePropertiesSourceFile.AsString, AltDestFileName);
888 end;
889
890 tblImageProperties.edit;
891 tblImagePropertiesDuplicate.AsString := AltDestFileName;
892 tblImageProperties.Post;
893 end;
894 Application.ProcessMessages;
895 tblImageProperties.Next;
896 end; // while not tblImageProperties.eof and not frmStatus.Cancel
897 frmStatus.State := stCompleted;
898end;
899
900procedure TfrmMain.rgFileActionClick(Sender: TObject);
901begin
902 frmStatus.FileAction := TFileAction(rgFileAction.ItemIndex);
903 if Assigned(frmStatus) then
904 StatusBar.Panels[4].Text := FileActionStr[frmStatus.FileAction];
905end;
906
907function TfrmMain.Scan(Path: string): TFunctionResult;
908{ scans directory for files, recurses for directories found
909 Path does not have final backslash }
910const
911 Success: integer = 0;
912var
913 f: TSearchRec;
914 FileName: string;
915begin
916 Result := frError;
917 if FindFirst(Path + '\*.*', faAnyFile, f) = Success then
918 begin
919 repeat // until FindNext(f) <> Success
920 if (f.Attr and faDirectory) <> 0 then
921 begin // is directory
922 if (f.Name[1] <> '.') then
923 begin // not current or parent directory
924 Result := Scan(Path + '\' + f.Name); // recurses all sub-directories
925 end; // if fname not .. or . (ie not this or parent directory)
926 end // f.attr = faDirectory
927 else // // is not directory
928 begin
929 FileName := Path + '\' + f.Name;
930 file_list.Add(FileName);
931 Inc(FileCounter);
932 end;
933 Application.ProcessMessages;
934 until (FindNext(f) <> Success) or frmStatus.Cancel;
935
936 if frmStatus.Cancel or (Result = frCancel) then
937 Result := frCancel
938 else
939 Result := frOk;
940
941 System.SysUtils.FindClose(f);
942
943 { Show only final values for better performance }
944 StatusBar.Panels[1].Text := FileCounter.ToString;
945 StatusBar.Panels[9].Text := TruncateFileName(Path + '\' + f.Name,
946 (StatusBar.Panels[9].Width - 10) div 9);
947 frmStatus.FilesProcessed := FileCounter;
948 frmStatus.ProcessingFile := Path + '\' + f.Name;
949 end; // FindFirst(Path + '\*.*', faDirectory, f) = Success
950end;
951
952initialization
953
954begin
955 FileListName := TL.Components.Folder.LocalAppData +
956 '\Langstraat\PicOrg\file_list.args';
957 if not System.SysUtils.ForceDirectories(ExtractFilePath(FileListName)) then
958 raise Exception.Create('Can not create: ' + FileListName);
959end;
960
961end.
962