Project Structure

• SaxDemo1.dpr
• SaxForm.pas
• SaxForm.dfm

program SaxDemo1;

uses
  Forms,
  SaxForm in 'SaxForm.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit SaxForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, OleServer, MSXML2_TLB, ActiveX, ComObj;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    sax: IVBSAXXMLReader;
  public
    procedure ParseFile;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  Log: TStrings;

type
  TMySaxHandler = class (TInterfacedObject, IVBSAXContentHandler)
  protected
    stack: TStringList;
  public
    constructor Create;
    destructor Destroy; override;
    // IDispatch
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

    // IVBSAXContentHandler
    procedure Set_documentLocator(const Param1: IVBSAXLocator); virtual; safecall;
    procedure startDocument; virtual; safecall;
    procedure endDocument; virtual; safecall;
    procedure startPrefixMapping(var strPrefix: WideString; var strURI: WideString); virtual; safecall;
    procedure endPrefixMapping(var strPrefix: WideString); virtual; safecall;
    procedure startElement(var strNamespaceURI: WideString; var strLocalName: WideString;
                           var strQName: WideString; const oAttributes: IVBSAXAttributes); virtual; safecall;
    procedure endElement(var strNamespaceURI: WideString; var strLocalName: WideString;
                         var strQName: WideString); virtual; safecall;
    procedure characters(var strChars: WideString); virtual; safecall;
    procedure ignorableWhitespace(var strChars: WideString); virtual; safecall;
    procedure processingInstruction(var strTarget: WideString; var strData: WideString); virtual; safecall;
    procedure skippedEntity(var strName: WideString); virtual; safecall;
  end;

  TMySimpleSaxHandler = class (TMySaxHandler)
  public
    procedure startElement(var strNamespaceURI: WideString; var strLocalName: WideString;
                           var strQName: WideString; const oAttributes: IVBSAXAttributes); override; safecall;
    procedure characters(var strChars: WideString); override; safecall;
  end;

  TMyBooksListSaxHandler = class (TMySaxHandler)
  private
    isBook: Boolean;
  public
    procedure startElement(var strNamespaceURI: WideString; var strLocalName: WideString;
                           var strQName: WideString; const oAttributes: IVBSAXAttributes); override; safecall;
    procedure characters(var strChars: WideString); override; safecall;
  end;

  TMySaxErrorHandler = class (TInterfacedObject, IVBSAXErrorHandler)
  public
    // IDispatch
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

    // IVBSAXErrorHandler
    procedure error(const oLocator: IVBSAXLocator; var strErrorMessage: WideString;
                    nErrorCode: Integer); safecall;
    procedure fatalError(const oLocator: IVBSAXLocator; var strErrorMessage: WideString;
                         nErrorCode: Integer); safecall;
    procedure ignorableWarning(const oLocator: IVBSAXLocator; var strErrorMessage: WideString;
                               nErrorCode: Integer); safecall;
  end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Memo1.Clear;
  sax.ContentHandler := TMySaxHandler.Create;
  ParseFile;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Log := Memo1.Lines;
  // create sax and connect error handler
  sax := CreateComObject (CLASS_SAXXMLReader) as IVBSAXXMLReader;
  sax.ErrorHandler := TMySaxErrorHandler.Create;
end;

{ TMySaxHandler }

function RemoveWhites (str: WideString): WideString;
var
  i: integer;
begin
  for i := 1 to Length (str) do
    if Ord(str[i]) >= 32 then
      Result := Result + str [i];
  Result := Trim (Result);
end;

procedure TMySaxHandler.characters(var strChars: WideString);
begin
end;

constructor TMySaxHandler.Create;
begin
  stack := TStringList.Create;
end;

destructor TMySaxHandler.Destroy;
begin
  inherited;
  stack.Free;
end;

procedure TMySaxHandler.endDocument;
begin
  Log.Add ('--- endDocument ---');
end;

procedure TMySaxHandler.endElement(var strNamespaceURI, strLocalName,
  strQName: WideString);
begin
  stack.Delete (stack.Count - 1);
end;

procedure TMySaxHandler.endPrefixMapping(var strPrefix: WideString);
begin

end;

function TMySaxHandler.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TMySaxHandler.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

function TMySaxHandler.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := E_NOTIMPL;
end;

procedure TMySaxHandler.ignorableWhitespace(var strChars: WideString);
begin

end;

function TMySaxHandler.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

