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

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июля!


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

БОЛЬШОЙ FAQ ПО DELPHI



Записать в реестр данные бинарного вида

Четыре стадии обнищания программиста:
4. Кормить кошку kitekat-ом.
3. Нет денег на хлеб.
2. Нет денег на женщин.
1. Нет денег на апгрейд.


 var
   Reg: TRegistry;
   buf : array [0..4] of byte;
   i: Integer;
 begin
   Reg := TRegistry.Create;
   try
     Reg.RootKey := HKEY_CURRENT_USER;
     if Reg.OpenKey('\Software', True) then begin
       for i:=1 to 4 do buf[i]:=0;
       buf[0]:=1;
       Reg.WriteBinnaryData('Value', buf, sizeof(buf));
       Reg.CloseKey;
     end;
   finally
     Reg.Free;
     inherited;
   end;
   {...}
 end;
 




Регистрация классов



 unit InfoForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
   Dbctrls, Dbgrids, Dblookup, Dbtables, Ddeman, Dialogs,
   Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
   Olectrls, Outline, Tabnotbk, Tabs;
 
 type
   TForm1 = class(TForm)
     ListBox1: TListBox;
     Label1: TLabel;
     Edit1: TEdit;
     Label2: TLabel;
     ButtonShow: TButton;
     Label3: TLabel;
     Panel1: TPanel;
     ComboBox1: TComboBox;
     procedure FormCreate(Sender: TObject);
     procedure ButtonShowClick(Sender: TObject);
     procedure ComboBox1DblClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 type
   TClassArray = array [1..140] of TPersistentClass;
 
 const
   ClassArray: TClassArray = (
     TBitmap, TGraphic, TOutlineNode, TGraphicsObject,
     TBrush, THeaderSection, TParams, TCanvas,
     THeaderSections, TPen, TIcon, TPicture,
     TIconOptions, TCollection, TCollectionItem, TColumn,
     TStatusPanel, TColumnTitle, TStatusPanels, TClipboard,
     TControlScrollBar, TListColumn, TStringList, TListItem,
     TStrings, TListItems, TMetafile, TMetafileCanvas,
     TTreeNode, TFont, TParaAttributes, TTreeNodes,
     TApplication, TDDEServerItem, TPanel, TAutoIncField,
     TDirectoryListBox, TPopupMenu, TBatchMove, TDrawGrid,
     TPrintDialog, TBCDField, TDriveComboBox, TPrinterSetupDialog,
     TBevel, TEdit, TProgressBar, TBitBtn,
     TField, TQuery, TBlobField, TFileListBox,
     TRadioButton, TBooleanField, TFilterComboBox, TRadioGroup,
     TButton, TFindDialog, TReplaceDialog, TBytesField,
     TFloatField, TCheckBox, TFontDialog,
     TRichEdit, TColorDialog, TForm, TSaveDialog,
     TComboBox, TGraphicField, TScreen, TCurrencyField,
     TGroupBox, TScrollBar, TDatabase, THeader,
     TScrollBox, TDataSource, THeaderControl, TSession,
     TDateField, THotKey, TShape, TDateTimeField,
     TImage, TSmallIntField, TDBCheckBox, TImageList,
     TSpeedButton, TDBComboBox, TIntegerField, TStatusBar,
     TDBCtrlGrid, TLabel, TStoredProc, TDBEdit,
     TListBox, TStringField, TDBGrid, TListView,
     TStringGrid, TDBImage, TMainMenu, TTabbedNotebook,
     TDBListBox, TMaskEdit, TTabControl, TDBLookupCombo,
     TMediaPlayer, TTable, TMemoField, TDBLookupComboBox,
     TMemo, TTabSet, TDBLookupList, TTabSheet,
     TDBLookupListBox, TMenuItem, TTimeField, TDBMemo,
     TNotebook, TTable, TDBNavigator, TOleContainer,
     TTimer, TDBRadioGroup, TOpenDialog, TTrackBar,
     TDBText, TOutline, TTreeView, TDDEClientConv,
     TOutline, TUpdateSQL, TDDEClientItem, TPageControl,
     TUpDown, TDDEServerConv, TPaintBox, TVarBytesField,
     TWordField);
 
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   I: Integer;
 begin
   // register all of the classes
   RegisterClasses (ClassArray);
   // copy class names to the listbox
   for I := Low (ClassArray) to High (ClassArray) do
     ComboBox1.Items.Add (ClassArray [I].ClassName);
 end;
 
 procedure TForm1.ButtonShowClick(Sender: TObject);
 var
   MyClass: TClass;
 begin
   MyClass := GetClass (ComboBox1.Text);
   if MyClass = nil then
     Beep
   else
   begin
     Edit1.Text := Format ('Name: %s - Size: %d bytes',
       [MyClass.ClassName, MyClass.InstanceSize]);
     with Listbox1.Items do
     begin
       Clear;
       while MyClass.ClassParent <> nil do
       begin
         MyClass := MyClass.ClassParent;
         Add (MyClass.ClassName);
       end; // while
     end; // with
   end; // else
 end;
 
 procedure TForm1.ComboBox1DblClick(Sender: TObject);
 begin
   ButtonShowClick (Sender);
 end;
 
 end.

Загрузить весь проект




Зарегистрировать или удалить OCX, ActiveX

Приходит жена программиста с работы, а муж весь расстроенный.
- Миша, что случилось?
- Мама умерла... да погоди радоваться, не моя - у компа..


 {1.}
 
 type
   TDllRegisterServer = function: HResult; stdcall;
 
 function RegisterOCX(FileName: string): Boolean;
 var
   OCXHand: THandle;
   RegFunc: TDllRegisterServer;
 begin
   OCXHand := LoadLibrary(PChar(FileName));
   RegFunc := GetProcAddress(OCXHand, 'DllRegisterServer');
   if @RegFunc <> nil then
     Result := RegFunc = S_OK
   else
     Result := False;
   FreeLibrary(OCXHand);
 end;
 
 function UnRegisterOCX(FileName: string): Boolean;
 var
   OCXHand: THandle;
   RegFunc: TDllRegisterServer;
 begin
   OCXHand := LoadLibrary(PChar(FileName));
   RegFunc := GetProcAddress(OCXHand, 'DllUnregisterServer');
   if @RegFunc <> nil then
     Result := RegFunc = S_OK
   else
     Result := False;
   FreeLibrary(OCXHand);
 end;
 
 {**********}
 
 {2.}
 
 function RegisterServer(const aDllFileName: string; aRegister: Boolean): Boolean;
 type
   TRegProc = function: HResult;
   stdcall;
 const
   cRegFuncNameArr: array [Boolean] of PChar =
     ('DllUnregisterServer', 'DllRegisterServer');
 var
   vLibHandle: THandle;
   vRegProc: TRegProc;
 begin
   Result := False;
   vLibHandle := LoadLibrary(PChar(aDllFileName));
   if vLibHandle = 0 then Exit;
     @vRegProc := GetProcAddress(vLibHandle, cRegFuncNameArr[aRegister]);
   if @vRegProc <> nil then
     Result := vRegProc = S_OK;
   FreeLibrary(vLibHandle);
 end;
 




Переименование каталога


 uses
   ShellApi;
 
 procedure RenameDir(DirFrom, DirTo: string);
 var
   shellinfo: TSHFileOpStruct;
 begin
   with shellinfo do
   begin
     Wnd    := 0;
     wFunc  := FO_RENAME;
     pFrom  := PChar(DirFrom);
     pTo    := PChar(DirTo);
     fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
               FOF_SILENT or FOF_NOCONFIRMATION;
   end;
   SHFileOperation(shellinfo);
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   RenameDir('C:\Dir1', 'C:\Dir2');
 end;
 




Изменение месторасположения .NET-файла во время работы

Автор: Scott Frolich

Кто-нибудь знает как изменить месторасположение файла PDOXUSRS.NET во время выполнения программы?


 DbiSetProp(hSessionHandle, sesNetFile, pchar('c:\newdir'));
 

Для получения дескриптора сеанса, если вы используете сессию по умолчанию, необходимо вызвать DbiGetCurrSession .




Как заменить или переместить файл, используемый другим приложением

Автор: Marcus Neves

