fqbclass.pas

这个是功能强大的报表软件

  inherited CreateParams(Params);
  with Params do
  begin
    Style:= Style or WS_SIZEBOX;
    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.SetXPStyle(const AComp: TControl);
begin
  {$IFDEF Delphi7}
  if ThemeServices.ThemesEnabled then
    AComp.ControlStyle := AComp.ControlStyle - [csParentBackground] + [csOpaque];
  {$ENDIF};
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
  PostMessage(Handle, CM_RELEASE, 0, 0);
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;
end;

procedure TfqbTableListBox.CreateWnd;
begin
  Style := lbOwnerDrawFixed;
  ItemHeight := 18;
  inherited;
end;

procedure TfqbTableListBox.DblClick;
begin
  inherited DblClick;
  fqbCore.TableArea.InsertTable(Items[ItemIndex])
end;

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

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

function TfqbDialog.Execute: Boolean;
var
  tmp: TStringList;
begin
  {$IFDEF TRIAL}
  ShowMessage(' Fast Query Builder'#10#13'Unregistered version');
  {$ENDIF}
  fqbDesigner := TfqbDesigner.Create(Self);
  fqbCore.Engine := Engine;
  fqbCore.Grid := fqbDesigner.fqbGrid1;
  fqbCore.TableArea := fqbDesigner.fqbTableArea1;

  tmp:= TStringList.Create;
  tmp.Text := fqbCore.FText;
  try
    try
      fqbCore.LoadFromStr(tmp);
    except
    end;

    if fqbDesigner.ShowModal = mrOk then
    begin
      tmp.Clear;
      fqbCore.SaveToStr(tmp);
      fqbCore.FText := tmp.Text;
      Result := true
    end
    else
      Result := false;
  finally
    tmp.Free;
    fqbDesigner.Free
  end
end;

{$IFDEF FQB_COM}
function TfqbDialog.DesignQuery(
  const Param1:       IfrxCustomQuery; 
  out ModalResult:    WordBool): HResult; stdcall;
var
  SQLText:            WideString;
  SQLSchemaText:      WideString;
  idsp:               IInterfaceComponentReference;
  obj:                TComponent; //TfqbEngine;
begin
  try
    Result := Param1.QueryInterface( IInterfaceComponentReference, idsp);
    if Result = S_OK then
    begin
      obj := idsp.GetComponent;
      if obj is TfrxCustomQuery then
      begin
        Engine := TfrxCustomQuery(obj).QBEngine;
        SchemaInsideSQL := False;
        Param1.Get_SQL(SQLText);
        SQL := SQLText;
        Param1.Get_SQLSchema(SQLSchemaText);
        SQLSchema := SQLSchemaText;
        ModalResult := Execute;
      end
      else
      begin
        ShowMessage(' Fast Query Builder'#10#13'Received object is not TfrxCustomQuery');
      end
    end;
  except
    Result := E_FAIL;
  end;
end;

function TfqbDialog.Get_SQL(out Value: WideString): HResult; stdcall;
begin
  Value := SQL;
  Result := S_OK;
end;
function TfqbDialog.Set_SQL(const Value: WideString): HResult; stdcall;
begin
  SQL := Value;
  Result := S_OK;
end;
function TfqbDialog.Get_SQLSchema(out Value: WideString): HResult; stdcall;
begin
  Value := SQLSchema;
  Result := S_OK;
end;
function TfqbDialog.Set_SQLSchema(const Value: WideString): HResult; stdcall;
begin
  SQLSchema := Value;
  Result := S_OK;
end;
{$ENDIF}

function TfqbDialog.GetSchemaInsideSQL: Boolean;
begin
  Result := fqbCore.SchemaInsideSQL;
end;

function TfqbDialog.GetSQL: string;
begin
  Result := fqbCore.SQL;
end;

function TfqbDialog.GetSQLSchema: string;
begin
  Result := fqbCore.SQLSchema;
end;

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

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

procedure TfqbDialog.SetSchemaInsideSQL(const Value: Boolean);
begin
  fqbCore.SchemaInsideSQL := Value;
end;

procedure TfqbDialog.SetSQL(Value: string);
begin
  fqbCore.SQL := Value;
end;

procedure TfqbDialog.SetSQLSchema(const Value: string);
begin
  fqbCore.SQLSchema := Value;
end;

{-----------------------  TfqbCore -----------------------}
constructor TfqbCore.Create;
begin
  if FfqbCore <> nil then
    raise EfqbError.Create('TfqbCore class already initialized.');
  if FExternalCreation then
    raise EfqbError.Create('Call fqbCore function to reference this class.');
  inherited;
  FUseCoding := True;
  FUsingQuotes := False;
end;

destructor TfqbCore.Destroy;
begin
  FfqbCore := nil;
  inherited;
end;

procedure TfqbCore.Clear;
var
  i: Integer;
begin
  for i:= Grid.Items.Count - 1 downto 0 do
      Dispose(PGridColumn(Grid.Items[i].Data));
  Grid.Items.Clear;
  
  for i := TableArea.ComponentCount - 1 downto 0 do
    TableArea.Components[i].Free
end;

function TfqbCore.ExtractSchema(const Value: string): string;
var
  e, b: Integer;
begin
  b := Pos(_fqbBeginModel, Value) + Length(_fqbBeginModel);
  e := Pos(_fqbEndModel, Value);
  if not (e = 0) then
  begin
    Result := Copy(Value, b, e-b);
    Result := fqbTrim(Result, [#10, #13]);
  end
  else
    Result := Value;
end;

function TfqbCore.ExtractSQL(const Str: string): string;
var
  e, b: Integer;
begin
  b := Pos(_fqbBeginModel, Str);
  e := Pos(_fqbEndModel, Str);
  Result := Str;
  Delete(Result, b, e);
end;

function TfqbCore.GenerateSQL: string;
  
  const
    strTab  = '    ';
    strSel = 'SELECT ';
    strFrom = 'FROM';
    strWhere = 'WHERE';
    strOrder = 'ORDER BY ';
    strGroup = 'GROUP BY ';
  var
    i: integer;
    tmpStr, orderStr, prd, groupStr: string;
    slFrom, slWhere: TStringList;
    Tbl1, Tbl2, Tbl3: TfqbTable;
    CopyLL: TList;
    flg: boolean;
    SQL: TStringList;
  
  function FormingFrom(const Ind: integer):string;
    var
      tmp: TfqbLink;
  begin
      tmp := TableArea.LinkList[Ind];
      Result :=  {strTab + }JoinType[tmp.JoinType] + ' '
                + Tbl2.TableName + ' ' + Tbl2.AliasName + ' ON ('
                + Tbl1.AliasName + '.' + tmp.SourceField.FieldName
                + LinkType[tmp.JoinOperator]
                + Tbl2.AliasName + '.' + tmp.DestField.FieldName + ')'
  end;
  
  function FormingFromAnd(const Ind: integer):string;
    var
      tmp: TfqbLink;
  begin
    tmp := TfqbLink(TableArea.LinkList[Ind]);
    Result := ' AND ('
             + Tbl1.AliasName + '.' + tmp.SourceField.FieldName
             + LinkType[tmp.JoinOperator]
             + Tbl3.AliasName + '.' + tmp.DestField.FieldName + ') '
  end;
  
begin
  SQL := TStringList.Create;
  //SELECT
  tmpStr := strSel;
  
  if Grid.Items.Count = 0 then Exit;
  
  for i := 0 to Grid.Items.Count - 1 do
  
  if TGridColumn(Grid.Items[i].Data^).Visibl then
  begin
  
    if Grid.Items[i].SubItems[rowFunction - 1] <> '' then
      prd := Grid.Items[i].SubItems[rowFunction - 1] + '('
    else
      prd := '';
  
    tmpStr := tmpStr + prd + TGridColumn(Grid.Items[i].Data^).Alias + '.'
              + TGridColumn(Grid.Items[i].Data^).Field;
  
    if prd <> '' then prd := ')';
  
    tmpStr := tmpStr + prd + ', '
  end;
  tmpStr := Copy(tmpStr,1,Length(tmpStr) - 2);
  SQL.Add(tmpStr);
  
  //FROM
  tmpStr := '';
  slFrom := TStringList.Create;
  CopyLL := TList.Create;
  for i := 0 to TableArea.LinkList.Count - 1 do
    CopyLL.Add(Pointer(i));
  while CopyLL.Count <> 0 do
  begin
    Tbl1 := TableArea.LinkList[0].SourceTable;
    Tbl2 := TableArea.LinkList[0].DestTable;
    slFrom.Add(strTab + Tbl1.TableName + ' ' + Tbl1.AliasName);
    slFrom.Add(strTab + FormingFrom(0));
    for i := 1 to CopyLL.Count - 1 do
    begin
      Tbl3 := TableArea.LinkList[i].DestTable;
  
      if (Tbl3.AliasName = Tbl2.AliasName) then
      begin
        slFrom[slFrom.Count - 1] := slFrom[slFrom.Count - 1] + FormingFromAnd(Integer(CopyLL[i]));
        CopyLL[i] := Pointer(-1);
      end
      else