ewbtools.pas

Delphi VCL Component Pack

//***********************************************************
//                           EwbTools                       *
//                                                          *
//                    For Delphi 5 to 2006                  *
//                     Freeware Component                   *
//                            by                            *
//                      bsalsa & Smot                       *
//                  [e-mail]                   *
//                                                          *
//  Documentation and updated versions:                     *
//               http://www.bsalsa.com                      *
//***********************************************************

{*******************************************************************************}
{LICENSE:
THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
AND DOCUMENTATION. [YOUR NAME] DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. VSOFT SPECIFICALLY
DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.

You may use, change or modify the component under 3 conditions:
1. In your website, add a link to "http://www.bsalsa.com"
2. In your application, add credits to "Embedded Web Browser"
3. Mail me  ([e-mail]) any code change in the unit
   for the benefit of the other users.
   4. You may consider donation in our web site!
{*******************************************************************************}

unit EWBTools;

interface

{$I EWB.inc}

uses
   EWBAcc, Windows, Classes, ExtCtrls, ShlObj, Graphics, ActiveX,
   Mshtml_Ewb, SHDocVw_EWB, URLMon, EmbeddedWB;

var
   PrintingWithOptions: Boolean;

//Document and Frame
function DocumentLoaded(Document: IDispatch): Boolean;
procedure AssignEmptyDocument(WebBrowser: TEmbeddedWB);
function GetDocument(WebBrowser: TEmbeddedWB): IHTMLDocument2;
function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;

function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2; //By Aladin
function FrameCount(Document: IDispatch): Longint;
function FrameCountFromDocument(SourceDoc: IHtmlDocument2): Integer; //By Aladin

//Document Operations
function DesignMode(Document: IDispatch): Boolean;
procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
procedure Cmd_Copy(Document: IDispatch);
procedure Cmd_Paste(Document: IDispatch);
procedure Cmd_Cut(Document: IDispatch);
procedure SelectAll(Document: IDispatch);

procedure ScrollToTop(OleObject: Variant);
procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
procedure ScrollToBottom(OleObject: Variant);

procedure Zoom(Document: IDispatch; ZoomValue: Integer);
function ZoomValue(Document: IDispatch): Integer;
function ZoomRangeHigh(Document: IDispatch): Integer;
function ZoomRangeLow(Document: IDispatch): Integer;
function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string): Boolean;
function GetCookie(OleObject: Variant): string;
procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth, TargetHeight, TargetWidth: Integer): Boolean;

//View Document Fields/Properties/Images
procedure ViewPageFieldsToStrings(OleObject: Variant; FieldList: TStrings);
procedure ViewPageImagesToStrings(OleObject: Variant; ImagesList: TStrings);
procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
procedure ViewPageSourceHTMLToStrings(OleObject: Variant; Document: IDispatch; HtmlList: TStrings);
procedure ViewPageSourceTextToStrings(OleObject: Variant; Document: IDispatch; TextList: TStrings);
procedure ViewPagePropertiesToStrings(OleObject: Variant; Document: IDispatch; PropertiesList: TStrings);
procedure ViewPageSourceText(OleObject: Variant; Document: IDispatch);

//Save & Load
function SaveToFile(Document: IDispatch; const Fname: string): HRESULT;
function SaveToStream(Document: IDispatch; var AStream: TStream): HRESULT;
function SaveToStrings(Document: IDispatch; AStrings: TStrings): HRESULT;
function SaveDocToStrings(Document: IDispatch; var AStrings: TStrings): HRESULT;
function SaveDocToStream(Document: IDispatch; var AStream: TStream): HRESULT;
function SaveDocToFile(Document: IDispatch; const Fname: string): HRESULT;
function SaveFrameToFile(Document: IDispatch; FrameNo: Integer; const Fname: string): HRESULT;
function SaveFrameToStream(Document: IDispatch; FrameNo: Integer; AStream: TStream): HRESULT;
function SaveFrameToStrings(Document: IDispatch; FrameNo: Integer; AStrings: TStrings): HRESULT;

