fqbclass.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

  
  function FindDublicat(AAlias: string): boolean;
    var i: integer;
  begin
    Result:= False;
    for i:= 0 to ComponentCount - 1 do
    begin
      if AAlias = TfqbTable(Components[i]).AliasName then
      begin
        Result:= True;
        Break
      end
    end
  end;
  
begin
  Result:= ATableName[1];
  n:=1;
  while FindDublicat(Result) do
  begin
    Result:= ATableName[1] + IntToStr(n);
    Inc(n)
  end
end;

function TfqbTableArea.GetLineAtCursor: Integer;
  
    procedure SwapInt(var X, Y: Integer);
      var
        T: Integer;
    begin
      T := X;
      X := Y;
      Y := T
    end;
  
    function InRange(const AValue, AMin, AMax: Integer): Boolean;
    begin
      Result := (AValue >= AMin) and (AValue <= AMax)
    end;
  
    const
      sf = 6; //Scale factor
  var
    i,TX1, TX2, TY1,TY2,X1,Y1,
    X2,Y2,Lx, Ly, C: integer;
    MousePos: TPoint;
    Delta: Real;
  
begin
  Result:= - 1;
  for i:= 0 to LinkList.Count - 1 do
  begin
    MousePos:= Mouse.CursorPos;
    MousePos:= ScreenToClient(MousePos);
    X1:= TfqbLink(LinkList[i]).GetSourceCoords.X;
    X2:= TfqbLink(LinkList[i]).GetDestCoords.X;
    Y1:= TfqbLink(LinkList[i]).GetSourceCoords.Y;
    Y2:= TfqbLink(LinkList[i]).GetDestCoords.Y;
    TX1:= X1;
    TX2:= X2;
    TY1:= Y1;
    TY2:= Y2;
    if TX1> TX2 then SwapInt(TX1, TX2);
    if TY1> TY2 then SwapInt(TY1, TY2);
    Lx:= X2-X1;
    Ly:= Y2-Y1;
    C:= -Ly*X1 + Lx*Y1;
    Delta:= Sqrt(Power((X1-X2), 2) + Power((Y1-Y2), 2)) * sf;
    if (Abs(-Ly*MousePos.X + Lx*MousePos.Y - C)<= Delta) and
       InRange(MousePos.X, TX1 - sf, TX2 + sf) and
       InRange(MousePos.Y, TY1 - sf, TY2 + sf) then
    begin
      Result:= i;
      break
    end
  end
end;

procedure TfqbTableArea.InsertTable(const X, Y : integer; const Name: string);
var
  tmp: TfqbTable;
begin
  tmp := TfqbTable.Create(Self);
  tmp.Left := X;
  tmp.Top := Y;
  tmp.Parent := Self;
  tmp.TableName := Name;
  fqbActiveEngine.ReadFieldList(Name, tmp.FFieldList);
  tmp.UpdateFieldList
end;

procedure TfqbTableArea.InsertTable(const Name : string);
begin
  InsertTable(FInstX, FInstY, Name);
  
  if FInstY > Height then
    FInstY:= 15
  else
    FInstY:= FInstY + 15;
  
  if FInstX > Width then
    FInstX := 15
  else
    FInstX:= FInstX + 15
end;

procedure TfqbTableArea.WMPaint(var Message: TWMPaint);
var
  i: Integer;
  
  {$IFDEF TRIAL}
  str: string;
  l, dx: integer;
  {$ENDIF}
  
begin
  inherited;
  {$IFDEF TRIAL}
  FCanvas.Font.Size := 50;
  FCanvas.Font.Color:= clRed;
  FCanvas.Font.Name := 'Tahoma';
  str := 'deretsigern';
  l := FCanvas.TextWidth(str + 'U');
  dx := (Width div 2) - (l div 2);
  FCanvas.TextOut(dx, 100, 'U');
  for i := 11 downto 1 do
    FCanvas.TextOut(FCanvas.PenPos.x, FCanvas.PenPos.y, str[i]);
  {$ENDIF}
  for i := 0 to LinkList.Count - 1 do
    LinkList[i].Draw
