Çeşitli kod ipuçları

[ikutluay]

Merhaba

http://www.swissdelphicenter.ch adresinde çeşitl ipuçları var. metinler genelde yabancıdilde olsada kodlaranlaşılır. ben başlık olarak bu threadin altına atacağım konuları

En azından ilerde arayanlar yararlanır.

saygılar

[ikutluay]

Kod: Tümünü seç

//This is how to color a specific cell in a specific case.
// Define the condition for which field
// I used as Base the RX DBGRID version

procedure TFRM_Main.DBG_MainGetCellParams(Sender: TObject; Field: TField;
AFont: TFont; var Background: TColor; Highlight: Boolean);
begin

if (Field.AsString = '0') and (Field.FullName = 'LoadingAttn') then
begin
Background := $00E69B00;
AFont.Color := clBlack;
AFont.Style := AFont.Style + [fsBold];
end
else
begin
if (Field.AsString = '0') and (Field.FullName = 'DeliveryAttn') then
begin
Background := $0082FFFF;
AFont.Color := clBlack;
AFont.Style := AFont.Style + [fsBold];
end
else
begin
if (Field.AsString = 'H') and (Field.FullName = 'EctaCode1') then
begin
Background := $008080FF;
AFont.Color := clBlack;
AFont.Style := AFont.Style + [fsBold];
end
else
begin
AFont.Color := clBlack;
AFont.Style := AFont.Style - [fsBold];
Background := clWhite;
end;
end;
end;


end;

[ikutluay]

uses
ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
AccessApp: Variant;
begin
AccessApp := CreateOleObject('Access.Application');
AccessApp.NewCurrentDatabase('c:\111.mdb');
AccessApp := Unassigned;
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
var
  test1: Real;
  RowNo: Integer;
begin
  with (Sender as TDBGrid) do
  begin
    if (gdSelected in State) then
    begin
      // Farbe für die Zelle mit dem Focus
      // color of the focused row
      Canvas.Brush.Color := clblue;
    end
    else
    begin
      // Zeile erfahren
      // get the actual row number
      rowno := Query1.RecNo;
      // gerade und ungerade Zeilen ermitteln
      // odd or even ?
      test1 := (RowNo / 2) - trunc(RowNo / 2);
      // Zeile gerade...
      // If it's an even one...
      if test1 = 0 then
      begin
        farbe := clWhite
      end
      // ...Zeile ungerade
      // ...else it's an odd one
      else
      begin
        farbe := clYellow;
      end;
      Canvas.Brush.Color := farbe;
      // Font-Farbe immer schwarz
      // font color always black
      Canvas.Font.Color := clBlack;
    end;
    Canvas.FillRect(Rect);
    // Denn Text in der Zelle ausgeben
    // manualy output the text
    Canvas.TextOut(Rect.Left + 2, Rect.Top + 1, Column.Field.AsString);
  end
end;

[ikutluay]

Kod: Tümünü seç

//...
uses
// ...
  Grids, DBGrids, db
//...

  procedure artgrid(Sender: TObject; const Rect: TRect; DataCol: Integer;
  Column: TColumn; State: TGridDrawState);
  //...

implementation
//...

procedure TForm1.artgrid(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  if ((Sender as tdbgrid).DataSource.DataSet.RecNo mod 2) = 0 then
    (Sender as tdbgrid).Canvas.Brush.Color := clblue; //or any color
  (Sender as tdbgrid).DefaultDrawColumnCell(rect, datacol, column, state);
end;

//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// for all DrawColumnCell event of DBGrid in any Form (here "Form2"):

procedure TForm2.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  Form1.artgrid(Sender, Rect, DataCol, Column, State);
end;

[ikutluay]

Kod: Tümünü seç

{I see always people manually building the connection string.
Wy not use the dialog that windows provide for us ? Of course
it is possible to use the PromptDataSource in ADODB, but this
give not the opportunity to see if the user has pressed OK or
Cancel, so we dont know when to save the changes. So I use this
code instead. I hope it benefit many people. Rgds, Wilfried}

uses OleDB, ComObj, ActiveX;

function ADOConnectionString(ParentHandle: THandle; InitialString: WideString;
  out NewString: string): Boolean;
var
  DataInit: IDataInitialize;
  DBPrompt: IDBPromptInitialize;
  DataSource: IUnknown;
  InitStr: PWideChar;
begin
  Result   := False;
  DataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;
  if InitialString <> '' then
    DataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER, PWideChar(InitialString),
      IUnknown, DataSource);
  DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;
  if Succeeded(DBPrompt.PromptDataSource(nil, ParentHandle,
    DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource)) then 
  begin
    InitStr := nil;
    DataInit.GetInitializationString(DataSource, True, InitStr);
    NewString := InitStr;
    Result    := True;
  end;
