rm_utils.pas

这是一个功能强大

  Result := aComponent is aClassRef;
  if not Result then
  begin
    lClass := aComponent.ClassType;
    while lClass <> nil do
    begin
      if lClass.ClassName = aClassRef.ClassName then
      begin
        Result := True;
        Break;
      end;

      lClass := lClass.ClassParent;
    end;
  end;
end;

{$HINTS OFF}

procedure RMGetComponents(aOwner: TComponent; aClassRef: TClass; aList: TStrings;
  aSkip: TComponent);
var
  i: Integer;
{$IFDEF COMPILER6_UP}
  j: Integer;
{$ENDIF}

  procedure _EnumComponents(aComponent: TComponent);
  var
    i: Integer;
    lComponent: TComponent;
    //(2004-12-9 0:08 PYZFL)
    lComponentName: string;
    lIsDataSet: Boolean;
  begin
{$IFDEF COMPILER5_UP}
    if aComponent is TForm then
    begin
      for i := 0 to TForm(aComponent).ControlCount - 1 do
      begin
        lComponent := TForm(aComponent).Controls[i];
        if lComponent is TFrame then
          _EnumComponents(lComponent);
      end;
    end;
{$ENDIF}

    for i := 0 to aComponent.ComponentCount - 1 do
    begin
      lComponent := aComponent.Components[i];
      //(2004-12-8 23:28 PYZFL)
      // 如果Visible=false，则在设计器中不显示。
      lIsDataSet := RMClassIsOk(lComponent, TRMDataset);
      if lIsDataSet and (not TRMDataset(lComponent).Visible) then Continue;
      if RMClassIsOk(lComponent, TRMDBDataSet) and (TRMDBDataSet(lComponent).DataSet = nil) then Continue;

      if (lComponent <> aSkip) and RMClassIsOk(lComponent, aClassRef) and
        ((lComponent.Name <> '') or (lIsDataSet and (TRMDataSet(lComponent).AliasName <> ''))) then
      begin
        if aComponent = aOwner then
          lComponentName := lComponent.Name
        else if ((aComponent is TForm) or (aComponent is TDataModule)) then
          lComponentName := aComponent.Name + '.' + lComponent.Name
        else
          lComponentName := TControl(aComponent).Parent.Name + '.' + aComponent.Name + '.' + lComponent.Name;

        if (lComponent is TRMDataset) and (TRMDataset(lComponent).AliasName <> '') then
          lComponentName := TRMDataset(lComponent).AliasName;
//          lComponentName := lComponentName + '-(' + TRMDataset(lComponent).AliasName + ')';

        aList.Add(lComponentName);
      end;
    end;
  end;

begin
  aList.Clear;
  for i := 0 to Screen.CustomFormCount - 1 do
  begin
    if (Screen.CustomForms[i].Name <> 'RMDesignerForm') and
      (Screen.CustomForms[i].Name <> 'RMGridReportDesignerForm') then
      _EnumComponents(Screen.CustomForms[i]);
  end;
  for i := 0 to Screen.DataModuleCount - 1 do
    _EnumComponents(Screen.DataModules[i]);

{$IFDEF COMPILER6_UP}
  with Screen do
  begin
    for i := 0 to CustomFormCount - 1 do
    begin
      with CustomForms[i] do
      begin
        if (ClassName = 'TDataModuleForm') then
        begin
          for j := 0 to ComponentCount - 1 do
          begin
            if (Components[j] is TDataModule) then
              _EnumComponents(Components[j]);
          end;
        end;
      end;
    end;
  end;
{$ENDIF}
end;
{$HINTS ON}

function RMRemoveQuotes(const aStr: WideString): WideString;
begin
  if (Length(aStr) > 2) and (aStr[1] = '"') and (aStr[Length(aStr)] = '"') then
    Result := Copy(aStr, 2, Length(aStr) - 2)
  else
    Result := aStr;
end;

procedure RMSetCommaText(Text: string; sl: TStringList);
var
  i: Integer;

  function _ExtractCommaName(s: string; var Pos: Integer): string;
  var
    i: Integer;
  begin
    i := Pos;
    while (i <= Length(s)) and (s[i] <> ';') do
      Inc(i);
    Result := Copy(s, Pos, i - Pos);
    if (i <= Length(s)) and (s[i] = ';') then
      Inc(i);
    Pos := i;
  end;

begin
  i := 1;
  sl.Clear;
  while i <= Length(Text) do
    sl.Add(_ExtractCommaName(Text, i));
end;

type
  THackCanvas = class(TCanvas);

function RMWideCanvasTextExtent(aCanvas: TCanvas; const aText: WideString): TSize;
begin
  with THackCanvas(aCanvas) do
  begin
    RequiredState([csHandleValid, csFontValid]);

    Result.cx := 0;
    Result.cy := 0;
    Windows.GetTextExtentPoint32W(Handle, PWideChar(aText), Length(aText), Result);
  end;
end;

