xfunctions.pas

自己写的一个 RSS 阅读器

unit XFunctions;

interface

uses
  Windows, Messages;

function GetFileVersion(const FileName: string; Const All: Boolean = True; Const BuildOnly: Boolean = False): string;
function ReadIEUserAgent: string;
function GetIEProxyInformation: string;
function GetExeForProtocol(URL:string): string;
procedure OpenNewBrowserWindow(const ApplicationHandle: THandle;
                               const OpenNewWindow: boolean;
                               const Handle: HWND;
                               const Operation, FileName, Parameters, Directory: string;
                               const ShowCommand: integer);
                               
const
  DigitChars = ['0'..'9'];

implementation

uses
  SysUtils, Forms, Registry, ShellApi,WinInet;

function GetIEProxyInformation: string;
var
  ProxyInfo: PInternetProxyInfo;
  Len: LongWord;
begin
  Result := '';
  Len := 4096;
  GetMem(ProxyInfo, Len);
  try
    if InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len) then
      if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
      begin
        Result := ProxyInfo^.lpszProxy
      end;
  finally
    FreeMem(ProxyInfo);
  end;
end;

//Get file version

function GetFileVersion(const FileName: string; Const All: Boolean = True; Const BuildOnly: Boolean = False): string;
var
  InfoSize, Wnd: DWORD;
  VerBuf: Pointer;
  FI: PVSFixedFileInfo;
  VerSize: DWORD;
begin
  Result := '';
  InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
  if InfoSize <> 0 then
  begin
    GetMem(VerBuf, InfoSize);
    try
      if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
        if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then Begin
          If All Then
            Result := Format('%d.%d.%d.%d',
               [FI.dwFileVersionMS shr 16 and $0000FFFF,
                FI.dwFileVersionMS and $0000FFFF,
                FI.dwFileVersionLS shr 16 and $0000FFFF,
                FI.dwFileVersionLS and $0000FFFF])
          Else Begin
            If BuildOnly Then
              Result := Format('%d', [FI.dwFileVersionLS and $0000FFFF])
             Else
              Result := Format('%d.%d',
                 [FI.dwFileVersionMS shr 16 and $0000FFFF,
                  FI.dwFileVersionMS and $0000FFFF]);
          End;
        end;
    finally
      FreeMem(VerBuf);
    end;
  end;
end;

function GetExeForProtocol(URL:string):string;
var Reg  : TRegistry;
    Res  : boolean;
    Temp : string;
    P    : integer;

  function PosN(const AText,S:string;N:integer):integer;
  var Temp : string;
      P    : integer;
  begin
    if N>1 then begin
      Temp:=copy(S, N, length(S)-N+1);
      dec(N);
    end
    else
      Temp:=S;
    P:=Pos(AText, Temp);
    if P>0 then
      Result:=P+N
    else
      Result:=0;
  end;

  function GetWindowsDir:string;
  var WinDir : array [0..Max_Path] of char;
  begin
    GetWindowsDirectory(WinDir, Max_Path);
    Result:=IncludeTrailingPathDelimiter(String(WinDir));
  end;

  function GetProgramFilesDir:string;
  var Reg : TRegistry;
      Res : boolean;
  begin
    Reg:=TRegistry.Create;
    try
      Reg.Rootkey:=HKEY_LOCAL_MACHINE;
      Res:=Reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion',false);
      if Res then begin
        Result:=IncludeTrailingPathDelimiter(Reg.ReadString('ProgramFilesDir'));
        Reg.CloseKey;
      end
      else
        Result:='';
    finally
      Reg.Free;
    end;
  end; 

  function ReplaceRegistryPathVars(const AText:string):string;
  var P,Q      : integer;
      PathVar,
      RealPath : string;

    function GetProgramFilesPathVar:string;
    var Reg : TRegistry;
        Res : boolean;
    begin
      Result:='%ProgramFiles%';
      Reg:=TRegistry.Create;
      try
        Reg.Rootkey:=HKEY_LOCAL_MACHINE;
        Res:=Reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion',false);
        if Res then begin
          Result:=Reg.ReadString('ProgramFilesPath');
          Reg.CloseKey;
        end;
      finally
        Reg.Free;
      end;
    end;

  begin
    Result:=AText;
    P:=Pos('%', AText);
    if P>0 then begin
      Q:=PosN('%', AText, P+1);
      PathVar:=LowerCase(copy(AText, P, Q-P+1));
      RealPath:='???';
      if PathVar=LowerCase(GetProgramFilesPathVar) then
        RealPath:=GetProgramFilesDir;
      if PathVar='%systemroot%' then
        RealPath:=GetWindowsDir;
      Result:=copy(AText, 1, P-1)+ExcludeTrailingPathDelimiter(RealPath)+copy(AText, Q+1, length(AText)-Q);
    end;
  end;