В Windows NT 4/2000 есть такая API функция, имеющая очень интересный последний аргумент. Функция позволяет также переименовывать указанный файл или директорию.


 MoveFileEx(ExistingFN, NewFN, MOVEFILE_REPLACE_EXISTING или
 MOVEFILE_DELAY_UNTIL_REBOOT
 

Если задать MOVEFILE_DELAY_UNTIL_REBOOT в dwFlags (характерно для Windows NT 4/2000), то в реестр будет занесена специальная информация и после перезагрузки Windows сотрёт или перепишет указанный файл

Параметры:

  • ExistingFN указатель на строку (null-terminated) , которая содержит имя нужного нам файла или директории.
  • NewFN указатель на строку (null-terminated), содкржащую новое имя файла, указанного ExistingFN.
  • Флаг MOVEFILE_REPLACE_EXISTING указывает функции заменить, если файл ExistingFN уже существует. Если указать в NewFN - nil, ExistingFN будет стёрт.

Пример:

  • Перемещение файла:

 MoveFileEx('c:\winnt\system32\kernel32.dll', 'd:\winnt.bak\system32\kernel32.dll',
 MOVEFILE_REPLACE_EXISTING или MOVEFILE_DELAY_UNTIL_REBOOT
 

  • Удаление существующего файла:

 MoveFileEx('c:\winnt\system32\kernel32.dll', nil,
 MOVEFILE_REPLACE_EXISTING или MOVEFILE_DELAY_UNTIL_REBOOT
 




Замена подстрок

Автор: Сергею Шамайтис


 function ReplaceSub(str, sub1, sub2: string): string;
 var
   aPos: Integer;
   rslt: string;
 begin
   aPos := Pos(sub1, str);
   rslt := '';
   while (aPos <> 0) do
   begin
     rslt := rslt + Copy(str, 1, aPos - 1) + sub2;
     Delete(str, 1, aPos + Length(sub1) - 1);
     aPos := Pos(sub1, str);
   end;
   Result := rslt + str;
 end;
 




Заменяем текст в текстовом файле

Идут два мужика: один - сисадмин, другой - тоже козел.


 procedure FileReplaceString(const FileName, searchstring, replacestring: string);
 var
   fs: TFileStream;
   S: string;
 begin
   fs := TFileStream.Create(FileName, fmOpenread or fmShareDenyNone);
   try
     SetLength(S, fs.Size);
     fs.ReadBuffer(S[1], fs.Size);
   finally
     fs.Free;
   end;
   S  := StringReplace(S, SearchString, replaceString, [rfReplaceAll, rfIgnoreCase]);
   fs := TFileStream.Create(FileName, fmCreate);
   try
     fs.WriteBuffer(S[1], Length(S));
   finally
     fs.Free;
   end;
 end;
 




Заменить текст в документе Word


 uses
   ComObj;
 
 // Replace Flags 
 type
   TWordReplaceFlags = set of (wrfReplaceAll, wrfMatchCase,
   wrfMatchWildcards);
 
 function Word_StringReplace(ADocument: TFileName; SearchString,
 ReplaceString: string; Flags: TWordReplaceFlags): Boolean;
 const
   wdFindContinue = 1;
   wdReplaceOne = 1;
   wdReplaceAll = 2;
   wdDoNotSaveChanges = 0;
 var
   WordApp: OLEVariant;
 begin
   Result := False;
 
   { Check if file exists }
   if not FileExists(ADocument) then
   begin
     ShowMessage('Specified Document not found.');
     Exit;
   end;
 
   { Create the OLE Object }
   try
     WordApp := CreateOLEObject('Word.Application');
   except
     on E: Exception do
     begin
       E.Message := 'Word is not available.';
       raise;
     end;
   end;
 
   try
     { Hide Word }
     WordApp.Visible := False;
     { Open the document }
     WordApp.Documents.Open(ADocument);
     { Initialize parameters}
     WordApp.Selection.Find.ClearFormatting;
     WordApp.Selection.Find.Text := SearchString;
     WordApp.Selection.Find.Replacement.Text := ReplaceString;
     WordApp.Selection.Find.Forward := True;
     WordApp.Selection.Find.Wrap := wdFindContinue;
     WordApp.Selection.Find.Format := False;
     WordApp.Selection.Find.MatchCase := wrfMatchCase in Flags;
     WordApp.Selection.Find.MatchWholeWord := False;
     WordApp.Selection.Find.MatchWildcards := wrfMatchWildcards in Flags;
     WordApp.Selection.Find.MatchSoundsLike := False;
     WordApp.Selection.Find.MatchAllWordForms := False;
     { Perform the search}
     if wrfReplaceAll in Flags then
       WordApp.Selection.Find.Execute(Replace := wdReplaceAll)
     else
       WordApp.Selection.Find.Execute(Replace := wdReplaceOne);
     { Save word }
     WordApp.ActiveDocument.SaveAs(ADocument);
     { Assume that successful }
     Result := True;
     { Close the document }
     WordApp.ActiveDocument.Close(wdDoNotSaveChanges);
   finally
     { Quit Word }
     WordApp.Quit;
     WordApp := Unassigned;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Word_StringReplace('C:\Test.doc','Old String','New String',
   [wrfReplaceAll]);
 end;
 




Word для генерации отчетов

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


 var
   Word: Variant;
 begin
   Word := CreateOleObject('Word.Basic');
   with Word do
   begin {Затем следуют "чистые" команды WordBASIC...}
     FileNew('Normal');
     Insert('Это первая строчка'#13);
     Insert('Это вторая строчка'#13);
     FileSaveAs('c:\temp\test.txt', 3);
   end;
 end;
 




Резидентная программа

- Как бы вы поступили, если бы случайно оказались в одной камере с Гитлером, Саддамом Хусейном и Билли Гейтсом, и у вас, случайно, оказался с собой пистолет и два патрона?
- Сначала два раза выстрелил бы в Гейтса, а потом рукояткой его, рукояткой.

Программу без использования VCL (Visual Component Library). Иначе это можно назвать "написанием программ на WinAPI". Один из способов создать такой проект в Delphi - в меню File | New... выбрать Console Application и удалить строку {$APPTYPE CONSOLE}.

Почти для любого действия нам понадобится окно. Но видеть нам его не нужно. Поэтому, создадим невидимое окно. Для этого нужно зарегистрировать класс окна и создать его, но не показывать. Эти два действия происходят в функции CreateMyWnd. Чтобы было возможно общение пользователя с программой, можно сделать TrayIcon (иконку справа на панели задач). Она создается в процедуре CreateTray. Иконку я взял, наверное, не самую подходящую, но это для примера. Точно так же можно взять собственную иконку. Для tray также нужно всплывающее меню. Здесь оно создается в функции CreateMyMenu и состоит всего из одного пункта. Резидентные программы обычно отслеживают что-то. Для этой цели бывает необходим таймер. Создается он при помощи SetTimer. Чтобы наша программа не "тормозила" компьютер, приоритет программы лучше всего установить в самый низкий. Конечно, это хорошо не во всех случаях, но иногда это весьма полезно. Эта программа занимается тем, что запускает ScreenSaver при сдвиге курсора в левый верхний угол (координаты курсора проверяются каждую секунду) и при нажатии клавиши Pause (реализуются через HotKey). Задача, конечно, не самая актуальная. Присылайте, пожалуйста, ваши идеи по поводу задач для резидентной программы.


 program MyResident;
 uses
   Windows,
   ShellAPI,
   Messages;
 
 const
   ClassName = 'MyResident'; { Имя класса }
   WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
     генерироваться при событиях с tray }
 
 var
   menu: hMenu; { Всплывающее меню }
   mywnd: hWnd; { Окно программы }
 
 function MyWndProc(wnd: hWnd; msg, wParam,
   lParam: longint): longint; stdcall;
 var
   p: TPoint;
   s: array [0..255] of char;
   tray: TNotifyIconData;
 begin
   case msg of
     WM_TIMER: begin { Событие таймера }
       GetCursorPos(p);
       if (p.x = 0) and (p.y = 0) then begin { Проверка координат курсора }
         { Если ScreenSaver еще не запущен - запустить: }
         GetClassName(GetForegroundWindow, s, length(s));
         if s <> 'WindowsScreenSaverClass'
           then SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
       end;
       result := 0;
     end;
     WM_NOTIFYTRAYICON: begin { Событие tray }
       { Если нажата правая кнопка, показать меню: }
       if lparam = WM_RBUTTONUP then begin
         GetCursorPos(p);
         TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
       end;
       result := 0;
     end;
     WM_COMMAND: begin { Выбран пункт меню }
       { Если выбран нулевой пункт (здесь - единственный) -
         закрыть программу: }
       if lo(lparam) = 0 then SendMessage(mywnd, WM_CLOSE, 0, 0);
       result := 0;
     end;
     WM_HOTKEY: begin { Нажата горячая клавиша }
       { Запуск хранителя экрана: }
       SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
       result := 0;
     end;
     WM_DESTROY: begin { Закрытие программы }
        { Удаление tray: }
       with tray do begin
         cbSize := sizeof(TNotifyIconData);
         wnd := mywnd;
         uID := 0;
       end;
       Shell_NotifyIcon(NIM_DELETE, @tray);
       PostQuitMessage(0);
       result := 0;
     end;
     else Result := DefWindowProc(wnd, msg, WParam, LParam);
   end;
 end;
 
 function CreateMyWnd: hWnd;
 var
   wc: WndClass;
 begin
   { Гегистрация класса: }
   wc.style := 0;
   wc.lpfnWndProc := @MyWndProc;
   wc.cbClsExtra := 0;
   wc.cbWndExtra := 0;
   wc.hInstance := hInstance;
   wc.hIcon := 0;
   wc.hCursor := 0;
   wc.hbrBackground := COLOR_WINDOW;
   wc.lpszMenuName := nil;
   wc.lpszClassName := ClassName;
   if RegisterClass(wc) = 0 then halt(0);
   { Создание окна: }
   result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
     'My Window', WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
   if result = 0 then halt(0);
 end;
 
 procedure CreateTray;
 var
   tray: TNotifyIconData;
 begin
   { Создание tray: }
   with tray do begin
     cbSize := sizeof(TNotifyIconData);
     wnd := mywnd;
     uID := 0;
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
     uCallBackMessage := WM_NOTIFYTRAYICON;
     hIcon := LoadIcon(0, IDI_ASTERISK);
     szTip := ('My Resident');
   end;
   Shell_NotifyIcon(NIM_ADD, @tray);
 end;
 
 function CreateMyMenu: hMenu;
 begin
   { Создание меню: }
   result := CreatePopupMenu;
   if result = 0 then halt(0);
   if not AppendMenu(result, MF_STRING, 0, 'Exit') then halt(0);
 end;
 
 var
   msg: TMsg;
 
 begin
   mywnd := CreateMyWnd; // Создание окна
   CreateTray; // Создание tray
   menu := CreateMyMenu; // Создание меню
   SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE); { Установка
     низкого приоритета }
   RegisterHotKey(mywnd, 0, 0, VK_PAUSE); // Регистрация "горячей клавиши"
   SetTimer(mywnd, 0, 1000, nil); // Создание таймера
   while (GetMessage(msg, 0, 0, 0)) do begin
     TranslateMessage(msg);
     DispatchMessage(msg);
   end;
   KillTimer(mywnd, 0); // Уничтожение таймера
   UnregisterHotKey(mywnd, 0); // "Уничтожение" горячей клавиши
 end.
 




Резидентная программа и записная книжка

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

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

Речь сегодня опять пойдет о резидентных программах. В этот раз в программу будут добавлены новые функции, а именно: записная книжка, "усыпление" компьютера, вызов диалога "Завершение работы Windows". Для тех, кто не читал предыдущего выпуска: чтобы создать программу без модулей (а это здесь нужно) можно в меню File | New... выбрать Console Application.

Начиная с этого выпуска, я буду выкладывать на сайт program.dax.ru все файлы проекта, необходимые для компиляции. Скачав их (в архиве они будут занимать 3-5 Кбайт), Вам не придется думать, что делать с этим текстом и какие компоненты с какими событиями создавать.

Записная книжка - это окно с многострочным полем ввода, которое легко вызывается и которое сохраняет текст, вводимый пользователем. То есть, при открытии текст считывается из файла, а при закрытии сохраняется в файл. Поскольку поле ввода - окно, его можно создать без каких-либо родительских окон. В VCL аналогом этого было бы создание Memo вне формы. Чтобы объяснить Windows, что это поле ввода, в качестве имени класса окна нужно указать 'EDIT'. ES_MULTILINE делает его многострочным. Когда записная книжка закрывается, текст из нее нужно сохранить. Но сообщения WM_CLOSE, WM_DESTROY и другие попадают не ко мне, а в стандартную оконную процедуру поля ввода. Поэтому стандартную процедуру поля ввода нужно заменить на свою. А чтобы сохранить функциональность поля ввода, все сообщения кроме WM_DESTROY пересылаются в старую оконную процедуру.

В прошлом выпуске программа отслеживала координаты курсора и, если мышь была в левом верхнем углу экрана, запускала ScreenSaver. Чтобы при следующей проверке координат курсора не запускать ScreenSaver повторно, программа проверяла, какое окно сейчас активно. Дело в том, что стандартные хранители экрана в некоторых версиях Windows всегда создают окна с названием класса 'WindowsScreenSaverClass'. Но, поскольку работает это не всюду, я решил убрать эту функцию.


 program Project1;
 uses
   Windows,
   ShellAPI,
   Messages;
 
 const
   ClassName = 'MyResident'; // Имя класса
   WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
                       генерироваться при событиях с tray }
 var
   menu: hMenu; // Всплывающее меню
   mywnd: hWnd; // Окно программы
   memo: hWnd = 0; // Окно записной книжки
   OldMemoProc: Pointer; // Стандартная оконная процедура Edit
 
 // Оконная процедура записной книжки:
 function MemoWndProc(wnd: hWnd; msg, wParam,
   lParam: longint): longint; stdcall;
 var
   s: PChar;
   len: integer;
   F: File;
 begin
   case msg of
     WM_DESTROY: begin // Окно закрывается
       // Сохранение текста:
       len := GetWindowTextLength(memo);
       GetMem(s, len + 1);
       GetWindowText(memo, s, len + 1);
       AssignFile(F, 'memo.txt');
       Rewrite(F, 1);
       BlockWrite(F, s^, len);
       CloseFile(F);
       FreeMem(s);
       result := 0;
       memo := 0;
     end;
     WM_KEYUP: begin // Нажата клавиша
       if wparam = VK_ESCAPE // Нажат Escape
         then result := SendMessage(memo, WM_CLOSE, 0, 0)
         else result := DefWindowProc(wnd, msg, wparam, lparam);
     end;
     // Иначе - вызвать старую оконную процедуру
     else result := CallWindowProc(OldMemoProc, wnd, msg, wparam, lparam);
   end;
 end;
 
 // Создание окна записной книжки:
 procedure CreateMemo;
 var
   len: cardinal;
   F: hFile;
   s: PChar;
   ReadBytes: cardinal;
 begin
   // Если записная книжка уже открыта - выход из процедуры:
   if GetForegroundWindow = memo then Exit;
   // Создание окна:
   memo := CreateWindowEx(WS_EX_PALETTEWINDOW, 'EDIT', nil,
     WS_POPUP or WS_SIZEBOX or WS_VSCROLL or
     ES_MULTILINE or ES_AUTOVSCROLL,
     GetSystemMetrics(SM_CXFULLSCREEN) div 2 - 200,
     GetSystemMetrics(SM_CYFULLSCREEN) div 2 - 200,
     400, 400, 0, 0, hinstance, nil);
   // Установка шрифта:
   SendMessage(memo, WM_SETFONT, GetStockObject(SYSTEM_FIXED_FONT), 0);
   // Сохранение старой и установка новой оконной процедуры:
   OldMemoProc := Pointer(GetWindowLong(memo, GWL_WNDPROC));
   SetWindowLong(memo, GWL_WNDPROC, longint(@MemoWndProc));
   { Открытие файла (здесь удобнее воспользоваться функциями WinAPI): }
   try
     F := CreateFile('memo.txt', GENERIC_READ, FILE_SHARE_READ, nil,
       OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
     if F = INVALID_HANDLE_VALUE then Exit;
     len := GetFileSize(F, nil);
     if len = $FFFFFFFF then Exit;
     GetMem(s, len + 1);
     ReadFile(F, s^, len, ReadBytes, nil);
     SetWindowText(memo, s);
     CloseHandle(F);
     FreeMem(s);
   except SetWindowText(memo, 'Error') end;
   // Показать окно:
   ShowWindow(memo, SW_SHOW);
   UpdateWindow(memo);
 end;
 
 // Главная оконная процедура:
 function MyWndProc(wnd: hWnd; msg, wParam,
   lParam: longint): longint; stdcall;
 var
   p: TPoint;
   tray: TNotifyIconData;
   ProgmanWnd: hWnd;
 begin
   case msg of
     WM_NOTIFYTRAYICON: begin // Событие tray
       // Если нажата правая кнопка, показать меню:
       if lparam = WM_RBUTTONUP then begin
         SetForegroundWindow(mywnd);
         GetCursorPos(p);
         TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
       end;
       result := 0;
     end;
     WM_COMMAND: begin // Выбран пункт меню
       { В зависимости от выбранного пункта меню открывается
       записная книжка, запускается ScreenSaver, "усыпляется"
       компьютер или закрывается программа: }
       case loword(wparam) of
         0: CreateMemo;
         1: SendMessage(mywnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
         2: SetSystemPowerState(true, true);
         4: SendMessage(mywnd, WM_CLOSE, 0, 0);
       end;
       result := 0;
     end;
     WM_HOTKEY: begin // Нажата горячая клавиша
       case loword(lparam) of
         // Нажата клавиша Pause:
         0: SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
         // Нажаты клавиши Alt+Pause:
         MOD_ALT: begin
           ProgmanWnd := FindWindow('Progman', 'Program Manager');
           if ProgmanWnd <> 0
             then SendMessage(ProgmanWnd, WM_CLOSE, 0, 0);
         end;
         // Нажаты клавиши Alt+Shift+Pause:
         MOD_ALT or MOD_SHIFT: SetSystemPowerState(true, true);
         // Иначе:
         else CreateMemo;
             result := 0;
     end;
     WM_ACTIVATEAPP: begin // Изменение активности приложения
       { Если приложение потеряло активность - закрыть (если нужно)
       записную книжку: }
       if (memo <> 0) and (wparam = 0)
         then SendMessage(memo, WM_CLOSE, 0, 0);
       result := 0;
     end;
     WM_DESTROY: begin // Закрытие программы
       // Удаление tray:
       with tray do begin
         cbSize := sizeof(TNotifyIconData);
         wnd := mywnd;
         uID := 0;
       end;
       Shell_NotifyIcon(NIM_DELETE, @tray);
       PostQuitMessage(0);
       result := 0;
     end;
     else result := DefWindowProc(wnd, msg, WParam, LParam);
   end;
 end;
 
 // Создание окна:
 function CreateMyWnd: hWnd;
 var
   wc: WndClass;
 begin
   // Регистрация класса:
   wc.style := CS_HREDRAW or CS_VREDRAW;
   wc.lpfnWndProc := @MyWndProc;
   wc.cbClsExtra := 0;
   wc.cbWndExtra := 0;
   wc.hInstance := hInstance;
   wc.hIcon := LoadIcon(hinstance, IDI_ASTERISK);
   wc.hCursor := LoadCursor(hinstance, IDC_ARROW);
   wc.hbrBackground := COLOR_INACTIVECAPTION;
   wc.lpszMenuName := nil;
   wc.lpszClassName := ClassName;
   if RegisterClass(wc) = 0 then halt(0);
   // Создание окна:
   result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
     'My Window', WS_POPUP, 100, 100, 200, 200, 0, 0, hInstance, nil);
   if result = 0 then halt(0);
 end;
 
 // Создание Tray:
 procedure CreateTray;
 var
   tray: TNotifyIconData;
 begin
   with tray do begin
     cbSize := sizeof(TNotifyIconData);
     wnd := mywnd;
     uID := 0;
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
     uCallBackMessage := WM_NOTIFYTRAYICON;
     hIcon := LoadIcon(0, IDI_ASTERISK);
     szTip := ('My Resident');
   end;
   Shell_NotifyIcon(NIM_ADD, @tray);
 end;
 
 // Создание всплывающего меню:
 function CreateMyMenu: hMenu;
 begin
   result := CreatePopupMenu;
   if result = 0 then Exit;
   AppendMenu(result, MF_STRING, 0, 'Memo');
   AppendMenu(result, MF_STRING, 1, 'ScreenSaver');
   AppendMenu(result, MF_STRING, 2, 'Sleep');
   AppendMenu(result, MF_SEPARATOR, 3, 'Exit');
   AppendMenu(result, MF_STRING, 4, 'Exit');
 end;
 
 var
   msg: TMsg;
 begin
   mywnd := CreateMyWnd; // Создание окна
   CreateTray; // Создание tray
   menu := CreateMyMenu; // Создание меню
   // Установка низкого приоритета:
   SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE);
   // Регистрация "горячих клавиш":
   RegisterHotKey(mywnd, 0, 0, VK_PAUSE);
   RegisterHotKey(mywnd, 1, MOD_ALT, VK_PAUSE);
   RegisterHotKey(mywnd, 2, MOD_SHIFT, VK_PAUSE);
   RegisterHotKey(mywnd, 3, MOD_ALT or MOD_SHIFT, VK_PAUSE);
 
   // Распределение сообщений:
   while (GetMessage(msg, 0, 0, 0)) do begin
     TranslateMessage(msg);
     DispatchMessage(msg);
   end;
 
   // "Уничтожение" горячих клавиш:
   UnregisterHotKey(mywnd, 0);
   UnregisterHotKey(mywnd, 1);
   UnregisterHotKey(mywnd, 2);
 end.
 




Момент окончания изменения размера или перемещения окна


 type
   TForm1 = class(TForm)
   private
     { Private declarations }
   public
     procedure WMEXITSIZEMOVE(var Message: TMessage);
       message WM_EXITSIZEMOVE;
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage);
 begin
   Form1.Caption := 'Finished Moving and sizing';
 end;
 




Изменение размеров колонок DBGrid

Если у тебя есть постоянная девушка, то на всех вечеринках приходится использовать установки "default" (по умолчанию). Можно попробовать переустановить "систему" в режиме "custom", но получаться те же самые Windows-совские глюки. Если ты Unix-оид, то у тебя, скорей всего, нет постоянной девушки.

У меня есть форма. На ней расположены поле редактирования, компонент SQL Query, DBGrid и кнопка. Я заполняю поле редактирования и при нажатии на кнопку DBGrid отражает результат запроса. Как я могу изменить размер табличной сетки и ее колонок в зависимости от новых значений полей? Поля, возвращаемые запросом, не заполняют всей ширины сетки, а все мои попытки сделать это из кода терпят крах...

Вы можете изменить размер колонки во время выполнения программы, изменяя свойство DisplayWidth соответствующего поля компонента DBGrid...


 MyTableMyField.DisplayWidth := Length(MyTableMyField.value);
 

Если Вам действительно необходимо вычислить ширину всего DBGrid, используйте следующий код:


 function NewTextWidth(fntFont: TFont; const sString: OpenString): integer;
 var
   fntSave: TFont;
 begin
   result := 0;
   fntSave := Application.MainForm.Font;
   Application.MainForm.Font := fntFont;
   try
     result := Application.MainForm.Canvas.TextWidth(sString);
   finally
     Application.MainForm.Font := fntSave;
   end;
 end;
 
 { вычисляем ширину табличной сетки, которую необходимо отобразить без                 }
 { горизонтальной полосы прокрутки и без дополнительного пространства между последней  }
 { колонкой и вертикальной полосой прокрутки. Свойство Datasource у компонента DBGrid, }
 { как и свойство Dataset у Datasource должны быть назначены заранее,                  }
 { но таблица не должна быть открытой. Примечание: полученная ширина включает ширину   }
 { вертикальной полосы прокрутки, полученной на основе базового режима                 }
 { отображения. Вычисленная ширина полностью занимает рабочую область компонента.      }
 
 function iCalcGridWidth(
   dbg: TDBGrid { корректируемый компонент }
   ): integer; { "точная" ширина }
 const
   cMEASURE_CHAR = '0';
   iEXTRA_COL_PIX = 4;
   iINDICATOR_WIDE = 11;
 var
   i, iColumns, iColWidth, iTitleWidth, iCharWidth: integer;
 begin
   iColumns := 0;
   result := GetSystemMetrics(SM_CXVSCROLL);
   iCharWidth := NewTextWidth(dbg.Font, cMEASURE_CHAR);
   with dbg.dataSource.dataSet do
     for i := 0 to FieldCount - 1 do
       with Fields[i] do
         if visible then
         begin
           iColWidth := iCharWidth * DisplayWidth;
           if dgTitles in dbg.Options then
           begin
             iTitleWidth := NewTextWidth(dbg.TitleFont, DisplayLabel);
             if iColWidth < iTitleWidth then
               iColWidth := iTitleWidth;
           end;
           inc(iColumns, 1);
           inc(result, iColWidth + iEXTRA_COL_PIX);
         end;
   if dgIndicator in dbg.Options then
   begin
     inc(iColumns, 1);
     inc(result, iINDICATOR_WIDE);
   end;
   if dgColLines in dbg.Options then
     inc(result, iColumns)
   else
     inc(result, 1);
 end;
 

Я должен использовать функцию NewTextWidth, а не Canvas.TextWith компонента DBGrid, так как Canvas еще не инициализирован во время вызова iCalcGridWidth.




Изменить размер Jpeg и сохранить его в новый файл

В Интернете прошел первый конкурс красоты. Звание Мисс Интернет завоевала девушка В_21399КS.JРG. Поздравляем победительницу!


 procedure TForm1.Button1Click(Sender: TObject);
 var
   bmp: TBItmap;
   jpg: TJpegImage;
   scale: Double;
 begin
   if opendialog1.execute then
   begin
     jpg := TJpegImage.Create;
     try
       jpg.Loadfromfile( opendialog1.filename );
       if jpg.Height > jpg.Width then
         scale := 50 / jpg.Height
       else
         scale := 50 / jpg.Width;
       bmp:= Tbitmap.Create;
       try
         {Create thumbnail bitmap, keep pictures aspect ratio}
         bmp.Width := Round( jpg.Width * scale );
         bmp.Height:= Round( jpg.Height * scale );
         bmp.Canvas.StretchDraw( bmp.Canvas.Cliprect, jpg );
         {Draw thumbnail as control}
         Self.Canvas.Draw( 100, 10, bmp );
         {Convert back to JPEG and save to file}
         jpg.Assign( bmp );
         jpg.SaveToFile(ChangeFileext( opendialog1.filename, '_thumb.JPG' ));
       finally
         bmp.free;
       end;
     finally
       jpg.free;
     end;
   end;
 end;
 




Панель с изменяющимися размерами

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


 unit Elastic;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls;
 
 type
 
   TElasticPanel = class(TPanel)
   private
     FHorz, FVert: boolean;
     nOldWidth, nOldHeight: integer;
     bResized: boolean;
   protected
     procedure WMSize(var message: TWMSize); message WM_SIZE;
   public
     nCount: integer;
     constructor Create(AOwner: TComponent); override;
   published
     property ElasticHorizontal: boolean read FHorz write FHorz default
       TRUE;
 
     property ElasticVertical: boolean read FVert write FVert default
       TRUE;
 
   end;
 
 procedure Register;
 
 implementation
 
 constructor TElasticPanel.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   FHorz := TRUE;
   FVert := TRUE;
   nOldWidth := Width;
   nOldHeight := Height;
   bResized := FALSE;
 end;
 
 procedure TElasticPanel.WMSize(var message: TWMSize);
 var
 
   bResize: boolean;
   xRatio: real;
   i: integer;
   ctl: TWinControl;
 begin
 
   Inc(nCount);
   if Align = alNone then
     bResize := TRUE
   else
     bResize := bResized;
   if not (csDesigning in ComponentState) and bResize then
   begin
     if FHorz then
     begin
       xRatio := Width / nOldWidth;
       for i := 0 to ControlCount - 1 do
       begin
         ctl := TWinControl(Controls[i]);
         ctl.Left := Round(ctl.Left * xRatio);
         ctl.Width := Round(ctl.Width * xRatio);
       end;
     end;
     if FVert then
     begin
       xRatio := Height / nOldHeight;
       for i := 0 to ControlCount - 1 do
       begin
         ctl := TWinControl(Controls[i]);
         ctl.Top := Round(ctl.Top * xRatio);
         ctl.Height := Round(ctl.Height * xRatio);
       end;
     end;
   end
   else
   begin
     nOldWidth := Width;
     nOldHeight := Height;
   end;
   bResized := TRUE;
   nOldWidth := Width;
   nOldHeight := Height;
 end;
 
 procedure Register;
 begin
 
   RegisterComponents('Additional', [TElasticPanel]);
 end;
 
 end.
 




Различные разрешения - различные размеры шрифтов

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

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

  1. Я получал безобразные результаты при изменении резолюции, пока я не начал задавать размер шрифта в пикселях (pixels) вместо точек (points). Вы можете установить font.height, и вы можете установить font.size. Я обнаружил, что установка значения font.height дает значительно лучшие результаты, поскольку данное свойство определяет количество пикселей, и размер шрифта меняется пропорционально изменению размера пиксела.

    Также, вы можете обнаружить, что шрифт по-умолчанию не может быть ниже определенной высоты. Будет гораздо лучше, если вместо SYSTEM вы выберите шрифт MS sans-serif.

  2. У формы имеется свойство, названное "scaling" (взял из памяти, надеюсь верно). Я обнаружил, что лучше его иметь выключенным. Если свойство включено, Delphi или Windows пытаются при изменении размера формы все соответствено смаштабировать. Все это хорошо только для сохранения относительных позиций элементов, так что я выключил свойство, и больше о нем не вспоминал.

    Если свойство выключено, а форма ваша максимизирована, вы обнаружите, что все ваши компоненты устремились вслед за левым верхним углом формы. Где не желателен этот эффект, я получал разрешение экрана (Screen.Height и Screen.Width) и прислаивал свойствам компонентов Left и Тор скорректированные свойства прежде, чем форма успевала появиться (в методе OnCreate, во время выполения приложения).

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




Как из своего пpиложения опpеделить загpузку pесуpсов GDI и USER

Автор: Nomadic

Подходит фидошник к ларьку с надписью "ПИРОЖКИ".
- Мне два сабжа пожалуйста.


 {$APPTYPE CONSOLE}
 
 // индикатоp pесуpсов
 program res;
 
 function MyGetFreeSystemResources32(Id: integer): integer;
 stdcall; external 'rsrc32' name '_MyGetFreeSystemResources32@4';
 
 const
   rSystem = 0;
   rGDI = 1;
   rUSER = 2;
 
 begin
   writeln('free resources');
   writeln('System:', MyGetFreeSystemResources32(rSystem), '%');
   writeln('GDI:', MyGetFreeSystemResources32(rGDI), '%');
   writeln('USER:', MyGetFreeSystemResources32(rUSER), '%');
 end.
 




Пример ресурсной таблицы строк

Автор: Ralph Friedman

Как мне создать ресурсную таблицу строк (Resource String Table), про которую упоминается в функции FmtLoadStr, но не сказано как создать эту таблицу, про это вообще нигде не сказано!

Создайте файл в приведенном ниже формате и обзовите его, скажем (подойдите к этому творчески), strings.rc:

   STRINGTABLE LOADONCALL MOVEABLE DISCARDABLE
   {
    1, "UNPACK.INI"
    2, "AcrobatClass"
    3, "ACROEXCH.EXE"
    4, "^.PDF"
    5, "Extensions"
    6, "ACROEXCH.EXE"
    7, "PDF"
    8, "AABSETUP.EXE"
    9, "DelFiles-"
    10, "INI-"
    11, "UNPACK.INI"
    12, "ACROSRCH.DLL"
    13, "Regedit"
    14, "ACROREAD.EXE"
    15, "ACRO_LE.EXE"
   }
Затем, с помощью компилятора ресурсов Borland (BRCC.EXE в вашем каталоге Delphi\Bin), скомпилируйте это в файл ресурсов:
  BRCC strings.rc

Вы получите файл с именем strings.res. В вашем .DPR-файле после строки {$R *.RES} добавьте строку {$R STRINGS.RES}, после этого строковые ресурсы будут компилироваться с вашим exe-файлом.




Восстановление размера окна

Автор: Mike Orriss

Существует ли какой-либо способ получения координат формы, которые она должна иметь при восстановлении с максимально распахнутого состояния?

Используйте API Функцию GetPlacement. Следующая выдержка из кода моего компонента TBag демонстрирует это:


 procedure TBag.SetFormPlace(AName: string; AForm: TForm);
 var
   s: string[99];
   Place: TWindowPlacement;
 begin
   Place.length := SizeOf(TWindowPlacement);
   if not GetWindowPlacement(AForm.Handle, @Place) then
     exit;
   with Place do
   begin
     s := IntToStr(Flags);
     s := AppendS(s, ShowCmd);
     s := AppendS(s, ptMinPosition.X);
     s := AppendS(s, ptMinPosition.Y);
     s := AppendS(s, ptMaxPosition.X);
     s := AppendS(s, ptMaxPosition.Y);
     s := AppendS(s, rcNormalPosition.Left);
     s := AppendS(s, rcNormalPosition.Top);
     s := AppendS(s, rcNormalPosition.Right);
     s := AppendS(s, rcNormalPosition.Bottom);
   end;
   SetString(AName, s);
 end;
 




Восстанавление длинных имен файлов по известным коротким

Автор: Boris

Мой Windows понима~1 длинны~1 имена, а твой?


 //---------------------------------------------------------------------
 // Восстанавливает длинные имена файлов по известным коротким (8.3)
 // В качестве аргумента принимает полный или неполный (в т.ч. относительный)
 // путь к файлу, например 'C:\WINDOWS\РАБОЧИ~1\ИТАКДА~1.LNK' или
 // '..\..\COMMON~1\BORLAN~1\BDE\BDEREA~1.TXT'. Понимает сетевые имена.
 // Возвращает полный(!) путь типа 'C:\Windows\Рабочий стол\и так далее.lnk',
 // 'C:\Program Files\Common Files\Borland Shared\BDE\bdereadme.txt',
 // '\\Computer\resource\Folder with long name\File with long name.ext'
 //---------------------------------------------------------------------
 
 function RestoreLongName(fn: string): string;
 
   function LookupLongName(const filename: string): string;
   var
     sr: TSearchRec;
   begin
     if FindFirst(filename, faAnyFile, sr) = 0 then
       Result := sr.Name
     else
       Result := ExtractFileName(filename);
     SysUtils.FindClose(sr);
   end;
   function GetNextFN: string;
   var
     i: integer;
   begin
     Result := '';
     if Pos('\\', fn) = 1 then
     begin
       Result := '\\';
       fn := Copy(fn, 3, length(fn) - 2);
       i := Pos('\', fn);
       if i <> 0 then
       begin
         Result := Result + Copy(fn, 1, i);
         fn := Copy(fn, i + 1, length(fn) - i);
       end;
     end;
     i := Pos('\', fn);
     if i <> 0 then
     begin
       Result := Result + Copy(fn, 1, i - 1);
       fn := Copy(fn, i + 1, length(fn) - i);
     end
     else
     begin
       Result := Result + fn;
       fn := '';
     end;
   end;
 var
   name: string;
 begin
 
   fn := ExpandFileName(fn);
   Result := GetNextFN;
   repeat
     name := GetNextFN;
     Result := Result + '\' + LookupLongName(Result + '\' + name);
   until length(fn) = 0;
 end;
 




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

Почему мышиный курсор не возвращается обратно (не становится обычной стрелкой) после выполнения запроса?

При выполнении открытого запроса, Delphi изменяет для вас курсор, и произойти это может даже в середине события, как, например, при нажатии на кнопку. Приведенный ниже пример отобразит курсор в виде иконки песочных часов (SQL Hourglass Icon) после того, как вы закроете окно с сообщением. При этом мышь будет вести себя так, как будто находится в режиме "стрелки".


 // Добавьте к обработчику события нажатия кнопки,
 // использование запроса при этом не имеет значения
 // Select * from Customer (в IBLocal)
 
 with query1 do
 begin
   close;
   open;
   showmessage(IntToStr(RecordCount));
 end; // with
 

При наступлении события, Delphi пробует обратно придать курсору тип стрелки (Arrow), при этом выводится новая форма (диалог showmessage), которая мешает автоматическому переводу курсора в режим стрелки.

Для решения этой проблемы нужно добавить Application.ProcessMessages прежде, чем форма будет показана, это позволит обработать все сообщения, скопившиеся в очереди (и очистить ее), после чего мышиный курсор вновь пример нормальную форму.


 // Добавьте к обработчику события нажатия кнопки,
 // использование запроса при этом не имеет значения
 // Select * from Customer (в IBLocal)
 
 with query1 do
 begin
   close;
   open;
   application.ProcessMessages;       // Добавьте эту строку.
   showmessage(IntToStr(RecordCount));
 end; // with
 




Подсветить HTML теги в RichEdit


 procedure HTMLSyntax(RichEdit: TRichEdit; TextCol,
   TagCol, DopCol: TColor);
 var
   i, iDop: Integer;
   s: string;
   Col: TColor;
   isTag, isDop: Boolean;
 begin
   iDop := 0;
   isDop := False;
   isTag := False;
   Col := TextCol;
   RichEdit.SetFocus;
 
   for i := 0 to Length(RichEdit.Text) do
   begin
     RichEdit.SelStart := i;
     RichEdit.SelLength := 1;
     s := RichEdit.SelText;
 
     if (s = '<') or (s = '{') then isTag := True;
 
     if isTag then
       if (s = '"') then
         if not isDop then
         begin
           iDop  := 1;
           isDop := True;
         end
         else
           isDop := False;
 
     if isTag then
       if isDop then
       begin
         if iDop <> 1 then Col := DopCol;
       end
       else
         Col := TagCol
     else
       Col := TextCol;
 
     RichEdit.SelAttributes.Color := Col;
 
     iDop := 0;
 
     if (s = '>') or (s = '}') then isTag := False;
   end;
 
   RichEdit.SelLength := 0;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   RichEdit1.Lines.BeginUpdate;
   HTMLSyntax(RichEdit1, clBlue, clRed, clGreen);
   RichEdit1.Lines.EndUpdate;
 end;
 




Как скопировать содержимое одного RichEdit в другой

TMemoryStream это самый простой инструмент взаимодействия между всеми VCL компонентами:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   MemoryStream: TMemoryStream;
 begin
   MemoryStream := TMemoryStream.Create;
   try
     RichEdit1.Lines.SaveToStream(MemoryStream);
     MemoryStream.Seek(0, soFromBeginning);
     RichEdit2.Lines.LoadFromStream(MemoryStream);
   finally
     MemoryStream.Free;
   end;
 end;
 




Преобразовать RGB в TColor и наоборот


 // RGB to TColor Values
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Edit1.Color := RGB(58, 110, 165);
 end;
 
 // TColor to RGB values
 procedure TForm1.Button2Click(Sender: TObject);
 var
   Color: Longint;
   r, g, b: Byte;
 begin
   Color := ColorToRGB(Edit1.Color);
   r     := Color;
   g     := Color shr 8;
   b     := Color shr 16;
   label1.Caption := ' Red  : ' + IntToStr(r) +
     ' Green: ' + IntToStr(g) +
     ' Blue : ' + IntToStr(b);
 end;
 




Как преобразовать цвета RGB в CMYK и обратно

Ниже представлены две функции RGBTOCMYK() и CMYKTORGB(), которые позволяют преобразовывать набор цветов RGB и CMYK.

Замечание: В цвете CMY чёрные тона достигаются путём одинаковых значений Циана, Магенты и Жёлтого чернил. Чёрные чернила используются только при чисто чёрных точках, для повышения контрастности и экономии цветных чернил. Как раз для этого предназначена третья функция ColorCorrectCMYK().


 procedure RGBTOCMYK(R: byte;
   G: byte;
   B: byte;
   var C: byte;
   var M: byte;
   var Y: byte;
   var K: byte);
 begin
   C := 255 - R;
   M := 255 - G;
   Y := 255 - B;
   if C < M then
     K := C
   else
     K := M;
   if Y < K then
     K := Y;
   if k > 0 then
   begin
     c := c - k;
     m := m - k;
     y := y - k;
   end;
 end;
 
 procedure CMYKTORGB(C: byte;
   M: byte;
   Y: byte;
   K: byte;
   var R: byte;
   var G: byte;
   var B: byte);
 begin
   if (Integer(C) + Integer(K)) < 255 then
     R := 255 - (C + K)
   else
     R := 0;
   if (Integer(M) + Integer(K)) < 255 then
     G := 255 - (M + K)
   else
     G := 0;
   if (Integer(Y) + Integer(K)) < 255 then
     B := 255 - (Y + K)
   else
     B := 0;
 end;
 
 procedure ColorCorrectCMYK(var C: byte;
   var M: byte;
   var Y: byte;
   var K: byte);
 var
   MinColor: byte;
 begin
   if C < M then
     MinColor := C
   else
     MinColor := M;
   if Y < MinColor then
     MinColor := Y;
   if MinColor + K > 255 then
     MinColor := 255 - K;
   C := C - MinColor;
   M := M - MinColor;
   Y := Y - MinColor;
   K := K + MinColor;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   R: byte;
   G: byte;
   B: byte;
   C: byte;
   M: byte;
   Y: byte;
   K: byte;
 begin
   R := 151;
   G := 81;
   B := 55;
   Memo1.Lines.Add('R = ' + IntToStr(R));
   Memo1.Lines.Add('G = ' + IntToStr(G));
   Memo1.Lines.Add('B = ' + IntToStr(B));
   Memo1.Lines.Add('-------------------');
   RGBTOCMYK(R, G, B, C, M, Y, K);
   Memo1.Lines.Add('C = ' + IntToStr(C));
   Memo1.Lines.Add('M = ' + IntToStr(M));
   Memo1.Lines.Add('Y = ' + IntToStr(Y));
   Memo1.Lines.Add('K = ' + IntToStr(K));
   Memo1.Lines.Add('-------------------');
   CMYKTORGB(C, M, Y, K, R, G, B);
   Memo1.Lines.Add('R = ' + IntToStr(R));
   Memo1.Lines.Add('G = ' + IntToStr(G));
   Memo1.Lines.Add('B = ' + IntToStr(B));
   Memo1.Lines.Add('-------------------');
   RGBTOCMYK(R, G, B, C, M, Y, K);
   c := c + 2;
   m := m + 2;
   y := y + 2;
   ColorCorrectCMYK(C, M, Y, K);
   Memo1.Lines.Add('C = ' + IntToStr(C));
   Memo1.Lines.Add('M = ' + IntToStr(M));
   Memo1.Lines.Add('Y = ' + IntToStr(Y));
   Memo1.Lines.Add('K = ' + IntToStr(K));
 end;
 




Как преобразовать RGB-цвет в оттенки серого



 function RgbToGray(RGBColor: TColor): TColor;
 var
   Gray: byte;
 begin
   Gray := Round((0.30 * GetRValue(RGBColor)) +
   (0.59 * GetGValue(RGBColor)) +
   (0.11 * GetBValue(RGBColor )));
   Result := RGB(Gray, Gray, Gray);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   h, w: integer;
 begin
   for w := 0 to Image1.Width-1 do
     for h := 0 to Image1.Height-1 do
       Image2.Canvas.Pixels[w, h] :=
       RgbToGray(Image2.Canvas.Pixels[w, h]);
 end;
 




Как конвертировать RGB в TColor


 function RGBToColor(R, G, B: Byte): TColor;
 begin
   Result := B shl 16 or G shl 8 or R;
 end;
 




Richedit сам меняет язык при перемещении

Автор: Максим Гуменюк

Заходит негр в компьютерную фирму и говорит:
- Здравствуйте, я ищу работу. У меня степень доктора наук по компьютерам.
Ему отвечают:
- Хорошо, мы вас возьмем. Для начала мы дадим вам 100 тысяч долларов в год, мы же вас пока плохо знаем. Согласны?
- Согласен.
- Да, мы вам дадим автомобиль, но покамест только "опель", потом что-нибудь лучше дадим. Согласны?
- Согласен.
- И еще мы вам дадим квартиру в хорошем районе, но пока только однокомнатную. Вас это устраивает?
Тут негр не выдерживает:
- Послушайте! Вы что, надо мной прикалываетесь?!
- Но ты же первый начал.

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

этот баг я обхожу так.

  1. я создаю потомка Richedit:
    • меню Component\New Component
    • указываю предком TRichedit
  2. Переписаю обработку события WM_INPUTLANGCHANGE, при этом я не вызываю обработчик предка, т.е. Richedit-а
  3. Заодно обрабатываю событие WM_INPUTLANGCHANGEREQUEST, которое сообщает, что пользователь изменил язык. Тут надо вызвать обработчик предка, а то не будет переключаться язык.

Вот что из этого получилось. Имеем исправленный компонент VCL с дополнительным событием.


 unit RichEditEx;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ComCtrls;
 
 type
   TLangChangeEvent = procedure(Sender: TObject; Lang: HKL) of object;
 
   TRichEditEx = class(TRichEdit)
   private
     FOnLangChange: TLangChangeEvent;
     procedure WMLangRequest(var M: TMessage); message WM_INPUTLANGCHANGEREQUEST;
     procedure WMLangChange(var M: TMessage); message WM_INPUTLANGCHANGE;
 
     { Private declarations }
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     property OnLangChange: TLangChangeEvent read FOnLangChange write
       FOnLangChange;
 
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 procedure tricheditex.WMLangRequest(var M: TMessage);
 begin
   if assigned(FOnLangChange) then
     FOnLangChange(self, m.LParam);
   inherited;
 end;
 
 procedure tricheditex.WMLangChange(var M: TMessage);
 begin
   m.Result := 1;
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TRichEditEx]);
 end;
 
 end.
 




Перейти на строку в RichEdit


 with Richedit1 do
 begin
      selstart := perform( EM_LINEINDEX, linenumber, 0 );
      perform( EM_SCROLLCARET, 0, 0 );
 end;
 
 {
 The EM_LINEINDEX message returns the character index of the first character
 on a given line, assigning that to selstart moves the caret to that position.
 The control will only automatically scroll the caret into view if it has
 the focus, thus the EM_SCROLLCARET.
 }
 




Печать из RichEdit

Автор: Nomadic


 procedure TForm1.Button1Click(Sender: TObject);
 var
   lst: TextFile;
   sc: Integer;
 begin
   //Printer.Orientation:=poPortraite
   AssignFile(lst,'prn');
   Rewrite(lst);
   sc:=0;
   for sc:=0 to RichEdit1.Lines.Count-1 do
     writeln(lst,StrToOem(RichEdit1.Lines[sc]));
   System.CloseFile(lst);
 end;
 




RichEdit замена текста

Штирлиц считает зарплату в рейхсмарках:
1022, 1023, 1024... "KB MEMORY OK", - подумал Штирлиц.


 // This example doesn't use TReplaceDialog 
 // Ohne Benutzung von TReplaceDialog 
 
 function Search_And_Replace(RichEdit: TRichEdit;
   SearchText, ReplaceText: string): Boolean;
 var
   startpos, Position, endpos: integer;
 begin
   startpos := 0;
   with RichEdit do
   begin
     endpos := Length(RichEdit.Text);
     Lines.BeginUpdate;
     while FindText(SearchText, startpos, endpos, [stMatchCase])<>-1 do
     begin
       endpos   := Length(RichEdit.Text) - startpos;
       Position := FindText(SearchText, startpos, endpos, [stMatchCase]);
       Inc(startpos, Length(SearchText));
       SetFocus;
       SelStart  := Position;
       SelLength := Length(SearchText);
       richedit.clearselection;
       SelText := ReplaceText;
     end;
     Lines.EndUpdate;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Search_And_Replace(Richedit1, 'OldText', 'NewText');
 end;
 




RichEdit поиск текста

Лев ходит по пустыне. В свое время физики предложили свою подборку методов решения задачи о поимке льва в пустыне и помещении его в клетку. А как решают ту же задачу различные деятели эпохи информационных технологий?
Программист на Паскале
Просматривает пустыню полным перебором. Обнаружив льва, строит вокруг него клетку.
Продвинутый программист на Паскале
Сортирует пустыню по возрастанию, после чего ищет льва двоичным поиском и строит вокруг него клетку. Если в процессе строительства лев уходит, бросает работу с криком "Range Check Error".
Программист на Си
Ищет в пустыне камень и помещает его в клетку. Присваивает камню значение "лев".
Продвинутый программист на Си
Присваивает пустыне значение "клетка".
Программист на Си++
Проектирует клетку таким образом, чтобы лев был ее составной частью. При инициализации клетки лев автоматически генерируется внутри.
Программист на Аде
Говорит, что лев и клетка - это объекты разных типов, и нечего морочить ему голову некорректными задачами.
Программист на Дельфи
Пишет во все конференции: "Народ, где взять компонент, который ищет в пустыне льва и помещает его в клетку?"
Железячник
Покупает в зоопарке львицу, делает ей операцию по смене пола и долго пытается запихнуть ее в клетку для канарейки.
Геймер-action'ер
Вооружается супершотганом, плазмаганом, рэйлганом, нэйлганом, шестиствольным пулеметом и бензопилой. Прочесывает пустыню, разнося все на своем пути. Ищет среди убитых льва и пытается обнаружить у него в животе желтый ключ. Если находит, отпирает им клетку и ждет награды.
Геймер-квестовик
Ищет по всей пустыне льва, находит, кладет в карман. Затем ищет по всей пустыне клетку, попутно пытаясь засунуть льва в чайник, башмак, телевизор, ведро с краской и другие попадающиеся на пути емкости.
Геймер-стратег
Поднимает по всей пустыне налоги, чтобы получить деньги на строительство клетки и охотничьих юнитов. К моменту окончания строительства все львы дохнут от голода.
Пользователь интернета
Заходит в свой любимый поисковик, пишет в строке Search "пустыня", ищет в найденном "лев в клетке". Если не находит, говорит, что задача неразрешима.
Вебмастер
Заходит в свой любимый поисковик и пишет в строке Search "пустыня + лев". Создает документ клетка.html и прописывает в нем ссылку на найденное.
Спамер
Рассылает по всей пустыне множество клеток, к каждой из которых привязана бумажка: "Если вы лев, пожалуйста, зайдите внутрь и закройтесь изнутри".
Троянщик
Делает то же, что и спамер, но вместо бумажки снаружи вешает внутри клетки картинку с голой львицей.
Админ
Выкапывает вокруг клетки ров, заполняет его концентрированной кислотой, устанавливает вдоль берега противотанковые ежи и противопехотные мины, все это опутывает колючей проволокой. К проволоке и прутьям клетки подключает провода от генератора высокого напряжения. Вешает на клетку 10 кодовых и 12 амбарных замков. Заходит внутрь, запирается на все замки, пускает ток, ключи проглатывает, коды забывает и говорит, что теперь ему никакой лев не страшен.
Хакер
Нейтрализует кислоту щелочью, перекусывает проволоку, проползает под ежами, перепрыгивает с шестом через мины, отключает ток, взламывает замки и входит в клетку. Не обнаружив внутри льва, матерится с досады, дает пинка админу и уходит обратно в пустыню.


 function SearchForText_AndSelect(RichEdit: TRichEdit; SearchText: string): Boolean;
 var
   StartPos, Position, Endpos: Integer;
 begin
   StartPos := 0;
   with RichEdit do
   begin
     Endpos := Length(RichEdit.Text);
     Lines.BeginUpdate;
     while FindText(SearchText, StartPos, Endpos, [stMatchCase])<>-1 do
     begin
       Endpos   := Length(RichEdit.Text) - startpos;
       Position := FindText(SearchText, StartPos, Endpos, [stMatchCase]);
       Inc(StartPos, Length(SearchText));
       SetFocus;
       SelStart  := Position;
       SelLength := Length(SearchText);
     end;
     Lines.EndUpdate;
   end;
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SearchForText_AndSelect(RichEdit1, 'Some Text');
 end;
 




Предел на размер текста в RichEdit

Автор: Richard Shotbolt

Я разместил на форме компонент TRichEdit, присвоил ему большой (104Кб) текст, но все попытки его редактирования свелись только в сторону уменьшения размера текста. Это проблема распределения памяти? Есть решение этой проблемы?

Я думаю что ответ на этот вопрос нужно искать в WIN95 API:


 SendMessage(MyRichEdit.Handle, EM_EXLIMITTEXT, 0, NewBigSize);
 




Подсчет слов в Richedit


 function GetWord: boolean;
 var
   s: string; {предположим что слова не содержат>255 символов}
   c: char;
 begin
   result := false;
   s := ' ';
   while not eof(f) do
   begin
     read(f, c);
     if not (c in ['a'..'z', 'A'..'Z' {,... и т.д, и т.п.}]) then
       break;
     s := s + c;
   end;
   result := (s <> ' ');
 end;
 
 procedure GetWordCount(TextFile: string);
 begin
   Count := 0;
   assignfile(f, TextFile);
   reset(f);
   while not eof(f) do
     if GetWord then
       inc(Count);
   closefile(f);
 end;
 




Получить слово под курсором в RichEdit


 uses
  RichEdit;
 
 procedure TForm1.RichEdit1MouseMove(Sender: TObject; Shift: TShiftState;
   X, Y: Integer);
 var
   iCharIndex, iLineIndex, iCharOffset, i, j: Integer;
   Pt: TPoint;
   s: string;
 begin
   with TRichEdit(Sender) do
   begin
     Pt := Point(X, Y);
     // Get Character Index from word under the cursor 
     iCharIndex := Perform(Messages.EM_CHARFROMPOS, 0, Integer(@Pt));
     if iCharIndex < 0 then Exit;
     // Get line Index 
     iLineIndex  := Perform(EM_EXLINEFROMCHAR, 0, iCharIndex);
     iCharOffset := iCharIndex - Perform(EM_LINEINDEX, iLineIndex, 0);
     if Lines.Count - 1 < iLineIndex then Exit;
     // store the current line in a variable 
     s := Lines[iLineIndex];
     // Search the beginning of the word 
     i := iCharOffset + 1;
     while (i > 0) and (s[i] <> ' ') do Dec(i);
     // Search the end of the word 
     j := iCharOffset + 1;
     while (j <= Length(s)) and (s[j] <> ' ') do Inc(j);
     // Display Text under Cursor 
     Caption := Copy(s, i, j - i);
   end;
 end;
 




Как отловить правый Enter (NumPad)


Автор: Full
WEB-сайт: http://full.hotmail.ru

Заходит в лифт программист и вспоминает что ему надо попасть на 12-ый этаж. Что делать? Ну, нажимает он "1", потом нажимает "2" и начинает судорожно искать кнопку "ENTER"

Для этого можно воспользоваться функцией GetHeapStatus:


 procedure TForm1.WMKeyDown(var message: TWMKeyDown);
 begin
   inherited;
   case message.CharCode of
     VK_RETURN:
     begin
       if (message.KeyData and $1000000 <> 0) then
       begin
         { ENTER on numeric keypad }
       end
       else
       begin
         { ENTER on the standard keyboard }
       end;
     end;
   end;
 end;
 




Как правильно печатать любые растровые и векторные изображения

Автор: Nomadic

Как известно, смертоносный вирус "Я люблю тебя" видоизменился, приняв новые обличья. Он последовательно мутировал в вирусы:
"Ты мне нравишься"
"Ты, конечно, мне нравишься, но давай просто будем друзьями"
"Послушай, я просто хотела познакомиться..."
"Ладно, я думаю, нам нужно прервать всякие отношения!"
"Да я была просто пьяная!"
"Перестань мне звонить, идиот!"
"Ну все! Ты козел, папа твой козел и мама твоя дура!"
и, наконец, в вирус "Пошел на...!

Маленькое пpедисловие.

Т.к. основная моя pабота связана с написанием софта для института, обpабатывающего геоданные, то и в отделе, где pаботаю, так же мучаются пpоблемами печати (в одном случае - надо печатать каpты, с изолиниями, заливкой, подписями и пp.; в дpугом случае - свои таблицы и сложные отpисовки по внешнему виду).

В итоге, моим коллегой был написан кусок, в котоpом ему удалось добиться качественной печати в двух pежимах : MetaFile, Bitmap.

Работа с MetaFile у нас сложилась уже истоpически - достаточно удобно описать ф-цию, котоpая что-то отpисовыват (хоть на экpане, хоть где), котоpая пpинимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а потом этот Metafile выбpасывать на печать.Достаточно pешить лишь пpоблемы масштабиpования, после чего - впеpед.

Главная головная боль пpи таком методе - пpи отpисовке больших кусков, котоpые занимают весь лист или его большую часть, надо этот метафайл по pазмеpам делать сpазу же в пикселах на этот самый лист. Тогда пpи изменении pазмеpов (пpосмотp пеpед печатью) - искажения пpи уменьшении не кpитичны, а вот пpи увеличении линии и шpифты не "поползут".

Итак :

Hабоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистом отдела матобеспечения СибHИИHП, г. Тюмень. Моего здесь только - пpиделывание свеpху надстpоек для личного использования.

Вся pабота сводится к следующим шагам :

  1. Получить необходимые коэф-ты;
  2. Постpоить метафайл или bmp для последующего вывода на печать;
  3. Hапечатать.
Hиже пpиведенный кусок (пpошу меня не пинать, но писал я и писал для достаточно кpивой pеализации с пеpедачей паpаметpов чеpез глобальные пеpеменные) я использую для того, чтобы получить коэф-ты пеpесчета.

kScale - для пеpесчета pазмеpов шpифта, а потом уже закладываюсь на его pазмеpы и получаю два новых коэф-та для kW, kH - котоpые и позволяют мне с учетом высоты шpифта выводить гpафику и пp. У меня пpи pаботе kW <> kH, что пpиходится учитывать.

Решили пункт 1.


 procedure SetKoeffMeta; // установить коэф-ты
 var
   PrevMetafile: TMetafile;
   MetaCanvas: TMetafileCanvas;
 begin
   PrevMetafile := nil;
   MetaCanvas := nil;
   try
     PrevMetaFile := TMetaFile.Create;
     try
       MetaCanvas := TMetafileCanvas.Create(PrevMetafile, 0);
       kScale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) /
         Screen.PixelsPerInch;
       MetaCanvas.Font.Assign(oGrid.Font);
       MetaCanvas.Font.Size := Round(oGrid.Font.Size * kScale);
       kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W');
       kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
     finally
       MetaCanvas.Free;
     end;
   finally
     PrevMetafile.Free;
   end;
 end;
 

