VPF::как связать EmbeddedWB1NewWindow2 с Paramstr(2)

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

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;

запускается копия программы, но урл неподстовляется

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?

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

s2004

Дата 7.10.2012, 22:51 (ссылка)

(голосов:1)

Загрузка ...

Бывалый

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

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

вот только теперь любой клик открывается в новом окне ... а как сделать чтобы выбор был открыть в новом или в старом

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;

всё работает и в новом окне и в текущем...

Чучмек

Дата 9.10.2012, 01:57 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

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

--------------------

умную мысль держи при себе, а дурной - поделись с другими

Чучмек

Дата 9.10.2012, 17:32 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

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

--------------------

умную мысль держи при себе, а дурной - поделись с другими

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.Модераторы прошу заблокировать тему без возможности суда ещё что- то писать.

Чучмек

Дата 9.10.2012, 19:59 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

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

Присоединённый файл ( Кол-во скачиваний: 6 )

ppppp.7z 175,69 Kb

--------------------

умную мысль держи при себе, а дурной - поделись с другими

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...

Чучмек

Дата 9.10.2012, 20:14 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Цитата(s2004 @ 9.10.2012, 19:48

)

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

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

--------------------

умную мысль держи при себе, а дурной - поделись с другими

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.

Чучмек

Дата 9.10.2012, 20:22 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Цитата(s2004 @ 9.10.2012, 20:15

)

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

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

--------------------

умную мысль держи при себе, а дурной - поделись с другими

Чучмек

Дата 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.

--------------------

умную мысль держи при себе, а дурной - поделись с другими

Чучмек

Дата 12.10.2012, 12:11 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Этот код не имеет практического значения. Поскольку требует второго (скрытого) WB.
С дополнительным WB все делается гораздо проще - через OnBeforeNavigate2.
Однако, код показывает, как происходит открытие новой страницы.
Через передаваемый в ppDisp, события OnNewWindow2, интерфес wb.DefaultDispatch, запрашивается ряд интерфейсов.
В том числе ITargetFramePriv/ITargetFramePriv2.
Для перехвата запроса интерфейсов  используем  TMyIC (метод  QueryInterface).
При запросе ITargetFramePriv/ITargetFramePriv2 передаем интерфейс от TTargetFramePriv/TTargetFramePriv2.
При запросе остальных интерфейсов, передаем оригинальные интерфейсы от WB2.
Через ITargetFramePriv/ITargetFramePriv2 происходит передача url в новую страницу.
ITargetFramePriv - в старых версиях IE (метод NavigateHack), ITargetFramePriv2 (метод AggregatedNavigation2) - в новых.
TTargetFramePriv/TTargetFramePriv2 - служат для перехвата передачи url.
В ITargetFramePriv.NavigateHack url передается в виде WideString.  (передаем в CallbackProc, и меняем на about:blank)
В ITargetFramePriv2.AggregatedNavigation2 url передается в виде интерфейса IUri (в CallbackProc передаем строку полученную через pUri.GetAbsoluteUri, а вместо pUri передаем интерфейс от TUri)

При желании можно написать заглушки для необходимых интерфейсов. Тогда второй WB не понадобиться.

Это сообщение отредактировал(а) Чучмек - 12.10.2012, 12:21

--------------------

умную мысль держи при себе, а дурной - поделись с другими

Чучмек

Дата 12.10.2012, 23:22 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Цитата(Чучмек @ 9.10.2012, 20:22

)

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

Чтобы не быть голословным...

Присоединённый файл ( Кол-во скачиваний: 2 )

ppppp2.7z 175,09 Kb

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 13.10.2012, 17:56 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

попробовал последний архив, но значки просто так же, как у меня в программе отражаются- без содержимого? а я вроде докуче спрашивал чтобы именно с отражением сылки, так выбрать нужное окно легче. скомпиллировалось без проблем ошибки нет?

Добавлено @ 18:00
коды привидённые в теме желательно поместить в FAQ или DRKB? а то там очень бедно по поводу брузера.

Чучмек? архивы одинаковые....

Это сообщение отредактировал(а) s2004 - 13.10.2012, 18:10

Чучмек

Дата 16.10.2012, 07:55 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Цитата(s2004 @ 13.10.2012, 17:56

)

Чучмек? архивы одинаковые....

Да нет, отличаются настолько, насколько

Цитата

