FAQ VCL
Файлы и файловая система

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как найти программу, которая держит файл?

{$A+,Z4}

const
  PROCESS_QUERY_LIMITED_INFORMATION = $1000;

  RstrtMgr = 'Rstrtmgr.dll';

  // RM_SESSION_KEY_LEN - size in bytes of binary session key
  RM_SESSION_KEY_LEN = SizeOf(TGUID);
  // CCH_RM_SESSION_KEY - character count of text-encoded session key
  CCH_RM_SESSION_KEY = RM_SESSION_KEY_LEN * 2;
  // CCH_RM_MAX_APP_NAME - maximum character count of application friendly name
  CCH_RM_MAX_APP_NAME = 255;
  // CCH_RM_MAX_SVC_NAME - maximum character count of service short name
  CCH_RM_MAX_SVC_NAME = 63;
  // Uninitialized value for TS Session ID
  RM_INVALID_TS_SESSION = -1;
  // Uninitialized value for Process ID
  RM_INVALID_PROCESS = -1;

type
  TAppName = array[0..CCH_RM_MAX_APP_NAME] of WideChar;
  TServiceName = array[0..CCH_RM_MAX_SVC_NAME] of WideChar;
  TSessionKey = array[0..CCH_RM_SESSION_KEY] of WideChar;

  _RM_APP_TYPE = (
    // Application type cannot be classified in known categories
    RmUnknownApp = 0,
    // Application is a windows application that displays a top-level window
    RmMainWindow = 1,
    // Application is a windows app but does not display a top-level window
    RmOtherWindow = 2,
    // Application is an NT service
    RmService = 3,
    // Application is Explorer
    RmExplorer = 4,
    // Application is Console application
    RmConsole = 5,
    // Application is critical system process where a reboot is required to restart
    RmCritical = 1000
  );
  RM_APP_TYPE = _RM_APP_TYPE;
  TRMAppType = RM_APP_TYPE;

  _RM_SHUTDOWN_TYPE = (
    // Force app shutdown
    RmForceShutdown = $1,
    // Only shudown apps if all apps registered for restart
    RmShutdownOnlyRegistered = $10
  );
  RM_SHUTDOWN_TYPE = _RM_SHUTDOWN_TYPE;
  TRMShutdownType = RM_SHUTDOWN_TYPE;

  _RM_APP_STATUS = (
    // Application in unknown state or state not important
    RmStatusUnknown = $0,
    // Application is currently running
    RmStatusRunning = $1,
    // Application stopped by Restart Manager
    RmStatusStopped = $2,
    // Application detected stopped by outside action
    RmStatusStoppedOther = $4,
    // Application restarted by Restart Manager
    RmStatusRestarted = $8,
    // An error occurred when stopping this application
    RmStatusErrorOnStop = $10,
    // An error occurred when restarting this application
    RmStatusErrorOnRestart = $20,
    // Shutdown action masked by filer
    RmStatusShutdownMasked = $40,
    // Restart action masked by filter
    RmStatusRestartMasked = $80
  );
  RM_APP_STATUS = _RM_APP_STATUS;
  TRMAppStatus = RM_APP_STATUS;

  _RM_REBOOT_REASON = (
    // Reboot not required
    RmRebootReasonNone = $0,
    // Current user does not have permission to shut down one or more detected processes
    RmRebootReasonPermissionDenied = $1,
    // One or more processes are running in another TS session
    RmRebootReasonSessionMismatch = $2,
    // A critical process has been detected
    RmRebootReasonCriticalProcess = $4,
    // A critical service has been detected
    RmRebootReasonCriticalService = $8,
    // The current process has been detected
    RmRebootReasonDetectedSelf = $10
  );
  RM_REBOOT_REASON = _RM_REBOOT_REASON;
  TRMRebootReason = RM_REBOOT_REASON;

  _RM_UNIQUE_PROCESS = record
    // PID
    dwProcessId: DWORD;
    // Process creation time
    ProcessStartTime: TFileTime;
  end;
  RM_UNIQUE_PROCESS = _RM_UNIQUE_PROCESS;
  PRM_UNIQUE_PROCESS = ^_RM_UNIQUE_PROCESS;
  TRMUniqueProcess = RM_UNIQUE_PROCESS;
  PRMUniqueProcess = PRM_UNIQUE_PROCESS;

  _RM_PROCESS_INFO = record
    // Unique process identification
    Process: TRMUniqueProcess;
    // Application friendly name
    strAppName: TAppName;
    // Service short name, if applicable
    strServiceShortName: TServiceName;
    // Application type
    ApplicationType: TRMAppType;
    // Bit mask of application status
    AppStatus: ULONG;
    // Terminal Service session ID of process (-1 if n/a)
    TSSessionId: DWORD;
    // Is application restartable?
    bRestartable: BOOL;
  end;
  RM_PROCESS_INFO = _RM_PROCESS_INFO;
  PRM_PROCESS_INFO = ^_RM_PROCESS_INFO;
  TRMProcessInfo = RM_PROCESS_INFO;
  PRMProcessInfo = PRM_PROCESS_INFO;

  function QueryFullProcessImageName(hProcess: THandle; dwFlags: DWORD;
    lpExeName: PChar; var lpdwSize: Integer): BOOL; stdcall; external kernel32
    name {$IFDEF UNICODE}'QueryFullProcessImageNameW'{$ELSE}'QueryFullProcessImageNameA'{$ENDIF};

  function RmStartSession(out pSessionHandle: DWORD; dwSessionFlags: DWORD;
    out strSessionKey: TSessionKey): DWORD; stdcall; external RstrtMgr;
  function RmEndSession(dwSessionHandle: DWORD): DWORD; stdcall; external RstrtMgr;
  function RmRegisterResources(dwSessionHandle: DWORD; nFiles: UINT;
    rgsFileNames: PWideChar; nApplications: UINT; rgApplications: PRMUniqueProcess;
    nServices: UINT; rgsServiceNames: PPWideChar): DWORD; stdcall; external RstrtMgr;
  function RmGetList(dwSessionHandle: DWORD; out pnProcInfoNeeded: UINT; var pnProcInfo: UINT;
    out rgAffectedApps: TRMProcessInfo; out lpdwRebootReasons: DWORD): DWORD; stdcall; external RstrtMgr;

