validate2.pas

一个经典的读写Excel的控件

unit Validate2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$B-}

interface

uses Classes, SysUtils, FormulaHandler2, BIFFRecsII2, CellAreas2, XLSUtils2,
     XLSStream2, MoveCopy2;

type TValidationOperator = (vopBetween,vopNotBetween,vopEqual,vopNotEqual,vopGreater,vopLess,vopGreateEqual,vopLessEqual);

type
//:# Type of values that are accepted.
//: vtAny = Any value.<br>
//: vtInteger = Integer Values.<br>
//: vtNumber = Floating point values.<br>
//: vtList = Choose a value from a list. Use @link(SetList) to define the list.<br>
//: vtDate = Date values.<br>
//: vtTime = Time values.<br>
//: vtTextLength = Limit the text length of the value.<br>
//: vtCustom = Custom. Any formula?<br>
     TValidationType = (vtAny,vtInteger,vtNumber,vtList,vtDate,vtTime,vtTextLength,vtCustom);
type TValidationStyle = (vsStop,vsWarning,vsInfo);
type
//:# Validation options.
//: voAllowEmptyCells = Allow empty cells in the validation areas.<br>
//: voSupressDropDown = When ValidationType is vtList, prevent the combo box to be shown.<br>
//: voShowPromptBox = Show a hint text to the user.<br>
//: voShowErrorBox = Show an error message when an invalid value is entered.<br>
    TValidationOption = (voAllowEmptyCells,voSupressDropDown,voShowPromptBox,voShowErrorBox);
     TValidationOptions = set of TValidationOption;

type
//:# Validations of input values in cells.
//: Use TDataValidation in order to create a control of the cell values a user
//: enters in Excel. If a value not matches the criterias, the user can be
//: given a message, or the value can be refused.
    TDataValidation = class(TCollectionItemMoveCopy)
private
     FAssigned: boolean;
     FOptions: longword;
     FValidationOptions: TValidationOptions;
     FInputTitle: WideString;
     FErrorTitle: WideString;
     FInputMsg: WideString;
     FErrorMsg: WideString;
     FFormula1: TRecPTGS;
     FFormula2: TRecPTGS;
     FValidationType: TValidationType;
     FValidationStyle: TValidationStyle;
     FValidationOperator: TValidationOperator;
     FAreas: TCellAreas;

     procedure ClearExpr1;
     procedure ClearExpr2;
     function  GetExpression1: WideString;
     function  GetExpression2: WideString;
     procedure SetExpression1(const Value: WideString);
     procedure SetExpression2(const Value: WideString);
     procedure SetValidationOperator(const Value: TValidationOperator);
     procedure SetValidationStyle(const Value: TValidationStyle);
     procedure SetValidationType(const Value: TValidationType);
     procedure SetValidationOptions(const Value: TValidationOptions);
protected
     procedure LoadFromStream(Stream: TXLSStream; PBuf: PByteArray);
     procedure SaveToStream(Stream: TXLSStream; PBuf: PByteArray);
     procedure SetRawExpression1(Value: PByteArray; Len: integer);
     procedure SetRawExpression2(Value: PByteArray; Len: integer);
     function  Intersect(Col1,Row1,Col2,Row2: integer): boolean; override;
     procedure Copy(Col1,Row1,Col2,Row2,DeltaCol,DeltaRow: integer); override;
     procedure Delete(Col1,Row1,Col2,Row2: integer); override;
     procedure Include(Col1,Row1,Col2,Row2: integer); override;
     procedure Move(DeltaCol,DeltaRow: integer); override;
     procedure Move(Col1,Row1,Col2,Row2,DeltaCol,DeltaRow: integer); override;
public
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;
     //:# Assigns another TDataValidation to this.
     procedure Assign(Source: TPersistent); override;
     //:# Sets the validation type to a list.
     //: Use SetList to set a list of string values that the user can choose of.
     //: SetList will also set the @link(ValidationType) to vtList.
     procedure SetList(Values: array of WideString);
     //:# Get the list values.
     //: Use GetList to get the strings in the list when @link(ValidationType)
     //: is vtList. GetList returns True if if the validationType is vtList,
     //: and there where any strings in the list.<br>
     //: Use @link(GetListSize) to get the number of elements in the list.
     function  GetList(var Values: array of WideString): boolean;
     function  GetListSize: integer;
published
     //:# Options for a validation.
     property Options: TValidationOptions read FValidationOptions write SetValidationOptions;
     //:# The cell areas that the TDataValidation shall be applied to.
     property Areas: TCellAreas read FAreas write FAreas;
     //:# Message to the user.
     //: ErrorMsg is the message that the user will see if the cell value
     //: entered don't matches the criterias.
     property ErrorMsg: WideString read FErrorMsg write FErrorMsg;
     //:# Title of the message box.
     property ErrorTitle: WideString read FErrorTitle write FErrorTitle;
     //:# Expression for the first condition.
     property Expression1: WideString read GetExpression1 write SetExpression1;
     //:# Expression for the second condition, if needed.
     property Expression2: WideString read GetExpression2 write SetExpression2;
     //:# Prompt box shown for the user.
     //: In order to show a prompt box for the user, ValidationOptions must
     //: include the value voShowPromptBox.
     property InputMsg: WideString read FInputMsg write FInputMsg;
     //:# Title of prompt box.
     property InputTitle: WideString read FInputTitle write FInputTitle;
     //:# The validation operator.
     property ValidationOperator: TValidationOperator read FValidationOperator write SetValidationOperator;
     //:# Validation style.
     property ValidationStyle: TValidationStyle read FValidationStyle write SetValidationStyle;
     //:# Type of validation.
     property ValidationType: TValidationType read FValidationType write SetValidationType;
     end;