Решаем 2.


 ...
 var
   PrevMetafile: TMetafile;
   MetaCanvas: TMetafileCanvas;
 begin
   PrevMetafile := nil;
   MetaCanvas := nil;
 
   try
     PrevMetaFile := TMetaFile.Create;
 
     PrevMetafile.Width := oWidth;
     PrevMetafile.Height := oHeight;
 
     try
       MetaCanvas := TMetafileCanvas.Create(PrevMetafile, 0);
 
       // здесь должен быть ваш код - с учетом масштабиpования.
       // я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок
       // вызываю лишь для отpисовки целой стpаницы.
       см.PS1.
     finally
       MetaCanvas.Free;
     end;
     ...
       PS1.Код, котоpый используется для отpисовки.oCanvas - TCanvas метафайла.
       ...
     var
     iHPage: integer; // высота страницы
     begin
       with oCanvas do
       begin
 
         iHPage := 3000;
 
         // залили область метайфайла белым - для дальнейшей pаботы
         Pen.Color := clBlack;
         Brush.Color := clWhite;
         FillRect(Rect(0, 0, 2000, iHPage));
 
         // установили шpифты - с учетом их дальнейшего масштабиpования
         oCanvas.Font.Assign(oGrid.Font);
         oCanvas.Font.Size := Round(oGrid.Font.Size * kScale);
 
         ...
           xEnd := xBegin;
         iH := round(RowHeights[iRow] * kH);
         for iCol := 0 to ColCount - 1 do
         begin
           x := xEnd;
           xEnd := x + round(ColWidths[iCol] * kW);
           Rectangle(x, yBegin, xEnd, yBegin + iH);
           r := Rect(x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1);
           s := Cells[iCol, iRow];
 
           // выписали в полученный квадрат текст
           DrawText(oCanvas.Handle, PChar(s), Length(s), r, DT_WORDBREAK or
             DT_CENTER);
 

