ffrmmain.pas

照片自动分类归并

unit FfrmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls,FileCtrl, ComCtrls;

type
  TfrmMain = class(TForm)
    edtSrcDir: TLabeledEdit;
    SpeedButton1: TSpeedButton;
    edtDesDir: TLabeledEdit;
    SpeedButton2: TSpeedButton;
    chkIncludeSubDir: TCheckBox;
    rgCat: TRadioGroup;
    rgExist: TRadioGroup;
    cmbDirType: TComboBox;
    Label1: TLabel;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Memo1: TMemo;
    Label2: TLabel;
    memLog: TMemo;
    prgMain: TProgressBar;
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
    function ProcessFile(vFileName:String):Boolean;
    function GetFileExifDate(vFileName:String):TDateTime;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

procedure SearchFile(Path:string;MatchStr:string;var List:TStrings;IncludeSubDir:Boolean);

implementation

uses Exif;

{$R *.dfm}

procedure SearchFile(Path:string;MatchStr:string;var List:TStrings;IncludeSubDir:Boolean);
var
  i: Integer;
  bFound:boolean;
  LSrch: TSearchRec;
  SubPath:string;
  SubPaths:TStrings;
begin
  SubPaths:=TStringList.create;
  //找出当前目录下匹配文件
  i := FindFirst(Path +'\'+ MatchStr, faAnyFile, LSrch);
  try
    while i=0 do
    begin
      if (LSrch.Attr and faDirectory)=0 then
        List.Add(Path+'\'+LSrch.Name);
      i := FindNext(LSrch);
    end;
  finally
    FindClose(LSrch);
  end;

  if not IncludeSubDir then exit;

  //找出子目录
  i := FindFirst(Path +'\*.*', faDirectory, LSrch);
  try
    while i=0 do
    begin
      if (LSrch.Name<>'..') and (LSrch.Name<>'.')
        and ((LSrch.Attr and faDirectory)<>0) then
          SubPaths.Add(Path+'\'+LSrch.Name);
      i := FindNext(LSrch);
    end;
  finally
    FindClose(LSrch);
  end;

  try
    for i:=0 to SubPaths.Count-1 do
       SearchFile(SubPaths[i],MatchStr,List,True);
  finally
    SubPaths.free;
  end;
end;

procedure TfrmMain.BitBtn1Click(Sender: TObject);
var
  R:TStrings;
  i:Integer;
begin
  if cmbDirType.Text='' then
  begin
    MessageBox(handle,'请选择目录树样式!','提示窗口',mb_iconinformation);
    exit;
  end;
  try
    R:=TStringList.create;
    SearchFile(edtSrcDir.text,'*.jpg',R,chkIncludeSubDir.Checked);
    //写日志
    memLog.clear;
    memLog.Lines.Add('总共有'+inttostr(R.Count)+'张照片要处理!');
    prgMain.Max:=R.Count;
    for I := 0 to R.Count - 1 do
    begin
      if ProcessFile(R[i]) then
        memLog.Lines.Add('文件'+R[i]+'操作成功!')
      else
        memLog.Lines.Add('文件'+R[i]+'操作失败!');
      prgMain.StepIt;
    end;
  finally
    R.Free;
  end;
end;

function TfrmMain.GetFileExifDate(vFileName: String): TDateTime;
var
  ex : TExif;
  ExifDate:String;
begin
  ex:=TExif.Create;
  try
    ex.ReadFromFile(vFileName);
    if ex.Valid then
    begin
      ExifDate:=ex.DateTime;
      ExifDate[5]:='-';
      ExifDate[8]:='-';
      ExifDate:=Copy(ExifDate,1,10);
      Result:=strtodate(ExifDate);
    end
    else
      Result:=FileDateToDateTime(FileAge(vFileName));
  finally
    ex.Free;
  end;
end;

function TfrmMain.ProcessFile(vFileName: String): Boolean;
var
  DesFileName:String;
  Dir:String;
  DirIsExist,Over:Boolean;
  ExifDateInfo:TDateTime;
begin
  //操作文件
  //建立目标文件
  ExifDateInfo:=GetFileExifDate(vFileName);
  case cmbDirType.ItemIndex  of
    0://年-月-日
      DesFileName:=edtDesDir.text+'\'+FormatDateTime('yyyy',ExifDateInfo)+'\'
        +FormatDateTime('MM',ExifDateInfo)+'\'
        +FormatDateTime('YYYY-MM-DD',ExifDateInfo)+'\'+ExtractFileName(vFileName);
    1://年-日
      DesFileName:=edtDesDir.text+'\'+FormatDateTime('yyyy',ExifDateInfo)+'\'
        +FormatDateTime('yyyy-mm-DD',ExifDateInfo)+'\'+ExtractFileName(vFileName);
    2://年
      DesFileName:=edtDesDir.text+'\'+FormatDateTime('yyyy',ExifDateInfo)+'\'+ExtractFileName(vFileName);
  end;
  //判断是否已存在
  if FileExists(DesFileName) then
  case rgExist.ItemIndex  of
    0:Over:=True;
    1:Over:=False;
    2:DesFileName:=copy(DesFileName,1,length(DesFileName)-4)+FormatDateTime('yyyymmddhhmmss',now)+'.jpg';
  end;

  Dir:=ExtractFilePath(DesFileName);
  if not DirectoryExists(Dir) then
    ForceDirectories(Dir);
  case rgCat.ItemIndex  of
    0:CopyFile(PAnsiChar(vFileName),PAnsiChar(DesFileName),Over);
    1:MoveFile(PAnsiChar(vFileName),PAnsiChar(DesFileName));
  end;

  Result:=True;
end;

procedure TfrmMain.SpeedButton1Click(Sender: TObject);
var
  strPath:String;
begin
  if SelectDirectory('请选择原文件路径:','', strPath) then
  begin
    edtSrcDir.Text :=strPath;
  end;
end;

procedure TfrmMain.SpeedButton2Click(Sender: TObject);
var
  strPath:String;
begin
  if SelectDirectory('请选择目标路径:','', strPath) then
  begin
    edtDesDir.Text :=strPath;
  end;
end;


end.