Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 8 мая!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Drag and Drop из RichEdit

Разговор двух программистов:
- Ты слышал, Костя умер.
- А он записался?!!


  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;
 




Drag and Drop TImage

Вот рабочий пример. Расположите на форме панель побольше, скопируйте и измените приведенный код так, чтобы изображение загружалось из ВАШЕГО каталога Delphi.


 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:\DELPHI\IMAGES\CHIP.BMP');
     DragMode := dmAutomatic;
     OnDragOver := Panel1DragOver;
     OnDragDrop := Panel1DragDrop;
   end;
 end;
 
 




Drag and Drop несколько элементов в TListView


 { 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;
 




Пример Drag and Drop между двумя DBGrid

Данный пример компонента и демонстрационный проект показывают простой путь осуществления операции "drag and drop" (перетащи и брось) между двумя полями различных табличных сеток.

  1. Запустите Delphi 3 (с незначительными изменениями данный код может работать и в Delphi 1-2).

  2. Активизируйте File|New|Unit. Скопируйте приведенный ниже модуль MyDBGrid во вновь созданный модуль. Сделайте File|Save As. Сохраните модуль как MyDBGrid.pas.

  3. Выберите пункт меню Component|Install Component. Переключитесь на страницу Info New Package. Поместите MyDBGrid.pas в поле редактирования "Unit file name" (имя файла модуля). Назовите модуль MyPackage.dpk. Ответьте Yes на вопрос Delphi 3 о необходимости сборки и установки пакета. Нажмите OK на сообщение Delphi 3 о необходимости включения VCL30.DPL. После этого пакет будет собран и установлен. Теперь компонент TMyDBGrid будет отображен в Палитре Компонентов в группе "Samples". Закройте редактор пакетов и сохраните пакет.

  4. Выберите пункт меню File|New Application. Щелкните правой кнопкой мыши на форме (Form1) и выберите View As Text. Скопируйте приведенный ниже исходный код формы GridU1 в Form1. Щелкните правой кнопкой мыши на форме и выберите View As Form. Убедитесь в активности ваших таблиц. Скопируйте расположенный ниже модуль GridU1 в ваш модуль Unit1.

  5. Выберите пункт меню File|Save Project As. Сохраните модуль как GridU1.pas. Сохраните проект как GridProj.dpr.

  6. Теперь запустите проект и наслаждайтесь функцией Drag and Drop между двумя табличными сетками.

 // Модуль MyDBGrid
 
 unit MyDBGrid;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, Grids, DBGrids;
 
 type
 
   TMyDBGrid = class(TDBGrid)
   private
     { Private declarations }
     FOnMouseDown: TMouseEvent;
   protected
     { Protected declarations }
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); override;
   published
     { Published declarations }
     property Row;
     property OnMouseDown read FOnMouseDown write FOnMouseDown;
   end;
 
 procedure Register;
 
 implementation
 
 procedure TMyDBGrid.MouseDown(Button: TMouseButton;
 
   Shift: TShiftState; X, Y: Integer);
 begin
 
   if Assigned(FOnMouseDown) then
     FOnMouseDown(Self, Button, Shift, X, Y);
   inherited MouseDown(Button, Shift, X, Y);
 end;
 
 procedure Register;
 begin
 
   RegisterComponents('Samples', [TMyDBGrid]);
 end;
 
 end.
 
 // Модуль GridU1
 
 unit GridU1;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, Db, DBTables, Grids, DBGrids, MyDBGrid, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     MyDBGrid1: TMyDBGrid;
     Table1: TTable;
     DataSource1: TDataSource;
     Table2: TTable;
     DataSource2: TDataSource;
     MyDBGrid2: TMyDBGrid;
     procedure MyDBGrid1MouseDown(Sender: TObject;
       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
     procedure MyDBGrid1DragOver(Sender, Source: TObject;
       X, Y: Integer; State: TDragState; var Accept: Boolean);
     procedure MyDBGrid1DragDrop(Sender, Source: TObject;
       X, Y: Integer);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 var
 
   SGC: TGridCoord;
 
 procedure TForm1.MyDBGrid1MouseDown(Sender: TObject;
 
   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 var
 
   DG: TMyDBGrid;
 begin
 
   DG := Sender as TMyDBGrid;
   SGC := DG.MouseCoord(X, Y);
   if (SGC.X > 0) and (SGC.Y > 0) then
     (Sender as TMyDBGrid).BeginDrag(False);
 end;
 
 procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject;
 
   X, Y: Integer; State: TDragState; var Accept: Boolean);
 var
 
   GC: TGridCoord;
 begin
 
   GC := (Sender as TMyDBGrid).MouseCoord(X, Y);
   Accept := Source is TMyDBGrid and (GC.X > 0) and (GC.Y > 0);
 end;
 
 procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject;
 
   X, Y: Integer);
 var
 
   DG: TMyDBGrid;
   GC: TGridCoord;
   CurRow: Integer;
 begin
 
   DG := Sender as TMyDBGrid;
   GC := DG.MouseCoord(X, Y);
   with DG.DataSource.DataSet do
   begin
     with (Source as TMyDBGrid).DataSource.DataSet do
       Caption := 'Вы перетащили "' + Fields[SGC.X - 1].AsString + '"';
     DisableControls;
     CurRow := DG.Row;
     MoveBy(GC.Y - CurRow);
     Caption := Caption + ' в "' + Fields[GC.X - 1].AsString + '"';
     MoveBy(CurRow - GC.Y);
     EnableControls;
   end;
 end;
 
 end.
 
 // Форма GridU1
 
 object Form1: TForm1
 
   Left = 200
     Top = 108
     Width = 544
     Height = 437
     Caption = 'Form1'
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     PixelsPerInch = 96
     TextHeight = 13
     object MyDBGrid1: TMyDBGrid
     Left = 8
       Top = 8
       Width = 521
       Height = 193
       DataSource = DataSource1
       Row = 1
       TabOrder = 0
       TitleFont.Charset = DEFAULT_CHARSET
       TitleFont.Color = clWindowText
       TitleFont.Height = -11
       TitleFont.Name = 'MS Sans Serif'
       TitleFont.Style = []
       OnDragDrop = MyDBGrid1DragDrop
       OnDragOver = MyDBGrid1DragOver
       OnMouseDown = MyDBGrid1MouseDown
   end
   object MyDBGrid2: TMyDBGrid
     Left = 7
       Top = 208
       Width = 521
       Height = 193
       DataSource = DataSource2
       Row = 1
       TabOrder = 1
       TitleFont.Charset = DEFAULT_CHARSET
       TitleFont.Color = clWindowText
       TitleFont.Height = -11
       TitleFont.Name = 'MS Sans Serif'
       TitleFont.Style = []
       OnDragDrop = MyDBGrid1DragDrop
       OnDragOver = MyDBGrid1DragOver
       OnMouseDown = MyDBGrid1MouseDown
   end
   object Table1: TTable
     Active = True
       DatabaseName = 'DBDEMOS'
       TableName = 'ORDERS'
       Left = 104
       Top = 48
   end
   object DataSource1: TDataSource
     DataSet = Table1
       Left = 136
       Top = 48
   end
   object Table2: TTable
     Active = True
       DatabaseName = 'DBDEMOS'
       TableName = 'CUSTOMER'
       Left = 104
       Top = 240
   end
   object DataSource2: TDataSource
     DataSet = Table2
       Left = 136
       Top = 240
   end
 end
 




Drag and Drop - как использовать ItemAtPos для получения элемента DirListBox

Просто сохраните результат функции ItematPos в переменной формы, и затем используйте эту переменную в обработчике ListBoxDragDrop. Пример:


 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;
 
 




Как получить список файлов из Проводника

Автор: Nomadic

Развлекался когда-то - вот, осталось:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ShellAPI, Grids, StdCtrls;
 
 type
   TForm1 = class(TForm)
     lb: TListBox;
     Memo1: TMemo;
     Button1: TButton;
     Button2: TButton;
     procedure FormCreate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     procedure WMDropFiles(var M: TMessage); message WM_DROPFILES;
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 var
   CountFiles: integer;
   SizeName: integer;
   cch: integer;
 
 var
   hDrop: integer;
   Point: TPoint;
   lpszFile: PChar;
 
 {$R *.DFM}
 
 procedure TForm1.WMDropFiles(var M: TMessage);
 var
   i: integer;
 begin
   hDrop := M.WParam;
   DragQueryPoint(hDrop, Point);
   CountFiles := DragQueryFile(hDrop, $FFFFFFFF, nil, cch);
   for i := 0 to CountFiles - 1 do
   begin
     SizeName := DragQueryFile(hDrop, i, nil, cch);
     GetMem(lpszFile, SizeName + 1);
     DragQueryFile(hDrop, i, lpszFile, SizeName + 1);
     lb.Items.Add(lpszFile);
     FreeMem(lpszFile, SizeName + 1);
   end;
   DragFinish(hDrop);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   DragAcceptFiles(Handle, True);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   lb.Items.Clear;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   ShellAbout(Handle, 'Anton Saburov', 'APSystems', 0);
 end;
 
 end.
 




Перемещение из DbGrid

Что говорят мыши:
Мышь квакера: «Слушай, кореш, давай ещё разок колесо, я кайф недоловила»
Мышь фотошопера: “Так, вот в эту точку? Сейчас, блин, с тобой косоглазой станешь, да, вижу, вижу, что опять не то выделила? Да иди ты на хр@н, это у тебя руки дрожат!”
Мышь програмиста: “Я, это, посплю децл, ок?”
Мышь любителя DOSа: “It’s no fate”

Кто-нибудь пробовал перемещать что-либо из DbGrid методом перетащи и брось (drag and drop)? Вы сами можете создать потомка TDBGrid (или TDBCustomGrid) и добавить необходимую функциональность для достижения цели.

