ucommon.pas

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

unit UCommon;

interface

uses
  Windows, Classes, Graphics, StdCtrls, Grids, fUtils, fDef;

const

  RS_URL            = 'http://tw.stock.yahoo.com/s/list.php?c='; //TSE: 25凭证,26权证,27公司债; OTC: 25权证; 26公司债

  RS_TSE_SECTOR     = '水泥,食品,塑料,纺织一,纺织二,电机,电器电缆,化工,玻璃,造纸,钢铁,橡胶,汽车,' +
    '电子一,电子二,电子三,电子四,电子五,电子六,营建,运输,观光,金融一&c=金融二,贸易百货,' +
    '其它,凭证,权证一&c=权证二&c=权证三&c=权证四&c=权证五&c=权证六,公司债一&c=公司债二&c=公司债三';

  RS_OTC_SECTOR     = '柜生技,柜食品,柜塑料,柜纺织,柜电机,柜电器,柜化工,柜玻璃,柜通讯,柜钢铁,柜橡胶,柜软件,柜电子一,' +
    '柜电子二,柜电子三,柜电子四,柜电子五,柜营建,柜航运,柜观光,柜金融,柜贸易,柜证券,柜管理,柜其它,' +
    '柜权证,柜公司债一&c=柜公司债二&c=柜公司债三&c=柜公司债四&c=柜公司债五&c=柜公司债六';

  DEF_COLOR         : array[0..5] of TColor = (clYellow, clLime, clRed, clAqua, clFuchsia, clSilver);
var
  FONT_CHINESE      : string = '楷体';
  FONT_DIGIT        : string = 'ARIAL';
  IS_FRACTION_UNDERLINE: Boolean = False;
  IS_CHINESE_AUTOCOLOR: Boolean = False;
  IS_DRAW_MA        : Boolean = True; //平均线开关
  IS_SHOW_DATESCALE : Boolean = True; //日期坐标开关
  ShowBackgroundDotLine: Boolean = True;
  FValueList        : TArrayOfSingle = nil;

function _if_(B: Boolean; T, F: Single): Single; overload;
function _if_(B: Boolean; T, F: Integer): Integer; overload;
function _if_(B: Boolean; T, F: string): string; overload;
function _if_(B: Boolean; T, F: TObject): TObject; overload;
function _if_(B: Boolean; T, F: TDateTime): TDateTime; overload;
function _if_(B: Boolean; T, F: Boolean): Boolean; overload;
function _if_(B: Boolean; T, F: Pointer): Pointer; overload;
function _if_(B: Boolean; T, F: Int64): Int64; overload;
function _if_(B: Boolean; T, F: TRect): TRect; overload;
function _if_(B: Boolean; T, F: WORD): WORD; overload;
function _if_(B: Boolean; T, F: TAlignment): TAlignment; overload;
procedure _if_(B: Boolean; T: TMAS_ProcEvent; F: TMAS_ProcEvent); overload;
procedure _if_(B: Boolean; T: TMAS_Procedure; F: TMAS_Procedure); overload;
procedure _if_(B: Boolean; T: TMAS_ProcEvent; F: TMAS_Procedure); overload;
procedure _if_(B: Boolean; T: TMAS_Procedure; F: TMAS_ProcEvent); overload;
function _valid_(Index, loBound, hiBound: Integer): Boolean; overload;
procedure _setPen_(Canvas: TCanvas; Color: TColor; Width: Integer; Style: TPenStyle; Mode: TPenMode); overload;
procedure _setPen_(Pen: TPen; Color: TColor; Width: Integer; Style: TPenStyle; Mode: TPenMode); overload;
procedure _setBrush_(Canvas: TCanvas; Color: TColor; Style: TBrushStyle); overload;
procedure _setBrush_(Brush: TBrush; Color: TColor; Style: TBrushStyle); overload;
function _offset_(R: TRect; dx, dy: Integer): TRect;

function Fy2Iy(FY: Single; R: TRect; ScaleHigh, ScaleLow: Single): Integer;

function _rec_(R: TRect; S: string; FC: TColor = clWhite; BC: TColor = clBlack;
  AL: TAlignment = taCenter; TL: TTextLayout = tlCenter; Transparent: Boolean = False): TTextRectInfo;

procedure _clearObject_(List: TStringList); overload;
function _create_(Sorted: Boolean): TStringList; overload;
function _create_(Sorted: Boolean; FileName: string): TStringList; overload;
procedure _free_(var Obj); overload;
procedure _free_(List: TStringList; isClearObject: Boolean); overload;
function _split_(S, Delimiter: string): TStringList; overload;
function _split_(CVS: string): ISplitStrList; overload;
function _toCVS_(S: string; CharSet: TCharSet): string;

