sttxtdat.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

  FS := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyNone);

  try
    SaveToStream(FS);
  finally
    FS.Free;
  end;
end;


{
General format of a Schema file, based on BDE ASCII driver schema files:

; this is a comment
[NAME]
Filetype=<VARYING>|<FIXED>
Separator=char (default = ',' comma)
Delimiter=char (default = '"' double quote)
FieldN=<FieldName>,<FieldType>,<FieldWidth>,<FieldDecimals>,<FieldOffset>
; example fields:
Field1=Name,CHAR,20,00,00
Field2=Rating,CHAR,2,00,20
Field3=Date,DATE,10,00,22
Field4=Weight,Float,7,2,32
}

{!!.01 -- Rewritten}
procedure TStTextDataSchema.SaveToStream(AStream: TStream);
var
  TS : TStAnsiTextStream;
  i : Integer;
  SL : TStringList;
begin
  SL := nil;
  TS := nil;

  try
    SL := TStringList.Create;
    BuildSchema(SL);

    TS := TStAnsiTextStream.Create(AStream);
    for i := 0 to Pred(SL.Count) do
      TS.WriteLine(SL[i]);

  finally
    TS.Free;
    SL.Free;
  end;
end;
{!!.01 -- End Rewritten}

procedure TStTextDataSchema.SetCommentDelimiter(const Value: AnsiChar);
begin
  FCommentDelimiter := Value;
end;

procedure TStTextDataSchema.SetFieldByName(const FieldName: AnsiString;
  const Value: TStDataField);
begin
  dsFieldList.FieldByName[FieldName] := Value;
end;

procedure TStTextDataSchema.SetFieldDelimiter(const Value: AnsiChar);
begin
  FFieldDelimiter := Value;
end;

procedure TStTextDataSchema.SetField(Index: Integer;
  const Value: TStDataField);
begin
  dsFieldList.Fields[Index] := Value;
end;

{!!.01 -- Added }
procedure TStTextDataSchema.SetFixedSeparator(const Value: AnsiChar);
begin
  FFixedSeparator := Value;
end;
{!!.01 -- End Added }

procedure TStTextDataSchema.SetLayoutType(const Value: TStSchemaLayoutType);
begin
  FLayoutType := Value;
end;

procedure TStTextDataSchema.SetQuoteDelimiter(const Value: AnsiChar);
begin
  FQuoteDelimiter := Value;
end;

procedure TStTextDataSchema.SetSchema(const Value: TStrings);
begin
  FSchema.Assign(Value);                                                 {!!.01}
  Update(FSchema);                                                       {!!.01}
end;

procedure TStTextDataSchema.SetSchemaName(const Value: AnsiString);
begin
  FSchemaName := Value;
end;

{!!.01 -- Added }
procedure TStTextDataSchema.Update(AList : TStrings);
var
  ValStr : AnsiString;
  Idx : Integer;