end;

[ikutluay]

Kod: Tümünü seç

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1. create new blank field in dbgrid-boş bir sütun ekleyin
  2. rename the title with 'No'- başlığını no yapın
  3. put this code in OnDrawColumncell - bu evente aşağıdaki kodu yapıştırın
  4. Now your Grid has a row number-işlem bitti
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  if DataSource1.DataSet.RecNo > 0 then
  begin
    if Column.Title.Caption = 'No' then
      DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo));
  end;
end;

[ikutluay]

Kod: Tümünü seç

// example: create lookup field (string, size: 50) at runtime

with TStringField.Create(YourDataSet) do
begin
   FieldName := 'FieldName';
   FieldKind := fkLookup;
   DataSet := YourDataSet;
   Name := DataSet.Name + FieldName;
   KeyFields := 'YourKeyFields';
   LookupDataSet := YourLookupDataSet;
   LookupKeyFields := 'YourLookupKeyFields';
   LookupResultField := 'YourLookupResultField';

   FieldDefs.Add(FieldName, ftString, 50, False);
end;

[ikutluay]

Kod: Tümünü seç

/////////////////////////////
//                         //
//       LittleReport      //
//                         //
//       HTML Reports      //
//                         //
//                         //
//     Unit written by     //
//                         //
//     Simone Di Cicco     //
//  simone.dicicco@tin.it  //
// simone.dicicco@email.it //
//                         //
/////////////////////////////

unit LittleReport;

interface

uses Windows, Messages, SysUtils, Classes, DB, Graphics;

const
  FAuthor  = 'Simone Di Cicco';
  FVersion = '1.0';


type

  TLittleReport = class(TComponent)
  protected
    FDataSet: TDataSet;
    FWidth: Integer;
    FTitle: string;
    FAfterHTML: TStringList;
    FPreHTML: TStringList;
    procedure GetDBFieldData(StringList: TStringList; FieldName: string);
    function GetDataRowsTXT: string;
    function GetDataRowsHTML: string;
  private

    ColumnsCont: array of TStringList;
    FieldNames: TStringList;
    HTMLTable: TStringList;
    TXTFile: TStringList;
    IncRowTXT: Integer;
    IncRowHTML: Integer;
  published
    property DataSet: TDataSet read FDataSet write FDataSet;
    property HTMLTableWidth: Integer read FWidth write FWidth default 100;
    property HTMLPageTitle: string read FTitle write FTitle;
    property BeforeReportHTML: TStringList read FPreHTML write FPreHTML;
    property AfterReportHTML: TStringList read FAfterHTML write FAfterHTML;
  public

    constructor Create(AOwner: TComponent); override;
    // destructor Destroy; override;
    procedure CreateReportHTML(Location: TFileName);
    procedure CreateReportTXT(Location: TFileName);
  end;

procedure Register;


implementation

{ TLittleReport }

procedure Register;
begin
  RegisterComponents('Simone Di Cicco', [TLittleReport]);
end;


constructor TLittleReport.Create(AOwner: TComponent);
begin
  inherited;
  FPreHTML := TStringList.Create;
  FPreHTML.Clear;
  FAfterHTML := TStringList.Create;
  FAfterHTML.Clear;
  FieldNames := TStringList.Create;
  FieldNames.Clear;
  HTMLTable := TStringList.Create;
  HTMLTable.Clear;
  TXTFile := TStringList.Create;
  TXTFile.Clear;