procedure TForm1.Button1Click(Sender: TObject);

  function StrFromAppType(const AAppType: TRMAppType): String;
  begin
    case AAppType of
      RmMainWindow:
        // WindowsZприложение в отдельном процессе с главным окном
        Result := 'Application is a windows application that displays a top-level window';
      RmOtherWindow:
        // WindowsZприложение без отдельного процесса и главного окна
        Result := 'Application is a windows app but does not display a top-level window';
      RmService:
        // Сервис Windows
        Result := 'Application is an NT service';
      RmExplorer:
        // Windows Explorer
        Result := 'Application is Explorer';
      RmConsole:
        // Консольное приложение
        Result := 'Application is Console application';
      RmCritical:
        // Процесс, критичный для Windows
        Result := 'Application is critical system process where a reboot is required to restart';
    else
      // Приложение не может быть классифицировано
      Result := 'Application type cannot be classified in known categories';
    end;
  end;

const
  Num = 10;

var
  dwSession: DWORD;
  szSessionKey: TSessionKey;
  pszFile: PWideChar;
  P: PWideChar;
  FileName: WideString;
  dwReason: DWORD;
  i: Integer;
  nProcInfoNeeded: UINT;
  nProcInfo: UINT;
  rgpi: array[0..Num-1] of TRMProcessInfo;
  hProcess: THandle;
  ftCreate, ftExit, ftKernel, ftUser: TFileTime;
  sz: String;
  cch: Integer;