Главное, что важно помнить на этом этапе - это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите - это уже ваше дело). В данном случае - я pаботаю с пеpеделанным TStringGrid, котоpый сделал для многостpаничной печати. Последний пункт - надо сфоpмиpованный метафайл или bmp напечатать.


 ...
 var
   Info: PBitmapInfo;
   InfoSize: Integer;
   Image: Pointer;
   ImageSize: DWORD;
   Bits: HBITMAP;
   DIBWidth, DIBHeight: Longint;
   PrintWidth, PrintHeight: Longint;
 begin
   ...
 
   case ImageType of
 
     itMetafile:
       begin
         if Picture.Metafile <> nil then
           Printer.Canvas.StretchDraw(Rect(aLeft, aTop, aLeft + fWidth, aTop +
             fHeight), Picture.Metafile);
       end;
 
     itBitmap:
       begin
         if Picture.Bitmap <> nil then
         begin
           with Printer, Canvas do
           begin
             Bits := Picture.Bitmap.Handle;
             GetDIBSizes(Bits, InfoSize, ImageSize);
             Info := AllocMem(InfoSize);
             try
               Image := AllocMem(ImageSize);
               try
                 GetDIB(Bits, 0, Info^, Image^);
                 with Info^.bmiHeader do
                 begin
                   DIBWidth := biWidth;
                   DIBHeight := biHeight;
                 end;
                 PrintWidth := DIBWidth;
                 PrintHeight := DIBHeight;
                 StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,
                   PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,
                   DIB_RGB_COLORS, SRCCOPY);
               finally
                 FreeMem(Image, ImageSize);
               end;
             finally
               FreeMem(Info, InfoSize);
             end;
           end;
         end;
       end;
   end;
 