Скопируйте код из данного "Совета", сохраните его с именем DBGrid.pas и установите компонент в палитру. У Вас появится новый компонент EDBGrid с двумя новыми событиями: OnMouseDown и OnMouseUp. Я не считаю эту информацию конфиденциальной: это ошибка разработчиков Delphi! На самом деле эти два события должны быть частью компонента DBGrid.


 unit Dbgrid;
 
 interface
 
 uses
 
   DBGrids, Controls, Classes;
 
 type
 
   TEDBGrid = class(TDBGrid)
   private
     FOnMouseDown: TMouseEvent;
     FOnMouseUp: TMouseEvent;
   protected
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
       Integer); override;
 
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
       Integer); override;
 
   published
     property OnMouseDown: TMouseEvent read FOnMouseDown write
       FOnMouseDown;
 
     property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
 
   RegisterComponents('Data Controls', [TEDBGrid]);
 end;
 
 procedure TEDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
   X, Y: Integer);
 begin
 
   if Assigned(FOnMouseDown) then
     FOnMouseDown(Self, Button, Shift, X, Y);
   inherited MouseDown(Button, Shift, X, Y);
 end;
 
 procedure TEDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
   Y: Integer);
 begin
 
   if Assigned(FOnMouseUp) then
     FOnMouseUp(Self, Button, Shift, X, Y);
   inherited MouseUp(Button, Shift, X, Y);
 end;
 
 end.
 




Drag and Drop c Windows Explorer

Крошка сын к отцу пришел
И сказала кроха:
Navigator - хорошо,
а Explorer - плохо!


 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs,
 
   ComCtrls;
 
 type
 
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
     procedure FileIsDropped(var Msg: TMessage); message WM_DropFiles;
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 uses
   shellapi;
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
   DragAcceptFiles(Handle, True);
 end;
 
 procedure TForm1.FileIsDropped(var Msg: TMessage);
 var
 
   hDrop: THandle;
   fName: array[0..254] of CHAR;
   NumberOfFiles: INTEGER;
   fCounter: INTEGER;
   Names: string;
 begin
 
   hDrop := Msg.WParam;
   NumberOfFiles := DragQueryFile(hDrop, -1, fName, 254);
   Names := '';
   for fCounter := 1 to NumberOfFiles do
   begin
     DragQueryFile(hDrop, fCounter, fName, 254);
     // Здесь вы получаете один к одному имя вашего файла
 
     Names := Names + #13#10 + fName;
   end;
 
   ShowMessage('Бросаем ' + IntToStr(NumberOfFiles) + ' файла(ов) : ' + Names);
   DragFinish(hDrop);
 end;
 
 end.
 




Drag и Drop c эксплорером

Автор: Aleksey


 {Так можно заставить окно принимать файлы, перетаскиваемые из проводника}
 {ОБЯЗАТЕЛЬНО ПОМЕСТИТЕ В СЕКЦИЮ PRIVATE СТРОКИ
 
 procedure CreateParams(var Params: TCreateParams); override;
 procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
 и не забудьте - ShellAPI поместить в uses}
 
 procedure TForm1.CreateParams(var Params: TCreateParams);
 begin
 
   inherited
     CreateParams(Params);
   {сделаем окно способным принимать файлы}
   Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES;
 end;
 
 procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
 var
 
   aFile: array[0..255] of Char;
   //FilesCount : Integer;
 begin
 
   inherited;
   {так можно узнать сколько файлов перетягивается}
   // FilesCount := DragQueryFile(Message.drop, $FFFFFFFF, nil, 0);
 
   begin
     {здесь можно поставить цикл открытия всех перетаскиваемых файлов
 
     for N := 0 to FilesCount - 1 do DragQueryFile(Message.drop, N, aFile, 256);
     а в данном случае открывается только первый файл в списке}
     DragQueryFile(Message.drop, 0, aFile, 256);
     Memo1.Lines.LoadFromFile(aFile);
   end;
   DragFinish(Message.Drop);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject); {Form1.OnCreate}
 begin
   {сделаем окно неравнодушным к пролетающим над ним файлам}
   DragAcceptFiles(Handle, True);
 end;
 
 




Как перетаскивать (Drag and Drop) выделенный текст между компонентами Memo

Данный способ позволяет не погружаясь глубоко в создание компонент осуществить операцию "drag and drop" выделенного текста.

Создайте новый компонент (TMyMemo), наследовав его от TMemo. И объявите его следующим образом:


 type
   TMyMemo = class(TMemo)
   private
     FLastSelStart : Integer;
     FLastSelLength : Integer;
     procedure WMLButtonDown(var message: TWMLButtonDown); message WM_LBUTTONDOWN;
   published
     property LastSelStart : Integer read FLastSelStart write FLastSelStart;
     property LastSelLength : Integer read FLastSelLength write FLastSelLength;
 end;
 

Добавьте обработчик WMLButtonDown:


 procedure TMyMemo.WMLButtonDown(var message: TWMLButtonDown);
 var
   Ch: Integer;
 begin
   if SelLength > 0 then
   begin
     Ch := LoWord(Perform(EM_CHARFROMPOS, 0,
     MakeLParam(message.XPos, message.YPos)));
     LastSelStart := SelStart;
     LastSelLength := SelLength;
     if (Ch >= SelStart) and (Ch <= SelStart+SelLength-1) then
       BeginDrag(True)
     else
       inherited;
   end
   else
     inherited;
 end;
 

Теперь установите этот компонент в package, создайте новый проект в Delphi и поместите на форму два TMyMemo. Для обоих компонент необходимо создать обработчики событий OnDragOver, которые должны выглядеть следующим образом:


 procedure TForm1.MyMemo1DragOver(Sender, Source: TObject; X, Y: Integer;
 State: TDragState; var Accept: Boolean);
 begin
   Accept := Source is TMyMemo;
 end;
 

Так же для них необходимо сделать обработчики событий OnDragDrop:


 procedure TForm1.MyMemo1DragDrop(Sender, Source: TObject;
 X, Y: Integer);
 var
   Dst, Src : TMyMemo;
   Ch : Integer;
   Temp : string;
 begin
   Dst := Sender as TMyMemo;
   Src := Source as TMyMemo;
   Ch := LoWord(Dst.Perform(EM_CHARFROMPOS,0,MakeLParam(X,Y)));
 
   if (Src = Dst) and (Ch >= Src.LastSelStart) and
   (Ch <= Src.LastSelStart+Src.LastSelLength-1) then
     Exit;
 
   Dst.Text := Copy(Dst.Text,1,Ch)+Src.SelText+
   Copy(Dst.Text,Ch+1,Length(Dst.Text)-Ch);
   Temp := Src.Text;
   Delete(Temp,Src.LastSelStart+1,Src.LastSelLength);
   Src.Text := Temp;
 end;
 

Запустите приложение, поместите в поля memo какой-нибудь текст, и посмотрите что произойдёт, если перетащить текст между полями.




Drag and Drop между двумя компонентами ListBox

Вот пересмотренный OnDragDrop, использующий source (источник) и sender (передатчик) вместо DstList и SrcList. Теперь, если вы установили SrcList и DstList для использования тех же методов OnDragOver и OnDragDrop и создали обработчик события OnDragDrop, то для операции Drag and Drop вы можете использовать оба решения.


 procedure TDualListDlg.DstListDragDrop(Sender, Source: TObject; X,
   Y: Integer);
 var
   droppedOnIndex: integer;
   anItem: integer;
   numberOfItems: integer;
 begin
   if (Sender is TListbox) and (Source is TListBox) then
   begin
     droppedOnIndex := TListBox(Sender).ItemAtPos(Point(X, Y), false);
     numberOfItems := TListBox(Source).SelCount;
     anItem := 0;
     while numberOfItems > 0 do
     begin
       if TListBox(Source).Selected[anItem] = true then
       begin
         TListBox(Sender).Items.Insert(droppedOnIndex,
           TListBox(Source).Items[anItem]);
         TListBox(Source).Items.Delete(anItem);
         TListBox(Source).Update;
         TListBox(Sender).Update;
         numberOfItems := numberOfItems - 1;
       end
       else
         anItem := anItem + 1;
     end;
   end;
 end;
 

Для того, чтобы предотвратить операцию Drag and Drop с одним и тем же компонентом, используйте следующий код в обработчике события OnDragOver:


 if (Sender is TListBox) and (Source is TListBox) then
 begin
   if TListBox(Sender).Name = TListBox(Source).Name then
     Accept := False
   else
     Accept := true;
 end;
 




Перетаскивание элементов управления c рамкой контура

Автор: NEil

...как перетаскивать элементы управления с контурной рамкой по их форме, "приклеенной" к курсору? Решение, найденное вами, работать не будет, поскольку таскаемая рамка не обязательно может находиться в пределах области компонента (а вы отрисовываете ее только на компоненте).

В общих чертах, вы должны рисовать на всей поверхности формы и даже рабочего стола, для чего необходимо сделать растровую КОПИЮ окна или десктопа и рисовать на ней. Вот что нам нужно.

Начните со свеженькой формы. Бросьте на нее компонент Notebook и установите его свойство Align в alClient. Разработайте форму на первой странице компонента Notebook. Создайте вторую страницу в Notebook, поместите туда Paintbox и установите его свойство Align в alClient. Далее добавьте нижеследующие строчки в секцию Private вашей формы:


 Img : TBitmap;
 DragX, DragY, DragW, DragH, XOff, YOff : Integer;
 

В обработчике формы OnCreate:


 Img := TBitmap.Create;
 

