Модераторы: Poseidon, Snowy, bems, MetalFan

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> как связать EmbeddedWB1NewWindow2 с Paramstr(2), событие NewWindow2 + Paramstrp + ppdisp  
V
    Опции темы
s2004
  Дата 2.10.2012, 19:58 (ссылка)    | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



в embeddedwb имеется событие  EmbeddedWB1NewWindow2 необходимое для открытия нового окна при кликание сылки при этом подставляется урл открывается новое окно, но при закрытие родительской формы всё тоже закрывается решил о необходимости запускать копию программы с подстановкой урла тут в некоторых форумах были советы с испрользованием  Paramstrp и shellexecute. 
перепрообвал многие, но только получилось так, что запускается копия и плюс ещё iexplorer ...

Код вначале который был
Код

procedure TForm1.EmbeddedWB1NewWindow2(ASender: TObject; var ppDisp: IDispatch;
 var Cancel: WordBool);
 var NewWindow:TForm1;
begin

NewWindow := TForm1.Create(parent);
SetWindowLong(NewWindow.Handle, GWL_EXSTYLE, GetWindowLong(NewWindow.Handle, GWL_EXSTYLE) or WS_EX_APPWINDOW);
NewWindow.Show;
ppDisp:=NewWindow.EmbeddedWB1.DefaultDispatch; 



коды некоторые которые перепробовал меня смущает, что получается в них я не задействовал
парметр заданый в событие это var ppDisp: IDispatch;

Код

procedure TForm1.EmbeddedWB1NewWindow2(ASender: TObject; var ppDisp: IDispatch;
  var Cancel: WordBool);
  var
    url,ts: string;
   NewWindow:TForm1;

begin
  with TRegistry.Create do
      try
        rootkey := HKEY_CLASSES_ROOT;
        OpenKey('\htmlfile\shell\open\command', False);
        try
          ts := ReadString('');
        except
          ts := '';
        end;
        CloseKey;
      finally
        Free;
      end;
    if ts = '' then Exit;

//winexec (Pchar('C:\Program Files\Net\net.exe'), SW_SHOWNORMAL);
  
 ts := Copy(ts, Pos('"', ts) + 1, Length(ts));
    ts := Copy(ts, 1, Pos('"', ts) - 1);
    ShellExecute(3, 'open', PChar('ppDisp:=NewWindow.EmbeddedWB1.DefaultDispatch'), PChar(url), nil, SW_SHOW);
//  ShellExecute( handle, 'net', PChar('C:\Program Files\Net\net.exe'), PChar(url), nil, SW_SHOW);
    
//ppDisp := Self.EmbeddedWB1.Application;
  end;


одним словом запутался  smile 
PM MAIL   Вверх
s2004
  Дата 5.10.2012, 22:40 (ссылка)    | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



Код


 var
  newwindow:tform1;
//  dir:string;
begin
//   dir:=extractFilePath(ParamStr(0));

NewWindow := TForm1.Create(parent);
//SetWindowLong(NewWindow.Handle, GWL_EXSTYLE, GetWindowLong(NewWindow.Handle, GWL_EXSTYLE) or WS_EX_APPWINDOW);
NewWindow.Show;
// dir:=extractFilePath(ParamStr(0));
ShellExecute(form1.Handle, 'open', 'c:\netwin.exe', nil, nil, SW_SHOWNORMAL);


// ShellExecute(Form1.Handle, paramstr(0),nil, nil, SW_SHOWNORMAL);
ppDisp:=NewWindow.EmbeddedWB1.DefaultDispatch;


запускается копия программы, но урл неподстовляется
PM MAIL   Вверх
s2004
  Дата 6.10.2012, 18:32 (ссылка)    | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



по порядку в DRKB идёт такой пример
OnNewWindow2 
Возникает при попытке открыть документ в новом окне. Если Вы хотите, чтобы документ был открыт в Вашем экземпляре броузера, то Вам нужно создать свой экземпляр броузера и параметру ppDisp присвоить интерфейсную ссылку на этот экземпляр:
Код

procedure TFormSimpleWB.WebBrowser1NewWindow2(Sender: TObject;   
  var ppDisp: IDispatch; var Cancel: WordBool);   
var    
  newForm:TFormSimpleWB;   
begin    
  newForm := TFormSimpleWB.Create(Application);   
  newForm.Show;   
  ppDisp := newForm.WebBrowser1.ControlInterface;   
end;  

как видите код, как у меня практически,  он запускает новое окно, НО ТОЛЬКО, КАК ДОЧЕРНЕЕ при этом при закрытие родительского закрывается и дочернее на форуме http://forum.sources.ru/index.php?showtopic=346017 посоветовали использовать winexec (shellexec) в связки с paramcount при этом рассуждаем так 
Код

var    
  newForm:TFormSimpleWB;   

 
не нужен? ведь с помощью shellexecute мы должны запустить копию программы с диска по умолчанию в c:\program files\net\net.exe пробовал разные варианты 
перечисляю 
Код

 ShellExecute(handle,'open','net.exe', Pchar(d), nil, SW_RESTORE);
