tscommon.pas

企业进销存管理系统

        REPNE   SCASB
        MOV     EAX,0
        JNE     @@1
        MOV     EAX,EDI
        INC     EAX
@@1:    CLD
        POP     EDI
end;

function AnsiStrNScan(Text : PChar; Chr : Char; Chars : Cardinal): PChar;
var
    CharsDone: Cardinal;
begin
    Result := StrNScan(Text, Chr, Chars);
    while Result <> nil do
    begin
        case StrByteType(Text, Result - Text) of
            mbSingleByte: Break;
            mbLeadByte: Inc(Result);
        end;
        CharsDone := Result - Text + 1;
        Result := StrNScan(Result + 1, Chr, Chars - CharsDone);
    end;
end;

function AnsiStrRNScan(Text : PChar; Chr : Char; Chars : Cardinal): PChar;
begin
    Result := StrRNScan(Text, Chr, Chars);
    while Result <> nil do
    begin
        case StrByteType(Text, Result - Text) of
            mbSingleByte: Break;
            mbTrailByte: Dec(Result);
        end;
        Result := StrRNScan(Text, Chr, Result - Text);
    end;
end;

function CheckEscapeChars(Str: string; CheckChar, EscapeChar: Char): string;
var
    CharPos : Integer;
begin
    Result := '';
    while Str <> '' do
    begin
        CharPos := Pos(CheckChar, Str);
        if CharPos <> 0 then
        begin
            Result := Result + Copy(Str, 1, CharPos - 1) + EscapeChar + Copy(Str, CharPos, 1);
            Str := Copy(Str, CharPos + 1, Length(Str));
        end
        else
        begin
            Result := Result + Str;
            Str := ''
        end;
    end;
end;

function VariantToObject(Value: Variant): TObject;
begin
    Result := TObject(Integer(Value));
end;

function ObjectToVariant(Value: TObject): Variant;
begin
    Result := Integer(Value);
end;

function VariantToBitmap(Value: Variant): TBitmap;
begin
    Result := TBitmap(VariantToObject(Value));
end;

function BitmapToVariant(Value: TBitmap): Variant;
begin
    Result := ObjectToVariant(Value);
end;

procedure WriteVariant(Writer: TWriter; Value: Variant);
begin
    case VarType(Value) of
        varString, varOLEStr: Writer.WriteString(Value);
        varInteger, varSmallInt: Writer.WriteInteger(Value);
        varSingle, varDouble, varDate: Writer.WriteFloat(Value);
        varBoolean: Writer.WriteBoolean(Value);
        varEmpty: Writer.WriteIdent('Empty');
        varNull: Writer.WriteIdent('Null');
    else
        Writer.WriteString('');
    end;
end;

function ReadVariant(Reader: TReader): Variant;
var
    Ident: string;
begin
    Result := Unassigned;
    case TReader_(Reader).NextValue of
        vaString, vaLString: Result := Reader.ReadString;
        vaInt8, vaInt16, vaInt32: Result := Reader.ReadInteger;
        vaExtended: Result := Reader.ReadFloat;
        vaTrue, vaFalse: Result := Reader.ReadBoolean;
        vaIdent:
            begin
                Ident := Reader.ReadIdent;
                if Ident = 'Empty' then Result := Unassigned;
                if Ident = 'Null' then Result := Null;
            end;
    end;
end;

function CompareVariant(Value1, Value2: Variant): Integer;
var
    I, Count: Integer;
    DimCount1, DimCount2: Integer;
begin
    if VarIsEmpty(Value1) then
    begin
        if VarIsEmpty(Value2)
            then begin Result := 0; Exit; end
            else begin Result := -1; Exit; end;
    end;

    if VarIsEmpty(Value2) then
    begin
        Result := -1;
        Exit;
    end;

    if VarIsNull(Value1) then
    begin
        if VarIsNull(Value2)
            then begin Result := 0; Exit; end
            else begin Result := -1; Exit; end;
    end;

    if VarIsNull(Value2) then
    begin
        Result := -1;
        Exit;
    end;

    DimCount1 := VarArrayDimCount(Value1);
    DimCount2 := VarArrayDimCount(Value2);
    if (DimCount1 = 0) and (DimCount2 = 0) then
    begin
        if Value1 < Value2 then
            Result := -1
        else if Value1 > Value2 then
            Result := 1
        else
            Result := 0;
    end
    else
    begin
        Result := 0;
        Count := CalcMax(DimCount1, DimCount2);
        for I := 1 to Count do
        begin
            Result := CompareVariant(Value1[I], Value2[I]);
            if Result <> 0 then Break;
        end;

        if Result = 0 then
        begin
            if DimCount1 < DimCount2 then
                Result := -1
            else if DimCount1 > DimCount2 then
                Result := 1
            else
                Result := 0;
        end;
    end;
