tsglib.pas

企业进销存管理系统

end;

procedure AdjustWidthForCRLF(Dc : HDC; Metric: TTextMetric; Text : PChar;
                             TextLen : Integer; var Width : Longint);
var
    RemainingChars : Integer;
    CharCount : Integer;
    PReturn : PChar;
    TextSize : TSize;
begin
    RemainingChars := TextLen;
    while RemainingChars > 0 do
    begin
        PReturn := StrNScanEol(Text, RemainingChars);
        if PReturn = nil then
            RemainingChars := 0
        else
        begin
            CharCount := NextCharCount(PReturn, 0);
            GetTextExtent(Dc, Metric, PReturn, CharCount, TextSize);
            Width := Width - TextSize.CX;

            GetTextExtent(Dc, Metric, RETURN_DISPLAY_CHAR, Length(RETURN_DISPLAY_CHAR), TextSize);
            Width := Width + TextSize.CX;

            RemainingChars := RemainingChars - (PReturn - Text) - CharCount;
            Text := PReturn + CharCount;
        end;
    end;
end;

procedure GetVisibleChars(Dc : HDC; Metric : TTextMetric; Text : PChar; TextLen : Integer;
                          DrawWidth : Integer; var Chars : Integer; var Width : Integer;
                          Align : TAlignment);
var
    TextSize : TSize;
    CharPos : PChar;
    CharCnt, EolPos : Integer;
begin
    if Align = taCenter then
        Chars := TextLen
    else
    begin
        Chars := DrawWidth div Metric.tmAveCharWidth;
        Chars := PCharToByteLen(Text, Chars, TextLen, (Align = taRightJustify));
    end;

    if Align in [taCenter, taLeftJustify] then
    begin
        if Chars > 0 then
        begin
            EolPos := Chars - 1;
            GetEofLine(Text, EolPos);
            if EolPos - (Chars - 1) > 1 then Chars := Chars - 1;
        end;

        GetTextExtent(Dc, Metric, Text, Chars, TextSize);
        AdjustWidthForCRLF(Dc, Metric, Text, Chars, TextSize.CX);
    end
    else
    begin
        if (Chars > 0) and (Chars < TextLen) then
        begin
            EolPos := TextLen - Chars - 1;
            GetEofLine(Text, EolPos);
            if EolPos - (TextLen - Chars - 1) > 1 then Chars := Chars - 1;
        end;

        GetTextExtent(Dc, Metric, Text + TextLen - Chars, Chars, TextSize);
        AdjustWidthForCRLF(Dc, Metric, Text + TextLen - Chars, Chars, TextSize.CX);
    end;

    Width := TextSize.CX;
    while (Width < DrawWidth) and (Chars < TextLen) do
    begin
        if Align in [taCenter, taLeftJustify] then
        begin
            CharCnt := NextCharCount(Text, Chars);
            CharPos := Text + Chars;
        end
        else
        begin
            CharCnt := PrevCharCount(Text, TextLen - Chars);
            CharPos := Text + TextLen - Chars - CharCnt;
        end;

        if EofLineChar(CharPos, 0) then
            GetTextExtent(Dc, Metric, RETURN_DISPLAY_CHAR, Length(RETURN_DISPLAY_CHAR), TextSize)
        else
            GetTextExtent(Dc, Metric, CharPos, CharCnt, TextSize);

        Width := Width + TextSize.CX;
        Chars := Chars + CharCnt;
    end;

    if Width > 0 then Width := Width + Metric.tmOverhang;
end;

procedure GetPrintCharWidth(Canvas : TCanvas; Metric: TTextMetric; Text : PChar;
                            Chars : Integer; MultiLine : Boolean;
                            WithOverhang: Boolean; var Width : Integer);
var
    PReturn : PChar;
    TextSize : TSize;
    RetChars : Integer;
