tscommon.pas

企业进销存管理系统

{*******************************************************}
{                                                       }
{       ObjectSight Visual Components                   }
{       TopGrid general classes and functions           }
{                                                       }
{       Copyright (c) 1997 - 1999, ObjectSight          }
{                                                       }
{*******************************************************}

unit TSCommon;

{$INCLUDE TSCmpVer}

interface

uses
    Classes, TypInfo, Windows, Graphics, Controls, StdCtrls, Registry, Dialogs,
    TSSetLib, TSMbcs {$IFDEF TSVER_V6}, Variants {$ENDIF};

const
    VK_A = Ord('A');
    VK_C = Ord('C');
    VK_V = Ord('V');
    VK_X = Ord('X');
    VK_Z = Ord('Z');
    CTRL_A = 1;
    CTRL_C = 3;
    CTRL_V = 22;
    CTRL_X = 24;
    CTRL_Z = 26;

    tsYMD = 0;
    tsMDY = 1;
    tsDMY = 2;

type
    TtsHorzAlignment   = (htaLeft, htaRight, htaCenter, htaDefault);
    TtsVertAlignment   = (vtaTop, vtaBottom, vtaCenter, vtaDefault);

    PtsIntegerArray = ^TtsIntegerArray;
    TtsIntegerArray = array[0..MaxListSize] of Integer;
    PtsPointerArray = ^TtsPointerArray;
    TtsPointerArray = array[0..(MaxListSize div ((SizeOf(Pointer) div SizeOf(LongInt)) + 1))] of Pointer;

    TosMaskEntry = class
    private
      FPicture : String;
      FName : String;
      FSystem : Boolean;
    protected
      function GetDisplayName : String;
      function GetStorageText : String;
      procedure SetStorageText(Value : String);
    public
      property Picture : String read FPicture write FPicture;
      property Name : String read FName write FName;
      property System : Boolean read FSystem write FSystem;
      property DisplayName : String read GetDisplayName;
      property StorageText : String read GetStorageText write SetStorageText;
    end;

    {TtsMemoryCanvas}
    {This class encapsulates an in memory canvas used by controls to
     draw on, after which the redrawn area is displayed on screen}

    TtsMemoryCanvas = class(TObject)
    protected
        FDc: Hdc;
        FWidth: Integer;
        FHeight: Integer;
        FCount: Integer;
        FMutex: THandle;
        FLockingThreadId: DWord;
        FLockingObject: TObject;

    public
        constructor Create;
        destructor  Destroy; override;

        procedure Prepare(Dc: Hdc; Width, Height: Integer);
        procedure Resize(Dc: Hdc; Width, Height: Integer);
        procedure Release;
        procedure FreeDc;
        procedure SetObjects(var Rect : TRect);
        procedure Lock(AObject: TObject);
        procedure Unlock;
        function  GetMutex: THandle;
        function  Locked(AObject: TObject): Boolean;

        property Dc: Hdc read FDc write FDc;
        property Width: Integer read FWidth write FWidth;
        property Height: Integer read FHeight write FHeight;
        property Count: Integer read FCount write FCount;
        property Mutex: THandle read GetMutex write FMutex;
    end;

    TtsBitmapElement = class(TtsSetElement)
    protected
        FBitmap: TBitmap;
        FCount: Longint;
        FBitmapID: Longint;
        FCanFree: Boolean;
    public
        constructor Create(Bitmap: TBitmap);
        destructor Destroy; override;

        function  Compare(NodeSet: TtsCustomSet; Value : TtsSetElement) : TtsSetOrder; override;
        function  CompareKey(NodeSet: TtsCustomSet; const KeyValue : array of const) : TtsSetOrder; override;

        property Bitmap: TBitmap read FBitmap;
        property BitmapID: Longint read FBitmapID write FBitmapID;
        property CanFree: Boolean read FCanFree write FCanFree;
        property Count: Longint read FCount write FCount;
    end;

    TtsBitmapSet = class(TtsObjectSet)
    protected
        procedure AddElement(Element: TtsBitmapElement);
        function  GetBitmap(Bitmap: TBitmap): TtsBitmapElement;
        function  AddBitmap(Bitmap: TBitmap): TtsBitmapElement;
        procedure RemoveBitmap(Bitmap: TBitmap);
    end;

    {Tts2DStorage}
    {This class is used for storing values in a 2-dimensional dynamic
     data structure. Cell entries are initially empty and created as
     needed.}

    TtsValueType = (vtpNone, vtpString, vtpInteger, vtpPicture, vtpPictureName, vtpNull);
    Pts2DDataStorage = ^Tts2DDataStorage;
    Pts2DDataType = ^Tts2DDataType;
    PtsRowDataType = ^TtsRowDataType;
    PtsColsInRow = ^TtsColsInRow;
    PtsRowData = ^TtsRowData;
    Tts2DDataStorage = array[0..(MaxListSize div ((SizeOf(PtsRowData) div SizeOf(LongInt)) + 1))] of PtsRowData;
    Tts2DDataType = array[0..(MaxListSize div ((SizeOf(PtsRowDataType) div SizeOf(LongInt)) + 1))] of PtsRowDataType;
    TtsRowDataType = array[0..(MaxListSize div ((SizeOf(TtsValueType) div SizeOf(LongInt)) + 1))] of TtsValueType;
    TtsRowData = array[0..(MaxListSize div ((SizeOf(Pointer) div SizeOf(LongInt)) + 1))] of Pointer;
    TtsColsInRow = array[0..MaxListSize] of Integer;

    Tts2DStorage = Class(TObject)
    protected
        FColsAllocSize: Integer;
        FRowsAllocSize: Integer;
        FData: Pts2DDataStorage;
        FDataType: Pts2DDataType;
        FRowsInData: Integer; //Nr of Rows allocated
        FColsInRow: PtsColsInRow; //Nr of cols in use per row
        FColsAllocInRow: PtsColsInRow; //Nr of cols allocated per row
        FInDesignMode: Boolean;

        procedure SetBitmapValue(DataCol, DataRow: Longint; CurValueType: TtsValueType; Bitmap: TBitmap);
        procedure CopyRow(FromRow, ToRow: Integer);
        procedure WriteInteger(Stream: TStream; Col, Row: Integer);
        procedure ReadInteger(Stream: TStream; Col, Row: Integer);
        procedure WriteString(Stream: TStream; Col, Row: Integer);
        procedure ReadString(Stream: TStream; Col, Row: Integer; ValueType: TtsValueType);
        procedure WritePicture(Stream: TStream; Col, Row: Integer; BmpSet: TtsBitmapSet; BmpList: TList);
        procedure ReadPicture(Stream: TStream; Col, Row: Integer; BmpList: TList);
        procedure WriteBitmapList(Stream: TStream; BmpList: TList);
        procedure ReadBitmapList(Stream: TStream; BmpList: TList);
        procedure CheckCreateRow(DataRow: Integer);
        procedure CheckCreateCol(DataCol, DataRow: Integer);

    public
        constructor Create(Cols, Rows: Integer);
        destructor  Destroy; override;

        procedure Assign(Source: Tts2DStorage); virtual;
        procedure BackupRow(DataRow: Integer); virtual;
        procedure Clear(StartRow: Integer; Resize: Boolean);
        procedure ClearBackupRow; virtual;
        procedure ClearRow(DataRow: Integer; ColsInRow: Integer);
        procedure ClearCol(DataCol: Integer);
        procedure ClearValue(DataCol, DataRow: Integer);
        procedure DeleteCols(FromCol, ToCol: Integer); virtual;
        procedure DeleteRows(FromRow, ToRow: Integer); virtual;
        function  GetValue(DataCol, DataRow: Integer): Variant; virtual;
        function  GetValueType(DataCol, DataRow: Integer): TtsValueType; virtual;
        procedure LoadFromStream(Stream: TStream; ColNumbers: TList); virtual;
        function  MaxColValueSet(DataRow: Integer): Integer;
        function  MaxRowSet: Integer;
        procedure ResizeRows(NewSize: Integer);
        procedure ResizeRowCols(DataRow: Integer; NewSize: Integer);
        procedure RestoreBackupRow(DataRow: Integer); virtual;
        property  RowsInData: Integer read FRowsInData;
        procedure SaveToStream(Stream: TStream); virtual;
        procedure SetValue(DataCol, DataRow: Integer; Value: Variant; ValueType: TtsValueType); virtual;

        property ColsAllocSize: Integer read FColsAllocSize write FColsAllocSize;
        property RowsAllocSize: Integer read FRowsAllocSize write FRowsAllocSize;
    end;


    TtsStack = class(TObject)
    protected
        FValueList: TList;
        function GetValueList: TList;
    public
        constructor Create;
        destructor  Destroy; override;

        procedure Push(Value: integer);
        function Pop: integer;
        function CurValue: integer;
        property ValueList: TList read GetValueList write FValueList;
    end;


