instfunc.pas

源代码

          ['DllRegisterServer', IntToHexStr8(RegisterCode)]));
    finally
      FreeLibrary(LibHandle);
    end;
  finally
    SetCurrentDir(SaveCurrentDir);
    SetErrorMode(SaveErrorMode);
    SetCursor(SaveCursor);
  end;
end;

function UnregisterServer(const Filename: String; const FailCriticalErrors: Boolean): Boolean;
var
  SaveCurrentDir: String;
  NewErrorMode, SaveErrorMode: UINT;
  LibHandle: THandle;
  UnregisterServerProc: function: HRESULT; stdcall;
begin
  Result := True;
  try
    SaveCurrentDir := GetCurrentDir;
    if FailCriticalErrors then
      NewErrorMode := SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS
    else
      NewErrorMode := SEM_NOOPENFILEERRORBOX;
    SaveErrorMode := SetErrorMode(NewErrorMode);
    try
      SetCurrentDir(PathExtractDir(Filename));
      LibHandle := SafeLoadLibrary(Filename, NewErrorMode);
      if LibHandle <> 0 then begin
        try
          @UnregisterServerProc := GetProcAddress(LibHandle, 'DllUnregisterServer');
          if Assigned(@UnregisterServerProc) and SUCCEEDED(UnregisterServerProc) then
            Exit;
        finally
          FreeLibrary(LibHandle);
        end;
      end;
    finally
      SetCurrentDir(SaveCurrentDir);
      SetErrorMode(SaveErrorMode);
    end;
  except
  end;
  Result := False;
end;

procedure UnregisterFont(const FontName, FontFilename: String);
var
  K: HKEY;
begin
  if Win32Platform <> VER_PLATFORM_WIN32_WINDOWS then begin
    WriteProfileString('Fonts', PChar(FontName), nil);
  end
  else begin
    if RegOpenKeyEx(HKEY_LOCAL_MACHINE, NEWREGSTR_PATH_SETUP + '\Fonts',
       0, KEY_SET_VALUE, K) = ERROR_SUCCESS then begin
      RegDeleteValue(K, PChar(FontName));
      RegCloseKey(K);
    end;
  end;
  if RemoveFontResource(PChar(FontFilename)) then
    SendNotifyMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

function GetSpaceOnDisk(const DriveRoot: String;
  var FreeBytes, TotalBytes: Integer64): Boolean;
type
  TLargeIntegerRec = record
    Lo, Hi: Cardinal;
  end;