end;

function IsNumVar(const Value: Variant): Boolean;
begin
    Result := VarType(Value) in [varSmallint, varInteger, varSingle, varDouble,
                                 varCurrency, varByte];
end;

function VariantEqual(var1, var2: variant): Boolean;
//can be used to compare variants which may be unassigned.
begin
    if (VarIsEmpty(var1) or VarIsEmpty(var2)) then
        Result := (VarIsEmpty(var1) = VarIsEmpty(var2))
    else
    begin
        Result := VarType(var1) = VarType(var2);
        if Result and not VarIsNull(var1) then
            Result := var1 = var2;
    end;
end;

function EqualPropValue(Var1, Var2: Variant): Boolean;
begin
    Result := VariantEqual(Var1, Var2);
    if (not Result) and (VarType(Var1) <> VarType(Var2)) and
       IsNumVar(Var1) and IsNumVar(Var2) then
        Result := Var1 = Var2;
end;

function ScanToNum(S: string; Pos: Integer): Integer;
begin
    Result := Pos;
    while (Result <= Length(S)) and not (S[Result] in ['0'..'9']) do
    begin
        if S[Result] in LeadBytes then Inc(Result);
        Inc(Result);
    end;
end;

function GetDateOrder: Integer;
var
    I: Integer;
begin
    Result := tsMDY;
    I := 1;
    while I <= Length(ShortDateFormat) do
    begin
        case Chr(Ord(ShortDateFormat[I]) and $DF) of
            'E': Result := tsYMD;
            'Y': Result := tsYMD;
            'M': Result := tsMDY;
            'D': Result := tsDMY;
        else
            Inc(I);
            Continue;
        end;
        Break;
    end;
end;

function GetEditDateFormat(IncludeCentury: Boolean): string;
var
    DayFmt, MonthFmt, YearFmt: string;
begin
    if AnsiPos('DD', UpperCase(ShortDateFormat)) <> 0
        then DayFmt := 'DD'
        else DayFmt := 'D';
    if AnsiPos('MM', UpperCase(ShortDateFormat)) <> 0
        then MonthFmt := 'MM'
        else MonthFmt := 'M';
    if IncludeCentury or (AnsiPos('YYY', UpperCase(ShortDateFormat)) <> 0)
        then YearFmt := 'YYYY'
        else YearFmt := 'YY';

    case GetDateOrder of
        tsYMD: Result := YearFmt + DateSeparator + MonthFmt + DateSeparator + DayFmt;
        tsMDY: Result := MonthFmt + DateSeparator + DayFmt + DateSeparator + YearFmt;
        tsDMY: Result := DayFmt + DateSeparator + MonthFmt + DateSeparator + YearFmt;
    else
        Result := MonthFmt + DateSeparator + DayFmt + DateSeparator + YearFmt;
    end;
end;

function GetDateYearString(Value: string): string;
var
    DateOrder: Integer;
    SPos1, SPos2, SPos3: Integer;
    EPos1, EPos2, EPos3: Integer;
begin
    DateOrder := GetDateOrder;
    SPos1 := ScanToNum(Value, 1);
    EPos1 := ScanNum(Value, SPos1, 1);
    SPos2 := ScanToNum(Value, EPos1);
    EPos2 := ScanNum(Value, SPos2, 1);
    SPos3 := ScanToNum(Value, EPos2);
    EPos3 := ScanNum(Value, SPos3, 1);

    Result := '';
    case DateOrder of
        tsYMD:
            Result := Copy(Value, SPos1, EPos1 - SPos1);

        tsMDY, tsDMY:
            if (EPos3 > SPos3) and (SPos3 < Length(Value)) then
                Result := Copy(Value, SPos3, EPos3 - SPos3);
    end;
end;

function StringToDateTime(Value: string): TDateTime;
var
    CharPos: Integer;
    Y, M, D: Word;
    CurY, CurM, CurD: Word;
    DateStr, YearStr: string;
