Открыть URL в новом стандартном окне TWebBrowser 2

Delphi , Интернет и Сети , Браузер

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

 { From: http://community.borland.com/article/0,1410,16858,00.html }

 uses
   DdeMan,
 {$IFDEF WIN32}
   Registry; {We will get it from the registry}
 {$ELSE}
   IniFiles; {We will get it from the win.ini file}
 {$ENDIF}

 {$IFNDEF WIN32}
 const
    MAX_PATH = 144;
   {$ENDIF}

 function GetProgramAssociation(Ext: string): string;
 var
   {$IFDEF WIN32}
   reg: TRegistry;
   s: string;
   {$ELSE}
   WinIni: TIniFile;
   WinIniFileName: array[0..MAX_PATH] of Char;
   s: string;
   {$ENDIF}
 begin
   {$IFDEF WIN32}
   s := '';
   reg := TRegistry.Create;
   reg.RootKey := HKEY_CLASSES_ROOT;
   if reg.OpenKey('.' + ext + '\shell\open\command',
     False) <> False then
    begin
     {The open command has been found}
     s := reg.ReadString('');
     reg.CloseKey;
   end
    else
    begin
     {perhaps thier is a system file pointer}
     if reg.OpenKey('.' + ext,
       False) <> False then
      begin
       s := reg.ReadString('');
       reg.CloseKey;
       if s <> '' then
        begin
         {A system file pointer was found}
         if reg.OpenKey(s + '\shell\open\command',
           False) <> False then
           {The open command has been found}
           s := reg.ReadString('');
         reg.CloseKey;
       end;
     end;
   end;
   {Delete any command line, quotes and spaces}
   if Pos('%', s) > 0 then
     Delete(s, Pos('%', s), Length(s));
   if ((Length(s) > 0) and
     (s[1] = '"')) then
     Delete(s, 1, 1);
   if ((Length(s) > 0) and
     (Pos('"', s) > 0)) then
     Delete(s, Pos('"', s), Length(s));
   while ((Length(s) > 0) and
     (s[Length(s)] = ' ')) do
     Delete(s, Length(s), 1);
   {$ELSE}
   GetWindowsDirectory(WinIniFileName, SizeOf(WinIniFileName));
   StrCat(WinIniFileName, '\win.ini');
   WinIni := TIniFile.Create(WinIniFileName);
   s  := WinIni.ReadString('Extensions',ext,'');
   WinIni.Free;
   {Delete any command line}
   if Pos(' ^', s) > 0 then
     Delete(s, Pos(' ^', s), Length(s));
   {$ENDIF}
   Result := s;
 end;

 procedure StartNewBrowserWindow(URL: string);
 var
   DDEConv: TDDEClientConv;
   URLFired: bool;
   App: string;
   UpApp: string;
   p: array[0..MAX_PATH] of Char;
 begin
   UrlFired := False;
   App := GetProgramAssociation('HTM');
   UpApp := Uppercase(App);
   Delete(App, Pos('.EXE', UpAPP), Length(App));
   if Pos('NETSCAPE.EXE',
     UpApp) > 0 then
    begin
     DDEConv := TDDEClientConv.Create(nil);
     DDEConv.ServiceApplication := App;
     if DDEConv.SetLink('NETSCAPE', 'WWW_OpenURL') then
       if DDEConv.RequestData(URL + ',,0x0,0x0') <> nil then
         if DDEConv.SetLink('NETSCAPE', 'WWW_Activate') then
           URLFired := DDEConv.RequestData('0xFFFFFFFF,0x0') <> nil;
     DDEConv.Free;
   end
    else if Pos('IEXPLORE.EXE',
     UpApp) > 0 then
    begin
     DDEConv := TDDEClientConv.Create(nil);
     DDEConv.ServiceApplication := App;
     if DDEConv.SetLink('iexplore', 'WWW_OpenURL') then
       if DDEConv.RequestData(URL + ',,0') <> nil then
         if DDEConv.SetLink('iexplore', 'WWW_Activate') then
           URLFired := DDEConv.RequestData('0,0') <> nil;
     DDEConv.Free;
   end;
   if UrlFired = False then
     WinExec(StrPCopy(@p, URL), SW_SHOWNORMAL);
 end;

 procedure TForm1.Button1Click(Sender: TObject);
 begin
   StartNewBrowserWindow('http://www.borland.com');
   StartNewBrowserWindow('http://www.yahoo.com');
 end;

Функция GetProgramAssociation Эта функция получает программную ассоциацию для конкретного расширения файла из реестра Windows или INI-файла. Ассоциация используется для определения, какой приложение должно быть запущено, когда файл с этим расширением открывается.

Функция принимает два параметра: Ext, расширение файла для которого ассоциация получается, и s, переменная, которая будет хранить результатную программную ассоциацию.

Сначала функция проверяет, является ли она запущенной на Windows (WIN32) или нет. Если это Windows, она использует реестр для получения ассоциации; в противном случае, она использует INI-файл.

Затем функция открывает ключ реестра для указанного расширения и получает значение, связанное с подключением "shell\open\command". Это значение ожидается быть строкой, содержащей командную строку, используемую для запуска приложения, ассоциированного с расширением.

Если ключ "shell\open\command" не существует, функция проверяет, есть ли системный файловый указатель, связанный с расширением, и получает его командную строку, если она существует.

Функция затем очищает любые кавычки или пробелы в полученной командной строке, удаляя их с помощью процедуры Delete.

Процедура StartNewBrowserWindow Эта процедура открывает новый браузерный окно для указанного URL. Она принимает один параметр: URL, URL, который нужно открыть.

Процедура сначала проверяет, есть ли программная ассоциация для расширения "HTM" (обычно ассоциированного с файлами HTML). Если ассоциация существует, она проверяет, является ли приложение, ассоциированное с этим расширением, Netscape или Internet Explorer. Если это Netscape, она использует DDE для отправки запроса на открытие URL с помощью Netscape; если это Internet Explorer, она использует DDE для отправки запроса на открытие URL с помощью IE.

Если ассоциация не существует для расширения "HTM", или если пользовательский браузер не является Netscape или IE, процедура переходит к использованию WinExec для запуска по умолчанию браузера и открытия указанного URL.

Событие кнопки Button1Click Это событие вызывается, когда на форме нажимается кнопка. Оно вызывает процедуру StartNewBrowserWindow дважды, один раз с URL "http://www.borland.com" и один раз с URL "http://www.yahoo.com". Это откроет два новых браузерных окна для этих URL.

В целом, это код обеспечивает способ запуска по умолчанию браузера (Netscape или Internet Explorer) изнутри приложения Delphi, используя DDE на Windows. Если по умолчанию браузер не является Netscape или IE, он переходит к запуску по умолчанию браузера с помощью WinExec.

Открытие URL в новом стандартном окне TWebBrowser 2 позволяет пользователю открыть выбранную страницу в отдельном окне.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Браузер ::