begin
    Width := 0;

    while Chars > 0 do
    begin
        PReturn := StrNScanEol(Text, Chars);
        if PReturn = nil then
        begin
            GetTextExtent(Canvas.Handle, Metric, Text, Chars, TextSize);
            Width := Width + TextSize.CX;
            Chars := 0;
        end
        else
        begin
            GetTextExtent(Canvas.Handle, Metric, Text, PReturn - Text, TextSize);
            Width := Width + TextSize.CX;

            if not MultiLine then
            begin
                GetTextExtent(Canvas.Handle, Metric, RETURN_DISPLAY_CHAR, Length(RETURN_DISPLAY_CHAR), TextSize);
                Width := Width + TextSize.CX;
            end;

            RetChars := NextCharCount(PReturn, 0);
            Chars := Chars - (PReturn - Text) - RetChars;
            Text := PReturn + RetChars;
        end;
    end;

    if (Width > 0) and WithOverhang then Width := Width + Metric.tmOverhang;
end;

function LastCharIsEofLine(PText : PChar; Offset : Integer) : Boolean;
begin
    Result := false;
    if PText = nil then Exit;

    Offset := Offset - PrevCharCount(PText, Offset);
    Result := EofLineChar(PText, Offset);
end;

function IsMultiLineText(RowHeight : Integer; TextHeight : Integer) : Boolean;
begin
    Result := (RowHeight - TextHeight) >= (TextHeight div 3);
end;

procedure GetTextLines(Dc : Hdc; Text : PChar; RowHeight : Integer; DrawWidth : Integer;
                       Align : TAlignment; CanWordWrap: Boolean; var Lines : TtsIntegerList; MaxLines: Integer);
var
    Chars : Integer;
    TotalChars : Integer;
    Metric : TTextMetric;
    PText : PChar;
    TopOffset, LineSpacing: Integer;
begin
    GetTextMetrics(Dc, Metric);
    LineSpacing := TextLineSpacing(Metric);
    TopOffset := LineSpacing;

    if Text = nil then Text := '';

    Lines.Clear;
    if (not CanWordWrap) or (not IsMultiLineText(RowHeight - TopOffset, Metric.tmHeight + LineSpacing)) then
        Lines.AddItem(0)
    else
    begin
        PText := Text;
        TotalChars := 0;

        while GetNextLine(Dc, Metric, PText, DrawWidth - 1, Align, Chars) and
              ((Lines.Count < MaxLines) or (MaxLines = 0)) do
        begin
            Lines.AddItem(TotalChars);

            TotalChars := TotalChars + Chars;
            PText := PText + Chars;
        end;

        if Lines.Count = 0 then
            Lines.AddItem(0)
        else if LastCharIsEofLine(Text, TotalChars) then
            Lines.AddItem(TotalChars);
    end;
end;

procedure GetTextHeight(Dc : Hdc; Text : PChar; DrawWidth : Integer;
                        Align : TAlignment; CanWordWrap: Boolean;
                        var TextLines, TextHeight: Integer);
var
    Chars : Integer;
    TotalChars : Integer;
    Metric : TTextMetric;
    PText : PChar;
begin
    TextLines := 0;
    GetTextMetrics(Dc, Metric);
    if Text = nil then Text := '';

    if (not CanWordWrap) then
        TextLines := 1
    else
    begin
        PText := Text;
        TotalChars := 0;

        while GetNextLine(Dc, Metric, PText, DrawWidth - 1, Align, Chars) do
        begin
            Inc(TextLines);
            TotalChars := TotalChars + Chars;
            PText := PText + Chars;
        end;

        if TextLines = 0 then
            TextLines := 1
        else if LastCharIsEofLine(Text, TotalChars) then
            Inc(TextLines)
    end;

    TextHeight := TextLines * (Metric.tmHeight + TextLineSpacing(Metric));
end;

procedure FillPolyRect(Canvas: TCanvas; Metric: TTextMetric;
                       TextRect, ClipRect: TRect; SelColor: TColor);
var
    Bitmap: TBitmap;
    ToRect, FromRect: TRect;
    Overhang: Integer;
    PolyRect: TPolyRect;
