webbrowseredit.pas

帮助编写程序

unit WebBrowserEdit;

interface

uses
  Windows, Messages, Forms, SysUtils, Classes, Controls, Graphics, OleCtrls,
  SHDocVw, Dialogs, ComCtrls, mshtml, Variants, ActiveX, StdCtrls, ExtCtrls, ComObj;

  function HtmlToColor(Color: string): TColor;
  function ColorToHtml(Color: TColor): string;
  procedure InsertHTMLContent(Doc: IHTMLDocument2; HTML: string);
  procedure InsertTable(NumRows,NumCols:Integer;TableAttrs,CellAttrs: string;WebDesign: TWebBrowser);    //表格
  procedure InsertBGImage(WebDesign: TWebBrowser; ImageURI: string); //图片
  function SaveToMHT(const AUrl, AFileName: string;AShowErrorMessage: Boolean = False;IsUrl:Boolean = False): Boolean;

implementation

function HtmlToColor(Color: string): TColor;
var
  i, j, StrLength: Integer;
  lBit: Byte;
  Power: Longint;
begin
  Result := 0;
  try
    StrLength := Length(Color);
    for i := 2 to  StrLength do
    begin
      lBit := Ord(UpCase(Color[i]));
      case lBit of
        65 .. 70:  lBit := lBit - 55;
        48 .. 57:  lBit := lBit - 48;
        else       lBit := 0;
      end;
      Power := 1;
      for j := 3 to i do Power := Power * 16;
      Result := Result + lBit * Power;
    end;
  except
    Result := 0;
  end;
end;

function ColorToHtml(Color: TColor): string;
begin
  result:='#' + IntToHex(Color and $FF,2)+
          IntToHex(Color shr 8 and $FF,2)+
          IntToHex(Color shr 16 and $FF,2);
end;

procedure InsertHTMLContent(Doc: IHTMLDocument2; HTML: string);
var
Sel: IHTMLSelectionObject;
Range: IHTMLTxtRange;
begin
Sel := Doc.selection;
if assigned(Sel) then
begin
if (Sel.type_='None') or (Sel.type_='Text') then
  begin
  Range := Sel.createRange as IHTMLTxtRange;
  Range.pasteHTML(HTML);
  end;
end; 

end; 

procedure InsertTable(NumRows,NumCols:Integer;TableAttrs,CellAttrs: string;WebDesign: TWebBrowser);
var
Doc: IHTMLDocument2;
TableStr: string;
R,C:integer;
begin
Doc := WebDesign.Document as IHTMLDocument2;
if assigned(Doc) then
begin
TableStr :=  '<table border="2" cellpadding="2" cellspacing="4" width="100%">';
 for R:=0 to NumRows do
 begin
  TableStr := TableStr + '<tr>';
  for C:=0 to NumCols do
  begin
   TableStr := TableStr + '<td width="50%">　</td>';
  end;
  TableStr := TableStr + '<tr>';
 end;
TableStr := TableStr + '</table>';
InsertHTMLContent(Doc, TableStr);
end;
end;

procedure InsertBGImage(WebDesign: TWebBrowser; ImageURI: string);
var
 Doc: IHTMLDocument2;
 Body: IHTMLBodyElement;
begin
 Doc := WebDesign.Document as IHTMLDocument2;
 Body := Doc.body as IHTMLBodyElement;
 Body.background := ImageURI;
end;

function SaveToMHT(const AUrl, AFileName: string;AShowErrorMessage: Boolean = False;IsUrl:Boolean = False ): Boolean;
var
oMSG, oConfig: OleVariant;
sFileName: string;
Retvar: Boolean;
begin
sFileName := ChangeFileExt(AFileName, '.mht');
DeleteFile(PAnsiChar(sFileName));
try
    oConfig := CreateOleObject('CDO.Configuration');
    oMSG    := CreateOleObject('CDO.Message');
    oMSG.Configuration := oConfig;
    if IsUrl  then
      oMSG.CreateMHTMLBody(AUrl)
      else oMSG.HTMLBody := AUrl;
    oMSG.GetStream.SaveToFile(sFileName);
    Retvar := True;
except
    on E: Exception do
    begin
      if AShowErrorMessage then MessageDlg(E.Message, mtError, [mbOK], 0);
      Retvar := False;
    end;
end;
oMSG    := VarNull;
oConfig := VarNull;
Result  := Retvar;
end;


end.