|
:: 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;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
