unit xBase;

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

const
  MaxComboItems = 20;

procedure xInitComponents(const A: array of TComponent);
procedure xUpdateComponents(const A: array of TComponent);
function xResolve(const Host: String): Integer;
function GetStringFromResource(const Res: String): String;
function HexToInt(Value: String): LongWord;
function SafeWrite(hFile: THandle; Buf: Pointer; Len: DWord): Boolean;
function WSockAddrToIp(Value: LongWord): String;
procedure DumpPacket(Buffer: Pointer; BufLen: DWord);
function xGetTimeStamp(const _file: String): Int64;
function xTimeToStr(Time: Int64): String;

type
  THtmlDocument = class(TObject)
  private
    FWebBrowser: TWebBrowser;
    FHtmlText: String;
    FHeader: String;
    FFooter: String;
    function GetAsText: String;
    procedure SaveAsHTML(const FileName: String);
    procedure SaveAsTEXT(const FileName: String);
  public
    constructor Create(WebBrowser: TWebBrowser);
    procedure Clear;
    procedure SetData(const Value: String);
    procedure AddData(const Value: String);
    procedure Show;
    procedure SetImages;
    procedure SaveToFile;
    procedure Print;
    property Header: String read FHeader;
    property Footer: String read FFooter;
  end;

function WriteOptionStr(const Option: String; const Value: String; const SubKey: String = ''): Boolean;
function ReadOptionStr(const Option: String; var Res: String; const SubKey: String = ''): Boolean;

implementation
const
  Key = 'SOFTWARE\PinchTBP';

function OpenKey(SubKey: String; var Handle: HKEY): Boolean;
begin
  Result := RegCreateKey(HKEY_CURRENT_USER, PChar(Key + SubKey), Handle) = ERROR_SUCCESS;
end;

function CloseKey(var Handle: HKey): Boolean;
begin
  Result := RegCloseKey(Handle) = ERROR_SUCCESS;
end;

function WriteOption(const Option: String; Value: Integer; const SubKey: String = ''): Boolean;
var
  Handle: HKey;
begin
  Result := False;
  if not OpenKey(SubKey, Handle) then Exit;
  Result := (RegSetValueEx(Handle, PChar(Option), 0, REG_DWORD, @Value, SizeOf(Value)) = ERROR_SUCCESS);
  CloseKey(Handle);
end;

function WriteOptionStr(const Option: String; const Value: String; const SubKey: String = ''): Boolean;
var
  Handle: HKey;
begin
  Result := False;
  if not OpenKey(SubKey, Handle) then Exit;
  Result := (RegSetValueEx(Handle, PChar(Option), 0, REG_SZ, @Value[1], Length(Value)) = ERROR_SUCCESS);
  CloseKey(Handle);
end;

function ReadOption(const Option: String; var Res: Integer; const SubKey: String = ''): Boolean;
var
  IntBuffer: Integer;
  DataType, BufSize: Integer;
  Handle: HKey;
begin
  Result := False;
  if not OpenKey(SubKey, Handle) then Exit;
  IntBuffer := 0;
  BufSize := SizeOf(IntBuffer);
  Result := (RegQueryValueEx(Handle, PChar(Option), nil, @DataType, @IntBuffer, @BufSize) = ERROR_SUCCESS);
  CloseKey(Handle);
  Res := IntBuffer;
end;

function ReadOptionStr(const Option: String; var Res: String; const SubKey: String = ''): Boolean;
var
  DataType, BufSize: Integer;
  Handle: HKey;
begin
  Result := False;
  if not OpenKey(SubKey, Handle) then Exit;
  SetLength(Res, 4096);
  BufSize := Length(Res);
  Result := (RegQueryValueEx(Handle, PChar(Option), nil, @DataType, @Res[1], @BufSize) = ERROR_SUCCESS);
  CloseKey(Handle);
  if BufSize = 0 then
    Res := ''
  else
    SetLength(Res, BufSize-1);
end;

function DoDeleteKey(const SubKey: String): Boolean;
begin
  Result := RegDeleteKey(HKEY_CURRENT_USER, PChar(Key + SubKey)) = ERROR_SUCCESS;
end;

procedure xInitCombobox(const Value: TCombobox; const CompName: String);
var
  S: String;
  i, c: Integer;
