Turbo Toolbox/Turbo_Toolbox.iso/turbo4/mcutil.pas

Pascal/Delphi Source File | 1987-12-08 | 10.3 KB | 371 lines

{           Copyright (c) 1985, 87 by Borland International, Inc.            }

unit MCUTIL;

interface

uses Crt, Dos, MCVars;

function Pad(S : String; Len : Word) : String;
{ Bringt einen String durch Anhängen von Leerzeichen auf die angegebene Länge }
function Spaces(Num : Word) : String;
{ Liefert einen String mit der angegebenen Anzahl von Leerzeichen zurück }
function UpperCase(S : String) : String;
{ Übersetzt in Großbuchstaben }

function WordToString(Num, Len : Word) : String;
{ Konvertiert einen Wert des Typs Word in einen String }
function RealToString(Num : Real; Len, Places : Word) : String;
{ Konvertiert eine Realzahl in einen String }

function AllocText(Col, Row : Word; S : String) : Boolean;
{ Belegt Speicherplatz für eine Zelle mit Text }
function AllocValue(Col, Row : Word; Amt : Real) : Boolean;
{ Belegt Speicherplatz für eine Zelle mit einem Wert }
function AllocFormula(Col, Row : Word; S : String; Amt : Real) : Boolean;
{ Belegt Speicherplatz für eine Zelle mit einer Formel }

function RowWidth(Row : Word) : Word;
{ Liefert die Breite (Zeichenzahl) einer Reihe }

function FormulaStart(Input : String; Place : Word;
                      var Col, Row, FormLen : Word) : Boolean;
{ Liefert TRUE, wenn der Beginn des Strings als Formel interpretiert
  werden kann, ansonsten FALSE. Für Formeln werden zusätzlich Spalte,
  Zeile und Länge des Textes zurückgeliefert }

function ColString(Col : Word) : String;
{ Konvertiert eine Spaltennummer in einen String }
function CenterColString(Col : Word) : String;
{ Konvertiert eine Spaltennummer in einen mittenzentrierten String }

function TextString(InString : String; Col, FValue : Word;
                    Formatting : Boolean) : String;
{ Bestimmt die Darstellung von Strings als Text }
function ValueString(CPtr : CellPtr; Value : Real; Col, FValue : Word;
                     var Color : Word; Formatting : Boolean) : String;
{ Bestimmt die Darstellung von Werten als Text }
function CellString(Col, Row : Word; var Color : Word;
                    Formatting : Boolean) : String;
{ Erzeugt den String zur Darstellung der Daten, die in der durch col und
  row angegebenen Zelle gespeichert sind; liefert außerdem die Farbe
  dieser Zelle zurück }

procedure Switch(var Val1, Val2 : Word);
{ Vvertauscht die beiden übergebenen Werte miteinander }

procedure InitVars;
{ Initialisiert diverse globale Variablen }

function Exists(FileName : String) : Boolean;
{ Liefert TRUE, wenn FileName existiert bzw. gefunden werden kann }

implementation

{$F+}
function HeapFunc(Size : Word) : Word;  { Behandlung von Fehlern bei }
begin                                   { der dynamischen Speicherverwaltung }
  HeapFunc := 1;       { New und GetMem liefern im Fehlerfall nil zurück }
end;
{$F-}

function Pad;
begin
  if Length(S) < Len then
    FillChar(S[Succ(Length(S))], Len - Length(S), ' ');
  S[0] := Chr(Len);
  Pad := S;
end;

function Spaces;
var  S: String;
begin
  S[0] := Chr(Num);
  FillChar(S[1], Num, ' ');
  Spaces := S;
end;

function UpperCase;
var Counter: Word;
begin
  for Counter := 1 to Length(S) do
    S[Counter] := UpCase(S[Counter]);
  UpperCase := S;
end;

function WordToString;
var S: String[5];
begin
  Str(Num:Len, S);
  WordToString := S;
end;

function RealToString;
var S: String[80];
begin
  Str(Num:Len:Places, S);
  RealToString := S;
end;

