rm_utils.pas

这是一个功能强大

  Temp: WideString;
begin
  Result := '';
  if S = '' then Exit;
  SetLength(Temp, Length(S));

  L := Utf8ToUnicode(PWideChar(Temp), Length(Temp) + 1, PChar(S), Length(S));
  if L > 0 then
    SetLength(Temp, L - 1)
  else
    Temp := '';
  Result := Temp;
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;

function RMReadAnsiMemo(aStream: TStream): string;
var
  lStrLen: Integer;
begin
  Result := '';
  lStrLen := RMReadInt32(aStream);
  if lStrLen > 0 then
  begin
    SetLength(Result, lStrLen);
    aStream.Read(Pointer(Result)^, lStrLen);
  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
  n: Word;
begin
  aStream.Read(n, 2);
  SetLength(Result, n);
  aStream.Read(Pointer(Result)^, n);
end;

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

function RMReadWideString(aStream: TStream): WideString;
var
  lCount: Integer;
  lUtf8Str: string;
  lType: TRMValueType;
begin
  aStream.Read(lType, 1);
  if lType = rmvaUTF8String then
  begin
    aStream.Read(lCount, 4);
    SetLength(lUtf8Str, lCount);
    aStream.Read(Pointer(lUtf8Str)^, lCount);
    Result := UTF8Decode(lUtf8Str);
  end
  else
  begin
    aStream.Read(lCount, 4);
    SetLength(Result, lCount);
    aStream.Read(Pointer(Result)^, lCount * 2);
  end;
end;

procedure RMWriteWideString(aStream: TStream; const s: WideString);
var
  lCount, lCountUtf8: Integer;
  lUtf8Str: string;
  lType: TRMValueType;
begin
  lUtf8Str := Utf8Encode(s);
  lCount := Length(s);
  lCountUtf8 := Length(lUtf8Str);
  if lCountUtf8 < (lCount * SizeOf(WideChar)) then
  begin
    lType := rmvaUTF8String;
    aStream.Write(lType, 1);

    aStream.Write(lCountUtf8, 4);
    aStream.Write(Pointer(lUtf8Str)^, lCountUtf8);
  end
  else
  begin
    lType := rmvaWideString;
    aStream.Write(lType, 1);

    aStream.Write(lCount, 4);
    aStream.Write(Pointer(s)^, lCount * 2);
  end;
end;

procedure RMReadWideMemo(aStream: TStream; aStrings: TWideStrings);
var
  lLen: Integer;
  lStr: WideString;
  lUtf8Str: string;
  lType: TRMValueType;
begin
  aStrings.Clear;
  aStream.Read(lType, 1);
  if lType = rmvaUTF8String then
  begin
    aStream.Read(lLen, 4);
    SetLength(lUtf8Str, lLen);
    aStream.Read(Pointer(lUtf8Str)^, lLen);
    aStrings.Text := Utf8Decode(lUtf8Str);
  end
  else
  begin
    aStream.Read(lLen, 4);
    SetLength(lStr, lLen);
    aStream.Read(Pointer(lStr)^, lLen * 2);
    aStrings.Text := lStr;
  end;
end;

procedure RMWriteWideMemo(aStream: TStream; aStrings: TWideStrings);
var
  lLen, lLenUtf8: Integer;
  lStr: WideString;
  lUtf8Str: string;
  lType: TRMValueType;
begin
  lStr := aStrings.Text;
  lUtf8Str := Utf8Encode(lStr);
  lLen := Length(lStr);
  lLenUtf8 := Length(lUtf8Str);
  if lLenUtf8 < (lLen * 2) then
  begin
    lType := rmvaUTF8String;
    aStream.Write(lType, 1);

    aStream.Write(lLenUtf8, 4);
    aStream.Write(Pointer(lUtf8Str)^, lLenUtf8);
  end
  else
  begin
    lType := rmvaWideString;
    aStream.Write(lType, 1);

    aStream.Write(lLen, 4);
    aStream.Write(Pointer(lStr)^, lLen * 2);
  end;
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 RMReadRect(aStream: TStream): TRect;
begin
  Result.Left := RMReadInt32(aStream);
  Result.Top := RMReadInt32(aStream);
  Result.Right := RMReadInt32(aStream);
  Result.Bottom := RMReadInt32(aStream);
end;

procedure RMWriteRect(aStream: TStream; aRect: TRect);
begin
  RMWriteInt32(aStream, aRect.Left);
  RMWriteInt32(aStream, aRect.Top);
  RMWriteInt32(aStream, aRect.Right);
  RMWriteInt32(aStream, aRect.Bottom);
end;

type
  TWrapperComponent = class(TComponent)
  private
    fP : TPersistent;
  published
    property P : TPersistent read fP write fP;
  end;

const
  DefaultOpenMode : integer = fmOpenRead or fmShareDenyWrite;

procedure RMWriteObjToStream(aStream: TStream; aObj : TPersistent);
var
  m : TWrapperComponent;
begin
  if aObj is TComponent then
  begin
    aStream.WriteComponent(TComponent(aObj))
  end
  else
    begin
      m := TWrapperComponent.Create(nil);
      try
        m.P := aObj;
        aStream.WriteComponent(m);
      finally
        m.Free;
      end;
    end;
end;

procedure RMReadObjFromStream(aStream: TStream; aObj : TPersistent);
var
  m : TWrapperComponent;
begin
  BeginGlobalLoading;
  try
    if aObj is TComponent then
      begin
        aStream.ReadComponent(TComponent(aObj));
        NotifyGlobalLoading;
      end
    else
      begin
        m := TWrapperComponent.Create(nil);
        try
          m.P := aObj;
          aStream.ReadComponent(m);
        finally
          m.Free;
        end;
      end;
  finally
    EndGlobalLoading;
  end;
end;

procedure RMReadObjFromFile(aObj:TPersistent;const aFileName:String);
Var
  F:TFileStream;
begin
  F:=TFileStream.Create(aFileName, DefaultOpenMode);
  try
    RMReadObjFromStream(F,aObj);
  finally
    F.Free;
  end;
end;

procedure RMWriteObjToFile(aObj:TPersistent;const aFilename:String);
Var
  F:TFileStream;
begin
  F:=TFileStream.Create(aFileName,fmcreate);
  try
    RMWriteObjToStream(F,aObj);
  finally
    F.Free;
  end;
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