В чем заключается идея PreView ? Остается имея на pуках Metafila, Bmp - отpисовать с пеpесчетом внешний вид изобpажения (надо высчитать левый веpхний угол и pазмеpы "пpедваpительно пpосматpиваемого" изобpажения. Для показа изобpажения достаточно использовать StretchDraw.

После того, как удалось вывести объекты на печать, пpоблему создания PreView pешили как "домашнее задание".

Кстати, когда мы pаботаем с Bmp, то для пpосмотpа используем следующий хинт - записываем битовый обpаз чеpез такую пpоцедуpу:


 w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),Screen.PixelsPerInch);
 h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),Screen.PixelsPerInch);
 PrevBmp.Width:=w;
 PrevBmp.Height:=h;
 PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp);
 
 aPicture.Assign(PrevBmp);
 

Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи печати - пpиходится bmp печатать именно так, как описано выше. Итог - наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но пpи этом - внешне - без каких-либо искажений и пp.

Imho, я для себя пpоблему печати pешил. Hа основе вышесказанного, сделал PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пp. на несколько листов, осталось кое-что допилить, но с пpинтеpом у меня пpоблем не будет уже точно :)

PS. Кстати, Андpей Аpистов на основе своей наpаботки сделал сложные геокаpты, котоpые по качеству не хуже, а может, и лучше, чем выдает Surfer (специалисты поймут). Hа ватмат.

