rm_utils.pas

report machine 2.3 功能强大

    end;
  end;

  if j <> i then
    sl.Add(Copy(ComplexName, j, 255));

  case n of
    0: // field name only
      begin
        if DataSet <> nil then
        begin
          s := RMRemoveQuotes(ComplexName);
          Field := FindField(DataSet, s);
        end;
      end;
    1: // DatasetName.FieldName
      begin
        DataSet := TDataSet(RMFindComponent(f, sl[0]));
        s := RMRemoveQuotes(sl[1]);
        Field := FindField(DataSet, s);
      end;
    2: // FormName.DatasetName.FieldName
      begin
        f := FindGlobalComponent(sl[0]);
        if f <> nil then
        begin
          DataSet := TDataSet(f.FindComponent(sl[1]));
          s := RMRemoveQuotes(sl[2]);
          Field := FindField(DataSet, s);
        end;
      end;
    3: // FormName.FrameName.DatasetName.FieldName - Delphi5
      begin
        f := FindGlobalComponent(sl[0]);
        if f <> nil then
        begin
          cn := TControl(f.FindComponent(sl[1]));
          DataSet := TDataSet(cn.FindComponent(sl[2]));
          s := RMRemoveQuotes(sl[3]);
          Field := FindField(DataSet, s);
        end;
      end;
  end;

  sl.Free;
end;

function RMFindComponent(Owner: TComponent; Name: string): TComponent;
var
  n: Integer;
  s1, s2: string;
begin
  Result := nil;
  n := Pos('.', Name);
  try
    if n = 0 then
      Result := Owner.FindComponent(Name)
    else
    begin
      s1 := Copy(Name, 1, n - 1); // module name
      s2 := Copy(Name, n + 1, 99999); // component name
      Owner := FindGlobalComponent(s1);
      if Owner <> nil then
      begin
        n := Pos('.', s2);
        if n <> 0 then // frame name - Delphi5
        begin
          s1 := Copy(s2, 1, n - 1);
          s2 := Copy(s2, n + 1, 99999);
          Owner := Owner.FindComponent(s1);
          if Owner <> nil then
            Result := Owner.FindComponent(s2);
        end
        else
          Result := Owner.FindComponent(s2);
      end;
    end;
  except
    on Exception do
      raise EClassNotFound.Create('Missing ' + Name);
  end;
end;

{$HINTS OFF}

procedure RMGetComponents(Owner: TComponent; ClassRef: TClass; List: TStrings; Skip: TComponent);
var
  i, j: Integer;

  procedure EnumComponents(f: TComponent);
  var
    i: Integer;
    c: TComponent;
  begin
{$IFDEF Delphi5}
    if f is TForm then
    begin
      for i := 0 to TForm(f).ControlCount - 1 do
      begin
        c := TForm(f).Controls[i];
        if c is TFrame then
          EnumComponents(c);
      end;
    end;
{$ENDIF}
    for i := 0 to f.ComponentCount - 1 do
    begin
      c := f.Components[i];
      if (c <> Skip) and (c is ClassRef) then
      begin
        if f = Owner then
          List.Add(c.Name)
        else if ((f is TForm) or (f is TDataModule)) then
          List.Add(f.Name + '.' + c.Name)
        else
          List.Add(TControl(f).Parent.Name + '.' + f.Name + '.' + c.Name)
      end;
    end;
  end;

begin
  List.Clear;
  for i := 0 to Screen.FormCount - 1 do
    EnumComponents(Screen.Forms[i]);
  for i := 0 to Screen.DataModuleCount - 1 do
    EnumComponents(Screen.DataModules[i]);

{$IFDEF Delphi6}
  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 RMStrToFloat(s: string): Double;
var
  i: Integer;
begin
  for i := 1 to Length(s) do
  begin
    if s[i] in [',', '.'] then
      s[i] := DecimalSeparator;
  end;
  Result := StrToFloat(Trim(s));
end;

function RMRemoveQuotes(const s: string): string;
begin
  if (Length(s) > 2) and (s[1] = '"') and (s[Length(s)] = '"') then
    Result := Copy(s, 2, Length(s) - 2)
  else
    Result := s;
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;

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

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