function RMWideCanvasTextWidth(aCanvas: TCanvas; const aText: WideString): Integer;
begin
  Result := RMWideCanvasTextExtent(aCanvas, aText).cx;
end;

function RMWideCanvasTextHeight(aCanvas: TCanvas; const aText: WideString): Integer;
begin
  Result := RMWideCanvasTextExtent(aCanvas, aText).cy;
end;

function RMCanvasWidth(const aStr: string; aFont: TFont): integer;
begin
  with TCanvas.Create do
  begin
    Handle := GetDC(0);
    Font.Assign(aFont);
    Result := TextWidth(aStr);
    ReleaseDC(0, Handle);
    Free;
  end;
end;

function RMCanvasHeight(const aStr: string; aFont: TFont): integer;
begin
  with TCanvas.Create do
  begin
    Handle := GetDC(0);
    Font.Assign(aFont);
    Result := TextHeight(aStr);
    ReleaseDC(0, Handle);
    Free;
  end;
end;

function RMWrapStrings(const aSrcLines: TWideStringList; aDstLines: TWideStringList;
  aCanvas: TCanvas; aWidth: Integer; const aLineSpacing: Integer;
  aWordBreak, aCharWrap, aAllowHtmlTag, aWidthFlag, aAddChar: Boolean): integer;