function  CalcMax(First, Second: Longint): Longint;
function  CalcMin(First, Second: Longint): Longint;
procedure SwapLongint(var High, Low: Longint);
function  Sign(Value: Integer): Integer;
function  PointInRect(APoint: TPoint; ARect: TRect): Boolean;

function  StrNScan(Text : PChar; Chr : Char; Chars : Cardinal) : PChar;
function  StrRNScan(Text : PChar; Chr : Char; Chars : Cardinal): PChar;
function  AnsiStrNScan(Text : PChar; Chr : Char; Chars : Cardinal): PChar;
function  AnsiStrRNScan(Text : PChar; Chr : Char; Chars : Cardinal): PChar;
function  CheckEscapeChars(Str: string; CheckChar, EscapeChar: Char): string;

function  VariantToObject(Value: Variant): TObject;
function  ObjectToVariant(Value: TObject): Variant;
function  VariantToBitmap(Value: Variant): TBitmap;
function  BitmapToVariant(Value: TBitmap): Variant;
procedure WriteVariant(Writer: TWriter; Value: Variant);
function  ReadVariant(Reader: TReader): Variant;
function  CompareVariant(Value1, Value2: Variant): Integer;
function  IsNumVar(const Value: Variant): Boolean;
function  VariantEqual(var1, var2: variant): Boolean;
function  EqualPropValue(Var1, Var2: Variant): Boolean;