легко решается

Цитата(s2004 @ 13.10.2012, 17:56

)

Это ты в другой теме спрашивал.
...Ну хорошо.
Элементарно Уатсон. smile

Я дурак, обещаю исправится smile

Это сообщение отредактировал(а) Чучмек - 17.10.2012, 09:36

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 16.10.2012, 20:27 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

запустил последний архив. значки, как отражались Form2 так и отражаются как и у меня. выбрать нужный значок нельзя - не открыв его и содержимое заглавия страницы не отражено.

Это сообщение отредактировал(а) s2004 - 16.10.2012, 20:57

Чучмек

Дата 16.10.2012, 20:56 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Разве ни это надо?

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 16.10.2012, 20:59 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

да надо так, но у меня всё скомпилировалось, а этого нет -только form2 и всё.
хорошо бы, если вместе form 2 отражалась и сылка страницы.

Это сообщение отредактировал(а) s2004 - 16.10.2012, 21:04

Чучмек

Дата 16.10.2012, 21:02 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Aero в винде включено?

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 16.10.2012, 21:07 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

у меня виста basic, надо и чтобы в ХР работало.

Это сообщение отредактировал(а) s2004 - 16.10.2012, 21:12

Чучмек

Дата 16.10.2012, 21:29 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Цитата(s2004 @ 16.10.2012, 21:07

)

у меня виста basic, надо и чтобы в ХР работало.

Да не, это семерошный наворот.
Он и так, сам по себе работает. Завтычил.Исправлюсь.Посмотрю,что можно сделать.

Добавлено @ 21:36
Добавь обработчик OnTitleChange
Вот тебе еще вариант.

Это сообщение отредактировал(а) Чучмек - 17.10.2012, 12:07

Присоединённый файл ( Кол-во скачиваний: 4 )

ppppp4.7z 176,77 Kb

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 17.10.2012, 20:02 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

вот то, что практически нужно (правда без миниатюр) Чучмек благодарю smile

.
выложу код думаю всем будет интересно

Код


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(nil)do
  begin
  caption:=FormCaption;
  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);
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WebBrowser1TitleChange(Sender: TObject;
      const Text: WideString);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

const FormCaption='Moй браузер';

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;

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited;
Params.WndParent:=GetDesktopWindow;
end;

procedure TForm2.WebBrowser1TitleChange(Sender: TObject;
  const Text:WideString );
begin
Caption:=FormCaption+':'+Text;

end;

end.

s2004

Дата 17.10.2012, 20:55 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

у меня код

Код


program net;

uses
  Forms,windows,
  Unit1 in 'Unit1.pas' {Form1},
  adCpuUsage in 'adCpuUsage.pas',
  Unit3 in 'Unit3.pas' {Form3},
  MSHTML_TLB in 'c:\program files\borland\bds\4.0\Imports\MSHTML_TLB.pas',
  Unit16 in 'Unit16.pas' {Form16},
  Unit9 in 'Unit9.pas' {Form9},
  Unit23 in 'Unit23.pas' {Form23},
  Unit20 in 'Unit20.pas' {Form20},
  Unit10 in 'Unit10.pas' {Form10};

{$R *.res}

begin
//  Application.ShowMainForm:=false;
  Application.Initialize;
//  Application.Title := '';
//  Application.ShowMainForm:=false;
  Application.HelpFile := 'D:\2005\help.hlp';
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TForm3, Form3);
  Application.CreateForm(TForm3, Form3);
  Application.CreateForm(TForm23, Form23);
  Application.CreateForm(TForm20, Form20);
  Application.CreateForm(TForm9, Form9);
  Application.CreateForm(TForm16, Form16);
  Application.CreateForm(TForm10, Form10);
  ShowWindow(Application.Handle, SW_HIDE);
  Application.Run;
end.

если

ввожу

Код



Application.ShowMainForm:=false;
ругается на разные типы boolen и integer

поэтому в твоём архиве компиляция без проблем и всё работает, но у меня пока не работает.

Чучмек

Дата 18.10.2012, 20:12 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Значит у тебя, в каком то модуле, до implementation есть что-нибудь типа

Код


var false:integer;

или

Код


 const false=0;

Если не хочешь исправлять (а НАДО) - напиши

Код


Application.ShowMainForm:=1=0;

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 18.10.2012, 20:23 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