end;

procedure TLittleReport.GetDBFieldData(StringList: TStringList;
  FieldName: string);
begin
  StringList.Clear;
  with FDataSet do
  begin
    Open;
    DisableControls;
    try
      while not EOF do

      begin
        StringList.Add(FieldByName(FieldName).AsString);
        Next;
      end;
    finally
      EnableControls;
      Close;
    end;
  end;
end;


procedure TLittleReport.CreateReportHTML(Location: TFileName);
var 
  Counter, ColCount, RowCont: Integer;
  BHTMLPRE, BContPRE, BHTMLAF, BContAF: Integer;
  NameCont, FieldCont: Integer;
  FieldTitle: string;
begin
  NameCont   := 0;
  FieldCont  := 0;
  RowCont    := 0;
  BHTMLPRE   := 0;
  BContPRE   := 0;
  BHTMLAF    := 0;
  BContAF    := 0;
  IncRowHTML := 0;
  FDataSet.Open;
  FieldNames.Clear;
  FDataSet.GetFieldNames(FieldNames);
  ColCount := FDataSet.Fields.Count;
  SetLength(ColumnsCont, ColCount);
  HTMLTable.Clear;
  Counter := 0;
  repeat
    ColumnsCont[Counter] := TStringList.Create;
    GetDBFieldData(ColumnsCont[Counter], FieldNames.Strings[Counter]);
    Inc(Counter, 1);
  until Counter = ColCount;
  RowCont  := ColumnsCont[0].Count;
  BHTMLPRE := FPreHTML.Count;
  if BHTMLPRE >= 1 then

  begin
    repeat
      HTMLTable.Add(FPreHTML.Strings[BContPRE]);
      Inc(BContPRE, 1);
    until BContPRE = BHTMLPRE;
  end;
  if FTitle = '' then HTMLTable.Add('<title>' + Location + '</title>')
  else 
    HTMLTable.Add('<title>' + FTitle + '</title>');
  HTMLTable.Add('<Table Width="' + IntToStr(FWidth) + '%">');
  NameCont := FieldNames.Count;
  repeat

    FieldTitle := FieldTitle + '</TD><TD></TD><TD><B>' +
      FieldNames.Strings[FieldCont] + '</B></TD><TD></TD><TD>';
    Inc(FieldCont, 1);
  until NameCont = FieldCont;
  FieldTitle := '<TR><TD>' + FieldTitle + '</TD></TR>';
  HTMLTable.Add(FieldTitle);
  repeat

    HTMLTable.Add(GetDataRowsHTML);
    Inc(IncRowHTML, 1);
  until IncRowHTML = RowCont;
  HTMLTable.Add('</table>');
  BHTMLAF := FAfterHTML.Count;
  if BHTMLAF >= 1 then
  begin
    repeat
      HTMLTable.Add(FAfterHTML.Strings[BContAF]);
      Inc(BContAF, 1);
    until BContAF = BHTMLAF;
  end;
  HTMLTable.SaveToFile(Location);
end;

procedure TLittleReport.CreateReportTXT(Location: TFileName);
var 
  CounterRep, ColCount, RowCont: Integer;
  NameCont, FieldCont: Integer;
  FieldTitle: string;
begin
  NameCont  := 0;
  FieldCont := 0;
  RowCont   := 0;
  IncRowTXT := 0;
  FDataSet.Open;
  FieldNames.Clear;
  FDataSet.GetFieldNames(FieldNames);
  ColCount := FDataSet.Fields.Count;
  SetLength(ColumnsCont, ColCount);
  TXTFile.Clear;
  CounterRep := 0;
  repeat
    ColumnsCont[CounterRep] := TStringList.Create;
    GetDBFieldData(ColumnsCont[CounterRep], FieldNames.Strings[CounterRep]);
    Inc(CounterRep, 1);
  until CounterRep = ColCount;
  RowCont  := ColumnsCont[0].Count;
  NameCont := FieldNames.Count;
  repeat
    FieldTitle := FieldTitle + '| ' + FieldNames.Strings[FieldCont];
    Inc(FieldCont, 1);
  until NameCont = FieldCont;
  FieldTitle := FieldTitle + '|';
  TXTFile.Add(FieldTitle);
  TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
  TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
  repeat

    TXTFile.Add(GetDataRowsTXT);
    TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
    Inc(IncRowTXT, 1);
  until IncRowTXT = RowCont;
  TXTFile.SaveToFile(Location);