В общем, для всех перетаскиваемых компонентов, обработчике события OnMouseDown:


 IF NOT (ssShift IN Shift) THEN Exit;
 Img := GetFormImage;
 Notebook1.PageIndex := 1;
 WITH Sender AS TControl DO
 BEGIN
 DragW := Width;
 DragH := Height;
 XOff:= X;
 YOff := Y;
 BeginDrag(True);
 END;
 

В общем, для всех перетаскиваемых компонентов, обработчике события EndDrag:


 Notebook1.PageIndex := 0;
 WITH Sender AS Tcontrol DO
 BEGIN
 Left := X-Xoff;
 Top := Y-YOff;
 END;
 

Поместите следующую строку в обработчик события OnPaint компонента PaintBox:


 PaintBox1.Canvas.Draw(0, 0, Img);
 

И наконец, если вам еще это не надоело, поместите следующую строчку в обработчик OnDragOver компонента PaintBox:


 IF (X=DragX) AND (Y=DragY) THEN Exit;
 WITH PaintBox1.Canvas DO
 BEGIN
 DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH);
 DragX := X; DragY := Y;
 DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH);
 END;
 

ФУ!! Но это работает! Я не хотел убирать в компонентах возможность перетаскивания их мышью обычным способом, поэтому для включения дополнительной характеристики необходимо при старте держать нажатой клавишу Shift. Попробуйте это!

Я пытаюсь "потаскать" TPanel, используемую в качестве ToolBar и всегда почему-то получаю иконку с перечеркнутым кругом. Я понимаю, что это означает невозможность перетаскивания. К сожалению, в документации я ничего не нашел как решить эту проблему. Я пробовал и ручные, и автоматические настройки (DragMode = dmManual/dmAutomatic - В.О.), но все без толку.

Иногда я вообще не могу "оторвать" TPanel!

Начнем с самого начала. Причина того, что вы получаете курсор "crNoDrop" в том, что под курсором элемент управления не готов принять перетаскиваемый компонент. Чтобы исправить эту ситуацию, дважды щелкните (в Инспекторе Объектов) на событии формы или компонента OnDragOver и установите параметр Accept в, например так:


 procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer;
 State: TDragState; var Accept: Boolean);
 begin
   Accept := true ;
 end;
 

Благодарю за пример создания прямоугольника при перетаскивании. Ваши инструкции помогли мне первое время и я легко интегрировал ваш код в мое приложение. Но если вы не возражаете, я хотел бы получить другой небольшой совет .... есть ли возможность во время операции перетаскивания (PaintBox1DragOver) работать с элементами управления, находящимимя под PainBox с тем, чтобы они также изменяли курсор и также могли бы принимать перетаскиваемый элемент? Когда перетаскиваемый элемент выдает сообщение EndDrag, параметр Target должен быть PaintBox (логически).

Можно как-то определить, с каким конкретно элементом управления, расположенным под PainBox, взаимодействует в данный момент перетаскиваемый элемент (для его акцептования)? Я опять что-то упустил, но я не знаю как это сделать.

Вы можете получить координаты в методе OnDragOver при сравнении BoundsRect с областью компонентов. Например, вы не хотите принимать перетаскиваемый компонент кнопкой, перекрывающей любую другую имеющуюся кнопку. В обработчике OnDragOver напишите примерно следующее:


 FOR N := 0 TO ComponentCount-1 DO
   IF COmponents[N] IS TButton THEN
     IF IntersectRect(DummyRect, TControl(Components[N]).BoundsRect,
       (Bounds(X-XOff, Y-YOff, DragW, DragH)) >0 THEN
         Accept := False;
 

В этом случае курсор будет изменяться на перечеркнутый кружок при пересечении перетаскиваемым элементом границы интересующей вас кнопки. Вы должны сделать аналогичную логику или в обработчике EndDrag или OnDragDrop компонента PainBox.




Drag and Drop с минимизированным приложением

Автор: Neil J. Rubenking

В ситуации, когда ваше приложение минимизировано, необходимо понимать, что окно главной формы НЕ работает. Фактически, если вы проверяете окно главной формы, и обнаруживаете, что оно имеет прежний размер, не удивляйтесь, оно просто невидимо. Иконка минимизированного Delphi-приложения принадлежит объекту Application, чей дескриптор окна - Application.Handle.

Вот некоторый код из моей программы, который с помощью компонента CheckBox проверяет возможность принятия перетаскиваемых файлов минимизированным приложением:


 procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
 {Вызывается только если TApplication НЕ получает drag/drop}
 begin
   RecordDragDrop(Msg.Drop, False); {внутренняя функция}
   Msg.Result := 0;
 end;
 
 procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
 {когда активно, получаем сообщения WM_DROPFILES, посылаемые
 форме ИЛИ минимизированному приложению}
 begin
   if Msg.message = WM_DROPFILES then
   begin
     RecordDragDrop(Msg.wParam, Msg.hWnd = Application.Handle);
     Handled := True;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   DragAcceptFiles(Handle, True);
   DragAcceptFiles(Application.Handle, False);
   Application.OnMessage := nil;
 end;
 

OK? Первоначально вызов DragAcceptFiles работает с дескриптором главной формы...




Рисование без мерцания

Автор: Mike Scott

...вот я и удивляюсь - почему я получаю мерцание, если я вызываю Repaint или Refresh, а не метод OnPaint напрямую? Или это просто "вариация на тему"?

Имеются две фазы обновления окна. В первой фазе, при выводе окна, Windows посылает ему сообщение WM_ERASEBKGND, сообщающее о необходимости стирания фона перед процедурой рисования. Затем посылается сообщение WM_PAINT, служащее сигналом для закрашивания "переднего плана".

Тем не менее, вы можете пропустить первую фазу, которая вызывает мерцание, одним из двух способов: первый способ заключается в том, что вы форсируете обновление сами, с помощью вызова функции Windows API InvalidateRect. На входе он получает дескриптор окна, указатель на закрашиваемую область - передаем NIL, если вы хотите отрисовать всю область окна - и третий параметр, сообщающий о необходимости очистки фона. Вот как раз последний параметр и должен содержать значение FALSE, если вы сами будете в методе Paint полностью отрисовывать всю область:


 InvalidateRect( Handle, NIL, FALSE ) ;
 

Handle должен быть дескриптором формы или элемента управления.

Описав первый способ, я скажу, что существует другое подходящее решение - использовать функциональность VCL. Вы можете указать VCL не стирать фон, добавляя [ csOpaque ] к значению свойства ControlStyle, как показано ниже:


 ControlStyle := ControlStyle + [ csOpaque ] ;
 

Это ограничивает заполнение заднего фона, но вы все еще можете видеть процесс "наполнения" области изображением, т.е. процесс рисования. В этом случае вы можете отделаться от эффекта мельтешения, рисуя на TBitmap и выводя его затем на экран командой CopyRect.

Если вы хотите углубиться в тему дальше, то я отошлю вас к моей статье "Optimizing Display Updates in Delphi" (Оптимизация обновления экрана в Delphi), опубликованной в первом выпуске журнала "Delphi magazine".




Как вывести на Canvas надпись под углом


 {Create a rotated font based on the font object F}
 function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
 var
   LF: TLogFont;
 begin
   FillChar(LF, SizeOf(LF), #0);
   with LF do
   begin
     lfHeight := F.Height;
     lfWidth := 0;
     lfEscapement := Angle*10;
     lfOrientation := 0;
     if fsBold in F.Style then
       lfWeight := FW_BOLD
     else
       lfWeight := FW_NORMAL;
     lfItalic := Byte(fsItalic in F.Style);
     lfUnderline := Byte(fsUnderline in F.Style);
     lfStrikeOut := Byte(fsStrikeOut in F.Style);
     lfCharSet := DEFAULT_CHARSET;
     StrPCopy(lfFaceName, F.name);
     lfQuality := DEFAULT_QUALITY;
     {everything else as default}
     lfOutPrecision := OUT_DEFAULT_PRECIS;
     lfClipPrecision := CLIP_DEFAULT_PRECIS;
     case F.Pitch of
       fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
       fpFixed: lfPitchAndFamily := FIXED_PITCH;
       else
         lfPitchAndFamily := DEFAULT_PITCH;
     end;
   end;
   Result := CreateFontIndirect(LF);
 end;
 
 ...
 
 {create the rotated font}
 if FontAngle <> 0 then
   Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
 ...
 

Вращаются только векторные шрифты.




Программа рисует на форме календарь на 2002 год

Автор: Даниил Карапетян
WEB сайт: http://program.dax.ru

Девушка флиртует с программистом (сисадмином, электронщиком).
Задает вопрос:
- О чем думает компьютер?
Получает ответ:
- Он думает о том дебиле, который написал для него программу о том что нужно думать.

В связи с наступающим Новым годом я решил посвятить выпуск календарю. Ниже приведенная программа рисует на форме календарь на 2002 год. Для каждого месяца сначала выводится его название (используется глобальная переменная LongMonthNames модуля SysUtils), далее выводятся сокращенные названия дней недели (глобальная переменная ShortDayNames модуля SysUtils) и, наконец, выводятся сами числа. Количество дней в месяце записано в массиве months. Чтобы определить, високосный это год или нет, используется функция IsLeapYear.

Скачать необходимые для компиляции файлы проекта можно на program.dax.ru


 const year = 2002; // Год календаря
 
 var months: array [1..12] of byte;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Form1.Caption := 'Календарь на ' + IntToStr(year) + ' год';
   Form1.Color := clWhite;
   // Длины месяцев:
   months[1] := 31;
   months[2] := 28 + ord(IsLeapYear(year));
   months[3] := 31;
   months[4] := 30;
   months[5] := 31;
   months[6] := 30;
   months[7] := 31;
   months[8] := 31;
   months[9] := 30;
   months[10] := 31;
   months[11] := 30;
   months[12] := 31;
 end;
 
 procedure TForm1.FormPaint(Sender: TObject);
 const // Настройки размеров календаря:
   MonthDX = 150;
   MonthDY = 135;
   DayDX = 20;
   DayDY = 15;
   MonthH = 20;
 var
   month, i: integer;
   day: integer;
   s: string[2];
 begin
   with Form1.Canvas do for month := 1 to 12 do begin
     // Вывод названия месяца:
     Font.Name := 'Times';
     Font.Size := 13;
     TextOut((month - 1) mod 3 * MonthDX, (month - 1) div 3 * MonthDY,
       LongMonthNames[month]);
 
     Font.Name := 'Courier';
     Font.Size := 8;
     // Вывод названий дней недели:
     for day := 1 to 7 do
       TextOut((month - 1) mod 3 * MonthDX,
         day mod 7 * DayDY + (month - 1) div 3 * MonthDY + MonthH,
         ShortDayNames[(day + 1) mod 7 + 1]);
 
     // Определение дня недели первого числа месяца:
     day := DayOfWeek(EncodeDate(year, month, 1)) - 2;
     if day < 0 then inc(day, 7);
     // Вывод чисел:
     for i := 1 to months[month] do begin
       str(i: 2, s);
       TextOut(day div 7 * DayDX + (month - 1) mod 3 * MonthDX + DayDX,
         day mod 7 * DayDY + (month - 1) div 3 * MonthDY + MonthH, s);
       inc(day);
     end;
   end;
 end;
 




Выводим цветной текст на форме под любым углом

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   logfont: TLogFont;
   font: Thandle;
   count: integer;
 begin
   LogFont.lfheight := 20;
   logfont.lfwidth := 20;
   logfont.lfweight := 750;
   LogFont.lfEscapement := -200;
   logfont.lfcharset := 1;
   logfont.lfoutprecision := out_tt_precis;
   logfont.lfquality := draft_quality;
   logfont.lfpitchandfamily := FF_Modern;
 
   font := createfontindirect(logfont);
 
   SelectObject(Form1.canvas.handle, font);
 
   SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
   SetBKmode(Form1.canvas.handle, transparent);
 
   for count := 1 to 10 do
   begin
     Canvas.TextOut(Random(form1.width), Random(form1.height), 'Delphi World');
     SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random(255)));
   end;
 
   DeleteObject(font);
 end;
 