//:# List of data validations.     
type TDataValidations = class(TCollectionMoveCopy)
private
     FRecDVAL: TRecDVAL;

     function  GetDataValidation(Index: integer): TDataValidation;
protected
     FOwner: TPersistent;
     FFormulaHandler: TFormulaHandler;

     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; FormulaHandler: TFormulaHandler);
     function  Add: TDataValidation;
     procedure LoadFromStream(Stream: TXLSStream; PBuf: PByteArray);
     procedure SaveToStream(Stream: TXLSStream; PBuf: PByteArray);

     property Items[Index: integer]: TDataValidation read GetDataValidation; default;
     end;

implementation

{ TDataValidation }

procedure TDataValidation.Assign(Source: TPersistent);
begin
  FAssigned := True;
  FOptions := TDataValidation(Source).FOptions;
  FInputTitle := TDataValidation(Source).FInputTitle;
  FErrorTitle := TDataValidation(Source).FErrorTitle;
  FInputMsg := TDataValidation(Source).FInputMsg;
  FErrorMsg := TDataValidation(Source).FErrorMsg;

  FFormula1.Size := TDataValidation(Source).FFormula1.Size;
  GetMem(FFormula1.PTGS,FFormula1.Size);
  System.Move(TDataValidation(Source).FFormula1.PTGS^,FFormula1.PTGS^,FFormula1.Size);

  FFormula2.Size := TDataValidation(Source).FFormula2.Size;
  GetMem(FFormula2.PTGS,FFormula2.Size);
  System.Move(TDataValidation(Source).FFormula2.PTGS^,FFormula2.PTGS^,FFormula2.Size);

  FValidationType := TDataValidation(Source).FValidationType;
  FValidationStyle := TDataValidation(Source).FValidationStyle;
  FValidationOperator := TDataValidation(Source).FValidationOperator;
  FAreas.Assign(TDataValidation(Source).Areas);
end;

procedure TDataValidation.ClearExpr1;
begin
  FreeMem(FFormula1.PTGS);
  FFormula1.PTGS := Nil;
  FFormula1.Size := 0;
end;

procedure TDataValidation.ClearExpr2;
begin
  FreeMem(FFormula2.PTGS);
  FFormula2.PTGS := Nil;
  FFormula2.Size := 0;
end;

procedure TDataValidation.Copy(Col1, Row1, Col2, Row2, DeltaCol, DeltaRow: integer);
begin
  FAreas.Copy(Col1, Row1, Col2, Row2,DeltaCol,DeltaRow);
end;

constructor TDataValidation.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FAreas := TCellAreas.Create(Self);
  FValidationType := vtAny;
  FValidationStyle := vsStop;
  FValidationOperator := vopEqual;
  FValidationOptions := [voAllowEmptyCells,voShowPromptBox,voShowErrorBox];
end;

procedure TDataValidation.Delete(Col1, Row1, Col2, Row2: integer);
begin
  FAreas.Delete(Col1, Row1, Col2, Row2);
end;

destructor TDataValidation.Destroy;
begin
  inherited;
  ClearExpr1;
  ClearExpr2;
  FAreas.Free;
end;

function TDataValidation.GetExpression1: WideString;
begin
  if (FFormula1.PTGS <> Nil) and (FFormula1.Size > 0) then
    Result := TDataValidations(Collection).FFormulaHandler.DecodeFormula(FFormula1.PTGS,FFormula1.Size)
  else
    Result := '';
end;

function TDataValidation.GetExpression2: WideString;
begin
  if (FFormula2.PTGS <> Nil) and (FFormula2.Size > 0) then
    Result := TDataValidations(Collection).FFormulaHandler.DecodeFormula(FFormula1.PTGS,FFormula1.Size)
  else
    Result := '';
end;

function TDataValidation.GetList(var Values: array of WideString): boolean;
var
  i,j,k,Sz,Count: integer;
  pB: PByteArray;
  pW: PWordArray;
begin
  Result := False;
  Count := GetListSize;
  if Count <= 0 then
    Exit;
  Sz := FFormula1.PTGS[1];
  if FFormula1.PTGS[2] = 0 then begin
    pB := PByteArray(@FFormula1.PTGS[3]);
    i := 0;
    k := 0;
    while i < Sz do begin
      SetLength(Values[k],255);
      j := 1;
      while (i < Sz) and (pB[i] <> 0) do begin
        Values[k][j] := WideChar(pB[i]);
        Inc(i);
        Inc(j);
      end;
      SetLength(Values[k],j - 1);
      Inc(i);
      Inc(k);
    end;
  end
  else begin
    pW := PWordArray(@FFormula1.PTGS[3]);
    i := 0;
    k := 0;
    while i < Sz do begin
      SetLength(Values[k],255);
      j := 1;
      while (i < Sz) and (pW[i] <> 0) do begin
        Values[k][j] := WideChar(pW[i]);
        Inc(i);
        Inc(j);
      end;
      SetLength(Values[k],j - 1);
      Inc(i);
      Inc(k);
    end;
  end;
end;

function TDataValidation.GetListSize: integer;
var
  i,Sz: integer;
  pB: PByteArray;
  pW: PWordArray;
begin
  Result := 0;
  if FValidationType <> vtList then
    Exit;
  if (FFormula1.Size < 3) or (FFormula1.PTGS[0] <> ptgStr) then
    Exit;
  Sz := FFormula1.PTGS[1];
  if FFormula1.PTGS[2] = 0 then begin
    pB := @FFormula1.PTGS[3];
    for i := 0 to Sz - 1 do begin
      if pB[i] = 0 then
        Inc(Result);
    end;
    Inc(Result);
  end
  else begin
    pW := PWordArray(@FFormula1.PTGS[3]);