FAQ VCL
Браузер

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

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

:: MVP ::

:: RSS ::

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

Как програмно открыть URL в новом окне браузера?

uses
  {...,} ShellApi;

// Для того, чтобы Internet Explorer запустился, 
// обязательно нужно, чтобы Label1.Caption начинался с 
// "www." или "http://" { естественно без ковычек }
procedure TForm1.Label1Click(Sender: TObject);
begin
   keybd_event( VK_SHIFT, 0, 0, 0 );
   ShellExecute( 0, nil, PChar( Label1.Caption ),
                 nil, nil, SW_NORMAL );
   keybd_event( VK_SHIFT, 0, KEYEVENTF_KEYUP, 0 );
end;


Как получить активный URL из браузера?

uses
  {...,} DdeMan;

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    function Get_URL(Servicio: string): String;
  public
    { Public declarations }
  end;

function TForm1.Get_URL(Servicio: string): String;
var
  Cliente_DDE: TDDEClientConv;
  temp: PChar;
begin
   Result := '';
   Cliente_DDE:= TDDEClientConv.Create( nil );
   with Cliente_DDE do
   begin
      SetLink( Servicio, 'WWW_GetWindowInfo' );
      temp := RequestData( '0xFFFFFFFF' );
      Result := StrPas( temp );
      StrDispose( temp );
      CloseLink;
   end;       
   Cliente_DDE.Free; 
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( Get_URL( 'IExplore' ) );
//   ShowMessage( Get_URL( 'Netscape' ) );
end;


Как получить закладки из IE?

uses
  {...,} ShlObj;

function GetIEFavourites(const FavPath: string):TStrings;
var
  SearchRec: TSearchRec;
  str: TStrings;
  path, dir, filename: string;
  Buffer: array[0..2047] of Char;
  found: integer;
begin
   str := TStringList.Create;
   path := FavPath + '\*.url';
   dir := ExtractFilepath( path );
   found := FindFirst( path, faAnyFile, SearchRec );
   while found = 0 do
   begin
      SetString( filename, Buffer, GetPrivateProfileString( 'InternetShortcut',
      PChar( 'URL' ), nil, Buffer, SizeOf( Buffer ), PChar( dir + SearchRec.Name ) ) );
      str.Add( filename );
      found := FindNext( SearchRec );
   end;
   found := FindFirst( dir + '\*.*', faAnyFile, SearchRec );
   while found = 0 do
   begin
      if ( ( SearchRec.Attr and faDirectory ) > 0 ) and ( SearchRec.Name[1] <> '.' ) then
         str.AddStrings( GetIEFavourites( dir + '\' + SearchRec.Name ) );
      found := FindNext( SearchRec );
   end;
   FindClose( SearchRec );
   Result := str;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  pidl: PItemIDList;
  FavPath: array[0..MAX_PATH] of char;
begin
   SHGetSpecialFolderLocation( Handle, CSIDL_FAVORITES, pidl );
   SHGetPathFromIDList( pidl, FavPath );
   ListBox1.Items := GetIEFavourites( StrPas( FavPath ) );
end;


Как отчистить Temporary Internet Files?

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

procedure EmptyTemporaryInternetFiles;
var
  lpEntryInfo: PInternetCacheEntryInfo;
  hCacheDir: LongWord;
  dwEntrySize: LongWord;
  dwLastError: LongWord;
begin
   dwEntrySize := 0;
   FindFirstUrlCacheEntry( nil, TInternetCacheEntryInfo( nil^ ), dwEntrySize );
   GetMem( lpEntryInfo, dwEntrySize );
   hCacheDir := FindFirstUrlCacheEntry( nil, lpEntryInfo^, dwEntrySize );
   if ( hCacheDir <> 0 ) then
      DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );
   FreeMem( lpEntryInfo );
   repeat
      dwEntrySize := 0;
      FindNextUrlCacheEntry( hCacheDir, TInternetCacheEntryInfo( nil^ ), dwEntrySize );
      dwLastError := GetLastError;
      if ( GetLastError = ERROR_INSUFFICIENT_BUFFER ) then
      begin
         GetMem( lpEntryInfo, dwEntrySize );
         if ( FindNextUrlCacheEntry( hCacheDir, lpEntryInfo^, dwEntrySize ) ) then
            DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );
         FreeMem( lpEntryInfo );
      end;
   until ( dwLastError = ERROR_NO_MORE_ITEMS );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   EmptyTemporaryInternetFiles;