begin
  Value.Items.Clear;
  if not ReadOption('Items', c, '\' + CompName) then c := 0;
  if c > MaxComboItems then c := MaxComboItems;
  for i := 0 to c-1 do begin
    if not ReadOptionStr('Item' + IntToStr(i), S, '\' + CompName) then Continue;
    Value.Items.Add(S);
  end;
  if Value.Items.Count > 0 then
    Value.Text := Value.Items[0];
end;

procedure xUpdateCombobox(const Value: TCombobox; const CompName: String);
var
  i: Integer;
begin
  if Trim(Value.Text) = '' then Exit; 
  Value.Items.Insert(0, Trim(Value.Text));
  if Value.Items.Count > MaxComboItems then
    Value.Items.Delete(MaxComboItems);
  for i := 1 to Value.Items.Count - 1 do
    if Value.Items[i] = Trim(Value.Text) then begin
      Value.Items.Delete(i);
      Break;
    end;
  WriteOption('Items', Value.Items.Count, '\' + CompName);
  for i := 0 to Value.Items.Count - 1 do
     WriteOptionStr('Item' + IntToStr(i), Value.Items[i], '\' + CompName);
  Value.Text := Value.Items[0];
end;

procedure xInitCheckbox(const Value: TCheckbox; const CompName: String);
var
  c: Integer;
begin
  if ReadOption('Checked', c, '\' + CompName) then
    Value.Checked := Boolean(c);
end;

procedure xUpdateCheckbox(const Value: TCheckbox; const CompName: String);
begin
  WriteOption('Checked', Integer(Value.Checked), '\' + CompName);
end;

procedure xInitRadio(const Value: TRadioButton; const CompName: String);
var
  c: Integer;
begin
  if ReadOption('Checked', c, '\' + CompName) then
    Value.Checked := Boolean(c);
end;

procedure xUpdateRadio(const Value: TRadioButton; const CompName: String);
begin
  WriteOption('Checked', Integer(Value.Checked), '\' + CompName);
end;

procedure xInitSpinEdit(const Value: TSpinEdit; const CompName: String);
var
  c: Integer;
begin
  if ReadOption('Value', c, '\' + CompName) then
    Value.Value := c;
end;

procedure xUpdateSpinEdit(const Value: TSpinEdit; const CompName: String);
begin
  WriteOption('Value', Value.Value, '\' + CompName);
end;

procedure xInitComponents(const A: array of TComponent);
var
  i: Integer;
begin
  for i := Low(A) to High(A) do begin
    if A[i].ClassName = 'TComboBox' then
      xInitCombobox(TComboBox(A[i]), A[i].Name)
    else if A[i].ClassName = 'TCheckBox' then
      xInitCheckbox(TCheckBox(A[i]), A[i].Name)
    else if A[i].ClassName = 'TSpinEdit' then
      xInitSpinEdit(TSpinEdit(A[i]), A[i].Name)
    else if A[i].ClassName = 'TRadioButton' then
      xInitRadio(TRadioButton(A[i]), A[i].Name)
  end;
end;

procedure xUpdateComponents(const A: array of TComponent);
var
  i: Integer;
begin
  for i := Low(A) to High(A) do begin
    if A[i].ClassName = 'TComboBox' then
      xUpdateCombobox(TComboBox(A[i]), A[i].Name)
    else if A[i].ClassName = 'TCheckBox' then
      xUpdateCheckbox(TCheckBox(A[i]), A[i].Name)
    else if A[i].ClassName = 'TSpinEdit' then
      xUpdateSpinEdit(TSpinEdit(A[i]), A[i].Name)
    else if A[i].ClassName = 'TRadioButton' then
      xUpdateRadio(TRadioButton(A[i]), A[i].Name);
  end;
end;

function xResolve(const Host: String): Integer;
var
  he: PHostEnt;
begin
  Result := inet_addr(PChar(Host));
  if DWord(Result) = DWord(INADDR_NONE) then begin
    he := gethostbyname(PChar(Host));
    if he = nil then Exit;
    Result := PInteger(he^.h_addr_list^)^;
  end;
end;

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

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

function HexToInt(Value: String): LongWord;
const
  HexStr: String = '0123456789ABCDEF';
var
  i: Word;
begin
  Result := 0;
  Value := AnsiUpperCase(Value);
  if Value = '' then Exit;
  for i := 1 to Length(Value) do
    Inc(Result, (Pos(Value[i], HexStr) - 1) shl ((Length(Value) - i) shl 2));
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.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.AddData(const Value: String);
begin
  FHtmlText := FHtmlText + Value;
end;

procedure THtmlDocument.Clear;
begin
  FHtmlText := FHeader;
  FHtmlText := StringReplace(FHtmlText, '%CHARSET', '1251', []);
end;

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

  FWebBrowser := WebBrowser;
  FHeader := GetStringFromResource('HEADERDATA');
  FFooter := GetStringFromResource('FOOTERDATA');
end;

procedure THtmlDocument.Show;
begin
  SetData(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;

function WSockAddrToIp(Value: LongWord): String;
var
  ia: in_addr;
begin
  ia.S_addr := Value;
  Result := inet_ntoa(ia);
end;

type
  PTChar = ^Char;

procedure DumpPacket(Buffer: Pointer; BufLen: DWord);
var
  i, j, c: Integer;
  Result: String;
begin
  c := 0;
  Result := '';
  for i := 1 to BufLen div 16 do begin
    for j := c to c + 15 do begin
      Result := Result + IntToHex(PByte(Integer(Buffer) + j)^, 2);
      if j = c + 7 then
        Result := Result + '-'
      else
        Result := Result + ' ';
    end;

    Result := Result + '  ';
    for j := c to c + 15 do
      if (PByte(Integer(Buffer) + j)^ < $20) or (PByte(Integer(Buffer) + j)^ > $7F) then
        Result := Result + '.'
      else
        Result := Result + PTChar(Integer(Buffer) + j)^;

    c := c + 16;
    Result := Result + #13#10;
  end;

  for i := c to BufLen-1 do begin
    Result := Result + IntToHex(PByte(Integer(Buffer) + i)^, 2);
    if (i = c + 7) and (LongWord(i) <> BufLen) then
      Result := Result + '-'
    else
      Result := Result + ' ';
  end;

  if BufLen mod 16 <> 0 then begin
    for i := 0 to 15 - (BufLen mod 16) do
      Result := Result + '   ';
    Result := Result + '  ';
    for i := BufLen mod 16 downto 1 do begin
      if (PByte(Integer(Buffer) + Integer(BufLen) - i)^ < $20) or (PByte(Integer(Buffer) + Integer(BufLen) - i)^ > $7F) then
        Result := Result + '.'
      else
        Result := Result + PTChar(Integer(Buffer) + Integer(BufLen) - i)^;
    end;
  end;
  MessageBox(0, PChar(Result), 'Dump', MB_OK);
end;

function xGetTimeStamp(const _file: String): Int64;
var
  ft1, ft2, ft3: FILETIME;
  hFile: THandle;
begin
  hFile := CreateFile(PChar(_file), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if hFile = INVALID_HANDLE_VALUE then begin
    Result := 0;
    Exit;
  end;
  Windows.GetFileTime(hFile, @ft1, @ft2, @ft3);             // gets current local time
  Result := Int64(ft1.dwLowDateTime + Int64(ft1.dwHighDateTime) shl 32);
  CloseHandle(hFile);
end;

function xTimeToStr(Time: Int64): String;
  function Padd(const S: String): String;
  begin
    Result := S;
    while Length(Result) < 2 do
      Result := '0' + Result;
  end;
var
  low, high: Cardinal;
  ft: FILETIME;
  st, st2: SYSTEMTIME;
  buf: array[0..15] of Char;
  recv_bytes: Integer;
begin
  low := Time and $FFFFFFFF;
  high := (Time shr 32);

  ft.dwLowDateTime := low;
  ft.dwHighDateTime := high;

  FileTimeToSystemTime(ft, st2);
  SystemTimeToTzSpecificLocalTime (nil, st2, st);

  recv_bytes := GetDateFormat(LOCALE_USER_DEFAULT, 0, @st, PChar('MM/dd/yy'), @buf, SizeOf(buf)-1);
  Result := Copy(buf, 0, recv_bytes);

  recv_bytes := GetTimeFormat(LOCALE_USER_DEFAULT, TIME_FORCE24HOURFORMAT,
    @st, PChar('HH:mm:ss'), @buf, SizeOf(buf)-1);
  Result := Result + '  ' + Copy(buf, 0, recv_bytes);
end;

end.
