unit XLExport;
(**************************************************************
  Takes a delimited text file (TAB-, SEMICOLON-, or
  PIPE-delimited) and exports it to Microsoft Excel.
  A new Worksheet is added for each block of 64K rows
  (Including the column headers)

  Data source can be a physical file or a memory stream.

  Usage:  ExcelExport(filename,delimiter);
  Usage:  ExcelStreamExport(datastream,delimiter);

  All cells are formatted as Text unless they are prepended
  with a tilde (~), in which case they use the "General" format.

  © 1999 Daniel J. Wojcik / Brute Force Programming
 **************************************************************)

interface

uses
  SysUtils,
  Classes,
  Windows,
  ComObj,
  ActiveX;

VAR
  RowList : TStringList;
  Filename,
  Delimiter : string;
  F : File;

procedure ExcelExport(Filename,Delimiter : string);
procedure ExcelStreamExport(VAR Datastream : TMemoryStream;Delimiter : string);

implementation

(**************************************************
  Open an instance of Excel and put the data into
  it.  All cells are formatted as Text.
 **************************************************)
procedure SendToExcel(Delim : string);
VAR
  XLApp,
  Sheet,
  ColumnRange : Variant;
  SheetIndex,
  ColIndex,
  EndRow,
  RowListIndex : integer;
  HeaderRow,
  TempHeaderRow,
  CurrentRow,
  Cell : string;

  procedure SetColumnWidth(Data : string;Col,SheetNo : integer);
    Begin
      ColumnRange := XLApp.Workbooks[1].WorkSheets['Sheet'+IntToStr(SheetNo)].Columns;
      ColumnRange.Columns[Col].ColumnWidth := Length(Data)+1;
    End;

  procedure PutCell(ACol,ARow : integer; Data : string; Title : boolean);
    Begin
      IF Title THEN
        Sheet.Cells[ARow,ACol].Font.Bold := True;
      IF Length(Data) > 0 THEN
        Begin
          IF Data[1] = '~' THEN
            Delete(Data,1,1)
          ELSE
            Sheet.Cells[ARow,ACol].NumberFormat := '@';
        End;
      Sheet.Cells[ARow,ACol].Value := Data;
      Sheet.Cells[ARow,ACol].Locked := False;
    End;

begin
  Coinitialize(nil);
  try
    XLApp:= CreateOleObject('Excel.Application');
    XLApp.Workbooks.Add(-4167);
    XLApp.Workbooks[1].WorkSheets[1].Name := 'Sheet1';
  except
    ON E : Exception DO
      Begin
        MessageBox(0,PChar(E.Message),'Excel Call Error',mb_OK);
        IF NOT VarIsEmpty(XLApp) THEN
          Begin
            XLApp.DisplayAlerts := False;
            XLApp.Quit;
          End;
        Exit;
      End;
  end;

  try
    HeaderRow := RowList[0];
    IF HeaderRow[Length(HeaderRow)] <> Delim THEN
      HeaderRow := HeaderRow+Delim;
    TempHeaderRow := HeaderRow;
  except
    MessageBox(0,'The file contained no data, or the Column headers were missing.','Error',mb_OK);
    IF NOT VarIsEmpty(XLApp) THEN
      Begin
        XLApp.DisplayAlerts := False;
        XLApp.Quit;
      End;
    Exit;
  end;

  SheetIndex := 1;

  ColIndex := 0;

  try
  Sheet := XLApp.Workbooks[1].WorkSheets['Sheet1'];
  except
    ON E : Exception DO
      Begin
        MessageBox(0,PChar(E.Message),'Excel Sheet Error',mb_OK);
        IF NOT VarIsEmpty(XLApp) THEN
          Begin
            XLApp.DisplayAlerts := False;
            XLApp.Quit;
          End;
        Exit;
      End;
  end;

//headers
  WHILE Length(TempHeaderRow) > 0 DO
    Begin
      Inc(ColIndex);
      Cell := Copy(TempHeaderRow,1,Pos(Delim,TempHeaderRow)-1);
      Delete(TempHeaderRow,1,Pos(Delim,TempHeaderRow));
      IF Length(Cell) > 0 THEN
        PutCell(ColIndex,1,Cell,True);
      SetColumnWidth(Cell,ColIndex,SheetIndex);
    End;

