procedure DrawGridCheckBox(Canvas: TCanvas; Rect: TRect; Checked: boolean);

var

DrawFlags: Integer;

begin

Canvas.TextRect(Rect, Rect.Left + 1, Rect.Top + 1, ' ');

DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);

DrawFlags := DFCS_BUTTONCHECK or DFCS_ADJUSTRECT;// DFCS_BUTTONCHECK

if Checked then

DrawFlags := DrawFlags or DFCS_CHECKED;

DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DrawFlags);

end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;

DataCol: Integer; Column: TColumn; State: TGridDrawState);

begin

if Column.FieldName = 'WEIGHT' then // Модифицируйте под себя

if Column.Field.AsInteger > 10 then

DrawGridCheckBox(DBGrid1.Canvas, Rect, true)

else

DrawGridCheckBox(DBGrid1.Canvas, Rect, false)

end;

procedure TfrmMain.DBGrid1ColEnter(Sender: TObject);

begin

with TDBGrid(Sender) do

if SelectedField.FieldName = 'Weight' then // Модифицируйте под себя

Options := Options - [dgEditing]

else

Options := Options + [dgEditing]

end;

FDragItem := ItematPos(X, Y, True);

if FDragItem >= 0 then

BeginDrag(false);

...



procedure TForm1.ListBoxDragDrop(Sender, Source: TObject; X, Y: Integer);

begin

if Source is TDirectoryListBox then

ListBox.Items.Add(TDirectoryListBox(Source).GetItemPath(FDragItem));

end;

procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);

begin

with Source as TImage do

begin

Left := X;

Top := Y;

end;

end;



procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

Accept := Source is TImage;

end;



procedure TForm1.FormCreate(Sender: TObject);

begin

with TImage.Create(Self) do

begin

Parent := Panel1;

AutoSize := True;

Picture.LoadFromFile('D:DELPHIIMAGESCHIP.BMP');

DragMode := dmAutomatic;

OnDragOver := Panel1DragOver;

OnDragDrop := Panel1DragDrop;

end;

end;

OnMouseDown:

BeginDrag(False);

while ... do

begin

Application.ProccessMessages; { это позволяет Windows обработать }

{ все сообщения за один шаг }

end;

unit Unit1;



interface



uses



SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, Grids, Outline;



type



TForm1 = class(TForm)

Outline1: TOutline;

Outline2: TOutline;

procedure OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);

procedure OutlineMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure OutlineDragOver(Sender, Source: TObject; X, Y: Integer;



State: TDragState; var Accept: Boolean);

private

{ Private declarations }

public

{ Public declarations }

end;



var



Form1: TForm1;



implementation



{$R *.DFM}



procedure TForm1.OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);

begin



with Sender as TOutline do

begin

AddChild(GetItem(x, y),

TOutline(Source).Items[TOutline(Source).SelectedItem].Text);

end;



end;



procedure TForm1.OutlineMouseDown(Sender: TObject; Button: TMouseButton;



Shift: TShiftState; X, Y: Integer);

begin



if Button = mbLeft then

with Sender as TOutline do

begin

if GetItem(x, y) >= 0 then

BeginDrag(False);

end;

end;



procedure TForm1.OutlineDragOver(Sender, Source: TObject; X, Y: Integer;



State: TDragState; var Accept: Boolean);

begin

if (Source is TOutline) and (TOutline(Source).GetItem(x, y) <>

TOutline(Source).SelectedItem) then

Accept := True

else

Accept := False;

end;

end.

var

Form1: TForm1;

richcopy: string;

transfering: boolean;

implementation



{$R *.DFM}



procedure TForm1.RichEdit1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if length(richedit1.seltext)>0 then begin

richcopy:=richedit1.seltext;

transfering:=true;

end; //seltext

end;



procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

if transfering then begin

transfering:=false;

listbox1.items.add(richcopy);

end; //transfering