end;

{-----------------------  TfqbTable -----------------------}
constructor TfqbTable.Create(AOwner: TComponent);
begin
  inherited;
  
  Width := 130;
  Height := 150;
  BevelOuter := bvNone;
  BorderWidth := 1;
  
  FLabel := TLabel.Create(Self);
  with FLabel do
  begin
    Parent := Self;
    Align := alTop;
    Color := clActiveCaption;
    Font.Charset := DEFAULT_CHARSET;
    Font.Color := clCaptionText;
    AutoSize := False;
    Height := Height + 6;
    Font.Size := Font.Size + 1;
    Layout := tlCenter;
  end;
  
  FImage := TImage.Create(Self);
  with FImage do
  begin
    Parent := Self;
    Top := 3;
    Left := 3;
    Width := 16;
    Height := 16;
    AutoSize := True;
    FImage.Picture.Bitmap.LoadFromResourceName(HInstance,'TABLEIMAGE1');
    Transparent := True;
  end;
  
  FButtonClose := TSpeedButton.Create(Self);
  with FButtonClose do
  begin
    Parent := Self;
    Top := 3;
    Width := 17;
    Height := 15;
    OnClick := _DoExit;
    Glyph.LoadFromResourceName(HInstance,'BTN_CLOSE');
  end;
  
  FButtonMinimize := TSpeedButton.Create(Self);
  with FButtonMinimize do
  begin
    Parent := Self;
    Top := 3;
    Width := 17;
    Height := 15;
    OnClick := _DoMinimize;
    Glyph.LoadFromResourceName(HInstance,'BTN_MINI');
  end;
  
  FCheckListBox := TfqbCheckListBox.Create(Self);
  with FCheckListBox do
  begin
    Parent := Self;
    Align := alClient;
    ItemHeight := 13;
    Style := lbOwnerDrawVariable;
    DragMode := dmAutomatic
  end;
  
  Constraints.MinHeight := FLabel.Height + 8;
  Constraints.MinWidth := 120;
  
  Caption := '';
  FFieldList := TfqbFieldList.Create(Self, TfqbField);
  DragMode := dmAutomatic;
  DoubleBuffered := true;
  ShowHint := False;
  Height := 200;
  Width := 150
end;

destructor TfqbTable.Destroy;
var
  i: Integer;
  tmp: TfqbGrid;
begin
  if GetParentForm(Self) <> nil then
  begin
    tmp:= TfqbGrid(FindFQBcomp('TfqbGrid', GetParentForm(Self)));
    if Assigned(tmp) then
    begin
      for i:= tmp.Items.Count - 1 downto 0 do
      begin
        if TGridColumn(tmp.Items[i].Data^).Table = TableName then
        begin
          FreeMem(tmp.Items[i].Data,SizeOf(TGridColumn));
          tmp.Items[i].Delete;
        end
      end;
      tmp.UpdateColumn
    end
  end;
  UpdateLinkList;
  
  FLabel.Free;
  FCheckListBox.Free;
  FFieldList.Free;
  FImage.Free;
  FButtonClose.Free;
  FButtonMinimize.Free;
  
  if Parent <> nil then
  begin
    Parent.Invalidate;
    Parent:= nil
  end;
  inherited
end;

procedure TfqbTable.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style:= Style or WS_SIZEBOX;
    WindowClass.hIcon:= LoadIcon(hInstance, 'TABLEICO');
    WindowClass.Style:= WindowClass.Style xor CS_VREDRAW
  end
end;

function TfqbTable.GetLinkPoint(AIndex: integer; ASide: char): TPoint;
var
  tmpRec: TRect;
