unit xBase;

interface

uses
  Windows, SysUtils, StdCtrls, Spin, Classes, WinSock, ShDocVw, ieConst, IEDocHostUIHandler, Graphics,
  MSHTML, ActiveX, Variants, ComCtrls, Dialogs, Forms, Controls, Menus;

type
  THtmlDocument = class(TObject)
  private
    FWebBrowser: TWebBrowser;
    FHtmlText: String;
    FHeader: String;
    FFooter: String;
    FDocHostUIHandler: TDocHostUIHandler;
    procedure WebBrowserNavigateComplete2(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
    function GetAsText: String;
    procedure SaveAsHTML(const FileName: String);
    procedure SaveAsTEXT(const FileName: String);
  public
    constructor Create(WebBrowser: TWebBrowser);
    destructor Destroy; override;
    procedure Clear;
    procedure SetData(const Value: String);
    procedure Add(const Value: String);
    procedure Show;
    procedure SetImages;
    procedure SaveToFile;
    procedure Print;
    property Header: String read FHeader;
    property Footer: String read FFooter;
  end;

function HexToInt(Value: String): LongWord;
function DecodeBase64(Value: String): String;
function IsICQUIN(const Value: String): Boolean;
function GenHTMLList(const Args: array of String): String;
function HTMLSafe(const S: String): String;
function PassToHex(const Value: String): String;
function CRC64Update(CRC64: Int64; Data: PByte; Count: Cardinal): Int64;
function GetStringFromResource(const Res: String): String;

implementation

function GetResourcePointer(const Res: String; var Size: LongWord; var hgRes: hGlobal): Pointer;
var
  SRC: HRSRC;
begin
  Result := nil;
  SRC := FindResource(0, PChar(Res), RT_RCDATA);
  if SRC = 0 then Exit;
  Size := SizeOfResource(0, SRC);
  if Size = 0 then Exit;
  hgRes := LoadResource(0, SRC);
  if hgRes = 0 then Exit;
  Result := LockResource(hgRes);
end;

function GetStringFromResource(const Res: String): String;
var
  rcLen: Cardinal;
  ResPointer: Pointer;
  hgRes: hGlobal;
begin
  Result := '';
  ResPointer := GetResourcePointer(Res, rcLen, hgRes);
  if (ResPointer <> nil) then begin
    SetLength(Result, rcLen);
    Move(ResPointer^, Result[1], rcLen);
    UnlockResource(Cardinal(ResPointer));
    FreeResource(hgRes);
  end;
end;

function SafeWrite(hFile: THandle; Buf: Pointer; Len: DWord): Boolean;
var
  count, wt, plen: DWord;
  Err: Bool;
begin
  if hFile <> INVALID_HANDLE_VALUE then begin
    count := 0; Err := True;
    while (len > 0) and (Err) do begin
      if len > $EFD1 then
        plen := $EFD1
      else
        plen := len;              // The total size must be less than 64K.
      Err := WriteFile(hFile,     // Handle to the console screen buffer.
        Pointer(LongWord(Buf) + count)^,    // Pointer to a buffer that contains characters to be written to the console screen buffer.
        plen,                     // Number of TCHARs to write.
        wt,                       // Pointer to a variable that receives the number of TCHARs actually written.
        nil);                     // Reserved; must be NULL.
      Dec(len, wt);
      Inc(count, wt);
    end;
    Result := Err;
  end else
    Result := False;
end;

procedure xSaveTextToFile(const FileName, Value: String);
var
  Handle: THandle;
begin
  Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CREATE_ALWAYS, 0, 0);
  if Handle = INVALID_HANDLE_VALUE then Exit;
  SafeWrite(Handle, @Value[1], Length(Value));
  CloseHandle(Handle);
end;

//*****************************************************************
{ THtmlDocument }

