/Source/FR_UTILS.PAS

  1
  2{*****************************************}
  3{                                         }
  4{             FastReport v2.3             }
  5{            Various routines             }
  6{                                         }
  7{  Copyright (c) 1998-99 by Tzyganenko A. }
  8{                                         }
  9{*****************************************}
 10
 11unit FR_Utils;
 12
 13interface
 14
 15{$I FR.inc}
 16
 17uses
 18  SysUtils, Windows, Messages, Classes, Graphics, Controls,
 19  FR_DBRel, Forms, StdCtrls, ClipBrd, Menus, FR_Class;
 20
 21
 22procedure frReadMemo(Stream: TStream; l: TStrings);
 23procedure frReadMemo22(Stream: TStream; l: TStrings);
 24procedure frWriteMemo(Stream: TStream; l: TStrings);
 25function frReadString(Stream: TStream): String;
 26function frReadString22(Stream: TStream): String;
 27procedure SaveToFR3Stream(Report: TfrReport; Stream: TStream);
 28function StrToXML(const s: String): String;
 29function frStreamToString(Stream: TStream): String;
 30{$IFDEF FREEREP2217READ}
 31function frReadString2217(Stream: TStream): String;
 32{$ENDIF}
 33procedure frWriteString(Stream: TStream; s: String);
 34procedure frEnableControls(c: Array of TControl; e: Boolean);
 35function frControlAtPos(Win: TWinControl; p: TPoint): TControl;
 36function frGetDataSet(ComplexName: String): TfrTDataSet;
 37procedure frGetDataSetAndField(ComplexName: String;
 38  var DataSet: TfrTDataSet; var Field: TfrTField);
 39function frGetFontStyle(Style: TFontStyles): Integer;
 40function frSetFontStyle(Style: Integer): TFontStyles;
 41function frFindComponent(Owner: TComponent; Name: String): TComponent;
 42procedure frGetComponents(Owner: TComponent; ClassRef: TClass;
 43  List: TStrings; Skip: TComponent);
 44function frGetWindowsVersion: String;
 45
 46
 47
 48implementation
 49
 50uses FR_DSet, Printers;
 51
 52
 53function frSetFontStyle(Style: Integer): TFontStyles;
 54begin
 55  Result := [];
 56  if (Style and $1) <> 0 then Result := Result + [fsItalic];
 57  if (Style and $2) <> 0 then Result := Result + [fsBold];
 58  if (Style and $4) <> 0 then Result := Result + [fsUnderLine];
 59end;
 60
 61function frGetFontStyle(Style: TFontStyles): Integer;
 62begin
 63  Result := 0;
 64  if fsItalic in Style then Result := Result or $1;
 65  if fsBold in Style then Result := Result or $2;
 66  if fsUnderline in Style then Result := Result or $4;
 67end;
 68
 69procedure RemoveQuotes(var s: String);
 70begin
 71  if (s[1] = '"') and (s[Length(s)] = '"') then
 72    s := Copy(s, 2, Length(s) - 2);
 73end;
 74
 75procedure frReadMemo(Stream: TStream; l: TStrings);
 76var
 77  s: String;
 78  b: Byte;
 79  n: Word;
 80begin
 81  l.Clear;
 82  Stream.Read(n, 2);
 83  if n > 0 then
 84    repeat
 85      Stream.Read(n, 2);
 86      SetLength(s, n);
 87      Stream.Read(s[1], n);
 88      l.Add(s);
 89      Stream.Read(b, 1);
 90    until b = 0
 91  else
 92    Stream.Read(b, 1);
 93end;
 94
 95procedure frWriteMemo(Stream: TStream; l: TStrings);
 96var
 97  s: String;
 98  i: Integer;
 99  n: Word;