ShellExecute(handle,'open',PChar(d),PChar(newwindow.EmbeddedWB1.DefaultDispatch),nil, SW_SHOWNORMAL);
 ShellExecute(NewWindow.EmbeddedWB1.LoadFrameFromStrings, 'open', PChar(newWindow), nil, nil, SW_NORMAL);
 ShellExecute(NewWindow.Handle, 'open', 'www.scip.be', nil, nil, SW_SHOW);
ShellExecute (Form1.Handle, nil, PChar (Application.ExeName), nil, nil, SW_RESTORE);


но это запустит только копию программы с установочной папки а как сотворить подстановку урла?
Куда прикрутить ppdisp? 
PM MAIL   Вверх
s2004
Дата 7.10.2012, 22:22 (ссылка)    | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



Код

var
  Form1: TForm1;
  S:string; //тут будем хранить сылку на новое окно

procedure TForm1.EmbeddedWB1StatusTextChange(ASender: TObject;
  const Text: WideString);
begin
 StatusBar1.SimpleText:=Text;
  if Copy(Text, 1, 4)='http' then S:=Text; //Если ссылка, то ее записать
                                    //(вдруг потом нужно будет по ней перейти)



procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
begin
  Cancel:=True; //Заприщаем запуск обозревателя IE
  ShellExecute(Handle, 'open', PChar(ParamStr(0)), PChar(S), nil, 0);
    //Запускаем себя еще раз, только указав в параметрах ссылку на новое окно
    // можно и вкладки создать, как в опере... но это уже другой разговор =))
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  if Form1.Tag=1 then Exit;
  If ParamCount>0 then   //Если имеется параметр, то переходим по нему
  begin
    Edit1.Text:=ParamStr(1);
    WebBrowser1.Navigate(ParamStr(1));
  end;
  Form1.Tag:=1; //Если сново будет вызов onshow, то ничего не делать
end;




вот нашёл на одном форуме 

Это сообщение отредактировал(а) s2004 - 7.10.2012, 22:37
PM MAIL   Вверх
s2004
Дата 7.10.2012, 22:51 (ссылка)    | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



вот только теперь любой клик открывается в новом окне ... а как сделать чтобы выбор был открыть в новом или в старом
PM MAIL   Вверх
s2004
Дата 8.10.2012, 20:09 (ссылка)    | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



Код

procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
   const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
   Headers: OleVariant; var Cancel: WordBool);
 var
   newURL: string;
 begin
   newURL := URL;
   // For local links, don't show a dialog but open the file directly 
  if (not FIsStartPage) and FileExists(newURL) then
   begin
     Cancel := True;
     ShellExecute(Application.Handle, 'open', PChar(newURL), nil, nil, SW_NORMAL);
   end;
 end;



всё работает и в новом окне и в текущем...
PM MAIL   Вверх
Чучмек
Дата 9.10.2012, 01:57 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


НЭТ БИЛЭТ
**


Профиль
Группа: Участник
Сообщений: 841
Регистрация: 11.5.2008
Где: СССР

Репутация: 14
Всего: 41



Открытие страницы в  новом окне, это нечто большее, чем запуск копии браузера с новым урл. Сохраняется связь между старой страницей и новой.
Поэтому в  OnNewWindow2 мы имеем ppDisp: IDispatch, а не URL:string.
Правильное решение с другой стороны (COM).
Аналогично использованию MS Office через CreateOleObject('Word.Application') 


--------------------
умную мысль держи при себе, а дурной - поделись с другими 
PM MAIL   Вверх
Чучмек
Дата 9.10.2012, 17:32 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


НЭТ БИЛЭТ
**


Профиль
Группа: Участник
Сообщений: 841
Регистрация: 11.5.2008
Где: СССР

Репутация: 14
Всего: 41



Отмечаю все сообщения минусом, потому что в корне неверное решение.
Если правая нога не лезет в левый ботинок - примотаем ботнки к ногам изолентой.


--------------------
умную мысль держи при себе, а дурной - поделись с другими 
PM MAIL   Вверх
s2004
Дата 9.10.2012, 19:48 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



чучмек прочитай своё , что написал.... твоё сообщение один минус 

Повторю кто в танке, событие onnewwindow при использование
 
Код

ppDisp:=NewWindow.EmbeddedWB1.DefaultDispatch; 


открывала новое окно но только как дочернее которое закрывалось при закрытие родительского 
окна а мне в моей пргги этого не нужно
 поэтому код был изменён на 
Код

 Cancel:=True; //Запрещаем запуск обозревателя IE
  ShellExecute(Handle, 'open', PChar(ParamStr(0)), PChar(S), nil, 0);


при этом и запускается копия проги с диска с подстановкой урла, что мне и надо было, а различные опусы не нужны, выложил тем кому возможно понадобится. 

p.s.Модераторы прошу заблокировать тему без возможности суда ещё что- то писать. 

PM MAIL   Вверх
Чучмек
Дата 9.10.2012, 19:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


НЭТ БИЛЭТ
**


Профиль
Группа: Участник
Сообщений: 841
Регистрация: 11.5.2008
Где: СССР

Репутация: 14
Всего: 41



Писать лень.
Вот посмотри.


Присоединённый файл ( Кол-во скачиваний: 6 )
Присоединённый файл  ppppp.7z 175,69 Kb


