rm_utils.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,252 行 · 第 1/4 页

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 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 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 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);
    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 aStr: string; var aBeginPos, aEndPos: Integer): string;
var
  c: Integer;
  lFlag1, lFlag2: Boolean;
  lStrLen: Integer;
begin
  aEndPos := aBeginPos;
  lFlag1 := True;
  lFlag2 := True;
  c := 0;
  Result := '';
  lStrLen := Length(aStr);
  if (aStr = '') or (aBeginPos >= lStrLen) or (aEndPos > lStrLen) then
    Exit;

  Dec(aEndPos);
  repeat
    Inc(aEndPos);
    if aStr[aEndPos] in LeadBytes then
    begin
      aEndPos := aEndPos + 1;
    end
    else
    begin
      if lFlag1 and lFlag2 then
      begin
        if aStr[aEndPos] = '[' then
        begin
          if c = 0 then
            aBeginPos := aEndPos;
          Inc(c);
        end
        else if aStr[aEndPos] = ']' then
          Dec(c);
      end;

      if lFlag1 then
      begin
        if aStr[aEndPos] = '"' then
          lFlag2 := not lFlag2;
      end;

      if lFlag2 then
      begin
        if aStr[aEndPos] = '''' then
          lFlag1 := not lFlag1;
      end;
    end;
  until (c = 0) or (aEndPos >= lStrLen);

  Result := Copy(aStr, aBeginPos + 1, aEndPos - aBeginPos - 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;
  lNeedAddZero: 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;

  lNeedAddZero := 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 (iSection = 0) and (i = 1) then
          lNeedAddZero := True;

        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 + Result;
        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
    if lNeedAddZero then // 需要加"零", 107000.53:壹拾万柒仟元零伍角叁分
      Result := Result + _ChineseNumeric[0];

    for i := iPosOfDecimalPoint + 1 to Length(sArabic) do
    begin
      iDigit := Ord(sArabic[i]) - 48;
      Result := Result + _ChineseNumeric[iDigit];
      case i - (iPosOfDecimalPoint + 1) of
        0:
          begin
            if iDigit > 0 then
              Result := Result + _ChineseNumeric[17];
          end;
        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);
  result := '';
  presult := '';
  if hjnum < 0 then
  begin
    hjnum := -hjnum;
    Result := '负';
  end;

  xxbb[1] := '亿';
  xxbb[2] := '千';
  xxbb[3] := '百';
  xxbb[4] := '十';
  xxbb[5] := '万';
  xxbb[6] := '千';
  xxbb[7] := '百';
  xxbb[8] := '十';
  xxbb[9] := '一';
  xxbb[10] := '.';
  xxbb[11] := '';
  xxbb[12] := '';

  uppna[0] := '零';
  uppna[1] := '一';
  uppna[2] := '二';
  uppna[3] := '三';
  uppna[4] := '四';
  uppna[5] := '五';
  uppna[6] := '六';
  uppna[7] := '七';
  uppna[8] := '八';
  uppna[9] := '九';

  Str(hjnum: 12: 2, Vstr);
  cc := '';
  cc1 := '';
  zzz := '';

  iZero := 0;
  //  vPoint:=0;
  for iCount := 1 to 10 do
  begin
    cc := Vstr[iCount];
    if cc <> ' ' then
    begin
      zzz := xxbb[iCount];
      if cc = '0' then
      begin
        if iZero < 1 then //*对“零”进行判断*//
          cc := '零'
        else
          cc := '';
        if iCount = 5 then //*对万位“零”的处理*//
          if copy(result, length(result) - 1, 2) = '零' then
            result := copy(result, 1, length(result) - 2) + xxbb[iCount] + '零'
          else
            result := result + xxbb[iCount];
        cc1 := cc;
        zzz := '';