var
  i: Integer;
  lNewLine: WideString;
  lNewLineWidth: Integer;
  lNowHeight: Integer;
  lLineFinished: Boolean;
  lHtmlList: TRMHtmlList;
  lFontStack: TRMHtmlFontStack;
  lLineHeight: Integer;
  lAddFirstCharFlag: Boolean;

  function _TW(const aStr: WideString): Integer;
  var
    i: Integer;
  begin
    Result := 0;
    for i := 1 to Length(aStr) do
    begin
      Result := Result + RMWideCanvasTextHeight(aCanvas, aStr[i]);
    end;
  end;

  function _LineWidth(const aLine: WideString; aIsBreakWord: Boolean): integer;
  begin
    if aWidthFlag then
    begin
      Result := RMWideCanvasTextWidth(aCanvas, aLine);
      if aIsBreakWord then
        Result := Result div 2;
    end
    else
      Result := _TW(aLine);
  end;

  procedure _FlushLine;
  begin
    if lAddFirstCharFlag then
      lNewLine := #1 + lNewLine;

    aDstLines.Add(lNewLine);
    Inc(lNowHeight, lLineHeight {aOneLineHeight});
    lNewLine := '';
    lLineFinished := True;
    lNewLineWidth := 0;
    lAddFirstCharFlag := False;
  end;

  procedure _AddWord(aWord: WideString);
  var
    i: Integer;
    lStr, lStr1: WideString;
    lPos: Integer;
    lCurWidth: Integer;
    lFlag: Boolean;
  begin
    if aWord = #1 then Exit;

    lFlag := False;
    if aWordBreak and (lNewLine <> '') then
    begin
      for i := Low(RMChineseBreakChars) to High(RMChineseBreakChars) do
      begin
        if aWord = RMChineseBreakChars[i] then
        begin
          lFlag := True;
          Break;
        end;
      end;
    end;

    lCurWidth := _LineWidth(aWord, lFlag);
    if lNewLineWidth + lCurWidth > aWidth then // 太长了，该换行了
    begin
      if lNewLine = '' then
      begin
        while True do
        begin
          lStr := Copy(aWord, 1, 1);
          lCurWidth := _LineWidth(lStr, False);
          if lNewLineWidth + lCurWidth < aWidth then
          begin
            lNewLine := lNewLine + lStr;
            Inc(lNewLineWidth, lCurWidth);
            Delete(aWord, 1, Length(lStr));
          end
          else
          begin
            if lNewLine = '' then
            begin
              lNewLine := lNewLine + lStr;
              Inc(lNewLineWidth, lCurWidth);
              Delete(aWord, 1, Length(lStr));
            end;
            Break;
          end;
        end; {while}
      end
      else if aCharWrap then
      begin
        lPos := 1;
        lStr := '';
        while lPos < Length(aWord) do
        begin
          lStr1 := Copy(aWord, lPos, 1);
          lPos := lPos + 1;
          lCurWidth := _LineWidth(lStr + lStr1, False);
          if lNewLineWidth + lCurWidth > aWidth then
            Break
          else
          begin
            lStr := lStr + lStr1;
          end;
        end;

        lNewLine := lNewLine + lStr;
        Inc(lNewLineWidth, _LineWidth(lStr, False));
        Delete(aWord, 1, Length(lStr));
      end
      else
      begin
        if aAddChar and (lNewLine <> '') and (lNewLine[1] <> #1) then
        begin
          lAddFirstCharFlag := True; // 实现自动调整间距功能
        end;
      end;

      _FlushLine;
      if Length(aWord) > 0 then
        _AddWord(aWord);
    end
    else
    begin
      lNewLine := lNewLine + aWord;
      Inc(lNewLineWidth, lCurWidth);
      if Length(aWord) > 0 then
        lLineFinished := False;
    end;
  end;

  procedure _AddOneLine(aStr: WideString);
  var
    i, lPos: Integer;
    lNextWord: WideString;
    lHtmlElement: PRMHtmlElement;
    lHtmlTagStr: WideString;

    procedure _AddOneStr;
    var
      i, lPos: Integer;
      //lAnsiStr: string;
    begin
      lPos := 0; {lAnsiStr := '';}
      while (lPos < Length(aStr)) and (Length(aStr) > 0) do
      begin
        repeat
          Inc(lPos);
          //lAnsiStr := aStr[lPos];
        until (Cardinal(aStr[lPos]) > $7F {Length(lAnsiStr) > 1}) or (AnsiChar(aStr[lPos]) in RMBreakChars) or (lPos >= Length(aStr));

        if aWordBreak and (lPos + 1 < Length(aStr)) and (Cardinal(aStr[lPos]) > $7F {Length(lAnsiStr) > 1}) then
        begin
          lNextWord := Copy(aStr, lPos + 1, 2);
          if (lNewLineWidth > 0) and (lNewLineWidth + _LineWidth(Copy(aStr, 1, lPos) + lNextWord, False) > aWidth) then
          begin
            for i := Low(RMChineseBreakChars) to High(RMChineseBreakChars) do
            begin
              if lNextWord = RMChineseBreakChars[i] then
              begin
                if lNewLineWidth + _LineWidth(Copy(aStr, 1, lPos), False) + _LineWidth(lNextWord, True) > aWidth then
                begin
                  if not aCharWrap then
                  begin
                    if aAddChar and (lNewLine <> '') and (lNewLine[1] <> #1) then
                      lAddFirstCharFlag := True; // 实现自动调整间距功能
                  end;

                  _FlushLine;
                end;

                Break;
              end; { liNextWord = RMChineseBreakChars[i] }
            end;
          end;
        end;

        _AddWord(Copy(aStr, 1, lPos));
        Delete(aStr, 1, lPos);
        lPos := 0;
      end;
    end;

  begin
    while Pos(#10, aStr) > 0 do
      Delete(aStr, Pos(#10, aStr), 1);

    lPos := Pos(#13, aStr);
    if lPos > 0 then
    begin
      repeat
        _AddOneLine(Copy(aStr, 1, lPos - 1));
        Delete(aStr, 1, lPos);
        lPos := Pos(#13, aStr);
      until lPos = 0;

      _AddOneLine(aStr);
      Exit;
    end;

    lHtmlTagStr := '';
    lNewLine := '';
    lLineFinished := False;
    lAddFirstCharFlag := (aStr <> '') and (aStr[1] = #1);
    if aAllowHtmlTag then
    begin
      RMHtmlAnalyseElement(aStr, lHtmlList);
      for i := 0 to lHtmlList.Count - 1 do
      begin
        lHtmlElement := lHtmlList[i];
        if lHtmlElement^.H_tag <> '' then
        begin
          RMHtmlSetFont(aCanvas.Font, lHtmlElement, lFontStack, rmdmDesigning, 1, nil);
          lHtmlTagStr := lHtmlTagStr + '<' + lHtmlElement.H_TagStr + '>';
        end
        else
        begin
          if lHtmlTagStr <> '' then
            lNewLine := lNewLine + lHtmlTagStr;

          lLineHeight := Max(lLineHeight, -aCanvas.Font.Height + aLineSpacing);
          aStr := lHtmlElement.H_str;
          _AddOneStr;
          lHtmlTagStr := '';
        end;
      end;

      if lHtmlTagStr <> '' then
      begin
        lNewLine := lNewLine + lHtmlTagStr;
        aStr := '';
        _AddWord('');
        lHtmlTagStr := '';
      end;
    end
    else
      _AddOneStr;

    if not lLineFinished then
      _FlushLine;
  end;

begin
  lNewLineWidth := 0;
  lNowHeight := 0;
  aDstLines.BeginUpdate;
  lLineFinished := False;
  lAddFirstCharFlag := False;

  lHtmlList := nil;
  lFontStack := nil;
  if aAllowHtmlTag then
  begin
    lHtmlList := TRMHtmlList.Create;
    lFontStack := TRMHtmlFontStack.Create;
  end;

  try
    for i := 0 to aSrcLines.Count - 1 do
    begin
      lLineHeight := -aCanvas.Font.Height + aLineSpacing;
      _AddOneLine(aSrcLines[i]);
    end;
  finally
    if lHtmlList <> nil then
      lHtmlList.Clear;

    lHtmlList.Free;
    lFontStack.Free;
    aDstLines.EndUpdate;
    Result := lNowHeight;
  end;
end;


(* -------------------------------------------------- *)
(* RMCurrToBIGNum  将阿拉伯数字转成中文数字字串
(* 使用示例:
(*   RMCurrToBIGNum(10002.34) ==> 一万零二圆三角四分
(* -------------------------------------------------- *)
const
  _ChineseNumeric: array[0..22] of string = (