begin
   FileName := 'c:\test.txt';

   FillChar(szSessionKey, SizeOf(szSessionKey), 0);
   SetLastError(RmStartSession(dwSession, 0, szSessionKey));
   Win32Check(GetLastError = ERROR_SUCCESS);
   try
      P := PWideChar(FileName);
      pszFile := @P;
      SetLastError(RmRegisterResources(dwSession, 1, pszFile, 0, nil, 0, nil));
      Win32Check(GetLastError = ERROR_SUCCESS);

      nProcInfo := Num;
      SetLastError(RmGetList(dwSession, nProcInfoNeeded, nProcInfo, rgpi[0], dwReason));
      Win32Check(GetLastError = ERROR_SUCCESS);

      for i := 0 to nProcInfo - 1 do
      begin
         ShowMessage(Format('%d.ApplicationType = %d (%s)',
            [i, Ord(rgpi[i].ApplicationType), StrFromAppType(rgpi[i].ApplicationType)]));
         ShowMessage(Format('%d.strAppName = %s', [i, rgpi[i].strAppName]));
         ShowMessage(Format('%d.Process.dwProcessId = %d', [i, rgpi[i].Process.dwProcessId]));

         hProcess := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, rgpi[i].Process.dwProcessId);
         if hProcess <> 0 then
         try
            if GetProcessTimes(hProcess, ftCreate, ftExit, ftKernel, ftUser) and
               (CompareFileTime(rgpi[i].Process.ProcessStartTime, ftCreate) = 0) then
            begin
               cch := MAX_PATH;
               SetLength(sz, cch);
               if QueryFullProcessImageName(hProcess, 0, PChar(sz), cch) and (cch <= MAX_PATH) then
               begin
                  SetLength(sz, cch);
                  ShowMessage(Format('%d.Process.Name = %s', [i, sz]));
               end;
            end;
         finally
            CloseHandle(hProcess);
         end;
      end;
   finally
      RmEndSession(dwSession);
   end;
end;


Как конвертировать файл в Base64 и обратно?

// Способ первый
uses
   {...,} Soap.EncdDecd;

procedure TForm1.Button1Click(Sender: TObject);
const
  b64 = 'iVBORw0KGgoAAAANSUhEUgAAAAkAAAAJCAYAA' +
        'ADgkQYQAAAANUlEQVQoU2PkLrj9n4EAYAQp+j' +
        'pBlRGXOpA8hiJ0TaQrwuY2kDNINwnmcKLchO5' +
        'LuHWEwgkAlO5FBwhFaI8AAAAASUVORK5CYII=';
var
  bs: TBytesStream;
begin
  bs := TBytesStream.Create(DecodeBase64(b64));
  try
    bs.SaveToFile('c:\tmp\tmp.png');
  finally
    bs.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  aStr: AnsiString;
  bs: TBytesStream;
  str: string;
begin
  bs := TBytesStream.Create;
  try
    bs.LoadFromFile('c:\tmp\tmp.png');
    aStr := EncodeBase64(bs.Memory, bs.Size);
    str := StringReplace(aStr, sLineBreak, '', [rfReplaceAll]);
  finally
    bs.Free;
  end;

  MessageBox(Handle, PChar(str), '', 0);
end;

// Способ второй
uses
  {...,} System.NetEncoding;

procedure TForm1.Button1Click(Sender: TObject);
const
  b64 = 'iVBORw0KGgoAAAANSUhEUgAAAAkAAAAJCAYAA' +
        'ADgkQYQAAAANUlEQVQoU2PkLrj9n4EAYAQp+j' +
        'pBlRGXOpA8hiJ0TaQrwuY2kDNINwnmcKLchO5' +
        'LuHWEwgkAlO5FBwhFaI8AAAAASUVORK5CYII=';
var
  bs: TBytesStream;
  b: TBytes;