да это я нашёл убирал, подстовлял твой код в свою прогу, так она hidden получается в диспечере висит, а так не видно.

событие formcreate NewForm; сделала скрытым браузер при заремачивание начинает работать, но неполностью правильно. запускается прога- клик на сылку открывается новое окно при этом отображается название каждое своё в каждом окне, но вместо например двух значков проги на панели задач видны 3 значка.

Это сообщение отредактировал(а) s2004 - 18.10.2012, 20:58

Чучмек

Дата 18.10.2012, 20:54 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

А ты не понял зачем это?
Как в примере?
Основное окно приложения делаем не видимым

Код


 ShowWindow(Application.Handle, SW_HIDE);

Из панели задач исчезает кнопка "Project1"
Главную форму приложения делаем невидимой / скрытой

Код


Application.ShowMainForm:=false;

Главная форма у нас ничего не содержит.
В событии главной формы OnCreate, создаем (Через TFormN.Create) видимую форму - окно браузера.
При закрытии окна браузера, завершение приложения НЕ ПРОИСХОДИТ.
Этим решаем проблему, с которой ты начинал эту тему.

Это сообщение отредактировал(а) Чучмек - 18.10.2012, 20:55

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 19.10.2012, 20:39 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Чучмек, если заремачено

Код


Application.ShowMainForm:=false;
 ShowWindow(Application.Handle, SW_HIDE);
 NewForm;

то браузер работает, но не совсем правильно

виден третий значок на панели задач (окон браузера только два),
если строки кода прописаны ТО БРАУЗЕРА НЕТ, НИ ГЛАВНОГО ОКНА, НИ ФОРМЫ просто есть отражение в диспечере задач ну как "троян". весь остальной код, как у тебя.

Это сообщение отредактировал(а) s2004 - 19.10.2012, 20:51

Чучмек

Дата 20.10.2012, 07:46 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Скинь. Я посмотрю.

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 20.10.2012, 20:30 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

вышлю через личку

Чучмек

Дата 20.10.2012, 22:00 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Ты так ничего не понял. Читай мой пост через один вверх.
Давай заново.
Из юнита, из того, который ты мне скинул, -(Unit1)
Удаляй

Код


var

  form_count:cardinal=0;

Код


function NewForm:Idispatch;
procedure DecFormCount;

Код


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

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

из TForm1.FormCreate удаляй NewForm;

Потом File->New->Form
Form.Name=FormXXX

Юнит новой формы сохрани как StartForm_Unit
в нем

Код


unit StartForm_Unit;

interface

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

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

var
  FormXXX: TFormXXX;
  form_count:cardinal=0;



function NewForm:Idispatch;
procedure DecFormCount;
implementation

{$R *.dfm}

function NewForm:Idispatch;
begin
 with TForm1.Create(nil)do
  begin
  caption:=FormCaption;
  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 TFormXXX.FormCreate(Sender: TObject);
begin
NewForm;
end;

end.

В dpr - первая создаваемая форма FormXXX

Код


program Project1;

uses
  Forms,
  windows,
  StartForm_Unit in 'StartForm_Unit.pas' {FormXXX},
  Unit1 in 'Unit1.pas' {Form1},
  ...
  ...



{$R *.res}

begin
  Application.ShowMainForm:=false;
  Application.Initialize;
  Application.CreateForm(TFormXXX, FormXXX); //!!! эта строка первая из Application.CreateForm
//Application.CreateForm(TForm1, Form1); // !!! эту строку удаляешь или комментируешь ОБЯЗАТЕЛЬНО!!!  
  ShowWindow(Application.Handle, SW_HIDE);
  Application.Run;
end.

В uses Unit1 прописываешь StartForm_Unit

Это сообщение отредактировал(а) Чучмек - 20.10.2012, 22:03

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 20.10.2012, 22:25 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

попробую завтра спасибо.

s2004

Дата 21.10.2012, 16:17 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

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

Код



Application.ShowMainForm:=1=0; прописано
Application.ShowMainForm:=false; не получается вроде до implementation проверял наверно сбой ещё по другой причине

Чучмек

Дата 21.10.2012, 17:29 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

У тебя встречается код

Код


