ewbtools.pas

Delphi VCL Component Pack

procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);

   function StrToChr(Str: string; Pos: Integer): Char;
   begin
      Result := Str[Pos];
   end;
var
   Flags: OleVariant;
   HistoryStg: IUrlHistoryStg;
begin
   Flags := navNoHistory;
   WebBrowser.Navigate(WideString(URL), Flags);
   Wait(WebBrowser);
   HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg;
   HistoryStg.DeleteUrl(PWideChar(StrToChr(URL, 0)), 0);
end;

procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
var
   VaEmpty, vaPidl: OleVariant;
   psa: PSafeArray;
   cbData: UINT;
begin
   cbdata := GetPidlSize(pidl);
   psa := SafeArrayCreateVector(VT_UI1, 0, cbData);
   if (psa <> nil) then
      begin
         CopyMemory(psa.pvData, pidl, cbData);
         VariantInit(vaPidl);
         TVariantArg(vaPidl).vt := VT_ARRAY or VT_UI1;
         TVariantArg(vaPidl).parray := psa;
         WebBrowser.Navigate2(vaPidl, vaEmpty, vaEmpty, vaEmpty, vaEmpty);
         VariantClear(vaPidl);
      end;
end;

function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2;
var //by Aladin
   OleContainer: IOleContainer;
   enum: ActiveX.IEnumUnknown;
   unk: IUnknown;
   Fetched: PLongint;
begin
   Result := nil;
   Fetched := nil;
   if not DocumentLoaded(SourceDoc) then
      Exit;
   OleContainer := SourceDoc as IOleContainer;
   OleContainer.EnumObjects(OLECONTF_EMBEDDINGS or OLECONTF_OTHERS, Enum);
   Enum.Skip(FrameNo);
   Enum.Next(1, Unk, Fetched);
   Result := Unk as IWebBrowser2;
end;

function NavigateToFrame(WebBrowser: TEmbeddedWB; FrameList: string): IHtmlDocument2;
var
   Document: IHtmlDocument2;
   FramesIndexList: TStringList;
   i: Integer;
begin
   Result := nil;
   Document := WebBrowser.GetDocument;
   FramesIndexList := TStringList.Create;
   try
      FramesIndexList.CommaText := FrameList; //move into the last frame
      for i := 0 to FramesIndexList.Count - 1 do
         begin
            Document := GetFrameFromDocument(Document, StrToInt(FramesIndexList[i])).Document as IHtmlDocument2;
            if not DocumentLoaded(Document) then
               Exit;
         end;
      Result := Document;
   finally
      FramesIndexList.Free;
   end;
end;

procedure NavigateFolder(WebBrowser: TEmbeddedWB; CSIDL: Integer);
var
   sFolder: PItemIdList;
begin
   SHGetSpecialFolderLocation(0, CSIDL, SFolder);
   NavigatePidl(WebBrowser, SFolder);
   CoTaskMemFree(SFolder);
end;

procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
begin
   WebBrowser.Go('about:blank');
   Wait(WebBrowser);
end;

procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
begin
   SaveToFile(Document, mFileName);
   Sleep(800);
   with TEwbMapiMail.Create(AOwner) do
      begin
         try
            Subject := mSubject;
            Body := mBody;
            Attachments.Add(mFileName);
            EditDialog := True;
            if Send then
               if not DeleteFile(mFileName) then
                  if WebBrowser.MessagesBoxes.InternalErrMsg then
                     MessageDlg('An error accured while deleting ' + mFileName, mtInformation, mbOKCancel, 0);
         finally
            Free;
         end;
      end;
end;

procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
var
   Flags: OleVariant;
begin
   Flags := navNoHistory or navNoReadFromCache or navNoWriteToCache
      or navAllowAutosearch or navBrowserBar;
   WebBrowser.Navigate(URL, Flags);
end;

function DownloadFile(SourceFile, TargetFile: string): Boolean;
begin
   try
      Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(TargetFile), 0, nil) = 0;
   except
      Result := False;
   end;
end;

procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);
begin
   if notify then
      begin
         if DownloadFile(SourceFile, TargetFile) then
            MessageBox(0, PChar('Downloading: ' + SourceFile + #10 + #13 +
               'To: ' + TargetFile + #10 + #13 + 'was succesfully finished.'),
               PChar('Download successful.'), MB_OK)
         else
            MessageBox(0, PChar(
               'An error ocurred while contacting the site for downloading' + SourceFile),
               PChar('Downloading Error!!'), MB_ICONERROR or MB_OK);
      end
   else
      DownloadFile(SourceFile, TargetFile);
end;

procedure AddToFavorites(URL, Title: string);
const
   CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
var
   ShellUIHelper: ISHellUIHelper;
   Url1, Title1: OleVariant;
begin
   Title1 := Title;
   Url1 := Url;
   CoCreateInstance(CLSID_SHELLUIHELPER, nil, CLSCTX_INPROC_SERVER, IID_IShellUIHelper, ShellUIHelper);
   ShellUIHelper.AddFavorite(URL1, Title1);
end;

function GetFavoritesPath: string;
var
   Reg: TRegistry;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CURRENT_USER;
      if Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False) then
         Result := Reg.ReadString('Favorites');
   finally
      Reg.CloseKey;
      Reg.Free;
   end;
end;

function GetCookiesPath: string;
var
   Reg: TRegistry;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CURRENT_USER;
      if Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False) then
         Result := Reg.ReadString('Cookies');
   finally
      Reg.CloseKey;
      Reg.Free;
   end;
