rm_utils.pas

report machine 2.3 功能强大

{*****************************************}
{                                         }
{           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 Delphi6}, Variants{$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(ComplexName: string; var DataSet: TDataSet; var Field: 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: Boolean): integer;

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

function RMCurrToBIGNum(Value: Currency): string;
function RMChineseNumber(const jnum: string): string;
procedure RMSetFontSize(aComboBox: TComboBox; aFontSize: integer);
function RMGetFontSize(aComboBox: TComboBox): integer;
function RMCreateBitmap(const ResName: string): TBitmap;
function RMLoadStr(ID: Integer): string;
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);

implementation

uses Registry, RM_Const1, RM_Class, RM_DSet;

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;

procedure RMGetDataSetAndField(ComplexName: string; var DataSet: TDataSet; var Field: string);
var
  i, j, n: Integer;
  f: TComponent;
  sl: TStringList;
  s: string;
  c: Char;
  cn: TControl;

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

begin
  Field := '';
  f := CurReport.Owner;
  sl := TStringList.Create;

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