end;

procedure TForm1.GenericMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

TImage(Sender).BeginDrag(False);

{что-то другое, что вы хотели бы сделать}

end;



{....}



UmpteenthDynImage := TImage.Create(dummyImage);

UmpteenthDynImage.MouseDown := TForm1.GenericMouseDown;

{ ListView1.DragMode := dmAutomatic }



procedure TForm1.ListView1DragDrop(Sender, Source: TObject; X, Y: Integer);

var

DragItem, DropItem, CurrentItem, NextItem: TListItem;

begin

if Sender = Source then

with TListView(Sender) do

begin

DropItem := GetItemAt(X, Y);

CurrentItem := Selected;

while CurrentItem <> nil do

begin

NextItem := GetNextItem(CurrentItem, SdAll, [IsSelected]);

if DropItem = nil then DragItem := Items.Add

else

DragItem := Items.Insert(DropItem.Index);

DragItem.Assign(CurrentItem);

CurrentItem.Free;

CurrentItem := NextItem;

end;

end;

end;



procedure TForm1.ListView1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState;

var Accept: Boolean);

begin

Accept := Sender = ListView1;

end;

unit HintEdit;



interface



uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;



type

THintEdit = class(TCustomEdit)

private

{ Private declarations }

FHintList: TStrings;

Searching,

CanSearch: boolean;

CurSPos: integer;

protected

{ Protected declarations }

procedure Change; override;

procedure KeyDown(var Key: Word; Shift: TShiftState); override;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

property HintList: TStrings read FHintList write FHintList;

destructor Destroy; override;

published

{ Published declarations }

property Anchors;

property AutoSelect;

property AutoSize;

property BiDiMode;

property BorderStyle;

property CharCase;

property Color;

property Constraints;

property Ctl3D;

property DragCursor;

property DragKind;

property DragMode;

property Enabled;

property Font;

property HideSelection;

property ImeMode;

property ImeName;

property MaxLength;

property OEMConvert;

property ParentBiDiMode;

property ParentColor;

property ParentCtl3D;

property ParentFont;

property ParentShowHint;

property PasswordChar;

property PopupMenu;

property ReadOnly;

property ShowHint;

property TabOrder;

property TabStop;

property Text;

property Visible;

property OnChange;

property OnClick;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDock;

property OnEndDrag;

property OnEnter;

property OnExit;

property OnKeyDown;

property OnKeyPress;

property OnKeyUp;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDock;

property OnStartDrag;

end;



procedure Register;



implementation



{$R *.DCR}



procedure Register;

begin

RegisterComponents('Netscape', [THintEdit]);

end;



constructor THintEdit.Create;

begin

inherited;

FHintList := TStringList.Create;

Searching := false;

CanSearch := true;

CurSPos := -1;

end;



procedure THintEdit.Change;

var

i, l: integer;

begin

if Searching then

Exit;

if not CanSearch then

Exit;

if Text = '' then

exit;

l := Length(Text);

for i := 0 to FHintList.Count - 1 do

if Copy(FHintList[i], 1, l) = Text then

begin

Searching := true;

CurSPos := i;

Text := FHintList[i];

Searching := false;

SelStart := Length(Text);

SelLength := -(Length(Text) - l);

break;

end;

inherited;

end;



procedure THintEdit.KeyDown;

var

l: integer;

begin

if Chr(Key) in ['A'..'z', 'А'..'Я', 'а'..'я'] then

CanSearch := true

else

CanSearch := false;

case Key of

VK_DOWN:

begin

if (CurSPos < HintList.Count - 1) and (SelLength > 0) then

if Copy(FHintList[CurSPos + 1], 1, SelStart) = Copy(Text, 1, SelStart)

then

begin

l := SelStart;

Inc(CurSPos);

Text := FHintList[CurSPos];

SelStart := Length(Text);

SelLength := -(Length(Text) - l);

end;

