fr_class.pas

航空人身保险信息管理系统使用SQL和DELHPI开发

end;

procedure TfrObject.ClearPropList;
var
  p:  PfrPropRec;
begin
  while PropList.Count > 0 do
  begin
    p := PropList[0];
    if p^.Enum <> nil then
      p^.Enum.Free;
    Dispose(p);
    PropList.Delete(0);
  end;
end;
 
procedure TfrObject.AddProperty(PropName: string; PropType: TfrDataTypes;
  PropEditor: TNotifyEvent);
var
  p: PfrPropRec;
begin
  New(p);
  p^.PropName := PropName;
  p^.PropType := PropType;
  p^.PropEditor := PropEditor;
  p^.Enum := nil;
  PropList.Add(p);
end;

procedure TfrObject.AddEnumProperty(PropName: string; Enum: String;
  const EnumValues: Array of Variant);
var 
  p:  PfrPropRec;
  vv: Variant;
begin
  New(p);
  p^.PropName := PropName;
  p^.PropType := [frdtEnum];
  p^.PropEditor := nil;
  p^.Enum := TStringList.Create;
  frSetCommaText(Enum, p^.Enum);

  if TVarData(EnumValues[0]).VType = varArray + varVariant then
    vv := EnumValues[0] else
    vv := VarArrayOf(EnumValues);
 
  if vv[0] = Null then
    p^.EnumValues := Null else
    p^.EnumValues := vv;
  PropList.Add(p);
end;

procedure TfrObject.DelProperty(PropName: String);
var 
  p: PfrPropRec;
begin
  p := PropRec[PropName];
  if p <> nil then
  begin
    PropList.Delete(PropList.IndexOf(p));
    Dispose(p);
  end;
end;
 
procedure TfrObject.DefineProperties;
begin
// abstract method
end;
 
procedure TfrObject.SetPropValue(Index: string; Value: Variant);
begin
// abstract method
end;

function TfrObject.DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant;
begin
  Result := Null;
end;
 
function TfrObject.GetPropValue(Index: string): Variant;
begin
  Result := Null;
end;
 
function TfrObject.GetPropRec(Index: String): PfrPropRec;
var 
  i: Integer;
  p: PfrPropRec;
begin
  Result := nil;
  for i := 0 to PropList.Count - 1 do
  begin
    p := PropList[i];
    if AnsiCompareText(p^.PropName, Index) = 0 then
    begin
      Result := p;
      break;
    end;
  end;
end;
 
procedure TfrObject.SetFontProp(Font: TFont; Prop: string; Value: Variant);
begin
  if Prop = 'FONT.NAME' then
    Font.Name := Value
  else if Prop = 'FONT.SIZE' then
    Font.Size := Value
  else if Prop = 'FONT.STYLE' then
    Font.Style := frSetFontStyle(Value)
  else if Prop = 'FONT.COLOR' then
    Font.Color := Value
end;

function TfrObject.GetFontProp(Font: TFont; Prop: String): Variant;
begin
  Result := Null;
  if Prop = 'FONT.NAME' then
    Result := Font.Name
  else if Prop = 'FONT.SIZE' then
    Result := Font.Size
  else if Prop = 'FONT.STYLE' then
    Result := frGetFontStyle(Font.Style)
  else if Prop = 'FONT.COLOR' then
    Result := Font.Color
end;

function TfrObject.LinesMethod(Lines: TStrings; MethodName, LinesName: String;
  Par1, Par2, Par3: Variant): Variant;
begin
  if MethodName = 'SETINDEXPROPERTY' then
  begin
// Par1 is index property name (e.g. 'Lines')
// Par2 is index (e.g. 1)
// Par3 is value which you must assign to the index property
    if Par1 = LinesName then
      Lines[Par2] := Par3;
  end
  else if MethodName = 'GETINDEXPROPERTY' then
  begin
// Par1 is index property name
// Par2 is index
// Par3 is Null - don't use it
    if Par1 = LinesName then
      Result := Lines[Par2];
  end
  else if MethodName = LinesName + '.ADD' then
    Lines.Add(frParser.Calc(Par1))
  else if MethodName = LinesName + '.CLEAR' then
    Lines.Clear
  else if MethodName = LinesName + '.DELETE' then
    Lines.Delete(frParser.Calc(Par1))
  else if MethodName = LinesName + '.INDEXOF' then
    Result := Lines.IndexOf(frParser.Calc(Par1))
end;


{ TfrView }
 
