使用中ファイルを強制削除するには (ID:37855)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

サンプルはDelphi2010で動作確認しました。
他のバージョンでも恐らく動作可能だと思います。
ただし2009以降はUnicode化していて、JEDIのNativeAPIユニットが対応していないので、
JwaWinType.pasのGetProcedureAddress（一番下にある）を以下のように書き換えます。

procedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: string);
var
  ModuleHandle: HMODULE;
begin
  if not Assigned(P) then
  begin
    ModuleHandle := GetModuleHandle(PAnsiChar(AnsiString(ModuleName)));
    if ModuleHandle = 0 then
    begin
      ModuleHandle := LoadLibrary(PAnsiChar(AnsiString(ModuleName)));
      if ModuleHandle = 0 then
        raise EJwaLoadLibraryError.CreateFmt(RsELibraryNotFound, [ModuleName]);
    end;
    P := Pointer(GetProcAddress(ModuleHandle, PAnsiChar(AnsiString(ProcName))));
    if not Assigned(P) then
      raise EJwaGetProcAddressError.CreateFmt(RsEFunctionNotFound, [ModuleName, ProcName]);
  end;
end;

以下のコードをコンパイルすると、
引数にプロセスIDとファイル名を渡すことでロック解除するツールになります。
http://jedi-apilib.sourceforge.net/
からwin32apiとntapiをダウンロードしてパスを通しておいて下さい。

program Project1;

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils, JwaNative, JwaNtStatus, JwaWinType;

type
  TByteArray = array of Byte;

function EnableDebugPrivilege: Boolean;
var
  hToken: Cardinal;
  tokenPriv: TTokenPrivileges;
  luidDebug: TLargeInteger;
  len: Cardinal;
begin
  Result := False;
  if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
  begin
    if LookupPrivilegeValue(nil, 'SeDebugPrivilege', luidDebug) then
    begin
      tokenPriv.PrivilegeCount := 1;
      tokenPriv.Privileges[0].Luid := luidDebug;
      tokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      Result := AdjustTokenPrivileges(hToken, False, tokenPriv,
        SizeOf(tokenPriv), nil, len);
    end;
  end;
end;

function GetHandleTable: TByteArray;
var
  size: ULONG;
  ret: NTSTATUS;
begin
  size := $1000;
  repeat
    size := size * 2;
    SetLength(Result, size);
    ret := ZwQuerySystemInformation(SystemHandleInformation, PVOID(Result), size, nil);
  until ret <> STATUS_INFO_LENGTH_MISMATCH;
  if ret <> STATUS_SUCCESS then
    Result := nil;
end;

procedure CloseRemoteHandle(hProcess, hFile: THandle);
var
  hRemoteThread: THandle;
  threadId: Cardinal;
begin
  hRemoteThread := CreateRemoteThread(hProcess, nil, 0,
    GetProcAddress(GetModuleHandle('kernel32.dll'), 'CloseHandle'), Pointer(hFile), 0, threadId);
  if hRemoteThread <> 0 then
  try
    WaitForSingleObject(hRemoteThread, INFINITE);
  finally
    CloseHandle(hRemoteThread);
  end;
end;

function GetObjectName(hObject: THandle; var ObjName: string; NameLen: Cardinal = 0): Boolean;
var
  bytes: TByteArray;
  info: PObjectNameInformation;
  status: NTSTATUS;
begin
  Result := False;
  if NameLen = 0 then
    NameLen := MAX_PATH*2;
  SetLength(bytes, NameLen);
  status := ZwQueryObject(hObject, ObjectNameInformation, Pointer(bytes), Length(bytes), @NameLen);
  if status = STATUS_BUFFER_OVERFLOW then
  begin
    SetLength(bytes, NameLen);
    status := ZwQueryObject(hObject, ObjectNameInformation, Pointer(bytes), Length(bytes), @NameLen);
    if status <> STATUS_SUCCESS then Exit;
  end
  else if status <> STATUS_SUCCESS then Exit;
  info := PObjectNameInformation(bytes);
  ObjName := info.Name.Buffer;
  Result := True;
end;

function GetDeviceFileName(const FileName: string; var DeviceFileName: string): Boolean;
var
  hFile: THandle;
begin
  Result := False;
  hFile := CreateFile(PChar(FileName), 0, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if hFile <> INVALID_HANDLE_VALUE then
  try
    Result := GetObjectName(hFile, DeviceFileName);
  finally
    CloseHandle(hFile);
  end;
end;

procedure UnlockFile(ProcessId: Cardinal; const FileName: string);
var
  devName: string;
  bytes, bytes1: TByteArray;
  num: Cardinal;
  info: PSystemHandleInformation;
  i: Integer;
  s: string;
  hProcess: THandle;
  hObject: THandle;
  obi: TObjectBasicInformation;
  len: Cardinal;
begin
  if not GetDeviceFileName(FileName, devname) then Exit;

bytes := GetHandleTable;
  if bytes = nil then Exit;
  num := PCardinal(bytes)^;
  info := PSystemHandleInformation(@bytes[4]);
  for i := 0 to num-1 do
  try
    if info.ProcessId <> ProcessId then Continue;
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, info.ProcessId);
    if hProcess = 0 then Continue;
    try
      if ZwDuplicateObject(hProcess, info.Handle, GetCurrentProcess, @hObject,
          0, 0, DUPLICATE_SAME_ACCESS) = STATUS_SUCCESS then
      try
        if ZwQueryObject(hObject, ObjectBasicInformation, @obi, SizeOf(obi), @len) <> STATUS_SUCCESS then Continue;
        SetLength(bytes1, obi.TypeInformationLength+2);
        FillChar(Pointer(bytes1)^, Length(bytes1), 0);

if ZwQueryObject(hObject, ObjectTypeInformation, Pointer(bytes1), Length(bytes1), @len) <> STATUS_SUCCESS then Continue;
        if PObjectTypeInformation(bytes1).Name.Buffer <> 'File' then Continue;
        if GetObjectName(hObject, s, obi.NameInformationLength) then
        begin
          if SameText(s, devname) then
          begin
            CloseRemoteHandle(hProcess, info.Handle);
          end;
        end;
      finally
        CloseHandle(hObject);
      end;
    finally
      CloseHandle(hProcess);
    end;
  finally
    Inc(info);
  end;
end;

var
  pid: Integer;
  fname: string;
begin
  if ParamCount <> 2 then Exit;
  if not TryStrToInt(ParamStr(1), pid) then Exit;
  fname := ParamStr(2);
  if not EnableDebugPrivilege then Exit;
  UnlockFile(pid, fname);
end.

←解決時は質問者本人がここをチェックしてください。

戻る