tscommon.pas

企业进销存管理系统

    begin
        case Alignment of
            taLeftJustify: Result := htaLeft;
            taCenter: Result := htaCenter;
            taRightJustify: Result := htaRight;
        end;
    end;
end;

function HorzAlignmentToAlignment(HorzAlignment: TtsHorzAlignment): TAlignment;
begin
    Result := taLeftJustify;
    case HorzAlignment of
        htaDefault, htaLeft: Result := taLeftJustify;
        htaCenter: Result := taCenter;
        htaRight: Result := taRightJustify;
    end;
end;

function HorzAlignmentToAlign(HorzAlignment: TtsHorzAlignment): Boolean;
begin
    Result := HorzAlignment <> htaDefault;
end;

function GetMainHelpDir(Version: string): string;
var
    RegKey: string;
    MainDir: string;
begin
    Result := '';
    RegKey := '';
    if Length(Version) < 2 then Exit;

    if UpperCase(Version[1]) = 'D' then
    begin
        if Version[2] = '3' then
            RegKey := Delphi3RootDirKey
        else if Version[2] = '4' then
            RegKey := Delphi4RootDirKey
        else if Version[2] = '5' then
            RegKey := Delphi5RootDirKey;
    end
    else
    begin
        if Version[2] = '3' then
            RegKey := CBuilder3RootDirKey
        else if Version[2] = '4' then
            RegKey := CBuilder4RootDirKey;
    end;

    if RegKey <> '' then
    begin
        MainDir := GetRegStrValue(HKEY_LOCAL_MACHINE, RegKey, RootKeyName);
        Result := MainDir + '\' + HelpSubDir;
    end;
end;

function GetMainHelpFile(Version: string): string;
begin
    Result := '';
    if Length(Version) < 2 then Exit;

    if UpperCase(Version[1]) = 'D' then
    begin
        if Version[2] = '3' then
            Result := Delphi3Help
        else if Version[2] = '4' then
            Result := Delphi4Help
        else if Version[2] = '5' then
            Result := Delphi5Help;
    end
    else
    begin
        if Version[2] = '3' then
            Result := CBuilder3Help
        else if Version[2] = '4' then
            Result := CBuilder4Help;
    end;
end;

function GetHelpFile(CompilerVersion: string): string;
var
    HelpDir, FileName: string;
begin
    Result := '';
    HelpDir := GetMainHelpDir(CompilerVersion);
    FileName := GetMainHelpFile(CompilerVersion);
    if (HelpDir <> '') and (FileName <> '') then
        Result := HelpDir + '\' + FileName;
end;

function GetCompilerVersion: string;
begin
    Result := '';
    {$IFDEF TSVER_DELPHI}
        {$IFDEF TSVER_V5}
            Result := 'D5';
        {$ELSE} {$IFDEF TSVER_V4}
            Result := 'D4';
        {$ELSE} {$IFDEF TSVER_V3}
            Result := 'D3';
        {$ENDIF} {$ENDIF} {$ENDIF}
    {$ENDIF}

    {$IFDEF TSVER_CBUILD}
        {$IFDEF TSVER_V4}
            Result := 'C4';
        {$ELSE} {$IFDEF TSVER_V3}
            Result := 'C3';
        {$ENDIF} {$ENDIF}
    {$ENDIF}
end;

procedure ShowHelpTopic(Handle: Hdc; Key: string);
var
    HelpFile: string;
begin
    HelpFile := GetHelpFile(GetCompilerVersion);
    if HelpFile <> '' then
        WinHelp(Handle, PChar(HelpFile), HELP_KEY, Longint(PChar(Key)));
end;

function ScanNum(S: string; Pos: Integer; Direction: Integer): Integer;
var
    Chars: Integer;
begin
    Result := Pos;
    while (Result >= 1) and (Result <= Length(S)) do
    begin
        Chars := NextCharCount(PChar(S), Result - 1);
        if Chars > 1 then Break;
        if not (S[Result] in ['0'..'9']) then Break;
        Inc(Result, Direction);
    end;
end;

function ScanNumChars(S: string; Pos: Integer; Direction: Integer): Integer;
var
    Chars: Integer;
