tscommon.pas

企业进销存管理系统

        end;

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

function SeparateCheckBoxValues(CheckBoxValues: string; var StrChecked, StrUnchecked, StrGrayed: string): Boolean;
var
    P, S: PChar;
    Separator: string;
begin
    Result := True;
    StrChecked := '';
    StrUnchecked := '';
    StrGrayed := '';
    if Length(CheckBoxValues) = 0 then Exit;

    S := PChar(CheckBoxValues);
    Separator := CheckBoxValueSeparator;
    P := AnsiStrPos(S, PChar(Separator));
    if P = nil then
        StrChecked := CheckBoxValues
    else
    begin
        StrChecked := Copy(CheckBoxValues, 1, Integer(P) - Integer(S));
        S := P + 1;
        P := AnsiStrPos(S, PChar(Separator));
        if P = nil then
            StrUnchecked := Copy(CheckBoxValues, Integer(S) - Integer(PChar(CheckBoxValues)) + 1, Length(CheckBoxValues))
        else
        begin
            StrUnchecked := Copy(CheckBoxValues, Integer(S) - Integer(PChar(CheckBoxValues)) + 1, Integer(P) - Integer(S));
            S := P + 1;
            P := AnsiStrPos(S, PChar(Separator));
            if P = nil then
                StrGrayed := Copy(CheckBoxValues, Integer(S) - Integer(PChar(CheckBoxValues)) + 1, Length(CheckBoxValues))
            else
                StrGrayed := Copy(CheckBoxValues, Integer(S) - Integer(PChar(CheckBoxValues)) + 1, Integer(P) - Integer(S));
        end;
    end;

    Result := (strUnchecked <> '') and (P = nil);
end;

function CheckBoxValuesOk(CheckBoxValues: string): Boolean;
var
    StrChecked, StrUnchecked, StrGrayed: string;
begin
    Result := SeparateCheckBoxValues(CheckBoxValues, StrChecked, StrUnchecked, StrGrayed);
end;

function CheckBoxToString(Value: TCheckBoxState; CheckBoxValues: string): string;
var
    StrChecked, StrUnchecked, StrGrayed: string;
begin
    Result := '';
    SeparateCheckBoxValues(CheckBoxValues, StrChecked, StrUnchecked, StrGrayed);
    case Value of
        cbChecked: Result := StrChecked;
        cbUnchecked: Result := StrUnchecked;
        cbGrayed: Result := StrGrayed;
    end;
end;

function StringToCheckBox(Value: string; CheckBoxValues: string): TCheckBoxState;
var
    StrChecked, StrUnchecked, StrGrayed: string;
begin
    Result := cbGrayed;
    if Length(CheckBoxValues) = 0 then Exit;

    SeparateCheckBoxValues(CheckBoxValues, StrChecked, StrUnchecked, StrGrayed);
    if AnsiCompareText(Value, StrChecked) = 0 then
        Result := cbChecked
    else if AnsiCompareText(Value, StrUnchecked) = 0 then
        Result := cbUnchecked
    else
        Result := cbGrayed;
end;

function CheckBoxToVariant(Value: TCheckBoxState; CheckBoxValues: string): Variant;
var
    StrChecked, StrUnchecked, StrGrayed: string;
begin
    Result := '';
    if Length(CheckBoxValues) = 0 then
    begin
      Result := Value;
      Exit;
    end;

    SeparateCheckBoxValues(CheckBoxValues, StrChecked, StrUnchecked, StrGrayed);
    case Value of
        cbChecked: Result := StrChecked;
        cbUnchecked: Result := StrUnchecked;
        cbGrayed: Result := StrGrayed;
    end;

    if AnsiCompareText(Result, StrCheckBoxNull) = 0 then Result := Null;
end;

function VariantToCheckBox(Value: Variant; CheckBoxValues: string): TCheckBoxState;
var
    StrChecked, StrUnchecked, StrGrayed: string;
begin
    if VarType(Value) = varString then
        Result := StringToCheckBox(Value, CheckBoxValues)
    else if VarType(Value) = varInteger then
        Result := Value
    else if VarIsNull(Value) then
    begin
        SeparateCheckBoxValues(CheckBoxValues, StrChecked, StrUnchecked, StrGrayed);
        if StrChecked = StrCheckBoxNull then
            Result := cbChecked
        else if StrUnchecked = StrCheckBoxNull then
            Result := cbUnchecked
        else
            Result := cbGrayed;
    end
    else
        Result := cbGrayed;
end;

function ResourceStr(StrCode: Variant): string;
begin
    if VarType(StrCode) = varInteger then
        Result := LoadStr(StrCode)
    else
        Result := StrCode
end;

function TextAccelKey(Value: string; var AccelKeyPos: Integer): string;
var
    CurPos: Integer;
    AccelStr: PChar;