begin
    Bitmap := TBitmap.Create;
    try
        Overhang := 0;
        if fsItalic in Canvas.Font.Style then Overhang := Metric.tmOverhang;
        if (Overhang > 0) and (fsBold in Canvas.Font.Style) then Dec(Overhang); 

        Bitmap.Width := TextRect.Right - TextRect.Left + Overhang;
        Bitmap.Height := TextRect.Bottom - TextRect.Top;

        FromRect := Rect(0, 0, Bitmap.Width, Bitmap.Height);
        Bitmap.Canvas.Brush := Canvas.Brush;
        Bitmap.Canvas.FillRect(FromRect);

        Bitmap.Canvas.Pen.Color := SelColor;
        Bitmap.Canvas.Pen.Width := 1;
        Bitmap.Canvas.Brush.Color := SelColor;

        PolyRect[1].X := Overhang;
        PolyRect[1].Y := 0;
        PolyRect[2].X := Bitmap.Width - 1;
        PolyRect[2].Y := 0;
        PolyRect[3].X := Bitmap.Width - 1 - Overhang;
        PolyRect[3].Y := Bitmap.Height - 1;
        PolyRect[4].X := 0;
        PolyRect[4].Y := Bitmap.Height - 1;

        Bitmap.Canvas.Polygon(Slice(PolyRect, 4));

        ToRect.Left := TextRect.Left;
        ToRect.Top := TextRect.Top;
        ToRect.Right := ToRect.Left + Bitmap.Width;
        if ToRect.Right > ClipRect.Right then
        begin
            FromRect.Right := FromRect.Right - (ToRect.Right - ClipRect.Right);
            ToRect.Right := ClipRect.Right;
        end;

        ToRect.Bottom := ToRect.Top + Bitmap.Height;
        if ToRect.Bottom > ClipRect.Bottom then
        begin
            FromRect.Bottom := FromRect.Bottom - (ToRect.Bottom - ClipRect.Bottom);
            ToRect.Bottom := ClipRect.Bottom;
        end;

        Canvas.CopyRect(ToRect, Bitmap.Canvas, FromRect);
    finally
        Bitmap.Free;
    end;
end;

procedure DisplayTextWithSelect(Canvas : TCanvas; Metric: TTextMetric;
                                Text : PChar; Chars : Integer; TextRect : TRect;
                                Left, Top : Integer; SelStart, SelLength : Integer;
                                SelColor, SelFontColor : TColor; AccelPos: Integer;
                                LineSpacing: Integer);
var
    Options : Integer;
    StartTextSize, SelTextSize : TSize;
    Rect : TRect;
    OldBkMode: Integer;
    OldFontColor: TColor;
begin
    if TextRect.Left > TextRect.Right then Exit;

    if SelStart < 0 then
    begin
        SelLength := SelLength + SelStart;
        SelStart := 0;
    end;

    OldBkMode := Windows.SetBkMode(Canvas.Handle, TRANSPARENT);
    if (SelLength <= 0) or (SelStart >= Chars) then
    begin
        Options := ETO_CLIPPED;
        TextOutAccel(Canvas, Metric, Left, Top, Options, @TextRect, Text, Chars,
                     nil, AccelPos)
    end
    else
    begin
        OldFontColor := Canvas.Font.Color;

        if SelStart + SelLength > Chars then SelLength := Chars - SelStart;
        GetTextExtent(Canvas.Handle, Metric, Text, SelStart, StartTextSize);
        GetTextExtent(Canvas.Handle, Metric, Text + SelStart, SelLength, SelTextSize);

        Rect := TextRect;
        Rect.Left := Left + StartTextSize.CX;
        Rect.Right := Rect.Left + SelTextSize.CX;
        Rect.Bottom := Rect.Top + Metric.tmHeight + LineSpacing;
        if Rect.Left < TextRect.Left then Rect.Left := TextRect.Left;
        if (SelLength > 0) and (Rect.Left <= Rect.Right) then
        begin
            FillPolyRect(Canvas, Metric, Rect, TextRect, SelColor);
        end;

        Options := ETO_CLIPPED;
        ExtTextOut(Canvas.Handle, Left, Top, Options, @TextRect, Text, SelStart, nil);

        Canvas.Font.Color := SelFontColor;
        Windows.SetBkMode(Canvas.Handle, TRANSPARENT);
        Left := Left + StartTextSize.CX;
        ExtTextOut(Canvas.Handle, Left, Top, Options, @TextRect, Text + SelStart, SelLength, nil);

        Canvas.Font.Color := OldFontColor;
        Windows.SetBkMode(Canvas.Handle, TRANSPARENT);
        Left := Left + SelTextSize.CX;
        ExtTextOut(Canvas.Handle, Left, Top, Options, @TextRect, Text + SelStart + SelLength, Chars - SelStart - SelLength, nil);
    end;

    Windows.SetBkMode(Canvas.Handle, OldBkMode);