Как вывести цветную надпись на StatusBare

Статусбар, это стандартный элемент управления Windows и как все отображает шрифт, заданный в параметре clBtnText, который устанавливается через Панель управления. Поумолчанию этот цвет чёрный, но он может менятся в зависимоти пользовательской темы. StatusBar и связанные с ним панели имеют возможность самостоятельной перерисовки (owner-draw), позволяющей рисовать текст различными цветами. Для этого необходимо в TStatusBar.Panels установить свойство Style в OwnerDraw.


 procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
           Panel: TStatusPanel; const Rect: TRect);
 begin
   if Panel = StatusBar.Panels[0] then
   begin
     StatusBar.Canvas.Font.Color := clRed;
     StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
   end
   else
   begin
     StatusBar.Canvas.Font.Color := clGreen;
     StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
   end;
 end;
 




Нарисовать подсвеченный прямоугольник вокруг контрола под мышкой


 {
   This tip might be useful if you want to program
   a screen capture tool and show a bounding box
   around a control or for a spy tool like winsight to
   highlight a object on the screen.
 }
 var
  hOldWnd :HWND;
 
 procedure FrameWindow(Wnd: HWnd);
 var
   Rect: TRect;
   DC: hDC;
   OldPen, Pen: hPen;
   OldBrush, Brush: hBrush;
   X2, Y2: Integer;
 begin
   { Get the target window's rect and DC }
   GetWindowRect(Wnd, Rect);
   DC := GetWindowDC(Wnd);
   { Set ROP appropriately for highlighting }
   SetROP2(DC, R2_NOT);
   { Select brush and pen }
   Pen := CreatePen(PS_InsideFrame, 4, 0);
   OldPen := SelectObject(DC, Pen);
   Brush := GetStockObject(Null_Brush);
   OldBrush := SelectObject(DC, Brush);
   { Set dimensions of highlight }
   X2 := Rect.Right - Rect.Left;
   Y2 := Rect.Bottom - Rect.Top;
   { Draw highlight box }
   Rectangle(DC, 0, 0, X2, Y2);
   { Clean up }
   SelectObject(DC, OldBrush);
   SelectObject(DC, OldPen);
   ReleaseDC(Wnd, DC);
   { Do NOT delete the brush, because it was a stock object }
   DeleteObject(Pen);
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   hNewWnd: HWnd;
 begin
   hNewWnd := WindowFromPoint(Mouse.CursorPos);
   { To avoid flickering, remove the old frame ONLY if moved to new window }
   if hNewWnd <> hOldWnd then
   begin
     if hOldWnd <> 0 then
       FrameWindow(hOldWnd);
     if hNewWnd <> 0 then
       FrameWindow(hNewWnd);
     hOldWnd := hNewWnd;
   end;
 end;
 




Рисование КРИВЫХ в Delphi

Автор: Dmitry Streblechenko

В: У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте. Пожалуйста используйте для ответа мой адрес электронной почты.

О: Я делал это недавно; мне было лениво разбираться с тем, как рисовать кривые Безье с помощью Win API, поэтому я использовал функцию Polyline().

Примечание: для координатных точек я использовал реальные величины типа floating (я применял некоторый тип виртуального экрана), округляя их до целого.


 PBezierPoint = ^TBezierPoint;
 TBezierPoint = record
   X, Y: double;   // основной узел
   Xl, Yl: double; // левая контрольная точка
   Xr, Yr: double; // правая контрольная точка
 end;
 
 // P1 и P2 - две точки TBezierPoint, расположенные между 0 и 1:
 // когда t=0 X=P1.X, Y=P1.Y; когда t=1 X=P2.X, Y=P2.Y;
 
 procedure BezierValue(P1, P2: TBezierPoint; t: double; var X, Y: double);
 var
   t_sq, t_cb, r1, r2, r3, r4: double;
 begin
   t_sq := t * t;
   t_cb := t * t_sq;
   r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.X;
   r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Xr;
   r3 := (3 * t_sq - 3 * t_cb) * P2.Xl;
   r4 := (t_cb) * P2.X;
   X := r1 + r2 + r3 + r4;
   r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.Y;
   r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Yr;
   r3 := (3 * t_sq - 3 * t_cb) * P2.Yl;
   r4 := (t_cb) * P2.Y;
   Y := r1 + r2 + r3 + r4;
 end;
 

Для рисования кривой Безье разделяем интервал между P1 и P2 на несколько отрезков (их количество влияет на точность воспроизведения кривой, 3 - 4 точки вполне достаточно), затем в цикле создаем массив точек, используем описанную выше процедуру с параметром t от 0 до 1 и рисуем данный массив точек, используя функцию polyline().




Рисование КРИВЫХ в Delphi 7

В: У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте. Пожалуйста используйте для ответа мой адрес электронной почты.

Я решил ответить на этот крик души - причина?: 1. Не первый раз вижу подобный вопрос, 2. Задача настолько избита, что я без труда нашел ответ в своем архиве. (BTW: У меня есть более старые решения, чем это ;-P)

Тем не менее эта технология жива до сих пор и приносит свои плоды:


 (********************************************************************)
 (*                         GRAPHIX TOOLBOX 4.0                      *)
 (*       Copyright (c) 1985, 87 by  Borland International, Inc.     *)
 (********************************************************************)
 unit GShell;
 
 interface
 
 {------------------------------ вырезано --------------------------}
 
 procedure Bezier(A: PlotArray; MaxContrPoints: integer;
   var B: PlotArray; MaxIntPoints: integer);
 
 implementation
 
 {------------------------------ вырезано --------------------------}
 
 procedure Bezier {(A : PlotArray; MaxContrPoints : integer;
 var B : PlotArray; MaxIntPoints : integer)};
 const
   MaxControlPoints = 25;
 type
   CombiArray = array[0..MaxControlPoints] of Float;
 var
   N: integer;
   ContrPoint, IntPoint: integer;
   T, SumX, SumY, Prod, DeltaT, Quot: Float;
   Combi: CombiArray;
 begin
   MaxContrPoints := MaxContrPoints - 1;
   DeltaT := 1.0 / (MaxIntPoints - 1);
   Combi[0] := 1;
   Combi[MaxContrPoints] := 1;
   for N := 0 to MaxContrPoints - 2 do
     Combi[N + 1] := Combi[N] * (MaxContrPoints - N) / (N + 1);
   for IntPoint := 1 to MaxIntPoints do
   begin
     T := (IntPoint - 1) * DeltaT;
     if T <= 0.5 then
     begin
       Prod := 1.0 - T;
       Quot := Prod;
       for N := 1 to MaxContrPoints - 1 do
         Prod := Prod * Quot;
       Quot := T / Quot;
       SumX := A[MaxContrPoints + 1, 1];
       SumY := A[MaxContrPoints + 1, 2];
       for N := MaxContrPoints downto 1 do
       begin
         SumX := Combi[N - 1] * A[N, 1] + Quot * SumX;
         SumY := Combi[N - 1] * A[N, 2] + Quot * SumY;
       end;
     end
     else
     begin
       Prod := T;
       Quot := Prod;
       for N := 1 to MaxContrPoints - 1 do
         Prod := Prod * Quot;
       Quot := (1 - T) / Quot;
       SumX := A[1, 1];
       SumY := A[1, 2];
       for N := 1 to MaxContrPoints do
       begin
         SumX := Combi[N] * A[N + 1, 1] + Quot * SumX;
         SumY := Combi[N] * A[N + 1, 2] + Quot * SumY;
       end;
     end;
     B[IntPoint, 1] := SumX * Prod;
     B[IntPoint, 2] := SumY * Prod;
   end;
 end; { Bezier }
 
 end. { GShell }
 




Как вывести текст с красивым обрезанием если не помещается

Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS.


 procedure TForm1.FormPaint(Sender: TObject);
 var
   r: TRect;
 begin
   r := Rect(20, 20, 110, 70);
   // DT_PATH_ELLIPSIS or DT_WORD_ELLIPSIS or DT_END_ELLIPSIS
   DrawTextEx(Form1.Canvas.Handle, 'Delphi World - это круто!!!',
    25, r, DT_WORD_ELLIPSIS, nil);
 end;
 




Рисовать неактивный текст



 function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
   var Rect: TRect; Format: Word): Integer;
 begin
   SetBkMode(Canvas.Handle, TRANSPARENT);
 
   OffsetRect(Rect, 1, 1);
   Canvas.Font.color := ClbtnHighlight;
   DrawText(Canvas.Handle, Str, Count, Rect, Format);
 
   Canvas.Font.Color := ClbtnShadow;
   OffsetRect(Rect, -1, -1);
   DrawText(Canvas.Handle, Str, Count, Rect, Format);
 end;
 




