rm_utils.pas

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

{*****************************************}
{                                         }
{           Report Machine v2.0           }
{            Various routines             }
{                                         }
{*****************************************}

unit RM_utils;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls,
  Menus, RM_DBRel, DB
{$IFDEF Delphi4}, SysConst{$ENDIF}
{$IFDEF Delphi6}, Variants{$ENDIF};

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

{$IFNDEF DELPHI4}
type
  TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);

function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;
function Min(A, B: Single): Single;
function Max(A, B: Double): Double;
{$ENDIF}

procedure RMReadMemo(Stream: TStream; l: TStrings);
procedure RMReadMemo22(Stream: TStream; l: TStrings);
procedure RMWriteMemo(Stream: TStream; l: TStrings);
function RMReadString(Stream: TStream): string;
function RMReadString22(Stream: TStream): string;
procedure RMWriteString(Stream: TStream; s: string);
function RMReadBoolean(Stream: TStream): Boolean;
function RMReadByte(Stream: TStream): Byte;
function RMReadWord(Stream: TStream): Word;
function RMReadInteger(Stream: TStream): Integer;
procedure RMReadFont(Stream: TStream; Font: TFont);
procedure RMWriteBoolean(Stream: TStream; Value: Boolean);
procedure RMWriteByte(Stream: TStream; Value: Byte);
procedure RMWriteWord(Stream: TStream; Value: Word);
procedure RMWriteInteger(Stream: TStream; Value: Integer);
procedure RMWriteFont(Stream: TStream; Font: TFont);
function RMReadFloat(Stream: TStream): Single;
procedure RMWriteFloat(Stream: TStream; Value: Single);

procedure RMEnableControls(c: array of TControl; e: Boolean);
function RMGetDataSet(ComplexName: string): TDataSet;
function RMGetFieldValue(F: TField): Variant;
procedure RMGetDataSetAndField(aComplexName: string; var aDataSet: TDataSet; var aField: string);
function RMGetFontStyle(Style: TFontStyles): Integer;
function RMSetFontStyle(Style: Integer): TFontStyles;
function RMFindComponent(Owner: TComponent; Name: string): TComponent;
procedure RMGetComponents(Owner: TComponent; ClassRef: TClass; List: TStrings; Skip: TComponent);
function RMStrToFloat(s: string): Double;
function RMRemoveQuotes(const s: string): string;
procedure RMSetCommaText(Text: string; sl: TStringList);

function RMCanvasWidth(const str: string; AFont: TFont): integer;
function RMCanvasHeight(const str: string; AFont: TFont): integer;
function RMWrapStrings(const SrcLines: TStrings; DstLines: TStrings; aCanvas: TCanvas;
  aWidth: integer; const aOneLineHeight: integer; aWordBreak, aMangeTag, aWidthFlag: Boolean): integer;

function RMGetBrackedVariable(const s: string; var i, j: Integer): string;

function RMCurrToBIGNum(Value: Currency): string;
function RMChineseNumber(const jnum: string): string;
function RMSmallToBig(curs: string): string;
procedure RMSetFontSize(aComboBox: TComboBox; aFontSize: integer);
function RMGetFontSize(aComboBox: TComboBox): integer;
function RMCreateBitmap(const ResName: string): TBitmap;
function RMLoadStr(ID: Integer): string;
procedure RMSetStrProp(aObject: TObject; const aPropName: string; ID: Integer);
function RMGetPropValue(const aObjectName, aPropName: string): Variant;
function RMRound(x: Extended; dicNum: Integer): Extended; //四舍五入

function RMMakeFileName(AFileName, AFileExtension: string; ANumber: Integer): string;
function RMAppendTrailingBackslash(const S: string): string;
function RMColorBGRToRGB(AColor: TColor): string;
function RMMakeImgFileName(AFileName, AFileExtension: string; ANumber: Integer): string;
procedure RMSetControlsEnable(AControl: TWinControl; AState: Boolean);

procedure RMSaveFormPosition(f: TForm);
procedure RMRestoreFormPosition(f: TForm);
procedure RMGetBitmapPixels(aGraphic: TGraphic; var x, y: Integer);
function RMGetWindowsVersion: string;

function RMMonth_EnglishShort(aMonth: Integer): string;
function RMMonth_EnglishLong(aMonth: Integer): string;
function RMSinglNumToBig(Value: Extended; Digit: Integer): string;

function RMStream2TXT(aStream: TStream): AnsiString;
function RMTXT2Stream(inStr: AnsiString; OutStream: TStream): Boolean;

implementation

uses TypInfo, Registry, RM_Const1, RM_Class, RM_DSet;

{$IFNDEF DELPHI4}

function Min(A, B: Single): Single;
begin
  if A < B then
    Result := A
  else
    Result := B;
end;

function Max(A, B: Double): Double;
begin
  if A > B then
    Result := A
  else
    Result := B;