function  GetDateOrder: Integer;
function  GetEditDateFormat(IncludeCentury: Boolean): string;
function  StringToDateTime(Value: string): TDateTime;
function  VariantToDateTime(Value: Variant): TDateTime;
function  LongYearFormat(Fmt: string): string;
function  LongHourFormat(Fmt: string): string;
function  AMPMFormat: Boolean;
function  DateReplaceMonthName(DateStr: string): string;
function  DateRemoveDayName(DateStr: string): string;

function  CheckBoxValuesOk(CheckBoxValues: string): Boolean;
function  CheckBoxToString(Value: TCheckBoxState; CheckBoxValues: string): string;
function  StringToCheckBox(Value: string; CheckBoxValues: string): TCheckBoxState;
function  CheckBoxToVariant(Value: TCheckBoxState; CheckBoxValues: string): Variant;
function  VariantToCheckBox(Value: Variant; CheckBoxValues: string): TCheckBoxState;

function  ResourceStr(StrCode: Variant): string;
function  TextAccelKey(Value: string; var AccelKeyPos: Integer): string;
function  CreateStringList(Strings: string): TStringList;
function  StringInList(PName: PShortString; List: TStringList): Boolean;

procedure SeparateFirstPart(var Remainder, Item: string; Separator: string);
function  AddPictureIds(Value: string; ImageListIndex, ImageId: Integer): string;
function  SeparatePictureIds(Value: string; var ComponentId, ImageId: Integer): string;

function  GetPropertyList(Obj: TObject; TypeKinds: TTypeKinds; var PropCount: Integer): PPropList;
procedure FreePropertyList(PropList: PPropList; PropCount: Integer);
procedure AssignPropertyValue(PropInfo: PPropInfo; ToObject, FromObject: TObject);
procedure AssignNameValue(PropName: string; ToObject, FromObject: TObject);
procedure AssignObject(ToObject, FromObject: TObject; NoAssignProps: string);

function  OpenRegistryKey(const Key: string; CanCreate: Boolean): TRegistry;
function  GetRegStrValue(RootKey: HKey; const Key: string; const ValueName: string): string;
procedure InitCanvas(Canvas: TCanvas);
procedure FreeNil(var AObject: TObject);
function  AlignmentToHorzAlignment(Alignment: TAlignment; Align: Boolean): TtsHorzAlignment;
function  HorzAlignmentToAlignment(HorzAlignment: TtsHorzAlignment): TAlignment;
function  HorzAlignmentToAlign(HorzAlignment: TtsHorzAlignment): Boolean;

function ScanNum(S: string; Pos: Integer; Direction: Integer): Integer;
function ScanNumChars(S: string; Pos: Integer; Direction: Integer): Integer;
function IncStrNum(S: string; Increment: Double): string;
function IncStrAtPos(S: string; Increment: Extended; APos: Integer; var StartPos, Len: Integer): string;
function PadDecimals(Sample: string; NumStr: string): string;
function PadNumber(Sample: string; NumStr: string): string;

function ControlFocused(Control: TWinControl): Boolean;
function ControlVisible(Control: TWinControl): Boolean;
function IsControlHandle(Handle: Hwnd; Control: TWinControl): Boolean;

function CheckForWhiteSpace(theText : String) : String;
function GetCompilerVersion: string;
procedure ShowHelpTopic(Handle: Hdc; Key: string);

implementation

uses
    SysUtils;