Хочу прорисовать границу ячейки в Excel



 Cells[i,j].Borders.LineStyle := xlContinuous;
 




Вывод шрифтов в списке в виде самих шрифтов


- Что общего между Биллом Гейтсом и Россией?
- Одинаковый валютный запас


 unit Fontlist;
 
 interface
 
 uses
   Windows, Classes, Graphics, Forms, Controls, StdCtrls;
 
 type
   TForm1 = class(TForm)
     ListBox1: TListBox;
     Label1: TLabel;
     FontLabel: TLabel;
     procedure FormCreate(Sender: TObject);
     procedure ListBox1Click(Sender: TObject);
     procedure DrawItem(Control: TWinControl; index: Integer; Rect: TRect;
       State: TOwnerDrawState);
     procedure ListBox1MeasureItem(Control: TWinControl; index: Integer;
       var Height: Integer);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Listbox1.Items := Screen.Fonts;
 end;
 
 procedure TForm1.ListBox1Click(Sender: TObject);
 begin
   FontLabel.Caption := ListBox1.Items[ListBox1.ItemIndex];
 end;
 
 procedure TForm1.DrawItem(Control: TWinControl; index: Integer;
   Rect: TRect; State: TOwnerDrawState);
 begin
   with ListBox1.Canvas do
   begin
     FillRect(Rect);
     Font.name := ListBox1.Items[index];
     Font.Size := 0; // use font's preferred size
     TextOut(Rect.Left+1, Rect.Top+1, ListBox1.Items[index]);
   end;
 end;
 
 procedure TForm1.ListBox1MeasureItem(Control: TWinControl; index: Integer;
   var Height: Integer);
 begin
   with ListBox1.Canvas do
   begin
     Font.name := Listbox1.Items[index];
     Font.Size := 0; // use font's preferred size
     Height := TextHeight('Wg') + 2; // measure ascenders and descenders
   end;
 end;
 
 end.
 




Рисование графов

...вы могли бы использовать объект TCanvas, чем рисовать самому. В вашем случае сгодится компонент TImage, он имеет bitmap и свойство canvas, на котором очень удобно рисовать.

Пример: (Создайте новую форму, добавьте к ней Image и Button. Добавьте следующий код к обработчику события нажатия кнопки)


 var
   x, l: Integer;
   y, a: Double;
 begin
   Image1.Picture.Bitmap := TBitmap.Create;
   Image1.Picture.Bitmap.Width := Image1.Width;
   Image1.Picture.Bitmap.Height := Image1.Height; {Эти три строчки могут быть
   размещены в обработчике Form1.Create}
   l := Image1.Picture.Bitmap.Width;
   for x := 0 to l do
   begin
     a := (x / l) * 2 * Pi; {Преобразуем позицию по оси X к углу между 0 & 2Pi}
     y := Sin(a); {Ваша функция должна находиться здесь}
     y := y * (Image1.Picture.Bitmap.Height / 2); {Масштабируем по оси Y}
     y := y * -1; {Инвертируем Y, верх экрана это 0 !}
     y := y + (Image1.Picture.Bitmap.Height / 2);
       {Добавляем компенсацию для среднего 0}
     Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
   end;
 end;
 

Я обнаружил, что лучшим решением будет рисование на холсте. Предпочтительно делать это в отдельной процедуре, которая принимает в качестве параметров TCanvas и TRect. Таким способом мы может передать в качестве параметров холст вашего окна и клиентскую область для рисования на экране, и холст принтера и область клиента для ее позиционирования и печати. Чтобы посмотреть доступные для рисования подпрограммы, взгляните на методы холста.




Вывести полупрозрачный текст



 procedure TForm1.FormPaint(Sender: TObject);
 var
   x, y: integer;
   bm: TBitMap;
 begin
   Form1.ClientWidth := 200;
   Form1.ClientHeight := 100;
   randomize;
   for x := 0 to 199 do
     for y := 0 to 99 do
       if random(3) = 1 then
         Form1.Canvas.Pixels[x,y] := clGreen
       else
         Form1.Canvas.Pixels[x,y] := clLime;
   bm := TBitMap.Create;
   bm.Width := 200;
   bm.Height := 100;
   with bm.Canvas do
   begin
     Brush.Color := clGreen;
     FillRect(ClipRect);
     Font.name := 'Arial';
     Font.Size := 50;
     Font.Color := clGray;
     Font.Style := [fsBold];
     TextOut((bm.Width - TextWidth('Text')) div 2,
     (bm.Height - TextHeight('Text')) div 2, 'Text');
   end;
   Form1.Canvas.CopyMode := cmSrcPaint;
   Form1.Canvas.CopyRect(bm.Canvas.ClipRect, bm.Canvas,
   bm.Canvas.ClipRect);
   bm.Destroy;
 end;
 




Как рисовать картинки в пунктах меню (через OwnerDraw)


 unit DN_Win;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, Menus, StdCtrls,
 
 type
   TDNForm = class(TForm)
     MainMenu1: TMainMenu;
     cm_MainExit: TMenuItem;
     procedure FormCreate(Sender: TObject);
     procedure cm_MainExitClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     BM: TBitmap;
     procedure WMDrawItem(var Msg:TWMDrawItem); message wm_DrawItem;
     procedure WMMeasureItem(var Msg:TWMMeasureItem); message wm_MeasureItem;
 end;
 
 var
   DNForm: TDNForm;
 
 implementation
 
 {$R *.DFM}
 
 var
   Comm, yMenu: word;
 
 procedure TDNForm.FormCreate(Sender: TObject);
 begin
   yMenu:=GetSystemMetrics(SM_CYMENU);
   comm:=cm_MainExit.Command;
   ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
 end;
 
 procedure TDNForm.cm_MainExitClick(Sender: TObject);
 begin
   DNForm.Close;
 end;
 
 procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
 begin
   with Msg.MeasureItemStruct^ do
     if ItemID=comm then
     begin
       ItemWidth:=yMenu;
       Itemheight:=yMenu;
     end;
 end;
 
 procedure TDNForm.WMDrawItem(var Msg: TWMDrawItem);
 var
   MemDC:hDC;
   BM:hBitMap;
   mtd:longint;
 begin
   with Msg.DrawItemStruct^ do
   begin
     if ItemID=comm then
     begin
       BM:=LoadBitMap(hInstance,'dver');
       MemDC:=CreateCompatibleDC(hDC);
       SelectObject(MemDC,BM);
       if ItemState=ods_Selected then
         mtd:=NotSrcCopy
       else
         mtd:=SrcCopy;
 
       StretchBlt(hDC,rcItem.left, rcItem.top, yMenu, yMenu, MemDC,
       0, 0, 24, 23, mtd);
       DeleteDC(MemDC);
       DeleteObject(BM);
     end;
   end;
 end;
 
 end.
 




Компонент для отрисовки линий

Автор: William E Murto

Вот компонент, инкапсулирующий функции рисования линий. Он может рисовать горизонтальные, вертикальные и диагональные линии. Вы можете добавить необходимые вам события в секцию *published*.


 unit Lines; {от Bill Murto, CIS 73730,2505}
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms;
 
 type
   TLineOrigin = (loTopLeft, loTopRight);
   TLine = class(TGraphicControl)
   private
     { Private declarations }
     fOrigin: TLineOrigin;
     fPen: TPen;
     procedure SetOrigin(Value: TLineOrigin);
     procedure SetPen(Value: TPen);
   protected
     { Protected declarations }
     procedure Paint; override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     { Published declarations }
     property Origin: TLineOrigin read fOrigin write SetOrigin default
       loTopLeft;
     property Pen: TPen read fPen write SetPen;
     property Height default 33;
     property Width default 33;
     procedure StyleChanged(Sender: TObject);
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TLine]);
 end;
 
 procedure TLine.SetOrigin(Value: TLineOrigin);
 begin
   if fOrigin <> Value then
   begin
     fOrigin := Value;
     Invalidate;
   end;
 end;
 
 procedure TLine.SetPen(Value: TPen);
 begin
   fPen.Assign(Value);
 end;
 
 procedure TLine.StyleChanged(Sender: TObject);
 begin
   Invalidate;
 end;
 
 constructor TLine.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   Height := 33;
   Width := 33;
   fPen := TPen.Create;
   fPen.OnChange := StyleChanged;
   if csOpaque in ControlStyle then
     ControlStyle := ControlStyle - [csOpaque];
 end;
 
 procedure TLine.Paint;
 begin
   with Canvas do
   begin
     Pen := fPen;
     if (Width <= Pen.Width) or (Height <= Pen.Width) then
     begin
       if Width <= Pen.Width then
       begin
         MoveTo(0, 0);
         LineTo(0, Height);
       end;
       if Height <= Pen.Width then
       begin
         MoveTo(0, 0);
         LineTo(Width, 0);
       end;
     end
     else
       case fOrigin of
         loTopLeft:
           begin
             MoveTo(0, 0);
             LineTo(Width, Height);
           end;
         loTopRight:
           begin
             MoveTo(Width, 0);
             LineTo(0, Height);
           end;
       end;
   end;
 end;
 
 destructor TLine.Destroy;
 begin
   fPen.Free;
   inherited Destroy;
 end;
 
 end.
 




