{ --▽---------------------------▼-- ファイル関係共通処理関数ユニット 2003/03/03 作成 2003/09/28 改良など 2004/11/06 ・FileFolderExistsを作成した 2004/11/20 ・GetDriveString/DriveTypeを追加 ・GetDiskFree/GetDiskSizeを追加 2005/02/09 ・Windows.GetFileVersionInfoと名前がかぶるので GetFileVersionInfo>>GetFileVersionInformationと変更 2006/07/03 ・GetCurrentDirを実装した 2006/09/18(月) 15:24 ・ApplicationTitlePlusVersionを実装 前からもってたものを使いやすくした 2007/07/22(日) 00:04 ・ExtractFolderFileName関数をFileNameUnit.pasへ移動 2011/10/03(月) ・ShellAPIをusesしたくないため GetFileTypeName関数をShellFileCtrlへ移した //--▲---------------------------△-- } unit FileUnit; interface uses RTLConsts, Windows, //TFileTimeを使っている為 SysUtils, //SystemTimeToDateTimeを使っている為 // XPtest, uses_end; type TFileFolderDateTimes = record Create: TDateTime; Modify: TDateTime; Access: TDateTime; class operator equal(a, b: TFileFolderDateTimes): Boolean; end; //function GetFileDateTimes(const FilePath: String): TFileFolderDateTimes; procedure SetFileDateTimes(const FilePath: String; FileDateTime: TFileFolderDateTimes); function GetFileFolderDateTimes(const Path: String): TFileFolderDateTimes; function APICopyFile(OldName, NewName: string; Overwrite: Boolean):Boolean; function APIMoveFile(OldName, NewName: string; Overwrite: Boolean):Boolean; function GetFileSize(FilePath: string): Int64; function FileInUse(FileName: string): Boolean; function GetFileVersionInformation(FileName, TitleKey: String): String; type TVersionFormat = (vfMajorMinorReleaseBuild, vfMajorMinorRelease, vfMajorMinor); function ApplicationTitlePlusVersion(Title: String; VersionJuntionText: String = ' ver '; VersionFormat: TVersionFormat = vfMajorMinorRelease): String; function FileFolderExists(FileFolderName: String): Boolean; function GetDriveString: String; function DriveType(DriveLetter: Char): Integer; function GetDiskFree(DriveLetter: Char): Int64; function GetDiskSize(DriveLetter: Char): Int64; procedure GetDiskFreeSpaceEx(DriveLetter: Char; out TotalResult, FreeResult: Int64); function GetCurrentDir: String; overload; function GetCurrentDir(DriveLetter: Char): String; overload; implementation uses Math; // TFileTime型をTDateTime型に変換する function FileTimeToDateTime(FileTime: TFileTime):TDateTime; var LocalFileTime: TFileTime; SystemTime: TSystemTime; begin result := 0; if (FileTime.dwLowDateTime = 0) and (FileTime.dwHighDateTime = 0) then Exit; FileTimeToLocalFileTime(FileTime,LocalFileTime); {ローカル日時に変換} FileTimeToSystemTime(LocalFileTime,SystemTime); {システム日時に変換} Result := SystemTimeToDateTime(SystemTime); {TDateTime型に変換} end; // TDateTime型をTFileTime型に変換する function DateTimeToFileTime(DateTime: TDateTime):TFileTime; var LocalFileTime, FileTime: TFileTime; SystemTime: TSystemTime; begin result.dwLowDateTime := 0; result.dwHighDateTime := 0; DateTimeToSystemTime(DateTime, SystemTime); {システム日時に変換} SystemTimeToFileTime(SystemTime, LocalFileTime); {ローカル日時に変換} LocalFileTimeToFileTime(LocalFileTime, FileTime); {TFileTime型に変換} result := FileTime; end; {------------------------------- // ファイルの日付[作成][更新][アクセス]日時を取得/設定する GetFileDateTime SetFileDateTime 引数説明: FilePath:ファイルのパス 備考: GetFileDateTime FileOpenのアクセス権がfmOpenReadだと Application.ExeNameなどにアクセスした場合 変な値が返されるので、fmShareDenyNoneにしておく SetFileDateTime ファイルに書き込みを行うので 書き込みが行えない場合は例外が発生する 履歴: 2003/03/03 2004/08/19 Folderの日付はGetFileDateTimeでは取得不具合が おきることがわかった 2005/07/26 どうもGetFileDateTimesで取得できる アクセス日時だけエクスプローラと互換性がない FileOpenをするのでアクセス日時が更新されるらしいので ファイルの日付を得るには FindFirstを使用するGetFileFolderDateTimesを使うべきだ //--▼----------------------▽--} type TFileTimes = record Create: TFileTime; Modify: TFileTime; Access: TFileTime; end; (*--▽---------------------------▼-- //使用禁止>>GetFileFolderDateTimesを使いましょう function GetFileDateTimes(const FilePath: String): TFileFolderDateTimes; var hFile: integer; FileTimes: TFileTimes; begin hFile:=FileOpen(FilePath, fmShareDenyNone ); with FileTimes do GetFileTime(hFile,@Create, @Access, @Modify); Result.Create := FileTimeToDateTime(FileTimes.Create); {作成日時} Result.Modify := FileTimeToDateTime(FileTimes.Modify); {更新日時} Result.Access := FileTimeToDateTime(FileTimes.Access); {アクセス日時} FileClose(hFile); //ファイルを閉じる end; //--▲---------------------------△--*) procedure SetFileDateTimes(const FilePath: String; FileDateTime: TFileFolderDateTimes); var FileTimes: TFileTimes; FileHandle: Integer; begin FileHandle := FileOpen(FilePath, fmOpenReadWrite); if FileHandle < 0 then raise Exception.CreateResFmt(@SFCreateError, [FilePath]); FileTimes.Create := DateTimeToFileTime(FileDateTime.Create); {作成日時} FileTimes.Modify := DateTimeToFileTime(FileDateTime.Modify); {更新日時} FileTimes.Access := DateTimeToFileTime(FileDateTime.Access); {アクセス日時} with FileTimes do SetFileTime(FileHandle, @Create, @Access, @Modify); if FileHandle >= 0 then FileClose(FileHandle); end; //こちらはFileStreamを使っている為、uses Classesが必要 //procedure SetFileDateTimes(const FilePath: String; FileDateTime: TFileDateTimes); //var // FileTimes: TFileTimes; // FileStream: TFileStream; // FileHandle: Integer; //begin // FileStream := TFileStream.Create(FilePath, fmOpenReadWrite); try // // FileTimes.Create := DateTimeToFileTime(FileDateTime.Create); {作成日時} // FileTimes.Modify := DateTimeToFileTime(FileDateTime.Modify); {更新日時} // FileTimes.Access := DateTimeToFileTime(FileDateTime.Access); {アクセス日時} // // with FileTimes do // SetFileTime(FileStream.Handle, @Create, @Access, @Modify); // // finally FileStream.Free; end; //end; //--△----------------------▲-- {------------------------------- // フォルダの日付[作成][更新][アクセス]日時を取得する GetFileFolderDateTimes 引数説明: Path:ファイルかフォルダのパス 備考: エクスプローラの詳細表示で [作成日時][更新日時][アクセス日時]と互換性がある 履歴: 2005/07/26 作成 2005/11/23 ファイルとフォルダ両方で 正しく(=エクスプローラ同等で)動く事を確認 //--▼----------------------▽--} function GetFileFolderDateTimes(const Path: String): TFileFolderDateTimes; var sr: TSearchRec; begin if FindFirst(Path, faAnyFile, sr) = 0 then begin Result.Create := FileTimeToDateTime(sr.FindData.ftCreationTime); {作成日時} Result.Modify := FileTimeToDateTime(sr.FindData.ftLastWriteTime); {更新日時} Result.Access := FileTimeToDateTime(sr.FindData.ftLastAccessTime); {アクセス日時} FindClose(sr); end; end; //こちらは正しくないので使用しない //function GetFolderDateTime(FullPath: String): TDateTime; //var // sr: TSearchRec; //begin // Result := 0; // if FindFirst(FullPath, faAnyFile, sr) = 0 then // begin // Result := SysUtils.FileDateToDateTime(sr.Time); // FindClose(sr); // end; //end; //--△----------------------▲-- function APICopyFile(OldName, NewName: string; Overwrite: Boolean):Boolean; begin Result := Boolean(CopyFile(PChar(OldName),PChar(NewName),not Overwrite)); end; function APIMoveFile(OldName, NewName: string; Overwrite: Boolean):Boolean; begin Result := Boolean(MoveFile(PChar(OldName),PChar(NewName))); end; {------------------------------- // ファイルサイズを求める。 機能: 戻り値: ファイルのバイト数 備考: 履歴: 2003/02/26 2003/03/16 2003/09/28 新たに作り直し・Integer超えサイズに対応 //--▼----------------------▽--} function GetFileSize(FilePath: string): Int64; var fd: TWin32FindData; begin Result := 0; if FileExists(FilePath) = False then Exit; Windows.FindClose(FindFirstFile(PChar(FilePath),fd)); Result := fd.nFileSizeHigh; Result := Result shl 32 + fd.nFileSizeLow; {↑Result shl 32 + fd.nFileSizeLow; もしくは Result := fd.FindData.nFileSizeHigh * $100000000 + fd.FindData.nFileSizeLow; もしくは with Int64Rec(Result) do begin Hi := data.nFileSizeHigh; Lo := data.nFileSizeLow; end; //} end; //--△----------------------▲-- {------------------------------- // ファイルが使用中かどうかを調べる関数 備考: 参考: http://www.scalabium.com/faq/dct0066.htm 履歴: 2003/09/28 //--▼----------------------▽--} function FileInUse(FileName: string): Boolean; var hFileRes: HFILE; begin Result := False; if not FileExists(FileName) then exit; hFileRes := CreateFile( PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Result := (hFileRes = INVALID_HANDLE_VALUE); if not Result then CloseHandle(hFileRes); end; {↑テストコード Memo1.Lines.Add(BoolToStr(FileInUse( Application.ExeName), True)); Memo1.Lines.Add(BoolToStr(FileInUse( ExtractFilePath(Application.ExeName)+'Unit1.pas'), True)); //} //--△----------------------▲-- {------------------------------- // ファイルのプロパティ、バージョン情報を取得する 機能: ファイル、プロパティの[バージョン情報]タブに表示される 各種の値を取得します。 引数説明: TitleKey:バージョン情報の各値のタイトルを指定する 指定できるキー値は次のとおり、//以降はWindowsで表示される名称 CompanyName //会社名 FileDescription //説明 or ファイル記述子 FileVersion //ファイル バージョン InternalName //内部名 or 内部ファイル名 LegalCopyright //著作権 or 著作権情報 LegalTrademarks //商標 OriginalFileName//正式ファイル名 or オリジナルファイル名 ProductName //製品名 ProductVersion //製品バージョン Comments //コメント 参考: 履歴: 2003/09/28 //--▼----------------------▽--} function GetFileVersionInformation(FileName, TitleKey: String): String; const coTRANSLATION = '\\VarFileInfo\\Translation'; coSTR_FILE_INFO = '\\StringFileInfo\\'; var fileVarsionInfoSize :Integer; dummy :DWORD; versionInfoSize :DWORD; pFileVarsionInfo, translation, infoPointer :Pointer; varValue :String; begin Result := ''; {バージョン情報サイズを得る} fileVarsionInfoSize := GetFileVersionInfoSize(PChar(FileName), dummy); if fileVarsionInfoSize > 0 then begin {バージョン情報用メモリ確保} GetMem(pFileVarsionInfo, fileVarsionInfoSize); try {バージョン情報リソース取得} windows.GetFileVersionInfo(PChar(FileName), 0, fileVarsionInfoSize, pFileVarsionInfo); {変換テーブルへのポインタ取得} VerQueryValue(pFileVarsionInfo, coTRANSLATION, translation, versionInfoSize); {バージョン情リクエスト文字列を初期化する} varValue := coSTR_FILE_INFO + IntToHex(LoWord(LongInt(translation^)), 4) + IntToHex(HiWord(LongInt(translation^)), 4) + '\\'; if VerQueryValue(pFileVarsionInfo, PChar(varValue + TitleKey), infoPointer, versionInfoSize) then begin {（注）ここは直接Resultに入れない方がいいはずです} varValue := String(PChar(infoPointer)); Result := varValue; end; finally {メモリ解放} FreeMem(pFileVarsionInfo, fileVarsionInfoSize); end;{try...} end; end; {↑テストコードは次のとおり procedure TForm1.Button3Click(Sender: TObject); var Target: String; begin with Memo1.Lines do begin Target := Application.ExeName; Add(GetFileProperty(Target, 'CompanyName')); //会社名 Add(GetFileProperty(Target, 'FileDescription')); //説明 or ファイル記述子 Add(GetFileProperty(Target, 'FileVersion')); //ファイル バージョン Add(GetFileProperty(Target, 'InternalName')); //内部名 or 内部ファイル名 Add(GetFileProperty(Target, 'LegalCopyright')); //著作権 or 著作権情報 Add(GetFileProperty(Target, 'LegalTrademarks')); //商標 Add(GetFileProperty(Target, 'OriginalFileName')); //正式ファイル名 or オリジナルファイル名 Add(GetFileProperty(Target, 'ProductName')); //製品名 Add(GetFileProperty(Target, 'ProductVersion')); //製品バージョン Add(GetFileProperty(Target, 'Comments')); //コメント end; end; //} //--△----------------------▲-- {------------------------------- // アプリケーションのタイトルを生成する 機能: 『タイトル ver 1.0.0』という文字列を生成する Titleには『タイトル』 VersionJuntionTextには『 ver 』 VersionFormatに vfMajorMinorRelease を選択するとよい 備考: 履歴: 2006/09/18(月) 15:26 //--▼----------------------▽--} function ApplicationTitlePlusVersion(Title: String; VersionJuntionText: String = ' ver '; VersionFormat: TVersionFormat = vfMajorMinorRelease): String; function MajorMinorReleaseBuild: String; begin //出力形式：メジャー.マイナー.リリース.ビルド Result := GetFileVersionInformation(ParamStr(0), 'FileVersion'); end; function MajorMinorRelease: String; begin //出力形式：メジャー.マイナー.リリース Result := ChangeFileExt( GetFileVersionInformation(ParamStr(0), 'FileVersion'), '') end; function MajorMinor: String; begin //出力形式：メジャー.マイナー Result := ChangeFileExt( ChangeFileExt( GetFileVersionInformation(ParamStr(0), 'FileVersion'), ''), ''); end; var VersionInfo: String; begin case VersionFormat of vfMajorMinorReleaseBuild: VersionInfo := MajorMinorReleaseBuild; vfMajorMinorRelease: VersionInfo := MajorMinorRelease; vfMajorMinor: VersionInfo := MajorMinor; end; if VersionInfo = '' then begin Result := Title; end else begin Result := Title + VersionJuntionText + VersionInfo; end; end; //--△----------------------▲-- {------------------------------- // ファイルかフォルダの存在を確認します 備考: 履歴: 2004/11/06 //--▼----------------------▽--} function FileFolderExists(FileFolderName: String): Boolean; begin if FileExists(FileFolderName) then begin Result := True; Exit; end else if DirectoryExists(FileFolderName) then begin Result := True; Exit; end else begin Result := False; end; end; //--△----------------------▲-- {------------------------------- // 使用可能なデバイスを'ACDE'という形式で出力する関数 備考: 履歴: 2004/09/19 //--▼----------------------▽--} function GetDriveString: String; var R, Index: Integer; DriveBits: set of 0..25; begin Result := ''; R := GetLogicalDrives; if R <> 0 then begin Integer( DriveBits ) := R; for Index := 0 to 25 do if Index in DriveBits then Result := Result + Char( Index + Ord( 'A' ) ); end; end; //--△----------------------▲-- {------------------------------- // デバイスの種類を求める関数 戻り値: Windows.pasでの定義 DRIVE_UNKNOWN = 0; DRIVE_NO_ROOT_DIR = 1; DRIVE_REMOVABLE = 2; //フロッピー や リムーバブルDISK DRIVE_FIXED = 3; //HDD DRIVE_REMOTE = 4; //ネットワークドライブ DRIVE_CDROM = 5; //CD-ROM DRIVE_RAMDISK = 6; 履歴: 2004/09/19 //--▼----------------------▽--} function DriveType(DriveLetter: Char): Integer; begin Result := GetDriveType(PChar(String(DriveLetter + ':\'))); end; //--△----------------------▲-- {------------------------------- // ディスク容量/空き容量を求める関数 備考: 戻り値はバイト単位 サイズが求まらない場合 GetDiskSizeは-1を返す 履歴: 2004/11/20 2006/07/02 DriveIndexの処理にUpperCaseを入れた testDriveIndexを実装 //--▼----------------------▽--} const DriveLetterStr: String = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; function DriveIndex(DriveLetter: Char): Byte; begin Result := Pos(UpperCase(DriveLetter), DriveLetterStr); end; procedure testDriveIndex; begin // Check(1, DriveIndex('A')); // Check(1, DriveIndex('a')); // Check(3, DriveIndex('C')); // Check(3, DriveIndex('c')); // Check(24,DriveIndex('X')); // Check(24,DriveIndex('x')); // Check(26,DriveIndex('Z')); // Check(26,DriveIndex('z')); end; function GetDiskFree(DriveLetter: Char): Int64; var DriveNumber: Byte; begin DriveNumber := DriveIndex(DriveLetter); Result := IfThen(DriveNumber = 0, 0, DiskFree(DriveNumber)); end; function GetDiskSize(DriveLetter: Char): Int64; var DriveNumber: Byte; begin DriveNumber := DriveIndex(DriveLetter); Result := IfThen(DriveNumber = 0, 0, DiskSize(DriveNumber)); end; //{ ----------------------------------- //Win2000以降ならこの関数で求まる procedure GetDiskFreeSpaceEx(DriveLetter: Char; out TotalResult, FreeResult: Int64); var Avail, Total, Free: Int64; begin Windows.GetDiskFreeSpaceEx( PChar(String(DriveLetter)+DriveDelim+PathDelim), Avail, Total, @Free ); TotalResult := Total; FreeResult := Free; end; //----------------------------------- } //--△----------------------▲-- {------------------------------- // カレントディレクトリを求める関数 機能: DriveLetterを'A'とか指定すると そのドライブのカレントディレクトリを求めるが 存在しなかったり利用できないドライブの場合 カレントドライブのカレントディレクトリが返される 備考: 履歴: 2006/07/02(日) 22:45 //--▼----------------------▽--} function GetCurrentDir: String; overload; begin GetDir(0, Result); end; function GetCurrentDir(DriveLetter: Char): String; overload; begin GetDir(DriveIndex(DriveLetter), Result); if not SameText(DriveLetter, Result[1]) then begin Result := ''; end; end; //--△----------------------▲-- { TFileFolderDateTimes } class operator TFileFolderDateTimes.equal(a, b: TFileFolderDateTimes): Boolean; begin if (a.Create = b.Create) and (a.Modify = b.Modify) and (a.Access = b.Access) then Result := True else Result := False; end; end.