ucommon.pas

这是一个股票盘后数据分析系统基础底层,已经实现了基本的K线图的重现,RIS线,均线图的重现, 是在一个台湾高手发布的原码上修改的,现在支持通达信的股票数据格式.

          Result := Result + Src[I];
      end;
    end;
  end;
end;

function _extractDealTime_(Src: string): TDateTime;
begin
  Result := 0;
  Src := _extractStkData_(Src, FILTER_KEY_STKDATA, '</td>');
  if (Src <> '') and (Src <> '－') then
  begin
    Src := Src + ':00';
    Result := Int(Now) + Frac(StrToDateTime(Src));
  end;
end;

function _extractDeal_(Src: string): Single;
begin
  Result := 0;
  Src := _extractStkData_(Src, FILTER_KEY_STKDATA + '<b>', '</b></td>');
  if (Src <> '') and (Src <> '－') then
    Result := StrToFloat(Src);
end;

function _extractValue_(Src: string): Single;
begin
  Result := 0;
  Src := _extractStkData_(Src, FILTER_KEY_STKDATA, '</td>');
  if (Src <> '') and (Src <> '－') then
    Result := StrToFloat(Src);
end;

function _extractDiff_(Src: string): Single;
begin
  Result := 0;
  Src := _extractStkData_(Src, FILTER_KEY_STKDATA + '<font color=', '</font></td>', False);
  Src := Copy(Src, 9, Length(Src) - 8);
  if (Src <> '') and (Src <> '－') then
  begin
    if Pos('△', Src) > 0 then Src := Copy(Src, 3, Length(Src) - 2)
    else if Pos('▲', Src) > 0 then Src := Copy(Src, 3, Length(Src) - 2)
    else if Pos('▽', Src) > 0 then Src := '-' + Copy(Src, 3, Length(Src) - 2)
    else if Pos('▼', Src) > 0 then Src := '-' + Copy(Src, 3, Length(Src) - 2);
    Result := StrToFloat(Src);
  end;
end;

function AdjustStkName(S: string): string;
begin
  if Pos(' ', S) > 0 then
    S := ElimitBlankStr(S);
  if Length(S) = 4 then
    Result := Copy(S, 1, 2) + '　' + Copy(S, 3, 2) else Result := S;
end;

function ElimitBlankStr(S: string): string;
var
  I                 : Integer;
begin
  Result := '';
  for I := 1 to Length(S) do
  begin
    if S[I] <> #$20 then
      Result := Result + S[I];
  end;
end;

function _format_(Precise: Integer): string;
begin
  Result := '%.' + IntToStr(Precise) + 'f';
end;

function _vs_(Value: Extended; Precise: Integer; ShowZero, Signed: Boolean): string;
begin
  Result := '';
  if (Value = 0) and (not ShowZero) then
    Exit;
  Result := Format(_format_(Precise), [Value]);
  if Signed and (Value > 0) then
    Result := '+' + Result;
end;

procedure _textRect_(Canvas: TCanvas; Rect: TRect; Str: string; fgColor, bgColor: TColor;
  Alignment: TAlignment; Layout: TTextLayout; Transparent: Boolean);
var
  IsChinese         : Boolean;
  I, OFH            : Integer;
  OFN               : string;
begin
  OFH := Canvas.Font.Height;
  OFN := Canvas.Font.Name;
  try
    Canvas.Font.Color := fgColor;
    Canvas.Brush.Color := bgColor;

    IsChinese := False;
    if (Str = '') or (Str = '.') or (Str = '↑') or (Str = '↓') or (Str = '.') then
      Canvas.Font.Name := '宋体'
    else begin
      I := 1;
      while I < Length(Str) do
      begin
        IsChinese := Ord(Str[I]) > 127;
        if IsChinese then Break;
        Inc(I);
      end;
      Canvas.Font.Name := _if_(IsChinese, OFN, FONT_DIGIT);
    end;

    if (not Transparent) then
      Canvas.FillRect(Rect);

    if IS_CHINESE_AUTOCOLOR and IsChinese then
    begin
      {}
    end
    else if IS_FRACTION_UNDERLINE and not IsChinese then
    begin
      Canvas.Font.Style := Canvas.Font.Style - [fsBold];
      case Alignment of
        taLeftJustify: DRAW_UNDERLINE_ALIGNLEFT(Canvas, Rect, Str, fgColor, bgColor, Alignment, Layout);
        taRightJustify: DRAW_UNDERLINE_ALIGNRIGHT(Canvas, Rect, Str, fgColor, bgColor, Alignment, Layout);
      else
        DRAW_UNDERLINE_ALIGNCENTER(Canvas, Rect, Str, fgColor, bgColor, Alignment, Layout);
      end;
    end
    else
      DrawText(Canvas.Handle, PChar(Str), -1, Rect, _textRect_fmt_(Alignment, Layout));

  finally
    Canvas.Font.Height := OFH;
    Canvas.Font.Name := OFN;
  end;
end;