Как элемент списка нарисовать своим цветом

Hе забудь установить свойство Style у твоего ListBox в lbOwnerDrawFixed или в lbOwnerDrawVariable.


 procedure TForm1.ListBox1DrawItem(Control: TWinControl; index: Integer;
 Rect: TRect; State: TOwnerDrawState);
 begin
   with ListBox1 do
   begin
     if odSelected in State then
       Canvas.Brush.Color:=clTeal { твой цвет }
     else
       Canvas.Brush.Color:=clWindow;
     Canvas.FillRect(Rect);
     Canvas.TextOut(Rect.Left+2,Rect.Top,Items[index]);
   end;
 end;
 




Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas)


 // Пример рисует две горизонтальные линии на экране используя TDesktopCanvas.
 program TrinitronTraining;
 
 uses
   Messages, Windows, Graphics, Forms;
 
 type
   TDesktopCanvas = class(TCanvas)
   private
     DC : hDC;
     function GetWidth:Integer;
     function GetHeight:Integer;
   public
     constructor Create;
     destructor Destroy; override;
   published
     property Width: Integer read GetWidth;
     property Height: Integer read GetHeight;
 end;
 
 { Объект TDesktopCanvas }
 function TDesktopCanvas.GetWidth:Integer;
 begin
   Result:=GetDeviceCaps(Handle,HORZRES);
 end;
 
 function TDesktopCanvas.GetHeight:Integer;
 begin
   Result:=GetDeviceCaps(Handle,VERTRES);
 end;
 
 constructor TDesktopCanvas.Create;
 begin
   inherited Create;
   DC := GetDC(0);
   Handle := DC;
 end;
 
 destructor TDesktopCanvas.Destroy;
 begin
   Handle := 0;
   ReleaseDC(0, DC);
   inherited Destroy;
 end;
 
 
 const
   YCount = 2;
 
 var
   desktop : TDesktopCanvas;
   dx,dy : Integer;
   i : Integer;
   F : array[1..YCount] of TForm;
 
 function CreateLine(Y : Integer) : TForm;
 begin
   Result := TForm.Create(Application);
   with Result do begin
     Left := 0;
     Top := y;
     Width := dx;
     Height := 1;
     BorderStyle := bsNone;
     FormStyle := fsStayOnTop;
     Visible := True;
   end;
 end;
 
 procedure ProcessMessage;
 var
   Msg : TMsg;
 begin
   if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
     if Msg.message = WM_QUIT then
       Application.Terminate;
 end;
 
 begin
   desktop := TDesktopCanvas.Create;
   try
     dx := desktop.Width;
     dy := desktop.Height div (YCount+1);
   finally
     desktop.free;
   end;
   for i:=1 to YCount do
     F[i]:=CreateLine(i*dy);
   Application.NormalizeTopMosts;
   ShowWindow(Application.Handle, SW_Hide);
 
   for i:=1 to YCount do
     SetWindowPos(F[i].Handle, HWND_TOPMOST, 0,0,0,0, SWP_NOACTIVATE+SWP_NOMOVE+SWP_NOSIZE);
 
   {
   следующие строки используются для того, чтобы не останавливаться
   repeat
   ProcessMessage;
   until false;
   }
   Sleep(15000);
 
   for i:=1 to YCount do
     F[i].Free;
 end.
 




Можно ли рисовать на рамке формы

Обрабатывайте событие WM_NCPAINT. В примере рамка обводится красной линией толщиной в 1 пиксель.

В частных объявлениях объявляем процедуру обработки сообщение WMNCPaint:


 private
   { Private declarations }
   procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
 

В области реализации [после слова implemantation] пишем:


 procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
 var
   dc: hDc;
   Pen: hPen;
   OldPen: hPen;
   OldBrush: hBrush;
 begin
   inherited;
   dc := GetWindowDC(Handle);
   msg.Result := 1;
   Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
   OldPen := SelectObject(dc, Pen);
   OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
   Rectangle(dc, 0,0, Form1.Width, Form1.Height);
   SelectObject(dc, OldBrush);
   SelectObject(dc, OldPen);
   DeleteObject(Pen);
   ReleaseDC(Handle, Canvas.Handle);
 end;
 




Рисование на минимизированной иконке

Автор: Nick Hodges (Monterey, CA)

Есть ли у кого пример рисования на иконке минимизированного приложения с помощью Delphi?

Когда Delphi-приложение минимизировано, иконка, которая вы видите - реальное главное окно, объект TApplication, поэтому вам необходимо использовать переменную Application. Таким образом, чтобы удостовериться что приложение минимизировано, вызовите IsIconic(Application.Handle). Если функция возвратит True, значит так оно и есть. Для рисования на иконке создайте обработчик события Application.OnMessage. Здесь вы можете проверять наличие сообщения WM_Paint и при его нахождении отрисовывать иконку. Это должно выглядеть приблизительно так:


 ...
 { private declarations }
   procedure AppOnMessage(var Msg: TMsg; var Handled: Boolean);
 ...
 
 procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
 var
   DC: hDC;
   PS: TPaintStuff;
 begin
   if (Msg.Message = WM_PAINT) and IsIconic(Application.Handle) then
   begin
     DC := BeginPaint(Application.Handle, PS);
     ...осуществляем отрисовку с помощью вызовов Windows GDI...
 
     EndPaint(Application.Handle, PS);
     Handled := True;
   end;
 end;
 
 procedure TForm1.OnCreate(Sender: TObject);
 begin
   Application.OnMessage := AppOnMessage;
 end;
 

Код создан на основе алгоритма Neil Rubenking.




Как рисовать на органе управления, например, на TPanel

У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas. Грубо говоря, это аналог TDC из OWL. Те операции, которые нельзя выполнить с помощью методов TCanvas, можно выполнить с помощью WinAPI. Для этого у обьектов класса TCanvas имеется свойство Handle - это и есть Хэндл Дисплейного Контекста ОС Windows (HDC), который необходим графическим функциям WinAPI. Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.


 { Example. We recommend You to create this component
 through Component Wizard. In Delphi 1 it can be found
 as 'File|New Component...', and can be found as
 'Component|New Component...' in Delphi 2 or above. }
 type
   TcPanel = class(TPanel)
 public
   property Canvas;
 end;
 

А если у объекта нет свойства Canvas (у TDBEdit, вpоде-бы нет), по кpайней меpе в D3 можно использовать класс TControlCanvas. Пpимеpное использование:


 var
   cc: TControlCanvas;
 ...
   cc := TControlCanvas.Create;
   cc.Control := youControl;
 ...
 

и далее как обычно можно использовать методы Canvas.




Вывод текста на родительском элементе управления

Свойство Canvas в TCustomControl существует, но оно защищено. Поскольку свойство canvas инкапсулирует windows HDC (Canvas.Handle), вы можете создавать объект TCanvas и назначать через свойство Handle контекст устройства элементу управления, на котором вы хотите рисовать.

Для примера:


 procedure AControl.DrawLabel(ACaption: TCaption);
 var
   ACanvas: TCanvas;
   DC: HDC;
 begin
   ACanvas := TCanvas.Create;
   try
     WindowHandle := parent.Handle;
     DC := GetDeviceContext(WindowHandle);
     ACanvas.Handle := DC;
     with ACanvas do
     begin
     end;
     ACanvas.Handle := 0;
     ReleaseDC(WindowHandle, DC);
   finally
     ACanvas.free;
   end;
 end;
 




Как рисовать на экране

Обладая такими способностями, вы сможете, например, разлиновать поверхность экрана как в тетради в клеточку, выводить пугающие пользователя надписи и даже создать эффект окаменение экрана, если, конечно, разработаете алгоритм выполнения данной задачи.

Я покажу как рисовать на экране на примере разлиновки:

Сначала объявите глобальную переменную


 Scr: TCanvas;
 

Затем по событию OnCreate() для формы напишите такой код:


 Scr := TCanvas.Create;
 Scr.Handle := GetDC(HWND_DESKTOP);
 

По событию OnDestroy() такой:


 Scr.Free;
 

Обработчик события по нажатию на кнопку пусть выглядит так:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: integer;
 begin
   i := 0;
   while i < 1024 do
   begin
     with Scr do
     begin
       MoveTo(i, 0);
       LineTo(i, 768);
       i := i + 10;
     end;
   end;
   i := 0;
   while i < 768 do
   begin
     with Scr do
     begin
       MoveTo(0, i);
       LineTo(1024, i);
       i := i + 10;
     end;
   end;
   Button1.Refresh;
 end;
 




Как нарисовать что-нибудь на TMemo