function LoadFromStrings(WebBrowser: TEmbeddedWB; Document: IDispatch; const AStrings: TStrings): HRESULT;
function LoadFromStream(WebBrowser: TEmbeddedWB; Document: IDispatch; const AStream: TStream): HRESULT;
procedure LoadFromImage(WebBrowser: TEmbeddedWB; Image: TImage);
function LoadFrameFromStrings(Document: IDispatch; FrameNo: Integer; const AStrings: TStrings): HRESULT;
function LoadFrameFromStream(Document: IDispatch; FrameNo: Integer; AStream: TStream): HRESULT;

//Printing
procedure Print(ControlInterface: IWebBrowser2; bHideSetup: Boolean);
procedure PrintWithOptions(ControlInterface: IWebBrowser2; Document: IDispatch; UsePrintOptions, PrintOptionsEnabled, HideSetup: Boolean; var InvokingPageSetup: Boolean);
procedure PrintPreview(Webbrowser: IWebBrowser2);
procedure PrintPreviewExtended(ControlInterface: IWebBrowser2; nCMDShow: Integer; HideSetup: Boolean);
procedure PageSetup(Document: IDispatch; UsePrintOptions, PrintOptionsEnabled: Boolean; var InvokingPageSetup: Boolean);
procedure PrintSetup(ControlInterface: IWebBrowser2; HideSetup: Boolean);
procedure GetPrintValues(WebBrowser: TEmbeddedWB; PrintOptions: TPrintOptions; Measure: TMeasure);
function PrintMarginStr(Measure, RuntimeMeasure: TMeasure; M: Real): PChar;

//Dialogs
procedure OpenDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent);
procedure SaveDialog(Document: IDispatch); overload;
function SaveDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent): string; overload;
procedure ShowInternetOptions(Document: IDispatch);
procedure ShowPageProperties(Document: IDispatch);
procedure ShowOrganizeFavorites(Handle: THandle);
procedure ShowImportExportFavoritesAndCookies(Handle: THandle);
procedure ShowFindDialog(Document: IDispatch);
procedure SaveImagesDialog(OleObject: Variant; Document: IDispatch);
procedure ViewPageSourceHtml(Document: IDispatch);
procedure SavePageTextDialog(AOwner: TComponent; OleObject: Variant; Document: IDispatch);

//Open external programs
procedure OpenAddressBook;
procedure OpenEudoraMail;
procedure OpenOutlookExpressMail;
procedure OpenOutlookMail;
procedure OpenRegistryEditor;
function OpenCalendar: Boolean;
function OpenClient(Client: string): Boolean;
function OpenNetMeeting: Boolean;
function OpenNewsClient: Boolean;
procedure DoExploreFolder(Handle: THandle; Path: string);
procedure OpenIEBrowserWithAddress(Handle: THandle);

//Open specific webpages
function OpenHotmailMail(WebBrowser: TEmbeddedWB): Boolean;
function OpenYahooMail(WebBrowser: TEmbeddedWB): Boolean;
function OpenGoogleMail(WebBrowser: TEmbeddedWB): Boolean;
procedure GoSearchInGoogle(WebBrowser: TEmbeddedWB; SearchTerm: string);
procedure GoSearchInMSN(WebBrowser: TEmbeddedWB; SearchTerm: string);
procedure GoSearchInYahoo(WebBrowser: TEmbeddedWB; SearchTerm: string);

//Navigate & Download
procedure Go(WebBrowser: TEmbeddedWB; Url: string);
procedure GoWithQueryDetails(WebBrowser: TEmbeddedWB; Url, Query: string);
procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);
procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
function NavigateToFrame(WebBrowser: TEmbeddedWB; FrameList: string): IHTMLDocument2;
procedure NavigateFolder(WebBrowser: TEmbeddedWB; CSIDL: Integer);
procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
function DownloadFile(SourceFile, TargetFile: string): Boolean;
procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);

//Get Special Folders/URL paths etc.
function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
function GetIEHomePage: string;
function GetCachedFileFromURL(strUL: string; var strLocalFile: string): Boolean;
function GetDefaultBrowserFromRegistry: string;
function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;

//E-Mail functions
procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
procedure CreateNewMail;
procedure SendUrlInMail(LocationURL, LocationName: WideString);