const
  BreakChars: set of Char = [' ', #13, '-'];
  ChineseBreakChars: array[0..41] of string = (
    '。', '，', '、', '；', '：', '？', '！', '…', '—', '·', 'ˉ', '‘', '’',
    '“', '”', '～', '∶', '＂', '＇', '｀', '｜', '〔', '〕', '〈', '〉', '《',
    '》', '「', '」', '『', '』', '．', '〖', '〗', '【', '】', '（', '）', '［',
    '］', '｛', '｝');

function RMWrapStrings(const SrcLines: TStrings; DstLines: TStrings; aCanvas: TCanvas;
  aWidth: Integer; const aOneLineHeight: Integer; aWordBreak: Boolean): integer;
var
  i: Integer;
  liNewLine: string;
  NowHeight: Integer;
  LineFinished: Boolean;

  function LineWidth(const Line: string): integer;
  begin
    Result := aCanvas.TextWidth(Line);
  end;

  procedure FlushLine;
  begin
    DstLines.Add(liNewLine + #1);
    Inc(NowHeight, aOneLineHeight);
    liNewLine := '';
    LineFinished := True;
  end;

  procedure AddWord(aWord: string);
  var
    s: string;
  begin
    if LineWidth(liNewLine + aWord) > aWidth then
    begin
      if liNewLine = '' then
      begin
        while True do
        begin
          if (Length(aWord) > 1) and (aWord[1] in LeadBytes) then
            S := copy(aWord, 1, 2)
          else
            S := copy(aWord, 1, 1);

          if LineWidth(liNewLine + S) < aWidth then
          begin
            liNewLine := liNewLine + S;
            Delete(aWord, 1, Length(s));
          end
          else
          begin
            if liNewLine = '' then
            begin
              liNewLine := liNewLine + S;
              Delete(aWord, 1, Length(s));
            end;
            Break;
          end;
        end; {while}
      end; {if}

      FlushLine;
      if Length(aWord) > 0 then
        AddWord(aWord);
    end
    else
    begin
      liNewLine := liNewLine + aWord;
      if Length(aWord) > 0 then
        LineFinished := False;
    end;
  end;

{  procedure AddWord(aWord: string);
  var
    s: string;
  begin
   LineFinished := False;
    if LineWidth(liNewLine + aWord) > aWidth then
    begin
     while True do
      begin
       if (Length(aWord) > 1) and (aWord[1] in LeadBytes) then
         S := copy(aWord, 1, 2)
        else
         S := copy(aWord, 1, 1);

        if LineWidth(liNewLine + S) < aWidth then
        begin
         liNewLine := liNewLine + S;
          Delete(aWord, 1, Length(S));
        end
        else
         Break;
      end;
      FlushLine;
      if Length(aWord) > 0 then
        AddWord(aWord);
    end
    else
     liNewLine := liNewLine + aWord;
  end;
}

  procedure AddOneLine(aStr: string);
  var
    i, liPos: Integer;
    liSingleFlag: Boolean;
    liNextWord: string;
  begin
    while Pos(#10, aStr) > 0 do
      Delete(aStr, Pos(#10, aStr), 1);

    liPos := Pos(#13, aStr);
    if liPos > 0 then
    begin
      repeat
        AddOneLine(Copy(aStr, 1, liPos - 1));
        Delete(aStr, 1, liPos);
        liPos := Pos(#13, aStr);
      until liPos = 0;
      AddOneLine(aStr);
    end
    else
    begin
      liPos := 0; liNewLine := ''; LineFinished := False; liSingleFlag := False;
      while (liPos < Length(aStr)) and (Length(aStr) > 0) do
      begin
        repeat
          Inc(liPos);
          if aStr[liPos] in LeadBytes then
          begin
            if liSingleFlag then
            begin
              Dec(liPos);
            end
            else
              Inc(liPos);
            liSingleFlag := False;
            Break;
          end
          else
          begin
            liSingleFlag := True;
          end;
        until (aStr[liPos] in BreakChars) or (liPos >= Length(aStr));

        if aWordBreak then
        begin
          if (Length(aStr) - liPos > 1) and (aStr[liPos + 1] in LeadBytes) then
          begin
            liNextWord := Copy(aStr, liPos + 1, 2);
            if (Length(liNewLine) > 0) and (LineWidth(liNewLine + Copy(aStr, 1, liPos) + liNextWord) > aWidth) then
            begin
              for i := Low(ChineseBreakChars) to High(ChineseBreakChars) do
              begin
                if liNextWord = ChineseBreakChars[i] then
                begin
                  FlushLine;
                  Break;
                end;
              end;
            end;
          end;
        end;

        AddWord(Copy(aStr, 1, liPos));
        Delete(aStr, 1, liPos);
        liPos := 0;
      end;

      if not LineFinished then
        FlushLine;
    end;
  end;

begin
  NowHeight := 0;
  DstLines.BeginUpdate;
  LineFinished := False;
  for i := 0 to SrcLines.Count - 1 do
    AddOneLine(SrcLines[i]);
  DstLines.EndUpdate;
  Result := NowHeight;
end;

function RMGetBrackedVariable(const s: string; var i, j: Integer): string;
var
  c: Integer;
  fl1, fl2: Boolean;
begin
  j := i; fl1 := True; fl2 := True; c := 0;
  Result := '';
  if (s = '') or (j > Length(s)) then Exit;
  Dec(j);
  repeat
    Inc(j);
    if fl1 and fl2 then
    begin
      if s[j] = '[' then
      begin
        if c = 0 then i := j;
        Inc(c);
      end
      else if s[j] = ']' then
      	Dec(c);
    end;

    if fl1 then
    begin
      if s[j] = '"' then fl2 := not fl2;
    end;