function _textRect_fmt_(Alignment: TAlignment; Layout: TTextLayout = tlCenter): Cardinal;
begin
  Result := DT_SINGLELINE;
  case (Alignment) of
    taLeftJustify: Result := Result or DT_LEFT;
    taRightJustify: Result := Result or DT_RIGHT;
  else
    Result := Result or DT_CENTER;
  end;

  case (Layout) of
    tlTop: Result := Result or DT_TOP;
    tlBottom: Result := Result or DT_BOTTOM;
  else
    Result := Result or DT_VCENTER;
  end;
end;

procedure DRAW_UNDERLINE_ALIGNLEFT(Canvas: TCanvas; Rect: TRect; Str: string; fgColor: TColor;
  bgColor: TColor; Alignment: TAlignment; Layout: TTextLayout);
var
  I, OFH            : Integer;
  S1, S2, S3        : string;
  R1, R2, R3, TR    : TRect;
begin
  OFH := Canvas.Font.Height;
  I := Pos('.', Str);
  if I < 1 then
    DrawText(Canvas.Handle, PChar(Str), -1, Rect, _textRect_fmt_(Alignment, Layout))
  else
  begin
    S1 := Copy(Str, 1, I - 1);
    S2 := Copy(Str, I + 1, Length(Str) - I);
    S3 := '';
    with Canvas, Rect do
      R1 := Classes.Rect(Left, Top, Left + TextWidth(S1), Bottom);

    SubtractRect(R2, Rect, R1);
    Canvas.Font.Height := OFH * 7 div 10;
    if (Length(S2) > 1) and (S2[Length(S2)] in ['%']) then
    begin
      S2 := Copy(S2, 1, Length(S2) - 1);
      S3 := '%';
      TR := R2;
      with Canvas, TR do
        R2 := Classes.Rect(Left, Top, Left + TextWidth(S2), Bottom);

      SubtractRect(R3, TR, R2);
    end;

    R2.Bottom := R2.Bottom - 3;

    for I := 1 to 3 do
    begin
      Canvas.Font.Style := Canvas.Font.Style - [fsUnderLine];
      if I = 2 then
        Canvas.Font.Style := Canvas.Font.Style + [fsUnderLine];

      Canvas.Font.Height := _if_(I in [2, 3], OFH * 7 div 10, OFH);
      case I of
        1: DrawText(Canvas.Handle, PChar(S1), -1, R1, _textRect_fmt_(Alignment, Layout));
        2: DrawText(Canvas.Handle, PChar(S2), -1, R2, _textRect_fmt_(Alignment, Layout));
        3: begin
            if S3 <> '' then
              DrawText(Canvas.Handle, PChar(S3), -1, R3, _textRect_fmt_(Alignment, Layout));
          end;
      end;

    end;
  end;
end;

procedure DRAW_UNDERLINE_ALIGNRIGHT(Canvas: TCanvas; Rect: TRect; Str: string; fgColor: TColor;
  bgColor: TColor; Alignment: TAlignment; Layout: TTextLayout);
var
  I, OFH            : Integer;
  S1, S2, S3        : string;
  R1, R2, R3        : TRect;
begin
  OFH := Canvas.Font.Height;
  I := Pos('.', Str);
  if I < 1 then
    DrawText(Canvas.Handle, PChar(Str), -1, Rect, _textRect_fmt_(Alignment, Layout))
  else
  begin
    S1 := Copy(Str, 1, I - 1);
    S2 := Copy(Str, I + 1, Length(Str) - I);
    S3 := '';
    Canvas.Font.Height := OFH * 7 div 10;
    with Canvas, Rect do
      R2 := Classes.Rect(Left + _width_(Rect) - TextWidth(S2), Top, Right, Bottom);

    SubtractRect(R1, Rect, R2);
    if (Length(S2) > 1) and (S2[Length(S2)] in ['%']) then
    begin
      S2 := Copy(S2, 1, Length(S2) - 1);
      S3 := '%';
      with Canvas, R2 do
        R3 := Classes.Rect(Left + _width_(R2) - TextWidth(S3), Top, Right, Bottom);

      SubtractRect(R2, R2, R3);
    end;

    R2.Bottom := R2.Bottom - 3;

    for I := 1 to 3 do
    begin
      Canvas.Font.Style := Canvas.Font.Style - [fsUnderLine];
      if I = 2 then
        Canvas.Font.Style := Canvas.Font.Style + [fsUnderLine];

      Canvas.Font.Height := _if_(I in [2, 3], OFH * 7 div 10, OFH);
      case I of
        1: DrawText(Canvas.Handle, PChar(S1), -1, R1, _textRect_fmt_(Alignment, Layout));
        2: DrawText(Canvas.Handle, PChar(S2), -1, R2, _textRect_fmt_(Alignment, Layout));
        3: begin
            if S3 <> '' then
              DrawText(Canvas.Handle, PChar(S3), -1, R3, _textRect_fmt_(Alignment, Layout)); //在这里控制所有边界输入的字体大小与颜色
          end;
      end;

    end;
  end;
end;

procedure DRAW_UNDERLINE_ALIGNCENTER(Canvas: TCanvas; Rect: TRect; Str: string; fgColor: TColor;
  bgColor: TColor; Alignment: TAlignment; Layout: TTextLayout);
