Tips (1541)

Tip Bewertung (46):

{ Code 1 **************************************}

uses
  ddeman;

function GetURL(Service: string): string;
var
  ClDDE: TDDEClientConv;
  temp: PChar;
begin
  Result := '';
  //create a new DDE Client object
  ClDDE := TDDEClientConv.Create(nil);
  with ClDDE do
  begin
    SetLink(Service, 'WWW_GetWindowInfo');
    temp := RequestData('0xFFFFFFFF');
    Result := StrPas(temp);
    StrDispose(temp);
    CloseLink;
  end;
  ClDDE.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // the result should be something like:
  // "http://www.swissdelphicenter.ch","SwissDelphiCenter.ch"
  ShowMessage(GetURL('IExplore'));
  { ShowMessage(GetURL('Netscape')); }
end;

{ Code 2 **************************************}

uses
  ddeman;
  
procedure GetCurrentURL(out URL, Title: string);
var
   DDEClient : TDDEClientConv;
   p, q: PChar;
   i: Integer;
begin
   DDEClient := TDDEClientConv.Create(nil);
   try
     with DDEClient do if SetLink('IExplore', 'WWW_GetWindowInfo') or
       SetLink('Netscape', 'WWW_GetWindowInfo') or
       SetLink('Mosaic', 'WWW_GetWindowInfo') or
       SetLink('Netscp6', 'WWW_GetWindowInfo') or
       SetLink('Mozilla', 'WWW_GetWindowInfo') or
       SetLink('Firefox', 'WWW_GetWindowInfo') then
       p := RequestData('0xFFFFFFFF')
     else raise Exception.Create('Could not establish browser DDE link');
     if Assigned(p) then try
       q := p;
       Assert(q^ = '"');
       SetLength(URL, StrLen(q));
       Inc(q);
       i := 0;
       while q^ <> '"' do begin
         if (q^ = '\') and (q[1] = '"') then Inc(q);
         Inc(i);
         URL[i] := q^;
         Inc(q);
       end;
       SetLength(URL, i);
       SetLength(Title, StrLen(q));
       i := 0;
       Inc(q, 3);
       while q^ <> '"' do begin
         if (q^ = '\') and (q[1] = '"') then Inc(q);
         Inc(i);
         Title[i] := q^;
         Inc(q);
       end;
       SetLength(Title, i);
     finally
       StrDispose(p);
     end else raise Exception.Create('Could not fetch browser data');
   finally
     DDEClient.Free;
   end;
end;

{ Code 3 **************************************}


// To have the locationurls from all running instances of Internet Explorer -
// including open folders and Windows Explorer - shown in a listbox.
// by http://www.euromind.com/iedelphi/

uses
  shdocvw_tlb;

procedure TForm1.Button2Click(Sender: TObject);
var
  x: Integer;
  Sw: IShellWindows;
begin
  sw := CoShellWindows.Create;
  for x := 0 to SW.Count - 1 do
    Listbox1.Items.Add((Sw.Item(x) as IWebbrowser2).LocationUrl);
end;

{ Code 4 **************************************}


uses
  ActiveX, Shdocvw_tlb, MSHTML_TLB;

type
  TObjectFromLResult = function(LRESULT: lResult; const IID: TIID;
    wParam: wParam; out pObject): HRESULT;
  stdcall;


function GetIEFromHWND(WHandle: HWND; var IE: IWebbrowser2): HRESULT;
var
  hInst: HWND;
  lRes: Cardinal;
  Msg: Integer;
  pDoc: IHTMLDocument2;
  ObjectFromLresult: TObjectFromLresult;
begin
  hInst := LoadLibrary('Oleacc.dll'); @ObjectFromLresult :=
    GetProcAddress(hInst, 'ObjectFromLresult');
  if @ObjectFromLresult <> nil then
  begin
    try
      Msg := RegisterWindowMessage('WM_HTML_GETOBJECT');
      SendMessageTimeOut(WHandle, Msg, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes);
      Result := ObjectFromLresult(lRes, IHTMLDocument2, 0, pDoc);
      if Result = S_OK then
        (pDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp,
          IWebbrowser2, IE);
    finally
      FreeLibrary(hInst);
    end;
  end;
end;

function GetActiveIEURL: string;
var
  Document: IHtmlDocument2;
  IE: IWebBrowser2;
  Wnd: HWND;
  WndChild: HWND;
begin
  Wnd := GetForeGroundWindow;
  WndChild := FindWindowEX(Wnd, 0, 'Shell DocObject View', nil);
  if WndChild <> 0 then
  begin
    WndChild := FindWindowEX(WndChild, 0, 'Internet Explorer_Server', nil);
    if WndChild <> 0 then
    begin
      //Get Iwebbrowser2 from Handle
      GetIEFromHWnd(WndChild, IE);
      if IE <> nil then
      begin
        Result := IE.LocationURL;
        // Document := IE.Document as IHtmlDocument2;
      end;
    end;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Caption := GetActiveIEURL;
end;