rm_utils.pas

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

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

unit RM_utils;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls,
  Menus, RM_Class, RM_Dataset
  {$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}

{$IFNDEF Delphi6}
type
  UTF8String = type string;
  PUTF8String = ^UTF8String;
  {$ENDIF}

type
  TRMDeviceCompatibleCanvas = class(TCanvas)
  private
    FReferenceDC: HDC;
    FCompatibleDC: HDC;
    FCompatibleBitmap: HBitmap;
    FOldBitmap: HBitmap;
    FWidth: Integer;
    FHeight: Integer;
    FSavePalette: HPalette;
    FRestorePalette: Boolean;
  protected
    procedure CreateHandle; override;
    procedure Changing; override;
    procedure UpdateFont;
  public
    constructor Create(aReferenceDC: HDC; aWidth, aHeight: Integer; aPalette: HPalette);
    destructor Destroy; override;

    procedure RenderToDevice(aDestRect: TRect; aPalette: HPalette; aCopyMode: TCopyMode);
    property Height: Integer read FHeight;
    property Width: Integer read FWidth;
  end;

procedure RMReadMemo(aStream: TStream; aStrings: TStrings);
procedure RMWriteMemo(aStream: TStream; aStrings: TStrings);
function RMReadString(aStream: TStream): string;
procedure RMWriteString(aStream: TStream; const s: string);
function RMReadBoolean(aStream: TStream): Boolean;
procedure RMWriteBoolean(aStream: TStream; Value: Boolean);
function RMReadByte(aStream: TStream): Byte;
procedure RMWriteByte(aStream: TStream; Value: Byte);
function RMReadWord(aStream: TStream): Word;
procedure RMWriteWord(aStream: TStream; Value: Word);
function RMReadInt32(aStream: TStream): Integer;
procedure RMWriteInt32(aStream: TStream; Value: Integer);
function RMReadLongWord(aStream: TStream): LongWord;
procedure RMWriteLongWord(aStream: TStream; Value: LongWord);
function RMReadFloat(aStream: TStream): Single;
procedure RMWriteFloat(aStream: TStream; Value: Single);
procedure RMReadFont(aStream: TStream; Font: TFont);
procedure RMWriteFont(aStream: TStream; Font: TFont);

function RMFindComponent(aOwner: TComponent; const aComponentName: string): TComponent;
procedure RMGetComponents(aOwner: TComponent; aClassRef: TClass; aList: TStrings; aSkip: TComponent);
procedure RMEnableControls(c: array of TControl; e: Boolean);
function RMGetFontStyle(Style: TFontStyles): Integer;
function RMSetFontStyle(Style: Integer): TFontStyles;
function RMStrToFloat(s: string): Double;
function RMRemoveQuotes(const s: string): string;
procedure RMSetCommaText(Text: string; sl: TStringList);

function RMCanvasWidth(const aStr: string; aFont: TFont): integer;
function RMCanvasHeight(const aStr: string; aFont: TFont): integer;
function RMGetBrackedVariable(const aStr: string; var aBeginPos, aEndPos: Integer): string;
function RMWrapStrings(const SrcLines: TStrings; DstLines: TStrings; aCanvas: TCanvas;
  aWidth: integer; const aOneLineHeight: integer; aWordBreak, aMangeTag, aWidthFlag: Boolean): integer;