var
  I, OFH            : Integer;
  S1, S2, S3        : string;
  R1, R2, R3, TR    : TRect;
begin
  OFH := Canvas.Font.Height;
  I := Pos('.', Str);
  if I < 1 then
    DrawText(Canvas.Handle, PChar(Str), -1, Rect, _textRect_fmt_(Alignment, Layout))
  else
  begin
    S1 := Copy(Str, 1, I - 1);
    S2 := Copy(Str, I + 1, Length(Str) - I);
    S3 := '';
    R1 := Rect;
    R2 := Rect;
    if (Length(S1) + Length(S2)) > 0 then
      R1.Right := R1.Left + Round(_width_(Rect) * Length(S1) / (Length(S1) + Length(S2)));

    R2.Left := R1.Left + _width_(R1);
    R2.Right := R2.Left + _width_(Rect) - _width_(R1);
    Canvas.Font.Height := OFH * 9 div 10;
    if (Length(S2) > 1) and (S2[Length(S2)] in ['%']) then
    begin
      S2 := Copy(S2, 1, Length(S2) - 1);
      S3 := '%';
      TR := R2;
      with Canvas, TR do
        R2 := Classes.Rect(Left, Top, Left + TextWidth(S2), Bottom);

      SubtractRect(R3, TR, R2);
    end;

    R2.Bottom := R2.Bottom - 3;

    for I := 1 to 3 do
    begin
      Canvas.Font.Style := Canvas.Font.Style - [fsUnderLine];
      if I = 2 then
        Canvas.Font.Style := Canvas.Font.Style + [fsUnderLine];

      Canvas.Font.Height := _if_(I in [2, 3], OFH * 9 div 10, OFH);
      case I of
        1: DrawText(Canvas.Handle, PChar(S1), -1, R1, _textRect_fmt_(taRightJustify, Layout));
        2: DrawText(Canvas.Handle, PChar(S2), -1, R2, _textRect_fmt_(taLeftJustify, Layout));
        3: begin
            if S3 <> '' then
              DrawText(Canvas.Handle, PChar(S3), -1, R3, _textRect_fmt_(taLeftJustify, Layout));
          end;
      end;

    end;
  end;
end;

function _rec_(R: TRect; S: string; FC, BC: TColor; AL: TAlignment;
  TL: TTextLayout; Transparent: Boolean): TTextRectInfo;
begin
  Result.R := R;
  Result.S := S;
  Result.FC := FC;
  Result.BC := BC;
  Result.AL := AL;
  Result.TL := TL;
  Result.Transparent := Transparent;
end;

function RoundStkPrice(Price: Single; RoundUp: Boolean): Single;

  function DoRound(Price: Single; RoundUp: Boolean; Precise: Single = 0.01): Single;
  begin
    Result := 0;
    if Precise > 0 then
    begin
      if RoundUp then
        Result := Round((Price + Precise / 2) / Precise) * Precise
      else
        Result := Trunc(Price / Precise) * Precise;
    end;
  end;

begin
  if Price < 10 then
    Result := DoRound(Price, RoundUp, 0.01)
  else if Price < 50 then
    Result := DoRound(Price, RoundUp, 0.05)
  else if Price < 100 then
    Result := DoRound(Price, RoundUp, 0.1)
  else if Price < 500 then
    Result := DoRound(Price, RoundUp, 0.5)
  else if Price < 1000 then
    Result := DoRound(Price, RoundUp, 1)
  else
    Result := DoRound(Price, RoundUp, 5)
end;

procedure _line_(Canvas: TCanvas; X1, Y1, X2, Y2: Integer);
begin
  Canvas.MoveTo(X1, Y1);
  Canvas.LineTo(X2, Y2);
end;

procedure _lineBox_(Canvas: TCanvas; Rect: TRect);
begin
  with Rect do
    _lineBox_(Canvas, Left, Top, Right - 1, Bottom - 1);
end;

procedure _lineBox_(Canvas: TCanvas; X1, Y1, X2, Y2: Integer);
begin
  with Canvas do
  begin
    MoveTo(X1, Y1);
    if (X1 = X2) or (Y1 = Y2) then
      LineTo(X2, Y2)
    else
      PolyLine([Point(X1, Y1),
        Point(X2, Y1),
          Point(X2, Y2),
          Point(X1, Y2),
          Point(X1, Y1)]);
  end;
end;

procedure _line_(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; LineColor: TColor);
begin
  Canvas.Pen.Color := LineColor;
  Canvas.MoveTo(X1, Y1);
  Canvas.LineTo(X2, Y2);
end;

function _calcMA_(Data: TArrayOfSingle; MAC: Integer): TArrayOfSingle;
var
  Sum               : Single;
  I                 : Integer;
begin
  Result := nil;
  if Length(Data) * MAC = 0 then
    Exit;

  SetLength(Result, Length(Data));
  Sum := 0;
  for I := 0 to Length(Result) - 1 do
  begin
    Sum := Sum + Data[I];
    if I < MAC then
      Result[I] := Sum / (I + 1)
    else
    begin
      Sum := Sum - Data[I - MAC];
      Result[I] := Sum / MAC;