Form1.EmbeddedWb1.DownloadOptions:=Form1.EmbeddedWb1.DownloadOptions
- [DLCTL_DLIMAGES, DLCTL_BGSOUNDS, DLCTL_VIDEOS,DLCTL_NO_SCRIPTS]
+ [DLCTL_PRAGMA_NO_CACHE, DLCTL_NO_JAVA];
EmbeddedWB1.Refresh;

За комментируй в unit1 строку

Код


var Form1:TForm;

И исправь все

Код


procedure TForm1.bu...
begin
 form1.Em...

На

Код


procedure TForm1.bu...
begin
 self.Em...

Добавлено через 2 минуты и 15 секунд
После того как ты убрал строку Application.CreateForm(TForm1, Form1)
Form1 у тебя больше не существует

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 21.10.2012, 21:45 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

покрутил в выходные несколько часов. чтение без запроса с диска не идёт. после того, как например ещё убираю form1 на self среда дельфи начинает упорно подставить unit1 в unit1, что ошибка отказываясь от этого там другое лезет.
я вот помню вроде на каком то этапе у меня давно работало отражение открытых cskjr в значках на панели задач. Возможно какое другое решение тут действительно начинаешь одно менять появляется куча другого.

Чучмек

Дата 21.10.2012, 22:09 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Вот когда начинаешь понимать, что глобальные переменные это зло.
Вот что у тебя есть

Цитата

var
MyClpFormat: integer;

iconindex : integer;

PIInfo : PInternetProxyInfo;
Links : TStringlist;
ActiveDesigner: TEditDesigner;
EditServices: IHTMLEditServices;
FDocHostUIHandler: TDocHostUIHandler;
CtxMenuAdded: Boolean;
i:string;

Использовалось раньше одной формой - а теперь несколькими.
Перенеси внутрь TForm1

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 21.10.2012, 22:20 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

попробую наверно уже завтра

s2004

Дата 21.10.2012, 22:38 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

так вроде всё подправил, пока ошибок не пишет ....

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

нет возможности регулировать показывать картинку или нет

менял на self

Код



procedure TForm1.BitBtn2Click(Sender: TObject);
begin
if RadioButton1.checked then RadioButton2.checked := false
else RadioButton1.checked := true;
if True then
self.EmbeddedWb1.DownloadOptions:=self.EmbeddedWb1.DownloadOptions
+ [DLCTL_DLIMAGES,DLCTL_NO_JAVA]
- [DLCTL_PRAGMA_NO_CACHE,DLCTL_BGSOUNDS, DLCTL_VIDEOS, DLCTL_NO_SCRIPTS];
EmbeddedWB1.Refresh;
end;

procedure TForm1.RadioButton1Click(Sender: TObject);
begin
if RadioButton1.checked then RadioButton2.checked := false
else RadioButton1.checked := true;
if True then
self.EmbeddedWb1.DownloadOptions:=self.EmbeddedWb1.DownloadOptions
+ [DLCTL_DLIMAGES, DLCTL_BGSOUNDS, DLCTL_VIDEOS]
- [DLCTL_PRAGMA_NO_CACHE, DLCTL_NO_JAVA, DLCTL_NO_SCRIPTS];
end;

procedure TForm1.RadioButton2Click(Sender: TObject);
begin
if RadioButton2.checked then RadioButton1.checked := false
else RadioButton2.Checked  := true;
if True then
self.EmbeddedWb1.DownloadOptions:=self.EmbeddedWb1.DownloadOptions
- [DLCTL_DLIMAGES, DLCTL_BGSOUNDS, DLCTL_VIDEOS,DLCTL_NO_SCRIPTS]
+ [DLCTL_PRAGMA_NO_CACHE, DLCTL_NO_JAVA];

end;

Это сообщение отредактировал(а) s2004 - 21.10.2012, 22:57

Чучмек

Дата 22.10.2012, 09:20 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

У тебя еще куча юнитов, проверяй где еще есть обращение к form1

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 22.10.2012, 19:36 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

ещё 4 form1 нашёл теперь нет. но теперь программа при запуске ведёт так, как в начале темы - при открытие сылки из родительского окна и если это окно закрыть происходит и закрытие родительского и дочернего окна. вышлю unit1.pas. вопрос прописаны ini- файлы для сохранения параметров проги например включена возможность показа картинок? при закрытие проги и вновь открытии вновь приходится нажимать на соответсвующую кнопку чтобы отображались картинки прога несохраняет поему изменения. ну и нет докучи чтения с диска.