function AllocText;
var CPtr: CellPtr;
begin
  AllocText := False;  { Annahme: Belegung nicht möglich }
  GetMem(CPtr, Length(S) + 3);  { Versuch der Belegung, liefert via HeapFunc }
  if CPtr = nil then Exit;   { den Wert nil zurück -> Exit mit FALSE }
  CPtr^.Attrib := TXT;
  CPtr^.Error := False;
  CPtr^.T := S;           { ansonsten Initialisierung }
  Cell[Col, Row] := CPtr; { Eintrag ins Zell-Array }
  AllocText := True;      { Platz für die Zelle ist belegt }
end;

function AllocValue;
var CPtr : CellPtr;
begin
  AllocValue := False;
  GetMem(CPtr, SizeOf(Real) + 2);  { derselbe Mechanismus wie bei AllocText }
  if CPtr = nil then Exit;
  CPtr^.Attrib := VALUE; CPtr^.Error := False;
  CPtr^.Value := Amt;  Cell[Col, Row] := CPtr;
  AllocValue := True;
end;

function AllocFormula;
var CPtr : CellPtr;
begin
  AllocFormula := False;
  GetMem(CPtr, Length(S) + SizeOf(Real) + 3);  { derselbe Mechanismus ... }
  if CPtr = nil then Exit;
  CPtr^.Attrib := FORMULA;  CPtr^.Error := False;
  CPtr^.Formula := S;  CPtr^.FValue := Amt;
  Cell[Col, Row] := CPtr;
  AllocFormula := True;
end;

function RowWidth;
begin
  RowWidth := Succ(Trunc(Ln(Row) / Ln(10)));
end;

function FormulaStart;
var
  OldPlace, Len, MaxLen : Word;
  Start : IString;
  NumString : String[10];
begin
  FormulaStart := False;
  OldPlace := Place;
  MaxLen := RowWidth(MAXROWS);
  if not (Input[Place] in LETTERS) then Exit;  { Keine Zelladresse -> Exit }
  Col := Succ(Ord(Input[Place]) - Ord('A'));
  Inc(Place);
  if Input[Place] in LETTERS then
  begin
    Col := Col * 26;
    Col := Succ(Col + Ord(Input[Place]) - Ord('A'));
    Inc(Place);
  end;
  if Col > MAXCOLS then Exit;   { keine gültige Spalte }
  Start := Copy(Input, Place, MaxLen);
  Len := 0;
  while (Place <= Length(Input)) and
        (Input[Place] in ['0'..'9']) and (Len < MaxLen) do
  begin
    Inc(Len);
    Inc(Place);
  end;
  if Len = 0 then Exit;
  NumString := Copy(Start, 1, Len);
  Val(NumString, Row, Len);
  if Row > MAXROWS then Exit;   { keine gültige Zeile }
  FormLen := Place - OldPlace;
  FormulaStart := True;
end;

function ColString;
begin
  if Col <= 26 then ColString := Chr(Pred(Col) + Ord('A'))
  else ColString := Chr((Pred(Col) div 26) + Pred(Ord('A'))) +
               Chr((Pred(Col) mod 26) + Ord('A'));
end;

function CenterColString;
var
  S : String[2];
  Spaces1, Spaces2 : Word;
begin
  S := ColString(Col);
  Spaces1 := (ColWidth[Col] - Length(S)) shr 1;
  Spaces2 := ColWidth[Col] - Length(S) - Spaces1;
  CenterColString := Spaces(Spaces1) + S + Spaces(Spaces2);
end;

function TextString;
var
  OutString : String[80];
begin
  if ((FValue and RJUSTIFY) <> 0) and Formatting then
  begin
    OutString := InString;
    if Length(OutString) < ColWidth[Col] then
    begin
      while Length(OutString) < ColWidth[Col] do
        OutString := ' ' + OutString;
    end
    else OutString[0] := Chr(ColWidth[Col]);
  end
  else begin
    if Formatting then OutString := Pad(InString, ColWidth[Col])
    else OutString := InString;
  end;
  TextString := OutString;
end;

function ValueString;
var
  VString : String[MAXCOLWIDTH];
  FString : String[3];
  Width, P : Word;