constructor TfrView.Create;
begin
  inherited Create;
  Parent := nil;
  Memo := TStringList.Create;
  Memo1 := TStringList.Create;
  Script := TStringList.Create;
  FrameWidth := 1;
  FrameColor := clBlack;
  FillColor := clNone;
  Format := 2 * 256 + Ord(DecimalSeparator);
  BaseName := 'View';
  Visible := True;
  StreamMode := smFRF;
  ScaleX := 1; ScaleY := 1;
  OffsX := 0; OffsY := 0;
  Flags := flStretched;
  gapx := 2; gapy := 1;
  Typ := gtAddIn;
end;

destructor TfrView.Destroy;
begin
  Memo.Free;
  Memo1.Free;
  Script.Free;
  inherited Destroy;
end;
 
procedure TfrView.Assign(From: TfrView);
var 
  Stream: TMemoryStream;
begin
  Name := From.Name;
  Typ := From.Typ;
  Selected := From.Selected;
  Stream := TMemoryStream.Create;
  frVersion := frCurrentVersion;
  From.StreamMode := smFRF;
  From.SaveToStream(Stream);
  Stream.Position := 0;
  StreamMode := smFRF;
  LoadFromStream(Stream);
  Stream.Free;
end;

procedure TfrView.DefineProperties;
begin
  ClearPropList;
  AddProperty('Name', [frdtString, frdtOneObject], nil);
  AddProperty('Left', [frdtSize], nil);
  AddProperty('Top', [frdtSize], nil);
  AddProperty('Width', [frdtSize], nil);
  AddProperty('Height', [frdtSize], nil);
  AddProperty('Flags', [], nil);
  if (ClassName <> 'TfrBandView') and (ClassName <> 'TfrSubReportView') then
  begin
    AddProperty('FrameTyp', [frdtInteger], nil);
    AddProperty('FrameWidth', [frdtSize, frdtFloat], nil);
    AddProperty('FrameColor', [frdtColor], nil);
    AddEnumProperty('FrameStyle',
      'psSolid;psDash;psDot;psDashDot;psDashDotDot;psDouble',
      [psSolid,psDash,psDot,psDashDot,psDashDotDot,psDouble]);
    AddProperty('FillColor', [frdtColor], nil);
    AddProperty('Tag', [frdtHasEditor, frdtOneObject], frTagEditor);
    AddEnumProperty('BandAlign',
      'baNone;baLeft;baRight;baCenter;baWidth;baBottom;baTop;baRest',
      [baNone,baLeft,baRight,baCenter,baWidth,baBottom,baTop,baRest]);
  end;
  AddProperty('Visible', [frdtBoolean], nil);
  AddProperty('Memo', [frdtOneObject, frdtHasEditor], frMemoEditor);
  AddProperty('Memo.Count', [], nil);
  AddProperty('Restrictions', [frdtHasEditor], frRestrEditor);
end;

procedure TfrView.SetPropValue(Index: string; Value: Variant);
begin
  Index := AnsiUpperCase(Index);
  if Index = 'NAME' then
    Name := Value
  else if Index = 'LEFT' then
    x := Value
  else if Index = 'TOP' then
    y := Value
  else if Index = 'WIDTH' then
    dx := Value
  else if Index = 'HEIGHT' then
    dy := Value
  else if Index = 'FLAGS' then
    Flags := Value
  else if Index = 'FRAMETYP' then
    FrameTyp := Value
  else if Index = 'FRAMEWIDTH' then
    FrameWidth := Value
  else if Index = 'FRAMECOLOR' then
    FrameColor := Value
  else if Index = 'FRAMESTYLE' then
    FrameStyle := Value
  else if Index = 'FILLCOLOR' then
    FillColor := Value
  else if Index = 'VISIBLE' then
    Visible := Value
  else if Index = 'MEMO' then
    Memo.Text := Value
  else if Index = 'GAPX' then
    gapx := Value
  else if Index = 'GAPY' then
    gapy := Value
  else if Index = 'STRETCHED' then
    Flags := (Flags and not flStretched) or Word(Boolean(Value)) * flStretched
  else if Index = 'BANDALIGN' then
    BandAlign := Value
  else if Index = 'DATAFIELD' then
    Memo.Text := Value
  else if Index = 'TAG' then
    Tag := Value
end;

