uexprutils.pas

用于Delphi程序中嵌入公式解析

unit uExprUtils;

interface

uses
    Windows, Messages, Classes, SysUtils, Dialogs, ComCtrls;

const
    EXPR_VALIDNAME = ['A'..'Z', 'a'..'z', '0'..'9', '_'];

    function IsValidName(AName: string): Boolean;
    { 强制按键限制 }
    procedure ForcePressKeyForInteger(var Key: Char);
    procedure ForcePressKeyForFloat(var Key: Char);
    procedure ForcePressKeyForDateTime(var Key: Char);
    { 数据类型转换检查 }
    function StrCanBeDateTime(sValue: String): Boolean;
    function StrCanBeInteger(sValue: String): Boolean;
    function StrCanBeFloat(sValue: string): Boolean;
    { ListView自动调整宽度 }
    procedure LvwAutoWidth(LVW: TListView);
    procedure UnpackStrToStrings(Results    : TStrings;
                                 const AStr : string;
                                 const ADel : Char);
type
        { 基础类.............................................................. }
        TExprStream = class(TMemoryStream)
        Private
            function GetVariantStream: Variant;
            procedure SetVariantStream(const v: Variant);
        public
            procedure SaveInteger(v: Integer);
            procedure SaveDouble(v: double);
            procedure SaveDateTime(v: TDateTime);
            procedure SaveString(v: String);
            procedure SaveStrings(v: TStrings);
            function LoadInteger: integer;
            function LoadDouble: Double;
            function LoadDateTime: TDateTime;
            function LoadString: STring;
            function LoadStrings: TStrings;
            property VariantStream: Variant read GetVariantStream write SetVariantStream;
        end;

implementation

{-----------------------------------------------------------------------------
     >>>>  IsValidName   <<<<  Begin
检查对象名称是否合法。合法的对象名称由英文字母、数字和下划线组成，且第一个字
符必须为英文字母。
-----------------------------------------------------------------------------}
function IsValidName(AName : string): Boolean;
var     i : Integer;
begin
        Result := False;
        if Length(AName) >0 then
        begin
            if not (AName[1] in ['A'..'Z', 'a'..'z', '_']) then
            begin
                Exit;
            end;

            if Length(AName) >1 then
            begin
                for i := 2 to Length(AName) do
                begin
                    if not (AName[i] in ['A'..'Z', 'a'..'z', '0'..'9', '_']) then Exit;
                end;
            end;

            Result := True;
        end;
end;
{-----------------------------------------------------------------------------
     >>>>  LvwAutoWidth   <<<<  Begin
     根据Listview各列内容的实际长度自动调整ListView的列宽度使之相适应。仅应
     用于Report模式。
-----------------------------------------------------------------------------}
procedure LvwAutoWidth(LVW : TListView);
var
        Column_to_Size    : longint;
        Count    : longint;
begin
        if lvw.ViewStyle <> vsReport then Exit;
                    
        lvw.Items.BeginUpdate;
        Count := 0;
        if LVW.Columns.Count  = 0 then exit;
        for Column_to_Size := Count to LVW.Columns.Count -1 do
        begin
            SendMessageA(LVW.Handle, 4126, Column_to_Size, -2);
            {LVW.Columns.Items[Column_to_Size].AutoSize := True;}
        end;
        lvw.Items.EndUpdate;
end;
{-----------------------------------------------------------------------------
     >>>>  UnpackStrToStrings   <<<<  Begin
     将将羊肉分解为羊肉串。主要用于"Obj1.Obj2.Obj3"的形式或"dir1/dir2/dir3"
-----------------------------------------------------------------------------}
procedure UnpackStrToStrings(Results: TStrings; const AStr : string; const ADel: Char);
var     S : string;
        i : integer;
begin
        if not Assigned(Results) then Results := TStringList.Create
        else Results.Clear;

        if ADel = '' then
        begin
            Results.Add(AStr);
            Exit;
        end;

        if trim(AStr) = '' then Exit;
        
        s := AStr;
        repeat
            i := pos(Adel, s);
            if i = 0 then
            begin
                Results.Add(s);
                break;
            end;
            Results.Add(Copy(s, 1, i -1));

            if i = Length(s) then Break;

            s := Copy(s, i+1, Length(s) - i);
        until False;
end;

procedure ForcePressKeyForInteger(var Key: Char);
begin
        if not (Key in ['0'..'9', '-', ' ' ]) then
        begin
            Key := #0;
            Beep;
        end;
end;

procedure ForcePressKeyForFloat(var Key: Char);
begin
        if not (Key in ['0'..'9', '.', '-', 'E', ' ']) then
        begin
            Key := #0;
            Beep;
        end;
end;

procedure ForcePressKeyForDateTime(var Key: Char);
begin
        if not (Key in ['0'..'9', ':', '-', '/', ' ']) then
        begin
            Key := #0;
            Beep;
        end;
end;

function StrCanBeDateTime(sValue: String): Boolean;
begin
        Result := False;

end;

function StrCanBeFloat(sValue: String): Boolean;
begin
end;

function StrCanBeInteger(sValue: String): Boolean;
begin
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TExprStream
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TrptStream
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
procedure TExprStream.SaveInteger(v: integer);
begin
        write(v, SizeOf(integer));
end;

procedure TExprStream.SaveDouble(v: Double);
begin
        write(v, SizeOf(v));
end;

procedure TExprStream.SaveDateTime(v: TDateTime);
begin
        write(v, SizeOf(v));
end;

procedure TExprStream.SaveString(v: string);
var     sl: Integer;
begin
        sl := length(v);
        SaveInteger(sl);
        if sl >0 then write(PChar(v)^, sl);
end;

procedure TExprStream.SaveStrings(v: TStrings);
var     i : Integer;
        s : String;
begin
        i := v.Count;
        SaveInteger(i);
        if i>0 then
            for i := 0 to v.Count -1 do
            begin
                s := v.Strings[i];
                SaveString(s);
            end;
end;

procedure TExprStream.SetVariantStream(const v: Variant);
var     p : Pointer;
begin
        P := VarArrayLock(v);
        try
            Write(p^, VarArrayHighBound(v,1) + 1);
            Position := 0;
        finally
            VarArrayUnlock(v);
        end;
end;

function TExprStream.LoadInteger: integer;
begin
        Read(Result, SizeOf(Integer));
end;

function TExprStream.LoadDouble: Double;
begin
        Read(Result, SizeOf(Result));
end;

function TExprStream.LoadDateTime: TDateTime;
begin
        Read(Result, SizeOf(Result));
end;

function TExprStream.LoadString: String;
var     sc: integer;
begin
        Result := '';
        sc := LoadInteger;
        if sc >0 then
        begin
            SetLength(Result, sc);
            Read(Pointer(Result)^, sc);
        end;
end;

function TExprStream.LoadStrings: TStrings;
var     i, sc : Integer;
        S : string;
begin
        Result := TStringList.Create;

        sc := LoadInteger;
        if sc >0 then
            for i := 0 to sc -1 do
            begin
                s := LoadString;
                Result.Add(s);
            end;
end;

function TExprStream.GetVariantStream: Variant;
var     p: Pointer;
begin
        Result := VarArrayCreate([0, Size - 1], varByte);
        p := VarArrayLock(Result);
        try
            Position := 0;
            Read(p^, Size);
        finally
            VarArrayUnlock(Result);
        end;
end;
  
end.