PPS. Пpошу пpощения за возможные стилистические неточности - вpемя вышло, охpана уже pугается. Hо код - выдpан из pаботающих исходников.




Как научить Delphi делать правильное округление дробных чисел

Чем отличается законченный программист от простого пользователя? Пользователь думает, что в килобайте 1000 байт, а Программист думает, что в километре 1024 метра.


 function RoundStr(Zn: Real; kol_zn: Integer): Real;
 var
   snl, s, s0, s1, s2: string;
   n, n1: Real;
   nn, i: Integer;
 begin
   s := FloatToStr(Zn);
   if (Pos(',', s) > 0) and (Zn > 0) and
   (Length(Copy(s, Pos(',', s) + 1, length(s))) > kol_zn) then
   begin
     s0 := Copy(s, 1, Pos(',', s) + kol_zn - 1);
     s1 := Copy(s, 1, Pos(',', s) + kol_zn + 2);
     s2 := Copy(s1, Pos(',', s1) + kol_zn, Length(s1));
     n := StrToInt(s2) / 100;
     nn := Round(n);
     if nn >= 10 then
     begin
       snl := '0,';
       for i := 1 to kol_zn - 1 do
         snl := snl + '0';
       snl := snl + '1';
       n1 := StrToFloat(Copy(s, 1, Pos(',', s) + kol_zn)) + StrToFloat(snl);
       s := FloatToStr(n1);
       if Pos(',', s) > 0 then
         s1 := Copy(s, 1, Pos(',', s) + kol_zn);
     end
     else
       s1 := s0 + IntToStr(nn);
     if s1[Length(s1)] = ',' then
       s1 := s1 + '0';
     Result := StrToFloat(s1);
   end
   else
     Result := Zn;
 end;
 

