{
   This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either
  version 2 of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
{$D-}
unit Ufunction;

interface

uses Windows, Messages, SysUtils, Variants, Forms, Classes,
  Registry, Psapi, tlhelp32, shellapi, shlobj, activex,
  SHDocVw, mshtml, inifiles;

  function getcurrentfilename:string;
  function GetAppDirectory:string;
  function GetAppDirectory2:string;
  function GetSystemDir: string;
  function GetWindowsDir: string;
  function GetModuleDir: string;
  function RegisterOCX(FileName: string): Boolean;
  function UnRegisterOCX(FileName: string): Boolean;
  function GetProgramFilesDir: string;
  function ExecuteFile(filename:string; visible:boolean): Boolean;
  procedure deletefiles(dir,namespace:string);
  function GetOperatingSystem: Integer;
  procedure SplitString(str:string;var returnStr:TStringList;splitchar:char);

  function EXE_Running(FileName:string):THandle;
  function UrlDecode(const EncodedStr: String): String;
  function URLEncode(const S: string; const InQueryString: Boolean): string;

  function find_WinNTProcessID(FileName:string):integer;
  function ExtractRes(ResType, ResName, ResNewName: string): Boolean;
  function ConvertSize(value:integer):string;
  function ConvertSize2(value:integer):string;
  function timestamptodatetime(s:string):tdatetime;

  function getvalue(s1,s_w,e_w:string):string;
  function Get_File_Size2(sFileToExamine: string): integer;
  function getredirecturl(s1:string):string;
  function striphtmltag(s:string):string;
  function GetIconIndex(const APath: string; Attrs: DWORD): integer;
  procedure lockcontrol(c: THandle; lock: boolean);
  function validmemberid(s:string):boolean;
  function GetVersion(filename:string): string;

  function ForceForegroundWindow(hwnd: THandle): boolean;
  function OpenURLByIE(path:string;isshortcut,forcefront:boolean):integer;
  function AdvSelectDirectory(hOwn: HWND; const Caption: string; const Root: WideString;
    var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
    AllowCreateDirs: Boolean = True): Boolean;

const
  { operating system (OS)constants }
  cOsUnknown = -1;
  cOsWin95 = 0;
  cOsWin98 = 1;
  cOsWin98SE = 2;
  cOsWinME = 3;
  cOsWinNT = 4;
  cOsWin2000 = 5;
  cOsXP = 6;

implementation

type
  TDllRegisterServer = function: HResult; stdcall;

function getcurrentfilename:string;
var
  szFileName: array[0..MAX_PATH] of Char;
begin
  FillChar(szFileName, SizeOf(szFileName), #0);
  GetModuleFileName(hInstance, szFileName, MAX_PATH);
  Result := szFileName;
end;

function GetAppDirectory:string;
begin
  result:=ExtractFilePath(Application.ExeName);
  if (length(result)>0) and (result[length(result)]<>'\') then
    result:=result+'\';
  result:=result+'mosaic\';
end;

function GetAppDirectory2:string;
begin
  result:=ExtractFilePath(Application.ExeName);
end;

function GetSystemDir: string;
var
  dir: array [0..MAX_PATH] of Char;
begin
  GetSystemDirectory(dir, MAX_PATH);
  Result := StrPas(dir);
  if (length(result)>0) and (result[length(result)]<>'\') then
    result:=result+'\';
end;

function GetWindowsDir: string;
var
  dir: array [0..MAX_PATH] of Char;
begin
  GetWindowsDirectory(dir, MAX_PATH);
  Result := StrPas(dir);
  if (length(result)>0) and (result[length(result)]<>'\') then
    result:=result+'\';
end;

function GetModuleDir: string;
var
  szFileName: array[0..MAX_PATH] of Char;
begin
  FillChar(szFileName, SizeOf(szFileName), #0);
  GetModuleFileName(hInstance, szFileName, MAX_PATH);
  Result := szFileName;
  Result:= sysutils.ExtractFilePath(result);  
  if (length(result)>0) and (result[length(result)]<>'\') then
    result:=result+'\';
end;

function GetProgramFilesDir: string;
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion', False);
    Result := reg.ReadString('ProgramFilesDir');
  finally
    reg.Free;
  end;
  if (length(result)>0) and (result[length(result)]<>'\') then
    result:=result+'\';
end;

procedure SplitString(str:string;var returnStr:TStringList;splitchar:char);
var
 p1:integer;
 y:string;
begin

 p1:=pos(splitchar,str);
 while p1>0 do
 begin
    y:=copy(str,1,p1-1);
    returnStr.Add(y);
    delete(str,1,p1);
    p1:=pos(splitchar,str);
 end;
 if str <> '' then returnStr.Add(str);

end;

function RegisterOCX(FileName: string): Boolean;
var
  OCXHand: THandle;
  RegFunc: TDllRegisterServer;
begin
  OCXHand := LoadLibrary(PChar(FileName));
  RegFunc := GetProcAddress(OCXHand, 'DllRegisterServer');
  if @RegFunc <> nil then
    Result := RegFunc = S_OK
  else
    Result := False;
  FreeLibrary(OCXHand);
end;

function UnRegisterOCX(FileName: string): Boolean;
var
  OCXHand: THandle;
  RegFunc: TDllRegisterServer;
begin
  OCXHand := LoadLibrary(PChar(FileName));
  RegFunc := GetProcAddress(OCXHand, 'DllUnregisterServer');
  if @RegFunc <> nil then
    Result := RegFunc = S_OK
  else
    Result := False;
  FreeLibrary(OCXHand);
end;

function ExecuteFile(filename:string; visible:boolean): Boolean;
var
  SUInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  s:string;
begin
  FillChar(SUInfo, SizeOf(SUInfo), #0);
  with SUInfo do begin
     cb := SizeOf(SUInfo);
     dwFlags := STARTF_USESHOWWINDOW;
     if visible then
        wShowWindow := SW_NORMAL
     else
        wShowWindow := SW_HIDE;
//     s:=sysutils.ExtractFilePath(filename);
     createprocess(nil, PChar(filename), nil, nil, False,
        CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil,
        SUInfo, ProcInfo);
  end;
end;

procedure deletefiles(dir,namespace:string);
var
  SR: TSearchRec;
  a:string;
begin
  namespace:=lowercase(namespace);
  if FindFirst(dir+'*.*', faAnyFile, SR) = 0 then
   repeat
     if (SR.Attr <> faDirectory) and (SR.Name[1] <> '.') then begin
       a:=lowercase(sysutils.ExtractFileExt(SR.Name));
       if (namespace='*.*') or (a = namespace) then begin
          DeleteFile(dir+'\'+SR.Name);
       end;
     end;
   Until (FindNext(SR)<>0);
  FindClose(SR);
end;

function GetOperatingSystem: Integer;
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := cOsUnknown;
  { set operating system type flag }
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT: { Windows NT/2000 }
        begin
          if majorVer <= 4 then
            Result := cOsWinNT
          else if (majorVer = 5) and (minorVer = 0) then
            Result := cOsWin2000
          else if (majorVer = 5) and (minorVer = 1) then
            Result := cOsXP
          else
            Result := cOsUnknown;
        end;
      VER_PLATFORM_WIN32_WINDOWS:  { Windows 9x/ME }
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := cOsWin95
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := cOsWin98SE
            else
              Result := cOsWin98;
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := cOsWinME
          else
            Result := cOsUnknown;
        end;
      else
        Result := cOsUnknown;
    end;
  end
  else
    Result := cOsUnknown;
end;

///process check////
//Psapi, tlhelp32;
function CreateWin9xProcessList(FileName:string):THandle;
var
  hSnapShot: THandle;
  ProcInfo: TProcessEntry32;
  h:THandle;
begin
  result:=0;
  hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if (hSnapShot <> THandle(-1)) then 
  begin 
    ProcInfo.dwSize := SizeOf(ProcInfo);
    if (Process32First(hSnapshot, ProcInfo)) then
    begin
      if CompareText(ExtractFileName(ProcInfo.szExeFile), ExtractFileName(FileName)) = 0 then begin
         h:=OpenProcess(PROCESS_TERMINATE, False, ProcInfo.th32ProcessID);
         result:=h;
         CloseHandle(h);
         exit;
      end;

      while (Process32Next(hSnapShot, ProcInfo)) do
      if CompareText(ExtractFileName(ProcInfo.szExeFile), ExtractFileName(FileName)) = 0 then begin
         h:=OpenProcess(PROCESS_TERMINATE, False, ProcInfo.th32ProcessID);
         result:=h;
         CloseHandle(h);
         CloseHandle(hSnapShot);
         break;
      end;
    end;
    CloseHandle(hSnapShot);
  end;
end;

function CreateWinNTProcessList(FileName:string):THandle;
var
  PIDArray: array [0..1023] of DWORD;
  cb: DWORD;
  I: Integer; 
  ProcCount: Integer; 
  hMod: HMODULE; 
  hProcess: THandle;
  ModuleName: array [0..300] of Char;
  h:THandle;
begin
  result:=0;
  EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
  ProcCount := cb div SizeOf(DWORD);
  for I := 0 to ProcCount - 1 do
  begin
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
      PROCESS_VM_READ,
      False,
      PIDArray[I]);
    if (hProcess <> 0) then
    begin
      EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
      GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
      if CompareText(ModuleName, FileName) = 0 then begin
         h:=OpenProcess(PROCESS_TERMINATE, false, PIDArray[I]);
         result:=h;
         CloseHandle(h);
         CloseHandle(hProcess);
         break;
      end;
      CloseHandle(hProcess);
    end;
  end;
end;

function GetProcessList(FileName:string):THandle;
var
  ovi: TOSVersionInfo;
begin
//  if List = nil then Exit;
  result:=0;
  ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(ovi);
  case ovi.dwPlatformId of
    VER_PLATFORM_WIN32_WINDOWS: result:=CreateWin9xProcessList(FileName);
    VER_PLATFORM_WIN32_NT: result:=CreateWinNTProcessList(FileName);
  end
end;

function EXE_Running(FileName:string):THandle;
begin
  result:=GetProcessList(FileName);
end;

function HexToInt(HexStr: String): Int64;
var RetVar : Int64;
    i : byte;
begin
  HexStr := UpperCase(HexStr);
  if HexStr[length(HexStr)] = 'H' then
     Delete(HexStr,length(HexStr),1);
  RetVar := 0;

  for i := 1 to length(HexStr) do begin
      RetVar := RetVar shl 4;
      if HexStr[i] in ['0'..'9'] then
         RetVar := RetVar + (byte(HexStr[i]) - 48)
      else
         if HexStr[i] in ['A'..'F'] then
            RetVar := RetVar + (byte(HexStr[i]) - 55)
         else begin
            Retvar := 0;
            break;
         end;
  end;

  Result := RetVar;
end;

function UrlDecode(const EncodedStr: String): String;
var
  I: Integer;
begin
  Result := '';
  if Length(EncodedStr) > 0 then
  begin
    I := 1;
    while I <= Length(EncodedStr) do
    begin
      if EncodedStr[I] = '%' then
        begin
          Result := Result + Chr(HexToInt(EncodedStr[I+1]
                                       + EncodedStr[I+2]));
          I := Succ(Succ(I));
        end
      else if EncodedStr[I] = '+' then
        Result := Result + ' '
      else
        Result := Result + EncodedStr[I];

      I := Succ(I);
    end;
  end;
end;

function URLEncode(const S: string; const InQueryString: Boolean): string;
var
  Idx: Integer; // loops thru characters in string
begin
  Result := '';
  for Idx := 1 to Length(S) do
  begin
    case S[Idx] of
      'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
        Result := Result + S[Idx];
      ' ':
        if InQueryString then
          Result := Result + '+'
        else
          Result := Result + '%20';
      else
        Result := Result + '%' + SysUtils.IntToHex(Ord(S[Idx]), 2);
    end;
  end;
end;

function find_WinNTProcessID(FileName:string):integer;
var
  PIDArray: array [0..1023] of DWORD;
  cb: DWORD;
  I: Integer;
  ProcCount: Integer; 
  hMod: HMODULE; 
  hProcess: THandle;
  ModuleName: array [0..300] of Char;
begin
  result:=0;
  EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
  ProcCount := cb div SizeOf(DWORD);
  for I := 0 to ProcCount - 1 do
  begin
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
      PROCESS_VM_READ,
      False,
      PIDArray[I]);
    if (hProcess <> 0) then
    begin
      EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
      GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
      if CompareText(ModuleName, FileName) = 0 then begin
         result:=PIDArray[I];
         CloseHandle(hProcess);
         break;
      end;
      CloseHandle(hProcess);
    end;
  end;
end;

function ExtractRes(ResType, ResName, ResNewName: string): Boolean;
var
  Res: TResourceStream;
begin
  Result := False;
  Res := TResourceStream.Create(Hinstance, Resname, PChar(ResType));
  try
    Res.SavetoFile(ResNewName);
    Result := True;
  finally
    Res.Free;
  end;
end;

function ConvertSize(value:integer):string;
var
 s,d:double;
begin
try
  s:=value;
  if s > 1000000 then begin
     d := (s / 1000000);
     result:=formatfloat('##.#', d) + ' M';
  end else if s > 1000 then begin
     d := (s / 1000);
     result:=formatfloat('##.#', d) + ' Kb';
  end else begin
     result:=floattostr(s) + ' b';
  end;
except
  result:= '0 b';
end;
end;

function ConvertSize2(value:integer):string;
var
 s,d:double;
begin
try
  s:=value;
  if s > 1000 then begin
     d := (s / 1000);
     result:=formatfloat('##.#', d) + ' Kb';
  end else begin
     result:=floattostr(s) + ' b';
  end;
except
  result:= '0 b';
end;
end;

function timestamptodatetime(s:string):tdatetime;
begin
  s:=format('%s-%s-%s %s:%s',[
    copy(s,1,4),copy(s,5,2),copy(s,7,2),
    copy(s,9,2),copy(s,11,2)
    ]);
  result:=sysutils.StrToDateTime(s);
end;


 function getvalue(s1,s_w,e_w:string):string;
 var s2:string;
  p1:integer;
 begin
    result:='';
    p1:=pos(s_w,s1);
    if p1=0 then
       exit;
    s2:=copy(s1,p1+length(s_w),length(s1));
    p1:=pos(e_w,s2);
    result:=copy(s2,1,p1-1);
 end;

function Get_File_Size2(sFileToExamine: string): integer;
var
  SearchRec: TSearchRec;
  sgPath: string;
  inRetval, I1: Integer;
begin
  sgPath := ExpandFileName(sFileToExamine);
  try
    inRetval := FindFirst(ExpandFileName(sFileToExamine), faAnyFile, SearchRec);
    if inRetval = 0 then
      I1 := SearchRec.Size
    else
      I1 := -1;
  finally
    SysUtils.FindClose(SearchRec);
  end;
  Result := I1;
end;

 function getredirecturl(s1:string):string;
 var s2:string;
  p1:integer;
 begin
    result:='';
    p1:=pos('location: http',lowercase(s1));
    if p1=0 then
       exit;
    s2:=copy(s1,p1+14,length(s1));
    p1:=pos(#13,s2);
    result:='http' + copy(s2,1,p1-1);
 end;

function striphtmltag(s:string):string;
var
  p1,p2:integer;
begin
  p1:=pos('<',s);
  while p1>0 do begin
    p2:=pos('>',s);
    if p2>0 then
      delete(s,p1,p2-p1+1);
    p1:=pos('<',s);
  end;
  result:=trim(s);
end;

function GetIconIndex(const APath: string; Attrs: DWORD): integer;
var
  SFI: TSHFileInfo;
begin
  if FileExists(APath) or DirectoryExists(APath) then
    SHGetFileInfo(PChar(APath), 0, SFI, SizeOf(TSHFileInfo),
      SHGFI_SYSICONINDEX)
  else
    SHGetFileInfo(PChar(APath), Attrs, SFI, SizeOf(TSHFileInfo),
      SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
  Result := SFI.iIcon;
end;

procedure lockcontrol(c: THandle; lock: boolean);
begin
    if (c=0) then exit;
    if lock then SendMessage(c,WM_SETREDRAW,0,0)
    else begin
      SendMessage(c,WM_SETREDRAW,1,0);
      RedrawWindow(c,nil,0,
        RDW_ERASE or RDW_FRAME or RDW_INVALIDATE or RDW_ALLCHILDREN);
    end;
end;


function validmemberid(s:string):boolean;
var
  i:integer;
  c:char;
begin
  for i:=1 to length(s) do begin
    c:=s[i];
    if ((c>='0') and (c<='9')) or
      ((c>='a') and (c<='z')) or
      ((c>='A') and (c<='Z'))  then
      result:=true
    else begin
      result:=false;
      break;
    end;
  end;
end;

function GetVersion(filename:string): string;
var
  VerInfoSize: DWORD;
  VerInfo: Pointer;
  VerValueSize: DWORD;
  VerValue: PVSFixedFileInfo;
  Dummy: DWORD;
begin
  Result := '';
  VerInfoSize := GetFileVersionInfoSize(PChar(filename), Dummy);
  if VerInfoSize = 0 then Exit;
  GetMem(VerInfo, VerInfoSize);
  GetFileVersionInfo(PChar(filename), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  with VerValue^ do
  begin
    Result := IntToStr(dwFileVersionMS shr 16);
    Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
    Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
    Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
  end;
  FreeMem(VerInfo, VerInfoSize);
end;

var
  ownerformhandle:HWND;

procedure CenterDialog(child:HWND);
var
  r1,r2:trect;
  x,y,w1,h1,w2,h2:integer;
begin
  windows.GetWindowRect(ownerformhandle,r1);
  windows.GetWindowRect(child,r2);

  w1:=r1.Right-r1.Left;
  h1:=r1.Bottom-r1.Top;
  w2:=r2.Right-r2.Left;
  h2:=r2.Bottom-r2.Top;

  x:=r1.Left+(w1 div 2)-(w2 div 2);
  y:=r1.Top+(h1 div 2)-(h2 div 2);
  if (x+w2)>screen.Width then x:=screen.Width-w2;
  if x<0 then x:=0;
  if (y+h2)>screen.Height then y:=screen.Height-h2;
  if y<0 then y:=0;
  SetWindowPos(child, 0, x,y,-1,-1, SWP_NOSIZE);
end;

function AdvSelectDirectory(hOwn: HWND; const Caption: string; const Root: WideString;
  var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
  AllowCreateDirs: Boolean = True): Boolean;

  function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer;
    stdcall;
//  var
//    PathName: array[0..MAX_PATH] of Char;
  begin
    case uMsg of
      BFFM_INITIALIZED:begin
        SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
        CenterDialog(wnd);
      end;
      {BFFM_SELCHANGED:
      begin
        SHGetPathFromIDList(PItemIDList(lParam), @PathName);
        // the directory "PathName" has been selected
        // das Verzeichnis "PathName" wurde selektiert
      end;} 
    end; 
    Result := 0; 
  end;
var
  WindowList: Pointer; 
  BrowseInfo: TBrowseInfo; 
  Buffer: PChar; 
  RootItemIDList, ItemIDList: PItemIDList; 
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder; 
  Eaten, Flags: LongWord;
const 
  // necessary for some of the additional expansions
  // notwendig fur einige der zusatzlichen Erweiterungen 
  BIF_USENEWUI = $0040;
  BIF_NOCREATEDIRS = $0200; 
begin 
  Result := False;
  ownerformhandle:=hOwn;
  if not DirectoryExists(Directory) then
    Directory := ''; 
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); 
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then 
  begin 
    Buffer := ShellMalloc.Alloc(MAX_PATH); 
    try 
      RootItemIDList := nil; 
      if Root <> '' then
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(hOwn, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end; 
      OleInitialize(nil); 
      with BrowseInfo do 
      begin
        hwndOwner := hOwn;
        pidlRoot := RootItemIDList; 
        pszDisplayName := Buffer; 
        lpszTitle := PChar(Caption);
        // defines how the dialog will appear:
        // legt fest, wie der Dialog erscheint:
        ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI or 
          BIF_EDITBOX * Ord(EditBox) or BIF_BROWSEINCLUDEFILES * Ord(ShowFiles) or 
          BIF_NOCREATEDIRS * Ord(not AllowCreateDirs); 
        lpfn    := @SelectDirCB;
        if Directory <> '' then 
          lParam := Integer(PChar(Directory)); 
      end; 
      WindowList := DisableTaskWindows(0); 
      try 
        ItemIDList := ShBrowseForFolder(BrowseInfo); 
      finally 
        EnableTaskWindows(WindowList); 
      end; 
      Result := ItemIDList <> nil;
      if Result then 
      begin 
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

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 IsInternetExplorer(Wnd: HWND):boolean;
var
  ClassName : array[0..1024] of char;
  dwClass:DWORD;
begin
  result:=false;
  dwClass:=GetClassName(wnd,classname,sizeof(ClassName));
  ClassName[dwClass]:=#0;
  if (StrComp(ClassName,'IEFrame')=0) then begin
    result:=true
  end;
end;

function EnumWindowsProc2(Wnd: HWND; lParam: Integer): BOOL; stdcall;
begin
  Result := True;
  if (IsWindowVisible(Wnd) or IsIconic(wnd)) and
    ((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or
    (GetWindowLong(Wnd, GWL_HWNDPARENT) = GetDesktopWindow)) and
    (GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then begin
    if IsInternetExplorer(wnd) then begin
      integer(Pointer(lParam)^):=wnd;
      result:=false;
    end;
  end;
end;

function GetURL(URL: TFilename): string;
var
  ini: TIniFile;
begin
  ini := TIniFile.Create(URL);
  try
    result := ini.ReadString('InternetShortcut', 'URL', '');
  except;
    result := '';
    ini.Free;
    ini := nil;
  end;
  if Assigned(ini) then
    ini.Free;
end;

function EnumWindowsProc3(wnd: HWND; lParam: Integer): BOOL; stdcall;
var
  ClassName : array[0..1024] of char;
  dwClass:DWORD;
begin
  result:=true;
  dwClass:=GetClassName(wnd,classname,sizeof(ClassName));
  ClassName[dwClass]:=#0;
  if (StrComp(ClassName,'Internet Explorer_Server')=0) then begin
    integer(Pointer(lParam)^):=wnd;
    result:=false;
  end;
end;

function findchildwnd(parent:HWND):HWND;
var
  Param: Integer;
begin
  param:=0;
  EnumChildWindows(parent, @EnumWindowsProc3, integer(@Param));
  result:=param;
end;

function OpenURLByIE(path:string;isshortcut,forcefront:boolean):integer;
var
  Param: Integer;
  IE: IWebBrowser2;
  url:string;
  WndChild: HWND;
begin
  result:=0;
  param:=0;
  EnumWindows(@EnumWindowsProc2, integer(@Param));
  if Param>0 then begin
      WndChild := FindWindowEX(Param, 0, 'Shell DocObject View', nil);
      if wndchild=0 then
        WndChild := FindWindowEX(Param, 0, 'TabWindowClass', nil); //IE7
      if wndchild=0 then begin
        wndchild:=findchildwnd(Param);
      end else if wndchild<>0 then
        wndchild:=findchildwnd(wndchild);

      if WndChild <> 0 then begin
        GetIEFromHWnd(WndChild, IE);
        if IE <> nil then begin
          if isshortcut then
            url:=GetURL(path)
          else
            url:=path;
          if url<>'' then begin
            result:=Param;
            IE.Navigate(url,EmptyParam,EmptyParam,EmptyParam,EmptyParam);
            if forcefront then
              ForceForegroundWindow(Param);
          end;
        end;
      end;
{
    WndChild := FindWindowEX(Param, 0, 'Shell DocObject View', nil);
    if wndchild=0 then begin
      WndChild := FindWindowEX(Param, 0, 'TabWindowClass', nil);
      if WndChild<>0 then
        WndChild := FindWindowEX(WndChild, 0, 'Shell DocObject View', nil);
    end;
    if WndChild <> 0 then begin
      WndChild := FindWindowEX(WndChild, 0, 'Internet Explorer_Server', nil);
      if WndChild <> 0 then begin
        GetIEFromHWnd(WndChild, IE);
        if IE <> nil then begin
          if isshortcut then
            url:=GetURL(path)
          else
            url:=path;
          if url<>'' then begin
            result:=Param;
            IE.Navigate(url,EmptyParam,EmptyParam,EmptyParam,EmptyParam);
            if forcefront then
              ForceForegroundWindow(Param);
          end;
        end;
      end;
    end;
    }
  end;
end;

function ForceForegroundWindow(hwnd: THandle): boolean;
const
  SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
  SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var 
  ForegroundThreadID: DWORD; 
  ThisThreadID      : DWORD; 
  timeout           : DWORD;
begin 
  if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE); 

  if GetForegroundWindow = hwnd then Result := true
  else begin
    // Windows 98/2000 doesn't want to foreground a window when some other
    // window has keyboard focus
    if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4))
     or
      ((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
      ((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and
      (Win32MinorVersion > 0)))) then begin


      // Code from Karl E. Peterson, www.mvps.org/vb/sample.htm 
      // Converted to Delphi by Ray Lischner 
      // Published in The Delphi Magazine 55, page 16 


      Result := false; 
      ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow,nil);
      ThisThreadID := GetWindowThreadPRocessId(hwnd,nil);
      if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then begin
        BringWindowToTop(hwnd); // IE 5.5 related hack
        SetForegroundWindow(hwnd);
        AttachThreadInput(ThisThreadID, ForegroundThreadID, false);
        Result := (GetForegroundWindow = hwnd);
      end;
      if not Result then begin


        // Code by Daniel P. Stasinski 


        SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0);
        SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
        BringWindowToTop(hwnd); // IE 5.5 related hack
        SetForegroundWindow(hWnd);
        SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
      end;
    end
    else begin
      BringWindowToTop(hwnd); // IE 5.5 related hack
      SetForegroundWindow(hwnd);
    end;

    Result := (GetForegroundWindow = hwnd); 
  end; 
end;

end.