begin
    Value := Trim(Value);
    CharPos := ScanNum(Value, 1, 1);
    if CharPos > Length(Value) then
        Result := StrToInt(Value)
    else if (CharPos >= 1) and (Value[CharPos] = TimeSeparator) then
    begin
        Result := StrToTime(Value);
    end
    else
    begin
        DateStr := DateReplaceMonthName(Value);
        DateStr := DateRemoveDayName(DateStr);
        Result := StrToDateTime(DateStr);
        
        DecodeDate(Result, Y, M, D);
        DecodeDate(Date, CurY, CurM, CurD);
        if Y div 100 = CurY div 100 then
        begin
            YearStr := GetDateYearString(Value);
            if (Length(YearStr) > 2) then
            begin
                Y := StrToInt(Copy(YearStr, 1, 4));
                if Y > 0 then Result := EncodeDate(Y, M, D) + Frac(Result);
            end;
        end;
    end;
end;

function VariantToDateTime(Value: Variant): TDateTime;
begin
    if (VarType(Value) = varString) and (Trim(Value) <> '') then
    begin
        try
            Result := StringToDateTime(Value);
        except
            Result := Date + Time;
        end;
    end
    else if VarType(Value) in [varDate, varDouble] then
        Result := Value
    else
        Result := Date + Time;
end;

function LongYearFormat(Fmt: string): string;
var
    YearPos: Integer;
begin
    Result := Fmt;
    YearPos := Pos('YY', UpperCase(Fmt));
    if YearPos <> 0 then
    begin
        if (YearPos = Length(Fmt) - 1) or
           (not (Fmt[YearPos + 2] in ['y','Y'])) then
        begin
            Result := Copy(Fmt, 1, YearPos + 1) + 'yy' + Copy(Fmt, YearPos + 2, Length(Fmt));
        end;
    end;
end;

function LongHourFormat(Fmt: string): string;
var
    APos: Integer;
    AMPMStr: string;
begin
    Result := Fmt;

    AMPMStr := 'am/pm';
    APos := Pos(AMPMStr, LowerCase(Fmt));
    if APos = 0 then
    begin
        AMPMStr := 'a/p';
        APos := Pos(AMPMStr, LowerCase(Fmt));
    end;

    if APos = 0 then
    begin
        AMPMStr := 'ampm';
        APos := Pos(AMPMStr, LowerCase(Fmt));
    end;

    if APos <> 0 then
    begin
        Result := Trim(Copy(Fmt, 1, APos - 1) + Copy(Fmt, APos + Length(AMPMStr), Length(Fmt)));
    end;
end;

function AMPMFormat: Boolean;
begin
    Result := (TimeAMString <> '') or (TimePMString <> '');
end;

function FullWord(DateStr: string; StartPos, Len: Integer): Boolean;
var
    Chars: Integer;
begin
    Result := True;
    if StartPos > 1 then
    begin
        Chars := PrevCharCount(PChar(DateStr), StartPos - 1);
        if IsCharAlphaNumeric(DateStr[StartPos-Chars]) then Result := False;
    end;

    if Result and (StartPos + Len <= Length(DateStr)) then
    begin
        if IsCharAlphaNumeric(DateStr[StartPos + Len]) then Result := False;
    end;
end;

function DateReplaceMonthName(DateStr: string): string;
var
    CompStr: string;
    MPos, I, Len: Integer;
begin
    CompStr := UpperCase(DateStr);
    for I := 1 to 12 do
    begin
        Len := 0;
        MPos := AnsiPos(UpperCase(LongMonthNames[I]), CompStr);
        if MPos <> 0 then
            Len := Length(LongMonthNames[I])
        else
        begin
            MPos := AnsiPos(UpperCase(ShortMonthNames[I]), CompStr);
            if MPos <> 0 then Len := Length(ShortMonthNames[I]);
        end;

        if (MPos <> 0) and FullWord(DateStr, MPos, Len) then
        begin
            DateStr := Copy(DateStr, 1, MPos - 1) + IntToStr(I) +
                       Copy(DateStr, MPos + Len, Length(DateStr));
            Break;
        end;
    end;
    Result := DateStr;
end;

function DateRemoveDayName(DateStr: string): string;
var
    CompStr: string;
    DPos, I, Len: Integer;
begin
    CompStr := UpperCase(DateStr);
    for I := 1 to 7 do
    begin
        Len := 0;
        DPos := AnsiPos(UpperCase(LongDayNames[I]), CompStr);
        if DPos <> 0 then
            Len := Length(LongDayNames[I])
        else
        begin
            DPos := AnsiPos(UpperCase(ShortDayNames[I]), CompStr);
            if DPos <> 0 then Len := Length(ShortDayNames[I]);