//rows
  EndRow := 0;
  RowListIndex := 1;
  WHILE RowListIndex <= RowList.Count-1 DO
    Begin
      ColIndex := 0;
      CurrentRow := RowList[RowListIndex];
      IF CurrentRow[Length(CurrentRow)] <> Delim THEN
        CurrentRow := CurrentRow+Delim;
      WHILE Length(CurrentRow) > 0 DO
        Begin
          Inc(ColIndex);
          Cell := Copy(CurrentRow,1,Pos(Delim,CurrentRow)-1);
          Delete(CurrentRow,1,Pos(Delim,CurrentRow));
          IF Length(Cell) > 0 THEN
            PutCell(ColIndex,(RowListIndex-EndRow)+1,Cell,False);
        End;
      IF (((RowListIndex) MOD 65535) = 0) AND
         (RowListIndex <> RowList.Count-1) THEN  //need a new worksheet
        Begin
          //headers again on the new sheet
          EndRow := RowListIndex;
          Inc(SheetIndex);
          try
            XLApp.Workbooks[1].Sheets.Add(,XLApp.Sheets.Item[SheetIndex-1],1,-4167);
            Sheet := XLApp.Workbooks[1].WorkSheets['Sheet'+IntToStr(SheetIndex)];
          except
            ON E : Exception DO
              Begin
                MessageBox(0,PChar(E.Message),'Add Worksheet Error',mb_OK);
                IF NOT VarIsEmpty(XLApp) THEN
                  Begin
                    XLApp.DisplayAlerts := False;
                    XLApp.Quit;
                  End;
                Exit;
              End;
          end;

          TempHeaderRow := HeaderRow;
          ColIndex := 0;
          WHILE Length(TempHeaderRow) > 0 DO
            Begin
              Inc(ColIndex);
              Cell := Copy(TempHeaderRow,1,Pos(Delim,TempHeaderRow)-1);
              Delete(TempHeaderRow,1,Pos(Delim,TempHeaderRow));
              IF Length(Cell) > 0 THEN
                PutCell(ColIndex,1,Cell,True);
              SetColumnWidth(Cell,ColIndex,SheetIndex);
            End;
        End;
      Inc(RowListIndex);
    End;

  XLApp.Workbooks[1].Worksheets[1].Activate;//set it back to the first sheet
  XLApp.Visible := True;
end;

(**************************************************
  Load the data from an ascii disk file.
  Each row must have a CRLF at the end.
 **************************************************)
procedure ExcelExport(Filename,Delimiter : string);
begin
  IF (Filename = '') AND (Delimiter = '') THEN
    Begin
      MessageBox(0,PChar('Not enough parameters. '#13#10#13#10+
                         'Usage: ExcelExport(filename,delimiter)'#13#10#13#10+
                         'Filename is the Path and Filename of the delimited datafile.'+
                         ' (Use quotes around this parameter, if it contains spaces.)'#13#10#13#10+
                         'Delimiter is optional, and can be the words PIPE or SEMICOLON.  TAB is the default, '+
                         'if no (or an unknown) delimiter is specifed.'),'Error',mb_OK);
      Exit;
    End;
  IF CompareText(Delimiter,'pipe') = 0 THEN
    Delimiter := '|'
  ELSE
  IF CompareText(Delimiter,'semicolon') = 0 THEN
    Delimiter := ';'
  ELSE
    Delimiter := #9;
  RowList := TStringList.Create;
  try
  RowList.LoadFromFile(Filename);
  AssignFile(F,Filename);
  Erase(F);
  except
    ON E : Exception DO
      Begin
        MessageBox(0,PChar(E.Message),'Load Datafile Error',mb_OK);
        RowList.Free;
        Exit;
      End;
  end;
  SendToExcel(Delimiter);
  RowList.Free;
end;

(**************************************************
  Load the data from a memory stream.
  Each row must have a CRLF at the end.
 **************************************************)
procedure ExcelStreamExport(VAR Datastream : TMemoryStream;Delimiter : string);
begin
  IF DataStream.Size = 0  THEN
    Begin
      MessageBox(0,PChar('No data.'),'Error',mb_OK);
      Exit;
    End;
  IF CompareText(Delimiter,'pipe') = 0 THEN
    Delimiter := '|'
  ELSE
  IF CompareText(Delimiter,'semicolon') = 0 THEN
    Delimiter := ';'
  ELSE
    Delimiter := #9;
  RowList := TStringList.Create;
  try
  DataStream.Position := 0;
  RowList.LoadFromStream(DataStream);
  except
    ON E : Exception DO
      Begin
        MessageBox(0,PChar(E.Message),'Load Datafile Error',mb_OK);
        RowList.Free;
        Exit;
      End;
  end;
  SendToExcel(Delimiter);
  RowList.Free;
end;

end.