rm_utils.pas

中小企业管理系统------ ERP系统原代码

              aDataSet := TDataSet(cn.FindComponent(sl[2]));
            s := RMRemoveQuotes(sl[3]);
            aField := FindField(aDataSet, s);
          end;
        end;
    end;
  finally
    sl.Free;
  end;
end;

function RMFindComponent(Owner: TComponent; Name: string): TComponent;
var
  n: Integer;
  s1, s2: string;
begin
  Result := nil;
  n := Pos('.', Name);
  try
    if (n = 0) and (Owner <> nil) 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 AnsiCompareText(ClassRef.ClassName, 'TRMUserDataset') = 0 then
//        begin
//          if TRMUserDataset(c).FieldList.Count = 0 then
//            Break;
//        end;

        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.CustomFormCount - 1 do
    EnumComponents(Screen.CustomForms[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;

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

  function TW(const s: string): integer;
  var
    fs, fs1, i, j, k: Integer;
  begin
    fs := aCanvas.Font.size;
    fs1 := fs div 2;
    if fs1 < 6 then
      fs1 := 6;
    j := 0;
    i := 1;
    while i <= length(s) do
    begin
      if aMangeTag and (s[i] = '_') then
      begin
        aCanvas.Font.size := fs1;
        Inc(i);
      end;
      if aMangeTag and (s[i] = '~') then
      begin
        aCanvas.Font.size := fs1;
        Inc(i);
      end;
      if aMangeTag and (s[i] = '|') then
      begin
        aCanvas.Font.size := fs;
        Inc(i);
      end;
      if Windows.isDBCSLeadByte(Byte(s[i])) then
      begin
        k := aCanvas.TextHeight(Copy(s, i, 2));
        Inc(i);
      end
      else
      begin
        k := aCanvas.TextHeight(Copy(s, i, 2))
      end;

      j := j + k;
      Inc(i);
    end;

    Result := j;
    aCanvas.Font.size := fs;
  end;

  function LineWidth(const Line: string): integer;
  begin
    if aWidthFlag then
      Result := aCanvas.TextWidth(Line)
    else
      Result := tw(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 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);
      Exit;
    end;

    if aMangeTag then
    begin
      liPos := Pos('`', aStr);
      if liPos > 0 then
      begin
        repeat
          AddOneLine(Copy(aStr, 1, liPos - 1));
          Delete(aStr, 1, liPos);
          liPos := Pos('`', aStr);
        until liPos = 0;
        AddOneLine(aStr);
        Exit;
      end;
    end;

    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 RMBreakChars) 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(RMChineseBreakChars) to High(RMChineseBreakChars) do
            begin
              if liNextWord = RMChineseBreakChars[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;

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;

    if fl2 then
    begin
      if s[j] = '''' then
        fl1 := not fl1;
    end;
  until (c = 0) or (j >= Length(s));

  if RM_Class.Flag_TableEmpty then
    Result := ''
  else
    Result := Copy(s, i + 1, j - i - 1);
end;

(* -------------------------------------------------- *)
(* RMCurrToBIGNum  将阿拉伯数字转成中文数字字串
(* 使用示例:
(*   RMCurrToBIGNum(10002.34) ==> 一万零二圆三角四分
(* -------------------------------------------------- *)
const
  _ChineseNumeric: array[0..22] of string = (
    '零', '壹', '贰', '叁', '肆', '伍', '陆', '柒', '捌', '玖', '拾', '佰', '仟',
    '万', '亿', '兆', '圆', '角', '分', '厘', '点', '负', '整');

function RMCurrToBIGNum(Value: Currency): string;
var
  sArabic, sIntArabic: string;
  sSectionArabic, sSection: string;
  i, iDigit, iSection, iPosOfDecimalPoint: integer;
  bInZero, bMinus: boolean;

  function ConvertStr(const str: string): string; //将字串反向, 例如: 传入 '1234', 传回 '4321'
  var
    i: integer;
  begin
    Result := '';
    for i := Length(str) downto 1 do
      Result := Result + str[i];
  end;

begin
  Result := ''; bInZero := True;
  sArabic := FloatToStr(Value); //将数字转成阿拉伯数字字串
  if sArabic[1] = '-' then
  begin
    bMinus := True;
    sArabic := Copy(sArabic, 2, 9999);
  end
  else
    bMinus := False;
  iPosOfDecimalPoint := Pos('.', sArabic); //取得小数点的位置

  //先处理整数的部分
  if iPosOfDecimalPoint = 0 then
    sIntArabic := ConvertStr(sArabic)
  else
    sIntArabic := ConvertStr(Copy(sArabic, 1, iPosOfDecimalPoint - 1));

  //从个位数起以每四位数为一小节
  for iSection := 0 to ((Length(sIntArabic) - 1) div 4) do
  begin
    sSectionArabic := Copy(sIntArabic, iSection * 4 + 1, 4);
    sSection := '';
    for i := 1 to Length(sSectionArabic) do //以下的 i 控制: 个十百千位四个位数
    begin
      iDigit := Ord(sSectionArabic[i]) - 48;
      if iDigit = 0 then
      begin
        if (not bInZero) and (i <> 1) then
          sSection := _ChineseNumeric[0] + sSection;
        bInZero := True;
      end
      else
      begin
        case i of
          2: sSection := _ChineseNumeric[10] + sSection;
          3: sSection := _ChineseNumeric[11] + sSection;
          4: sSection := _ChineseNumeric[12] + sSection;
        end;
        sSection := _ChineseNumeric[iDigit] + sSection;
        bInZero := False;
      end;
    end;

    //加上该小节的位数
    if Length(sSection) = 0 then
    begin
      if (Length(Result) > 0) and (Copy(Result, 1, 2) <> _ChineseNumeric[0]) then
        Result := _ChineseNumeric[0] + Result;
    end
    else
    begin
      case iSection of
        0: Result := sSection;
        1: Result := sSection + _ChineseNumeric[13] + Result;
        2: Result := sSection + _ChineseNumeric[14] + Result;
        3: Result := sSection + _ChineseNumeric[15] + Result;
      end;
    end;
  end;

  if Length(Result) > 0 then
    Result := Result + _ChineseNumeric[16];
  if iPosOfDecimalPoint > 0 then //处理小数部分
  begin
    for i := iPosOfDecimalPoint + 1 to Length(sArabic) do
    begin
      iDigit := Ord(sArabic[i]) - 48;
      Result := Result + _ChineseNumeric[iDigit];
      case i - (iPosOfDecimalPoint + 1) of
        0: Result := Result + _ChineseNumeric[17];
        1: Result := Result + _ChineseNumeric[18];
        2: Result := Result + _ChineseNumeric[19];
      end;
    end;
  end;

  //其他例外状况的处理
  if Length(Result) = 0 then
    Result := _ChineseNumeric[0];
  if Copy(Result, 1, 4) = _ChineseNumeric[1] + _ChineseNumeric[10] then
    Result := Copy(Result, 3, 254);
  if Copy(Result, 1, 2) = _ChineseNumeric[20] then
    Result := _ChineseNumeric[0] + Result;

  if bMinus then
    Result := _ChineseNumeric[21] + Result;
  if ((Round(Value * 100)) div 1) mod 10 = 0 then
    Result := Result + _ChineseNumeric[22];
end;

function RMChineseNumber(const jnum: string): string;
var
  hjnum: real;
  Vstr, zzz, cc, cc1, Presult: string;
  xxbb: array[1..12] of string;
  uppna: array[0..9] of string;
  iCount, iZero {,vpoint}: integer;
begin
  hjnum := strtofloat(jnum);