begin
  tmpRec := ChBox.ItemRect(AIndex);
  tmpRec.Top := tmpRec.Top + FLabel.Height + (ChBox.Height - ChBox.ClientHeight);
  tmpRec.Bottom := tmpRec.Bottom + FLabel.Height + (ChBox.Height - ChBox.ClientHeight);
  
  if tmpRec.Bottom > ClientHeight then
    Result.y := ClientHeight
  else
  if tmpRec.Top < 0 then
    Result.y := 0
  else
    Result.y := tmpRec.Top + (tmpRec.Bottom - tmpRec.Top) div 2;
  
  Result := Parent.ScreenToClient(ClientToScreen(Result));
  
  // if ASide = 'L' then Left side else if ASide = 'R' then Right side
  if ASide = 'L' then
    Result.x := BoundsRect.Left
  else
    Result.x := BoundsRect.Right
end;

function TfqbTable.GetSellectedField: TfqbField;
begin
  Result := FFieldList[ChBox.ItemIndex]
end;

procedure TfqbTable.Resize;
begin
  inherited Resize;
  FButtonClose.Left := Width - 25;
  FButtonMinimize.Left := Width - 42
end;

procedure TfqbTable.SetTableName(const Value: string);
  
  function GetSpace(const Width: integer):string;
  begin
    Result := '';
    repeat
      Result := Result + ' '
    until FLabel.Canvas.TextWidth(Result) > Width
  end;
  
begin
  FTableName := Value;
  FAliasName:= TfqbTableArea(Parent).GenerateAlias(Value);
  FLabel.Caption := GetSpace(FImage.Width + 2) + Value + ' - ' + FAliasName
end;

procedure TfqbTable.UpdateFieldList;
var
  i: Integer;
begin
  ChBox.Items.BeginUpdate;
  ChBox.Items.Clear;
  if FFieldList.Count > 0 then
    ChBox.Items.Add(TfqbField(FFieldList[0]).FieldName);
  for i:= 1 to FFieldList.Count - 1 do
    ChBox.Items.Add(TfqbField(FFieldList[i]).FieldName + ' (' +
        StrFieldType[TfqbField(FFieldList[i]).FieldType] + ')');
  ChBox.Items.EndUpdate
end;

procedure TfqbTable.UpdateLinkList;
var
  i: Integer;
begin
  if Parent = nil then Exit;
  for i:= (Parent as TfqbTableArea).LinkList.Count - 1 downto 0 do
  if (((Parent as TfqbTableArea).LinkList[i].SourceTable = self) or ((Parent as TfqbTableArea).LinkList[i].DestTable = self)) then
        (Parent as TfqbTableArea).LinkList[i].Free
end;

procedure TfqbTable.WMMove(var Message: TWMMove);
begin
  inherited;
  Parent.Invalidate
end;

procedure TfqbTable.WMNCHitTest(var M: TWMNCHitTest);
var
  x: Integer;
begin
  inherited;
  x := ClientToScreen(Point(FButtonMinimize.Left,0)).X;
  if ((M.Result = htClient) and (M.XPos - x < 0)) then
     M.Result := htCaption
end;

procedure TfqbTable.WMPaint(var Message: TWMPaint);
begin
  inherited;
  Parent.Invalidate
end;

procedure TfqbTable._DoExit(Sender: TObject);
begin
  Free
end;

procedure TfqbTable._DoMinimize(Sender: TObject);
begin
  FOldHeight := Height;
  Height := 0;
  FButtonMinimize.OnClick := _DoRestore
end;

procedure TfqbTable._DoRestore(Sender: TObject);
begin
  Height := FOldHeight;
  FButtonMinimize.OnClick := _DoMinimize
end;

{-----------------------  TfqbTableListBox -----------------------}
constructor TfqbTableListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DragMode := dmAutomatic;
  Style := lbOwnerDrawVariable
end;

procedure TfqbTableListBox.DblClick;
begin
  inherited DblClick;
  TfqbTableArea(FindFQBcomp('TfqbTableArea', GetParentForm(Self))).InsertTable(Items[ItemIndex])
end;

procedure TfqbTableListBox.DrawItem(Index: Integer; Rect: TRect; State:
               TOwnerDrawState);