const
    StrHKEY_CLASSES_ROOT = 'HKEY_CLASSES_ROOT';
    StrHKEY_CURRENT_USER = 'HKEY_CURRENT_USER';
    StrHKEY_LOCAL_MACHINE = 'HKEY_LOCAL_MACHINE';
    StrHKEY_USERS = 'HKEY_USERS';
    StsUnknownRegistryKey = 'Unknown registry key %s';
    IdSeparator = #1;
    CheckBoxValueSeparator = '|';
    StrCheckBoxNull = 'Null';

    HelpSubDir = 'Help';
    RootKeyName = 'RootDir';

    Delphi3RootDirKey = 'Software\Borland\Delphi\3.0';
    Delphi4RootDirKey = 'Software\Borland\Delphi\4.0';
    Delphi5RootDirKey = 'Software\Borland\Delphi\5.0';
    CBuilder3RootDirKey = 'Software\Borland\C++Builder\3.0';
    CBuilder4RootDirKey = 'Software\Borland\C++Builder\4.0';

    Delphi3Help = 'DELPHI3';
    Delphi4Help = 'DELPHI4';
    Delphi5Help = 'DELPHI5';
    CBuilder3Help = 'BCB3';
    CBuilder4Help = 'BCB4';

type
    TReader_ = class(TReader) end;

var
    FInternalBitmaps: TtsBitmapSet = nil;

function CheckForWhiteSpace(theText : String) : String;
var i, iLen : Integer;
begin
    iLen := Length(theText);
    Result := '';
    for i := 1 to iLen do
    begin
      if theText[i] = '&' then
         Result := Result + '&'
      else if theText[i] = '''' then
         Result := Result + '''
      else if theText[i] = '"' then
         Result := Result + '"'
      else
         Result := Result + theText[i];
    end;
end;

function GetInternalBitmap(Bitmap: TBitmap): TtsBitmapElement;
begin
    Result := nil;
    if Assigned(FInternalBitmaps) then
        Result := FInternalBitmaps.GetBitmap(Bitmap);
end;

function CreateInternalBitmap: TtsBitmapElement;
begin
    if not Assigned(FInternalBitmaps) then
        FInternalBitmaps := TtsBitmapSet.Create;
    Result := FInternalBitmaps.AddBitmap(TBitmap.Create);
    if Assigned(Result) then
    begin
        Result.CanFree := True;
    end;
end;

procedure CheckInternalBitmap(Bitmap: TBitmap; Remove: Boolean);
var
    Element: TtsBitmapElement;
begin
    if not Assigned(FInternalBitmaps) then Exit;

    if Remove then
    begin
        if Assigned(FInternalBitmaps) then
            FInternalBitmaps.RemoveBitmap(Bitmap);
    end
    else
    begin
        Element := GetInternalBitmap(Bitmap);
        if Assigned(Element) then Element.Count := Element.Count + 1;
    end;
end;

function CalcMax(First, Second: Longint): Longint;
begin
    if First >= Second then Result := First
                       else Result := Second;
end;

function CalcMin(First, Second: Longint): Longint;
begin
    if First <= Second then Result := First
                       else Result := Second;
end;

procedure SwapLongint(var High, Low: Longint);
var
    Temp: Longint;
begin
    Temp := High;
    High := Low;
    Low := Temp;
end;

function Sign(Value: Integer): Integer;
begin
    if Value > 0 then
        Result := 1
    else if Value < 0 then
        Result := -1
    else
        Result := 0;
end;

function PointInRect(APoint: TPoint; ARect: TRect): Boolean;
begin
    Result := (APoint.X >= ARect.Left) and (APoint.X <= ARect.Right) and
              (APoint.Y >= ARect.Top) and (APoint.Y <= ARect.Bottom);
end;

function StrNScan(Text : PChar; Chr : Char; Chars : Cardinal): PChar; assembler;
asm
        PUSH    EDI
        MOV     EDI,Text
        MOV     ECX,Chars
        MOV     EAX,0
        CMP     ECX,0       //Exit if Chars = 0
        JE      @@1
        MOV     AL,Chr
        REPNE   SCASB
        MOV     EAX,0
        JNE     @@1
        MOV     EAX,EDI
        DEC     EAX
@@1:    POP     EDI
end;

function StrRNScan(Text : PChar; Chr : Char; Chars : Cardinal): PChar; assembler;
asm
        PUSH    EDI
        ADD     EAX,Chars
        MOV     EDI,EAX
        MOV     ECX,Chars
        MOV     EAX,0
        CMP     ECX,0       //Exit if Chars = 0
        JE      @@1
        STD
        DEC     EDI
        MOV     AL,Chr