begin
    Result := Value;
    AccelKeyPos := 0;

    AccelStr := AnsiStrNScan(PChar(Value), '&', Length(Value));
    if AccelStr <> nil then CurPos := AccelStr - PChar(Value) + 1
                       else CurPos := 0;
    if CurPos = 0 then Exit;

    Result := '';
    while CurPos <> 0 do
    begin
        if (CurPos < Length(Value)) and (Value[CurPos + 1] <> '&') then
            if AccelKeyPos = 0 then AccelKeyPos := Length(Result) + CurPos;

        Result := Result + Copy(Value, 1, CurPos - 1);
        if CurPos + 1 <= Length(Value) then Result := Result + Value[CurPos + 1];

        if CurPos + 2 <= Length(Value)
            then Value := Copy(Value, CurPos + 2, Length(Value) - (CurPos + 1))
            else Value := '';

        AccelStr := AnsiStrNScan(PChar(Value), '&', Length(Value));
        if AccelStr <> nil then CurPos := AccelStr - PChar(Value) + 1
                           else CurPos := 0;
    end;

    Result := Result + Value;
end;

procedure SeparateFirstPart(var Remainder, Item: string; Separator: string);
var
    Position: integer;

begin
    Position := AnsiPos(Separator, Remainder);
    if Position = 0 then
    begin
        Item := Remainder;
        Remainder := '';
    end
    else
    begin
        Item := System.Copy(Remainder, 1, Position - 1);
        Remainder := System.Copy(Remainder, Position + Length(Separator), Length(Remainder) - Position - Length(Separator) + 1);
    end;
end;

function AddPictureIds(Value: string; ImageListIndex, ImageId: Integer): string;
begin
    Result := Value + IdSeparator + IntToStr(ImageListIndex) + IdSeparator + IntToStr(ImageId);
end;

function SeparatePictureIds(Value: string; var ComponentId, ImageId: Integer): string;
var
    strValue, strCompId, strImageId: string;
begin
    strValue := Value;
    ComponentId := -1;
    ImageId := -1;
    SeparateFirstPart(strValue, Result, IdSeparator);
    if Length(strValue) > 0 then
    begin
        SeparateFirstPart(strValue, strCompId, IdSeparator);
        SeparateFirstPart(strValue, strImageId, IdSeparator);
        ComponentId := StrToInt(strCompId);
        ImageId := StrToInt(strImageId);
    end;
end;

function GetPropertyList(Obj: TObject; TypeKinds: TTypeKinds; var PropCount: Integer): PPropList;
begin
    PropCount := GetPropList(Obj.ClassInfo, TypeKinds, nil);
    GetMem(Result, PropCount * SizeOf(PPropInfo));
    GetPropList(Obj.ClassInfo, TypeKinds, Result);
end;

procedure FreePropertyList(PropList: PPropList; PropCount: Integer);
begin
    FreeMem(PropList, PropCount * SizeOf(PPropInfo));
end;

procedure AssignPropertyValue(PropInfo: PPropInfo; ToObject, FromObject: TObject);
begin
    case PropInfo^.PropType^.Kind of
        tkChar, tkWChar, tkEnumeration, tkSet, tkInteger, tkClass:
            SetOrdProp(ToObject, PropInfo, GetOrdProp(FromObject, PropInfo));

        tkFloat:
            SetFloatProp(ToObject, PropInfo, GetFloatProp(FromObject, PropInfo));

        tkMethod:
            SetMethodProp(ToObject, PropInfo, GetMethodProp(FromObject, PropInfo));

        tkString, tkLString:
            SetStrProp(ToObject, PropInfo, GetStrProp(FromObject, PropInfo));

        {$IFDEF TSVER_V3}
        tkWString:
            SetStrProp(ToObject, PropInfo, GetStrProp(FromObject, PropInfo));
        {$ENDIF}

        tkVariant:
            SetVariantProp(ToObject, PropInfo, GetVariantProp(FromObject, PropInfo));

    end;
end;

procedure AssignNameValue(PropName: string; ToObject, FromObject: TObject);
var
    PropInfo: PPropInfo;
begin
    PropInfo := GetPropInfo(FromObject.ClassInfo, PropName);
    if Assigned(PropInfo) then AssignPropertyValue(PropInfo, ToObject, FromObject);
end;

function StringInList(PName: PShortString; List: TStringList): Boolean;
var
    I, CompRes, iMaxLen: Integer;
begin
    Result := False;
    if List = nil then Exit;

    if not List.Sorted then List.Sorted := True;

    for I := 1 to List.Count do
    begin
        iMaxLen := Length(PName^);
        if Length(PChar(List[I-1])) < iMaxLen then
           iMaxLen := Length(PChar(List[I-1]));
        CompRes := AnsiStrLIComp(PChar(@PName^[1]),  PChar(List[I-1]), iMaxLen);
        if (CompRes = 0) and (Length(PName^) = Length(List[I-1])) then Result := True;
        if CompRes <= 0 then Break;
    end;
end;