end;

function GetHistoryPath: string;
var
   Reg: TRegistry;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CURRENT_USER;
      if Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False) then
         Result := Reg.ReadString('History');
   finally
      Reg.CloseKey;
      Reg.Free;
   end;
end;

function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
var
   exInfo: TShellExecuteInfo;
   Buf: PChar;
begin
   FillChar(exInfo, SizeOf(exInfo), 0);
   with exInfo do
      begin
         cbSize := SizeOf(exInfo);
         fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST;
         Wnd := CallerHandle;
         nShow := SW_SHOWNORMAL;
         Buf := StrAlloc(MAX_PATH);
         SHGetSpecialFolderPath(wnd, Buf, CSIDL, True);
         Result := Buf;
      end;
end;

function GetIEHomePage: string;
var
   HomePage: string;
begin
   with TRegistry.Create do
      try
         RootKey := HKEY_CURRENT_USER;
         OpenKey('\Software\Microsoft\Internet Explorer\Main', False);
         HomePage := ReadString('Start Page');
         CloseKey;
      finally
         Free;
      end;
   Result := HomePage;
end;

function GetCachedFileFromURL(strUL: string; var strLocalFile: string): Boolean;
var
   lpEntryInfo: PInternetCacheEntryInfo;
   hCacheDir: LongWord;
   dwEntrySize: LongWord;
   dwLastError: LongWord;
begin
   Result := False;
   dwEntrySize := 0;
  // Begin the enumeration of the Internet cache.
   FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
   GetMem(lpEntryInfo, dwEntrySize);
   hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
   if (hCacheDir <> 0) and (strUL = lpEntryInfo^.lpszSourceUrlName) then
      begin
         strLocalFile := lpEntryInfo^.lpszLocalFileName;
         Result := True;
      end;
   FreeMem(lpEntryInfo);
   if Result = False then
      repeat
         dwEntrySize := 0;
      // Retrieves the next cache group in a cache group enumeration
         FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
         dwLastError := GetLastError();
         if (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
            begin
               GetMem(lpEntryInfo, dwEntrySize);
               if (FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize)) then
                  begin
                     if strUL = lpEntryInfo^.lpszSourceUrlName then
                        begin
                           strLocalFile := lpEntryInfo^.lpszLocalFileName;
                           Result := True;
                           Break;
                        end;
                  end;
               FreeMem(lpEntryInfo);
            end;
      until (dwLastError = ERROR_NO_MORE_ITEMS);
end;

function URLFromFavorites(const dotURL: string): string;
begin
   with TIniFile.Create(dotURL) do
      try
         try
            Result := ReadString('InternetShortcut', 'URL', '');
         except;
            Result := '';
         end;
      finally
         Free;
      end;
end;

function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
var
   Handle: THandle;
   Info: IQueryInfo;
   W: PWideChar;
begin
   Handle := 0;
   Info := nil;
   ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));
   if Assigned(Info) then
      begin
         Info.GetInfoTip(0, w);
         Result := W;
      end
   else
      Result := '';
   Result := Trim(System.Copy(Result, Pos(#10, Result) + 1, length(Result)));
end;

function GetDefaultBrowserFromRegistry: string;
var
   Reg: TRegistry;
   KeyName: string;
begin
   Reg := TRegistry.Create;
   try
      Reg.RootKey := HKEY_CLASSES_ROOT;
      KeyName := 'htmlfile\shell\open\command';
      if Reg.OpenKey(KeyName, False) then
         begin
            Result := Reg.ReadString('');
            Reg.CloseKey;
         end
      else
         Result := 'No default browser was found';
   finally
      Reg.Free;
   end;
end;

function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;
type
   Name = array[0..100] of Char;
   PName = ^Name;
var
   HEnt: pHostEnt;
   HName: PName;
   WSAData: TWSAData;
   i: Integer;
begin
   Result := False;
   if WSAStartup($0101, WSAData) <> 0 then
      begin
         WSAErr := 'Winsock is not responding."';
         Exit;
      end;
   IPaddr := '';
   New(HName);
   if GetHostName(HName^, SizeOf(Name)) = 0 then
      begin
         HostName := StrPas(HName^);
         HEnt := GetHostByName(HName^);
         for i := 0 to HEnt^.h_length - 1 do
            IPaddr := Concat(IPaddr, IntToStr(Ord(HEnt^.h_addr_list^[i])) + '.');
         SetLength(IPaddr, Length(IPaddr) - 1);
         Result := True;
      end
   else
      begin
         case WSAGetLastError of
            WSANOTINITIALISED: WSAErr := 'WSANotInitialised';
            WSAENETDOWN: WSAErr := 'WSAENetDown';
            WSAEINPROGRESS: WSAErr := 'WSAEInProgress';
         end;
      end;
   Dispose(HName);
   WSACleanup;
end;

procedure CreateNewMail;
var
   em_subject, em_body, em_mail: string;
begin
   em_subject := '';
   em_body := '';
   em_mail := 'mailto:?subject=' + em_subject + '&body=' + em_body;
   ShellExecute(0, 'open', PChar(em_mail), nil, nil, SW_SHOWNORMAL);
end;

procedure SendUrlInMail(LocationURL, LocationName: WideString);
var
   em_body, em_mail, em_subject, URL, Title: string;
begin
   URL := LocationURL;
   Title := LocationName;
   em_subject := 'Check this site';