begin
    Result := Pos;
    while (Result >= 1) and (Result <= Length(S)) do
    begin
        Chars := NextCharCount(PChar(S), Result - 1);
        if Chars > 1 then Break;
        if not (S[Result] in ['0'..'9', ThousandSeparator, DecimalSeparator, '-', '+']) then Break;
        Inc(Result, Direction);
    end;
end;

function RemoveThousandsSeparator(var S: string): Boolean;
var
    Ok: Boolean;
    Pos: Integer;
    NewStr: string;
    PrevPos: Integer;
begin
    Result := False;
    NewStr := '';

    Ok := True;
    PrevPos := 0;
    while Ok do
    begin
        Pos := ScanNum(S, PrevPos + 1, 1);
        if (Pos > Length(S)) or (S[Pos] <> ThousandSeparator) then
        begin
            if (PrevPos <> 0) and (Pos - PrevPos <> 4)
                then Ok := False
                else NewStr := NewStr + Copy(S, PrevPos + 1, Length(S));
            Break;
        end;

        if S[Pos] <> ThousandSeparator then Break;
        if (PrevPos = 0) and (Pos <= 1) then
            Ok := False
        else if (PrevPos > 0) and (Pos - PrevPos <> 4) then
            Ok := False
        else
        begin
            NewStr := NewStr + Copy(S, PrevPos + 1, Pos - PrevPos - 1);
            PrevPos := Pos;
        end;
    end;

    if Ok then
    begin
        S := NewStr;
        Result := PrevPos <> 0;
    end;
end;

procedure InsertThousands(var S: string);
var
    Pos: Integer;
begin
    Pos := ScanNum(S, 1, 1);
    Pos := Pos - 3;
    while Pos > 1 do
    begin
        S := Copy(S, 1, Pos - 1) + ThousandSeparator + Copy(S, Pos, Length(S));
        Pos := Pos - 3;
    end;
end;

function IncStrNum(S: string; Increment: Double): string;
var
    Ok: Boolean;
    ExtValue: Extended;
    Value: Double;
    HasThousands: Boolean;
begin
    Value := 0;
    Ok := True;
    Result := S;

    if S = '' then
    begin
        HasThousands := False;
        Value := Increment;
    end
    else
    begin
        HasThousands := RemoveThousandsSeparator(S);
        Ok := TextToFloat(PChar(S), ExtValue, fvExtended);
        if Ok then
        begin
            Value := ExtValue;
            Value := Value + Increment;
        end;
    end;

    if Ok then
    begin
        Result := FloatToStr(Value);
        if HasThousands then InsertThousands(Result);
    end;
end;

function ValidNum(S: string): Boolean;
var
    Value: Extended;
    NumStr: string;
begin
    NumStr := S;
    RemoveThousandsSeparator(NumStr);
    Result := TextToFloat(PChar(NumStr), Value, fvExtended);
end;

function GetNumAtPos(S: string; Pos: Integer; var StartPos, Len: Integer): Boolean;
var
    SPos, EPos: Integer;
    NumStr: string;
    Chars: Integer;
begin
    Len := 0;
    StartPos := Pos;
    Result := False;

    if Pos <= 0 then
        Pos := 0
    else if Pos > Length(S) then
        Pos := Length(S);

    Chars := NextCharCount(PChar(S), Pos);
    SPos := ScanNumChars(S, Pos, -1) + 1;
    EPos := ScanNumChars(S, Pos + Chars, 1) - 1;
    if EPos < SPos then Exit;

    NumStr := Copy(S, SPos, EPos - SPos + 1);
    Result := ValidNum(NumStr);
    if Result then
    begin
        StartPos := SPos;
        Len := EPos - SPos + 1;
        Exit;
    end;

    SPos := ScanNum(S, Pos, -1) + 1;
    EPos := ScanNum(S, Pos + Chars, 1) - 1;
    if EPos < SPos then Exit;

    if (PrevCharCount(PChar(S), SPos - 1) = 1) and (S[SPos - 1] in ['-','+']) then
    begin
        if (SPos <= 2) then
            Dec(SPos)
        else if (PrevCharCount(PChar(S), SPos - 2) <> 1) or not (S[SPos - 2] in ['0'..'9']) then
            Dec(SPos);
    end;

    NumStr := Copy(S, SPos, EPos - SPos + 1);
    StartPos := SPos;
    Len := EPos - SPos + 1;
    Result := True;