function CreateStringList(Strings: string): TStringList;
var
    APos: Integer;
    Str: string;
begin
    Result := TStringList.Create;
    APos := Pos(';', Strings);
    while APos <> 0 do
    begin
        Str := Trim(Copy(Strings, 1, APos - 1));
        if Str <> '' then Result.Add(Str);

        Strings := Trim(Copy(Strings, APos + 1, Length(Strings)));
        APos := Pos(';', Strings);
    end;
    if Length(Strings) <> 0 then Result.Add(Trim(Strings));
end;

procedure AssignObject(ToObject, FromObject: TObject; NoAssignProps: string);
var
    I: Integer;
    Count: Integer;
    PropList: PPropList;
    PName: PShortString;
    ExcludeProps: TStringList;
begin
    ExcludeProps := CreateStringList(NoAssignProps);
    try
        PropList := GetPropertyList(FromObject, tkProperties, Count);
        try
            for I := 0 to Count - 1 do
            begin
              PName := @PropList[I]^.Name;
              if not StringInList(PName, ExcludeProps) then
                 AssignPropertyValue(PropList[I], ToObject, FromObject);
            end;
        finally
            FreePropertyList(PropList, Count);
        end;
    finally
        ExcludeProps.Free;
    end;
end;

function GetRootKey(const Key: string; var RootKey: HKey; var Root, SubKey: string): Boolean;
var
    APos : Integer;
begin
    Result := True;
    RootKey := 0;
    Root := '';
    SubKey := '';
    if (Length(Key) < 2) or (Copy(Key, 1, 2) <> '\\') then
    begin
        SubKey := Key;
        Exit;
    end;

    SubKey := Copy(Key, 3, Length(Key));
    APos := Pos('\', SubKey);
    if APos <> 0 then
    begin
        Root := UpperCase(Copy(SubKey, 1, APos - 1));
        SubKey := Copy(SubKey, APos, Length(SubKey));
    end
    else
    begin
        Root := UpperCase(SubKey);
        SubKey := '';
    end;

    if Root = StrHKEY_CLASSES_ROOT then RootKey := HKEY_CLASSES_ROOT
    else if Root = StrHKEY_CURRENT_USER then RootKey := HKEY_CURRENT_USER
    else if Root = StrHKEY_LOCAL_MACHINE then RootKey := HKEY_LOCAL_MACHINE
    else if Root = StrHKEY_USERS then RootKey := HKEY_USERS;

    Result := RootKey <> 0;
end;

function OpenRegistryKey(const Key: string; CanCreate: Boolean): TRegistry;
var
    Registry: TRegistry;
    RootKey: HKey;
    Root, SubKey: string;
begin
    if not GetRootKey(Key, RootKey, Root, SubKey) then
        raise ERegistryException.CreateFmt(StsUnknownRegistryKey, [Root]);

    Registry := TRegistry.Create;
    if RootKey <> 0 then
        Registry.RootKey := RootKey;

    if SubKey = '' then SubKey := '\';
    if CanCreate and not Registry.KeyExists(SubKey) then
    begin
        Registry.CreateKey(SubKey);
        Registry.LazyWrite := False;
        Registry.CloseKey;
        Registry.LazyWrite := True;
    end;

    if not Registry.OpenKey(SubKey, False) then
    begin
        Registry.Free;
        Registry := nil;
    end;

    Result := Registry;
end;

function GetRegStrValue(RootKey: HKey; const Key: string; const ValueName: string): string;
var
    Registry: TRegistry;
    Opened: Boolean;
begin
    Result := '';
    Registry := TRegistry.Create;
    try
        Registry.RootKey := RootKey;
        Opened := Registry.OpenKey(Key, False);
        try
            if Opened then
            begin
                if Registry.ValueExists(ValueName) then
                    Result := Registry.ReadString(ValueName);
            end;
        finally
            if Opened then Registry.CloseKey;
        end;
    finally
        Registry.Free;
    end;
end;

procedure InitCanvas(Canvas: TCanvas);
var
    Bmp: TBitmap;
begin
    //Procedure to provide a work-around for a Delphi canvas bug. If BrushCopy
    //is called prior to calling other Draw methods, BrushCopy will not operate
    //correctly. Call this method to initialize the canvas so drawing will
    //be correct. For each canvas, this only needs to be called once.

    Bmp := TBitmap.Create;
    try
    {$IFDEF TSVER_V3}
        Bmp.PixelFormat:=pf32bit;
    {$ENDIF}
        Bmp.Height:=1;
        Bmp.Width:=1;
        Canvas.Draw(0, 0, Bmp);
    finally
        Bmp.Free;
    end;
end;

procedure FreeNil(var AObject: TObject);
begin
    AObject.Free;
    AObject := nil;
end;

function AlignmentToHorzAlignment(Alignment: TAlignment; Align: Boolean): TtsHorzAlignment;
begin
    Result := htaDefault;
    if Align then