begin
  Result:='';
  P:=Pos(':', URL);
  if P>1 then
    delete(URL, P, length(URL)-P+1);
  {$IFDEF SR_Delphi4_Up}
  Reg := TRegistry.Create(Key_Read);
  {$ELSE}
  Reg := TRegistry.Create;
  {$ENDIF}
  try
    Reg.Rootkey:=HKEY_CLASSES_ROOT;
    Res:=Reg.OpenKey(URL+'\shell\open\command', false);
    if Res then begin
      Temp:=Reg.ReadString('');
      while (length(Temp)>0) and ((Temp[1]='"') or (Temp[1]=' ')) do
        delete(Temp, 1, 1);
      P:=Pos('"', Temp);
      if P>0 then
        delete(Temp, P, length(Temp)-P+1);
      Result:=ReplaceRegistryPathVars(Temp);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
end; {GetExeForProtocol}

procedure OpenNewBrowserWindow(const ApplicationHandle: THandle;
                               const OpenNewWindow: boolean;
                               const Handle: HWND;
                               const Operation, FileName, Parameters, Directory: string;
                               const ShowCommand: integer);
var
  AppPath: String;
  AppExe: String;
  ExePath: string;
  pOperation: PChar;
  pFilename: PChar;
  pParameter: PChar;
  pDirectory: PChar;
begin
  if (Operation <> '') then
    pOperation := PChar(Operation)
  else
    pOperation := nil;
  if (FileName <> '') then
    pFilename := PChar(FileName)
  else
    pFilename := nil;
  if (Parameters <> '') then
    pParameter := PChar(Parameters)
  else
    pParameter := nil;
  if (Directory <> '') then
    pDirectory := PChar(Directory)
  else
    pDirectory := nil;

  if OpenNewWindow then
  begin
    {
      Open a new browser window.
    }
    ExePath := GetExeForProtocol(FileName);
    AppPath := ExtractFilePath(ExePath);
    AppExe := ExtractFileName(ExePath);
    {
      Mozilla has ' -url ' appended in ExePath.
      With this string shellexecute doesn't open a new window.
      Therefor delete it.
    }
    if Pos(' ', AppExe) <> 0 then
      Delete(AppExe, Pos(' ', AppExe), Length(AppExe));
    ExePath := AppPath + AppExe;
    ShellExecute(Handle, pOperation, PChar(ExePath), pFilename,
                 pDirectory, ShowCommand);
  end
  else
  begin
    ShellExecute(Handle, pOperation, pFilename, pParameter, pDirectory, ShowCommand);
  end;
end;

function ReadIEUserAgent: string;
var
  Reg: TRegistry;
begin

  {
    Set a generic user agent.
  }
  result := 'Mozilla/4.0 (compatible; MSIE 5.0; Win32)';
  try

    {
      Create a "readonly" registry object.
      Since we just want to read from the registry we set the access level to
      KEY_READ.
      The creation would fail if the user has no administrator rights on the pc.
    }
    Reg := TRegistry.Create(KEY_READ);
    try

      {
        Set the path to the user agent entry.
      }
      Reg.RootKey := HKEY_CURRENT_USER;
      Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet Settings\', false);
      {
        If the value exists and its not empty read and return it.
      }
      if (Reg.ValueExists('User Agent')) and not (Length(Trim(Reg.ReadString('User Agent'))) = 0)
        then result := Reg.ReadString('User Agent');
    finally
      FreeAndNil(Reg);
    end;
  except
  end;
end;

end.