end;

function IncStrAtPos(S: string; Increment: Extended; APos: Integer; var StartPos, Len: Integer): string;
var
    NumStr, IncNum: string;
begin
    Result := S;
    if not GetNumAtPos(S, APos, StartPos, Len) then Exit;

    NumStr := Copy(S, StartPos, Len);
    IncNum := IncStrNum(NumStr, Increment);
    if IncNum <> NumStr then
    begin
        IncNum := PadDecimals(NumStr, IncNum);
        Result := Copy(S, 1, StartPos - 1) + IncNum + Copy(S, StartPos + Len, Length(S));
        Len := Length(IncNum);
    end;
end;

function PadDecimals(Sample: string; NumStr: string): string;
var
    DPos, NumDPos: Integer;
begin
    DPos := Pos(DecimalSeparator, Sample);
    NumDPos := Pos(DecimalSeparator, NumStr);
    if DPos <> 0 then
    begin
        if NumDPos = 0 then
        begin
            NumStr := NumStr + DecimalSeparator;
            NumDPos := Length(NumStr);
        end;
        while Length(Sample) - DPos > Length(NumStr) - NumDPos do
            NumStr := NumStr + '0';
    end;
    Result := NumStr;
end;

function PadNumber(Sample: string; NumStr: string): string;
var
    DPos, NumDPos: Integer;
begin
    NumStr := PadDecimals(Sample, NumStr);

    DPos := Pos(DecimalSeparator, Sample);
    NumDPos := Pos(DecimalSeparator, NumStr);
    while Length(Sample) - DPos > Length(NumStr) - NumDPos do
    begin
        if Sample[Length(Sample) - Length(NumStr)] = ThousandSeparator then
            NumStr := ThousandSeparator + NumStr
        else
            NumStr := '0' + NumStr
    end;

    Result := NumStr;
end;

function ControlFocused(Control: TWinControl): Boolean;
var
    I: Integer;
begin
    Result := Control.Focused;
    if Result then Exit;

    for I := 1 to Control.ControlCount do
    begin
        if Control.Controls[I-1] is TWinControl then
        begin
            Result := ControlFocused(TWinControl(Control.Controls[I-1]));
            if Result then Break;
        end;
    end;
end;

function ControlVisible(Control: TWinControl): Boolean;
begin
    Result := Control.Visible;
    if not Result then Exit;

    if Control.Parent <> nil then
        Result := ControlVisible(Control.Parent);
end;

function IsControlHandle(Handle: Hwnd; Control: TWinControl): Boolean;
var
    I: Integer;
begin
    Result := False;
    if not Assigned(Control) then Exit;
    if not Control.HandleAllocated then Exit;

    Result := (Control.Handle = Handle);
    if Result then Exit;

    for I := 1 to Control.ControlCount do
    begin
        if Control.Controls[I-1] is TWinControl then
        begin
            Result := IsControlHandle(Handle, TWinControl(Control.Controls[I-1]));
            if Result then Break;
        end;
    end;
end;

{TtsMemoryCanvas}

constructor TtsMemoryCanvas.Create;
begin
    inherited;

    FDc := 0;
    FWidth := 0;
    FHeight := 0;
    FCount := 0;
    FMutex := 0;
    FLockingThreadId := 0;
    FLockingObject := nil;
end;

{TtsMemoryCanvas}

destructor TtsMemoryCanvas.Destroy;
begin
    if FMutex <> 0 then
        CloseHandle(Mutex);
    FreeDc;
    inherited;
end;

procedure TtsMemoryCanvas.Resize(Dc: Hdc; Width, Height: Integer);
var
    Bmp : HBITMAP;
    OldBmp : HBITMAP;
begin
    if (FWidth < Width) or (FHeight < Height) then
    begin
        FWidth := CalcMax(FWidth,Width);
        FHeight := CalcMax(FHeight,Height);
        Bmp := CreateCompatibleBitmap(Dc, FWidth, FHeight);
        OldBmp := SelectObject(FDc, Bmp);
        DeleteObject(OldBmp);
    end;
end;

procedure TtsMemoryCanvas.Prepare(Dc: Hdc; Width, Height: Integer);
var
    Bmp: HBITMAP;
begin