Key := VK_RETURN;

end;

VK_UP:

begin

if (CurSPos > 0) and (SelLength > 0) then

if Copy(FHintList[CurSPos - 1], 1, SelStart) = Copy(Text, 1, SelStart)

then

begin

l := SelStart;

Dec(CurSPos);

Text := FHintList[CurSPos];

SelStart := Length(Text);

SelLength := -(Length(Text) - l);

end;

Key := VK_RETURN;

end;

VK_RETURN:

begin

SelStart := 0;

SelLength := Length(Text);

end;

end;

inherited;

end;



destructor THintEdit.Destroy;

begin

FHintList.Free;

inherited;

end;








©Drkb::00968

http://delphiworld.narod.ru/

DelphiWorld 6.0



Подстановка в TEdit





Code:

var

words: TStringList;



procedure TForm1.FormCreate(Sender: TObject);

begin

words := TStringList.Create;

words.Sorted := true;

words.Add('one');

words.Add('two');

words.Add('four');

words.Add('five');

words.Add('six');

words.Add('seven');

words.Add('eight');

words.Add('nine');

words.Add('ten');

end;



procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word;

Shift: TShiftState);

const

chars: set of char = ['A'..'Z', 'a'..'z', 'А'..'Я', 'а'..'я'];

var

w: string;

i: integer;

s: string;

full: string;

SelSt: integer;

begin

case Key of

VK_RETURN, VK_TAB:

begin

Edit1.SelStart := Edit1.SelStart + Edit1.SelLength;

Edit1.SelLength := 0;

Exit;

end;

VK_DELETE, VK_BACK:

begin

Edit1.ClearSelection;

Exit;

end;

end;

s := Edit1.Text;

SelSt := Edit1.SelStart;

i := SelSt;

if (length(s) > i) and (s[i+1] in chars) then

Exit;

w := '';

while (i >= 1) and (s[i] in chars) do

begin

w := s[i] + w;

dec(i);

end;

if length(w) <= 0 then

Exit;

words.Find(w, i);

if (i >= 0) and (UpperCase(copy(words[i], 1,

length(w))) = UpperCase(w)) then

begin

full := words[i];

insert(copy(full, length(w) + 1, length(full)), s, SelSt + 1);

Edit1.Text := s;

Edit1.SelStart := SelSt;

Edit1.SelLength := length(full) - length(w);

end;

end;

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;

Panel: TStatusPanel; const Rect: TRect);

begin

with statusbar1.Canvas do

begin

Brush.Color := clRed;

FillRect(Rect);

TextOut(Rect.Left, Rect.Top, 'Панель '+IntToStr(Panel.Index));

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

r: TRect;

pb: TProgressBar;

begin

Listview1.Columns.Add.Width := 100;

Listview1.Columns.Add.Width := 200;

Listview1.ViewStyle := vsReport;

Listview1.Items.Add.Caption := 'Text';



r := Listview1.Items[0].DisplayRect(drBounds);

r.Left := r.Left + Listview1.columns[0].Width;

r.Right := r.Left + Listview1.columns[1].Width;



pb := TProgressBar.Create(Self);

pb.Parent := Listview1;

pb.BoundsRect := r;

pb.Position := 30;

Listview1.Items[0].Data := pb;

end;





// Change the ProgressBar Position

// ProgressBar Position andern



procedure TForm1.Button2Click(Sender: TObject);

var

pb: TProgressBar;

begin

pb := TProgressBar(Listview1.Items[0].Data);

pb.StepIt;

end;

{

Use this ProgressBar when you do not know the amount of progress toward

completion but wish to indicate that progress is being made.



This ProgressBar works only on Windows XP and the ComCtl32.dll version

6.00 or later is needed. To use the new ComCtrl you have to provide the manifest.

In Delphi 7 just drop TXPManifest on the form. For prior versions of Delphi

you have to include the XP manifest resource.

}