или


 function RoundEx(X: Double; Precision: Integer ): Double;
 {
 Precision :
 1 - до целых
 10 - до десятых
 100 - до сотых
 ...
 }
 var
   ScaledFractPart, Temp: Double;
 begin
   ScaledFractPart := Frac(X) * Precision;
   Temp := Frac(ScaledFractPart);
   ScaledFractPart := Int(ScaledFractPart);
   if Temp >= 0.5 then
     ScaledFractPart := ScaledFractPart + 1;
   if Temp <= -0.5 then
     ScaledFractPart := ScaledFractPart - 1;
   RoundEx := Int(X) + ScaledFractPart / Precision;
 end;
 




Меню с правой стороны

Для выхода в меню нажмите Reset.

Главное меню окна – до боли знакомая вещь. Какое же извращение придумать с ним?..

Весьма необычно будет, если какой-нибудь пункт меню будет обособленно располагаться с правой стороны окна! (или несколько пунктов меню). Как же это сделать? Для этого нужно иметь: компонент MainMenu – 1 штука, форма – 1 штука, клава – 2 штуки (одна для того, чтобы набить ту чушь, что расположена ниже, а другая, являющаяся особой женского пола – для одних только вам известных забав). Начнём с первой (тем более, что кончить на второй всегда успеем!).

Всё что нужно сделать для этого – это создать главное меню, например, показанное на рисунке, и по созданию окна (событие OnCreate) написать следующий код:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   ModifyMenu(MainMenu1.Handle, 3, mf_ByPosition or mf_Popup or mf_Help,
   Help1.Handle, PChar(Help1.Caption));
 end;
 




Как в TEdit расположить текст справа


Новая серия книг Издательства Piter-press:
Windows 98: баг за багом.

Идея заключается в том, как сделать правое выравнивание текста в TEdit, не прибегая к написанию нового компонента.

Для этого можно воспользоваться канвасом. Так как TEdit не имеет канваса, то сперва мы создадим TControlCanvas а затем, прикрепим TEdit к этому канвасу.

Теперь нам доступны все свойства и методы TControlCanvas, поэтому мы спокойно можем настраивать в нём текст. Ниже приведёна процедура, реализующая всё вышесказанное.


 procedure RJustifyEdit(var ThisEdit : TEdit);
 var
   Left, Width: Integer;
   GString: string;
   Rgn: TRect;
   TheCanvas: TControlCanvas;
 begin
   TheCanvas := TControlCanvas.Create;
   try
     TheCanvas.Control := ThisEdit;
     GString := ThisEdit.Text;
     Rgn := ThisEdit.ClientRect;
     TheCanvas.FillRect(Rgn);
     Width := TheCanvas.TextWidth(GString);
     Left := Rgn.Right - Width - 1;
     TheCanvas.TextRect(Rgn, Left, 0, GString);
   finally
     TheCanvas.Free;
   end;
 end;
 




Как в TEdit расположить текст справа 2

Женится один программист. Друг его спрашивает:
- Ну, как невеста, хороша?
- Как топ-модель!
- Что, 90х60х90?
- Обижаешь: 128х64х128!

TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Memo1.Alignment := taRightJustify;
   Memo1.MaxLength := 24;
   Memo1.WantReturns := false;
   Memo1.WordWrap := false;
 end;
 
 procedure MultiLineMemoToSingleLine(Memo : TMemo);
 var
   t: string;
 begin
   t := Memo.Text;
   if Pos(#13, t) > 0 then
   begin
     while Pos(#13, t) > 0 do
       delete(t, Pos(#13, t), 1);
     while Pos(#10, t) > 0 do
       delete(t, Pos(#10, t), 1);
     Memo.Text := t;
   end;
 end;
 
 procedure TForm1.Memo1Change(Sender: TObject);
 begin
   MultiLineMemoToSingleLine(Memo1);
 end;
 
 procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
 begin
   MultiLineMemoToSingleLine(Memo1);
 end;
 




Окно в виде кольца

Умея создавать окно эллипсовидной формы, для вас не составит большого труда слепить что-нибудь наподобие того, что показано на рисунке. Всё, что вам нужно сделать - это создать не один, а два региона и объединить их, используя функцию CombineRgn, т.е. теперь по созданию окна можно написать что-то вроде этого:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   hsWindowRegion, hsWindowRegion2: Integer;
 begin
   hsWindowRegion := CreateEllipticRgn(50, 50, 350, 200);
   hsWindowRegion2:=CreateEllipticRgn(80, 80, 200, 150);
   CombineRgn(hsWindowRegion, hsWindowRegion, hsWindowRegion2, RGN_DIFF);
   SetWindowRgn(Handle, hsWindowRegion, true);
 end;
 

Мы уже знаем какую функцию нужно использовать для объединения регионов, но как же она действует и что же ей нужно указывать?

Вводятся следующие параметры:

  • Дескриптор региона назначения,
  • Дескриптор первого региона источника,
  • Дескриптор второго региона источника,
  • Режим взаимодействия регионов источников.

В качестве режима мы указали константу RGN_DIFF, а использовать можем:

  • RGN_AND - Создает пересечение из двух смешанных областей,
  • RGN_COPY - Создает копию области, идентифицированной дескриптором первой области источника,
  • RGN_DIFF - Выводит части первой области источника, которые не пересекаются со второй,
  • RGN_OR - Создает объединение двух смешанных областей,
  • RGN_XOR - Создает объединение двух смешанных областей за исключением зоны перекрытия.



Как повернуть Bitmap на любой угол



 const
   PixelMax = 32768;
 
 type
   pPixelArray = ^TPixelArray;
   TPixelArray = array [0..PixelMax-1] of TRGBTriple;
 
 procedure RotateBitmap_ads(SourceBitmap: TBitmap;
 out DestBitmap: TBitmap; Center: TPoint; Angle: Double);
 var
   cosRadians : Double;
   inX : Integer;
   inXOriginal : Integer;
   inXPrime : Integer;
   inXPrimeRotated : Integer;
   inY : Integer;
   inYOriginal : Integer;
   inYPrime : Integer;
   inYPrimeRotated : Integer;
   OriginalRow : pPixelArray;
   Radians : Double;
   RotatedRow : pPixelArray;
   sinRadians : Double;
 begin
   DestBitmap.Width := SourceBitmap.Width;
   DestBitmap.Height := SourceBitmap.Height;
   DestBitmap.PixelFormat := pf24bit;
   Radians := -(Angle) * PI / 180;
   sinRadians := Sin(Radians);
   cosRadians := Cos(Radians);
   for inX := DestBitmap.Height-1 downto 0 do
   begin
     RotatedRow := DestBitmap.Scanline[inX];
     inXPrime := 2*(inX - Center.y) + 1;
     for inY := DestBitmap.Width-1 downto 0 do
     begin
       inYPrime := 2*(inY - Center.x) + 1;
       inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians);
       inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians);
       inYOriginal := (inYPrimeRotated - 1) div 2 + Center.x;
       inXOriginal := (inXPrimeRotated - 1) div 2 + Center.y;
       if (inYOriginal >= 0) and (inYOriginal <= SourceBitmap.Width-1) and
       (inXOriginal >= 0) and (inXOriginal <= SourceBitmap.Height-1) then
       begin
         OriginalRow := SourceBitmap.Scanline[inXOriginal];
         RotatedRow[inY] := OriginalRow[inYOriginal]
       end
       else
       begin
         RotatedRow[inY].rgbtBlue := 255;
         RotatedRow[inY].rgbtGreen := 0;
         RotatedRow[inY].rgbtRed := 0
       end;
     end;
   end;
 end;
 
 {Usage:}
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Center : TPoint;
   Bitmap : TBitmap;
 begin
   Bitmap := TBitmap.Create;
   try
     Center.y := (Image.Height div 2)+20;
     Center.x := (Image.Width div 2)+0;
     RotateBitmap_ads(
     Image.Picture.Bitmap,
     Bitmap,
     Center,
     Angle);
     Angle := Angle + 15;
     Image2.Picture.Bitmap.Assign(Bitmap);
   finally
     Bitmap.Free;
   end;
 end;
 




Как повернуть Bitmap на любой угол 2


 procedure RotateBitmap(Bitmap: TBitmap; Angle: Double; BackColor: TColor);
 type TRGB = record
        B, G, R: Byte;
      end;
      pRGB = ^TRGB;
      pByteArray = ^TByteArray;
      TByteArray = array[0..32767] of Byte;
      TRectList = array [1..4] of TPoint;
 
 var x, y, W, H, v1, v2: Integer;
     Dest, Src: pRGB;
     VertArray: array of pByteArray;
     Bmp: TBitmap;
 
   procedure SinCos(AngleRad: Double; var ASin, ACos: Double);
   begin
     ASin := Sin(AngleRad);
     ACos := Cos(AngleRad);
   end;
 
   function RotateRect(const Rect: TRect; const Center: TPoint; Angle: Double): TRectList;
   var DX, DY: Integer;
       SinAng, CosAng: Double;
     function RotPoint(PX, PY: Integer): TPoint;
     begin
       DX := PX - Center.x;
       DY := PY - Center.y;
       Result.x := Center.x + Round(DX * CosAng - DY * SinAng);
       Result.y := Center.y + Round(DX * SinAng + DY * CosAng);
     end;
   begin
     SinCos(Angle * (Pi / 180), SinAng, CosAng);
     Result[1] := RotPoint(Rect.Left, Rect.Top);
     Result[2] := RotPoint(Rect.Right, Rect.Top);
     Result[3] := RotPoint(Rect.Right, Rect.Bottom);
     Result[4] := RotPoint(Rect.Left, Rect.Bottom);
   end;
 
   function Min(A, B: Integer): Integer;
   begin
     if A < B then Result := A
              else Result := B;
   end;
 
   function Max(A, B: Integer): Integer;
   begin
     if A > B then Result := A
              else Result := B;
   end;
 
   function GetRLLimit(const RL: TRectList): TRect;
   begin
     Result.Left := Min(Min(RL[1].x, RL[2].x), Min(RL[3].x, RL[4].x));
     Result.Top := Min(Min(RL[1].y, RL[2].y), Min(RL[3].y, RL[4].y));
     Result.Right := Max(Max(RL[1].x, RL[2].x), Max(RL[3].x, RL[4].x));
     Result.Bottom := Max(Max(RL[1].y, RL[2].y), Max(RL[3].y, RL[4].y));
   end;
 
   procedure Rotate;
   var x, y, xr, yr, yp: Integer;
       ACos, ASin: Double;
       Lim: TRect;
   begin
     W := Bmp.Width;
     H := Bmp.Height;
     SinCos(-Angle * Pi/180, ASin, ACos);
     Lim := GetRLLimit(RotateRect(Rect(0, 0, Bmp.Width, Bmp.Height), Point(0, 0), Angle));
     Bitmap.Width := Lim.Right - Lim.Left;
     Bitmap.Height := Lim.Bottom - Lim.Top;
     Bitmap.Canvas.Brush.Color := BackColor;
     Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
     for y := 0 to Bitmap.Height - 1 do begin
       Dest := Bitmap.ScanLine[y];
       yp := y + Lim.Top;
       for x := 0 to Bitmap.Width - 1 do begin
         xr := Round(((x + Lim.Left) * ACos) - (yp * ASin));
         yr := Round(((x + Lim.Left) * ASin) + (yp * ACos));
         if (xr > -1) and (xr < W) and (yr > -1) and (yr < H) then begin
           Src := Bmp.ScanLine[yr];
           Inc(Src, xr);
           Dest^ := Src^;
         end;
         Inc(Dest);
       end;
     end;
   end;
 
 begin
   Bitmap.PixelFormat := pf24Bit;
   Bmp := TBitmap.Create;
   try
     Bmp.Assign(Bitmap);
     W := Bitmap.Width - 1;
     H := Bitmap.Height - 1;
     if Frac(Angle) <> 0.0
       then Rotate
       else
     case Trunc(Angle) of
       -360, 0, 360, 720: Exit;
       90, 270: begin
         Bitmap.Width := H + 1;
         Bitmap.Height := W + 1;
         SetLength(VertArray, H + 1);
         v1 := 0;
         v2 := 0;
         if Angle = 90.0 then v1 := H
                         else v2 := W;
         for y := 0 to H do VertArray[y] := Bmp.ScanLine[Abs(v1 - y)];
         for x := 0 to W do begin
           Dest := Bitmap.ScanLine[x];
           for y := 0 to H do begin
             v1 := Abs(v2 - x)*3;
             with Dest^ do begin
               B := VertArray[y, v1];
               G := VertArray[y, v1+1];
               R := VertArray[y, v1+2];
             end;
             Inc(Dest);
           end;
         end
       end;
       180: begin
         for y := 0 to H do begin
           Dest := Bitmap.ScanLine[y];
           Src := Bmp.ScanLine[H - y];
           Inc(Src, W);
           for x := 0 to W do begin
             Dest^ := Src^;
             Dec(Src);
             Inc(Dest);
           end;
         end;
       end;
       else Rotate;
     end;
   finally
     Bmp.Free;
   end;
 end;
 
 // Использование
 RotateBitmap(Image1.Picture.Bitmap, StrToInt(Edit1.Text), clWhite);
 
 




Переворачиваем рабочий стол

Автор: William Egge

Весёлая программка, которая позволяет подшутить над Вашими друзьями:-]. Пример переворачивает десктоп и держит его в таком положение, до тех пор пока не кликнуть по нему мышкой. По мимо этого код содержит в себе довольно интересные моменты.

  1. В примере используется TDesktopCanvas, который получить доступ к десктопу через объект TCanvas.
  2. Так же в примере используется TQuickPixel, который позволяет увеличить скорость доступа к пикселям.

Скачайте исходник, откомпилируйте его, и поместите программку в папку "Автозагрузка" на компьютере Вашего друга и смело идите по своим делам :-).

Для завершения работы программки достаточно кликнуть по перевёрнутому экрану.

А теперь давайте разберёмся с исходником:

Класс TQuickPixel был сделан для быстрого доступа к пикселям, чтобы не возиться со строками развёртки. Для увеличения производительности, данный класс кэширует строки развёртки. Единственный недостаток данного класса заключается в том, что он устанавливает Ваш Bitmap в 24 бита.

Ниже представлен собственно сам код TQuickPixel.


 unit QuickPixel;
 
 interface
 uses
   Windows, Graphics;
 
 type
   TQuickPixel = class
   private
     FBitmap: TBitmap;
     FScanLines: array of PRGBTriple;
     function GetPixel(X, Y: Integer): TColor;
     procedure SetPixel(X, Y: Integer; const Value: TColor);
     function GetHeight: Integer;
     function GetWidth: Integer;
   public
     constructor Create(const ABitmap: TBitmap);
     property Pixel[X, Y: Integer]: TColor read GetPixel write SetPixel;
     property Width: Integer read GetWidth;
     property Height: Integer read GetHeight;
   end;
 
 implementation
 
 { TQuickPixel }
 
 constructor TQuickPixel.Create(const ABitmap: TBitmap);
 var
   I: Integer;
 begin
   inherited Create;
   FBitmap:= ABitmap;
   FBitmap.PixelFormat:= pf24bit;
   SetLength(FScanLines, FBitmap.Height);
   for I:= 0 to FBitmap.Height-1 do
     FScanLines[I]:= FBitmap.ScanLine[I];
 end;
 
 function TQuickPixel.GetHeight: Integer;
 begin
   Result:= FBitmap.Height;
 end;
 
 function TQuickPixel.GetPixel(X, Y: Integer): TColor;
 var
   P: PRGBTriple;
 begin
   P:= FScanLines[Y];
   Inc(P, X);
   Result:= (P^.rgbtBlue shl 16) or (P^.rgbtGreen shl 8) or P^.rgbtRed;
 end;
 
 function TQuickPixel.GetWidth: Integer;
 begin
   Result:= FBitmap.Width;
 end;
 
 procedure TQuickPixel.SetPixel(X, Y: Integer; const Value: TColor);
 var
   P: PRGBTriple;
 begin
   P:= FScanLines[Y];
   Inc(P, X);
   P^.rgbtBlue:= (Value and $FF0000) shr 16;
   P^.rgbtGreen:= (Value and $00FF00) shr 8;
   P^.rgbtRed:= Value and $0000FF;
 end;
 
 end.
 

Ну, надеюсь, вы с ним разобрались, перейдём же к самому проекту. Свойство окна BorderStyle установите в bsNone, свойство FormStyle - в fsStayOnTop, а свойству WindowState задайте значение wsMaximized. Вынесите на форму компонент TImage, его свойство Align выставьте в alClient, по нажатию на TImage напишите:


 Close;
 

Затем следующим образом опишите обработчик создания окна [событие OnCreate()]:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   B: TBitmap;
   Desktop: TDesktopCanvas;
   QP: TQuickPixel;
   X, Y: Integer;
   EndCopyIndex: Integer;
   Temp: TColor;
 begin
   Left:= 0;
   Top:= 0;
   Width:= Screen.Width;
   Height:= Screen.Height;
   B:= nil;
   Desktop:= nil;
   try
     Desktop:= TDesktopCanvas.Create;
     B:= TBitmap.Create;
     B.Width:= Screen.Width;
     B.Height:= Screen.Height;
     B.Canvas.CopyRect(Rect(0, 0, B.Width, B.Height),
     Desktop, Rect(0, 0, B.Width, B.Height));
     B.PixelFormat:= pf24bit;
     QP:= TQuickPixel.Create(B);
     try
       for Y:= 0 to (QP.Height div 2)-1 do
       begin
         EndCopyIndex:= (QP.Height-1)-Y;
         for X:= 0 to QP.Width-1 do
         begin
           Temp:= QP.Pixel[X, Y];
           QP.Pixel[X, Y]:= QP.Pixel[X, EndCopyIndex];
           QP.Pixel[X, EndCopyIndex]:= Temp;
         end;
       end;
     finally
       QP.Free;
     end;
     with Image1.Picture.Bitmap do
     begin
       Width:= Image1.Width;
       Height:= Image1.Height;
       Canvas.CopyRect(Rect(0, 0, Width, Height), B.Canvas,
       Rect(0, 0, Width, Height));
     end;
   finally
     B.Free;
     Desktop.Free;
   end;
 end;
 

Проверьте, все ли модули у вас подключены. Раздел uses должен выглядеть так:


 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, DesktopCanvas, QuickPixel;
 




Алгоритм поворота изображения


Сколько в Гейтса тортом не кидай, Windows лучше не станет.

Вот алгоритм поворота изображения. Пусть:

  • O - это центр поворота,
  • M - некая точка исходного изображения.

Для каждой точки M нужно найти угол alpha между отрезком OM и горизонталью и длину r отрезка OM. Теперь, чтобы повернуть изображение на угол beta, нужно каждой точке M присвоить цвет точки исходного изображения с координатами x,y, где


 x = xo + r * cos(alpha + beta)
 y = yo + r * sin(alpha + beta)
 

  • xo,yo - центр поворота,
  • r - длина отрезка OM

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

Эту программу можно сильно ускорить, если исходное изображение записать в массив и обращаться к реальной переменной, а не к свойству Canvas.Pixels.


 uses
   Math;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   bm, bm1: TBitMap;
   x, y: integer;
   r, a: single;
   xo, yo: integer;
   s, c: extended;
 begin
   bm := TBitMap.Create;
   bm.LoadFromFile('ex.bmp');
   xo := bm.Width div 2;
   yo := bm.Height div 2;
   bm1 := TBitMap.Create;
   bm1.Width := bm.Width;
   bm1.Height := bm.Height;
   a := 0;
   repeat
     for y := 0 to bm.Height - 1 do
     begin
       for x := 0 to bm.Width - 1 do
       begin
         r := sqrt(sqr(x - xo) + sqr(y - yo));
         SinCos(a + arctan2((y - yo), (x - xo)), s, c);
         bm1.Canvas.Pixels[x,y] := bm.Canvas.Pixels[
         round(xo + r * c), round(yo + r * s)];
       end;
       Application.ProcessMessages;
     end;
     Form1.Canvas.Draw(xo, yo, bm1);
     a := a + 0.05;
     Application.ProcessMessages;
   until
     Form1.Tag <> 0;
   bm.Destroy;
   bm1.Destroy;
 end;
 
 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
   Form1.Tag := 1;
 end;
 




Как вращать текст



 procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string);
 var
   hFont, Fontold: integer;
   DC: hdc;
   Fontname: string;
 begin
   if length(txt) = 0 then
     Exit;
   DC:= Screen.ActiveForm.Canvas.handle;
   SetBkMode(DC, transparent);
   Fontname:= Screen.ActiveForm.Canvas.Font.name;
   hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0,
   0,1,4,$10,2,4,PChar(Fontname));
   Fontold:= SelectObject(DC, hFont);
   TextOut(DC,x,y,PChar(txt), length(txt));
   SelectObject(DC, Fontold);
   DeleteObject(hFont);
 end;
 




Как вращать текст 2


 { Эта процедура устанавливает угол вывода текста
 для указанного Canvas, угол в градусах
 Шрифт должен быть TrueType }
 procedure CanvasSetTextAngle(c: TCanvas; d: single);
 var
   LogRec: TLOGFONT; { Информация о шрифте }
 begin
   {Читаем текущюю инф. о шрифте }
   GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
   { Изменяем угол }
   LogRec.lfEscapement := round(d*10);
   { Устанавливаем новые параметры }
   c.Font.Handle := CreateFontIndirect(LogRec);
 end;
 




Округление реальных типов

Автор: Steve Schafer

Если вам необходимо округлить число, то наиболее общее решение выглядит следующим образом:


 function RoundFloat(R: Extended; Decimals: Integer): Extended;
 var
   Factor: Extended;
 begin
   Factor := Int(Exp(Decimals * Ln(10)));
   Result := Round(Factor * R) / Factor;
 end;
 




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



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



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


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