home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / EXCEL / EXCELS.PAS < prev    next >
Pascal/Delphi Source File  |  1997-11-19  |  14KB  |  491 lines
  1. {*****************************************************}
  2. {       TExcel Component 3.2 for Delphi 1.0 .. 3.0    }
  3. {                                                     }
  4. {       Copyright (c) 1996, 1997 Tibor F. Liska       }
  5. {       Tel/Fax:    +36-1-165-2019                    }
  6. {       Office:     +36-1-209-5284                    }
  7. {       E-mail: liska@sztaki.hu                       }
  8. {*****************************************************}
  9. {                                                     }
  10. {   TExcel is provided free of charge as so long as   }
  11. {   it is not in commercial use. When it produces     }
  12. {   income for you, please send me some portion of    }
  13. {   your income (at least $50).         Thank you.    }
  14. {                                                     }
  15. {*****************************************************}
  16. unit Excels;
  17.  
  18. interface
  19.  
  20. uses WinTypes, Forms, Classes, DdeMan, SysUtils;
  21.  
  22. type
  23.   TExcel = class(TComponent)
  24.   private
  25.       FMacro     : TFileName;
  26.       FMacroPath : TFileName;
  27.       FDDE       : TDdeClientConv;
  28.       FConnected : Boolean;
  29.       FExeName   : TFileName;
  30.       FDecimals  : Integer;
  31.       FOnClose   : TNotifyEvent;
  32.       FOnOpen    : TNotifyEvent;
  33.       FBatch     : Boolean;
  34.       FMin       : Integer;
  35.       FMax       : Integer;
  36.       FFirstRow  : Integer;
  37.       FFirstCol  : Integer;
  38.       FLastCol   : Integer;
  39.       FLines     : TStrings;    { using TStringList }
  40.       FCells     : TStrings;    { using TStringList }
  41.     procedure SetExeName(const Value: TFileName);
  42.     procedure SetConnect(const Value: Boolean);
  43.     procedure SetMin    (const Value: Integer);
  44.     procedure SetMax    (const Value: Integer);
  45.     function GetSelection: string;
  46.     function GetReady: Boolean;
  47.   protected
  48.     procedure DoRect(Top, Left, Bottom, Right: Integer;
  49.                      Data: TStrings; Request: Boolean);
  50.     procedure CheckConnection; virtual;
  51.     procedure LinkSystem;
  52.     procedure OpenLink(Sender: TObject);
  53.     procedure ShutDown(Sender: TObject);
  54.     procedure LocateExcel; virtual;
  55.   public
  56.     constructor Create(AOwner: TComponent); override;
  57.     destructor Destroy; override;
  58.     procedure Connect;
  59.     procedure Disconnect;
  60.     procedure Wait;
  61.     procedure ProcessMessages;
  62.     function Request(const Item: string): string;
  63.     procedure Exec  (const Cmd : string);
  64.     procedure Run   (const Mn  : string);
  65.     procedure Select(Row, Col: Integer);
  66.     procedure PutStr(Row, Col: Integer; const s: string);
  67.     procedure PutExt(Row, Col: Integer; e: Extended); virtual;
  68.     procedure PutInt(Row, Col: Integer; i: Longint);  virtual;
  69.     procedure PutDay(Row, Col: Integer; d: TDateTime);virtual;
  70.     procedure BatchStart(FirstRow, FirstCol: Integer);
  71.     procedure BatchCancel;
  72.     procedure BatchSend;
  73.     procedure GetRange(R: TRect; Lines: TStrings);
  74.     function GetCell(Row, Col: Integer): string;
  75.     procedure OpenMacroFile(const Fn: TFileName; Hide: Boolean);
  76.     procedure CloseMacroFile;
  77.     property DDE: TDdeCLientConv   read FDDE;
  78.     property Connected: Boolean    read FConnected write SetConnect;
  79.     property Ready    : Boolean    read GetReady;
  80.     property Selection: string     read GetSelection;
  81.     property Lines    : TStrings   read FLines;
  82.     property FirstRow : Integer    read FFirstRow;
  83.     property LastCol  : Integer    read FLastCol   write FLastCol;
  84.     property BatchOn  : Boolean    read FBatch;
  85.   published
  86.     property ExeName  : TFileName  read FExeName   write SetExeName;
  87.     property Decimals : Integer    read FDecimals  write FDecimals;
  88.     property BatchMin : Integer    read FMin       write SetMin;
  89.     property BatchMax : Integer    read FMax       write SetMax;
  90.     property OnClose: TNotifyEvent read FOnClose   write FOnClose;
  91.     property OnOpen : TNotifyEvent read FOnOpen    write FOnOpen;
  92.   end;
  93.  
  94. procedure Register;
  95.  
  96. {$I EXCELS.INC}       { Message strings to be nationalized }
  97.  
  98. implementation
  99. uses WinProcs, ShellAPI;
  100.  
  101. procedure Register;
  102. begin
  103.   RegisterComponents('Liska', [TExcel]);
  104. end;
  105.  
  106. { TExcel }
  107.  
  108. constructor TExcel.Create(AOwner: TComponent);
  109. begin
  110.   inherited Create(AOwner);
  111.   if not (csDesigning in ComponentState) then
  112.   begin
  113.     FDDE := TDdeClientConv.Create(nil);
  114.     FDDE.ConnectMode := ddeManual;
  115.     FDDE.OnOpen  := OpenLink;
  116.     FDDE.OnClose := ShutDown;
  117.   end;
  118.   SetExeName('Excel');
  119.   FDecimals := 2;
  120.   FBatch := False;
  121.   FMin := 200;
  122.   FMax := 250;
  123. end;
  124.  
  125. destructor TExcel.Destroy;
  126. begin
  127.   if not (csDesigning in ComponentState) then FDDE.Free;
  128.   if FLines <> nil then FLines.Free;
  129.   if FCells <> nil then FCells.Free;
  130.   inherited Destroy;
  131. end;
  132.  
  133. procedure TExcel.SetExeName(const Value: TFileName);
  134. begin
  135.   Disconnect;
  136.   FExeName := ChangeFileExt(Value, '');
  137.   if not (csDesigning in ComponentState) then
  138.     FDDE.ServiceApplication := FExeName;
  139. end;
  140.  
  141. procedure TExcel.SetConnect(const Value: Boolean);
  142. begin
  143.   if FConnected = Value then Exit;
  144.   if Value then Connect
  145.            else Disconnect;
  146. end;
  147.  
  148. procedure TExcel.SetMin(const Value: Integer);
  149. begin
  150.   if Value > FMax then FMin := FMax
  151.                   else FMin := Value;
  152. end;
  153.  
  154. procedure TExcel.SetMax(const Value: Integer);
  155. begin
  156.   if Value < FMin then FMax := FMin
  157.                   else FMax := Value;
  158. end;
  159.  
  160. function TExcel.GetSelection: string;
  161. begin
  162.   Result := Request('Selection');
  163. end;
  164.  
  165. function TExcel.GetReady: Boolean;
  166. begin
  167.   Result := 'Ready' = Request('Status');
  168. end;
  169.  
  170. procedure TExcel.DoRect(Top, Left, Bottom, Right: Integer;
  171.                         Data: TStrings; Request: Boolean);
  172.   var
  173.       i : Integer;
  174.       Sel, Item : string;
  175.       RowMark,
  176.       ColMark : Char;
  177.       Reply : PChar;
  178. begin
  179.   Wait;
  180.   Select(1, 1);                          
  181.   Sel := Selection;
  182.   i := Pos('!', Sel);
  183.   if i = 0 then raise Exception.Create(msgNoTable);
  184.   RowMark := Sel[i+1];                   { Some nationalized version }
  185.   ColMark := Sel[i+3];                   {  using other then R and C }
  186.   FDDE.OnOpen  := nil;
  187.   FDDE.OnClose := nil;                   { Disable event handlers }
  188. try
  189.   FDDE.SetLink('Excel', Copy(Sel, 1, i-1));  { Topic = Sheet name }
  190.   ProcessMessages;
  191.   if not FDDE.OpenLink then
  192.     raise Exception.Create(msgNoLink);
  193.   ProcessMessages;
  194.   Item := Format('%s%d%s%d:%s%d%s%d', [RowMark, Top, ColMark, Left,
  195.                                     RowMark, Bottom, ColMark, Right]);
  196.   if Request then
  197.   begin
  198.     Reply := FDDE.RequestData(Item);
  199.     if Reply <> nil then Data.SetText(Reply);
  200.     StrDispose(Reply);
  201.   end
  202.   else if not FDDE.PokeDataLines(Item, Data) then
  203.     raise Exception.Create('"'+ Item + msgNotAccepted);
  204. finally
  205.   ProcessMessages;
  206.   LinkSystem;
  207.   ProcessMessages;
  208.   FDDE.OpenLink;
  209.   FDDE.OnOpen  := OpenLink;              { Enable event handlers }
  210.   FDDE.OnClose := ShutDown;
  211.   if not Connected and Assigned(FOnClose) then FOnClose(Self);
  212. end; end;
  213.  
  214. procedure TExcel.LinkSystem;
  215. begin
  216.   FDDE.SetLink('Excel', 'System');
  217. end;
  218.  
  219. procedure TExcel.CheckConnection;
  220. begin
  221.   if not Connected then
  222.     raise Exception.Create(msgNoConnect);
  223. end;
  224.  
  225. procedure TExcel.OpenLink(Sender: TObject);
  226. begin
  227.   FConnected := True;
  228.   if Assigned(FOnOpen) then FOnOpen(Self);
  229. end;
  230.  
  231. procedure TExcel.ShutDown(Sender: TObject);
  232. begin
  233.   FConnected := False;
  234.   if Assigned(FOnClose) then FOnClose(Self);
  235. end;
  236.  
  237. procedure TExcel.LocateExcel;
  238.   const
  239.       BuffSize = 255;
  240.   var
  241.       Buff: array[0..BuffSize] of Char;
  242.       Fn  : string;
  243.       Len : Longint;
  244. begin
  245.   Len := BuffSize;
  246.   StrPCopy(Buff, '.XLS');
  247.   if (RegQueryValue(HKEY_CLASSES_ROOT, Buff, Buff, Len)
  248.     = ERROR_SUCCESS) and (StrScan(Buff,'E') <> nil) then
  249.   begin
  250.     StrCat(Buff, '\Shell\Open\Command');
  251.     Len := BuffSize;
  252.     if RegQueryValue(HKEY_CLASSES_ROOT, Buff, Buff, Len)
  253.       = ERROR_SUCCESS then
  254.     begin
  255.       Fn := StrPas(StrUpper(Buff));
  256.       Len := Pos('EXCEL.EXE', Fn);
  257.       Delete(Fn, Len + Length('EXCEL.EXE'), 255);
  258.       if Buff[0] = '"' then Delete(Fn, 1, 1);
  259.       if FileExists(Fn) then
  260.         ExeName := Fn;
  261.     end;
  262.   end;
  263. end;
  264.  
  265. procedure TExcel.Connect;
  266. begin
  267.   if FConnected then Exit;
  268.   LinkSystem;
  269.   if FDDE.OpenLink then Exit;
  270.   LocateExcel;
  271.   if FDDE.OpenLink then Exit;            { Try again }
  272.   ProcessMessages;
  273.   if FDDE.OpenLink then Exit;            { Once more }
  274.   raise Exception.Create(msgNoExcel);
  275. end;
  276.  
  277. procedure TExcel.Disconnect;
  278. begin
  279.   if FConnected then FDDE.CloseLink;
  280. end;
  281.  
  282. procedure TExcel.Wait;
  283.   const
  284.         TryCount = 64;
  285.   var
  286.       i : Integer;
  287. begin
  288.   i := 0;
  289.   repeat
  290.     if Ready then Break;    { Waiting for Excel }
  291.     Inc(i);
  292.   until i = TryCount;
  293.   if i = TryCount then
  294.     raise Exception.Create(msgNoRespond);
  295. end;
  296.  
  297. procedure TExcel.ProcessMessages;
  298. begin
  299. {$IFDEF WIN32}
  300.   Application.HandleMessage;
  301. {$ELSE}
  302.   Application.ProcessMessages;
  303. {$ENDIF}
  304. end;
  305.  
  306. function TExcel.Request(const Item: string): string;
  307.   var
  308.       Reply : PChar;
  309. begin
  310.   CheckConnection;
  311.   ProcessMessages;
  312.   Reply := FDDE.RequestData(Item);
  313.   if Reply = nil then Result := msgNoReply
  314.                  else Result := StrPas(Reply);
  315.   StrDispose(Reply);
  316. end;
  317.  
  318. procedure TExcel.Exec(const Cmd: string);
  319.   var
  320.       a : array[0..555] of Char;
  321. begin
  322.   CheckConnection;
  323.   StrPCopy(a, Cmd);
  324.   if FDDE.ExecuteMacro(a, False) then
  325.     ProcessMessages
  326.   else
  327.   begin
  328.     Wait;
  329.     if FDDE.ExecuteMacro(a, True ) then
  330.       ProcessMessages
  331.     else
  332.       raise Exception.Create('"' + Cmd + msgNotAccepted);
  333.   end
  334. end;
  335.  
  336. procedure TExcel.Run(const Mn: string);
  337. begin
  338.   if FMacro = '' then
  339.     raise Exception.Create(msgNoMacro);
  340.   Exec('[RUN("' + FMacro + '!' + Mn + '";FALSE)]');
  341. end;
  342.  
  343. procedure TExcel.Select(Row, Col: Integer);
  344. begin
  345.   Exec(Format('[SELECT("R%dC%d")]', [Row, Col]));
  346. end;
  347.  
  348. procedure TExcel.PutStr(Row, Col: Integer; const s: string);
  349.   procedure SendMin;
  350.     var
  351.         i : Integer;
  352.   begin
  353.     FCells.Clear;
  354.     for i:=0 to FMin-1 do
  355.     begin
  356.       FCells.Add(FLines[0]);          { FCells as work space }
  357.       FLines.Delete(0);
  358.     end;
  359.     DoRect(FFirstRow, FFirstCol, FFirstRow + FMin - 1, FLastCol,
  360.            FCells, False);
  361.     Inc(FFirstRow, FMin);
  362.   end;
  363.  
  364.   procedure DoBatch;
  365.     var
  366.         i, j, Index : Integer;
  367.         Line : string;
  368.   begin
  369.     Index := Row - FFirstRow;                { Index to modify }
  370.     if Index >= Lines.Count then
  371.       for i:=Lines.Count to Index do         { Expand if needed }
  372.         Lines.Add('');
  373.     if Lines.Count > FMax then               { Send if needed }
  374.     begin
  375.       SendMin;
  376.       Index := Row - FFirstRow;              { Recalc Index }
  377.     end;
  378.     if Col > FLastCol then FLastCol := Col;  { Adjust to max }
  379.     Line := Lines[Index];
  380.     FCells.Clear;                            { Empty FCells }
  381.     j := 1;
  382.     for i:=1 to Length(Line) do              { Line disasseble }
  383.       if Line[i] = #9 then begin
  384.                              FCells.Add(Copy(Line, j, i-j));
  385.                              j := i + 1;
  386.                            end;
  387.     FCells.Add(Copy(Line, j, Length(Line) + 1 - j));
  388.     if FCells.Count < Col - FFirstCol + 1 then
  389.       for i:=FCells.Count to Col-FFirstCol do{ Expand if needed }
  390.         FCells.Add('');
  391.     FCells[Col-FFirstCol] := s;              { Replace cell }
  392.     Line := FCells[0];
  393.     for i:=1 to FCells.Count-1 do            { Line reasseble }
  394.       Line := Line + #9 + FCells[i];
  395.     Lines[Index] := Line;                    { Replace line }
  396.   end;
  397.  
  398. begin           { TExcel.PutStr }
  399.   if BatchOn and (Col >= FFirstCol) and (Row >= FFirstRow) then
  400.     DoBatch
  401.   else
  402.     Exec(Format('[FORMULA("%s","R%dC%d")]', [s, Row, Col]));
  403. end;
  404.  
  405. procedure TExcel.PutExt(Row, Col: Integer; e: Extended);
  406. begin
  407.   PutStr(Row, Col, Format('%0.*f', [Decimals, e]));
  408. end;
  409.  
  410. procedure TExcel.PutInt(Row, Col: Integer; i: Longint);
  411. begin
  412.   PutStr(Row, Col, IntToStr(i));
  413. end;
  414.  
  415. procedure TExcel.PutDay(Row, Col: Integer; d: TDateTime);
  416. begin
  417.   PutStr(Row, Col, DateToStr(d));
  418. end;
  419.  
  420. procedure TExcel.BatchStart(FirstRow, FirstCol: Integer);
  421. begin
  422.   if FLines = nil then FLines := TStringList.Create
  423.                   else FLines.Clear;
  424.   if FCells = nil then FCells := TStringList.Create
  425.                   else FCells.Clear;
  426.   FFirstRow := FirstRow;
  427.   FFirstCol := FirstCol;
  428.   FLastCol  := FirstCol;
  429.   FBatch := True;
  430. end;
  431.  
  432. procedure TExcel.BatchCancel;
  433. begin
  434.   if FLines <> nil then FLines.Free;
  435.   if FCells <> nil then FCells.Free;
  436.   FLines := nil;
  437.   FCells := nil;
  438.   FBatch := False;
  439. end;
  440.  
  441. procedure TExcel.BatchSend;
  442. begin
  443.   if FLines <> nil then
  444.     DoRect(FFirstRow, FFirstCol, FFirstRow + FLines.Count - 1,
  445.            FLastCol, FLines, False);
  446.   BatchCancel
  447. end;
  448.  
  449. procedure TExcel.GetRange(R: TRect; Lines: TStrings);
  450. begin
  451.   DoRect(R.Top, R.Left, R.Bottom, R.Right, Lines, True);
  452. end;
  453.  
  454. function TExcel.GetCell(Row, Col: Integer): string;
  455.   var
  456.       Data : TStringList;
  457. begin
  458.   Result := msgNoReply;
  459.   Data := TStringList.Create;
  460. try
  461.   DoRect(Row, Col, Row, Col, Data, True);
  462.   if Data.Count = 1 then Result := Data[0];
  463. finally
  464.   Data.Free
  465. end; end;
  466.  
  467. procedure TExcel.OpenMacroFile(const Fn: TFileName; Hide: Boolean);
  468. begin
  469.   if FMacroPath = Fn then Exit;
  470.   CloseMacroFile;
  471.   Exec('[OPEN("' + Fn + '")]');
  472.   if Hide then  Exec('[HIDE()]');
  473.   FMacroPath := Fn;
  474.   FMacro := ExtractFileName(Fn);
  475. end;
  476.  
  477. procedure TExcel.CloseMacroFile;
  478. begin
  479.   if FMacro <> '' then
  480.   try
  481.     Exec('[UNHIDE("' + FMacro + '")]');
  482.     Exec('[ACTIVATE("' + FMacro + '")]');
  483.     Exec('[CLOSE(FALSE)]');
  484.   finally
  485.     FMacro := '';
  486.     FMacroPath := '';
  487.   end;
  488. end;
  489.  
  490. end.
  491.