так нашёл почему прога стала закрываться при закрытие родительского окна
в form1 в onclose поставил

Код


Application.Terminate;

убрал выше названная ошибка прошла

вопрос как заставить программу удалять себя из памяти?

кстати по глобальным переменым в учебниках например расписывают, что это хорошо не надо прописовать к каждой процедуре, а тут действительно прав Чучмек - за них сбои. лучше прописать к каждой процедуре.

Это сообщение отредактировал(а) s2004 - 22.10.2012, 20:18

Чучмек

Дата 22.10.2012, 21:31 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

В TForm1.FormClose
Должно стоять (последней строкой) DecFormCount.
Посмотри внимательно: при вызове NewForm увеличивается на единицу form_count.
При вызове DecFormCount уменьшается. Если DecFormCount=0 ->application.Terminate

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 22.10.2012, 21:39 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

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

s2004

Дата 26.10.2012, 22:57 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

перебрал параметры ини файлов, но код не работает.
запись в ини файл идёт, а вот такое впечатление, что не читается.

Код



procedure TForm30.FormCreate(Sender: TObject);
var
  Ini:TIniFile;
begin
  with TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'net.ini') do
  begin
    {Здесь мы считываем высоту (Top) и отступ от
     левого края экрана (Left) нашей формы}
    form30.Top := ReadInteger('FormPosition', 'Top', form30.Top);
    form30.Left := ReadInteger('FormPosition', 'Left', form30.Left);
    {Соответственно загружаем
     длину (Height) и ширину (Width)}
    form30.Height := ReadInteger('FormSize', 'Height', form30.Height);
    form30.Width := ReadInteger('FormSize', 'Width', form30.Width);
    {Уничтожаем экземпляр}
//    Free;
//  end;
//var
// Ini:TIniFile;
//begin
NewForm;
// Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'net.ini');
//  self.Width:=Ini.ReadInteger('Size','Width',100);
  //последнее значение (100) это значение по умолчанию (default)
//  self.Height:=Ini.ReadInteger('Size','Height',100);
//  self.Left:=Ini.ReadInteger('Position','X',10);
//  self.Top:=Ini.ReadInteger('Position','Y',10);
/////////Ini := TIniFile.Create('netwin.ini');
//Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'net.ini');
//  self.Width:=Ini.ReadInteger('Size','Width',1024);
//  self.Height:=Ini.ReadInteger('Size','Height',768);
//  self.Left:=Ini.ReadInteger('Position','X',0);
//  self.Top:=Ini.ReadInteger('Position','Y',0);
//  RadioButton1.Checked:=Ini.ReadBool('self','RadioButton1Checked',RadioButton1.Checked); // состояние CheckBox1
//  RadioButton2.Checked:=Ini.ReadBool('self','RadioButton2Checked',RadioButton2.Checked);
  s := Ini.ReadString('files', 'path', ''); // <--- Здесь задай дефолтное значение
//  tform1.Image1.Picture.LoadFromFile(s);
  Ini.Free;
  end;
end;
procedure TForm30.FormDestroy(Sender: TObject);
//begin
var
Ini: Tinifile;
//////////begin
/////Ini := TIniFile.Create('netwin.ini');
//  Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'net.ini');
 //////// Ini.WriteInteger('Size','Width',self.width);
/////  Ini.WriteInteger('Size','Height',self.height);
 //// Ini.WriteInteger('Position','X',self.left);
 /////// Ini.WriteInteger('Position','Y',self.top);
//  Ini.WriteBool('FORM1','CheckBox1Checked',n1.Checked);

//  Ini.WriteBool('FORM1','video1Checked',n2.Checked);
 // checkbox1.checked := ini.readbool('first section','edit key',false);
//////////  Ini.WriteString('files','path', s); // <--- Сохраняешь измененный путь
 /////////// Ini.Free;
//  Links.Free;
 // HistoryMenu.Free;
//  end;
///end;
//var
//  Ini: Tinifile; //необходимо создать объект, чтоб потом с ним работать
//begin
begin
  with TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'net.ini') do
  begin
    {Здесь мы сохраняем высоту (Top) и отступ от
     левого края экрана (Left) нашей формы}
    WriteInteger('FormPosition', 'Top', form30.Top);
    WriteInteger('FormPosition', 'Left', form30.Left);
    {Следующие два метода хранят размеры формы,
     соответственно длину (Height) и ширину (Width)}
    WriteInteger('FormSize', 'Height', form30.Height);
    WriteInteger('FormSize', 'Width', form30.Width);
    {Ну и, конечно же, уничтожаем наш экземпляр}