//Search in Document & Fill Forms
function SearchString(Webbrowser: TEmbeddedWB; const strText: string): Boolean;
function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; const iPos: Integer = 1): IHTMLTxtRange;
procedure SearchAndHighlight(Document: IDispatch; const ACaption, APrompt: string; aText: string = ''; ShowInputQuery: Boolean = False);
function FillForm(OleObject: Variant; FieldName: string; Value: string): Boolean;
procedure AutoFillIEFormAndExcecute;

//Clearing
procedure ClearCache;
procedure ClearTypedUrls;

//Online Status
function CheckOnlineStatus: Boolean;
function IsGlobalOffline: Boolean;
procedure WorkOffline(WebBrowser: TEmbeddedWB);
procedure WorkOnline(WebBrowser: TEmbeddedWB);

//Restricted & Trusted Lists
function CheckIfInRestricredList(const URL: string): Boolean;
function CheckIfInTrustedList(const URL: string): Boolean;
procedure AddToTrustedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
procedure AddToRestrictedSiteList(WebBrowser: TEmbeddedWB; const URL: string);

//Zone Icon, Security Zone, SSL Status
procedure GetZoneIcon(IconPath: string; var Icon: TIcon);
function GetZoneIconToForm(LocationURL: string; Caption, Hint: string): Boolean;
function GetZoneAttributes(const URL: string): TZoneAttributes;
function GetSSLStatus(OleObject: Variant; LocationURL: string; var SSLName, SSLDescription: string): Boolean;
function GetUrlSecurityZone(LocationURL: string; var ZoneName, ZoneDescription: string; var Icon: TIcon): Boolean;

//Proxy & User agent
procedure SetProxy(UserAgent, ProxyServer: string);
//procedure SetProxy(Server: string)overload;
procedure SetUserAgent(var UserAgent: string);
procedure RemoveUserAgent(UserAgent: string);

//MIME Filter & NameSpace
function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
function RegisterNameSpace(clsid: TGUID): HRESULT;
function UnregisterNameSpace: HRESULT;

//Cookies
function GetCookiesPath: string;

//Favorites
function OrganizeFavorite(h: THandle; Path: PChar): Boolean; stdcall external 'shdocvw.dll' Name 'DoOrganizeFavDlg';
function URLFromFavorites(const dotURL: string): string;
function GetFavoritesPath: string;
procedure AddToFavorites(URL, Title: string);
procedure OpenOtherWBFavorites(WebBrowser: TEmbeddedWB);

//History
function GetHistoryPath: string;
function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
procedure ClearHistory;

//Pages
procedure SetNewHomePage(HomePage: string);
function GetLastVisitedPage(var LastVisitedPage: string): Boolean;
function SaveLastVisitedPage(WebBrowser: TEmbeddedWB; LocationURL: string): Boolean;

//Code accessories
procedure Wait(WebBrowser: TEmbeddedWB);
procedure InvokeCMD(Document: IDispatch; InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant);
function GetIEHandle(WebBrowser: TEmbeddedWB; ClassName: string): HWND;

//Miscellaneous
procedure RestoreApplicationFormSize(WebBrowser: TEmbeddedWB);
procedure SaveApplicationFormSize(WebBrowser: TEmbeddedWB);
procedure ShowIEVersionInfo(Handle: THandle);
procedure CreateDesktopShortcut(Handle: THandle);
procedure DisableNavSound(bDisable: Boolean);