procedure THtmlDocument.WebBrowserNavigateComplete2(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  hr: HResult;
  CustDoc: ICustomDoc;
begin
  hr := FWebBrowser.Document.QueryInterface(ICustomDoc, CustDoc);
  if hr = S_OK then
    CustDoc.SetUIHandler(FDocHostUIHandler);
end;

procedure THtmlDocument.SetData(const Value: String);
var
  HTMLDocument: IHTMLDocument2;
  v: Variant;
begin
  try
    if FWebBrowser.Document <> nil then begin
      HTMLDocument := FWebBrowser.Document as IHTMLDocument2;
      if HTMLDocument <> nil then begin
        v := VarArrayCreate([0, 0], varVariant);
        v[0] := Value;
        HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
        HTMLDocument.Close;
      end;
    end;
  except
  end;
end;

procedure THtmlDocument.Add(const Value: String);
begin
  FHtmlText := FHtmlText + Value;
end;

procedure THtmlDocument.Clear;
begin
  FHtmlText := '';
end;

constructor THtmlDocument.Create(WebBrowser: TWebBrowser);
begin
  {Set default page to blank}
  WebBrowser.Navigate('about:blank');

  FWebBrowser := WebBrowser;
  FHeader := GetStringFromResource('HTMLHEAD');
  FFooter := GetStringFromResource('HTMLFOOT');

  {Init HTML PopupMenu handler}
  FDocHostUIHandler := TDocHostUIHandler.Create;
  FDocHostUIHandler.FWebBrowser := WebBrowser;
  WebBrowser.OnNavigateComplete2 := WebBrowserNavigateComplete2;
end;

procedure THtmlDocument.Show;
begin
  SetData(FHeader + FHtmlText + FFooter);
end;

procedure THtmlDocument.SetImages;
var
  i: Integer;
begin
  for i := 0 to FWebBrowser.OleObject.Document.Images.Length - 1 do
    FWebBrowser.OleObject.Document.Images.Item(0).Src := 'c:\MyImage.gif';
end;

function THtmlDocument.GetAsText: String;
var
  Doc: IHTMLDocument2;
  W: WideString;
  i: Integer;
  S: String;
  WS: WideString;
begin
  Result := '';
  if FWebBrowser.Document = nil then Exit;
  if FWebBrowser.Document.QueryInterface(IID_IHTMLDocument2, Doc) = S_OK then begin
    if Doc.Body <> nil then begin
      W := PWideChar(Doc.Body.innerText);
      S := '';
      for i := 1 to Length(W) do
        case PWord(Ptr(Integer(W) + (i-1) * 2))^ of
          $03A9: S := S + 'Omega';        
          $2192: S := S + '->';
          $2194: S := S + '<->';
          $2264: S := S + '<=';
          $2261: S := S + '=';
          $255E: S := S + '|=';
        else
          begin
            WS := W[i];
            S := S + OleStrToString(PWideChar(WS));
          end;
        end;
      Result := S;
    end;
  end;
end;

procedure THtmlDocument.SaveAsHTML(const FileName: String);
var
  P: IPersistFile;
begin
  if (FWebBrowser.Document <> nil) then begin
    P := (FWebBrowser.Document as IPersistFile);
    if P <> nil then begin
      P.Save(StringToOleStr(FileName), False);
    end;
  end;
end;

procedure THtmlDocument.SaveAsTEXT(const FileName: String);
begin
  xSaveTextToFile(FileName, GetAsText);
end;

procedure THtmlDocument.SaveToFile;
var
  S: String;
  SD: TSaveDialog;
begin
  SD := TSaveDialog.Create(nil);
  SD.Filter := 'HTML Files (*.html)|*.html|Text Files (*.txt)|*.txt';
  SD.Options := SD.Options + [ofOverwritePrompt];
  if (SD.Execute) then begin
    try
      S := SD.FileName;
      if SD.FilterIndex = 1 then begin
        if Pos('.html', S) = 0 then
          S := S + '.html';
        SaveAsHTML(S);
      end else begin
        if Pos('.txt', S) = 0 then
          S := S + '.txt';
        SaveAsTEXT(S);
      end;
    except
    end;
  end;
  SD.Free;
end;

procedure THtmlDocument.Print;
begin
  if FWebBrowser.Document <> nil then
    try
      FWebBrowser.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT);
    except
    end;
end;

destructor THtmlDocument.Destroy;
begin
  FDocHostUIHandler.Free;
  inherited;
end;

function HexToInt(Value: String): LongWord;
const
  HexStr: String = '0123456789ABCDEF';
var
  i: Word;
begin
  Result := 0;
  if Value = '' then Exit;
  Value := AnsiUpperCase(Value);
  for i := 1 to Length(Value) do
    Inc(Result, (Pos(Value[i], HexStr) - 1) shl ((Length(Value) - i) shl 2));
end;

const
  b64alphabet: String = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function DecodeBase64(Value: String): String;
  function DecodeChunk(const Chunk: String): String;
  var
    W: LongWord;
    i, j: Integer;
  begin
    W := 0; Result := '';
    j := 3;
    for i := 1 to 4 do
      if Pos(Chunk[i], b64alphabet) <> 0 then
        W := W + Byte((Pos(Chunk[i], b64alphabet) - 1)) shl ((4 - i) * 6)
      else Dec(j);
    for i := 1 to j do
      Result := Result + Chr(W shr ((3 - i) * 8) and $ff);
  end;
begin
  Result := '';
  if Length(Value) mod 4 <> 0 then Exit;
  while Length(Value) > 0 do begin
    Result := Result + DecodeChunk(Copy(Value, 0, 4));
    Delete(Value, 1, 4);
  end;
end;

function IsICQUIN(const Value: String): Boolean;
var
  i: Word;
begin
  Result := True;
  for i := 1 to Length(Value) do
    Result := Result and (Value[i] in ['0'..'9']);
end;

function GenHTMLList(const Args: array of String): String;
var
  i, j: Integer;
begin
  Result := '<ul>';
  for i := Low(Args) to High(Args) do begin
    j := Pos(':', Args[i]);
    if j = 0 then
      Result := Result + '<li>' + HTMLSafe(Args[i])
    else if Args[i] <> Copy(Args[i], 1, j+1) then
      Result := Result + '<li>' + HTMLSafe(Args[i]);
  end;
  Result := Result + '</ul>';
end;

function HTMLSafe(const S: String): String;
begin
  Result := StringReplace(S, '<', '&lt;', [rfReplaceAll]);
  Result := StringReplace(Result, '>', '&gt;', [rfReplaceAll]);
  Result := StringReplace(Result, ' ', '&nbsp;', [rfReplaceAll]);  
end;

function PassToHex(const Value: String): String;
var
  i: Word;
begin
  Result := '';
  for i := 1 to Length(Value) do
    Result := Result + ' ' + IntToHex(Ord(Value[i]), 2);
end;

var
  CRC64Table: array[Byte] of Int64;

function CRC64Update(CRC64: Int64; Data: PByte; Count: Cardinal): Int64;
var
  I: Cardinal;
begin
  Result := not CRC64;
  for I := 1 to Count do begin
    Result := Result shr 8 xor CRC64Table[(Cardinal(CRC64) and $FF) xor Data^];
    Inc(Data);
  end;
  Result := not Result;
end;
  
procedure CRC64BuildTable;
var
  I, J: Byte;
  D: Int64;
begin
  for I := 0 to 255 do begin
    D := I;
    for J := 1 to 8 do
     if Odd(D) then
       D := (D shr 1) xor $C96C5795D7870F42 else D := D shr 1;
    CRC64Table[I] := D;
  end;
end;

initialization
  CRC64BuildTable;

end.