--------------------
умную мысль держи при себе, а дурной - поделись с другими 
PM MAIL   Вверх
MetalFan
Дата 9.10.2012, 20:10 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128



Цитата(s2004 @  9.10.2012,  19:48 Найти цитируемый пост)
Модераторы прошу заблокировать тему без возможности суда ещё что- то писать. 

ну-ну, полегче. не вижу повода для санкций.

Это сообщение отредактировал(а) MetalFan - 9.10.2012, 20:12


--------------------
There are always someone smarter than you...
PM MAIL   Вверх
Чучмек
Дата 9.10.2012, 20:14 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


НЭТ БИЛЭТ
**


Профиль
Группа: Участник
Сообщений: 841
Регистрация: 11.5.2008
Где: СССР

Репутация: 14
Всего: 41



Цитата(s2004 @  9.10.2012,  19:48 Найти цитируемый пост)
p.s.Модераторы прошу заблокировать тему без возможности суда ещё что- то писать. 

Встречная просьба повременить. Тема, на самом деле, интересная. Мне еще есть что сказать, в смысле кода, а не рассуждений. Сейчас не очень много времени, а нужно проверить прежде чем выкладывать 



--------------------
умную мысль держи при себе, а дурной - поделись с другими 
PM MAIL   Вверх
s2004
Дата 9.10.2012, 20:15 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 174
Регистрация: 30.10.2006

Репутация: нет
Всего: нет



архив посмотрел спасибо. это ещё одно решение - правда неудобно то, что на панели задач отображается в виде одного значка.

так я понял код будет интересен зрителям поэтому выложу его: 

Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,unit2;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  form_count:cardinal=0;

function NewForm:Idispatch;
procedure DecFormCount;
implementation

{$R *.dfm}

function NewForm:Idispatch;
begin
 with TForm2.Create(Application)do
  begin
  visible:=true;
  result:=WebBrowser1.DefaultDispatch;
  inc(form_count);
  end;
end;

procedure DecFormCount;
begin
dec(form_count);
if form_count=0 then application.Terminate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
NewForm;
end;

end.
 
unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw, StdCtrls, ExtCtrls;