begin
  for Idx := 0 to Pred(AList.Count) do begin
    ValStr := AList[Idx];

    { if line isn't blank }
    if ValStr <> '' then begin

      { assume it's the schema name }
      if (ValStr[1] = '[') and (ValStr[Length(ValStr)] = ']') then
        SchemaName := Copy(ValStr, 2, Length(ValStr) - 2)
      else
        { assume the line is a comment }
      if ValStr[1] = FCommentDelimiter {';'} then
        { ignore it };
      { else, it's blank, so skip it }
    end;

  end;

  { extract other Schema Info }
  { get layout type }
  ValStr := AList.Values['Filetype'];
  if UpperCase(ValStr) = 'VARYING' then
    FLayoutType := ltVarying
  else
  if UpperCase(ValStr) = 'FIXED' then
    FLayoutType := ltFixed
  else
    FLayoutType := ltUnknown;

  { get field separator for schema }
  ValStr := AList.Values['Separator'];
  if Length(ValStr) > 0 then
    FFieldDelimiter := StDeEscape(ValStr)
  else
  case FLayoutType of                                                 {!!.01}
    ltFixed :   FFieldDelimiter := StDefaultFixedSep;                 {!!.01}
    ltVarying:  FFieldDelimiter := StDefaultDelim;                    {!!.01}
  end;                                                                {!!.01}

  { get quote delimiter for schema }
  ValStr := AList.Values['Delimiter'];
  if Length(ValStr) > 0 then
    FQuoteDelimiter := StDeEscape(ValStr)
  else
    FQuoteDelimiter := StDefaultQuote;

  { get quote delimiter for schema }
  ValStr := AList.Values['Comment'];
  if Length(ValStr) > 0 then
    FCommentDelimiter := StDeEscape(ValStr)
  else
    FCommentDelimiter := StDefaultQuote;

  { build fields list }
  Idx := 1;
  dsFieldList.Clear;
  ValStr := AList.Values['Field' + IntToStr(Idx)];
  while ValStr <> '' do begin
    dsFieldList.AddFieldStr(ValStr);
    Inc(Idx);
    ValStr := AList.Values['Field' + IntToStr(Idx)];
  end;
end;
{!!.01 -- End Added }


{ TStTextDataRecord }

constructor TStTextDataRecord.Create;
begin
  inherited Create;

  { set default values }
  FValue := '';
  FQuoteAlways := False;
  FQuoteIfSpaces := False;

  { create internal instances }
  FFieldList := TStringList.Create;
end;

destructor TStTextDataRecord.Destroy;
begin
  { free internal instances }
  FFieldList.Free;

  inherited Destroy;
end;

procedure TStTextDataRecord.BuildRecord(Values : TStrings; var NewRecord : AnsiString);
{ re-construct record structure from list of field values }
var
  i : Integer;
  Temp : AnsiString;
begin
  NewRecord := '';

  for i := 0 to Pred(Values.Count) do begin
    Temp := Values[i];

    { re-quote value if needed }
    DoQuote(Temp);

    { add value onto record }
    if i = 0 then
      NewRecord := Temp
    else
      NewRecord := NewRecord + FSchema.FieldDelimiter + Temp;
  end;
end;

procedure TStTextDataRecord.DoQuote(var Value : AnsiString);
{ quote field string if needed or desired }
var
  QuoteIt : Boolean;
begin
  { fire event if available }
  if Assigned(FOnQuoteField) then begin
    FOnQuoteField(self, Value);
  end
  else begin { use default quoting policy }
    QuoteIt := False;
    if FQuoteAlways then
      QuoteIt := True
    else
    if ((Pos(' ', Value) > 0) and FQuoteIfSpaces)
      or (Pos(FSchema.FieldDelimiter, Value) > 0)
    then
      QuoteIt := True;

    if QuoteIt then
      Value := FSchema.QuoteDelimiter + Value + FSchema.QuoteDelimiter;
  end;
end;

function ConvertValue(Value : TVarRec) : AnsiString;
{ convert variant record to equivalent string }
const
  BoolChars: array[Boolean] of Char = ('F', 'T');
begin
  case Value.VType of
    vtAnsiString: Result := string(Value.VAnsiString);
    vtBoolean:    Result := BoolChars[Value.VBoolean];
    vtChar:       Result := Value.VChar;
    vtCurrency:   Result := CurrToStr(Value.VCurrency^);
    vtExtended:   Result := FloatToStr(Value.VExtended^);
    vtInteger:    Result := IntToStr(Value.VInteger);
    vtPChar:      Result := Value.VPChar;
    vtString:     Result := Value.VString^;
    {$IFDEF VERSION4}
    vtInt64:      Result := IntToStr(Value.VInt64^);
    {$ENDIF VERSION4}
    else
      raise EStException.CreateResTP(stscTxtDatUnhandledVariant, 0);
  end;
end;

procedure TStTextDataRecord.FillRecordFromArray(Values : array of const);
{ supply field values from a variant open array }
var
  i, j : Integer;
begin
  {$IFDEF Version4}
  if Length(Values) > 0 then begin
  {$ENDIF}
    i := 0;
    j := Low(Values);
    while (j <= High(Values)) and (i < Schema.FieldCount) do begin
      SetField(i, ConvertValue(Values[j]));
      Inc(i);
      Inc(j);
    end;
  {$IFDEF Version4}
  end;
  {$ENDIF}
end;

procedure TStTextDataRecord.FillRecordFromList(Items : TStrings);
{ supply field values from <name>=<value> pairs }
{
  Fields filled from pairs provided in TStrings
  <NAME> entries in Items that don't match Field Names are ignored
  Fields with Names having no corresponding entry in Items are left empty
}
var
  i : Integer;
  FN : AnsiString;
begin
  if Assigned(Items) then begin
    for i := 0 to Pred(Schema.FieldCount) do begin
      FN := Schema.Fields[i].FieldName;
      FieldByName[FN] := Items.Values[FN];
    end;
  end;
end;

procedure TStTextDataRecord.FillRecordFromValues(Values : TStrings);
{ supply field values from a list of values }
{
  Fields filled from Values provided in TStrings
  if more Values than Fields, extras are ignored
  if fewer Values than Fields, remaining Fields are left empty
}
var
  i : Integer;
begin
  if Assigned(Values) then begin
    i := 0;
    while (i < Values.Count) and (i < Schema.FieldCount) do begin
      SetField(i, Values[i]);
      Inc(i);
    end;
  end;
end;


function TStTextDataRecord.GetFieldByName(const FieldName: AnsiString): AnsiString;
{ retrieve value of field in current record with given name }
var
  Idx : Integer;
begin
  Result := '';
  Idx := FSchema.IndexOf(FieldName);
  if Idx > -1 then
    Result := GetField(Idx)
  else
    raise EStException.CreateResTP(stscTxtDatNoSuchField, 0);
end;

function TStTextDataRecord.GetField(Index: Integer): AnsiString;
{ retrieve value of field in current record at given index }
var
  Len, Offset: Integer;
  DataField : TStDataField;
  Fields : TStringList;
begin
  if (Index < -1) or (Index > Pred(FSchema.FieldCount)) then
    raise EStException.CreateResTP(stscBadIndex, 0);

  { get characteristics of the field of interest }
  DataField := FSchema.Fields[Index];
  Len := DataField.FieldLen;
  { Decimals := DataField.FieldDecimals; }
  Offset := DataField.FFieldOffset;


  { extract field data from record }
  case FSchema.LayoutType of
    ltFixed   : begin
      { note: Offset is zero based, strings are 1 based }              {!!.01}
      Result := Copy(FValue, Offset + 1, Len);                         {!!.01}
    end;

    ltVarying : begin
      Fields := TStringList.Create;
      try
        ExtractTokensL(FValue, FSchema.FieldDelimiter, FSchema.QuoteDelimiter,
          True, Fields);
        Result := Fields[Index];
      finally
        Fields.Free;
      end;
    end;

    ltUnknown : begin
      raise EStException.CreateResTP(stscTxtDatInvalidSchema, 0);
    end;
  end; {case}
end;

function TStTextDataRecord.GetFieldCount: Integer;
begin
  GetFieldList;                                                        {!!.02}
  Result := FFieldList.Count;
end;

function TStTextDataRecord.GetFieldList: TStrings;
{ convert fields of current record into TStrings collection
  of <name>=<value> pairs }
var
  i : Integer;
  FN : AnsiString;
begin
  FFieldList.Clear;

  for i := 0 to Pred(FSchema.FieldCount) do begin
    FN := FSchema.Fields[i].FieldName;
    FFieldList.Add(FN + '=' + FieldByName[FN]);
  end;

  Result := FFieldList;
end;

function TStTextDataRecord.GetValues: TStrings;
var
  i : Integer;
  FN : AnsiString;
begin
  FFieldList.Clear;

  for i := 0 to Pred(FSchema.FieldCount) do begin
    FN := FSchema.Fields[i].FieldName;
    FFieldList.Add(FieldByName[FN]);
  end;

  Result := FFieldList;
end;

procedure TStTextDataRecord.MakeEmpty;
{ create an empty record according to schema layout }
var
  i, Width, FieldPos : Integer;
begin
  case FSchema.LayoutType of
    { string of spaces, length equal to total record width }
    ltFixed: begin
      Width := 0;
      for i := 0 to Pred(FSchema.FieldCount) do begin                 {!!.01}
        FieldPos := FSchema.Fields[i].FieldLen +                      {!!.01}
                    FSchema.Fields[i].FieldOffset + 1;                {!!.01}
        if Width < FieldPos then                                      {!!.01}
           Width := FieldPos;                                         {!!.01}
      end;                                                            {!!.01}
      FValue := StringOfChar(FSchema.FixedSeparator, Width);          {!!.01}
    end;

    { string of field separators, length equal to one less than no. of fields }
    ltVarying: begin
      FValue := StringOfChar(FSchema.FieldDelimiter, Pred(FSchema.FieldCount));
    end;

    ltUnknown : begin
      raise EStException.CreateResTP(stscTxtDatInvalidSchema, 0);
    end;
  end;
end;

procedure TStTextDataRecord.SetFieldByName(const FieldName: AnsiString;
  const NewValue: AnsiString);
{ set value of field in current record with given name }
var
  Idx : Integer;
begin
  Idx := FSchema.IndexOf(FieldName);
  if Idx > -1 then
    SetField(Idx, NewValue)
  else
    raise EStException.CreateResTP(stscTxtDatNoSuchField, 0);
end;

procedure TStTextDataRecord.SetField(Index: Integer;
  const NewValue: AnsiString);
{ set value of field in current record at given index }
var
  Len, Offset: Integer;