100  b: Byte;
101begin
102  n := l.Count;
103  Stream.Write(n, 2);
104  for i := 0 to l.Count - 1 do
105  begin
106    s := l[i];
107    n := Length(s);
108    Stream.Write(n, 2);
109    Stream.Write(s[1], n);
110    b := 13;
111    if i <> l.Count - 1 then Stream.Write(b, 1);
112  end;
113  b := 0;
114  Stream.Write(b, 1);
115end;
116
117function frReadString(Stream: TStream): String;
118var
119  s: String;
120  n: Word;
121  b: Byte;
122begin
123  Stream.Read(n, 2);
124  SetLength(s, n);
125  Stream.Read(s[1], n);
126  Stream.Read(b, 1);
127  Result := s;
128end;
129
130procedure frWriteString(Stream: TStream; s: String);
131var
132  b: Byte;
133  n: Word;
134begin
135  n := Length(s);
136  Stream.Write(n, 2);
137  Stream.Write(s[1], n);
138  b := 0;
139  Stream.Write(b, 1);
140end;
141
142procedure frReadMemo22(Stream: TStream; l: TStrings);
143var
144  s: String;
145  i: Integer;
146  b: Byte;
147begin
148  SetLength(s, 4096);
149  l.Clear;
150  i := 1;
151  repeat
152    Stream.Read(b,1);
153    if (b = 13) or (b = 0) then
154    begin
155      SetLength(s, i - 1);
156      if not ((b = 0) and (i = 1)) then l.Add(s);
157      SetLength(s, 4096);
158      i := 1;
159    end
160    else if b <> 0 then
161    begin
162      s[i] := Chr(b);
163      Inc(i);
164      if i > 4096 then
165        SetLength(s, Length(s) + 4096);
166    end;
167  until b = 0;
168end;
169
170function frReadString22(Stream: TStream): String;
171var
172  s: String;
173  i: Integer;
174  b: Byte;
175begin
176  SetLength(s, 4096);
177  i := 1;
178  repeat
179    Stream.Read(b, 1);
180    if b = 0 then
181      SetLength(s, i - 1)
182    else
183    begin
184      s[i] := Chr(b);
185      Inc(i);
186      if i > 4096 then
187        SetLength(s, Length(s) + 4096);
188    end;
189  until b = 0;
190  Result := s;
191end;
192
193{$IFDEF FREEREP2217READ}
194function frReadString2217(Stream: TStream): String;
195var
196  I: Integer;
197begin
198  Stream.ReadBuffer(I, SizeOf(I));
199  SetLength(Result, I);
200  Stream.ReadBuffer(PChar(Result)^, I);
201end;
202{$ENDIF}
203
204type
205  THackWinControl = class(TWinControl)
206  end;
207
208procedure frEnableControls(c: Array of TControl; e: Boolean);
209const
210  Clr1: Array[Boolean] of TColor = (clGrayText,clWindowText);
211  Clr2: Array[Boolean] of TColor = (clBtnFace,clWindow);
212var
213  i: Integer;
214begin
215  for i := Low(c) to High(c) do
216    if c[i] is TLabel then
217      with c[i] as TLabel do
218      begin
219        Font.Color := Clr1[e];
220        Enabled := e;
221      end
222    else if c[i] is TWinControl then
223      with THackWinControl(c[i]) do
224      begin
225        Color := Clr2[e];
226        Enabled := e;
227      end;
228end;
229
230function frControlAtPos(Win: TWinControl; p: TPoint): TControl;
231var
232  i: Integer;
233  c: TControl;
234  p1: TPoint;
235begin
236  Result := nil;
237  with Win do
238  begin
239    for i := ControlCount - 1 downto 0 do
240    begin
241      c := Controls[i];
242      if c.Visible and PtInRect(Rect(c.Left, c.Top, c.Left + c.Width, c.Top + c.Height), p) then
243        if (c is TWinControl) and (csAcceptsControls in c.ControlStyle) and
244           (TWinControl(c).ControlCount > 0) then
245        begin
246          p1 := p;
247          Dec(p1.X, c.Left); Dec(p1.Y, c.Top);
248          c := frControlAtPos(TWinControl(c), p1);
249          if c <> nil then
250          begin
251            Result := c;
252            Exit;
253          end;
254        end
255        else
256        begin
257          Result := c;
258          Exit;
259        end;
260    end;
261  end;
262end;
263
264function frGetDataSet(ComplexName: String): TfrTDataSet;
265begin
266  Result := TfrTDataSet(frFindComponent(CurReport.Owner, ComplexName));
267end;
268
269procedure frGetDataSetAndField(ComplexName: String; var DataSet: TfrTDataSet;
270  var Field: TfrTField);
271var
272  n: Integer;
273  f: TComponent;
274  s1, s2, s3: String;
275begin
276  Field := nil;
277  f := CurReport.Owner;
278  n := Pos('.', ComplexName);
279  if n <> 0 then
280  begin
281    s1 := Copy(ComplexName, 1, n - 1);        // table name
282    s2 := Copy(ComplexName, n + 1, 255);      // field name
283    if Pos('.', s2) <> 0 then                 // module name present
284    begin
285      s3 := Copy(s2, Pos('.', s2) + 1, 255);
286      s2 := Copy(s2, 1, Pos('.', s2) - 1);
287      f := FindGlobalComponent(s1);
288      if f <> nil then
289      begin
290        DataSet := TfrTDataSet(f.FindComponent(s2));
291        RemoveQuotes(s3);
292        if DataSet <> nil then
293          Field := TfrTField(DataSet.FindField(s3));
294      end;
295    end
296    else
297    begin
298      DataSet := TfrTDataSet(frFindComponent(f, s1));
299      RemoveQuotes(s2);
300      if DataSet <> nil then
301        Field := TfrTField(DataSet.FindField(s2));
302    end;
303  end
304  else if DataSet <> nil then
305  begin
306    RemoveQuotes(ComplexName);
307    Field := TfrTField(DataSet.FindField(ComplexName));
308  end;
309end;
310
311function frFindComponent(Owner: TComponent; Name: String): TComponent;
312var
313  n: Integer;
314  s1, s2: String;
315begin
316  Result := nil;
317  n := Pos('.', Name);
318  try
319    if n = 0 then
320      Result := Owner.FindComponent(Name)
321    else
322    begin
323      s1 := Copy(Name, 1, n - 1);        // module name
324      s2 := Copy(Name, n + 1, 255);      // component name
325      Owner := FindGlobalComponent(s1);
326      if Owner <> nil then
327        Result := Owner.FindComponent(s2);
328    end;
329  except
330    on Exception do
331      raise EClassNotFound.Create('����������� ' + Name);
332  end;
333end;
334
335procedure frGetComponents(Owner: TComponent; ClassRef: TClass;
336  List: TStrings; Skip: TComponent);
337var
338  i: Integer;
339  procedure EnumComponents(f: TComponent);
340  var
341    i: Integer;
342    c: TComponent;
343  begin
344    for i := 0 to f.ComponentCount - 1 do
345    begin
346      c := f.Components[i];
347      if (c <> Skip) and (c is ClassRef) then
348        if f = Owner then
349          List.Add(c.Name) else
350          List.Add(f.Name + '.' + c.Name);
351    end;
352  end;
353begin
354  List.Clear;
355  for i := 0 to Screen.FormCount - 1 do
356    EnumComponents(Screen.Forms[i]);
357  for i := 0 to Screen.DataModuleCount - 1 do
358    EnumComponents(Screen.DataModules[i]);
359end;
360
361function frGetWindowsVersion: String;
362var Ver: TOsVersionInfo;
363begin
364  Ver.dwOSVersionInfoSize := SizeOf(Ver);
365  GetVersionEx(Ver);
366  with Ver do begin
367    case dwPlatformId of
368      VER_PLATFORM_WIN32s: Result := '32s';
369      VER_PLATFORM_WIN32_WINDOWS:
370        begin
371          dwBuildNumber := dwBuildNumber and $0000FFFF;
372          if (dwMajorVersion > 4) or ((dwMajorVersion = 4) and
373            (dwMinorVersion >= 10)) then
374            Result := '98' else
375            Result := '95';
376        end;
377      VER_PLATFORM_WIN32_NT: Result := 'NT';
378    end;
379  end;
380end;
381
382procedure SaveToFR3Stream(Report: TfrReport; Stream: TStream);
383const
384  fr01cm = 3.77953; // 96 / 25.4
385  frKx = 96 / (93 / 1.015); // convert from 2.4 units to 3.0 units
386
387  procedure WriteStr(const s: String);
388  begin
389    Stream.Write(s[1], Length(s));
390  end;
391
392  procedure WriteLn(const s: String);
393  begin
394    WriteStr(s + #13#10);
395  end;
396
397  function EncodePwd(const s: String): String;
398  var
399    i: Integer;
400  begin
401    Result := '';
402    for i := 1 to Length(s) do
403      Result := Result + Chr(Ord(s[i]) - 10);
404  end;
405  procedure WriteReportProp;
406
407    procedure WriteScript;
408    var
409      i, j: Integer;
410      Page: TfrPage;
411      v: TfrView;
412      Script: TStringList;
413
414      procedure AddScript(const vName: String; vScript: TStrings);
415      var
416        i: Integer;
417      begin
418        if vScript.Count <> 0 then
419        begin
420          Script.Add('procedure ' + vName + 'OnBeforePrint(Sender: TfrxComponent);');
421          Script.Add('begin');
422          Script.Add('  with ' + vName + ', Engine do');
423          Script.Add('  begin');
424          if vScript[0] <> 'begin' then
425            Script.Add(vScript[0]);
426
427          for i := 1 to vScript.Count - 2 do
428            Script.Add(vScript[i]);
429
430          if vScript[0] <> 'begin' then
431          begin
432            if vScript.Count <> 1 then
433              Script.Add(vScript[vScript.Count - 1]);
434            Script.Add('  end');
435            Script.Add('end;');
436          end
437          else
438          begin
439            Script.Add('  end');
440            Script.Add(vScript[vScript.Count - 1] + ';');
441          end;
442          Script.Add('');
443        end;
444      end;
445
446    begin
447      Script := TStringList.Create;
448      for i := 0 to Report.Pages.Count - 1 do
449      begin
450        Page := Report.Pages[i];
451//        AddScript('Page' + IntToStr(i + 1), Page.Script);
452        for j := 0 to Page.Objects.Count - 1 do
453        begin
454          v := Page.Objects[j];
455          AddScript(v.Name, v.Script);
456        end;
457      end;
458
459      Script.Add('begin');
460      Script.Add('');
461      Script.Add('end.');
462      WriteStr(StrToXML(Script.Text) + '" ');
463      Script.Free;
464    end;
465
466    procedure WriteVariables;
467    var
468      i: Integer;
469      wr: TWriter;
470      ms: TMemoryStream;
471      v: TValueType;
472      varName, varValue: String;
473      dsList: TStringList;
474    begin
475      ms := TMemoryStream.Create;
476      wr := TWriter.Create(ms, 4096);
477
478      dsList := TStringList.Create;
479      frGetComponents(Report.Owner, TfrDataset, dsList, nil);
480
481      v := vaCollection;
482      wr.WriteStr('Datasets');
483      wr.Write(v, SizeOf(v));
484      for i := 0 to dsList.Count - 1 do
485      begin
486//        varName := TfrDataset(dsList.Objects[i]).Name;
487        varName := dsList.Strings[i];
488        wr.WriteListBegin;
489        wr.WriteStr('DataSet');
490        v := vaNil;
491        wr.Write(v, SizeOf(v));
492        wr.WriteStr('DataSetName');
493        wr.WriteString(varName);
494        wr.WriteListEnd;
495      end;
496      wr.WriteListEnd;
497
498      wr.WriteStr('Variables');
499      wr.Write(v, SizeOf(v));
500      for i := 0 to Report.Variables.Count - 1 do
501      begin
502        varName := Report.Variables.Names[i];
503        varValue := Report.Variables.Values[varName];
504
505{        ds := nil;
506        fld := '';
507        frGetDatasetAndField(varValue, ds, fld);
508        if (ds <> nil) and (fld <> '') then
509        begin
510          dsFound := nil;
511          for j := 0 to dsList.Count - 1 do
512            if TObject(dsList.Objects[j]) is TfrDBDataSet then
513              if TfrDBDataset(dsList.Objects[j]).GetDataSet = ds then
514              begin
515                dsFound := TfrDataset(dsList.Objects[j]);
516                break;
517              end;
518          if dsFound <> nil then
519          begin
520            s := dsFound.Name;
521            if Pos('_', s) = 1 then
522              s := Copy(s, 2, 255);
523            varValue := '<' + s + '."' + fld + '">';
524          end;
525        end;
526 }
527        wr.WriteListBegin;
528        wr.WriteStr('Name');
529        wr.WriteString(varName);
530        wr.WriteStr('Value');
531        wr.WriteString(varValue);
532        wr.WriteListEnd;
533      end;
534
535      wr.WriteListEnd;
536      wr.Free;
537      WriteStr('Propdata="' + frStreamToString(ms) + '"');
538      ms.Free;
539      dsList.Free;
540    end;
541
542  begin
543    WriteStr('<TfrxReport ScriptLanguage="PascalScript" ScriptText.text="');
544    WriteScript;
545    WriteVariables;
546
547//    WriteStr(' ReportOptions.Name="' + {StrToXML(Report.ReportName)}' ' +
548//      '" ReportOptions.Author="' + {StrToXML(Report.ReportAutor)}' ' +
549//    '" ReportOptions.Description.text="' + {StrToXML(Report.ReportComment)}' ' +
550//    '" ReportOptions.CreateDate="' + {FloatToStr(Report.ReportCreateDate)}' ' +
551//    '" ReportOptions.LastChange="' + {FloatToStr(Report.ReportLastChange)}' ' +
552//    '" ReportOptions.VersionMajor="' + {StrToXML(Report.ReportVersionMajor)}' ' +
553//    '" ReportOptions.VersionMinor="' + {StrToXML(Report.ReportVersionMinor)}' ' +
554//    '" ReportOptions.VersionRelease="' + {StrToXML(Report.ReportVersionRelease)}' ' +
555//    '" ReportOptions.VersionBuild="' + {StrToXML(Report.ReportVersionBuild)}' ' +
556//    '" ReportOptions.Password="' + {StrToXML(EncodePwd(Report.ReportPassword))}''+ '"');
557    WriteLn('>');
558  end;
559
560  procedure WritePages;
561  var
562    i, j, ofx, savex: Integer;
563    Page: TfrPage;
564    v: TfrView;
565
566    procedure WritePageProp(Page: TfrPage; const PageName: String);
567    var
568      s: String;
569    begin
570      ofx := 0;
571        if Page.pgOr = poPortrait then
572          s := 'poPortrait' else
573          s := 'poLandscape';
574        WriteStr('<TfrxReportPage Name="' + PageName + '" ');
575        WriteStr('Orientation="' + s +
576          '" PaperWidth="' + IntToStr(Round(Page.prnInfo.PgW / fr01cm * frKx)) +
577          '" PaperHeight="' + IntToStr(Round(Page.prnInfo.PgH / fr01cm * frKx)) +
578          '" PaperSize="' + IntToStr(Page.pgSize) + '" ');
579        WriteStr('LeftMargin="' + IntToStr(Round(Page.LeftMargin / fr01cm * frKx)) +
580          '" RightMargin="' + IntToStr(Round((Page.prnInfo.PgW - Page.RightMargin) / fr01cm * frKx)) +
581          '" TopMargin="' + IntToStr(Round(Page.TopMargin / fr01cm * frKx)) +
582          '" BottomMargin="' + IntToStr(Round((Page.prnInfo.PgH - Page.BottomMargin) / fr01cm * frKx)) +
583          '" Columns="' + IntToStr(Page.ColCount) +
584          '" ColumnWidth="' + IntToStr(Page.ColWidth) + '"');
585        if Page.PrintToPrevPage then
586          WriteStr(' PrintOnPreviousPage="True"');
587//        if Page.Script.Count > 0 then
588//          WriteStr(' OnBeforePrint="' + PageName + 'OnBeforePrint"');
589
590        ofx := -Page.LeftMargin;
591      if Page.Objects.Count = 0 then
592        WriteLn('/>') else
593        WriteLn('>');
594    end;
595
596  begin
597    for i := 0 to Report.Pages.Count - 1 do
598    begin
599      Page := Report.Pages[i];
600      WritePageProp(Page, 'Page' + IntToStr(i + 1));
601
602      for j := 0 to Page.Objects.Count - 1 do
603      begin
604        v := Page.Objects[j];
605        savex := v.x;
606        v.x := v.x + ofx;
607        v.SaveToFR3Stream(Stream);
608        v.x := savex;
609        WriteLn('/>');
610      end;
611
612      if Page.Objects.Count <> 0 then
613        WriteLn('</TfrxReportPage>')
614    end;
615  end;
616
617begin
618  WriteLn('<?xml version="1.0" encoding="utf-8"?>');
619  WriteReportProp;
620  WritePages;
621  WriteLn('</TfrxReport>');
622end;
623
624function StrToXML(const s: String): String;
625const
626  SpecChars = ['<', '>', '"', #10, #13];
627var
628  i: Integer;
629
630  procedure ReplaceChars(var s: String; i: Integer);
631  begin
632    Insert('#' + IntToStr(Ord(s[i])) + ';', s, i + 1);
633    s[i] := '&';
634  end;
635
636begin
637  Result := s;
638  for i := Length(s) downto 1 do
639    if s[i] in SpecChars then
640      ReplaceChars(Result, i);
641end;
642
643function frStreamToString(Stream: TStream): String;
644var
645  b: Byte;
646begin
647  Result := '';
648  Stream.Position := 0;
649  while Stream.Position < Stream.Size do
650  begin
651    Stream.Read(b, 1);
652    Result := Result + IntToHex(b, 2);
653  end;
654end;
655
656end.