end;

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

procedure DeleteIECache;
var 
  lpEntryInfo: PInternetCacheEntryInfo; 
  hCacheDir: LongWord; 
  dwEntrySize: LongWord; 
begin 
   dwEntrySize := 0;
   FindFirstUrlCacheEntry( nil, TInternetCacheEntryInfo( nil^ ), dwEntrySize );
   GetMem( lpEntryInfo, dwEntrySize );
   if dwEntrySize > 0 then
      lpEntryInfo^.dwStructSize := dwEntrySize;
   hCacheDir := FindFirstUrlCacheEntry( nil, lpEntryInfo^, dwEntrySize );
   if hCacheDir <> 0 then
   begin
      repeat
         DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );
         FreeMem( lpEntryInfo, dwEntrySize );
         dwEntrySize := 0;
         FindNextUrlCacheEntry( hCacheDir, TInternetCacheEntryInfo( nil^ ), dwEntrySize );
         GetMem( lpEntryInfo, dwEntrySize );
         if dwEntrySize > 0 then
            lpEntryInfo^.dwStructSize := dwEntrySize;
      until not FindNextUrlCacheEntry( hCacheDir, lpEntryInfo^, dwEntrySize );
   end;
   FreeMem( lpEntryInfo, dwEntrySize );
   FindCloseUrlCache( hCacheDir );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   DeleteIECache;
end;


Как узнать стартовую страницу Internet Explorer?

uses
  {...,} Registry;

function GetIEStartPage: string;
var
  Reg: TRegistry;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CURRENT_USER;
      Reg.OpenKey( 'Software\Microsoft\Internet Explorer\Main', false );
      try
         Result := Reg.ReadString( 'Start Page' );
      except
         Result := '';
      end;
      Reg.CloseKey;
   finally
      Reg.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( GetIEStartPage );
end;


Как изменить стартовую страницу Internet Explorer?

uses
  {...,} Registry;

function SetIEStartPage( APage: string ): boolean;
var
  Reg: TRegistry;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CURRENT_USER;
      Reg.OpenKey( 'Software\Microsoft\Internet Explorer\Main', false );
      try
         Reg.WriteString( 'Start Page', APage );
         Result := True;
      except
         Result := false;
      end;
      Reg.CloseKey;
   finally
      Reg.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SetIEStartPage( 'http://decoding.narod.ru' );
end;


Как узнать версию IE?

uses
  {...,} Registry;

function GetIEVersion( Key: string ): string;
var 
  Reg: TRegistry; 
begin 
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_LOCAL_MACHINE;
      Reg.OpenKey( 'Software\Microsoft\Internet Explorer', false );
      try
         Result := Reg.ReadString( Key );
      except
         Result := '';
      end;
      Reg.CloseKey;
   finally
      Reg.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( 'IE-Version: ' + GetIEVersion( 'Version' )[1] + '.'
                + GetIEVersion( 'Version' )[3] );
   ShowMessage( 'IE-Version: ' + GetIEVersion( 'Version' ) );
   // <major version>.<minor version>.<build number>.<sub-build number>
end;


Как получить список последних открытых адресов IE?

uses
  {...,} Registry;

procedure ShowTypedUrls( Urls: TStrings );
var
  Reg: TRegistry;
  S: TStringList;
  i: Integer;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CURRENT_USER;
      if Reg.OpenKey( 'Software\Microsoft\Internet Explorer\TypedURLs', false ) then
      begin
         S := TStringList.Create;
         try
            Reg.GetValueNames( S );
            for i := 0 to S.Count-1 do
               Urls.Add( Reg.ReadString( S.Strings[i] ) );
         finally
            S.Free;
         end;
         Reg.CloseKey;
      end;
   finally
      Reg.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowTypedUrls( ListBox1.Items );