begin
  if Formatting then
  begin
    Str(CPtr^.Value:1:(FValue and 15), VString);
    if (FValue and COMMAS) <> 0 then
    begin
      P := Pos('.', VString);
      if P = 0 then P := Succ(Length(VString));
      while P > 4 do
      begin
        P := P - 3;
        if VString[Pred(P)] <> '-' then Insert(',', VString, P);
      end;
    end;
    if (FValue and DOLLAR) <> 0 then
    begin
      if VString[1] = '-' then
      begin
        FString := ' $';
        Width := ColWidth[Col] - 2;
      end
      else begin
        FString := ' $ ';
        Width := ColWidth[Col] - 3;
      end;
    end
    else begin
      Width := ColWidth[Col];
      FString := '';
    end;
    if (FValue and RJUSTIFY) <> 0 then
    begin
      if Length(VString) > Width then Delete(VString, Succ(Width),
                                             Length(VString) - Width)
      else while Length(VString) < Width do
              VString := ' ' + VString;
    end
    else VString := Pad(VString, Width);
    VString := FString + VString;
  end
  else Str(Value:1:MAXPLACES, VString);
  Color := VALUECOLOR;
  ValueString := VString;
end;

function CellString;
var
  CPtr : CellPtr;
  OldCol, P, NewCol, FormatValue : Word;
  S : String[80];
  V : Real;
begin
  CPtr := Cell[Col, Row];
  if CPtr = nil then
  begin
    if (not Formatting) or (Format[Col, Row] < OVERWRITE) then
    begin
      S := Spaces(ColWidth[Col]);
      Color := BLANKCOLOR;
    end
    else begin
      NewCol := Col;
      Dec(NewCol);
      while Cell[NewCol, Row] = nil do
        Dec(NewCol);
      OldCol := NewCol;
      P := 1;
      while (NewCol < Col) do
      begin
        Inc(P, ColWidth[NewCol]);
        Inc(NewCol);
      end;
      S := Copy(Cell[OldCol, Row]^.T, P, ColWidth[Col]);
      S := S + Spaces(ColWidth[Col] - Length(S));
      Color := TXTCOLOR;
    end;
  end
  else begin
    FormatValue := Format[Col, Row];
    if CPtr^.Error and (Formatting or (CPtr^.Attrib = VALUE)) then
    begin
      S := Pad(MSGERRORTXT, ColWidth[Col]);
      Color := ERRORCOLOR;
    end
    else case CPtr^.Attrib of
          TXT : begin
                   S := TextString(CPtr^.T, Col, FormatValue, Formatting);
                   Color := TXTCOLOR;
                 end;
      FORMULA : begin
                 if FormDisplay then
                 begin
                    S := TextString(CPtr^.Formula, Col, FormatValue,
                                     Formatting);
                    Color := FORMULACOLOR;
                  end
                else begin
                  V := CPtr^.FValue;
                  S := ValueString(CPtr, V, Col, FormatValue,
                                    Color, Formatting);
                   end;
                  end;
      VALUE : begin
                V := CPtr^.Value;
                S := ValueString(CPtr, V, Col, FormatValue,
                                 Color, Formatting);
              end;
      end; { case }
  end;
  CellString := S;
end;

procedure Switch;
var Temp : Word;
begin
  Temp := Val1; Val1 := Val2; Val2 := Temp;
end;

procedure InitVars;
begin
  LeftCol := 1; TopRow := 1; CurCol := 1; Currow := 1;
  LastCol := 1; LastRow := 1;
  AutoCalc := True;
  FormDisplay := False;
  FillChar(ColWidth, SizeOf(ColWidth), DEFAULTWIDTH);
  FillChar(Cell, SizeOf(Cell), 0);
  FillChar(Format, SizeOf(Format), DEFAULTFORMAT);
end;

function Exists;
var SR: SearchRec;
begin
  FindFirst(FileName, ReadOnly + Hidden + SysFile, SR);
  Exists := (DosError = 0) and (Pos('?', FileName) = 0) and
            (Pos('*', FileName) = 0);
end;

begin
  HeapError := @HeapFunc;  { Installation der "Fehlerbehandlung" }
end.