//----- add to ewb-------------------------------------------------------
function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
function CopyPIDL(IDList: PItemIDList): PItemIDList;
function CreatePIDL(Size: Integer): PItemIDList;
function DeleteUrl(Url: PWideChar): HResult;
function Encode(const S: string): string;
function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
function GetIEVersion: string;
function GetImageIndex(pidl: PItemIDList): integer;
function GetMailClients: TStrings;
function GetPIDLSize(IDList: PItemIDList): Integer;
function IE5_Installed: Boolean;
function IsChannel(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function IsFolderEx(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function NextPIDL(IDList: PItemIDList): PItemIDList;
function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
function ResolveLink(const path: string): string;
function ResolveUrlIni(Filename: string): string;
function ResolveUrlIntShCut(Filename: string): string;
function StringToVarArray(const S: string): Variant;
function URLFromShortcut(const dotURL: string): string;
function VarArrayToString(const V: Variant): string;
procedure DisposePIDL(ID: PItemIDList);
procedure StripLastID(IDList: PItemIDList);
function IsWinXPSP2OrLater(): Boolean;
function EncodeUrl(const InputStr: string; const bQueryStr: Boolean): string;
function DecodeUrl(const InputStr: string): string;
function IsValidProtocol(const URL: string): Boolean;
//--end of add to ewb---------------------------------

implementation

uses
   Registry, ShellAPI, Controls, Dialogs, Messages, Forms, SysUtils,
   OleCtrls, WinInet, SendMail_For_Ewb, ComObj, IEConst, IniFiles, JPEG, WinSock
   {$IFDEF DELPHI_6_UP}, Variants{$ENDIF}, Browse4Folder;

type
   OSVERSIONINFOEX = packed record
      dwOSVersionInfoSize: DWORD;
      dwMajorVersion: DWORD;
      dwMinorVersion: DWORD;
      dwBuildNumber: DWORD;
      dwPlatformId: DWORD;
      szCSDVersion: array[0..127] of Char;
      wServicePackMajor: WORD;
      wServicePackMinor: WORD;
      wSuiteMask: WORD;
      wProductType: BYTE;
      wReserved: BYTE;
   end;
   TOSVersionInfoEx = OSVERSIONINFOEX;
   POSVersionInfoEx = ^TOSVersionInfoEx;

const
   VER_GREATER_EQUAL = 3;
   VER_MINORVERSION      = $0000001;
   VER_MAJORVERSION      = $0000002;
   VER_SERVICEPACKMINOR  = $0000010;
   VER_SERVICEPACKMAJOR  = $0000020;

type
  fn_VerifyVersionInfo = function(var VersionInformation: OSVERSIONINFOEX;
    dwTypeMask: DWORD; dwlConditionMask: LONGLONG): BOOL; stdcall;
  fn_VerSetConditionMask = function(ConditionMask: LONGLONG; TypeMask: DWORD;
    Condition: Byte): LONGLONG; stdcall;


function IsWinXPSP2OrLater(): Boolean;
var
  osvi: TOSVersionInfoEx;
  dwlConditionMask: LONGLONG;
  op: Integer;
  hlib: THandle;
  VerifyVersionInfo: fn_VerifyVersionInfo;
  VerSetConditionMask: fn_VerSetConditionMask;
begin
  result := false;

  hLib := LoadLibrary('kernel32.dll');
  if (hLib <> 0) then begin
    @VerifyVersionInfo := GetProcAddress(hLib, 'VerifyVersionInfoA');
    @VerSetConditionMask := GetProcAddress(hLib, 'VerSetConditionMask');
    if ((@VerifyVersionInfo = nil) or (@VerSetConditionMask = nil)) then
      Exit;

    dwlConditionMask := 0;
    op := VER_GREATER_EQUAL;

    // Initialize the OSVERSIONINFOEX structure.
    ZeroMemory(@osvi, sizeof(OSVERSIONINFOEX));
    osvi.dwOSVersionInfoSize := sizeof(OSVERSIONINFOEX);
    osvi.dwMajorVersion := 5;
    osvi.dwMinorVersion := 1;
    osvi.wServicePackMajor := 2;
    osvi.wServicePackMinor := 0;

    // Initialize the condition mask.
    dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MAJORVERSION, op);
    dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MINORVERSION, op);
    dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMAJOR, op);
    dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMINOR, op);

    // Perform the test.
    result := VerifyVersionInfo(osvi, VER_MAJORVERSION or VER_MINORVERSION or
       VER_SERVICEPACKMAJOR or VER_SERVICEPACKMINOR, dwlConditionMask);
  end;
end;

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

function DecodeUrl(const InputStr: string): string;
var
  Idx: Integer;
  Hex: string;
  Code: Integer;
begin
  Result := '';
  Idx := 1;