end;


Как определить установлен ли Internet Explorer?

uses
  {...,} Registry;

function IE_installed( var Version: string ): boolean;
var
  Reg: TRegistry;
begin
   Reg := TRegistry.Create;
   with Reg do
   begin
      RootKey := HKEY_LOCAL_MACHINE;
      OpenKey( 'Software\Microsoft\Internet Explorer', false );
      if ValueExists( 'Version' ) then
         Version := ReadString( 'Version' )
      else
         Version := '';
      CloseKey;
      Free;
   end;
   Result := Version <> '';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  IE_Version: string;
begin
   if IE_Installed( IE_Version ) then
      ShowMessage( Format( 'Установлен Internet Explorer версии %s', [IE_Version] ) );
end;


Как узнать путь к браузеру по умолчанию?

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

procedure TForm1.Button1Click(Sender: TObject);
var
  Reg: TRegistry;
  ValueStr: string;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CLASSES_ROOT;
      if Reg.OpenKey( 'htmlfile\shell\open\command', false ) then
      begin
         ValueStr := Reg.ReadString( '' );
         Reg.CloseKey;
         ShowMessage( ValueStr );
      end
      else
         ShowMessage( 'No Default Webbrowser !' );
   finally
      Reg.Free;
   end;
end;

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

function GetDefBrowser: string;
var
  Reg: TRegistry;
begin
   Result := '';
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CLASSES_ROOT;
      if Reg.OpenKey( '\http\shell\open\command', FALSE ) then
         if Reg.ValueExists('') then
            Result := Reg.ReadString( '' );
      Result := Copy( Result, 0, Length( Result ) - Length( ExtractFileExt( Result ) ) ) + '.exe';
      if Copy( Result, 1, 1 ) = '"' then
         Result := Copy( Result, 2, Length( Result ) - 1 );
      Reg.CloseKey;
   finally
      Reg.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( GetDefBrowser );
end;

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

function StripChar( SelChar: Char; PassedStr: string ): string;
var
  DelPos: Integer;
begin
   while Pos( SelChar, PassedStr ) <> 0 do
   begin
      DelPos := Pos( SelChar, PassedStr );
      Delete( PassedStr, DelPos, 1 );
   end;
   Result := PassedStr;
end;

function GetDefaultBrowser: string;
var
  Reg: TRegistry;
  RegKeyInfo: TRegKeyInfo;
  HtmlKey, AssocType, FullProgPath: string;
  DelPos, DelLength: Integer;
begin
   Reg := TRegistry.Create;

   try
      try
         HtmlKey := '.html';
         Reg.RootKey := HKEY_CLASSES_ROOT;
         if Reg.KeyExists( HtmlKey ) then
         begin
            if Reg.OpenKey( HtmlKey, False ) then
            begin
               AssocType := Reg.ReadString( '' );
               Reg.CloseKey;
               AssocType := AssocType + '\shell\open\command';
               if Reg.OpenKey( AssocType, False ) then
               begin
                  FullProgPath := UpperCase( Reg.ReadString( '' ) );
                  FullProgPath := StripChar( '"', FullProgPath );
                  DelPos := Pos( 'EXE', FullProgPath );
                  DelLength := Length( FullProgPath ) - DelPos;
                  if DelPos <> 0 then
                     Delete( FullProgPath, DelPos+3, DelLength+1 );
                  Result := FullProgPath;
                  Reg.CloseKey;
               end;
            end;
         end
         else
            Result := 'Не удалось обнаружить веб-браузер по умолчанию.';
      except
         Result := 'Не удалось обнаружить веб-браузер по умолчанию.';
      end; { try/except }
   finally
      Reg.Free;
   end; { try/finally }
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( GetDefaultBrowser );
end;

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