function TfrView.GetPropValue(Index: String): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := Null;
  if Index = 'NAME' then
    Result := Name
  else if Index = 'LEFT' then
    Result := x
  else if Index = 'TOP' then
    Result := y
  else if Index = 'WIDTH' then
    Result := dx
  else if Index = 'HEIGHT' then
    Result := dy
  else if Index = 'FLAGS' then
    Result := Flags
  else if Index = 'FRAMETYP' then
    Result := FrameTyp
  else if Index = 'FRAMEWIDTH' then
    Result := FrameWidth
  else if Index = 'FRAMECOLOR' then
    Result := FrameColor
  else if Index = 'FRAMESTYLE' then
    Result := FrameStyle
  else if Index = 'FILLCOLOR' then
    Result := FillColor
  else if Index = 'VISIBLE' then
    Result := Visible
  else if Index = 'MEMO' then
    Result := Memo.Text
  else if Index = 'GAPX' then
    Result := gapx
  else if Index = 'GAPY' then
    Result := gapy
  else if Index = 'STRETCHED' then
    Result := (Flags and flStretched) <> 0
  else if Index = 'DATAFIELD' then
    if Memo.Count > 0 then
      Result := Memo[0] else
      Result := ''
  else if Index = 'BANDALIGN' then
    Result := BandAlign
  else if Index = 'MEMO.COUNT' then
    Result := Memo.Count
  else if Index = 'DATAFIELD' then
    Result := Memo.Text
  else if Index = 'TAG' then
    Result := Tag
end;

function TfrView.DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant;
begin
  Result := inherited DoMethod(MethodName, Par1, Par2, Par3);
  if Result = Null then
    Result := LinesMethod(Memo, MethodName, 'MEMO', Par1, Par2, Par3);
  if MethodName = 'HIDE' then
    Prop['Visible'] := False
  else if MethodName = 'SHOW' then
    Prop['Visible'] := True;
end;

procedure TfrView.CalcGaps;
var
  bx, by, bx1, by1, wx1, wx2, wy1, wy2: Integer;
begin
  SaveX := x; SaveY := y; SaveDX := dx; SaveDY := dy;
  SaveFW := FrameWidth;
  SaveGX := gapx; SaveGY := gapy;
  if DocMode = dmDesigning then
  begin
    ScaleX := 1; ScaleY := 1;
    OffsX := 0; OffsY := 0;
  end;
  x := Round(x * ScaleX) + OffsX;
  y := Round(y * ScaleY) + OffsY;
  dx := Round(dx * ScaleX);
  dy := Round(dy * ScaleY);
 
  wx1 := Round((FrameWidth * ScaleX - 1) / 2);
  wx2 := Round(FrameWidth * ScaleX / 2);
  wy1 := Round((FrameWidth * ScaleY - 1) / 2);
  wy2 := Round(FrameWidth * ScaleY / 2);
  FrameWidth := FrameWidth * ScaleX;
  gapx := wx2 + Round(gapx * ScaleX); gapy := wy2 div 2 + Round(gapy * ScaleY);
  bx := x;
  by := y;
  bx1 := Round((SaveX + SaveDX) * ScaleX + OffsX);
  by1 := Round((SaveY + SaveDY) * ScaleY + OffsY);
  if (FrameTyp and $1) <> 0 then Dec(bx1, wx2);
  if (FrameTyp and $2) <> 0 then Dec(by1, wy2);
  if (FrameTyp and $4) <> 0 then Inc(bx, wx1);
  if (FrameTyp and $8) <> 0 then Inc(by, wy1);
  DRect := Rect(bx, by, bx1 + 1, by1 + 1);
end;

procedure TfrView.RestoreCoord;
begin
  x := SaveX;
  y := SaveY;
  dx := SaveDX;
  dy := SaveDY;
  FrameWidth := SaveFW;
  gapx := SaveGX;
  gapy := SaveGY;
end;
 
procedure TfrView.ShowBackground;
var
  fp: TColor;
begin
  if DisableDrawing then Exit;
  fp := FillColor;
  if fp = clNone then
    fp := clWhite;
  SetBkMode(Canvas.Handle, Opaque);
  Canvas.Brush.Color := fp;
  if (DocMode = dmPrinting) and (FillColor = clNone) then Exit;
  if DocMode = dmDesigning then
    Canvas.FillRect(DRect) else
    Canvas.FillRect(Rect(x, y,
// use calculating coords instead of dx, dy - for best view
      Round((SaveX + SaveDX) * ScaleX + OffsX), Round((SaveY + SaveDY) * ScaleY + OffsY)));
end;

procedure TfrView.ShowFrame;
var 
  x1, y1: Integer;
 
  procedure Line(x, y, dx, dy: Integer);
  begin