end;

function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;
var
  SearchStr, Patt, NewStr: string;
  Offset: Integer;
begin
  if rfIgnoreCase in Flags then
  begin
    SearchStr := AnsiUpperCase(S);
    Patt := AnsiUpperCase(OldPattern);
  end else
  begin
    SearchStr := S;
    Patt := OldPattern;
  end;
  NewStr := S;
  Result := '';
  while SearchStr <> '' do
  begin
    Offset := AnsiPos(Patt, SearchStr);
    if Offset = 0 then
    begin
      Result := Result + NewStr;
      Break;
    end;
    Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
    if not (rfReplaceAll in Flags) then
    begin
      Result := Result + NewStr;
      Break;
    end;
    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  end;
end;
{$ENDIF}

function RMSetFontStyle(Style: Integer): TFontStyles;
begin
  Result := [];
  if (Style and $1) <> 0 then
    Result := Result + [fsItalic];
  if (Style and $2) <> 0 then
    Result := Result + [fsBold];
  if (Style and $4) <> 0 then
    Result := Result + [fsUnderLine];
  if (Style and $8) <> 0 then
    Result := Result + [fsStrikeOut];
end;

function RMGetFontStyle(Style: TFontStyles): Integer;
begin
  Result := 0;
  if fsItalic in Style then
    Result := Result or $1;
  if fsBold in Style then
    Result := Result or $2;
  if fsUnderline in Style then
    Result := Result or $4;
  if fsStrikeOut in Style then
    Result := Result or $8;
end;

procedure RMReadMemo(Stream: TStream; l: TStrings);
var
  s: string;
  b: Byte;
  n: Word;
begin
  l.Clear;
  Stream.Read(n, 2);
  if n > 0 then
  begin
    repeat
      Stream.Read(n, 2);
      SetLength(s, n);
      if n > 0 then
        Stream.Read(s[1], n);
      l.Add(s);
      Stream.Read(b, 1);
    until b = 0;
  end
  else
    Stream.Read(b, 1);
end;

procedure RMWriteMemo(Stream: TStream; l: TStrings);
var
  s: string;
  i: Integer;
  n: Word;
  b: Byte;
begin
  n := l.Count;
  Stream.Write(n, 2);
  for i := 0 to l.Count - 1 do
  begin
    s := l[i];
    n := Length(s);
    Stream.Write(n, 2);
    if n > 0 then
      Stream.Write(s[1], n);
    b := 13;
    if i <> l.Count - 1 then
      Stream.Write(b, 1);
  end;
  b := 0;
  Stream.Write(b, 1);
end;

function RMReadString(Stream: TStream): string;
var
  s: string;
  n: Word;
  b: Byte;
begin
  Stream.Read(n, 2);
  SetLength(s, n);
  if n > 0 then
    Stream.Read(s[1], n);
  Stream.Read(b, 1);
  Result := s;
end;

procedure RMWriteString(Stream: TStream; s: string);
var
  b: Byte;
  n: Word;
begin
  n := Length(s);
  Stream.Write(n, 2);
  if n > 0 then
    Stream.Write(s[1], n);
  b := 0;
  Stream.Write(b, 1);
end;

procedure RMReadMemo22(Stream: TStream; l: TStrings);
var
  s: string;
  i: Integer;
  b: Byte;
begin
  SetLength(s, 4096);
  l.Clear;
  i := 1;
  repeat
    Stream.Read(b, 1);
    if (b = 13) or (b = 0) then
    begin
      SetLength(s, i - 1);
      if not ((b = 0) and (i = 1)) then
        l.Add(s);
      SetLength(s, 4096);
      i := 1;
    end
    else if b <> 0 then
    begin
      s[i] := Chr(b);
      Inc(i);
      if i > 4096 then
        SetLength(s, Length(s) + 4096);
    end;
  until b = 0;
end;

function RMReadString22(Stream: TStream): string;
var
  s: string;
  i: Integer;
  b: Byte;
begin
  SetLength(s, 4096);
  i := 1;
  repeat
    Stream.Read(b, 1);
    if b = 0 then
      SetLength(s, i - 1)
    else
    begin
      s[i] := Chr(b);
      Inc(i);
      if i > 4096 then
        SetLength(s, Length(s) + 4096);
    end;
  until b = 0;
  Result := s;
end;

function RMReadBoolean(Stream: TStream): Boolean;
begin
  Stream.Read(Result, 1);
end;

function RMReadByte(Stream: TStream): Byte;
begin
  Stream.Read(Result, 1);
end;

function RMReadWord(Stream: TStream): Word;
begin
  Stream.Read(Result, 2);
end;

function RMReadInteger(Stream: TStream): Integer;
begin
  Stream.Read(Result, 4);
end;

{$HINTS OFF}

procedure RMReadFont(Stream: TStream; Font: TFont);
var
  w: Word;