begin
  bs := TBytesStream.Create;
  try
    b := TNetEncoding.Base64.DecodeStringToBytes(b64);
    bs.Write(b, Length(b));
    bs.SaveToFile('c:\tmp\tmp.png');
  finally
    bs.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  bs: TBytesStream;
  str: string;
begin
  bs := TBytesStream.Create;
  try
    bs.LoadFromFile('c:\tmp\tmp.png');
    str := TNetEncoding.Base64.EncodeBytesToString(bs.Bytes, bs.Size);
    str := StringReplace(str, sLineBreak, '', [rfReplaceAll]);
    MessageBox(Handle, PChar(str), '', 0);
  finally
    bs.Free;
  end;
end;

// Способ третий
uses
  {...,} IdCoder, IdCoderMIME;

procedure TForm1.Button1Click(Sender: TObject);
const
  b64 = 'iVBORw0KGgoAAAANSUhEUgAAAAkAAAAJCAYAA' +
        'ADgkQYQAAAANUlEQVQoU2PkLrj9n4EAYAQp+j' +
        'pBlRGXOpA8hiJ0TaQrwuY2kDNINwnmcKLchO5' +
        'LuHWEwgkAlO5FBwhFaI8AAAAASUVORK5CYII=';
var
  bs: TBytesStream;
  Decoder: TIdDecoderMIME;
begin
  bs := TBytesStream.Create;
  try
    Decoder := TIdDecoderMIME.Create;
    try
      Decoder.DecodeBegin(bs);
      Decoder.Decode(b64);
      Decoder.DecodeEnd;
    finally
      Decoder.Free;
    end;
    bs.SaveToFile('c:\tmp\tmp.png');
  finally
    bs.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  bs: TBytesStream;
  Encoder: TIdEncoderMIME;
  str: string;
begin
  bs := TBytesStream.Create;
  try
    bs.LoadFromFile('c:\tmp\tmp.png');
    Encoder := TIdEncoderMIME.Create;
    try
      str := Encoder.Encode(bs);
      MessageBox(Handle, PChar(str), '', 0);
    finally
      Encoder.Free;
    end;
  finally
    bs.Free;
  end;
end;


Как открыть файл в монопольном режиме?

// Способ первый
var
  f: TextFile;

procedure TForm1.Button1Click(Sender: TObject);
begin
   FileMode := fmOpenRead or fmShareDenyNone;
   AssignFile(f, 'c:\test.txt');
   Reset(f);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   CloseFile(f);
end;

// Способ второй
var
  h: NativeInt;

procedure TForm1.Button1Click(Sender: TObject);
begin
   h := FileOpen('c:\test.txt', fmOpenReadWrite or fmShareExclusive);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   FileClose(h);
end;

// Способ третий
var
  h: HFILE;

procedure TForm1.Button1Click(Sender: TObject);
begin
   h := CreateFile(PChar('c:\test.txt'), GENERIC_READ or GENERIC_WRITE,
                   0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   CloseHandle(h);
end;

// Способ четвертый
var
  fs: TFileStream;

procedure TForm1.Button1Click(Sender: TObject);
begin
   fs := TFileStream.Create('c:\test.txt', fmOpenReadWrite {or fmShareDenyNone});
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   fs.Free;
end;


Как получить список каталогов?

// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  isFound: Boolean;
  sRec: TSearchRec;
begin
   isFound := FindFirst('c:\*.*', faAnyFile, sRec) = 0;
   while isFound do
   begin
      if (sRec.Name <> '.') and
         (sRec.Name <> '..') and
         ((sRec.Attr and faDirectory) = faDirectory) then
         ShowMessage(sRec.Name);
      isFound := FindNext(sRec) = 0;
   end;
end;

// Способ второй
uses
  {...,} System.IOUtils, System.Types;
  
procedure TForm1.Button1Click(Sender: TObject);
var
  FileName: string;
begin
   for FileName in TDirectory.GetDirectories('c:\') do
      ShowMessage(ExtractFileName(FileName));
end;

При использовании материала - ссылка на сайт обязательна