function RMNumToBig(Value: Integer): string;
function RMCurrToBIGNum(Value: Currency): string;
function RMChineseNumber(const jnum: string): string;
function RMSmallToBig(curs: string): string;
procedure RMSetFontSize(aComboBox: TComboBox; aFontHeight, aFontSize: integer);
procedure RMSetFontSize1(aListBox: TListBox; aFontSize: integer);
function RMGetFontSize(aComboBox: TComboBox): integer;
function RMGetFontSize1(aIndex: Integer; aText: string): integer;
function RMCreateBitmap(const ResName: string): TBitmap;
function RMLoadStr(aResID: Integer): string;
procedure RMSetStrProp(aObject: TObject; const aPropName: string; ID: Integer);
function RMGetPropValue(aReport: TRMReport; 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(aParentKey: string; aForm: TForm);
procedure RMRestoreFormPosition(aParentKey: string; aForm: 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;

function RMisNumeric(St: string): Boolean;
function RMStrGetToken(s: string; delimeter: string; var APos: integer): string;
function RMCmp(const S1, S2: string): Boolean;
function RMExtractField(const aStr: string; aFieldNo: Integer): string;
procedure RMSetNullValue(var aValue1, aValue2: Variant);

procedure RMPrintGraphic(aCanvas: TCanvas; aDestRect: TRect; aGraphic: TGraphic;
  aIsPrinting: Boolean; aDirectDraw: Boolean; aTransparent: Boolean);
function RMDeleteNoNumberChar(s: string): string;

implementation

uses
  TypInfo, Registry, RM_Common, RM_Const, RM_Const1;

type
  THackReport = class(TRMReport)
  end;

  {$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 RMReadMemo40(aStream: TStream; aStrings: TStrings);
var
  lStr: string;
  i, lCount: Integer;
begin
  aStrings.Clear;
  aStream.Read(lCount, 4);
  for i := 0 to lCount - 1 do
  begin
    aStream.Read(lCount, 4);
    SetLength(lStr, lCount);
    if lCount > 0 then
    begin
      aStream.Read(lStr[1], lCount);
      aStrings.Add(lStr);
    end;
  end;
end;

procedure RMWriteMemo40(aStream: TStream; aStrings: TStrings);
var
  lStr: string;
  i: Integer;
  lCount: Integer;
begin
  lCount := aStrings.Count;
  aStream.Write(lCount, 4);
  for i := 0 to aStrings.Count - 1 do
  begin
    lStr := aStrings[i];
    lCount := Length(lStr);
    aStream.Write(lCount, 4);
    if lCount > 0 then
      aStream.Write(lStr[1], lCount);
  end;
end;

procedure RMReadMemo(aStream: TStream; aStrings: TStrings);
var
  lStr: string;
  lStrLen: Integer;
begin
  aStrings.Clear;
  lStrLen := RMReadInt32(aStream);
  if lStrLen > 0 then
  begin
    SetString(lStr, PChar(nil), lStrLen);
    aStream.Read(Pointer(lStr)^, lStrLen);
    aStrings.Text := lStr;
  end;
end;

procedure RMWriteMemo(aStream: TStream; aStrings: TStrings);
var
  lStr: string;
  lStrLen: Integer;
begin
  lStr := aStrings.Text;
  lStrLen := Length(lStr);
  RMWriteInt32(aStream, lStrLen);
  if lStrLen > 0 then
    aStream.WriteBuffer(Pointer(lStr)^, lStrLen);
end;

function RMReadString(aStream: TStream): string;
var
  s: string;
  n: Word;
begin
  aStream.Read(n, 2);
  SetLength(s, n);
  aStream.Read(s[1], n);
  Result := s;
end;

procedure RMWriteString(aStream: TStream; const s: string);
var
  n: Word;
begin
  n := Length(s);
  aStream.Write(n, 2);
  aStream.Write(s[1], n);
end;

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

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

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

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

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

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

function RMReadInt32(aStream: TStream): Integer;
begin
  aStream.Read(Result, 4);
end;

procedure RMWriteInt32(aStream: TStream; Value: Integer);
begin
  aStream.Write(Value, 4);
end;

function RMReadLongWord(aStream: TStream): LongWord;
begin
  aStream.Read(Result, 4);
end;

procedure RMWriteLongWord(aStream: TStream; Value: LongWord);
begin
  aStream.Write(Value, 4);
end;

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

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

{$HINTS OFF}

procedure RMReadFont(aStream: TStream; Font: TFont);
var
  lSize: Integer;

  function _SetFontStyle(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;

begin
  Font.Name := RMReadString(aStream);
  lSize := RMReadInt32(aStream);
  if lSize >= 0 then
    Font.Size := lSize
  else
    Font.Height := lSize;

  Font.Style := _SetFontStyle(RMReadWord(aStream));
  Font.Color := RMReadInt32(aStream);
  Font.Charset := RMReadWord(aStream);
end;

procedure RMWriteFont(aStream: TStream; Font: TFont);

  function _GetFontStyle(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;

begin
  RMWriteString(aStream, Font.Name);
  RMWriteInt32(aStream, Font.Height {Size});
  RMWriteWord(aStream, _GetFontStyle(Font.Style));
  RMWriteInt32(aStream, Font.Color);
  RMWriteWord(aStream, Font.Charset);
end;
{$HINTS ON}

function RMLoadStr(aResID: Integer): string;
begin
  Result := RMResourceManager.LoadStr(aResID);
end;

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 RMFindComponent(aOwner: TComponent; const aComponentName: string): TComponent;
var
  n: Integer;
  s1, s2: string;
begin
  Result := nil;
  if aComponentName = '' then Exit;

  n := Pos('.', aComponentName);
  try
    if n = 0 then
    begin
      if aOwner <> nil then
        Result := aOwner.FindComponent(aComponentName);
    end
    else
    begin
      s1 := Copy(aComponentName, 1, n - 1); // module name
      s2 := Copy(aComponentName, n + 1, 99999); // component name
      Result := RMFindComponent(FindGlobalComponent(s1), s2);
    end;
  except
    on Exception do
      raise EClassNotFound.Create('Missing ' + aComponentName);
  end;
end;

// --> Leon, 2004-10-10, 增加

function RMClassIsOk(aComponent: TComponent; aClassRef: TClass): boolean;
var
  lClass: TClass;
begin
  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 Delphi6}
  j: Integer;
  {$ENDIF}

  procedure _EnumComponents(aComponent: TComponent);
  var
    i: Integer;
    lComponent: TComponent;
  begin
    {$IFDEF Delphi5}
    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];
      if (lComponent.Name <> '') and (lComponent <> aSkip) and
        RMClassIsOk(lComponent, aClassRef) {(lComponent is aClassRef)} then
      begin
        if aComponent = aOwner then
          aList.Add(lComponent.Name)
        else if ((aComponent is TForm) or (aComponent is TDataModule)) then
          aList.Add(aComponent.Name + '.' + lComponent.Name)
        else
          aList.Add(TControl(aComponent).Parent.Name + '.' + aComponent.Name + '.' + lComponent.Name)
      end;
    end;
  end;