type
  TForm2 = class(TForm)
    Panel1: TPanel;
    Edit1: TEdit;
    Button1: TButton;
    WebBrowser1: TWebBrowser;
    procedure Button1Click(Sender: TObject);
    procedure WebBrowser1NewWindow2(Sender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation
 uses unit1;

{$R *.dfm}

procedure TForm2.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate(edit1.Text);
end;

procedure TForm2.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
begin
 ppDisp:=NewForm;
end;

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DecFormCount;
end;

end.

PM MAIL   Вверх
Чучмек
Дата 9.10.2012, 20:22 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


НЭТ БИЛЭТ
**


Профиль
Группа: Участник
Сообщений: 841
Регистрация: 11.5.2008
Где: СССР

Репутация: 14
Всего: 41



Цитата(s2004 @  9.10.2012,  20:15 Найти цитируемый пост)
правда неудобно то, что на панели задач отображается в виде одного значка

Это тоже легко решаеться.


--------------------
умную мысль держи при себе, а дурной - поделись с другими 
PM MAIL   Вверх
Чучмек
Дата 12.10.2012, 11:34 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


НЭТ БИЛЭТ
**


Профиль
Группа: Участник
Сообщений: 841
Регистрация: 11.5.2008
Где: СССР

Репутация: 14
Всего: 41



Вот. Наконец таки добрался.
В глубь по интерфейсам...
Перехват навигации. Пока без описания.   

unit1.pas
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,Unit_Obj, OleCtrls, SHDocVw, StdCtrls,shellapi;

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    WebBrowser2: TWebBrowser;
    Button1: TButton;
    Edit1: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure WebBrowser1NewWindow2(Sender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure cbp(s:widestring);
var param:string;
begin
 param:=s;
 shellexecute(0,nil,pchar(application.ExeName),pchar(param),nil,0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CallbackProc:=cbp;
  if ParamCount>0 then WebBrowser1.Navigate(ParamStr(1));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate(edit1.Text);
end;

procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
begin
 ppDisp:=TMyIC.Create(WebBrowser2.DefaultDispatch);
end;

end.


Unit_Obj.pas
Код

unit Unit_Obj;

interface

uses Unit_Interfaces,windows,urlmon,sysutils;


type
  TCallbackProc=procedure(url:widestring);

 TMyIC=class(TInterfacedObject,IDispatch)
  private
   FDisp:IDispatch;
  public
   constructor Create(Disp:IDispatch);
  protected
   function GetTypeInfoCount(out Count:integer):Hresult;stdcall;
   function GetTypeInfo(Index:Integer;LocaleId:Integer;out TypeInfo):Hresult;stdcall;
   function GetIDsOfNames(const IID:TGUID;Names:pointer;NameCount,LocaleID:integer;DispIDs:pointer):Hresult;stdcall;
   function Invoke(DispID:Integer;const IID:TGUID;LocaleID:Integer;Flags:Word;var Params;VarResult,ExcepInfo,ArgErr:pointer):Hresult;stdcall;
   function QueryInterface(const IID:TGUID;out Obj):Hresult;stdcall;
  end;

var CallbackProc:TCallbackProc=nil;

implementation

type

 TTargetFramePriv = class (TInterfacedObject,ITargetFramePriv)
  private
   FTargetFramePriv:ITargetFramePriv;
  public
   constructor create(TargetFramePriv:ITargetFramePriv);
  protected
   function  FindFrameDownwards(pszTargetName:LPCWSTR;dwFlags:DWORD;out ppunkTargetFrame:IUnknown ):HRESULT;stdcall;
   function  FindFrameInContext(pszTargetName:LPCWSTR;punkContextFrame: IUnknown;dwFlags:DWORD;out ppunkTargetFrame:IUnknown):HRESULT;stdcall;
   function  OnChildFrameActivate(pUnkChildFrame:IUnknown):HRESULT;stdcall;
   function  OnChildFrameDeactivate(pUnkChildFrame:IUnknown):HRESULT;stdcall;
   function  NavigateHack(grfHLNF:DWORD;pbc:cardinal{LPBC};pibsc: IBindStatusCallback;pszTargetName:LPCWSTR;pszUrl:LPCWSTR;pszLocation:LPCWSTR):HRESULT;stdcall;
   function  FindBrowserByIndex(dwID:DWORD;out ppunkBrowser: IUnknown):HRESULT;stdcall;
   function  QueryInterface(const IID:TGUID;out Obj):Hresult;stdcall;
  end;

 TTargetFramePriv2 = class(TTargetFramePriv,ITargetFramePriv2)
  public
    constructor Create(TargetFramePriv2:ITargetFramePriv2);
  protected
    function  AggregatedNavigation2(grfHLNF:DWORD;pbc:cardinal{LPBC;};pibsc:IBindStatusCallback;pszTargetName:LPCWSTR;pUri:IUri;pszLocation:LPCWSTR):HRESULT;stdcall;
  end;

 TUri_Property_Type=(PropertyNo,PropertyDWORD,PropertyStr);

 TUri_Property=record
  Property_Type : TUri_Property_Type;
  case  TUri_Property_Type of
   PropertyDWORD:   (vdw:dword);
   PropertyStr:     (vws:pwidechar);
 end;

 TPropertyTable = array [Uri_PROPERTY] of TUri_Property;

 TUri=class(TInterfacedObject,IUri)
  private
   FPropertyTable:TPropertyTable;
   FPropertyFlags:cardinal;
  public
   constructor create(PropertyTable:TPropertyTable);
  protected
   function GetPropertyBSTR(uriProp:Uri_PROPERTY;var pbstrProperty:BSTR;dwFlags:DWORD):HRESULT;stdcall;
   function GetPropertyLength(uriProp:Uri_PROPERTY;var pcchProperty:DWORD;dwFlags:DWORD):HRESULT;stdcall;
   function GetPropertyDWORD(uriProp:Uri_PROPERTY;var pdwProperty:DWORD;dwFlags:DWORD):HRESULT;stdcall;
   function HasProperty(uriProp:Uri_PROPERTY;var pfHasProperty:BOOL):HRESULT;stdcall;
   function GetAbsoluteUri(var pbstrAbsoluteUri:BSTR):HRESULT;stdcall;
   function GetAuthority(var pbstrAuthority:BSTR):HRESULT;stdcall;
   function GetDisplayUri(var pbstrDisplayString:BSTR):HRESULT;stdcall;
   function GetDomain(var pbstrDomain:BSTR):HRESULT;stdcall;
   function GetExtension(var pbstrExtension:BSTR):HRESULT;stdcall;
   function GetFragment(var pbstrFragment:BSTR):HRESULT;stdcall;
   function GetHost(var pbstrHost:BSTR):HRESULT;stdcall;
   function GetPassword(var pbstrPassword:BSTR):HRESULT;stdcall;
   function GetPath(var pbstrPath:BSTR):HRESULT;stdcall;
   function GetPathAndQuery(var pbstrPathAndQuery:BSTR):HRESULT;stdcall;
   function GetQuery(var pbstrQuery:BSTR):HRESULT;stdcall;
   function GetRawUri(var pbstrRawUri:BSTR):HRESULT;stdcall;
   function GetSchemeName(var pbstrSchemeName:BSTR):HRESULT;stdcall;
   function GetUserInfo(var pbstrUserInfo:BSTR):HRESULT;stdcall;
   function GetUserName(var pbstrUserName:BSTR):HRESULT;stdcall;
   function GetHostType(var pdwHostType:DWORD):HRESULT;stdcall;
   function GetPort(var pdwPort:DWORD):HRESULT;stdcall;
   function GetScheme(var pdwScheme:DWORD):HRESULT;stdcall;
   function GetZone(var pdwZone:DWORD):HRESULT;stdcall;
   function GetProperties(pdwFlags:LPDWORD):HRESULT;stdcall;
   function IsEqual(pUri:IUri;var pfEqual:BOOL):HRESULT;stdcall;
  end;

 { TMyIC }
constructor TMyIC.Create(Disp:IDispatch);
begin
FDisp:=Disp;
end;

function TMyIC.GetTypeInfoCount(out Count:integer):Hresult;stdcall;
begin
result:=FDisp.GetTypeInfoCount(Count);
end;

function TMyIC.GetTypeInfo(Index:Integer;LocaleId:Integer;out TypeInfo):Hresult;stdcall;
begin
result:=FDisp.GetTypeInfo(Index,LocaleId,TypeInfo);
end;

function TMyIC.GetIDsOfNames(const IID:TGUID;Names:pointer;NameCount,LocaleID:integer;DispIDs:pointer):Hresult;stdcall;
begin
result:=FDisp.GetIDsOfNames(IID,Names,NameCount,LocaleID,DispIDs);
end;

function TMyIC.Invoke(DispID:Integer;const IID:TGUID;LocaleID:Integer;Flags:Word;var Params;VarResult,ExcepInfo,ArgErr:pointer):Hresult;stdcall;
begin
result:=FDisp.Invoke(DispID,IID,LocaleID,Flags,Params,VarResult,ExcepInfo,ArgErr);
end;

function TMyIC.QueryInterface(const IID:TGUID;out Obj):Hresult;stdcall;
begin
result:=FDisp.QueryInterface(IID,Obj);
if result<>0 then exit;
if IsEqualGUID(IID,IID_TargetFramePriv)then
  ITargetFramePriv(obj):=TTargetFramePriv.create(ITargetFramePriv(obj))as ITargetFramePriv else
if IsEqualGUID(IID,IID_TargetFramePriv2)then
  ITargetFramePriv2(obj):=TTargetFramePriv2.create(ITargetFramePriv2(obj))as ITargetFramePriv2;
end;

{ TTargetFramePriv }

constructor TTargetFramePriv.create(TargetFramePriv: ITargetFramePriv);
begin
FTargetFramePriv:=TargetFramePriv;
end;

function TTargetFramePriv.FindBrowserByIndex(dwID: DWORD;
  out ppunkBrowser: IInterface): HRESULT;
begin
result:=FTargetFramePriv.FindBrowserByIndex(dwID,ppunkBrowser);
end;

function TTargetFramePriv.FindFrameDownwards(pszTargetName: LPCWSTR;
  dwFlags: DWORD; out ppunkTargetFrame: IInterface): HRESULT;
begin
result:=FTargetFramePriv.FindFrameDownwards(pszTargetName,dwFlags,ppunkTargetFrame);
end;

function TTargetFramePriv.FindFrameInContext(pszTargetName: LPCWSTR;
  punkContextFrame: IInterface; dwFlags: DWORD;
  out ppunkTargetFrame: IInterface): HRESULT;
begin
result:=FTargetFramePriv.FindFrameInContext(pszTargetName,punkContextFrame,dwFlags,ppunkTargetFrame);
end;

function TTargetFramePriv.NavigateHack(grfHLNF: DWORD; pbc: cardinal;
  pibsc: IBindStatusCallback; pszTargetName, pszUrl,
  pszLocation: LPCWSTR): HRESULT;
var i:IInterface;
begin
if (pbc<>0) and (pibsc<>nil)  then
 begin
 if Assigned(CallbackProc) then CallbackProc(pszUrl);
 pszUrl:='about:blank';
 end; 
result:=FTargetFramePriv.NavigateHack(grfHLNF,pbc,pibsc,pszTargetName,pszUrl,pszLocation);
end;

function TTargetFramePriv.OnChildFrameActivate(
  pUnkChildFrame: IInterface): HRESULT;
begin
result:=FTargetFramePriv.OnChildFrameActivate(pUnkChildFrame);
end;

function TTargetFramePriv.OnChildFrameDeactivate(
  pUnkChildFrame: IInterface): HRESULT;
begin
result:=FTargetFramePriv.OnChildFrameDeactivate(pUnkChildFrame);
end;

function TTargetFramePriv.QueryInterface(const IID: TGUID;
  out Obj): Hresult;
begin
result:=FTargetFramePriv.QueryInterface(IID,Obj);
end;



const PropertyTable:TPropertyTable=
 (
  (Property_Type:PropertyStr;  vws:'about:blank'),          //Uri_PROPERTY_ABSOLUTE_URI
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_AUTHORITY
  (Property_Type:PropertyStr;  vws:'about:blank'),          //Uri_PROPERTY_DISPLAY_URI
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_DOMAIN
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_EXTENSION
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_FRAGMENT
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_HOST
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_PASSWORD
  (Property_Type:PropertyStr;  vws:'blank'),                //Uri_PROPERTY_PATH
  (Property_Type:PropertyStr;  vws:'blank'),                //Uri_PROPERTY_PATH_AND_QUERY
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_QUERY
  (Property_Type:PropertyStr;  vws:'about:blank'),          //Uri_PROPERTY_RAW_URI
  (Property_Type:PropertyStr;  vws:'about'),                //Uri_PROPERTY_SCHEME_NAME
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_USER_INFO
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_USER_NAME
  (Property_Type:PropertyDWORD;vdw:DWORD(Uri_HOST_UNKNOWN)),//Uri_PROPERTY_HOST_TYPE
  (Property_Type:PropertyNo;   vdw:0),                      //Uri_PROPERTY_PORT
  (Property_Type:PropertyDWORD;vdw:DWORD(URL_SCHEME_ABOUT)),//Uri_PROPERTY_SCHEME
  (Property_Type:PropertyNo;   vdw:0)                       //Uri_PROPERTY_ZONE
 );




{ TTargetFramePriv2 }

function TTargetFramePriv2.AggregatedNavigation2(grfHLNF: DWORD;
  pbc: cardinal; pibsc: IBindStatusCallback; pszTargetName: LPCWSTR;
  pUri: IUri; pszLocation: LPCWSTR): HRESULT;
var
 url:WideString;
begin
if Assigned(CallbackProc) and (0=pUri.GetAbsoluteUri(url))then CallbackProc(url);
pUri:=TUri.Create(PropertyTable) as IUri;
result:=ITargetFramePriv2(FTargetFramePriv).AggregatedNavigation2(grfHLNF,pbc,pibsc,pszTargetName,pUri,pszLocation);
end;

constructor TTargetFramePriv2.Create(TargetFramePriv2: ITargetFramePriv2);
begin
  FTargetFramePriv:=ITargetFramePriv(TargetFramePriv2);
end;

{ TUri }

constructor TUri.Create(PropertyTable:TPropertyTable);
var
 i:Uri_PROPERTY;
 fr:dword;
begin
FPropertyTable:=PropertyTable;
FPropertyFlags:=0;
for i:=Uri_PROPERTY_ABSOLUTE_URI to Uri_PROPERTY_ZONE do
 if FPropertyTable[i].Property_Type<>PropertyNo then FPropertyFlags:=FPropertyFlags or(1 shl DWORD(i));
end;

function TUri.GetAbsoluteUri(var pbstrAbsoluteUri: BSTR): HRESULT;
begin
result:= GetPropertyBSTR(Uri_PROPERTY_ABSOLUTE_URI,pbstrAbsoluteUri,0);
end;

function TUri.GetAuthority(var pbstrAuthority: BSTR): HRESULT;
begin
result:= GetPropertyBSTR(Uri_PROPERTY_AUTHORITY,pbstrAuthority,0);
end;

function TUri.GetDisplayUri(var pbstrDisplayString: BSTR): HRESULT;
begin
result:= GetPropertyBSTR(Uri_PROPERTY_DISPLAY_URI,pbstrDisplayString,0);
end;

function TUri.GetDomain(var pbstrDomain: BSTR): HRESULT;
begin
result:= GetPropertyBSTR(Uri_PROPERTY_DOMAIN,pbstrDomain,0);
end;

function TUri.GetExtension(var pbstrExtension: BSTR): HRESULT;
begin
result:= GetPropertyBSTR(Uri_PROPERTY_EXTENSION,pbstrExtension,0);
end;

function TUri.GetFragment(var pbstrFragment: BSTR): HRESULT;
begin
result:= GetPropertyBSTR(Uri_PROPERTY_FRAGMENT,pbstrFragment,0);
end;

function TUri.GetHost(var pbstrHost: BSTR): HRESULT;
begin
result:= GetPropertyBSTR(Uri_PROPERTY_HOST,pbstrHost,0);
end;

function TUri.GetHostType(var pdwHostType: DWORD): HRESULT;
begin
result:= GetPropertyDWORD(Uri_PROPERTY_HOST_TYPE,pdwHostType,0);
end;

function TUri.GetPassword(var pbstrPassword: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_PASSWORD,pbstrPassword,0);
end;

function TUri.GetPath(var pbstrPath: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_PATH,pbstrPath,0);
end;

function TUri.GetPathAndQuery(var pbstrPathAndQuery: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_PATH_AND_QUERY,pbstrPathAndQuery,0);
end;

function TUri.GetPort(var pdwPort: DWORD): HRESULT;
begin
Result:=GetPropertyDWORD(Uri_PROPERTY_PORT,pdwPort,0);
end;

function TUri.GetProperties(pdwFlags: LPDWORD): HRESULT;
begin
if pdwFlags=nil then result:=S_FALSE else
 begin
 pdwFlags^:=FPropertyFlags;
 result:=0;
 end;
end;

function TUri.GetPropertyBSTR(uriProp: Uri_PROPERTY;
  var pbstrProperty: BSTR; dwFlags: DWORD): HRESULT;
begin
if (dword(uriProp)>18) or (FPropertyTable[uriProp].Property_Type=PropertyNo) then result:=S_FALSE else
if FPropertyTable[uriProp].Property_Type<>PropertyStr then Result:=E_INVALIDARG else
 begin
 pbstrProperty:=FPropertyTable[uriProp].vws;
 result:=S_OK;
 end;
end;

function TUri.GetPropertyDWORD(uriProp: Uri_PROPERTY;
  var pdwProperty: DWORD; dwFlags: DWORD): HRESULT;
begin
if (dword(uriProp)>18) or (FPropertyTable[uriProp].Property_Type=PropertyNo) then result:=S_FALSE else
if FPropertyTable[uriProp].Property_Type<>PropertyDWORD then Result:=E_INVALIDARG else
 begin
 pdwProperty:=FPropertyTable[uriProp].vdw;
 result:=S_OK;
 end;
end;

function TUri.GetPropertyLength(uriProp: Uri_PROPERTY;
  var pcchProperty: DWORD; dwFlags: DWORD): HRESULT;
begin
if (dword(uriProp)>18) or (FPropertyTable[uriProp].Property_Type=PropertyNo) then result:=S_FALSE else
if FPropertyTable[uriProp].Property_Type<>PropertyStr then Result:=E_INVALIDARG else
 begin
 pcchProperty:=length(FPropertyTable[uriProp].vws);
 result:=S_OK;
 end;
end;

function TUri.GetQuery(var pbstrQuery: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_QUERY,pbstrQuery,0);
end;

function TUri.GetRawUri(var pbstrRawUri: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_RAW_URI,pbstrRawUri,0);
end;

function TUri.GetScheme(var pdwScheme: DWORD): HRESULT;
begin
Result:=GetPropertyDWORD(Uri_PROPERTY_SCHEME,pdwScheme,0);
end;

function TUri.GetSchemeName(var pbstrSchemeName: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_SCHEME_NAME,pbstrSchemeName,0);
end;

function TUri.GetUserInfo(var pbstrUserInfo: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_USER_INFO,pbstrUserInfo,0);
end;

function TUri.GetUserName(var pbstrUserName: BSTR): HRESULT;
begin
Result:=GetPropertyBSTR(Uri_PROPERTY_USER_NAME,pbstrUserName,0);
end;

function TUri.GetZone(var pdwZone: DWORD): HRESULT;
begin
Result:=GetPropertyDWORD(Uri_PROPERTY_ZONE,pdwZone,0);
end;

function TUri.HasProperty(uriProp: Uri_PROPERTY;
  var pfHasProperty: BOOL): HRESULT;
begin
result:=S_OK;
pfHasProperty:=(dword(uriProp)<18) and (FPropertyTable[uriProp].Property_Type<>PropertyNo);
end;

function TUri.IsEqual(pUri: IUri; var pfEqual: BOOL): HRESULT;
begin
result:=0;
pfEqual:=false;
//  Для правильной работы  IsEqual необходимо разкомментировать последующий код,
//  но, если pUri, также, является интерфейсом от TUri, получим  stack overflow !!!
{
if pUri=nil then pfEqual:=false else
 try
  if 0<>pUri.IsEqual(self as iuri,pfEqual)then pfEqual:=false;
 except
  pfEqual:=false;
 end;
}
end;


end.


Unit_Interfaces.pas
Код

unit Unit_Interfaces;

interface
uses windows,urlmon;

const
  IID_Uri = '{a39ee748-6a27-4817-a6f2-13914bef5890}';
  IID_TargetFramePriv:TGUID = '{9216E421-2BF5-11D0-82B4-00A0C90C29C5}';
  IID_TargetFramePriv2:TGUID = '{b2c867e6-69d6-46f2-a611-ded9a4bd7fef}';

type
BSTR=WideString;

Uri_PROPERTY =(
  Uri_PROPERTY_ABSOLUTE_URI = 0,
  Uri_PROPERTY_STRING_START = Uri_PROPERTY_ABSOLUTE_URI,
  Uri_PROPERTY_AUTHORITY = 1,
  Uri_PROPERTY_DISPLAY_URI = 2,
  Uri_PROPERTY_DOMAIN = 3,
  Uri_PROPERTY_EXTENSION = 4,
  Uri_PROPERTY_FRAGMENT = 5,
  Uri_PROPERTY_HOST = 6,
  Uri_PROPERTY_PASSWORD = 7,
  Uri_PROPERTY_PATH = 8,
  Uri_PROPERTY_PATH_AND_QUERY = 9,
  Uri_PROPERTY_QUERY = 10,
  Uri_PROPERTY_RAW_URI = 11,
  Uri_PROPERTY_SCHEME_NAME = 12,
  Uri_PROPERTY_USER_INFO = 13,
  Uri_PROPERTY_USER_NAME = 14,
  Uri_PROPERTY_STRING_LAST = Uri_PROPERTY_USER_NAME,
  Uri_PROPERTY_HOST_TYPE = 15,
  Uri_PROPERTY_DWORD_START = Uri_PROPERTY_HOST_TYPE,
  Uri_PROPERTY_PORT = 16,
  Uri_PROPERTY_SCHEME = 17,
  Uri_PROPERTY_ZONE = 18,
  Uri_PROPERTY_DWORD_LAST = Uri_PROPERTY_ZONE
 );

Uri_HOST_TYPE =(
  Uri_HOST_UNKNOWN = 0,
  Uri_HOST_DNS = 1,
  Uri_HOST_IPV4 = 2,
  Uri_HOST_IPV6 = 3,
  Uri_HOST_IDN = 4
  );

TURL_SCHEME = (
    URL_SCHEME_INVALID = -1,
    URL_SCHEME_UNKNOWN = 0,
    URL_SCHEME_FTP,
    URL_SCHEME_HTTP,
    URL_SCHEME_GOPHER,
    URL_SCHEME_MAILTO,
    URL_SCHEME_NEWS,
    URL_SCHEME_NNTP,
    URL_SCHEME_TELNET,
    URL_SCHEME_WAIS,
    URL_SCHEME_FILE,
    URL_SCHEME_MK,
    URL_SCHEME_HTTPS,
    URL_SCHEME_SHELL,
    URL_SCHEME_SNEWS,
    URL_SCHEME_LOCAL,
    URL_SCHEME_JAVASCRIPT,
    URL_SCHEME_VBSCRIPT,
    URL_SCHEME_ABOUT,
    URL_SCHEME_RES,
    URL_SCHEME_MSSHELLROOTED,
    URL_SCHEME_MSSHELLIDLIST,
    URL_SCHEME_MSHELP,
    URL_SCHEME_MSSHELLDEVICE,
    URL_SCHEME_WILDCARD,
    URL_SCHEME_SEARCH_MS,
    URL_SCHEME_SEARCH,
    URL_SCHEME_KNOWNFOLDER,
    URL_SCHEME_MAXVALUE);

 IUri =  interface(IUnknown)
  ['{a39ee748-6a27-4817-a6f2-13914bef5890}']
   function GetPropertyBSTR(uriProp:Uri_PROPERTY;var pbstrProperty:BSTR;dwFlags:DWORD):HRESULT;stdcall;
   function GetPropertyLength(uriProp:Uri_PROPERTY;var pcchProperty:DWORD;dwFlags:DWORD):HRESULT;stdcall;
   function GetPropertyDWORD(uriProp:Uri_PROPERTY;var pdwProperty:DWORD;dwFlags:DWORD):HRESULT;stdcall;
   function HasProperty(uriProp:Uri_PROPERTY;var pfHasProperty:BOOL):HRESULT;stdcall;
   function GetAbsoluteUri(var pbstrAbsoluteUri:BSTR):HRESULT;stdcall;
   function GetAuthority(var pbstrAuthority:BSTR):HRESULT;stdcall;
   function GetDisplayUri(var pbstrDisplayString:BSTR):HRESULT;stdcall;
   function GetDomain(var pbstrDomain:BSTR):HRESULT;stdcall;
   function GetExtension(var pbstrExtension:BSTR):HRESULT;stdcall;
   function GetFragment(var pbstrFragment:BSTR):HRESULT;stdcall;
   function GetHost(var pbstrHost:BSTR):HRESULT;stdcall;
   function GetPassword(var pbstrPassword:BSTR):HRESULT;stdcall;
   function GetPath(var pbstrPath:BSTR):HRESULT;stdcall;
   function GetPathAndQuery(var pbstrPathAndQuery:BSTR):HRESULT;stdcall;
   function GetQuery(var pbstrQuery:BSTR):HRESULT;stdcall;
   function GetRawUri(var pbstrRawUri:BSTR):HRESULT;stdcall;
   function GetSchemeName(var pbstrSchemeName:BSTR):HRESULT;stdcall;
   function GetUserInfo(var pbstrUserInfo:BSTR):HRESULT;stdcall;
   function GetUserName(var pbstrUserName:BSTR):HRESULT;stdcall;
   function GetHostType(var pdwHostType:DWORD):HRESULT;stdcall;
   function GetPort(var pdwPort:DWORD):HRESULT;stdcall;
   function GetScheme(var pdwScheme:DWORD):HRESULT;stdcall;
   function GetZone(var pdwZone:DWORD):HRESULT;stdcall;
   function GetProperties(pdwFlags:LPDWORD):HRESULT;stdcall;
   function IsEqual(pUri:IUri;var pfEqual:BOOL):HRESULT;stdcall;
 end;

 ITargetFramePriv = interface(IUnknown)
  ['{9216e421-2bf5-11d0-82b4-00a0c90c29c5}']
   function  FindFrameDownwards(pszTargetName:LPCWSTR;dwFlags:DWORD;out ppunkTargetFrame:IUnknown ):HRESULT;stdcall;
   function  FindFrameInContext(pszTargetName:LPCWSTR;punkContextFrame: IUnknown;dwFlags:DWORD;out ppunkTargetFrame:IUnknown):HRESULT;stdcall;
   function  OnChildFrameActivate(pUnkChildFrame:IUnknown):HRESULT;stdcall;
   function  OnChildFrameDeactivate(pUnkChildFrame:IUnknown):HRESULT;stdcall;
   function  NavigateHack(grfHLNF:DWORD;pbc:cardinal{LPBC;};pibsc: IBindStatusCallback;pszTargetName:LPCWSTR;pszUrl:LPCWSTR;pszLocation:LPCWSTR):HRESULT;stdcall;
   function  FindBrowserByIndex(dwID:DWORD;out ppunkBrowser: IUnknown):HRESULT;stdcall;
 end;

 ITargetFramePriv2 = interface(ITargetFramePriv)
  ['{b2c867e6-69d6-46f2-a611-ded9a4bd7fef}']
   function  AggregatedNavigation2(grfHLNF:DWORD;pbc:cardinal{LPBC;};pibsc:IBindStatusCallback;pszTargetName:LPCWSTR;pUri:IUri;pszLocation:LPCWSTR):HRESULT;stdcall;
 end;

implementation

end. 




--------------------
умную мысль держи при себе, а дурной - поделись с другими 
PM MAIL   Вверх
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Общие вопросы"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

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

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи


Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.

 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Общие вопросы | Следующая тема »


 




[ Время генерации скрипта: 0.0713 ]   [ Использовано запросов: 22 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.