Опять-таки... составляю тут резюме... первым делом, есессно, натыкаюсь на пункт "ФИО" и пытаюсь ввести свой ник... затем все же заставляю себя заполнить данный пункт, несколько ошалело глядя на собственные _реальные_ фамилию и имя... настолько привыкнув за время пребывания в Сети к осторожности скрытности, что в первый момент жутко ругаю себя, что что ж это я так уже себя не контролирую... При достижении пунта "e-mail" и не менее послушном заполнении ужас просто-таки начинает раздирать - как - я - оставляю свое мыло... недремлющий спаммер... через некоторое время все-таки приходит осознание ситуации и понимание необходимости ввести свой пол и возраст, а также телефон :))), ...который чудом не был заменен номером Аськи...

Для рисования на поверхности TMemo необходимо создать создать собственный компонент, наследованный от TMemo и переопределить в нём рисование. Примерно так:


 type
   TMyMemo = class(TMemo)
   protected
     procedure WMPaint(var message: TWMPaint); message WM_PAINT;
 end;
 

А теперь добавьте реализацию этой процедуры:


 procedure TMyMemo.WMPaint(var message: TWMPaint);
 var
   MCanvas: TControlCanvas;
   DrawBounds : TRect;
 begin
   inherited;
   MCanvas:=TControlCanvas.Create;
   // Работаем с временной записью TRect.
   DrawBounds := ClientRect;
   try
     MCanvas.Control:=Self;
     with MCanvas do
     begin
       Brush.Color := clBtnFace;
       FrameRect( DrawBounds );
       InflateRect( DrawBounds, -1, -1);
       FrameRect( DrawBounds );
       FillRect ( DrawBounds );
       MoveTo ( 33, 0 );
       Brush.Color := clWhite;
       LineTo ( 33, ClientHeight );
       PaintImages;
     end;
   finally
     MCanvas.Free;
   end;
 end;
 

Процедура PaintImages рисует картинки на канвасе Memo.


 procedure TMyMemo.PaintImages;
 var
   MCanvas: TControlCanvas;
   DrawBounds : TRect;
   i, j : Integer;
   OriginalRegion : HRGN;
   ControlDC : HDC;
 begin
   MCanvas:=TControlCanvas.Create;
   // Работаем с временной записью TRect.
   DrawBounds := ClientRect;
   try
     MCanvas.Control:=Self;
     ControlDC := GetDC(Handle);
     MCanvas.Draw(0, 1, Application.Icon);
   finally
     MCanvas.Free;
   end;
 end;
 

Теперь мы имеем собственноручно нарисованный memo.




Рисование прямоугольника на изображении

Билл Гейтс помер и попал на небеса, а там вместо апостола Петра машину с Windows поставили. И, значит, в окне на мониторе надпись: "Уважаемый Билл, за Ваши заслуги перед человечеством мы разрешаем Вам самому выбрать, куда Вы попадете - в ад или в рай Выбирайте - в ад или в рай?". И ниже три кнопки с вариантами ответов: "Yes, No,Cancel"...

Я хочу узнать как можно позволить пользователю нарисовать на изображении прямоугольник, чтобы в дальнейшем выбранную часть, к примеру, масштабировать. Я хотел бы достичь такого же эффекта, как в других программах, где с помощью мышки можно при нажатой левой кнопке мыши выделить какую-либо область изображения.

Создайте логическое поле ImageMouse, для рисования прямоугольника ImageRect используйте метод холста drawfocusrect. Следующий код работает одинаково для левой и правой кнопок мыши:


 procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   ImageMouse := True;
   ImageRect.Left := X;
   ImageRect.Top := Y;
   ImageRect.Right := X;
   ImageRect.Bottom := Y;
   Image1.Canvas.DrawFocusRect(ImageRect);
 end;
 
 procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
   Integer);
 var
   NewRect: tRect;
 begin
   if ImageMouse then
     if (X > ImageRect.Left) and (Y > ImageRect.Top) then
     begin
       {Восстанавливаем фон}
       Image1.Canvas.DrawFocusRect(ImageRect);
       {Меняем прямоугольник}
       ImageRect.Right := X;
       ImageRect.Bottom := Y;
       {Рисуем прямоугольник фокуса}
       Image1.Canvas.DrawFocusRect(ImageRect);
     end;
 end;
 
 procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   {Восстанавливаем фон}
   if ImageMouse then
   begin
     ImageRect.Right := X;
     ImageRect.Bottom := Y;
     Image1.Canvas.DrawFocusRect(ImageRect);
     ImageMouse := False;
     Image1.Canvas.CopyRect(Image1.Canvas.ClipRect,
       Image1.Canvas, ImageRect)
   end;
 end;
 




Как отобразить выбранную строку DBGrid различными цветами

Разговаривают два программиста:
- А что он собой представляет?
- Очень общительный и доброжелательный, даже не скажешь, что программист.

Если Вы хотите раскрасить выбранную строку DBGrid, но не хотите использовать опцию dgRowSelect, так как хотели бы редактировать данные, то можно воспользоваться следующей технологией в событии DBGrid.OnDrawColumnCell:


 type
   TCustomDBGridCracker = class(TCustomDBGrid);
 
 procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
   const Rect: TRect; DataCol: Integer; Column: TColumn;
   State: TGridDrawState);
 begin
   with Cracker(Sender) do
     if DataLink.ActiveRecord = Row - 1 then
       Canvas.Brush.Color := clRed
     else
       Canvas.Brush.Color := clWhite;
   DefaultDrawColumnCell(Rect, DataCol, Column, State);
 end;
 




Как быстро нарисовать тень в заданном регионе



 procedure TForm2.DrawShadows(WDepth, HDepth : Integer);
 var
   Dst, RgnBox: TRect;
   hOldDC: HDC;
   OffScreen: TBitmap;
   Pattern: TBitmap;
   Bits: array [0..7] of WORD;
 begin
   Bits[0]:=$0055;
   Bits[1]:=$00aa;
   Bits[2]:=$0055;
   Bits[3]:=$00aa;
   Bits[4]:=$0055;
   Bits[5]:=$00aa;
   Bits[6]:=$0055;
   Bits[7]:=$00aa;
 
   hOldDC:=Canvas.Handle;
   Canvas.Handle:=GetWindowDC(Form1.Handle);
 
   OffsetRgn(ShadeRgn, WDepth, HDepth);
   GetRgnBox(ShadeRgn, RgnBox);
 
   Pattern:=TBitmap.Create;
   Pattern.ReleaseHandle;
   Pattern.Handle:=CreateBitmap(8, 8, 1, 1, @(Bits[0]));
   Canvas.Brush.Bitmap:=Pattern;
 
   OffScreen:=TBitmap.Create;
   OffScreen.Width:=RgnBox.Right-RgnBox.Left;
   OffScreen.Height:=RgnBox.Bottom-RgnBox.Top;
   Dst:=Rect(0, 0, OffScreen.Width, OffScreen.Height);
 
   OffsetRgn(ShadeRgn, 0, -RgnBox.Top);
   FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);
   OffsetRgn(ShadeRgn, 0, RgnBox.Top);
 
   // BitBlt работает быстрее CopyRect
   BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height,
   Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND);
 
   Canvas.Brush.Color:=clBlack;
   FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);
 
   BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width,
   OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT);
 
   OffScreen.Free;
   Pattern.Free;
   OffsetRgn(ShadeRgn, -WDepth, -HDepth);
 
   ReleaseDC(Form1.Handle, Canvas.Handle);
   Canvas.Handle:=hOldDC;
 end;
 

Комментарии:

Функция рисует тень сложной формы на форме Form2 (извиняюсь за стиль). Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API.




Рисование текста в DBGrid

Решение всех жизненных проблем находится на интернете. Надо только уметь хорошо искать.

Следующий метод может быть использован в качестве обработчика события TDBGrid.OnDrawDataCell. Он демонстрирует способ рисования текста в колонке цветом, отличным от цвета текста в остальной части табличной сетки.


 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect:
   TRect; Field: TField; State: TGridDrawState);
   { ПРИМЕЧАНИЕ: Свойство DefaultDrawing компонента
   Grid должно быть установлено в False }
 begin
   { если имя поля - "NAME" }
   if Field.FieldName = 'NAME' then
     { изменяем цвет шрифта на красный }
     (Sender as TDBGrid).Canvas.Font.Color := clRed;
   { выводим текст в табличной сетке }
   (Sender as TDBGrid).Canvas.TextRect(Rect, Rect.Left + 2,
     Rect.Top + 2, Field.AsString);
 end;
 




Рисование текста в DBGrid 2

Автор: Eryk

Для отображения таблицы я использую DBGrid. Для некоторых полей я хочу применить другой шрифт, размер, цвет...

Вам необходимо обработать событие OnDrawDataCell, например так:


 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const
   Rect: TRect; Field: TField; State: TGridDrawState);
 begin
   if Field.FieldName = 'SERIAL' then
     if (Field as TStringField).Value = 'НЕИЗВЕСТНО' then
       with (Sender as TDBGrid).Canvas do
       begin
         Brush.Color := clRed;
         Font.Style := [fsItalic];
         Font.Color := clAqua;
         FillRect(Rect);
         TextOut(Rect.Left, Rect.Top, Field.AsString);
       end;
 end;
 

....BTW, выключите DefaultDrawing.




Вывод текста на канве картинки

При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему?

Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.


 var
   bm : TBitmap;
   OldBkMode : integer;
 begin
   bm := TBitmap.Create;
   bm.Width := BitBtn1.Glyph.Width;
   bm.Height := BitBtn1.Glyph.Height;
   bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
   OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
   bm.Canvas.TextOut(0, 0, 'The Caption');
   SetBkMode(bm.Canvas.Handle, OldBkMode);
   BitBtn1.Glyph.Assign(bm);
 end;
 