//    Free;





  //создали файл в директории программы
//  Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'net.ini');
//  Ini.WriteInteger('Size','Width',self.width);
//  Ini.WriteInteger('Size','Height',self.height);
//  Ini.WriteInteger('Position','X',self.left);
//  Ini.WriteInteger('Position','Y',self.top);
  Ini.WriteString('files','path', s);
  Ini.Free;
end;
end;

Чучмек

Дата 26.10.2012, 23:05 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

breakpoint в TForm30.FormCreate поставь. И через F7/F8 посмотри читается или нет.

Добавлено через 1 минуту и 56 секунд
Form30 - это что за зверь?

--------------------

умную мысль держи при себе, а дурной - поделись с другими

Чучмек

Дата 27.10.2012, 14:28 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Код


unit StartForm_Unit;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,unit1;
type
  TFormXXX = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  FormXXX: TFormXXX;
  form_count:cardinal=0;
//Здесь переменные для хранения настроек!!!
function NewForm:Idispatch;
procedure DecFormCount;
implementation
{$R *.dfm}
function NewForm:Idispatch;
begin
 with TForm1.Create(nil)do
  begin
  caption:=FormCaption;
  visible:=true;
  result:=WebBrowser1.DefaultDispatch;
  inc(form_count);
  //Здесь применяешь настройки к каждой вновь создаваемой форме 
  end;
end;
procedure DecFormCount;
begin
dec(form_count);
if form_count=0 then 
 begin
 //Здесь сохраняешь настройки при завершении приложения
 application.Terminate;
 end;
end;
procedure TFormXXX.FormCreate(Sender: TObject);
begin
//Здесь загружаешь настройки в переменные при запуске приложения 
NewForm;
end;
end.

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 27.10.2012, 23:05 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Код


function NewForm:Idispatch;
var
  Ini:TIniFile;
begin
 with TForm1.Create(nil)do
  begin
  caption:=app_Caption;
  visible:=true;
  result:=embeddedwb1.DefaultDispatch;
  inc(form_count);
  Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'net.ini');
  form30.Width:=Ini.ReadInteger('Size','Width',1024);
  form30.Height:=Ini.ReadInteger('Size','Height',768);
  form30.Left:=Ini.ReadInteger('Position','X',0);
  form30.Top:=Ini.ReadInteger('Position','Y',0);

  end;
end;

procedure DecFormCount;
var
Ini: Tinifile;
s: string;

begin
dec(form_count);
if form_count=0 then application.Terminate;
 Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'net.ini');
  Ini.WriteInteger('Size','Width',form30.width);
  Ini.WriteInteger('Size','Height',form30.height);
  Ini.WriteInteger('Position','X',form30.left);
  Ini.WriteInteger('Position','Y',form30.top);
//  Ini.WriteString('files','path', s);
  Ini.Free;
end;

а переменную s ставил в

Код


s := Ini.ReadString('files', 'path', '');
NewForm;

но при запуске ошибку пишет и браузер не работает заремачил вначале надо добиться чтобы положение и размер сохранял и восстанавливал. по выше привидённому коду пишет инифайл

Код


[Size]
Width=1024
Height=768
[Position]
X=0
Y=0

и всё, его не меняет. размеры и положение не изменяет.

Чучмек

Дата 27.10.2012, 23:17 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Что такое Form30???

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 28.10.2012, 16:50 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

form30 это StartForm_Unit

Чучмек

Дата 28.10.2012, 17:25 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

А зачем ты настройки невидимого окна сохраняешь???

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 28.10.2012, 19:17 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

так вот вначале сохранял form1, потом пробовал form30

Чучмек