var
  Bitmap: TBitmap;
  Offset: Integer;
  BMPRect: TRect;
begin
  inherited DrawItem(Index, Rect, State);
  Canvas.FillRect(Rect);
  Bitmap := TBitmap.Create;
  Bitmap.LoadFromResourceName(HInstance,'TABLEIMAGE1');
  Offset := 0;
  if Bitmap <> nil then
  begin
    BMPRect := Bounds(Rect.Left, Rect.Top,
             (Rect.Bottom-Rect.Top), Rect.Bottom-Rect.Top);
    Canvas.BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
    Bitmap.Canvas.Pixels[0, Bitmap.Height-1]);
    Offset := (Rect.Bottom-Rect.Top+1);
  end;
  Canvas.TextOut(Rect.Left+Offset, Rect.Top, Items[Index]);
  Bitmap.Free
end;

{-----------------------  TfqbDialog -----------------------}
constructor TfqbDialog.Create(AOwner: TComponent);
begin
  inherited;
  FSchemaInsideSQL := True;
end;

function TfqbDialog.Execute: Boolean;
var
  tmp: TStringList;
begin
  fqbActiveEngine := Engine;
  fqbDesigner := TfqbDesigner.Create(Self);

  tmp:= TStringList.Create;
  tmp.Text := Ftext;
  try
    try
      fqbLoadFromStr(fqbDesigner.fqbTableArea1, fqbDesigner.fqbGrid1, tmp);
    except
    end;

    if fqbDesigner.ShowModal = mrOk then
    begin
      tmp.Clear;
      fqbSaveToStr(fqbDesigner.fqbTableArea1, fqbDesigner.fqbGrid1, tmp);
      FText := tmp.Text;
      if not FSchemaInsideSQL then
      begin
        FSQL := ExtractSQL(FText);
        FSQLSchema := ExtractSchema(FText);
      end;
      Result := true
    end
    else
      Result := false;
  finally
    tmp.Free;
    fqbDesigner.Free
  end
end;

function TfqbDialog.GetSQL: string;
begin
  if SchemaInsideSQL then
    Result := Ftext
  else
  Result := FSQL;
end;

function TfqbDialog.GetSQLSchema: string;
begin
  if SchemaInsideSQL then
    Result := ''
  else
    Result := FSQLSchema;
end;

procedure TfqbDialog.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if (AComponent = FEngine) and (Operation = opRemove) then
  begin
    FEngine := nil;
    fqbActiveEngine := nil;
  end;
end;

procedure TfqbDialog.SetEngine(const Value: TfqbEngine);
begin
  if FEngine <> Value then
  begin
    FEngine := Value;
    fqbActiveEngine := Value;
    FreeNotification(FEngine);
  end
end;

procedure TfqbDialog.SetSchemaInsideSQL(const Value: Boolean);
begin
  FSchemaInsideSQL := Value;
  if SchemaInsideSQL then
  begin
    FSQL := ExtractSQL(Ftext);
    FSQLSchema := ExtractSchema(Ftext);
  end
end;

procedure TfqbDialog.SetSQL(Value: string);
begin
  FSQL := ExtractSQL(Value);
  FSQLSchema := ExtractSchema(Value);
  Ftext := FSQL + _fqbBeginModel + #$D#$A + FSQLSchema + #$D#$A + _fqbEndModel
end;

procedure TfqbDialog.SetSQLSchema(const Value: string);
begin
  FSQLSchema := ExtractSchema(Value);
  Ftext := FSQL + _fqbBeginModel + #$D#$A + FSQLSchema + #$D#$A + _fqbEndModel
end;

{-----------------------  TfqbCheckListBox -----------------------}
procedure TfqbCheckListBox.ClickCheck;
var
  tmp: TfqbGrid;
  tbl: TfqbTable;
  i: Integer;
begin
  tmp := TfqbGrid(FindFQBcomp('TfqbGrid', GetParentForm(Self)));
  tbl := (Parent as TfqbTable);
  
  if not Assigned(tmp) then