procedure TMySaxHandler.processingInstruction(var strTarget,
  strData: WideString);
begin

end;

procedure TMySaxHandler.Set_documentLocator(const Param1: IVBSAXLocator);
begin

end;

procedure TMySaxHandler.skippedEntity(var strName: WideString);
begin

end;

procedure TMySaxHandler.startDocument;
begin
  Log.Add ('--- startDocument ---');
end;

procedure TMySaxHandler.startElement(var strNamespaceURI, strLocalName,
  strQName: WideString; const oAttributes: IVBSAXAttributes);
begin
  stack.Add (strLocalName);
end;

procedure TMySaxHandler.startPrefixMapping(var strPrefix,
  strURI: WideString);
begin

end;

{ TMySaxErrorHandler }

procedure TMySaxErrorHandler.error(const oLocator: IVBSAXLocator;
  var strErrorMessage: WideString; nErrorCode: Integer);
begin
  Log.Add ('[Error] ' +
    IntToStr (oLocator.lineNumber) + '.' + IntToStr (oLocator.columnNumber) + ':' +
    strErrorMessage);
end;

procedure TMySaxErrorHandler.fatalError(const oLocator: IVBSAXLocator;
  var strErrorMessage: WideString; nErrorCode: Integer);
begin
  Log.Add ('[Fatal] ' +
    IntToStr (oLocator.lineNumber) + '.' + IntToStr (oLocator.columnNumber) + ':' +
    strErrorMessage);
end;

function TMySaxErrorHandler.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TMySaxErrorHandler.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

function TMySaxErrorHandler.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := E_NOTIMPL;
end;

procedure TMySaxErrorHandler.ignorableWarning(
  const oLocator: IVBSAXLocator; var strErrorMessage: WideString;
  nErrorCode: Integer);
begin
  Log.Add ('[Warning] ' +
    IntToStr (oLocator.lineNumber) + '.' + IntToStr (oLocator.columnNumber) + ':' +
    strErrorMessage);
end;

function TMySaxErrorHandler.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TMySimpleSaxHandler }

procedure TMySimpleSaxHandler.characters(var strChars: WideString);
var
  str: WideString;
begin
  inherited;

  str := RemoveWhites (strChars);
  if (str <> '') then
    Log.Add ('Text: ' + str);
end;

procedure TMySimpleSaxHandler.startElement(var strNamespaceURI,
  strLocalName, strQName: WideString; const oAttributes: IVBSAXAttributes);
begin
  inherited;
  Log.Add (strLocalName + '(' + stack.CommaText + ')');
end;

{ TMyBooksListSaxHandler }

procedure TMyBooksListSaxHandler.characters(var strChars: WideString);
var
  str: string;
begin
  inherited;
  if isbook then
  begin
    str := RemoveWhites (strChars);
    if (str <> '') then
      Log.Add (stack.CommaText + ': ' + str);
  end;
end;

procedure TMyBooksListSaxHandler.startElement(var strNamespaceURI,
  strLocalName, strQName: WideString; const oAttributes: IVBSAXAttributes);
begin
  inherited;
  isbook := (strLocalName = 'title');
end;

procedure TForm1.ParseFile;
var
  filename: string;
begin
  filename := ExtractFilePath (Application.Exename) + 'books.xml';
  if FileExists (filename) then
  begin
    sax.parseURL (filename)
  end
  else
    Log.Add ('file not found: ' + filename);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Memo1.Clear;
  sax.ContentHandler := TMySimpleSaxHandler.Create;
  ParseFile;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  Memo1.Clear;
  sax.ContentHandler := TMyBooksListSaxHandler.Create;
  ParseFile;
end;

end.

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 487
  Height = 480
  Caption = 'SaxDemo1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  DesignSize = (
    479
    453)
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 32
    Top = 32
    Width = 75
    Height = 25
    Caption = 'Parse Base'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Memo1: TMemo
    Left = 144
    Top = 32
    Width = 288
    Height = 385
    Anchors = [akLeft, akTop, akRight, akBottom]
    ScrollBars = ssVertical
    TabOrder = 1
  end
  object Button2: TButton
    Left = 32
    Top = 64
    Width = 75
    Height = 25
    Caption = 'Parse List'
    TabOrder = 2
    OnClick = Button2Click
  end
  object Button3: TButton
    Left = 32
    Top = 96
    Width = 75
    Height = 25
    Caption = 'Parse Titles'
    TabOrder = 3
    OnClick = Button3Click
  end
end