rm_utils.pas

这是一个功能强大

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

unit RM_utils;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, TypInfo, Classes, Graphics, Controls, Forms, StdCtrls,
  Menus, RM_Common, RM_Class, RM_Dataset
{$IFDEF COMPILER4_UP}, SysConst{$ENDIF}
{$IFDEF COMPILER6_UP}, Variants{$ENDIF}
{$IFDEF COMPILER7_UP}, StrUtils{$ENDIF}
{$IFDEF TntUnicode}, TntSysUtils{$ENDIF};

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

{$IFNDEF COMPILER4_UP}
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 COMPILER6_UP}
type
  UTF8String = type string;
  PUTF8String = ^UTF8String;

function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload;
function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload;

function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload;
function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload;

function UTF8Encode(const WS: WideString): UTF8String;
function UTF8Decode(const S: UTF8String): WideString;
{$ENDIF}

type

  { TRMDeviceCompatibleCanvas }
  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;

  { TRMHtmlFontStack }
  TRMHtmlFontStack = class(TObject) //字体栈
  private
    FFontList: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Push(aFont: TFont);
    function Pop: TFont;
  end;

  PRMHtmlElement = ^TRMtmlElement;
  TRMtmlElement = record
    H_tag: WideString; //标记名称
    H_str: WideString; //字符内容
    H_paras: array of WideString; //参数名称列表
    H_values: array of WideString; //参数值列表
    H_TagStr: WideString;
  end;

  PRMHtmlParaValue = ^TRMHtmlParaValue;
  TRMHtmlParaValue = record
    ParaName: WideString; //参数名称
    ParaValue: WideString; //参数的值
  end;

  { TRMHtmlList }
  TRMHtmlList = class(TList)
  private
  protected
  public
    procedure Clear; override;
  end;

function RMReadAnsiMemo(aStream: TStream): string;
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 RMReadWideString(aStream: TStream): WideString;
procedure RMReadWideMemo(aStream: TStream; aStrings: TWideStrings);
procedure RMWriteWideMemo(aStream: TStream; aStrings: TWideStrings);
procedure RMWriteWideString(aStream: TStream; const s: WideString);
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 RMReadRect(aStream: TStream): TRect;
procedure RMWriteRect(aStream: TStream; aRect: TRect);

{Added by dejoy begin}
procedure RMReadObjFromStream(aStream: TStream; aObj : TPersistent);
procedure RMWriteObjToStream(aStream: TStream; aObj : TPersistent);

procedure RMReadObjFromFile(aObj:TPersistent;const aFileName:String);
procedure RMWriteObjToFile(aObj:TPersistent;const aFilename:String);
{Added by dejoy end}

function RMWideCharIn(aChar: WideChar; aSysCharSet: TSysCharSet): Boolean;
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 RMRemoveQuotes(const aStr: WideString): WideString;
procedure RMSetCommaText(Text: string; sl: TStringList);

function RMWideCanvasTextExtent(aCanvas: TCanvas; const aText: WideString): TSize;
function RMWideCanvasTextWidth(aCanvas: TCanvas; const aText: WideString): Integer;
function RMWideCanvasTextHeight(aCanvas: TCanvas; const aText: WideString): Integer;
function RMCanvasWidth(const aStr: string; aFont: TFont): Integer;
function RMCanvasHeight(const aStr: string; aFont: TFont): Integer;
function RMWrapStrings(const aSrcLines: TWideStringList; aDstLines: TWideStringList;
  aCanvas: TCanvas; aWidth: Integer; const aLineSpacing: Integer;
  aWordBreak, aCharWrap, aAllowHtmlTag, aWidthFlag, aAddChar: Boolean): integer;

function RMLoadStr(aResID: Integer): string;
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;
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 RMGetTmpFileName: string; overload;
function RMGetTmpFileName(aExt: string): string; overload;

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 RMStrToFloat(aStr: string): Double;
function RMisNumeric(aStr: string): Boolean;
function RMIsValidFloat(aStr: string): Boolean;
function RMStrGetToken(s: string; delimeter: string; var APos: integer): string;
function RMExtractField(const aStr: string; aFieldNo: Integer): string;
procedure RMSetNullValue(var aValue1, aValue2: Variant);
procedure RMSetControlsEnabled(aControl: TWinControl; aEnabled: Boolean);

procedure RMPrintGraphic(const aCanvas: TCanvas; aDestRect: TRect; const aGraphic: TGraphic;
  aIsPrinting: Boolean; aDirectDraw: Boolean; aTransparent: Boolean);
function RMDeleteNoNumberChar(s: string): string;
function RMO2V(O: TObject): Variant;
{$IFNDEF COMPILER6_UP}
function TryStrToFloat(const S: string; out Value: Extended): Boolean;
{$ENDIF}
function RMNumToLetters(Number: Real): string;
function RMTrim(aStr: string): string;

procedure RMHtmlAnalyseElement(aSourceStr: WideString; var aHtmlElements: TRMHtmlList);
procedure RMHtmlSetFont(aFont: TFont; aHtmlElement: PRMHtmlElement;
  aFontStack: TRMHtmlFontStack; aDocMode: TRMDocMode; aFactorY: Double; aList: TWideStringList);

function RMPosEx(const SubStr, S: WideString; Offset: Cardinal = 1): Integer;