//Extract Data from string
function _isStockIdName_(S: string): Boolean;
function _isStockData_(S: string): Boolean;
function _extract_IDNAME_(Src: string): string;
function _extractStkID_(Src: string): string;
function _extractStkNAME_(Src: string): string;
function _extractStkData_(Src: string; Head, Tail: string; Check: Boolean = True): string;
function _extractDealTime_(Src: string): TDateTime;
function _extractDeal_(Src: string): Single;
function _extractValue_(Src: string): Single;
function _extractDiff_(Src: string): Single;
function _format_(Precise: Integer): string;
function _vs_(Value: Extended; Precise: Integer = 2; ShowZero: Boolean = false; Signed: Boolean = false): string;
function _width_(const R: TRect): Integer;
function _height_(const R: TRect): Integer;

procedure CalcColWidths(G: TStringGrid);
procedure CalcRowHeights(G: TStringGrid);
procedure CalcFontHeight(G: TStringGrid; ColWordLen: Single);
function AdjustStkName(S: string): string;
function ElimitBlankStr(S: string): string;
procedure _textRect_(Canvas: TCanvas; Rect: TRect; Str: string; fgColor: TColor = clWhite;
  bgColor: TColor = clBlack; Alignment: TAlignment = taCenter;
  Layout: TTextLayout = tlCenter; Transparent: Boolean = False);

function _textRect_fmt_(Alignment: TAlignment; Layout: TTextLayout = tlCenter): Cardinal;

procedure DRAW_UNDERLINE_ALIGNLEFT(Canvas: TCanvas; Rect: TRect; Str: string; fgColor: TColor;
  bgColor: TColor; Alignment: TAlignment; Layout: TTextLayout);
procedure DRAW_UNDERLINE_ALIGNRIGHT(Canvas: TCanvas; Rect: TRect; Str: string; fgColor: TColor;
  bgColor: TColor; Alignment: TAlignment; Layout: TTextLayout);
procedure DRAW_UNDERLINE_ALIGNCENTER(Canvas: TCanvas; Rect: TRect; Str: string; fgColor: TColor;
  bgColor: TColor; Alignment: TAlignment; Layout: TTextLayout);

function RoundStkPrice(Price: Single; RoundUp: Boolean = True): Single;
procedure _line_(Canvas: TCanvas; X1, Y1, X2, Y2: Integer); overload;
procedure _line_(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; LineColor: TColor); overload;
procedure _lineBox_(Canvas: TCanvas; X1, Y1, X2, Y2: Integer); overload;
procedure _lineBox_(Canvas: TCanvas; Rect: TRect); overload;
function _calcMA_(Data: TArrayOfSingle; MAC: Integer): TArrayOfSingle;
function _calcRSI_(UD: TArrayOfSingle; RSIC: Integer): TArrayOfSingle;
function _calcMDAC_(Data: TArrayOfSingle; EMA: Integer): TArrayOfSingle;
function _div_(Value, DivNum: Single; DefaultWhenDivZero: Single = 0): Extended;
procedure DRAW_HORZ_SCALE(C: TCanvas; R: TRect; L, H, LL, HH: Single; LineCount: Integer; RoundToPrice: Boolean);
procedure DRAW_SCALE(C: TCanvas; R: TRect; L, H, LL, HH: Single; LineCount: Integer; RoundToPrice: Boolean); overload;
procedure DRAW_SCALE(C: TCanvas; R: TRect; L, H, LL, HH: Single; LineCount: Integer; RoundToPrice: Boolean; Vol: Boolean); Overload;
procedure DRAW_SCALE(C: TCanvas; R: TRect; Values: TArrayOfSingle; L, H, LL, HH: Single); overload;
procedure DRAW_SCALE(C: TCanvas; R: TRect; Values: TArrayOfSingle; L, H, LL, HH: Single; Vol: Boolean); overload;
function _round_(Price: Single; ued: Integer): Single; overload; //ued=1(up);ued=0(dont care);ued=-1(down)
function ArrayOdSingle(A: array of Single): TArrayOfSingle;
procedure _setupBitmap_(Canvas: TCanvas; bmp: TBitmap; Rect: TRect; var BitmapRect: TRect);
procedure _textRectBackground_(Canvas: TCanvas; Rect: TRect; mStr: string;
  FontHeight: Integer = -1;
  fgColor: TColor = clWhite;
  bgColor: TColor = clBlack; Alignment: TAlignment = taCenter;
  Layout: TTextLayout = tlCenter; Transparent: Boolean = False;
  IsFontBold: Boolean = False); overload;
function _inflate_(R: TRect; dx, dy: Integer): TRect;
function _CalcFontHeight_(Rect: TRect; const S: string): Integer; overload;

implementation

uses
  Math, SysUtils;

procedure _free_(List: TStringList; isClearObject: Boolean);
begin
  if isClearObject then
    _clearObject_(List);
  _free_(List);
end;

procedure CalcColWidths(G: TStringGrid);
begin
  with G do DefaultColWidth := (ClientWidth - 14) div ColCount;
end;

procedure CalcRowHeights(G: TStringGrid);
var
  M                 : Integer;
begin
  with G do
  begin
    DefaultRowHeight := ClientHeight div RowCount;
    M := ClientHeight mod RowCount;
    while M > 0 do
    begin
      RowHeights[M - 1] := RowHeights[M - 1] + 1;
      Dec(M);
    end;
    Update;
  end;