end;

function TLittleReport.GetDataRowsTXT: string;
var

  CounterRow, ColArray: Integer;
  ReportRow: string;
begin
  CounterRow := 0;
  ColArray   := Length(ColumnsCont);
  repeat
    ReportRow := ReportRow + '| ' + ColumnsCont[CounterRow].Strings[IncRowTXT] + ' |';
    Inc(CounterRow, 1);
  until CounterRow = ColArray;
  Result := ReportRow;
end;

function TLittleReport.GetDataRowsHTML: string;
var
  CounterRow, ColArray: Integer;
  ReportRow: string;
begin
  CounterRow := 0;
  ColArray   := Length(ColumnsCont);
  repeat

    ReportRow := ReportRow + '</TD><TD></TD><TD>' +
      ColumnsCont[CounterRow].Strings[IncRowHTML] + '</TD><TD></TD><TD>';
    Inc(CounterRow, 1);
  until CounterRow = ColArray;
  ReportRow := '<TR><TD>' + ReportRow + '</TD></TR>';
  Result    := ReportRow;
end;

end.

[ikutluay]

Kod: Tümünü seç

{ Thanks to Thomas Stutz' tip on this site!}
{ A dbgrid is awkward since it has no cells,}
{ you have to step through the table using next;}
{ This procedure is however slow }

procedure SetGridColumnWidths(Grid: Tdbgrid);
const
  DEFBORDER = 10;
var
  temp, n: Integer;
  lmax: array [0..30] of Integer;
begin
  with Grid do
  begin
    Canvas.Font := Font;
    for n := 0 to Columns.Count - 1 do
      //if columns[n].visible then
      lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;
    grid.DataSource.DataSet.First;
    while not grid.DataSource.DataSet.EOF do 
    begin
      for n := 0 to Columns.Count - 1 do 
      begin
        //if columns[n].visible then begin
        temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
        if temp > lmax[n] then lmax[n] := temp;
        //end; { if }
      end; {for}
      grid.DataSource.DataSet.Next;
    end; { while }
    grid.DataSource.DataSet.First;
    for n := 0 to Columns.Count - 1 do
      if lmax[n] > 0 then
        Columns[n].Width := lmax[n];
  end; { With }
end; {SetGridColumnWidths  }

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetGridColumnWidths(dbgrid3);
end;

[ikutluay]

Kod: Tümünü seç

 - Here is tip how to scroll DBGrid -}

//...
private
  OldGridProc: TWndMethod;
  procedure GridWindowProc(var Message: TMessage);
//...

procedure TForm1.FormCreate(Sender: TObject);
begin
  OldGridProc        := DBGrid1.WindowProc;
  DBGrid1.WindowProc := GridWindowProc;
end;

procedure TForm1.GridWindowProc(var Message: TMessage);
var
  Pos: SmallInt;
begin
  OldGridProc(Message);
  if Message.Msg = WM_VSCROLL then  //or WM_HSCROLL
  begin
    Pos          := Message.WParamHi;  //Scrollbox position
    Table1.RecNo := Pos;
  end;
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOConnection1.Connected := True;
  ADOCommand1.CommandText  := 'Exec SP_AddLogin ' + QuotedStr('UserName') +
    ',' + QuotedStr('Password') + ',' + QuotedStr('Database Name') + ',' +
    QuotedStr('English') + ';';
  ADOCommand1.Execute;
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOConnection1.ConnectionString := 'Server=Hostname;DataBase=DatabaseName';
  ADOConnection1.Open('UserName', 'Password');
  ADOConnection1.Connected := True;
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOQuery1.SQL.Add('Exec SP_WHO');
  ADOQuery1.Active := True;
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOQuery1.SQL.Add('Exec SP_DATABASES');
  ADOQuery1.Active := True;
end;