unit MarqueeProgressBar;



interface



uses

SysUtils, Windows, Classes, Controls, ComCtrls, Messages;



type

TMarqueeProgressBar = class(TProgressBar)

private

FActive: Boolean;

FAnimationSpeed: Integer;

procedure SetActive(const Value: Boolean);

procedure SetAnimationSpeed(const Value: Integer);

procedure UpdateProgressBar;

protected

procedure CreateParams(var Params: TCreateParams); override;

public

constructor Create(AOwner: TComponent); override;

published

property Active: Boolean read FActive write SetActive;

property AnimationSpeed: Integer read FAnimationSpeed write SetAnimationSpeed;

end;



const

PBS_MARQUEE = $08;

PBM_SETMARQUEE = WM_USER + 10;



procedure Register;



implementation



procedure Register;

begin

RegisterComponents('SwissDelphiCenter', [TMarqueeProgressBar]);

end;



constructor TMarqueeProgressBar.Create(AOwner: TComponent);

begin

inherited;

FAnimationSpeed := 60;

end;



procedure TMarqueeProgressBar.CreateParams(var Params: TCreateParams);

begin

inherited;

Params.Style := Params.Style or PBS_MARQUEE;

end;



procedure TMarqueeProgressBar.SetActive(const Value: Boolean);

begin

FActive := Value;

UpdateProgressBar;

end;



procedure TMarqueeProgressBar.SetAnimationSpeed(const Value: Integer);

begin

FAnimationSpeed := Value;

UpdateProgressBar;

end;



procedure TMarqueeProgressBar.UpdateProgressBar;

begin

if FActive then

SendMessage(Self.Handle, PBM_SETMARQUEE, 1, FAnimationSpeed)

else

SendMessage(Self.Handle, PBM_SETMARQUEE, 0, 0);

end;



end.

unit vsprgs;



interface



uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComCtrls;



type

TNProgressBar = class(TProgressBar)

procedure WMNCPAINT(var Msg: TMessage); message WM_NCPAINT;

private

FShowFrame: boolean;

procedure SetShowFrame(Value: boolean);

protected

public

constructor Create(AOwner: TComponent); override;

published

property ShowFrame: boolean read FShowFrame write SetShowFrame;

end;



procedure Register;



implementation

{ TNProgressBar }



constructor TNProgressBar.Create(AOwner: TComponent);

begin

inherited;

FShowFrame := True;

end;



procedure TNProgressBar.SetShowFrame(Value: boolean);

begin

if FShowFrame <> Value then

begin

FShowFrame := Value;

RecreateWnd;

end;

end;



procedure TNProgressBar.WMNCPAINT(var Msg: TMessage);

var

DC: HDC;

RC: TRect;

begin

if ShowFrame then

begin

inherited;

Invalidate;

end

else

begin

DC := GetWindowDC(Handle);

try

Windows.GetClientRect(Handle, RC);

with RC do

begin

Inc(Right, 2);

Inc(Bottom, 2);

end;

Windows.FillRect(DC, RC, Brush.Handle);

finally

ReleaseDC(Handle, DC);

end;

end;

end;



procedure Register;

begin

RegisterComponents('Controls', [TNProgressBar]);

end;



end.

const

PBS_MARQUEE = $08;

PBM_SETMARQUEE = WM_USER+10;



...



with ProgressBar1 do

begin

SetWindowLong (Handle, GWL_STYLE, (GetWindowLong (Handle, GWL_STYLE) or PBS_MARQUEE));

Perform(PBM_SETMARQUEE, 1, 50);

end;

unit StatusBarExt;



interface



uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;



type

TStatusBarExt = class(TStatusBar)

public

constructor Create(AOwner: TComponent); override; // добавить конструктор

end;



procedure Register;



implementation



uses Consts; // не забыть



constructor TStatusBarExt.Create( AOwner : TComponent );

begin

inherited Create(AOwner);