Как нарисовать Bitmap с прозрачностью


 procedure DrawTransparentBmp(Cnv: TCanvas; x,y: Integer; Bmp: TBitmap; clTransparent: TColor);
 var
   bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
   oldcol: Longint;
 begin
   try
     bmpAND := TBitmap.Create;
     bmpAND.Width := Bmp.Width;
     bmpAND.Height := Bmp.Height;
     bmpAND.Monochrome := True;
     oldcol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent));
     BitBlt(bmpAND.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
     SetBkColor(Bmp.Canvas.Handle, oldcol);
 
     bmpINVAND := TBitmap.Create;
     bmpINVAND.Width := Bmp.Width;
     bmpINVAND.Height := Bmp.Height;
     bmpINVAND.Monochrome := True;
     BitBlt(bmpINVAND.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, NOTSRCCOPY);
 
     bmpXOR := TBitmap.Create;
     bmpXOR.Width := Bmp.Width;
     bmpXOR.Height := Bmp.Height;
     BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
     BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpINVAND.Canvas.Handle, 0, 0, SRCAND);
 
     bmpTarget := TBitmap.Create;
     bmpTarget.Width := Bmp.Width;
     bmpTarget.Height := Bmp.Height;
     BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Cnv.Handle, x, y, SRCCOPY);
     BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, SRCAND);
     BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpXOR.Canvas.Handle, 0, 0, SRCINVERT);
     BitBlt(Cnv.Handle, x, y, Bmp.Width, Bmp.Height, bmpTarget.Canvas.Handle, 0, 0, SRCCOPY);
   finally
     bmpXOR.Free;
     bmpAND.Free;
     bmpINVAND.Free;
     bmpTarget.Free;
   end;
 end;
 




Как с помощью функции Textout вывести на канве прозрачный текст

Вот небольшой участок кода из купленного мною CD-ROM "How To Book". Файл с именем "HowUtils.Pas" содержит реализацию алгоритма "потухания" текста и обратного ему эффекта на холсте, откуда вы можете почерпнуть необходимую вам информацию.


 function TFadeEffect.FadeInText(Target: TCanvas; X, Y: integer; FText: string):
   TRect;
 var
   Pic: TBitmap;
   W, H: integer;
   PicRect, TarRect: TRect;
 begin
   Pic := TBitmap.Create;
   Pic.Canvas.Font := Target.Font;
   W := Pic.Canvas.TextWidth(FText);
   H := Pic.Canvas.TextHeight(FText);
   Pic.Width := W;
   Pic.Height := H;
   PicRect := Rect(0, 0, W, H);
   TarRect := Rect(X, Y, X + W, Y + H);
   Pic.Canvas.CopyRect(PicRect, Target, TarRect);
   SetBkMode(Pic.Canvas.Handle, Transparent);
   Pic.Canvas.TextOut(0, 0, FText);
   FadeInto(Target, X, Y, Pic);
   Pic.Free;
   FadeInText := TarRect;
 end;
 
 procedure TFadeEffect.FadeOutText(Target: TCanvas; TarRect: TRect; Orig:
   TBitmap);
 var
   Pic: TBitmap;
   PicRect: TRect;
 begin
   Pic := TBitmap.Create;
   Pic.Width := TarRect.Right - TarRect.Left;
   Pic.Height := TarRect.Bottom - TarRect.Top;
   PicRect := Rect(0, 0, Pic.Width, Pic.Height);
   Pic.Canvas.CopyRect(PicRect, Orig.Canvas, TarRect);
   FadeInto(Target, TarRect.Left, TarRect.Top, Pic);
   Pic.Free;
 end;
 




Дубликат Paradox или dBase записи

Автор: Eryk Bottomley

Встречаются два администратора: (1)-Юникса, (2)-Винды
(1) - Вот, на работе скукотища - делать совсем нечего. Hикто не жалуется...
(2) - А у меня всегда работа есть - каждые полчаса систему переставляю.
(1) - Hу ни фига себе - ну ты крут. Как ты добился, чтобы винда 30 минут работала???
(2) - Да нет, это она 30 минут переставляется...

Существует ли какое-либо простое решение для Delphi-приложения, позволяющее прочесть запись из первого поля таблицы Paradox (первичный ключ) и потом обратно добавить ее в таблицу в виде новой записи?

Вот одно "кривое" решение:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   p : CURProps;
 begin
   Table2.Insert;
   DbiGetCursorProps(Table1.Handle,p);
   Move(Table1.ActiveBuffer^,Table2.ActiveBuffer^,p.iRecBufSize);
   Table2.FieldByName('ID').AsInteger := Table1.FieldByName('ID').AsInteger + 1;
   Table2.Post;
 end;
 

...это работает на том "основании", что как Table1, так и Table2 ссылаются на один и тот же табличный файл. Вы могли бы осуществить это и с единственным TTable, если сохраните содержание в активном буфере (ActiveBuffer).




Ошибка дублирования идентификатора ресурса

Повесился как-то программист, и в кармане у него нашли записку: Critical error. System halted.

У вас есть исходный код VCL? Если да, то в этом случае ее можно всю перекомпилировать, добавив каталог к вашему библиотечному пути (Library path) в опциях среды (Environment Options | Library). Я думаю это нужно сделать, чтобы отделаться от этой ошибки. При другом способе необходимо вычислить вызывающую проблему директиву $R, временно удалить ее, и осуществить перекомпиляцию. Временно выключить директиву $R можно добавлением '.' перед $ (но это не единственный путь выключить ее).

Вероятно, вы сабкласситесь от VCL. Убедитесь в том, что идентификатор ресурса для вашей иконки уникальный. Просто загрузите ее в любой редактор ресурсов, и измените ее номер. После этого вы должны пересобрать вашу библиотеку.




Создание новой таблицы на основе структуры другой таблицы

На ум сразу приходит операция присваивания значения свойству (стоящему с левой стороны от ':='), при которой Delphi в своих недрах вызывает метод 'write' и передает ему в виде единственного параметра все то, что находится в правой части выражения. Если свойство не имеет метода write, оно предназначено только для чтения. Вот определение свойства FieldDefs объекта TDataSet в файле DB.PAS:


 property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;
 

Как вы можете видеть, у него есть метод write. Следовательно, код:


 Destination.FieldDefs := Source.FieldDefs;
 

в действительности делает такую операцию:


 Destination.SetFieldDefs(Source.FieldDefs);
 

(за исключением того, что вы не можете использовать эту строку, поскольку SetFieldDefs определен в секции Private.)

Вот определение свойства IndexDefs объекта TTable в файле DBTABLES.PAS file:


 property IndexDefs: TIndexDefs read FIndexDefs;
 

В этом случае метод write отсутствует, поэтому свойство имеет атрибут только для чтения. Тем не менее, для самого объекта TIndexDefs существует метод Assign. Следовательно, следующий код должен работать:


 Source.IndexDefs.Update;
 Destination.IndexDefs.Assign(Source.IndexDefs);
 

Перед вызовом Assign для Source.IndexDefs вызывайте метод Update, чтобы быть уверенным в том, что вы получите то, что хотите.

Метод SetFieldDefs является процедурой с одной строкой кода, в которой вызывается метод FieldDefs Assign.

Также можно проверить, определен ли реально индекс, и, если нет, то при вызове IndexDefs.Assign вы можете получить исключение типа "List Index Out Of Bounds" (или что-то типа этого). Например, так:


 if Source.IndexDefs.Count > 0 then...
 

Вам нужно будет это сделать, поскольку метод TIndexDefs.Assign не проверяет это перед копированием индекс-информации. Также вам нет необходимости вызывать Clear до работы с IndexDefs, поскольку метод Assign сделает это и без вашего участия.




Дублируем TTable со всеми индексами


 type
   TForm1 = class(TForm)
     tbSource: TTable;
     tbTarget: TTable;
   end;
 
 implementation
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   tbSource.TableName := 'Source.DB';  // The name of your tables which you want to copy from 
   tbTarget.TableName := 'Target.DB';  // The name of your tables which you will to copy to 
                                       // You Can  set the tbSource.DataBaseName to an existing path/Alias 
                                       //    where you store your DB 
                                       // You Can  set the tbTarget.DataBaseName to an existing path/Alias 
                                       //    where you want to store the duplicate DB 
   tbSource.StoreDefs := True;
   tbTarget.StoreDefs := True;
   tbSource.FieldDefs.Update;
   tbSource.IndexDefs.Update;
   tbTarget.FieldDefs := tbSource.FieldDefs;
   tbTarget.IndexDefs := tbSource.IndexDefs;
   tbTarget.CreateTable;
 end;
 




Динамическое добавление пунктов меню

Честно говоря, я так и не понял к чему вы хотите добавлять новые пункты меню - к верхнему уровню или в качестве подменю. На всякий случай я публикую оба метода. Выбирайте любой.

Новый элемент верхнего уровня:


 procedure tform1.addmainitem(s: string);
 var
   newitem: Tmenuitem;
 begin
   newitem := tmenuitem.create(Mainmenu1);
   newitem.caption := s;
   {если вы хотите определить событие onclick
   newitem.onclick:=Dynamenuclick; }
   {добавляем это к верхнему уровню меню}
   mainmenu1.items.insert(mainmenu1.items.count, newitem);
   removemenu1.enabled := true;
   addmenuitem1.enabled := true;
 end;
 

Создание подменю:


 procedure tform1.addsubitem(s: string; to : integer);
 var
   newitem, toitem: Tmenuitem;
 begin
   {to = верхний уровень меню для нового пункта}
   toitem := mainmenu1.items[to ];
   newitem := tmenuitem.create(toitem);
   newitem.caption := s;
   {если вы хотите определить событие onclick
   newitem.onclick:=Dynamenuclick; }
   toitem.onclick := nil;
   toitem.insert(toitem.count, newitem);
   removemenuitem1.enabled := true;
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS