ewbtools.pas

Delphi VCL Component Pack

  while Idx <= Length(InputStr) do
  begin
    case InputStr[Idx] of
      '%':
      begin
        if Idx <= Length(InputStr) - 2 then
        begin
          Hex := InputStr[Idx+1] + InputStr[Idx+2];
          Code := SysUtils.StrToIntDef('$' + Hex, -1);
          Inc(Idx, 2);
        end
        else
          Code := -1;
        if Code = -1 then
          raise SysUtils.EConvertError.Create('Invalid hex digit in URL');
        Result := Result + Chr(Code);
      end;
      '+':
        Result := Result + ' '
      else
        Result := Result + InputStr[Idx];
    end;
    Inc(Idx);
  end;
end;

function IsValidProtocol(const URL: string): Boolean;
const
  Protocols: array[1..11] of string = ('ftp://', 'http://', 'https://',
     'gopher://', 'mailto:', 'news:', 'nntp://',  'telnet://', 'wais://',
     'file://', 'prospero://');
var
  I: Integer;
begin
  Result := False;
  for I := 1 to 11 do
    if Pos(Protocols[I], SysUtils.LowerCase(URL)) <> 0 then
    begin
      Result := True;
      Break;
    end;
end;

function DocumentLoaded(Document: IDispatch): Boolean;
var
   iDoc: IHtmlDocument2;
begin
   Result := False;
   if Assigned(Document) then
      begin
         Document.QueryInterface(IHtmlDocument2, iDoc);
         Result := Assigned(iDoc);
      end;
end;

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

function GetDocument(WebBrowser: TEmbeddedWB): IHtmlDocument2;
begin
   Result := WebBrowser.Document as IHtmlDocument2;
   if Result = nil then
      raise Exception.Create('Unable to load the document');
end;

function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;
var
   Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
   WebBrowser.Navigate('about:' + StringToHtml, Flags, TargetFrameName, PostData, Headers);
   Result := True;
end;

function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
var
   OleContainer: IOleContainer;
   enum: ActiveX.IEnumUnknown;
   unk: IUnknown;
   Fetched: PLongint;
begin
   if DocumentLoaded(Document) then
      begin
         Fetched := nil;
         OleContainer := Document as IOleContainer;
         OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
         Enum.Skip(FrameNo);
         Enum.Next(1, Unk, Fetched);
         Result := Unk as IWebBrowser2;
      end
   else
      Result := nil;
end;

function FrameCount(Document: IDispatch): LongInt;
var //fix by Aladin
   OleContainer: IOleContainer;
   enum: ActiveX.IEnumUnknown;
   FetchedContrs: LongInt;
   Unknown: IUnknown;
   IWeb: IWebBrowser2;
begin
   Result := 0; //bsalsa
   if not DocumentLoaded(Document) then
      Exit;
   OleContainer := Document as IOleContainer;
   if OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum) = S_OK then
      begin
         while Enum.Next(1, Unknown, @FetchedContrs) = S_OK do
            begin
               if Unknown.QueryInterface(IID_IWebBrowser2, IWeb) = S_OK then //check if it is frame
                  Inc(Result);
            end;
      end;
end;

function FrameCountFromDocument(SourceDoc: IHtmlDocument2): Integer;
var //by Aladin
   OleContainer: IOleContainer;
   enum: ActiveX.IEnumUnknown;
   unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;"
   EnumResult: HRESULT;
begin
   Result := 0;
   if not DocumentLoaded(SourceDoc) then
      Exit;
   OleContainer := SourceDoc as IOleContainer;
   EnumResult := OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
   if EnumResult = S_OK then
      begin // Added per OLE help
         Enum.Next(100, Unk, @Result)
      end
   else
      begin // Added per OLE help
         Enum := nil;
      end;
end;

function DesignMode(Document: IDispatch): Boolean;
// by smot
var
   HTMLDocument2: IHTMLDocument2;
   Status: string;
begin
   Result := False;
   HTMLDocument2 := (Document as IHTMLDocument2);
   if HTMLDocument2 <> nil then
      begin
         Status := HTMLDocument2.get_designMode;
         if Status = 'On' then
            begin
               HTMLDocument2.designMode := 'Off';
            end
         else
            begin
               HTMLDocument2.designMode := 'On';
               Result := True;
            end;
      end;
end;

procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
begin
   if DocumentLoaded(Document) then
      with (Dispatch as IOleObject) do
         DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser, 0, WebBrowser.Handle, WebBrowser.ClientRect);
end;

procedure CMD_Copy(Document: IDispatch);
var
   vaIn, vaOut: OleVariant;
begin
   InvokeCmd(Document, False, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure CMD_Paste(Document: IDispatch);
var
   vaIn, vaOut: OleVariant;
begin
   InvokeCmd(Document, False, OLECMDID_PASTE, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure CMD_Cut(Document: IDispatch);
var
   vaIn, vaOut: OleVariant;
begin
   InvokeCmd(Document, False, OLECMDID_CUT, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure SelectAll(Document: IDispatch);
var
   vaIn, vaOut: OleVariant;
begin
   InvokeCmd(Document, False, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure ScrollToTop(OleObject: Variant);
begin
   try
      if DocumentLoaded(OleObject.Document) then
         OleObject.Document.ParentWindow.ScrollTo(0, 0);
   except
   end;
end;

procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
begin
   try
      if DocumentLoaded(OleObject.Document) then
         OleObject.Document.ParentWindow.ScrollTo(X, Y);
   except
   end;
end;

procedure ScrollToBottom(OleObject: Variant);
begin
   try
      if DocumentLoaded(OleObject.Document) then
         OleObject.Document.ParentWindow.ScrollTo(0, MaxInt);
   except
   end;
end;

procedure Zoom(Document: IDispatch; ZoomValue: Integer);
var
   vaIn, vaOut: OleVariant;
begin
   if ZoomValue < ZoomRangeLow(Document) then
      vaIn := ZoomRangeLow(Document)
   else
      if ZoomValue > ZoomRangeHigh(Document) then
         vaIn := ZoomRangeHigh(Document)
      else
         vaIn := ZoomValue;
   InvokeCmd(Document, False, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;

function ZoomValue(Document: IDispatch): Integer;
var
   vaIn, vaOut: OleVariant;
begin
   vaIn := null;
   InvokeCmd(Document, False, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
   Result := vaOut;
end;

function ZoomRangeHigh(Document: IDispatch): Integer;
var
   vaIn, vaOut: OleVariant;
begin
   InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
   Result := HiWord(DWORD(vaOut));
end;

function ZoomRangeLow(Document: IDispatch): Integer;
var
   vaIn, vaOut: OleVariant;
begin
   InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
   Result := LoWord(DWORD(vaOut));
end;

function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string): Boolean;
var
   RefreshLevel: OleVariant;
begin
   Wait(WebBrowser);
   Result := False;
   if DocumentLoaded(Document) then
      begin
         try
            Mshtml_Ewb.IHTMLDocument2(Document).Set_CharSet(ACharactersSet);
            Result := True;
            RefreshLevel := 7;
            WebBrowser.Refresh2(RefreshLevel);
         except
         end;
      end;
end;

function GetCookie(OleObject: Variant): string;
begin
   Result := '';
   Result := OleObject.Document.Cookie;
end;

procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
var
   DrawRect: TRect;
begin
   if Image = nil then
      Exit;
   DrawRect := Rect(0, 0, Image.Height, Image.Width);
   Image.Picture.Bitmap.Height := Image.Height;
   Image.Picture.Bitmap.Width := Image.Width;
   (Dispatch as IViewObject).Draw(DVASPECT_DOCPRINT, 0, nil, nil, 0,
      Image.Canvas.Handle, @DrawRect, nil, nil, 0);
   Image.Refresh;
end;

function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
var
   ViewObject: IViewObject;
   sourceDrawRect: TRect;
   ScreenImg: Graphics.TBitmap;
begin
   Result := False;
   if DocumentLoaded(Document) then
      try
         Document.QueryInterface(IViewObject, ViewObject);
         if Assigned(ViewObject) then
            try
               ScreenImg := TBitmap.Create;
               ScreenImg.Height := Height;
               ScreenImg.Width := Width;
               sourceDrawRect := Rect(0, 0, ScreenImg.Width, ScreenImg.Height);
               ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Handle,
                  ScreenImg.Canvas.Handle, @sourceDrawRect, nil, nil, 0);
               ScreenImg.SaveToFile(FileName);
               Result := True;
            finally
               ViewObject._Release;
            end;
      except
         Result := False;
      end;
end;

function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth,
   TargetHeight, TargetWidth: Integer): Boolean;
var
   sourceDrawRect: TRect;
   targetDrawRect: TRect;
   sourceBitmap: Graphics.TBitmap;
   targetBitmap: Graphics.TBitmap;
   aJPG: TJPEGImage;
   aViewObject: IViewObject;
   IWeb: IWebBrowser2;
begin
   Result := False;
   sourceBitmap := Graphics.TBitmap.Create;
   targetBitmap := Graphics.TBitmap.Create;
   aJPG := TJPEGImage.Create;
   IWeb := ControlInterface;
   try
      try
         sourceDrawRect := Rect(0, 0, SourceWidth, SourceHeight);
         sourceBitmap.Width := SourceWidth;
         sourceBitmap.Height := SourceHeight;
         aViewObject := IWeb as IViewObject;
         if aViewObject = nil then
            Exit;
         OleCheck(aViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil,
            Forms.Application.Handle,
            sourceBitmap.Canvas.Handle,
            @sourceDrawRect, nil, nil, 0));
         targetDrawRect := Rect(0, 0, TargetWidth, TargetHeight);
         targetBitmap.Height := TargetHeight;
         targetBitmap.Width := TargetWidth;
         targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap);
         aJPG.Assign(targetBitmap);
         aJPG.SaveToFile(FileName);
         Result := True;
      finally
         aJPG.Free;
         sourceBitmap.Free;
         targetBitmap.Free;
      end;
   except
      Result := False;
   end;
end;

procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
var //by smot
   UNum: Variant;
   s: string;

   procedure RecurseLinks(htmlDoc: Variant);
   var
      BodyElement, ElementCo, HTMLFrames, HTMLWnd, doc: OleVariant;
      j, i: Integer;
   begin
      if VarIsEmpty(htmlDoc) then
         Exit;
      BodyElement := htmlDoc.body;
      if BodyElement.tagName = 'BODY' then
         begin
            ElementCo := htmlDoc.links;
            j := ElementCo.Length - 1;
            for i := 0 to j do
               begin