begin
  Font.Name := RMReadString(Stream);
  Font.Size := RMReadInteger(Stream);
  Font.Style := RMSetFontStyle(RMReadWord(Stream));
  Font.Color := RMReadInteger(Stream);
  w := RMReadWord(Stream);
{$IFNDEF Delphi2}
  Font.Charset := w;
{$ENDIF}
end;
{$HINTS ON}

procedure RMWriteBoolean(Stream: TStream; Value: Boolean);
begin
  Stream.Write(Value, 1);
end;

procedure RMWriteByte(Stream: TStream; Value: Byte);
begin
  Stream.Write(Value, 1);
end;

procedure RMWriteWord(Stream: TStream; Value: Word);
begin
  Stream.Write(Value, 2);
end;

procedure RMWriteInteger(Stream: TStream; Value: Integer);
begin
  Stream.Write(Value, 4);
end;

function RMReadFloat(Stream: TStream): Single;
begin
  Stream.Read(Result, SizeOf(Result));
end;

procedure RMWriteFloat(Stream: TStream; Value: Single);
begin
  Stream.Write(Value, SizeOf(Value));
end;

{$HINTS OFF}

procedure RMWriteFont(Stream: TStream; Font: TFont);
var
  w: Word;
begin
  RMWriteString(Stream, Font.Name);
  RMWriteInteger(Stream, Font.Size);
  RMWriteWord(Stream, RMGetFontStyle(Font.Style));
  RMWriteInteger(Stream, Font.Color);
  w := RMCharset;
{$IFNDEF Delphi2}
  w := Font.Charset;
{$ENDIF}
  RMWriteWord(Stream, w);
end;
{$HINTS ON}

type
  THackWinControl = class(TWinControl)
  end;

procedure RMEnableControls(c: array of TControl; e: Boolean);
const
  Clr1: array[Boolean] of TColor = (clGrayText, clWindowText);
  Clr2: array[Boolean] of TColor = (clBtnFace, clWindow);
var
  i: Integer;
begin
  for i := Low(c) to High(c) do
  begin
    if c[i] is TLabel then
    begin
      with TLabel(c[i]) do
      begin
        Font.Color := Clr1[e];
        Enabled := e;
      end;
    end
    else if c[i] is TWinControl then
    begin
      with THackWinControl(c[i]) do
      begin
        Color := Clr2[e];
        Enabled := e;
      end;
    end
    else
      c[i].Enabled := e;
  end;
end;

function RMGetDataSet(ComplexName: string): TDataSet;
begin
  Result := TDataSet(RMFindComponent(CurReport.Owner, ComplexName));
end;

function RMGetFieldValue(F: TField): Variant;
begin
//  if not F.DataSet.Active then
//    F.DataSet.Open;
  if Assigned(F.OnGetText) then
    Result := F.DisplayText
  else
  begin
{$IFDEF Delphi4}
    if F.DataType in [ftLargeint] then
      Result := F.DisplayText
    else
{$ENDIF}
      Result := F.AsVariant;
//    if F.DataType in [ftCurrency{$IFDEF Delphi4}, ftLargeint{$ENDIF}] then
//      Result := F.DisplayText
//    else
//      Result := F.AsVariant;
  end;

  if Result = Null then
  begin
    if F.DataType in [ftString{$IFDEF Delphi4}, ftWideString{$ENDIF}] then
      Result := ''
    else if F.DataType = ftBoolean then
      Result := False
    else
      Result := 0;
  end;
end;

type
  THackReport = class(TRMReport)
  end;

procedure RMGetDataSetAndField(aComplexName: string; var aDataSet: TDataSet; var aField: string);
var
  i, j, n: Integer;
  f: TComponent;
  sl: TStringList;
  s: string;
  c: Char;
  cn: TControl;
  liDatasetOwner: TComponent;

  function FindField(aDataSet: TDataSet; const aFieldName: string): string;
  var
    sl: TStringList;
  begin
    Result := '';
    if aDataSet <> nil then
    begin
      sl := TStringList.Create;
      RMGetFieldNames(aDataSet, sl);
      if sl.IndexOf(aFieldName) <> -1 then
        Result := aFieldName;
      sl.Free;
    end;
  end;

begin
  sl := TStringList.Create;
  try
    aField := '';
    f := CurReport.Owner;
    if CurReport <> nil then
      liDatasetOwner := THackReport(CurReport).FDefaultDatasetOwner
    else
      liDatasetOwner := nil;

    n := 0; j := 1;
    for i := 1 to Length(aComplexName) do
    begin
      c := aComplexName[i];
      if c = '"' then
      begin
        sl.Add(Copy(aComplexName, i, 255));
        j := i;
        Break;
      end
      else if c = '.' then
      begin
        sl.Add(Copy(aComplexName, j, i - j));
        j := i + 1;
        Inc(n);
      end;
    end;

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

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