Дата 28.10.2012, 19:36 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Рановато ты за это взялся, по видимому :(

Присоединённый файл ( Кол-во скачиваний: 3 )

ppppp5.7z 182,76 Kb

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 28.10.2012, 19:59 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Цитата(Чучмек @ 28.10.2012, 19:36)

Рановато ты за это взялся, по видимому :(

нормально, это у меня хобби на 1-2 месяца в год для себя. и разумеется, если незаниматься языком то забываешь и по новой приходится вспоминать, но хочется себе любимому smile

.

архив распаковал, посмотрел не работает. у меня ini работали пока я не начал менять по теме, вероятно где то какая- та ошибка. файл config.ini несоздаётся.

Чучмек

Дата 28.10.2012, 20:14 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Цитата(s2004 @ 28.10.2012, 19:59

)

архив распаковал, посмотрел не работает

В меню есть пункт "Запомнить позицию"

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 28.10.2012, 20:26 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

да моя не внимательность :( - работает.

s2004

Дата 30.10.2012, 20:14 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Чучмек (благодарю за расширенные ответы с примерами) вопрос по чтению файла с диска без подтверждения - до модернизации код был в form1

Код



function get(FName:string): boolean;
var
form1: tform1;
//
begin
 form1.EmbeddedWB1.Navigate(FName);
end;
oncreate...
if ParamCount <> 0 then get(ParamStr(1));

теперь, как бы надо использовать form30. подстовлял различные параметры, но не работает

Код


form30
function get(fname:string): boolean;
var
self: tform1;
begin
 self.EmbeddedWB1.Navigate(FName);  
end;
end;

form30
oncreate
if ParamCount <> 0 then get(ParamStr(1));

программа запускается, но при попытки открыть файл с диска пишет ошибку и загрузка файла непроисходит

Чучмек

Дата 31.10.2012, 12:49 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Посмотри соседнюю тему про несколько окон одного класса.
Если в функции/процедуре было обрашение к форме/компонентам на форме
Возможны варианты
а) сделать функцию методом класса TFormN (доступ к форме через self)
б) добавить параметр Form:TForm и передавать self
Добавь в функцию NewForm параметр SelfForm:TForm (как в моем последнем примере)
И делай проверку SelfForm=nil (при первом вызове в NewForm передавай nil, при открытии нового окна передавай текущее(self))

Код


function NewForm(SelfForm:TForm)...
begin
...
with TForm1.Create(Application)do
 begin
 ...
 ...
 if not Assigned(SelfForm) and (ParamCount > 0) then get(ParamStr(1));
 ...
 end;
...
end;

Функцию get сделай методом TForm1

Код


function TForm1.get(fname:string): boolean;
begin
EmbeddedWB1.Navigate(FName);  
end;

Это сообщение отредактировал(а) Чучмек - 31.10.2012, 12:53

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 6.11.2012, 19:41 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Чучмек при попытки в form30 исправить функции newform и tform.get вылетают ошибки, при исправление в form1 ошибки нет. но и не работает. ты уже объяснял нельзя ли подробней всё таки по поводу form30?

Это сообщение отредактировал(а) s2004 - 6.11.2012, 19:41

Чучмек

Дата 6.11.2012, 21:26 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Исправляешь описание TForm1
Было

Код


  TForm1 = class(TForm)
  ...
  private
    { Private declarations }
  public
    { Public declarations }
  ...
  end;

Стало

Код


  TForm1 = class(TForm)
  ...
  private
    { Private declarations }
  public
    { Public declarations }
   function  get(fname:string): boolean;
   ...
  end;

Потом ставишь курсор внутрь блока TForm1 =... end; и нажимаешь Ctrl+Shift+C получаешь заготовку метода Get

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 6.11.2012, 21:52 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

у меня было

Код


function get(FName:string): boolean;
var
self: tform1;
begin
 self.EmbeddedWB1.Navigate(FName);  
end;

... нажимаешь Ctrl+Shift+C получаешь заготовку метода Get - это не срабатывает.

Чучмек

Дата 7.11.2012, 09:55 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Ну добавь ручками TForm1.

Код


function TForm1.get(FName:string): boolean;
//var
//self: tform1;
begin
 self.EmbeddedWB1.Navigate(FName);  
end;

Предварительно добавь в секцию public TForm1 строку

Код


function get(FName:string): boolean;

зы get должен быть в том же юните что и tform1

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 7.11.2012, 20:00 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Код


procedure TForm1.EmbeddedWB1NewWindow2(ASender: TObject; var ppDisp: IDispatch;
 var Cancel: WordBool);
  begin
  ppDisp:=NewForm;  - исправил теперь, ругается- нет других параметров.

Код


procedure TForm30.FormCreate(Sender: TObject);
begin
NewForm;  тут тоже ругается если заремачить вверху и внизу то запускается, но без отображения формы. 
end;
end.

этот код для form1?

Код



function NewForm(SelfForm:TForm)...
begin
...
with TForm1.Create(Application)do
 begin
 ...
 ...
 if not Assigned(SelfForm) and (ParamCount > 0) then get(ParamStr(1));
 ...
 end;
...
end;

Это сообщение отредактировал(а) s2004 - 7.11.2012, 20:22

Чучмек

Дата 7.11.2012, 22:17 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Ну посмотри последний пример. Там в NewForm уже добавлен параметр.
В EmbeddedWB1NewWindow2

Код


ppDisp:=NewForm(self);

В TForm30.FormCreate

Код


NewForm(nil);

Цитата(s2004 @ 7.11.2012, 20:00

)

if not Assigned(SelfForm) and (ParamCount > 0) then get(ParamStr(1));

Если SelfForm=nil (если не Assigned(SelfForm)) вызвать метод get

параметр SelfForm (в NewForm ) - это форма, в WB которой, открывается новое окно. При старте программы еще никакого окна НЕТ, поэтому передаем nil
Значит если SelfForm=nil программа только запустилась.

Это сообщение отредактировал(а) Чучмек - 7.11.2012, 22:18

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 8.11.2012, 19:39 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Код


ppDisp:=NewForm(self); пишет разные типы dispath и boolean

когда подставил nil

Код


NewForm(nil); too many actual parametrs

Чучмек

Дата 8.11.2012, 20:55 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Вот посмотри.
... и еще. Чтобы при закрытии форма уничтожалась а не скрывалась,необходимо в OnClose перед вызовом DecFormCount вызвать Free

Код


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
...
Free;//!!!Предпоследняя!!! строка
DecFormCount;//!!!Последняя!!! строка
end;

Присоединённый файл ( Кол-во скачиваний: 2 )

ppppp6.7z 183,36 Kb

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 8.11.2012, 21:58 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Код


CaFree; 
self := nil;
DecFormCount;

у меня вот так было

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

Это сообщение отредактировал(а) s2004 - 8.11.2012, 22:35

Чучмек

Дата 8.11.2012, 22:20 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Можно и так.
тогда DecFormCount лучше вызывать в OnDestroy

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 9.11.2012, 18:51 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

ошибка при закрытии

не стал кнопкой фиксировать нужную позицию, через

Код


procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin
MIntSettings[sTop].Curr:=Top;
MIntSettings[sLeft].Curr:=Left;
MIntSettings[sWidth].Curr:=Width;
MIntSettings[sHeight].Curr:=Height;


end;

Это сообщение отредактировал(а) s2004 - 9.11.2012, 19:27

Чучмек

Дата 9.11.2012, 20:10 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Форма должна уничтожатся до вызова Application.Terminate

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 10.11.2012, 18:07 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

Код


procedure DecFormCount;
var ind:TIntSettings;
begin
dec(form_count);
if form_count=0 then
 begin
 for ind:=low(MIntSettings) to  high(MIntSettings) do
  if MIntSettings[ind].Curr<>MIntSettings[ind].Load then IniF.WriteInteger('BrowserWindow',IntSettingsName[ind],MIntSettings[ind].Curr);
 IniF.Free;
 application.Terminate;
 end;
end;

если в form1 ставлю

Код


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin

free;
DecFormCount;
Application.Terminate;
end;

то ошибка сохраняется плюс закрывается все окна при закрытие любого окна браузера,
а так Application.Terminate вызывается только в form30. как у тебя в примере.
а так уменя в form1 стоит

Код


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin

free;
DecFormCount;

end;

Добавлено через 11 минут и 32 секунды
а вот получилось при таком коде

Код


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin

CaFree; 
self := nil;

DecFormCount;

end;

Это сообщение отредактировал(а) s2004 - 10.11.2012, 18:09

Чучмек

Дата 10.11.2012, 18:21 (ссылка)

(нет голосов)

Загрузка ...

НЭТ БИЛЭТ

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

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

Ошибка всегда, или только когда открываешь файл с диска?

Добавлено через 13 минут и 24 секунды
Перенеси вызов DecFormCount в OnDestroy. Так правильнее более правильно будет.

--------------------

умную мысль держи при себе, а дурной - поделись с другими

s2004

Дата 10.11.2012, 20:12 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

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

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

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

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