end;

procedure DisplayTextLineSingle(Canvas : TCanvas; Metric : TTextMetric; Text : PChar;
                                TextLen : Integer; TextOffset: Integer; TextRect : TRect;
                                Left, Top : Integer; SelStart, SelLength : Integer;
                                SelColor, SelFontColor : TColor; Align : TAlignment;
                                VertAlign: TtsVertAlignment; AccelPos: Integer);
var
    Chars : Integer;
    PrintChars : Integer;
    PrintWidth : Integer;
    ARect, ClipRect : TRect;
    PReturn : PChar;
    TextSize : TSize;
    LeftOffset : Integer;
    CanCenter: Boolean;
    LineSpacing: Integer;
begin
    LineSpacing := TextLineSpacing(Metric);
    ARect := TextRect;
    ARect.Top := Top;
    ClipRect := ARect;
    if Left > ClipRect.Left then ClipRect.Left := Left;

    Canvas.FillRect(TextRect);
    if VertAlign in [vtaDefault, vtaTop] then
    begin
        if (SelLength > 0) and (ARect.Bottom > ARect.Top + Metric.tmHeight + LineSpacing) then
        begin
            ARect.Bottom := ARect.Top + Metric.tmHeight + LineSpacing;
            ClipRect.Bottom := ClipRect.Top + Metric.tmHeight + LineSpacing;
        end
    end
    else if VertAlign = vtaBottom then
    begin
        Top := ARect.Bottom - Metric.tmHeight;
        if (SelLength > 0) and (ARect.Bottom > ARect.Top + Metric.tmHeight + LineSpacing) then
        begin
            ARect.Top := Top;
            ClipRect.Top := Top;
        end;
    end
    else if VertAlign = vtaCenter then
    begin
        if ARect.Bottom - ARect.Top > Metric.tmHeight + 1 then
            Top := Top + (ARect.Bottom - ARect.Top - Metric.tmHeight) div 2;

        if (SelLength > 0) and (ARect.Bottom > Top + Metric.tmHeight + LineSpacing) then
        begin
            ARect.Top := Top;
            ARect.Bottom := ARect.Top + Metric.tmHeight + LineSpacing;
            ClipRect.Top := Top;
            ClipRect.Bottom := ClipRect.Top + Metric.tmHeight + LineSpacing;
        end;
    end;

    if Align = taLeftJustify then
    begin
        Text := Text + TextOffset;
        TextLen := TextLen - TextOffset;
        SelStart := SelStart - TextOffset;
        GetVisibleChars(Canvas.Handle, Metric, Text, TextLen, ARect.Right - Left,
                        PrintChars, PrintWidth, Align);
    end
    else if Align = taRightJustify then
    begin
        GetVisibleChars(Canvas.Handle, Metric, Text, TextLen, ARect.Right - Left,
                        PrintChars, PrintWidth, Align);
        PrintWidth := PrintWidth + RIGHT_PRINT_MARGIN;

        if (PrintWidth > ARect.Right - Left) and (Left <> ARect.Left) then
        begin