Marco Web Center |
Home: Code Repository: Mastering Delphi 5Project DRAWDATA
Project StructureDRAWDATA.DPRprogram DrawData; uses Forms, DrawForm in 'DrawForm.pas' {Form1}; {$R *.RES} begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end. DRAWFORM.PASunit DrawForm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DBTables, DB, Grids, DBGrids, ExtCtrls, StdCtrls, DBCtrls; type TForm1 = class(TForm) DataSource1: TDataSource; DBGrid1: TDBGrid; Table1: TTable; Table1SpeciesNo: TFloatField; Table1Category: TStringField; Table1Common_Name: TStringField; Table1Lengthcm: TFloatField; Table1Notes: TMemoField; Table1Graphic: TGraphicField; procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); procedure FormCreate(Sender: TObject); procedure Table1NotesGetText(Sender: TField; var Text: String; DisplayText: Boolean); procedure Table1NotesSetText(Sender: TField; const Text: String); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); var Bmp: TBitmap; OutRect: TRect; BmpWidth: Integer; begin // default output rectangle OutRect := Rect; if Column.Field = Table1Common_Name then begin // draw the image Bmp := TBitmap.Create; try Bmp.Assign (Table1Graphic); BmpWidth := (Rect.Bottom - Rect.Top) * 2; OutRect.Right := Rect.Left + BmpWidth; DBGrid1.Canvas.StretchDraw (OutRect, Bmp); finally Bmp.Free; end; // reset output rectangle, leaving space for the graphic OutRect := Rect; OutRect.Left := OutRect.Left + BmpWidth; end; // red font color if length > 100 if (Column.Field = Table1Lengthcm) and (Table1Lengthcm.AsInteger > 100) then DBGrid1.Canvas.Font.Color := clRed; // default drawing DBGrid1.DefaultDrawDataCell (OutRect, Column.Field, State); end; procedure TForm1.FormCreate(Sender: TObject); begin Table1.Active := True; end; procedure TForm1.Table1NotesGetText(Sender: TField; var Text: String; DisplayText: Boolean); begin Text := Trim (Sender.AsString); end; procedure TForm1.Table1NotesSetText(Sender: TField; const Text: String); begin Sender.AsString := Text; end; end. DRAWFORM.DFMobject Form1: TForm1 Left = 181 Top = 119 Width = 790 Height = 309 Caption = 'Draw Data Grid' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = True OnCreate = FormCreate PixelsPerInch = 96 TextHeight = 13 object DBGrid1: TDBGrid Left = 0 Top = 0 Width = 782 Height = 282 Align = alClient BorderStyle = bsNone DataSource = DataSource1 DefaultDrawing = False Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -16 Font.Name = 'MS Sans Serif' Font.Style = [fsBold] Options = [dgEditing, dgAlwaysShowEditor, dgTitles, dgIndicator, dgColumnResize, dgColLines, dgRowLines, dgTabs, dgConfirmDelete, dgCancelOnExit] ParentFont = False TabOrder = 0 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText TitleFont.Height = -11 TitleFont.Name = 'MS Sans Serif' TitleFont.Style = [] OnDrawColumnCell = DBGrid1DrawColumnCell end object DataSource1: TDataSource DataSet = Table1 Left = 24 Top = 16 end object Table1: TTable DatabaseName = 'DBDEMOS' FieldDefs = < item Name = 'Species No' DataType = ftFloat end item Name = 'Category' DataType = ftString Size = 15 end item Name = 'Common_Name' DataType = ftString Size = 30 end item Name = 'Species Name' DataType = ftString Size = 40 end item Name = 'Length (cm)' DataType = ftFloat end item Name = 'Length_In' DataType = ftFloat end item Name = 'Notes' DataType = ftMemo Size = 50 end item Name = 'Graphic' DataType = ftGraphic end> IndexDefs = < item Name = 'Table1Index1' Fields = 'Species No' Options = [ixPrimary, ixUnique] end> StoreDefs = True TableName = 'biolife.db' UpdateMode = upWhereChanged Left = 24 Top = 72 object Table1SpeciesNo: TFloatField FieldName = 'Species No' Visible = False end object Table1Category: TStringField DisplayWidth = 12 FieldName = 'Category' FixedChar = False Size = 15 end object Table1Common_Name: TStringField DisplayWidth = 23 FieldName = 'Common_Name' FixedChar = False Size = 30 end object Table1Lengthcm: TFloatField DisplayWidth = 9 FieldName = 'Length (cm)' end object Table1Notes: TMemoField DisplayWidth = 36 FieldName = 'Notes' OnGetText = Table1NotesGetText OnSetText = Table1NotesSetText BlobType = ftMemo Size = 50 end object Table1Graphic: TGraphicField DisplayWidth = 9 FieldName = 'Graphic' Visible = False BlobType = ftGraphic end end end
|
||
© Copyright Marco Cantù, 1995-2020, All rights reserved |