ControlStyle := ControlStyle + [csAcceptsControls]; // собственно все!

end;



procedure Register;

begin

RegisterComponents('Samples', [TStatusBarExt]);

end;



end.

unit Unit1;



interface



uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, Grids, ComCtrls;



type

TForm1 = class(TForm)

StringGrid1: TStringGrid;

DateTimePicker1: TDateTimePicker;

procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;

var CanSelect: Boolean);

procedure FormCreate(Sender: TObject);

procedure StringGrid1Exit(Sender: TObject);

procedure DateTimePicker1Exit(Sender: TObject);

end;



var

Form1: TForm1;



implementation



{$R *.dfm}



procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,

ARow: Integer; var CanSelect: Boolean);

var

D: TDateTime;

begin

DateTimePicker1.Visible := True;

DateTimePicker1.BoundsRect := StringGrid1.CellRect(ACol, ARow);

D := DateTimePicker1.DateTime;

TryStrToDateTime(StringGrid1.Cells[ACol, ARow], D);

DateTimePicker1.DateTime := D;

DateTimePicker1.SetFocus;

end;



procedure TForm1.FormCreate(Sender: TObject);

begin

DateTimePicker1.Parent := StringGrid1;

DateTimePicker1.Visible := False;

DateTimePicker1.OnExit := DateTimePicker1Exit;



StringGrid1.OnSelectCell := StringGrid1SelectCell;

end;



procedure TForm1.StringGrid1Exit(Sender: TObject);

begin

DateTimePicker1.Visible := False;

end;



procedure TForm1.DateTimePicker1Exit(Sender: TObject);

begin

with StringGrid1 do

Cells[Col, Row] := DateTimeToStr(DateTimePicker1.DateTime);

end;



end.

unit RowGrid;

interface

uses
WinTypes, WinProcs, Classes, Grids, DBGrids;

type
TRowDBGrid = class(TDBGrid)
public
property Row;
property RowCount;
property VisibleRowCount;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Data Controls', [TRowDBGrid]);
end;

end.



{вот небольшой испытательный демо-проект.. мы
поместили на форму нашу сетку-наследницу, 3 компонента
EditBox и поместили следующий код в обработчик события
ondrawdatacell вашего TRowGrid}
procedure TForm1.RowDBGrid1DrawDataCell(Sender: TObject; const Rect:
TRect; Field: TField; State: TGridDrawState);
begin
eb_row.text := inttostr(rowdbgrid1.row);
eb_rowcount.text := inttostr(rowdbgrid1.rowcount);
eb_visiblerowcount.text := inttostr(rowdbgrid1.visiblerowcount);
end;

var
c: shortint;
s: string;
begin
s := 'A';
with DBNavigator1 do
for c := 0 to ControlCount - 1 do
if Controls[c] is TNavButton then
with TNavButton(Controls[c]) do
begin
ListBox1.Items.Add(Name);
Glyph := nil;
Caption := s;
Inc(s[1]);
end;
end;

Function CreateProgressBar(StatusBar:TStatusBar; index:integer):TProgressBar;

var findleft:integer;

i:integer;

begin

result:=TProgressBar.create(Statusbar);

result.parent:=Statusbar;

result.visible:=true;

result.top:=2;

findleft:=0;

for i:=0 to index-1 do

findleft:=findleft+Statusbar.Panels[i].width+1;

result.left:=findleft;

result.width:=Statusbar.Panels[index].width-4;

result.height:=Statusbar.height-2;

end;

procedure TForm1.Edit1Exit(Sender: TObject);

begin

if Edit1.Text <> '' then

begin

try

StrToDate(Edit1.Text);

except

Edit1.SetFocus;

MessageBeep(0);

raise Exception.Create('"' + Edit1.Text

+ '" - некорректная дата');

end {try};

Edit1.Text := DateToStr(StrToDate(Edit1.Text));

end {if};

end;