var
  GetDiskFreeSpaceExFunc: function(lpDirectoryName: PAnsiChar;
    lpFreeBytesAvailable: PLargeInteger; lpTotalNumberOfBytes: PLargeInteger;
    lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
  SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: Cardinal;
begin
  { NOTE: The docs claim that GetDiskFreeSpace supports UNC paths on
    Windows 95 OSR2 and later. But that does not seem to be the case in my
    tests; it fails with error 50 on Windows 95 through Me.
    GetDiskFreeSpaceEx, however, *does* succeed with UNC paths, so use it
    if available. }
  GetDiskFreeSpaceExFunc := GetProcAddress(GetModuleHandle(kernel32),
    'GetDiskFreeSpaceExA');
  if Assigned(@GetDiskFreeSpaceExFunc) then begin
    Result := GetDiskFreeSpaceExFunc(PChar(DriveRoot),
      @TLargeInteger(FreeBytes), @TLargeInteger(TotalBytes), nil);
  end
  else begin
    Result := GetDiskFreeSpace(PChar(DriveRoot), DWORD(SectorsPerCluster),
      DWORD(BytesPerSector), DWORD(FreeClusters), DWORD(TotalClusters));
    if Result then begin
      { Windows 95/98 cap the result of GetDiskFreeSpace at 2GB, but NT 4.0
        does not, so we must use a 64-bit multiply operation to avoid an
        overflow. }
      Multiply32x32to64(BytesPerSector * SectorsPerCluster, FreeClusters,
        FreeBytes);
      Multiply32x32to64(BytesPerSector * SectorsPerCluster, TotalClusters,
        TotalBytes);
    end;
  end;
end;

function GrantPermission(const ObjectType: DWORD; const ObjectName: String;
  const Entries: TGrantPermissionEntry; const EntryCount: Integer;
  const Inheritance: DWORD): Boolean;
{ Grants the specified access to the specified object. Returns True if
  successful. Always fails on Windows 9x/Me and NT 4.0. }
type
  PPSID = ^PSID;
  PPACL = ^PACL;
  PTrusteeW = ^TTrusteeW;
  TTrusteeW = record
    pMultipleTrustee: PTrusteeW;
    MultipleTrusteeOperation: DWORD;  { MULTIPLE_TRUSTEE_OPERATION }
    TrusteeForm: DWORD;  { TRUSTEE_FORM }
    TrusteeType: DWORD;  { TRUSTEE_TYPE }
    ptstrName: PWideChar;
  end;
  TExplicitAccessW = record
    grfAccessPermissions: DWORD;
    grfAccessMode: DWORD;  { ACCESS_MODE }
    grfInheritance: DWORD;
    Trustee: TTrusteeW;
  end;
  PArrayOfExplicitAccessW = ^TArrayOfExplicitAccessW;
  TArrayOfExplicitAccessW = array[0..999999] of TExplicitAccessW;
const
  GRANT_ACCESS = 1;
  TRUSTEE_IS_SID = 0;
  TRUSTEE_IS_UNKNOWN = 0;
var
  AdvApiHandle: THandle;
  GetNamedSecurityInfoA: function(pObjectName: PAnsiChar; ObjectType: DWORD;
    SecurityInfo: SECURITY_INFORMATION; ppsidOwner, ppsidGroup: PPSID;
    ppDacl, ppSacl: PPACL; var ppSecurityDescriptor: PSECURITY_DESCRIPTOR): DWORD;
    stdcall;
  SetNamedSecurityInfoA: function(pObjectName: PAnsiChar; ObjectType: DWORD;
    SecurityInfo: SECURITY_INFORMATION; ppsidOwner, ppsidGroup: PSID;
    ppDacl, ppSacl: PACL): DWORD; stdcall;
  SetEntriesInAclW: function(cCountOfExplicitEntries: ULONG;
    const pListOfExplicitEntries: TExplicitAccessW; OldAcl: PACL;
    var NewAcl: PACL): DWORD; stdcall;
  SD: PSECURITY_DESCRIPTOR;
  Dacl, NewDacl: PACL;
  ExplicitAccess: PArrayOfExplicitAccessW;
  E: ^TGrantPermissionEntry;
  I: Integer;
  Sid: PSID;
begin
  Result := False;
  if Win32Platform <> VER_PLATFORM_WIN32_NT then
    Exit;
  if Lo(GetVersion) < 5 then
    Exit;  { GetNamedSecurityInfo and SetEntriesInACL are buggy on NT 4 }

  AdvApiHandle := GetModuleHandle(advapi32);
  GetNamedSecurityInfoA := GetProcAddress(AdvApiHandle, 'GetNamedSecurityInfoA');
  SetNamedSecurityInfoA := GetProcAddress(AdvApiHandle, 'SetNamedSecurityInfoA');
  SetEntriesInAclW := GetProcAddress(AdvApiHandle, 'SetEntriesInAclW');
  if (@GetNamedSecurityInfoA = nil) or (@SetNamedSecurityInfoA = nil) or
     (@SetEntriesInAclW = nil) then
    Exit;

  ExplicitAccess := nil;
  if GetNamedSecurityInfoA(PChar(ObjectName), ObjectType, DACL_SECURITY_INFORMATION,
     nil, nil, @Dacl, nil, SD) <> ERROR_SUCCESS then
    Exit;
  try
    { Note: Dacl will be nil if GetNamedSecurityInfo is called on a FAT partition.
      Be careful not to dereference a nil pointer. }
    ExplicitAccess := AllocMem(EntryCount * SizeOf(ExplicitAccess[0]));
    E := @Entries;
    for I := 0 to EntryCount-1 do begin
      if not AllocateAndInitializeSid(E.Sid.Authority, E.Sid.SubAuthCount,
         E.Sid.SubAuth[0], E.Sid.SubAuth[1], 0, 0, 0, 0, 0, 0, Sid) then
        Exit;
      ExplicitAccess[I].grfAccessPermissions := E.AccessMask;
      ExplicitAccess[I].grfAccessMode := GRANT_ACCESS;
      ExplicitAccess[I].grfInheritance := Inheritance;
      ExplicitAccess[I].Trustee.TrusteeForm := TRUSTEE_IS_SID;
      ExplicitAccess[I].Trustee.TrusteeType := TRUSTEE_IS_UNKNOWN;
      PSID(ExplicitAccess[I].Trustee.ptstrName) := Sid;
      Inc(E);
    end;
    if SetEntriesInAclW(EntryCount, ExplicitAccess[0], Dacl, NewDacl) <> ERROR_SUCCESS then
      Exit;
    try
      if SetNamedSecurityInfoA(PChar(ObjectName), ObjectType,
         DACL_SECURITY_INFORMATION, nil, nil, NewDacl, nil) <> ERROR_SUCCESS then
        Exit;
    finally
      LocalFree(HLOCAL(NewDacl));
    end;
  finally
    if Assigned(ExplicitAccess) then begin
      for I := EntryCount-1 downto 0 do begin
        Sid := PSID(ExplicitAccess[I].Trustee.ptstrName);
        if Assigned(Sid) then
          FreeSid(Sid);
      end;
      FreeMem(ExplicitAccess);
    end;
    LocalFree(HLOCAL(SD));
  end;
  Result := True;
end;

const
  OBJECT_INHERIT_ACE    = 1;
  CONTAINER_INHERIT_ACE = 2;

function GrantPermissionOnFile(const Filename: String;
  const Entries: TGrantPermissionEntry; const EntryCount: Integer): Boolean;
{ Grants the specified access to the specified file/directory. Returns True if
  successful. Always fails on Windows 9x/Me and NT 4.0. }
const
  SE_FILE_OBJECT = 1;
var
  Attr, Inheritance: DWORD;
begin
  Attr := GetFileAttributes(PChar(Filename));
  if Attr = $FFFFFFFF then begin
    Result := False;
    Exit;
  end;
  if Attr and FILE_ATTRIBUTE_DIRECTORY <> 0 then
    Inheritance := OBJECT_INHERIT_ACE or CONTAINER_INHERIT_ACE
  else
    Inheritance := 0;
  Result := GrantPermission(SE_FILE_OBJECT, Filename, Entries, EntryCount,
    Inheritance);
end;

function GrantPermissionOnKey(const RootKey: HKEY; const Subkey: String;
  const Entries: TGrantPermissionEntry; const EntryCount: Integer): Boolean;
{ Grants the specified access to the specified registry key. Returns True if
  successful. Always fails on Windows 9x/Me and NT 4.0. }
const
  SE_REGISTRY_KEY = 4;
var
  ObjName: String;
begin
  case RootKey of
    HKEY_CLASSES_ROOT: ObjName := 'CLASSES_ROOT';
    HKEY_CURRENT_USER: ObjName := 'CURRENT_USER';
    HKEY_LOCAL_MACHINE: ObjName := 'MACHINE';
    HKEY_USERS: ObjName := 'USERS';
  else
    { Other root keys are not supported by Get/SetNamedSecurityInfo }
    Result := False;
    Exit;
  end;
  ObjName := ObjName + '\' + Subkey;
  Result := GrantPermission(SE_REGISTRY_KEY, ObjName, Entries, EntryCount,
    CONTAINER_INHERIT_ACE);
end;

procedure RefreshEnvironment;
{ Notifies other applications (Explorer) that environment variables have
  changed. Based on code from KB article 104011.
  Note: Win9x's Explorer ignores this message. }
var
  MsgResult: DWORD;
begin
  { Note: We originally used SendNotifyMessage to broadcast the message but it
    turned out that while it worked fine on NT 4 and 2000 it didn't work on XP
    -- the string "Environment" in lParam would be garbled on the receiving
    end (why I'm not exactly sure). We now use SendMessageTimeout as directed
    in the KB article 104011. It isn't as elegant since it could cause us to
    be delayed if another app is hung, but it'll have to do. }
  SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0,
    LPARAM(PChar('Environment')), SMTO_ABORTIFHUNG, 5000, MsgResult);
end;

{ TSimpleStringList }

procedure TSimpleStringList.Add(const S: String);
var
  Delta: Integer;
begin
  if FCount = FCapacity then begin
    if FCapacity > 64 then Delta := FCapacity div 4 else
      if FCapacity > 8 then Delta := 16 else
        Delta := 4;
    SetCapacity(FCapacity + Delta);
  end;
  FList^[FCount] := S;
  Inc(FCount);
end;

procedure TSimpleStringList.AddIfDoesntExist(const S: String);
begin
  if IndexOf(S) = -1 then
    Add(S);
end;

procedure TSimpleStringList.SetCapacity(NewCapacity: Integer);
begin
  ReallocMem(FList, NewCapacity * SizeOf(Pointer));
  if NewCapacity > FCapacity then
    FillChar(FList^[FCapacity], (NewCapacity - FCapacity) * SizeOf(Pointer), 0);
  FCapacity := NewCapacity;
end;

procedure TSimpleStringList.Clear;
begin
  if FCount <> 0 then Finalize(FList^[0], FCount);
  FCount := 0;
  SetCapacity(0);
end;

function TSimpleStringList.Get(Index: Integer): String;
begin
  Result := FList^[Index];
end;

function TSimpleStringList.IndexOf(const S: String): Integer;
{ Note: This is case-sensitive, unlike TStringList.IndexOf }
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to FCount-1 do
    if FList^[I] = S then begin
      Result := I;
      Break;
    end;
end;

destructor TSimpleStringList.Destroy;
begin
  Clear;
  inherited Destroy;
end;

end.