//added by dejoy
procedure GetMethodDefinition(ATypeInfo: PTypeInfo; AStrings: TStrings);overload;
function GetMethodDefinition(ATypeInfo: PTypeInfo):string;overload;
function GetFullMethodDefinition(Instance: TComponent; const PropName: string):string;

implementation

uses
  Math, Registry, RM_Const, RM_Const1;

type
  THackReport = class(TRMReport)
  end;

function RMWideCharIn(aChar: WideChar; aSysCharSet: TSysCharSet): Boolean;
begin
  Result := (aChar <= High(AnsiChar)) and (AnsiChar(aChar) in aSysCharSet);
end;

function RMO2V(O: TObject): Variant;
begin
  TVarData(Result).VType := $0010;
  TVarData(Result).vPointer := O;
end;

{$IFNDEF COMPILER4_UP}

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}

{$IFNDEF COMPILER6_UP}

function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer;
var
  len: Cardinal;
begin
  len := 0;
  if Source <> nil then
    while Source[len] <> #0 do
      Inc(len);
  Result := UnicodeToUtf8(Dest, MaxBytes, Source, len);
end;

// UnicodeToUtf8(4):
// MaxDestBytes includes the null terminator (last char in the buffer will be set to null)
// Function result includes the null terminator.
// Nulls in the source data are not considered terminators - SourceChars must be accurate

function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
var
  i, count: Cardinal;
  c: Cardinal;
begin
  Result := 0;
  if Source = nil then Exit;
  count := 0;
  i := 0;
  if Dest <> nil then
  begin
    while (i < SourceChars) and (count < MaxDestBytes) do
    begin
      c := Cardinal(Source[i]);
      Inc(i);
      if c <= $7F then
      begin
        Dest[count] := Char(c);
        Inc(count);
      end
      else if c > $7FF then
      begin
        if count + 3 > MaxDestBytes then
          break;
        Dest[count] := Char($E0 or (c shr 12));
        Dest[count + 1] := Char($80 or ((c shr 6) and $3F));
        Dest[count + 2] := Char($80 or (c and $3F));
        Inc(count, 3);
      end
      else //  $7F < Source[i] <= $7FF
      begin
        if count + 2 > MaxDestBytes then
          break;
        Dest[count] := Char($C0 or (c shr 6));
        Dest[count + 1] := Char($80 or (c and $3F));
        Inc(count, 2);
      end;
    end;
    if count >= MaxDestBytes then count := MaxDestBytes - 1;
    Dest[count] := #0;
  end
  else
  begin
    while i < SourceChars do
    begin
      c := Integer(Source[i]);
      Inc(i);
      if c > $7F then
      begin
        if c > $7FF then
          Inc(count);
        Inc(count);
      end;
      Inc(count);
    end;
  end;
  Result := count + 1; // convert zero based index to byte count
end;

function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer;
var
  len: Cardinal;
begin
  len := 0;
  if Source <> nil then
    while Source[len] <> #0 do
      Inc(len);
  Result := Utf8ToUnicode(Dest, MaxChars, Source, len);
end;

function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal;
var
  i, count: Cardinal;
  c: Byte;
  wc: Cardinal;
begin
  if Source = nil then
  begin
    Result := 0;
    Exit;
  end;
  Result := Cardinal(-1);
  count := 0;
  i := 0;
  if Dest <> nil then
  begin
    while (i < SourceBytes) and (count < MaxDestChars) do
    begin
      wc := Cardinal(Source[i]);
      Inc(i);
      if (wc and $80) <> 0 then
      begin
        if i >= SourceBytes then Exit; // incomplete multibyte char
        wc := wc and $3F;
        if (wc and $20) <> 0 then
        begin
          c := Byte(Source[i]);
          Inc(i);
          if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char
          if i >= SourceBytes then Exit; // incomplete multibyte char
          wc := (wc shl 6) or (c and $3F);
        end;
        c := Byte(Source[i]);
        Inc(i);
        if (c and $C0) <> $80 then Exit; // malformed trail byte

        Dest[count] := WideChar((wc shl 6) or (c and $3F));
      end
      else
        Dest[count] := WideChar(wc);
      Inc(count);
    end;
    if count >= MaxDestChars then count := MaxDestChars - 1;
    Dest[count] := #0;
  end
  else
  begin
    while (i < SourceBytes) do
    begin
      c := Byte(Source[i]);
      Inc(i);
      if (c and $80) <> 0 then
      begin
        if i >= SourceBytes then Exit; // incomplete multibyte char
        c := c and $3F;
        if (c and $20) <> 0 then
        begin
          c := Byte(Source[i]);
          Inc(i);
          if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char
          if i >= SourceBytes then Exit; // incomplete multibyte char
        end;
        c := Byte(Source[i]);
        Inc(i);
        if (c and $C0) <> $80 then Exit; // malformed trail byte
      end;
      Inc(count);
    end;
  end;
  Result := count + 1;
end;

function UTF8Encode(const WS: WideString): UTF8String;
var
  L: Integer;
  Temp: UTF8String;
begin
  Result := '';
  if WS = '' then Exit;
  SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator

  L := UnicodeToUtf8(PChar(Temp), Length(Temp) + 1, PWideChar(WS), Length(WS));
  if L > 0 then
    SetLength(Temp, L - 1)
  else
    Temp := '';
  Result := Temp;
end;

function UTF8Decode(const S: UTF8String): WideString;
var
  L: Integer;