end;

procedure CalcFontHeight(G: TStringGrid; ColWordLen: Single);
begin
  G.Font.Height := ABS(Min(G.DefaultRowHeight - 2, Round(G.DefaultColWidth / ColWordLen) - 1));
end;

function _if_(B: Boolean; T, F: Single): Single;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: Integer): Integer;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: Int64): Int64;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: Pointer): Pointer;
begin if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: string): string;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: TObject): TObject;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: Boolean): Boolean;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: TDateTime): TDateTime;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: TRect): TRect;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: WORD): WORD;
begin
  if B then
    Result := T
  else
    Result := F;
end;

function _if_(B: Boolean; T, F: TAlignment): TAlignment;
begin
  if B then
    Result := T
  else
    Result := F;
end;

procedure _if_(B: Boolean; T: TMAS_ProcEvent; F: TMAS_ProcEvent);
begin
  if B and Assigned(T) then
    (T)
  else if not B and Assigned(F) then
    (F);
end;

procedure _if_(B: Boolean; T: TMAS_Procedure; F: TMAS_Procedure);
begin
  if B and Assigned(T) then
    (T)
  else if not B and Assigned(F) then
    (F);
end;

procedure _if_(B: Boolean; T: TMAS_ProcEvent; F: TMAS_Procedure);
begin
  if B and Assigned(T) then
    (T)
  else if not B and Assigned(F) then
    (F);
end;

procedure _if_(B: Boolean; T: TMAS_Procedure; F: TMAS_ProcEvent);
begin
  if B and Assigned(T) then
    (T)
  else if not B and Assigned(F) then
    (F);
end;

function _width_(const R: TRect): Integer;
begin
  Result := Max(0, R.Right - R.Left);
end;

function _height_(const R: TRect): Integer;
begin
  Result := Max(0, R.Bottom - R.Top);
end;

procedure _free_(var Obj);
begin
  if TObject(Obj) <> nil then
    FreeAndNil(Obj)
  else
    Pointer(Obj) := nil;
end;

function _split_(S, Delimiter: string): TStringList;
begin
  Result := TStringList.Create;
  Result.Text := StringReplace(S, Delimiter, #13, [rfReplaceAll, rfIgnoreCase]);
end;

function _split_(CVS: string): ISplitStrList;
begin
  Result := TSplitStrList.Create(CVS);
end;

procedure _clearObject_(List: TStringList);
var
  I                 : Integer;
begin
  if List = nil then Exit;
  for I := 0 to List.Count - 1 do
    if List.Objects[I] <> nil then
      List.Objects[I].Free;
  List.Clear;
end;

function _create_(Sorted: Boolean): TStringList;
begin
  Result := TStringList.Create;
  if Sorted then
  begin
    Result.Duplicates := dupIgnore;
    Result.Sorted := Sorted;
  end;
end;

function _create_(Sorted: Boolean; FileName: string): TStringList;
begin
  Result := _create_(Sorted);
  if FileExists(FileName) then
    Result.LoadFromFile(FileName);
end;

function _toCVS_(S: string; CharSet: TCharSet): string;
var
  I                 : Integer;
begin
  Result := S;
  for I := 1 to Length(Result) do
  begin
    if Result[I] in CharSet then
      Result[I] := ',';
  end;
end;

function _isStockIdName_(S: string): Boolean;
begin
  Result := Pos(FILTER_KEY_STKIDNAME, S) > 0;
end;

function _isStockData_(S: string): Boolean;
begin
  Result := Pos(FILTER_KEY_STKDATA, S) > 0;
end;

function _extract_IDNAME_(Src: string): string;
var
  I, J              : Integer;
begin
  Result := '';
  I := Pos('.html', Src);
  J := Pos('</a>', Src);
  if I * J > 0 then
    Result := Trim(Copy(Src, I + 6, J - I - 5));
end;

function _extractStkID_(Src: string): string;
var
  I                 : Integer;
begin
  Result := '';
  Src := _extract_IDNAME_(Src);
  I := Pos(#$20, Src);
  if I > 0 then
    Result := Trim(Copy(Src, 1, I - 1));
end;

function _extractStkNAME_(Src: string): string;
var
  I                 : Integer;
begin
  Result := '';
  Src := _extract_IDNAME_(Src);
  I := Pos(#$20, Src);
  if I > 0 then
    Result := Trim(Copy(Src, I + 1, Length(Src) - I - 1));
end;

function _extractStkData_(Src: string; Head, Tail: string; Check: Boolean): string;
var
  I, J, Len         : Integer;
begin
  Result := '';
  I := Pos(Head, Src);
  J := Pos(Tail, Src);
  if I * J > 0 then
  begin
    Len := Length(Head);
    Src := Trim(Copy(Src, I + Len, J - I - Len));
    if not Check then
      Result := Src
    else
    begin
      for I := 1 to Length(Src) do
      begin
        if Src[I] in ['0'..'9', '.', ':'] then