|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как получить имя для создания временного файла?
// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
Buffer: array[0..MAX_PATH] of Char;
begin
GetTempFileName( 'c:\', '~', 0, Buffer );
ShowMessage( Buffer );
end;
// Способ второй
function GetTempFile( const Extension: string ): string;
var
pStr: PChar;
begin
repeat
pStr := StrAlloc( MAX_PATH + 1 );
GetTempPath( MAX_PATH + 1, pStr );
GetTempFileName( pStr, '~', 0, pStr );
Result := ChangeFileExt( pStr, Extension );
if pStr <> nil then
StrDispose( pStr );
until not FileExists( Result );
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage( GetTempFile( '.~tp' ) );
end;
|
Как получить длинный путь из короткого?
// Способ первый
function ShortToLongFileName(FileName: string): string;
var
KernelHandle: THandle;
FindData: TWin32FindData;
Search: THandle;
GetLongPathName: function(lpszShortPath: PChar; lpszLongPath: PChar;
cchBuffer: DWORD): DWORD; stdcall;
begin
KernelHandle := GetModuleHandle('KERNEL32');
if KernelHandle <> 0 then
@GetLongPathName := GetProcAddress(KernelHandle, 'GetLongPathNameA');
// Использование GetLongPathName доступную в windows 98 и выше чтобы
// избежать проблем доступа к путям UNC в системах NT/2K/XP
if Assigned(GetLongPathName) then
begin
SetLength(Result, MAX_PATH + 1);
SetLength(Result, GetLongPathName(PChar(FileName), @Result[1], MAX_PATH));
end
else
begin
Result := '';
while true do
begin
Search := Windows.FindFirstFile(PChar(FileName), FindData);
if Search = INVALID_HANDLE_VALUE then Break;
Result := String('\') + FindData.cFileName + Result;
FileName := ExtractFileDir(FileName);
Windows.FindClose(Search);
if Length(FileName) <= 2 then Break;
end;
Result := ExtractFileDrive(FileName) + Result;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := ShortToLongFileName('C:\PROGRA~1\');
end;
// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
var
s, f: string;
Len: Integer;
begin
s := 'C:\PROGRA~1\';
Len := GetLongPathName(PChar(s), nil, 0);
SetLength(f, Len-1);
GetLongPathName(PChar(s), PChar(f), Len);
ShowMessage(f);
end;
|
Как открыть файл в проводнике и выделить его?
// Способ первый
uses
{...,} ShellAPI, SHDocVw;
function OpenExplorerAndSelectFile(Path: string): Boolean;
function ParceURLName( const Value: string ): string;
const
scFilePath: array [0..7] of Char = ('f', 'i', 'l', 'e', ':', '/', '/', '/');
begin
if CompareMem(@scFilePath[0], @Value[1], 8) then
begin
Result := Copy(Value, 9, Length(Value));
Result := StringReplace(Result, '/', '\', [rfReplaceAll]);
Result := StringReplace(Result, '%20', ' ', [rfReplaceAll]);
Result := IncludeTrailingBackslash(Result);
end
else
Result := Value;
end;
// Для того, чтобы корректно работало даже в случае 'c:\Windows\System32\\\'
function ExcludeTrailingPathDelimiterEx(Path: string): string;
begin
Result := Path;
if Path = '\' then
Exit;
while IsPathDelimiter(Result, Length(Result)) do
SetLength(Result, Length(Result) - 1);
end;
var
iShellWindow: IShellWindows;
iWB: IWebBrowserApp;
spDisp: IDispatch;
i: integer;
s, FilePath, FileName: String;
begin
Result := FileExists(Path);
if not Result then
begin
Path := ExcludeTrailingPathDelimiterEx(Path);
Result := DirectoryExists(Path);
end;
if not Result then
Exit;
FilePath := AnsiUpperCase(ExtractFilePath(Path));
FileName := ExtractFileName(Path);
iShellWindow := CoShellWindows.Create;
for i := 0 to iShellWindow.Count-1 do
begin
spDisp := iShellWindow.Item(i);
if spDisp = nil then
Continue;
spDisp.QueryInterface(IWebBrowserApp, iWB);
if iWB <> nil then
begin
s := ParceURLName(iWB.LocationURL);
if AnsiUpperCase(s) = FilePath then
begin
SendMessage(iWB.HWnd, WM_SYSCOMMAND, SC_CLOSE, 0);
Break;
end;
end;
end;
ShellExecute(0, 'open', 'explorer.exe', PChar( '/select, ' + FileName),
PChar(FilePath), SW_SHOWNORMAL);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not OpenExplorerAndSelectFile('c:\windows\notepad.exe') then
ShowMessage('Файл не найден.');
// Другие варианты:
// OpenExplorerAndSelectFile( 'c:\windows\' ) - выделение директории
// OpenExplorerAndSelectFile( '\' ) - откроется рабочий стол (выделится 'Компьютер')
// OpenExplorerAndSelectFile( '\.' ) - откроется компьютер
// OpenExplorerAndSelectFile( '/' ) - откроется папка пользователя (выделятся "мои документы")
// OpenExplorerAndSelectFile( '\\*' ) - аналогично OpenExplorerAndSelectFile( '/' )
// (вместо '*' можно ввести любой разрененный в имени файла
// символ, кроме пробела)
end;
// Способ второй
// Выделение одного файла или каталога
uses
{...,} ShellAPI, ShlObj;
type
PPItemIDList = ^PItemIDList;
const
OFASI_EDIT = 1;
OFASI_OPENDESKTOP = 2;
{...}
function SHOpenFolderAndSelectItems(pidlFolder: PItemIDList; cidl: UINT;
apidl: PPItemIDList; dwFlags: DWORD): HRESULT; stdcall; external shell32;
implementation
procedure OpenFolderAndSelectItem(Path: WideString);
var
desk: IShellFolder;
iidl: PItemIDList;
attrs, che: Cardinal;
begin
SHGetDesktopFolder(desk);
desk.ParseDisplayName(0, nil, PWideChar(Path), che, iidl, attrs);
SHOpenFolderAndSelectItems(iidl, 0, nil, 0);
// Если в функцию SHOpenFolderAndSelectItems в качестве последнего
// параметра подставить OFASI_EDIT, то выбранный пункт в проводнике
// перейдет в режим редактирования.
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenFolderAndSelectItem('C:\Program Files\Internet Explorer\IEXPLORE.EXE');
end;
// Выделение группы файлов и/или каталогов
uses
{...,} ShellAPI, ShlObj;
type
PPItemIDList = ^PItemIDList;
TPItemIDListArray = array[0..65535] of PItemIDList;
PPItemIDListArray = ^TPItemIDListArray;
{...}
function SHOpenFolderAndSelectItems(pidlFolder: PItemIDList; cidl: UINT;
apidl: PPItemIDListArray; dwFlags: DWORD): HRESULT; stdcall; external shell32;
implementation
procedure OpenFolderAndSelectItem(Dir: PWideChar; var Files: TStrings);
var
i: Integer;
Folder: PItemIDList;
FileList: PPItemIDListArray;
begin
Folder := ILCreateFromPath(Dir);
GetMem(FileList, SizeOf(PItemIDList) * Files.Count);
for i := 0 to Files.Count-1 do
FileList[i] := ILCreateFromPath(PWideChar(Dir + Files[i]));
SHOpenFolderAndSelectItems(Folder, Files.Count, FileList, 0);
ILFree(Folder);
for i := Files.Count-1 downto 0 do
ILFree(FileList[i]);
FreeMem(FileList);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
sl: TStrings;
begin
// Все файлы и каталоги должны находиться в одной директории
sl := TStringList.Create;
sl.Add('Файл 1.txt');
sl.Add('Файл 2.txt');
sl.Add('Файл 3.txt');
sl.Add('Каталог');
OpenFolderAndSelectItem('c:\', sl);
sl.Free;
end;
|
Как удалить файл без возможности восстановления?
// Процедура для очистки содержимого файла без возможности восстановления, по методу Гуттмана
procedure ZeroFillDelete( FileName: string );
var
fs: TFileStream;
i: integer;
procedure RandomWrite;
var
b: byte;
begin
repeat
b := Random( 256 );
fs.Write( b, 1 );
until fs.Position + 1 >= fs.Size;
end;
procedure WritePattern( Pattern: byte );
const patt: array[5..31] of DWORD = ( $555555, $AAAAAA, $924924, $492492,
$249249, 0, $111111, $222222, $333333, $444444, $555555, $666666,
$777777, $888888, $999999, $AAAAAA, $BBBBBB, $CCCCCC, $DDDDDD,
$EEEEEE, $FFFFFF, $924924, $492492, $249249, $6DB6DB, $B6DB6D, $DB6DB6 );
var
d: DWORD;
begin
d := patt[Pattern] shl 8;
repeat
fs.Write( d, 3 );
until fs.Position + 3 >= fs.Size;
end;
begin
if not FileExists( FileName ) then Exit;
for i := 1 to 35 do
try
fs := TFileStream.Create( FileName, fmOpenWrite );
try
if ( i < 5 ) or ( i > 31 ) then
RandomWrite
else
WritePattern( i );
finally
fs.Free;
end;
except
Exit;
end;
DeleteFile( FileName );
end;
|
Как получить дату создания каталога?
function GetDirTime( const Dir: string ): TDateTime;
var
H: Integer;
F: TFileTime;
S: TSystemTime;
begin
H := CreateFile( PChar( Dir ), $0080, 0, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0 );
if H <> -1 then
begin
GetFileTime( H, @F, nil, nil );
FileTimeToLocalFileTime( F, F );
FileTimeToSystemTime( F, S );
Result := SystemTimeToDateTime( S );
CloseHandle( H );
end
else
Result := -1;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage( DateTimeToStr( GetDirTime( 'c:\Program Files' ) ) );
end;
|
Как перетаскивать файлы в свою программу?
// Способ первый
uses
{...,} ShellAPI;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
procedure WMDropFiles( var Msg: TWMDropFiles ); message WM_DROPFILES;
end;
{...}
implementation
{...}
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Handle, True );
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DragAcceptFiles( Handle, False );
end;
procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
i, Amount, Size: integer;
FileName: PChar;
begin
inherited;
Amount := DragQueryFile( Msg.Drop, $FFFFFFFF, FileName, 255 );
for i := 0 to ( Amount-1 ) do
begin
Size := DragQueryFile( Msg.Drop, i, nil, 0 ) + 1;
FileName := StrAlloc( Size );
DragQueryFile( Msg.Drop, i, FileName, Size );
Memo1.Lines.add( StrPas( FileName ) );
StrDispose( FileName );
end;
DragFinish( Msg.Drop );
end;
// Способ второй
uses
{...,} ActiveX, ComObj;
type
TForm1 = class(TForm, IDropTarget)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
// IDropTarget
function DragEnter( const dataObj: IDataObject; grfKeyState: Longint;
pt: TPoint; var dwEffect: Longint ): HResult; stdcall;
function DragOver( grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint ): HResult; stdcall;
function DragLeave: HResult; stdcall;
function Drop( const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint ): HResult; stdcall;
// IUnknown (Ignore referance counting)
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public
end;
{...}
implementation
{...}
procedure TForm1.FormCreate(Sender: TObject);
begin
OleInitialize( nil );
OleCheck( RegisterDragDrop( Handle, Self ) );
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
RevokeDragDrop( Handle );
OleUninitialize;
end;
function TForm1.DragEnter(const dataObj: IDataObject; grfKeyState: Integer;
pt: TPoint; var dwEffect: Integer): HResult;
begin
dwEffect := DROPEFFECT_COPY;
Result := S_OK;
end;
function TForm1.DragOver(grfKeyState: Integer; pt: TPoint;
var dwEffect: Integer): HResult;
begin
dwEffect := DROPEFFECT_COPY;
Result := S_OK;
end;
function TForm1.DragLeave: HResult;
begin
Result := S_OK;
end;
function TForm1.Drop(const dataObj: IDataObject; grfKeyState: Integer;
pt: TPoint; var dwEffect: Integer): HResult;
var
aFmtEtc: TFORMATETC;
aStgMed: TSTGMEDIUM;
pData: PAnsiChar;
begin
if ( dataObj = nil ) then
raise Exception.Create( 'IDataObject-Pointer is not valid!' );
with aFmtEtc do
begin
cfFormat := CF_TEXT;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
{Get the data}
OleCheck( dataObj.GetData( aFmtEtc, aStgMed ) );
try
{Lock the global memory handle to get a pointer to the data}
pData := GlobalLock( aStgMed.hGlobal );
{ Replace Text }
Memo1.Text := pData;
finally
{Finished with the pointer}
GlobalUnlock( aStgMed.hGlobal );
{Free the memory}
ReleaseStgMedium( aStgMed );
end;
Result := S_OK;
end;
function TForm1._AddRef: Integer;
begin
Result := 1;
end;
function TForm1._Release: Integer;
begin
Result := 1;
end;
|
Как быстро создать файл любого размера?
// Способ первый
procedure MakeFile( Name: string; Size: Cardinal );
var
f: HWND;
begin
f := CreateFile( PChar( Name ), GENERIC_READ or GENERIC_WRITE, 0, 0,
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 );
SetFilePointer( f, Size * 1024 * 1024, nil, FILE_CURRENT );
SetEndOfFile( f );
CloseHandle( f );
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MakeFile( 'c:\file.big', 1000 );
end;
// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
fs: TFileStream;
begin
fs := TFileStream.Create( 'c:\file.big', fmCreate or fmOpenReadWrite );
fs.Size := 40000000000;
fs.Free;
end;
|
Как определить программу "по умолчанию", связанную с типом файла?
uses
{...,} ShellAPI;
function FindExec( FilePath: string): string;
var
defExecutable: array[0..MAX_PATH] of Char;
begin
Result := '';
if FileExists( FilePath ) then
begin
FindExecutable( PChar( FilePath ), nil, @defExecutable );
Result := defExecutable;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage( FindExec( 'c:\test.txt' ) );
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
