Статьи по Delphi (020)…

Пример опроса мыши методами DirectInput.

Code: {****************************************************************************** * * * Придумал и написал Кода Виктор, Март 2002 * * * * Файл: main.pas * * Содержание: Пример буферизированного опроса мыши методами DirectInput * * * ******************************************************************************} Unit main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Gb1: TGroupBox; LbX0: TLabel; LbY0: TLabel; LbX: TLabel; LbY: TLabel; Lb1: TLabel; Lb2: TLabel; Lb3: TLabel; Lb4: TLabel; LbBtn1: TLabel; LbBtn2: TLabel; LbBtn3: TLabel; LbBtn4: TLabel; ImCursor: TImage; Procedure FormActivate(Sender: TObject); Procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Procedure FormDestroy(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. Procedure Idle( Sender: TObject; var Done: Boolean ); End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Uses. DirectInput8; //------------------------------------------------------------------------------ // Константы и глобальные переменные. //------------------------------------------------------------------------------ Var. LpDI8: IDirectInput8 = nil; LpDIMouse: IDirectInputDevice8 = nil; MouseX: LongInt = 0; MouseY: LongInt = 0; //------------------------------------------------------------------------------ // Имя: InitDirectInput(). // Описание: Производит инициализацию объектов DirectInput в программе. //------------------------------------------------------------------------------ Function InitDirectInput( hWnd: HWND ): Boolean; Var. Dipropdw: TDIPROPDWORD; // Структура для задания характеристик мыши. Begin. Result := FALSE; // Создаём главный объект DirectInput. If FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION, IID_IDirectInput8, lpDI8, nil ) ) then. Exit; LpDI8._AddRef(); // Создаём объект для работы с мышью. If FAILED( lpDI8.CreateDevice( GUID_SysMouse, lpDIMouse, nil ) ) then. Exit; LpDIMouse._AddRef(); // Устанавлаваем предопределённый формат данных. If FAILED( lpDIMouse.SetDataFormat( @c_dfDIMouse ) ) then. Exit; // Устанавливаем уровень кооперации. If FAILED( lpDIMouse.SetCooperativeLevel( hWnd, DISCL_FOREGROUND or. DISCL_EXCLUSIVE ) ) then. Exit; // Подготавливаем структуру TDIPROPDWORD, она поможет установить нам. // буферизированный опрос мыши. ZeroMemory( @dipropdw, SizeOf( TDIPROPDWORD ) ); Dipropdw.diph.dwSize := SizeOf( TDIPROPDWORD ); Dipropdw.diph.dwHeaderSize := SizeOf( TDIPROPHEADER ); Dipropdw.diph.dwObj := 0; Dipropdw.diph.dwHow := DIPH_DEVICE; // Изменяем х-ки всего устройства. Dipropdw.dwData := 16; // Размер буфера для данных (по умолчанию 0). // Устанавливаем размер буфера для мыши. If FAILED( lpDIMouse.SetProperty( DIPROP_BUFFERSIZE, dipropdw.diph ) ) then. Exit; // Захвытываем мышь. LpDIMouse.Acquire(); Result := TRUE; End; //------------------------------------------------------------------------------ // Имя: ReleaseDirectInput(). // Описание: Производит удаление объектов DirectInput. //------------------------------------------------------------------------------ Procedure ReleaseDirectInput(); Begin. // Удаляем объект для работы с мышью. If lpDIMouse <> nil then. Begin. LpDIMouse.Unacquire(); LpDIMouse._Release(); LpDIMouse := nil; End; // Удаляем главный объект DirectInput (всегда последним). If lpDI8 <> nil then. Begin. LpDI8._Release(); LpDI8 := nil; End; End; //------------------------------------------------------------------------------ // Имя: GetMouseCaps(). // Описание: Получает характеристики мыши (определяет кол-во кнопок). //------------------------------------------------------------------------------ Procedure GetMouseCaps(); Var. LpCaps: TDIDEVCAPS; // Структура для получения данных об элементах мыши. Begin. // Подготавливаем структуру TDIDEVCAPS (для получения характеристик мыши). ZeroMemory( @lpCaps, SizeOf( TDIDEVCAPS ) ); LpCaps.dwSize := SizeOf( TDIDEVCAPS ); // Получаем характеристики мыши, данные записывааются в структуру lpCaps. LpDIMouse.GetCapabilities( lpCaps ); // Приводим UI в соответствующий вид. With Form1 do. Begin. If lpCaps.dwButtons > 0 then. Begin. Lb1.Enabled := TRUE; lbBtn1.Enabled := TRUE; End; If lpCaps.dwButtons > 1 then. Begin. Lb2.Enabled := TRUE; lbBtn2.Enabled := TRUE; End; If lpCaps.dwButtons > 2 then. Begin. Lb3.Enabled := TRUE; lbBtn3.Enabled := TRUE; End; If lpCaps.dwButtons > 3 then. Begin. Lb4.Enabled := TRUE; lbBtn4.Enabled := TRUE; End; End; End; //------------------------------------------------------------------------------ // Имя: UpdateMouseState(). // Описание: Производит опрос мыши и выводит данные в окно. //------------------------------------------------------------------------------ Function UpdateMouseState( var(*по параметру*)dwX, dwY: DWORD ): Boolean; Var. Od: TDIDEVICEOBJECTDATA; DwElements: DWORD; Begin. Result := FALSE; // Обазательно обнуляем! DwX := 0; DwY := 0; DwElements := 1; // Пока количество опрашиваемых элементов мыши (оси, кнопки, колёсики ) <> 0. While dwElements <> 0 do. Begin. // Получаем данные от мыши. If lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od, DwElements, 0 ) = DIERR_INPUTLOST then. Begin. // Снова захватываем. LpDIMouse.Acquire(); // Если всё бесполезно, то выходим. If FAILED( lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od, DwElements, 0 ) ) then. Exit; End; With Form1 do. Begin. Case od.dwOfs of. DIMOFS_X: dwX := od.dwData; DIMOFS_Y: dwY := od.dwData; DIMOFS_BUTTON0: if od.dwData = $080 then lbBtn1.Caption := 'Нажата' Else lbBtn1.Caption := ''; DIMOFS_BUTTON1: if od.dwData = $080 then lbBtn2.Caption := 'Нажата' Else lbBtn2.Caption := ''; DIMOFS_BUTTON2: if od.dwData = $080 then lbBtn3.Caption := 'Нажата' Else lbBtn3.Caption := ''; DIMOFS_BUTTON3: if od.dwData = $080 then lbBtn4.Caption := 'Нажата' Else lbBtn4.Caption := ''; End; End; End; Result := TRUE; End; //------------------------------------------------------------------------------ // Имя: TForm1.Idle(). // Описание: Вызывает функцию опроса состояния мыши. //------------------------------------------------------------------------------ Procedure TForm1.Idle( Sender: TObject; var Done: Boolean ); Var. DwOffsX, DwOffsY: DWORD; // Смещение мыши. Begin. // Получаем данные и записываем их в offsX и offsY. If not UpdateMouseState( dwOffsX, dwOffsY ) then. Begin. MessageBox( Form1.Handle, 'Потеряно устройство ввода!', 'Ошибка', MB_ICONHAND ); Form1.Close(); End; // Вычисляем абсолютные координаты. Inc( mouseX, dwOffsX ); Inc( mouseY, dwOffsY ); LbX.Caption := Format( '%d', [ mouseX ] ); LbY.Caption := Format( '%d', [ mouseY ] ); ImCursor.Left := 234 + mouseX; // 234 - координата, если мы хотим, чтобы. ImCursor.Top := 234 + mouseY; // курсор был с начала работы в центре окна. Done := FALSE; End; //------------------------------------------------------------------------------ // Имя: TForm1.FormActivate(). // Описание: Производит инициализацию DirectInput при активизации окна. //------------------------------------------------------------------------------ Procedure TForm1.FormActivate(Sender: TObject); Begin. If not InitDirectInput( Form1.Handle ) then. Begin. MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!', 'Ошибка!', MB_ICONHAND ); Form1.Close(); End; // Получаем характеристики мыши (сколько кнопок?). Кстати, я не знаю - как. // определить, есть ли у мыши колёсико? GetMouseCaps(); // Приводим UI в соответствующий вид. LbBtn1.Caption := ''; LbBtn2.Caption := ''; LbBtn3.Caption := ''; LbBtn4.Caption := ''; Application.OnIdle := Idle; End; //------------------------------------------------------------------------------ // Имя: TForm1.FormKeyDown(). // Описание: Обрабатывает клавиатурный ввод. //------------------------------------------------------------------------------ Procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. If Key = VK_ESCAPE then Form1.Close(); End; //------------------------------------------------------------------------------ // Имя: TForm1.FormDestroy(). // Описание: Вызывается при удалении программы из памяти. //------------------------------------------------------------------------------ Procedure TForm1.FormDestroy(Sender: TObject); Begin. ReleaseDirectInput(); End; End.

Как можно работать с DDE?

Как можно работать с DDE под Delphi, используя вызовы API.

Кстати, достаточно легко: следующий пример демонстрирует как можно научить общаться клиентскую программу с программой-сервером. Обе программы полностью созданы на Delphi. В итоге мы имеет 2 проекта, 3 формы и 3 модуля. Для работы с DDE-запросами данный пример использует методы DDE ML API.

Сервер должен начать свою работу перед тем, как клиент будет загружен. Данный пример демонстрирует 3 способа взаимодействия между клиентом и сервером:

Клиент может "пропихивать" (POKE) данные на сервер.

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

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

Как работает программа.

Ниже приведены 8 файлов, сконкатенированных в единое целое. Каждый файл имеет следующую структуру:

{ *** НАЧАЛО КОДА FILENAME.EXT *** } КОД { *** КОНЕЦ КОДА FILENAME.EXT *** },

Поэтому вам остается всего-лишь взять код, расположенный между маркерами { *** }, скопировать в файл с соответствующим именем, и собрать оба проекта в среде Delphi.

Code: { *** НАЧАЛО КОДА DDEMLCLI.DPR *** }. Program Ddemlcli; Uses. Forms, Ddemlclu in 'DDEMLCLU.PAS' {Form1}; {$R *.RES}. Begin. Application.CreateForm(TForm1, Form1); Application.Run; End. { *** КОНЕЦ КОДА DDEMLCLI.DPR *** }. { *** НАЧАЛО КОДА DDEMLCLU.DFM *** }. Object Form1: TForm1. Left = 197. Top = 95. Width = 413. Height = 287. HorzScrollBar.Visible = False. VertScrollBar.Visible = False. Caption = 'Демонстрация DDEML, Клиентское приложение' Font.Color = clWindowText. Font.Height = -13. Font.Name = 'System' Font.Style = []. Menu = MainMenu1. PixelsPerInch = 96. OnCreate = FormCreate. OnDestroy = FormDestroy. OnShow = FormShow. TextHeight = 16. Object PaintBox1: TPaintBox. Left = 0. Top = 0. Width = 405. Height = 241. Align = alClient. Color = clWhite. ParentColor = False. OnPaint = PaintBox1Paint. End. Object MainMenu1: TMainMenu. Top = 208. Object File1: TMenuItem. Caption = '&Файл' Object exit1: TMenuItem. Caption = 'В&ыход' OnClick = exit1Click. End. End. Object DDE1: TMenuItem. Caption = '&DDE' Object RequestUpdate1: TMenuItem. Caption = '&Запрос на обновление' OnClick = RequestUpdate1Click. End. Object AdviseofChanges1: TMenuItem. Caption = '&Сообщение об изменениях' OnClick = AdviseofChanges1Click. End. Object N1: TMenuItem. Caption = '-' End. Object PokeSomeData: TMenuItem. Caption = '&Пропихивание данных' OnClick = PokeSomeDataClick. End. End. End. End. { *** КОНЕЦ КОДА DDEMLCLU.DFM *** }.

Midas и COM. Советы и Приемы.

Автор: Bill Todd.

Перевод: Михаил Голованов.

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

Вы можете не нуждаться в распределенных приложениях, но вы нуждаетесь в Midas.

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

Транзакции в настольных базах данных.

Если Вы работаете с Paradox или Dbase таблицами, и нуждаетесь в поддержке транзакций, Вы ограничены, потому что единственный уровень изоляции транзакции read uncommited (также грязное чтение). Вдобавок ко всему, невозможно произвести откат при возникновении аварийной ситуации , т.е аварийный отказ может оставлять вашу базу данных в несогласованном состоянии. Однако, если Вы используете ClientDataSet, Вы действительно получаете транзакции и автоматический откат в аварийных ситуациях.

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

ClientDataSet содержит все изменения в памяти в свойстве Delta, пока Вы не вызывете ApplyUpdates. Это означает, что при аварии произойдет откат транзакции, потому что все изменения в Delta будут потеряны. Единственый недостаток в использовании ClientDataSet, то, что аварийный отказ, во время выполнения ApplyUpdates, может все еще оставлять вашу базу данных в несогласованном состоянии. Однако, Если Вы вызываете ApplyUpdates достаточно часто достаточно, чтобы гарантировать, что только несколько записей модифицируются, модификация происходит в течении долей секунды. Это - намного меньшее окно уязвимости, чем использование локальных транзакций, где база данных может находится в несогласованном состоянии с момента первого изменения до проведения или отката транзакции. Для пользователя, вручную вносящего изменения, это время может быть несколько минут.

Улучшение параллельности работы баз данных.

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

Кэшируемые изменения были первоначально добавлены к Delphi, чтобы преодолеть эту проблему, и ClientDataSet является развитием этой идеи. Если Вы используете ClientDataSets, чтобы редактировать ваши данные, изменения сохранятся в локальной копии данных - в кэше ClientDataSet. База данных не содержит сделанных изменений, пока Вы не вызываете ApplyUpdates. Так как транзакция активна на сервере только, во время обращения к ApplyUpdates т.е обычно на доли секунды, блокировки не задерживается в течение длительного времени, и параллелизм улучшается.

Обеспечение нескольких платформ серверов баз данных.

Предположим, что Вы пишете приложение для рынка. Вы знаете, что некоторые из ваших потенциальных заказчиков уже выбрали платформу сервера базы данных, так что Вы должны создать версии вашего приложения, для выполнения на Oracle, Microsoft SQL и Interbase. Компоненты, используемые, для работы с базами данных различны. Для Interbase самый лучший выбор Interbase Express, для MS SQL , самый лучший выбор - ADO Express и для Oracle, Вы можете использовать или BDE или ADO Express.

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

Создание модульных приложений.

Объединение Midas с COM позволяет, создавать большие сложные приложения из множества COM серверов, которые совместно используют общее соединение базы данных. Использование Midas и COM вместе:

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

Делает многомодульные приложения проще - устанавлиаются только те модули, которые нужны пользователю.

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

Делает модули доступными независимо от языка программирования, который используется.

Делает проще поддержку баз данных.

Следующие разделы этой статьи посвящены разработке простого приложения, которое показывает совместное использование Midas и COM. Также рассмотрены обратные вызовы от COM сервера к клиенту. Мы разработаем модульное приложение. Создадим очень простой пример, который состоит из Midas сервера и двух Midas клиентов. Первый Midas клиент будет главной формой приложения, отображающей данные из таблиц Customer и Order. Это приложение - EXE. Второй Midas клиент отобразит данные из таблицы Order и выполнен как внутренний сервер автоматизации. Midas сервер также выполнен как DLL внутреннего сервера автоматизации. Роли трех модулей могут немного смутить Вас. Чтобы разъяснить кто, что делает следующая таблица показывает каждое приложение и его назначение.

Приложение Назначение Роль Реализация.

DemoDllServer Обеспечивает соединение с базой данных Midas сервер ActiveX Library DLL.

DemoClient Содержит форму для таблицы Customer Midas клиент.

COM клиент EXE.

DemoOrders Содержит форму таблицы Order Midas клиент COM сервер ActiveX Library DLL.

Разработка Midas сервера.

Midas сервер имеет только одну необычную возможность. Он выполнен как DLL, так что не будет отображать форму или показывать иконку в панели задач. В то время как наличие отображаемой формы сервера может быть допустимым для распределенной системы, где никто обычно не видит экран машины - Midas сервера, это - плохая идея для приложения, где сервер и клиент выполнится на одном PC, потому что пользователь может быть введен в заблуждение дополнительной иконкой и может пробовать закрывать сервер. Решение состоит в том, чтобы выполнить Midas сервер как DLL, так чтобы он не имел никакого интерфейса пользователя. При выполнении Midas сервера в виде DLL также улучшается производительность. Для создания Midas сервера как DLL, выберем меню File | New из меню и затем закладку ActiveX репозитария объектов. Двойным щелчком левой кнопки мыши на иконке ActiveX Library создаст новый проект ActiveX библиотеки. С тех пор как Midas использует COM, чтобы обработать связь между Midas клиентом и Midas сервером, ActiveX библиотека используется, чтобы обеспечить требуемую поддержку COM.

После этого процесс создания сервера в виде DLL ничем не отличается от разработки EXE. Выберите File | New, перейдите к странице Multitier, и добавьте Remote Data Module (удаленный модуль данных ) к проекту. Рисунок 1 показывает удаленный модуль данных для типового приложения.

Рис.1. Удаленный модуль данных.

Это приложение написано в типичном стиле клиента / сервера. Когда пользователь открывает приложение, никакие данные не отображаются. Взамен пользователь должен ввести некоторые критерии выбора(выделения), которые выберут приемлемое число записей. Чтобы реализовать этот подход, предложение SQL для CustomerQry компонента:

Code: Select * from Customer. Where CustNo = -1.

OpenGL - радиальное размытие.

Code: // К заголовку RadialBlur(For OpenGL). // Данный код работает правильно только, если в пректе 0 форм , // а сам код введен в DPR файл! Program RadialBlur; Uses. Windows, Messages, OpenGL; Const. WND_TITLE = 'Radial Blur'; FPS_TIMER = 1; // Timer to calculate FPS. FPS_INTERVAL = 1000; // Calculate FPS every 1000 ms. Type. TVector = array[0..2] of glFloat; Var. H_Wnd: HWND; // Global window handle. H_DC: HDC; // Global device context. H_RC: HGLRC; // OpenGL rendering context. Keys: array[0..255] of Boolean; // Holds keystrokes. FPSCount: Integer = 0; // Counter for FPS. ElapsedTime: Integer; // Elapsed time between frames. // Textures. BlurTexture: glUint; // An Unsigned Int To Store The Texture Number. // User vaiables. Angle: glFloat; Vertexes: array[0..3] of TVector; Normal: TVector; // Lights and Materials. GlobalAmbient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0); // Set Ambient Lighting To Fairly Dark Light (No Color). Light0Pos: array[0..3] of glFloat = (0.0, 5.0, 10.0, 1.0); // Set The Light Position. Light0Ambient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0); // More Ambient Light. Light0Diffuse: array[0..3] of glFloat = (0.3, 0.3, 0.3, 1.0); // Set The Diffuse Light A Bit Brighter. Light0Specular: array[0..3] of glFloat = (0.8, 0.8, 0.8, 1.0); // Fairly Bright Specular Lighting. LmodelAmbient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0); // And More Ambient Light. {$R *.RES}. Procedure glBindTexture(target: GLenum; texture: GLuint); Stdcall; external opengl32; Procedure glGenTextures(n: GLsizei; var textures: GLuint); Stdcall; external opengl32; Procedure glCopyTexSubImage2D(target: GLenum; level, xoffset, Yoffset, x, y: GLint; width, height: GLsizei); Stdcall; external opengl32; Procedure glCopyTexImage2D(target: GLenum; level: GLint; InternalFormat: GLenum; x, y: GLint; Width, height: GLsizei; border: GLint); stdcall; external opengl32; {------------------------------------------------------------------} { Function to convert int to string. (No sysutils = smaller EXE) }. {------------------------------------------------------------------} // using SysUtils increase file size by 100K. Function IntToStr(Num: Integer): string; Begin. Str(Num, result); End; Function EmptyTexture: glUint; Var. Txtnumber: glUint; Data: array of glUint; PData: Pointer; Begin. // Create Storage Space For Texture Data (128x128x4). GetMem(pData, 128 * 128 * 4); GlGenTextures(1, txtnumber); // Create 1 Texture. GlBindTexture(GL_TEXTURE_2D, txtnumber); // Bind The Texture. GlTexImage2D(GL_TEXTURE_2D, 0, 4, 128, 128, 0, GL_RGBA, GL_UNSIGNED_BYTE, pData); GlTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); GlTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); Result := txtNumber; End; Procedure ReduceToUnit(var vector: array of glFloat); Var. Length: glFLoat; Begin. // Calculates The Length Of The Vector. Length := sqrt((vector[0] * vector[0]) + (vector[1] * vector[1]) + (vector[2] * vector[2])); If Length = 0 then. Length := 1; Vector[0] := vector[0] / length; Vector[1] := vector[1] / length; Vector[2] := vector[2] / length; End; Procedure calcNormal(const v: array of TVector; Var cross: array of glFloat); Var. V1, v2: array[0..2] of glFloat; Begin. // Finds The Vector Between 2 Points By Subtracting. // The x,y,z Coordinates From One Point To Another. // Calculate The Vector From Point 1 To Point 0. V1[0] := v[0][0] - v[1][0]; // Vector 1.x=Vertex[0].x-Vertex[1].x. V1[1] := v[0][1] - v[1][1]; // Vector 1.y=Vertex[0].y-Vertex[1].y. V1[2] := v[0][2] - v[1][2]; // Vector 1.z=Vertex[0].y-Vertex[1].z. // Calculate The Vector From Point 2 To Point 1. V2[0] := v[1][0] - v[2][0]; // Vector 2.x=Vertex[0].x-Vertex[1].x. V2[1] := v[1][1] - v[2][1]; // Vector 2.y=Vertex[0].y-Vertex[1].y. V2[2] := v[1][2] - v[2][2]; // Vector 2.z=Vertex[0].z-Vertex[1].z. // Compute The Cross Product To Give Us A Surface Normal. Cross[0] := v1[1] * v2[2] - v1[2] * v2[1]; // Cross Product For Y - Z. Cross[1] := v1[2] * v2[0] - v1[0] * v2[2]; // Cross Product For X - Z. Cross[2] := v1[0] * v2[1] - v1[1] * v2[0]; // Cross Product For X - Y. ReduceToUnit(cross); // Normalize The Vectors. End; // Draws A Helix. Procedure ProcessHelix; Const. Twists = 5; MaterialColor: array[1..4] of glFloat = (0.4, 0.2, 0.8, 1.0); Specular: array[1..4] of glFloat = (1, 1, 1, 1); Var. X, y, z: glFLoat; Phi, theta: Integer; R, u, v: glFLoat; Begin. GlLoadIdentity(); // Reset The Modelview Matrix. // Eye Position (0,5,50) Center Of Scene (0,0,0), Up On Y Axis. GluLookAt(0, 5, 50, 0, 0, 0, 0, 1, 0); GlPushMatrix(); // Push The Modelview Matrix. GlTranslatef(0, 0, -50); // Translate 50 Units Into The Screen. GlRotatef(angle / 2.0, 1, 0, 0); // Rotate By angle/2 On The X-Axis. GlRotatef(angle / 3.0, 0, 1, 0); // Rotate By angle/3 On The Y-Axis. GlMaterialfv(GL_FRONT_AND_BACK, GL_AMBIENT_AND_DIFFUSE, @MaterialColor); GlMaterialfv(GL_FRONT_AND_BACK, GL_SPECULAR, @specular); R := 1.5; // Radius. GlBegin(GL_QUADS); // Begin Drawing Quads. Phi := 0; While phi < 360 do. Begin. Theta := 0; While theta < 360 * twists do. Begin. V := phi / 180 * pi; // Calculate Angle Of First Point ( 0 ). U := theta / 180.0 * pi; // Calculate Angle Of First Point ( 0 ). X := cos(u) * (2 + cos(v)) * r; // Calculate x Position (1st Point). Y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (1st Point). Z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (1st Point). Vertexes[0][0] := x; // Set x Value Of First Vertex. Vertexes[0][1] := y; // Set y Value Of First Vertex. Vertexes[0][2] := z; // Set z Value Of First Vertex. V := (phi / 180 * pi); // Calculate Angle Of Second Point ( 0 ). U := ((theta + 20) / 180 * pi); // Calculate Angle Of Second Point ( 20 ). X := cos(u) * (2 + cos(v)) * r; // Calculate x Position (2nd Point). Y := sin(u) * (2 + cos(v)) * r; // Calculate y Positio. Z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (2nd Point). Vertexes[1][0] := x; // Set x Value Of Second Vertex. Vertexes[1][1] := y; // Set y Value Of Second Vertex. Vertexes[1][2] := z; // Set z Value Of Second Vertex. V := (phi + 20) / 180 * pi; // Calculate Angle Of Third Point ( 20 ). U := (theta + 20) / 180 * pi; // Calculate Angle Of Third Point ( 20 ). X := cos(u) * (2 + cos(v)) * r; // Calculate x Position (3rd Point). Y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (3rd Point). Z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (3rd Point). Vertexes[2][0] := x; // Set x Value Of Third Vertex. Vertexes[2][1] := y; // Set y Value Of Third Vertex. Vertexes[2][2] := z; // Set z Value Of Third Vertex. V := (phi + 20) / 180 * pi; // Calculate Angle Of Fourth Point ( 20 ). U := theta / 180 * pi; // Calculate Angle Of Fourth Point ( 0 ). X := cos(u) * (2 + cos(v)) * r; // Calculate x Position (4th Point). Y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (4th Point). Z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (4th Point). Vertexes[3][0] := x; // Set x Value Of Fourth Vertex. Vertexes[3][1] := y; // Set y Value Of Fourth Vertex. Vertexes[3][2] := z; // Set z Value Of Fourth Vertex. CalcNormal(vertexes, normal); // Calculate The Quad Normal. GlNormal3f(normal[0], normal[1], normal[2]); // Set The Normal. // Render The Quad. GlVertex3f(vertexes[0][0], vertexes[0][1], vertexes[0][2]); GlVertex3f(vertexes[1][0], vertexes[1][1], vertexes[1][2]); GlVertex3f(vertexes[2][0], vertexes[2][1], vertexes[2][2]); GlVertex3f(vertexes[3][0], vertexes[3][1], vertexes[3][2]); Theta := theta + 20; End; Phi := phi + 20; End; GlEnd(); // Done Rendering Quads. GlPopMatrix(); // Pop The Matrix. End; // Set Up An Ortho View. Procedure ViewOrtho; Begin. GlMatrixMode(GL_PROJECTION); // Select Projection. GlPushMatrix(); // Push The Matrix. GlLoadIdentity(); // Reset The Matrix. GlOrtho(0, 640, 480, 0, -1, 1); // Select Ortho Mode (640x480). GlMatrixMode(GL_MODELVIEW); // Select Modelview Matrix. GlPushMatrix(); // Push The Matrix. GlLoadIdentity(); // Reset The Matrix. End; // Set Up A Perspective View. Procedure ViewPerspective; Begin. GlMatrixMode(GL_PROJECTION); // Select Projection. GlPopMatrix(); // Pop The Matrix. GlMatrixMode(GL_MODELVIEW); // Select Modelview. GlPopMatrix(); // Pop The Matrix. End; // Renders To A Texture. Procedure RenderToTexture; Begin. GlViewport(0, 0, 128, 128); // Set Our Viewport (Match Texture Size). ProcessHelix(); // Render The Helix. GlBindTexture(GL_TEXTURE_2D, BlurTexture); // Bind To The Blur Texture. // Copy Our ViewPort To The Blur Texture (From 0,0 To 128,128... No Border). GlCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0); GlClearColor(0.0, 0.0, 0.5, 0.5); // Set The Clear Color To Medium Blue. // Clear The Screen And Depth Buffer. GlClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); GlViewport(0, 0, 640, 480); // Set Viewport (0,0 to 640x480). End; // Draw The Blurred Image. Procedure DrawBlur(const times: Integer; const inc: glFloat); Var. Spost, alpha, alphainc: glFloat; I: Integer; Begin. Alpha := 0.2; GlEnable(GL_TEXTURE_2D); // Enable 2D Texture Mapping. GlDisable(GL_DEPTH_TEST); // Disable Depth Testing. GlBlendFunc(GL_SRC_ALPHA, GL_ONE); // Set Blending Mode. GlEnable(GL_BLEND); // Enable Blending. GlBindTexture(GL_TEXTURE_2D, BlurTexture); // Bind To The Blur Texture. ViewOrtho(); // Switch To An Ortho View. Alphainc := alpha / times; // alphainc=0.2f / Times To Render Blur. GlBegin(GL_QUADS); // Begin Drawing Quads. // Number Of Times To Render Blur. For I := 0 to times - 1 do. Begin. GlColor4f(1.0, 1.0, 1.0, alpha); // Set The Alpha Value (Starts At 0.2). GlTexCoord2f(0 + spost, 1 - spost); // Texture Coordinate ( 0, 1 ). GlVertex2f(0, 0); // First Vertex ( 0, 0 ). GlTexCoord2f(0 + spost, 0 + spost); // Texture Coordinate ( 0, 0 ). GlVertex2f(0, 480); // Second Vertex ( 0, 480 ). GlTexCoord2f(1 - spost, 0 + spost); // Texture Coordinate ( 1, 0 ). GlVertex2f(640, 480); // Third Vertex ( 640, 480 ). GlTexCoord2f(1 - spost, 1 - spost); // Texture Coordinate ( 1, 1 ). GlVertex2f(640, 0); // Fourth Vertex ( 640, 0 ). // Gradually Increase spost (Zooming Closer To Texture Center). Spost := spost + inc; // Gradually Decrease alpha (Gradually Fading Image Out). Alpha := alpha - alphainc; End; GlEnd(); // Done Drawing Quads. ViewPerspective(); // Switch To A Perspective View. GlEnable(GL_DEPTH_TEST); // Enable Depth Testing. GlDisable(GL_TEXTURE_2D); // Disable 2D Texture Mapping. GlDisable(GL_BLEND); // Disable Blending. GlBindTexture(GL_TEXTURE_2D, 0); // Unbind The Blur Texture. End; {------------------------------------------------------------------} { Function to draw the actual scene }. {------------------------------------------------------------------} Procedure glDraw(); Begin. // Clear The Screen And The Depth Buffer. GlClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); GlLoadIdentity(); // Reset The View. RenderToTexture; // Render To A Texture. ProcessHelix; // Draw Our Helix. DrawBlur(25, 0.02); // Draw The Blur Effect. Angle := ElapsedTime / 5; // Update angle Based On The Clock. End; {------------------------------------------------------------------} { Initialise OpenGL }. {------------------------------------------------------------------} Procedure glInit(); Begin. GlClearColor(0.0, 0.0, 0.0, 0.5); // Black Background. GlShadeModel(GL_SMOOTH); // Enables Smooth Color Shading. GlClearDepth(1.0); // Depth Buffer Setup. GlDepthFunc(GL_LESS); // The Type Of Depth Test To Do. GlHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST); File: //Realy Nice perspective calculations. GlEnable(GL_DEPTH_TEST); // Enable Depth Buffer. GlEnable(GL_TEXTURE_2D); // Enable Texture Mapping. // Set The Ambient Light Model. GlLightModelfv(GL_LIGHT_MODEL_AMBIENT, @LmodelAmbient); // Set The Global Ambient Light Model. GlLightModelfv(GL_LIGHT_MODEL_AMBIENT, @GlobalAmbient); GlLightfv(GL_LIGHT0, GL_POSITION, @light0Pos); // Set The Lights Position. GlLightfv(GL_LIGHT0, GL_AMBIENT, @light0Ambient); // Set The Ambient Light. GlLightfv(GL_LIGHT0, GL_DIFFUSE, @light0Diffuse); // Set The Diffuse Light. // Set Up Specular Lighting. GlLightfv(GL_LIGHT0, GL_SPECULAR, @light0Specular); GlEnable(GL_LIGHTING); // Enable Lighting. GlEnable(GL_LIGHT0); // Enable Light0. BlurTexture := EmptyTexture(); // Create Our Empty Texture. GlShadeModel(GL_SMOOTH); // Select Smooth Shading. GlMateriali(GL_FRONT, GL_SHININESS, 128); End; {------------------------------------------------------------------} { Handle window resize }. {------------------------------------------------------------------} Procedure glResizeWnd(Width, Height: Integer); Begin. If (Height = 0) then // prevent divide by zero exception. Height := 1; GlViewport(0, 0, Width, Height); // Set the viewport for the OpenGL window. GlMatrixMode(GL_PROJECTION); // Change Matrix Mode to Projection. GlLoadIdentity(); // Reset View. GluPerspective(45.0, Width / Height, 2.0, 200.0); // Do the perspective calculations. Last value = max clipping depth. GlMatrixMode(GL_MODELVIEW); // Return to the modelview matrix. GlLoadIdentity(); // Reset View. End; {------------------------------------------------------------------} { Processes all the keystrokes }. {------------------------------------------------------------------} Procedure ProcessKeys; Begin. End; {------------------------------------------------------------------} { Determines the application's response to the messages received }. {------------------------------------------------------------------} Function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; Begin. Case (Msg) of. WM_CREATE: Begin. // Insert stuff you want executed when the program starts. End; WM_CLOSE: Begin. PostQuitMessage(0); Result := 0. End; // Set the pressed key (wparam) to equal true so we can check if its pressed. WM_KEYDOWN: Begin. Keys[wParam] := True; Result := 0; End; // Set the released key (wparam) to equal false so we can check if its pressed. WM_KEYUP: Begin. Keys[wParam] := False; Result := 0; End; WM_SIZE: // Resize the window with the new width and height. Begin. GlResizeWnd(LOWORD(lParam), HIWORD(lParam)); Result := 0; End; WM_TIMER: // Add code here for all timers to be used. Begin. If wParam = FPS_TIMER then. Begin. FPSCount := Round(FPSCount * 1000 / FPS_INTERVAL); // calculate to get per Second incase intercal is. // less or greater than 1 second. SetWindowText(h_Wnd, PChar(WND_TITLE + ' [' + intToStr(FPSCount). + ' FPS]')); FPSCount := 0; Result := 0; End; End; Else. // Default result if nothing happens. Result := DefWindowProc(hWnd, Msg, wParam, lParam); End; End; {---------------------------------------------------------------------} { Properly destroys the window created at startup (no memory leaks) }. {---------------------------------------------------------------------} Procedure glKillWnd(Fullscreen: Boolean); Begin. If Fullscreen then // Change back to non fullscreen. Begin. ChangeDisplaySettings(devmode(nil^), 0); ShowCursor(True); End; // Makes current rendering context not current, and releases the device. // context that is used by the rendering context. If (not wglMakeCurrent(h_DC, 0)) then. MessageBox(0, 'Release of DC and RC failed!', 'Error', MB_OK or MB_ICONERROR); // Attempts to delete the rendering context. If (not wglDeleteContext(h_RC)) then. Begin. MessageBox(0, 'Release of rendering context failed!', 'Error', MB_OK or MB_ICONERROR); H_RC := 0; End; // Attemps to release the device context. If ((h_DC = 1) and (ReleaseDC(h_Wnd, h_DC) < > 0)) then. Begin. MessageBox(0, 'Release of device context failed!', 'Error', MB_OK or MB_ICONERROR); H_DC := 0; End; // Attempts to destroy the window. If ((h_Wnd < > 0) and (not DestroyWindow(h_Wnd))) then. Begin. MessageBox(0, 'Unable to destroy window!', 'Error', MB_OK or. H_Wnd := 0; End; // Attempts to unregister the window class. If (not UnRegisterClass('OpenGL', hInstance)) then. Begin. MessageBox(0, 'Unable to unregister window class!', 'Error', MB_OK or MB_ICONERROR); HInstance := 0; End; End; {--------------------------------------------------------------------} { Creates the window and attaches a OpenGL rendering context to it }. {--------------------------------------------------------------------} Function glCreateWnd(Width, Height: Integer; Fullscreen: Boolean; PixelDepth: Integer): Boolean; Var. WndClass: TWndClass; // Window class. DwStyle: DWORD; // Window styles. DwExStyle: DWORD; // Extended window styles. DmScreenSettings: DEVMODE; // Screen settings (fullscreen, etc...). PixelFormat: GLuint; // Settings for the OpenGL rendering. H_Instance: HINST; // Current instance. Pfd: TPIXELFORMATDESCRIPTOR; // Settings for the OpenGL window. Begin. H_Instance := GetModuleHandle(nil); File: //Grab An Instance For Our Window. ZeroMemory(@wndClass, SizeOf(wndClass)); // Clear the window class structure. With wndClass do // Set up the window class. Begin. Style := CS_HREDRAW or // Redraws entire window if length changes. CS_VREDRAW or // Redraws entire window if height changes. CS_OWNDC; // Unique device context for the window. LpfnWndProc := @WndProc; // Set the window procedure to our func WndProc. HInstance := h_Instance; HCursor := LoadCursor(0, IDC_ARROW); LpszClassName := 'OpenGL'; End; If (RegisterClass(wndClass) = 0) then // Attemp to register the window class. Begin. MessageBox(0, 'Failed to register the window class!', 'Error', MB_OK or MB_ICONERROR); Result := False; Exit. End; // Change to fullscreen if so desired. If Fullscreen then. Begin. ZeroMemory(@dmScreenSettings, SizeOf(dmScreenSettings)); With dmScreenSettings do. Begin // Set parameters for the screen setting. DmSize := SizeOf(dmScreenSettings); DmPelsWidth := Width; // Window width. DmPelsHeight := Height; // Window height. DmBitsPerPel := PixelDepth; // Window color depth. DmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL; End; // Try to change screen mode to fullscreen. If (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN) = DISP_CHANGE_FAILED) then. Begin. MessageBox(0, 'Unable to switch to fullscreen!', 'Error', MB_OK or MB_ICONERROR); Fullscreen := False; End; End; // If we are still in fullscreen then. If (Fullscreen) then. Begin. DwStyle := WS_POPUP or // Creates a popup window. WS_CLIPCHILDREN // Doesn't draw within child windows. Or WS_CLIPSIBLINGS; // Doesn't draw within sibling windows. DwExStyle := WS_EX_APPWINDOW; // Top level window. ShowCursor(False); // Turn of the cursor (gets in the way). End. Else. Begin. DwStyle := WS_OVERLAPPEDWINDOW or // Creates an overlapping window. WS_CLIPCHILDREN or // Doesn't draw within child windows. WS_CLIPSIBLINGS; // Doesn't draw within sibling windows. DwExStyle := WS_EX_APPWINDOW or // Top level window. WS_EX_WINDOWEDGE; // Border with a raised edge. End; // Attempt to create the actual window. H_Wnd := CreateWindowEx(dwExStyle, // Extended window styles. 'OpenGL', // Class name. WND_TITLE, // Window title (caption). DwStyle, // Window styles. 0, 0, // Window position. Width, Height, // Size of window. 0, // No parent window. 0, // No menu. H_Instance, // Instance. Nil); // Pass nothing to WM_CREATE. If h_Wnd = 0 then. Begin. GlKillWnd(Fullscreen); // Undo all the settings we've changed. MessageBox(0, 'Unable to create window!', 'Error', MB_OK or MB_ICONERROR); Result := False; Exit; End; // Try to get a device context. H_DC := GetDC(h_Wnd); If (h_DC = 0) then. Begin. GlKillWnd(Fullscreen); MessageBox(0, 'Unable to get a device context!', 'Error', MB_OK or MB_ICONERROR); Result := False; Exit; End; // Settings for the OpenGL window. With pfd do. Begin. // Size Of This Pixel Format Descriptor. NSize := SizeOf(TPIXELFORMATDESCRIPTOR); NVersion := 1; // The version of this data structure. DwFlags := PFD_DRAW_TO_WINDOW // Buffer supports drawing to window. Or PFD_SUPPORT_OPENGL // Buffer supports OpenGL drawing. Or PFD_DOUBLEBUFFER; // Supports double buffering. IPixelType := PFD_TYPE_RGBA; // RGBA color format. CColorBits := PixelDepth; // OpenGL color depth. CRedBits := 0; // Number of red bitplanes. CRedShift := 0; // Shift count for red bitplanes. CGreenBits := 0; // Number of green bitplanes. CGreenShift := 0; // Shift count for green bitplanes. CBlueBits := 0; // Number of blue bitplanes. CBlueShift := 0; // Shift count for blue bitplanes. CAlphaBits := 0; // Not supported. CAlphaShift := 0; // Not supported. CAccumBits := 0; // No accumulation buffer. CAccumRedBits := 0; // Number of red bits in a-buffer. CAccumGreenBits := 0; // Number of green bits in a-buffer. CAccumBlueBits := 0; // Number of blue bits in a-buffer. CAccumAlphaBits := 0; // Number of alpha bits in a-buffer. CDepthBits := 16; // Specifies the depth of the depth buffer. CStencilBits := 0; // Turn off stencil buffer. CAuxBuffers := 0; // Not supported. ILayerType := PFD_MAIN_PLANE; // Ignored. BReserved := 0; // Number of overlay and underlay planes. DwLayerMask := 0; // Ignored. DwVisibleMask := 0; // Transparent color of underlay plane. DwDamageMask := 0; // Ignored. End; // Attempts to find the pixel format supported by a device context that. // is the best match to a given pixel format specification. PixelFormat := ChoosePixelFormat(h_DC, @pfd); If (PixelFormat = 0) then. Begin. GlKillWnd(Fullscreen); MessageBox(0, 'Unable to find a suitable pixel format', 'Error', MB_OK or MB_ICONERROR); Result := False; Exit; End; // Sets the specified device context's pixel format to the format. // specified by the PixelFormat. If (not SetPixelFormat(h_DC, PixelFormat, @pfd)) then. Begin. GlKillWnd(Fullscreen); MessageBox(0, 'Unable to set the pixel format', 'Error', MB_OK or MB_ICONERROR); Result := False; Exit; End; // Create a OpenGL rendering context. H_RC := wglCreateContext(h_DC); If (h_RC = 0) then. Begin. GlKillWnd(Fullscreen); MessageBox(0, 'Unable to create an OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR); Result := False; Exit; End; // Makes the specified OpenGL rendering context the calling. // thread's current rendering context. If (not wglMakeCurrent(h_DC, h_RC)) then. Begin. GlKillWnd(Fullscreen); MessageBox(0, 'Unable to activate OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR); Result := False; Exit; End; // Initializes the timer used to calculate the FPS. SetTimer(h_Wnd, FPS_TIMER, FPS_INTERVAL, nil); // Settings to ensure that the window is the topmost window. ShowWindow(h_Wnd, SW_SHOW); SetForegroundWindow(h_Wnd); SetFocus(h_Wnd); // Ensure the OpenGL window is resized properly. GlResizeWnd(Width, Height); GlInit(); Result := True; End; {--------------------------------------------------------------------} { Main message loop for the application }. {--------------------------------------------------------------------} Function WinMain(hInstance: HINST; hPrevInstance: HINST; LpCmdLine: PChar; nCmdShow: Integer): Integer; stdcall; Var. Msg: TMsg; Finished: Boolean; DemoStart, LastTime: DWord; Begin. Finished := False; // Perform application initialization: If not glCreateWnd(640, 480, FALSE, 32) then. Begin. Result := 0; Exit; End; DemoStart := GetTickCount(); // Get Time when demo started. // Main message loop: While not finished do. Begin. // Check if there is a message for this window. If (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then. Begin. // If WM_QUIT message received then we are done. If (msg.message = WM_QUIT) then. Finished := True. Else. Begin // Else translate and dispatch the message to this window. TranslateMessage(msg); DispatchMessage(msg); End; End. Else. Begin. Inc(FPSCount); // Increment FPS Counter. LastTime := ElapsedTime; ElapsedTime := GetTickCount() - DemoStart; // Calculate Elapsed Time. // Average it out for smoother movement. ElapsedTime := (LastTime + ElapsedTime) div 2; GlDraw(); // Draw the scene. SwapBuffers(h_DC); // Display the scene. If (keys[VK_ESCAPE]) then // If user pressed ESC then set finised TRUE. Finished := True. Else. ProcessKeys; // Check for any other key Pressed. End; End; GlKillWnd(FALSE); Result := msg.wParam; End; Begin. WinMain(hInstance, hPrevInst, CmdLine, CmdShow); End.

Обзор компонентов InternetExpress.

Аннотация.

Среди новых возможностей Delphi5 одной из наиболее заметных является технология InternetExpress - средство публикации и обработки данных в Internet на основе технологии MIDAS. InternetExpress представляет собой набор компонентов, позволяющих реализовать полный цикл клиент-серверной обработки данных на базе Internet с использованием как уже имевшихся в распоряжении разработчиков на Delphi средств (создание Internet-приложений на основе ISAPI/NSAPI, ASP и CGI), так и новых средств, например стандарта XML (eXtended Markup Language - дальнейшего развития стандарта HTML, позволяющего реализовать объектный подход к созданию Internet-контента и структурированную передачу и обработку данных через Internet).

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

Краткое описание технологии InternetExpress.

До недавнего времени решения на основе MIDAS можно было задействовать в Internet, создав MIDAS-клиент на Java и используя в качестве транспорта данных протокол IIOP. В Delphi 5 появилась возможность для передачи данных пакеты XML (XML data packets), что автоматически сделало пакеты данных MIDAS частью открытого стандарта.

В InternetExpress используются средства поддержки XML из MIDAS 3. Поскольку в настоящее время даже лидеры среди Internet-броузеров (Netscape Navigator и Microsoft Internet Explorer) не поддерживают (или поддерживают частично) представление данных по стандарту XML, в InternetExpress реализована специальная технология поддержки XML на основе JavaScript и DHTML, позволяющая использовать InternetExpress даже с теми броузерами, которые вообще не имеют поддержки XML. В частности, для экспериментов с InternetExpress были использованы Netscape Navigator 4.61 и Internet Explorer 4.01, для которых поддержка XML не была реализована. В IE 5.0 уже встроена поддержка XML, поэтому большинство решений на основе этого стандарта требуют для работы наличия этого броузера, что, конечно, далеко не всегда желательно и (или) возможно.

Кстати, если приложение InternetExpress работает с IE 5, то порождаемый XML-пакет будет специальным образом оптимизироваться.

В броузерах, не имеющих встроенной поддержки XML, пакеты данных в этом формате разбираются с использованием специального модуля JavaScript (xmldom.js), который реализует спецификацию DOM (Document Object Model), позволяющую создавать HTML-клиенты для обработки данных на базе обычных web-серверов. Серверные приложения разрабатываются с использованием таких спецификаций взаимодействия с web-сервером, как ISAPI/NSAPI, CGI и ASP, которые позволяют канализировать запросы к данным и сами данные между клиентами и сервером приложений MIDAS.

Компоненты InternetExpress.

С точки зрения VCL (Visual Components Library, библиотеки визуальных компонент) InternetExpress представляет собой две компоненты базового набора: TXMLBroker и TMIDASPageProducer. TXMLBroker отвечает собственно за формирование XML-пакета, реакцию на изменения в данных и оповещение о действиях, выполняемых клиентом. TMIDASPageProducer отвечает за формирование сборного DHTML-документа, который, собственно, и является клиентским приложением, поскольку содержит все те визуальные элементы, которые соответствуют структуре пакета данных XML. В этот документ передаются XML-пакеты, формируемые компонентом XMLBroker. В тот момент, когда от клиентского приложения приходит сообщение о необходимости передать изменения в данных на сервер приложений, TMIDASPageProducer осуществляет опрос каждого из элементов управления HTML, формирует пакет с данными, подлежащими обновлению и передает их серверу приложений. Таким образом, обработка данных на клиенте происходит с использованием средств HTML, а передача структурированных данных к клиенту и изменений от него - при помощи пакетов данных XML.

Эти компоненты помещаются в web-модуль (WebModule) серверного приложения, для создания которого может быть использован специальный мастер (File->New->Web Server Application).

WebModule является наследником TDataModule и обладает некоторыми дополнительными возможностями по сравнению с базовым классом, которые позволяют обмениваться данными с Web-клиентами. В дополнение к базовому набору InternetExpress имеется несколько компонентов, например TReconcilePageProducer, которые устанавливаются из дополнительных пакетов (packages), входящих в поставку Delphi, и, конечно, существует возможность наследования базовых классов и создания на их основе собственных компонентов с расширенными возможностями.

Помимо визуальных компонентов InternetExpress состоит из ряда классов и интерфейсов, которые будут рассмотрены в разделе "Обзор компонентов InternetExpress".

Пакеты данных XML.

Пакеты данных XML используются InternetExpress как транспортные контейнеры для передачи данных от серверной части приложения к клиентской и обратно. В качестве примера можно привести пакет данных, сформированный демонстрационным приложением, описываемым далее в этом обзоре:

<FIELD fieldname="Species Name" attrname="Species_Name" fieldtype="string".

WIDTH="40"/>

</FIELDS>

</METADATA>

<ROW Species_No="90020" Category="Triggerfish" Common_Name="Clown Triggerfish".

Species_Name="Ballistoides conspicillum" Length__cm_="50".

Length_In="19.68503937007874" Notes="Also known as the big spotted triggerfish.

Inhabits outer reef areas and feeds upon crustaceans and mollusks by crushing.

Them with powerful teeth. They are voracious eaters, and divers report seeing.

The clown triggerfish devour beds of pearl oysters.

Do not eat.

This fish. According to an 1878 account, "the poisonous flesh acts.

Primarily upon the nervous tissue of the stomach, occasioning violent spasms.

Of that organ, and shortly afterwards all the muscles of the body. The frame.

Becomes rocked with spasms, the tongue thickened, the eye fixed, the breathing.

Laborious, and the patient expires in a paroxysm of extreme suffering.

"

Not edible.

Range is Indo-Pacific.

And East Africa to Somoa.
"/>

<ROW Species_No="90030" Category="Snapper" Common_Name="Red Emperor".

Species_Name="Lutjanus sebae" Length__cm_="60" Length_In="23.62204724409449".

Notes="Called seaperch in Australia. Inhabits the areas around lagoon coral.

Reefs and sandy bottoms.

The red emperor is a valuable food.

Fish and considered a great sporting fish that fights with fury when hooked.

The flesh of an old fish is just as tender to eat as that of the very young.



Range is from the Indo-Pacific to East Africa.
"/>

</ROWDATA>

</DATAPACKET>

Структура пакета данных XML.

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

В том случае, если пакет представляет собой разностный пакет данных XML (XML delta packet), в строку PARAMS метаданных добавляется фрагмент вида DATASET_DELTA="1", то есть строка PARAMS будет выглядеть следующим образом:

...

</FIELDS>

</METADATA>

...

</ROWDATA>

</DATAPACKET>

Структура разностного пакета данных XML.

Серверная часть Internet-приложения на основе InternetExpress.

Серверная часть такого приложения состоит из исполняемого модуля, написанного в данном случае на Delphi 5, и включающего WebModule, упомянутый выше, а также файлов-библиотек JavaScript, которые в случае отсутствия поддержки XML броузером передаются на сторону клиента, а именно:

Библиотека Назначение.

Xmldom.js XML-парзер, соответствующий стандарту DOM, написанный на JavaScript. Позволяет броузерам использовать пакеты данных XML не имея встроенной поддержки этого стандарта. Для IE5 этот файл не передается, а XML-пакет специальными образом оптимизируется.

Xmldb.js Библиотека классов доступа к данным, обслуживающая пакеты данных XML.

Xmldisp.js Библиотека описания связей между классами доступа к данным в xmldb.js и элементами HTML.

Xmlerrdisp.js Библиотека классов для обработки конфликтных ситуаций при внесении изменений в данные. Использует пакет разности данных (XML delta packet) и пакет ошибок (XML error packet).

Xmlshow.js Библиотека функций для отображения окон с данными XML.

Таблица 1. Библиотеки JavaScript, входящие в состав серверной части приложения InternetExpress.

Примечание:

Для того, чтобы серверная часть приложения InternetExpress корректно обслуживала клиентов без поддержки XML, эти библиотеки (по умолчанию) должны быть размещены в том же каталоге, что и исполняемый модуль серверной части приложения, или же для каждого из компонентов типа TMIDASPageProducer и его наследников свойство IncludePathURL должно указывать место расположения этих файлов (в относительном или полном формате), например /iexpress/, как в демонстрационном примере к данной статье.

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

Примечание:

Ссылка на xmldom.js требуется только в том случае, если броузер не имеет встроенной поддержки XML.

Клиентская часть приложения InternetExpress.

Клиентская часть приложения на основе InternetExpress представляет собой собственно HTML-документ, порожденный одним или более компонентами типа (или его наследниками) TMIDASPageProducer, исполняемый (интерпретируемый) тем или иным броузером. Как уже было сказано выше, этот документ может содержать элементы отображения и управления, соответствующие структуре пакета данных XML. К ним также могут добавляться элементы управления, формирующие HTML-аналог DBnavigator из состава Delphi VCL в том случае, если соответствующие параметры были заданы при настройке PageProducer, а также другие элементы управления HTML, как связанные с обработкой данных, так и составляющие независимые части интерфейса, например группу для ввода имени пользователя и пароля с целью авторизации доступа к данным системы.

Схема работы приложения InternetExpress.

В целом, схема работы приложения на основе InternetExpress выглядит следующим образом:

Броузер обращается по ссылке (URL) к серверному приложению InternetExpress, которое возвращает HTML-документ, являющийся, как правило, некой отправной точкой в алгоритме обработки данных.

По запросу пользователя серверное приложение сначала возвращает очередной HTML-документ, содержащий (при необходимости) ссылки на библиотеки JavaScript, отвечающие за обработку XML-пакетов, а затем уже этот документ посылает запрос серверной части приложения, которая затем посылает клиенту данные в виде пакетов XML, интерпретируемых соответствующими библиотеками JavaScrip.

После того, как пользователь просмотрел набор данных и, при необходимости, внес в них изменения, он имеет возможность передать изменения серверной части приложения. Это процесс запускается событием, которое, как правило, связано с "кнопкой" "Apply Updates" (Внести изменения) и передается серверной части приложения InternetExpress, а именно - компоненту TMIDASPageProducer. Все изменения в данных передаются серверной части приложения в виде разностных пакетов XML (XML delta packets).

Серверная часть получает информацию об изменениях в данных и использует сервер приложений для внесения этих изменений в базу данных. При возникновении конфликта (reconcile error) имеется возможность сформировать HTML-вариант Reconcile Dialog из состава Delphi или разрешить конфликтную ситуацию автоматически, включив компонент TReconcilePageProducer в состав серверной части приложения.

Компонент TMIDASPageProducer.

Данный компонент отвечает за сборку HTML-документа, отображающего "живой" набор данных, получаемый от сервера приложений, или же "типового" HTML-документа, не осуществляющего обработку данных вообще. Компонент может быть использован для создания Web-приложений на основе MIDAS, которые будут отображать информацию, содержащуюся в базе данных, получая ее через сервер приложений, и передавать ее HTML-клиентам в пакетах данных XML. Реализация компонента находится в модуле (unit) dsprod.

При создании Web-модуля ссылка на один из таких компонентов (свойство Producer) должна быть выставлена у соответствующих элементов TWebActionItem.

TMIDASPageProducer создает HTML-документ на основе шаблона. В отличие от других компонентов типа Producer, этот компонент имеет шаблон "по умолчанию" (default), в котором содержатся несколько описаний верхнего уровня, на основе которых в других компонентах порождаются HTML-документы. Помимо шаблонов содержание конечного документа может быть сгенерировано на основе данных, порождаемых другими компонентами, добавленными в Web-модуль, получено от другого компонента TMIDASPageProducer через свойство TMIDASPageProducer.Content и так далее.

Примечание:

Связывание HTML-элементов с пакетами данных XML и обработчиками событий HTTP в TMIDASPageProducer осуществляется исключительно по именам HTML-объектов и соответствующих событий, за счет чего становится возможным редактировать сгенерированный HTML-шаблон любым из средств работы с HTML-документами, придавая ему необходимый внешний вид и дополняя логику обработки данных вставками JavaScript, поскольку даже при изменении свойств объектов, порожденных встроенным редактором TMIDASPageProducer, внесенные другими средствами изменения потеряны не будут. В демонстрационном приложении, описываемом ниже в шаблон HTML-документа был изменен с целью добавить заголовок страницы с данными.

Расширение функциональности обработчика шаблонов (свойство TMIDASPageProducer.HTMLdoc) возможно за счет реализации обработчика события TMIDASPageProducer.OnHTMLtag или перекрытия метода TMIDASPageProducer.DoTagEvent. Реализовав свою собственную версию обработчика этого события вы получаете возможность использовать в теле шаблона документа собственные тэги, заменяя их на этапе генерации HTML-документа соответствующими значениями. Пример такого подхода показан в демонстрационном приложении InetXCenter из состава Delphi 5 (модуль InetXCenterProd.pas).

И конечно, возможности InternetExpress можно практически неограниченно расширять, реализуя специальные компоненты-наследники от TMIDASPageProducer и компонентов, используемых для формирования содержимого документа (TDataForm, TQueryForm и так далее). Создавая на их основе специализированные компоненты, вы получаете возможность максимально упростить создание конечного решения на основе InternetExpress за счет реализации специфических возможностей, необходимых вашему Internet-приложению. Например, в демонстрационном приложении InetXCenter за счет создания наследника от компонента TMIDASPageProducer реализованы такие возможности, как генерация таких полей заголовка HTML-документа, как , задание комментариев и описаний, автоматически подставляемых в конечный HTML-документ и другие расширения базового компонента.

Описание компонента TMIDASPageProducer.

Поскольку TMIDASPageProducer (TCustomMIDASPageProducer) является собственно генератором содержания HTML-документа, в его описание входит интерфейс IWebContent, который, собственно, это содержание и предоставляет. Заголовок соответствующего класса выглядит следующим образом:

TCustomMIDASPageProducer = class(TPageItemProducer, IWebContent,

IWebComponentEditor, IScriptEditor).

Помимо IWebContent в описании класса участвуют еще два интерфейса: IWebComponentEditor и IScriptEditor, которые, соответственно, являются средствами связи с design-time редактором для компонентов типа TWebComponent и HTML-кода.

Свойство Назначение.

HTMLDoc Собственно базовый шаблон, содержащий включения (includes) описателей содержания.

HTMLFile Аналогично HTMLDoc, но с привязкой к файлу.

IncludePathURL Путь к библиотекам JavaScript (в формате URL). Может быть как полный (http://someserver/iexpress/), т.е. с указанием имени сервера и так далее, так и относительный (/iexpress/).

Styles Описание стилей "по умолчанию" для генерации HTML-документа. Это свойство является аналогом файла стилей, используемого для создания канонических Web-страниц.

StylesFile Аналогично Styles, но с привязкой к файлу стилей.

WebPageItems Список специальных компонентов, определяющих ключевые элементы документа. Основные типы PageItem включают: DataForm, QueryForm и LayoutGroup. Каждый из базовых компонентов TWebPageItem может иметь вложенные компоненты. Например, для DataForm могут иметься DataGrid, DataNavigator и так далее.

Ключевые свойства компонента TMIDASPageProducer.

Комбинация компонентов TDataForm, TQueryForm и так далее, определяет структуру и основные параметры отображения HTML-документа, стили же (цвета, шрифты и так далее) определяются свойствами Styles и HTMLDoc.

Другие свойства компонента подробно описаны в документации и файле Справки Delphi.

Следует отметить, что за счет использования для определения состава элементов HTML-документа стандартных компонентов, поставляемых в исходных текстах, становится возможным практически неограниченное расширение функциональных возможностей InternetExpress путем создания специализированных наборов компонент для построения Internet-приложений. Примеры подобного подхода можно найти в демонстрационном приложении InetXCenter из поставки Delphi 5.

Компонент TWebActionItem.

TWebActionItem представляет собой невизуальный компонент, позволяющий задавать реакцию Internet-приложения на те или иные события, транслируемые протоколом HTTP от web-клиента. Предоставляя специальные свойства для задания ссылок на компоненты TMIDASPageProducer и TPageProducer, а также пути URL, TWebActionItem дает возможность задавать алгоритм перемещения между HTML-документами, составляющими Internet-приложение, реагировать на передачу параметров и значений полей HTML-документа специфическим образом и так далее. Реализуя обработчик события TWebActionItem.OnAction, программист получает возможность возвращать необходимые данные в полях запросов, устанавливать идентификационные маркеры (Cookies) для Web-клиентов, контролировать генерацию содержания HTML-документов и выполнять ряд других операций практически на самом нижнем уровне функционирования Internet-приложения.

Свойство Назначение.

Default Означает использование этого компонента как обработчика событий соответствующих типов (свойство MethodType) в тех случаях, когда иной обработчик явно не задан.Из всех компонентов TWebActionItem, присутствующих в контейнере TWebModule, только один может иметь свойство Default равным True.

DisplayName Служит для задания отображения компонента в списке компонента TCustomWebDispatcher. Должно быть уникальным для своего контекста.

Enabled Аналогично многим другим компонентам означает разрешение или запрет на выполнение связанных с компонентом действий. В случае установки в False содержимое HTML-документа соответствующим компонентом типа PageProducer генерироваться не будет.

MethodType Определяет метод HTTP, при вызове которого со стороны web-клиента будет задействован данный компонент. По умолчанию имеет значение mtAny, то есть все доступные методы, но может принимать значения отдельных типов, например mtGet (запрос на получение web-клиентом содержимого документа).

PathInfo В формате URI (Unified Resource Identifier) задает путь к получателю всех сообщений, принимаемых TWebActionItem. Позволяет перенаправить очередь сообщений другому компоненту PageProducer или HTML-документу.

Producer Ссылка на компонент PageProducer. В случае, если компонент явно не задан, обработчик OnAction должен быть реализован в обязательном порядке для осуществления реакции на сообщение. Если ссылка на PageProducer актуальна (не nil), сообщение обрабатывается или PageProducer, или реализацией OnAction в случае ее наличия.

Ключевые свойства компонента TWebActionItem.

Примеры использования свойств TWebActionItem можно найти в демонстрационном приложении InetXCenter (модуль InextXCenterModule.pas).

Невизуальные компоненты категории PageItems (элементы HTML-документа).

Компоненты PageItems предназначены для формирования структуры HTML-документа. Точно так же, как и компоненты VCL, они подразделяются на средства отображения типовых элементов HTML-документа и элементов для обработки данных, получаемых от сервера приложений. Для каждого из этих компонентов могут быть созданы наследники, расширяющие их свойства или реализующие те элементы HTML, эквивалента которым нет в текущей реализации InternetExpress. Реализация компонентов PageItems находится в модуле MidItems. При построении HTML-документа компоненты PageItems объединяются в иерархические структуры. Например, компонент TDataNavigator содержит компоненты типа TDataSetButton.

На этапе генерации содержания HTML-документа компонентом TMIDASPageProducer эти компоненты генерируют фрагменты HTML-кода, описывающего эквивалентные HTML-элементы. Эти фрагменты собираются TMIDASPageProducer в единый поток и подставляются вместо соответствующих тэгов в шаблоне документа. К элементам HTML привязываются обработчики на JavaScript, которые составляют аналог обработчиков событий для визуальных компонентов Delphi, таких, как OnClick и тому подобных. Отдельные компоненты PageItems позволяют напрямую задать мишень (target) для передачи сообщений (свойство Action) в формате URI, что позволяет осуществлять переход от одного HTML-документа к другому передачу параметров в формате протокола HTTP между этими документами.

За счет использования в TMIDASPageProducer шаблонов для генерации HTML-документов появляется возможность добавлять отдельные визуальные и невизуальные элементы HTML-документа прямым редактированием. Однако используя обработчики событий HTTP можно связывать такие элементы с генерируемыми по шаблону через компоненты TWebActionItem или при помощи создаваемых опять-таки прямым редактированием обработчиков на JavaScript внутри HTML-документа.

Компонент TXMLBroker.

Этот компонент осуществляет передачу пакетов данных в формате XML от сервера приложений HTML-клиенту, получение изменений в данных от HTML-клиента, расшифровку разностных пакетов данных XML и передачу информации об изменениях в данных на сервер приложений. Реализация компонента находится в модуле xmlbrokr.

Компонент TXMLBroker может быть использован в приложении, которое одновременно является и MIDAS-клиентом, и серверным Web-приложением. Серверы такого класса как правило имеют две основные функции:

Получать пакеты XML-данных от сервера приложений через интерфейс IAppServer.

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

Для того, чтобы сделать информацию, содержащуюся в базе данных, доступной в формате XML, достаточно добавить компонент TXMLBroker в контейнер WebModule совместно с компонентом TMIDASPageProducer, который будет использовать XML-пакеты данных для создания HTML-страниц.

TXMLBroker автоматически регистрирует себя в Web-модуле (или Web-диспетчере) как автодиспетчеризуемый объект (auto-dispatching object). Это означает, что Web-модуль или Web-диспетчер будут перенаправлять все входящие HTTP-сообщения непосредственно этому. Все входящие сообщения считаются данными для обновления, порождаемыми броузером в ответ на получение HTML-потока, порождаемого компонентом TApplyUpdatesButton. TXMLBroker автоматически передает пакет с XML-данным, содержащий различия в данных, на сервер приложений и возвращает все ошибки, возникшие при обновлении данных тому компоненту управления содержимым (TMIDASPageProducer) документа, который имеет возможность генерации соответствующего ответного сообщения.

Свойство.

Назначение.

AppServer.

Интерфейс IAppServer, служащий для связи с провайдерами (providers) данных.

MaxErrors.

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

MaxRecords.

Управляет формированием пакетов данных XML.

Значение -1 позволяет компоненту передать все записи из набора данных в XML-пакет;

Значение 0 позволяет передачу только метаданных;

Значение больше нуля собственно определяет число записей (строк), которые могут быть переданы в XML-пакет.

Params.

Список параметров, передаваемых серверу приложений. Используется, в частности, для передачи параметров хранимых процедур и SQL-запросов.

ProviderName.

Имя провайдера данных.

ReconcileProducer.

Ссылка на компонент TReconcilePageProducer, который будет использоваться при разрешении конфликтов данных во время операций обновления.

WebDispatch.

Перечисляет типы сообщений протокола HTTP, на которые будет реагировать компонент. Как правило, эти сообщения порождаются при нажатии кнопки типа TApplyUpdatesButton на HTML-странице.

Ключевые свойства компонента TXMLBroker.

Построение Web-приложения на основе InternetExpress.

Для создания Web-приложения необходимо наличие скомпилированного и зарегистрированного приложения-сервера данных. В данном примере используются данные из таблицы biolife.db, входящей в состав демонстрационной базы данных из комплекта Delphi 5. Данные публикуются через контейнер Remote Data Module.

Remote Data Module демонстрационного сервера данных.

После создания и регистрации сервера данных необходимо создать клиента для этого сервера, который, в свою очередь, будет являться сервером для HTML-клиента, являющегося третьим звеном в нашей системе. Delphi 5 предоставляет специальный мастер для создания приложений-расширений Web-сервера. Он может быть вызван через меню File->New->Web Server Application и имеет следующий вид:

Мастер создания серверных Web-приложений.

В данном случае мы создаем CGI-приложение, выводящее порождаемый поток данных в устройство стандартного вывода (stdout). Поток данных этого приложения будет без изменений передан вызывающему документу через транспортный протокол.

Мастер автоматически создаст контейнер типа TWebModule, в который необходимо поместить компоненты TMIDASPageProducer и TXMLBroker. Сюда же мы поместим и компонент TDCOMConnection, который будем использовать для подключения с удаленным сервером данных, а также компонент TClientDataSet для доступа к удаленному модулю данных.

Контейнер WebModule с размещенными в нем компонентами TXMLBroker и TMIDASPageProducer.

Определив необходимые для соединения с удаленным сервером свойства, переходим к созданию содержимого HTML-документа. Для этого необходимо назначить для TXMLBroker свойства RemoteServer и ProviderName, а также создать хотя бы один компонент TWebActionItem, вызвав соответствующий редактор по правой кнопке мыши на компоненте TXMLBroker и TMIDASPageProducer.

Всплывающее меню и ActionEditor.

Далее необходимо вызвать редактор Web-страниц, для чего необходимо выбрать пункт всплывающего меню компонента TMIDASPageProducer->Web Page Editor.

Примечание:

Для работы этого элемента необходимо наличие установленного Microsoft Internet Explorer 4.0 и выше.

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

Встроенное средство просмотра HTML. Красным выделены автоматически сгенерированные ссылки на библиотеки JavaScript.

После компиляции исполняемый модуль (в нашем примере - XMLServerApp.exe) необходимо поместить в каталог Web-сервера, для которого выделены права на запуск приложений. В этот же каталог необходимо поместить перечисленные в разделе "Серверная часть Internet-приложения на основе InternetExpress" библиотеки JavaScript. Для проверки правильности размещения библиотек можно воспользоваться специальным HTML-файлом scripttest.html, который находится в каталоге Demos\Midas\InternetExpress\TroubleShoot на компакт-диске Delphi 5 или в каталоге установки на жестком диске рабочей станции. Этот HTML-файл проверяет правильность размещения библиотек и настройки Web-сервера и в случае наличия тех или иных ошибок выдает некоторые рекомендации по разрешению проблем.

После того, как настройка закончена, можно обратиться к нашему приложению напрямую через протокол HTTP, поскольку оно порождает полноценный HTML-документ, не требующий дополнительной "обвязки".

Окно броузера Netscape Navigator со страницей, порожденной демонстрационным приложением InternetExpress.

Несколько советов.

Демонстрационное приложение для данного обзора тестировалось под управлением серверов Apache 1.3.6 для платформы Win32 и Microsoft Personal Web Server. Сервер Apache после установки был сконфигурирован следующим образом:

В корневом каталоге документов был создан подкаталог iexpress (F:\inetpub\iexpress), в который были помещены файлы, необходимые для работы приложения InternetExpress (библиотеки JavaScript, файл err.html).

В файл mime.types (перечень mime-типов) была внесены исправления, определяющие библиотеки JavaScript для передачи на клиентское место, а для исполнения на сервере вводящие новое расширение:

Text/javascript js.

Application/x-javascript jss.

Свойству компонента TMIDASPageProducer.IncludePathURL было присвоено значение "/iexpress/" с целью указать местонахождение библиотек JavaScript, поскольку по умолчанию TMIDASPageProducer по умолчанию предполагает размещение этих файлов в том же каталоге, что и исполняемый (.exe) модуль, однако в случае использования Apache содержимое каталога /cgi-bin/ по умолчанию считается исполняемым на стороне сервера и требуется дополнительная настройка с целью определить модули с расширением .js и .html как неисполняемые.

Настройка MS Personal Web Server заключалась в определении дополнительного каталога для серверных приложений (того же что и для Apache) и задания для него соответствующих прав доступа (Read и Execute).

Как показало тестирование, при отладке приложений InternetExpress удобнее пользоваться броузером Netscape Navigator (использовались версии 4.61 и 4.7), поскольку в случае возникновения ошибок он дает более полную диагностическую информацию нежели MSIE, старающийся "защитить" пользователя от различных "загадочных" сообщений. К тому же Netscape корректно обрабатывает обращения к localhost в отсутствие соединения с Internet.

Для отладки приложений InternetExpress также удобнее создавать их в CGI-варианте, поскольку IIS, Personal Web Server и Apache не блокируют по записи CGI-приложения в отличие от ISAPI/ASP, которые захватываются кэш-системой этих серверов и для освобождения (например для перезаписи новой версией) exe-файла требуется остановка и повторный запуск web-сервера. В то же время преобразование CGI-приложение в ISAPI или ASP выполняется простой заменой включения (uses) модуля CGIApp на ISAPIApp в исходном тексте проекта.

Приводимое здесь демонстрационное приложение отнюдь не претендует на полноту и законченность. Для более полного ознакомления с возможностями InternetExpress рекомендуется обратиться к демонстрационным примерам из поставки Delphi 5 Enterprise, находящиеся в каталоге Runimage\Delphi50\Demos\Midas\InternetExpress на компакт-диске или в D:\Delphi5\Demos\Midas\InternetExpress (или ином, в зависимости от пути установки Delphi) на жестком диске. Внимательно прочитайте сопроводительные файлы к этим примерам, поскольку некоторые из них требуют специфических настроек Delphi и (или) Web-сервера.

©Drkb::03578.

Взято с http://delphiworld.narod.ru.

Что такое протокол межсетевого взаимодействия IP?

Основу транспортных средств стека протоколов TCP/IP составляет протокол межсетевого взаимодействия - Internet Protocol (IP). К основным функциям протокола IP относятся:

Перенос между сетями различных типов адресной информации в унифицированной форме,

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

Формат пакета IP.

Пакет IP состоит из заголовка и поля данных. Заголовок пакета имеет следующие поля:

Поле Номер версии (VERS) указывает версию протокола IP. Сейчас повсеместно используется версия 4 и готовится переход на версию 6, называемую также IPng (IP next generation).

Поле Длина заголовка (HLEN) пакета IP занимает 4 бита и указывает значение длины заголовка, измеренное в 32-битовых словах. Обычно заголовок имеет длину в 20 байт (пять 32-битовых слов), но при увеличении объема служебной информации эта длина может быть увеличена за счет использования дополнительных байт в поле Резерв (IP OPTIONS).

Поле Тип сервиса (SERVICE TYPE) занимает 1 байт и задает приоритетность пакета и вид критерия выбора маршрута. Первые три бита этого поля образуют подполе приоритета пакета (PRECEDENCE). Приоритет может иметь значения от 0 (нормальный пакет) до 7 (пакет управляющей информации). Маршрутизаторы и компьютеры могут принимать во внимание приоритет пакета и обрабатывать более важные пакеты в первую очередь. Поле Тип сервиса содержит также три бита, определяющие критерий выбора маршрута. Установленный бит D (delay) говорит о том, что маршрут должен выбираться для минимизации задержки доставки данного пакета, бит T - для максимизации пропускной способности, а бит R - для максимизации надежности доставки.

Поле Общая длина (TOTAL LENGTH) занимает 2 байта и указывает общую длину пакета с учетом заголовка и поля данных.

Поле Идентификатор пакета (IDENTIFICATION) занимает 2 байта и используется для распознавания пакетов, образовавшихся путем фрагментации исходного пакета. Все фрагменты должны иметь одинаковое значение этого поля.

Поле Флаги (FLAGS) занимает 3 бита, оно указывает на возможность фрагментации пакета (установленный бит Do not Fragment - DF - запрещает маршрутизатору фрагментировать данный пакет), а также на то, является ли данный пакет промежуточным или последним фрагментом исходного пакета (установленный бит More Fragments - MF - говорит о том пакет переносит промежуточный фрагмент).

Поле Смещение фрагмента (FRAGMENT OFFSET) занимает 13 бит, оно используется для указания в байтах смещения поля данных этого пакета от начала общего поля данных исходного пакета, подвергнутого фрагментации. Используется при сборке/разборке фрагментов пакетов при передачах их между сетями с различными величинами максимальной длины пакета.

Поле Время жизни (TIME TO LIVE) занимает 1 байт и указывает предельный срок, в течение которого пакет может перемещаться по сети. Время жизни данного пакета измеряется в секундах и задается источником передачи средствами протокола IP. На шлюзах и в других узлах сети по истечении каждой секунды из текущего времени жизни вычитается единица; единица вычитается также при каждой транзитной передаче (даже если не прошла секунда). При истечении времени жизни пакет аннулируется.

Идентификатор Протокола верхнего уровня (PROTOCOL) занимает 1 байт и указывает, какому протоколу верхнего уровня принадлежит пакет (например, это могут быть протоколы TCP, UDP или RIP).

Контрольная сумма (HEADER CHECKSUM) занимает 2 байта, она рассчитывается по всему заголовку.

Поля Адрес источника (SOURCE IP ADDRESS) и Адрес назначения (DESTINATION IP ADDRESS) имеют одинаковую длину - 32 бита, и одинаковую структуру.

Поле Резерв (IP OPTIONS) является необязательным и используется обычно только при отладке сети. Это поле состоит из нескольких подполей, каждое из которых может быть одного из восьми предопределенных типов. В этих подполях можно указывать точный маршрут прохождения маршрутизаторов, регистрировать проходимые пакетом маршрутизаторы, помещать данные системы безопасности, а также временные отметки. Так как число подполей может быть произвольным, то в конце поля Резерв должно быть добавлено несколько байт для выравнивания заголовка пакета по 32-битной границе.

Максимальная длина поля данных пакета ограничена разрядностью поля, определяющего эту величину, и составляет 65535 байтов, однако при передаче по сетям различного типа длина пакета выбирается с учетом максимальной длины пакета протокола нижнего уровня, несущего IP-пакеты. Если это кадры Ethernet, то выбираются пакеты с максимальной длиной в 1500 байтов, умещающиеся в поле данных кадра Ethernet.

Управление фрагментацией.

Протоколы транспортного уровня (протоколы TCP или UDP), пользующиеся сетевым уровнем для отправки пакетов, считают, что максимальный размер поля данных IP-пакета равен 65535, и поэтому могут передать ему сообщение такой длины для транспортировки через интерсеть. В функции уровня IP входит разбиение слишком длинного для конкретного типа составляющей сети сообщения на более короткие пакеты с созданием соответствующих служебных полей, нужных для последующей сборки фрагментов в исходное сообщение.

В большинстве типов локальных и глобальных сетей определяется такое понятие как максимальный размер поля данных кадра или пакета, в которые должен инкапсулировать свой пакет протокол IP. Эту величину обычно называют максимальной единицей транспортировки - Maximum Transfer Unit, MTU. Сети Ethernet имеют значение MTU, равное 1500 байт, сети FDDI - 4096 байт, а сети Х.25 чаще всего работают с MTU в 128 байт.

Работа протокола IP по фрагментации пакетов в хостах и маршрутизаторах иллюстрируется рисунком 4.1.

Пусть компьютер 1 связан с сетью , имеющей значение MTU в 4096 байтов, например, с сетью FDDI. При поступлении на IP-уровень компьютера 1 сообщения от транспортного уровня размером в 5600 байтов, протокол IP делит его на два IP-пакета, устанавливая в первом пакете признак фрагментации и присваивая пакету уникальный идентификатор, например, 486. В первом пакете величина поля смещения равна 0, а во втором - 2800. Признак фрагментации во втором пакете равен нулю, что показывает, что это последний фрагмент пакета. Общая величина IP-пакета составляет 2800+20 (размер заголовка IP), то есть 2820 байтов, что умещается в поле данных кадра FDDI.

Далее компьютер 1 передает эти пакеты на канальный уровень К1, а затем и на физический уровень Ф1, который отправляет их маршрутизатору, связанному с данной сетью .

Маршрутизатор видит по сетевому адресу, что прибывшие два пакета нужно передать в сеть 2, которая имеет меньшее значение MTU, равное 1500. Вероятно, это сеть Ethernet. Маршрутизатор извлекает фрагмент транспортного сообщения из каждого пакета FDDI и делит его еще пополам, чтобы каждая часть уместилась в поле данных кадра Ethernet. Затем он формирует новые пакеты IP, каждый из которых имеет длину 1400 + 20 = 1420 байтов, что меньше 1500 байтов, поэтому они нормально помещаются в поле данных кадров Ethernet.

В результате в компьютер 2 по сети Ethernet приходит четыре IP-пакета с общим идентификатором 486, что позволяет протоколу IP, работающему в компьютере 2, правильно собрать исходное сообщение. Если пакеты пришли не в том порядке, в котором были посланы, то смещение укажет правильный порядок их объединения.

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

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

Маршрутизация с помощью IP-адресов.

Рассмотрим теперь принципы, на основании которых в сетях IP происходит выбор маршрута передачи пакета между сетями.

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

Длина маршрута может существенно измениться в зависимости от того, какой маршрутизатор выберет компьютер для передачи своего пакета на сервер, расположенный, например, в Германии, если маршрутизатор 1 соединен выделенной линией с маршрутизатором в Копенгагене, а маршрутизатор 2 имеет спутниковый канал, соединяющий его с Токио.

В стеке TCP/IP маршрутизаторы и конечные узлы принимают решения о том, кому передавать пакет для его успешной доставки узлу назначения, на основании так называемых таблиц маршрутизации (routing tables).

Следующая таблица представляет собой типичный пример таблицы маршрутов, использующей IP-адреса сетей:

Адрес сети.

Назначения Адрес следующего маршрутизатора Номер выходного.

Порта Расстояние до.

Сети назначения.

56.0.0.0 198.21.17.7 1 20.

56.0.0.0 213.34.12.4. 2 130.

116.0.0.0 213.34.12.4 2 1450.

129.13.0.0 198.21.17.6 1 50.

198.21.17.0 - 2 0.

213. 34.12.0 - 1 0.

Default 198.21.17.7 1 -

В этой таблице в столбце "Адрес сети назначения" указываются адреса всех сетей, которым данный маршрутизатор может передавать пакеты. В стеке TCP/IP принят так называемый одношаговый подход к оптимизации маршрута продвижения пакета (next-hop routing) - каждый маршрутизатор и конечный узел принимает участие в выборе только одного шага передачи пакета. Поэтому в каждой строке таблицы маршрутизации указывается не весь маршрут в виде последовательности IP-адресов маршрутизаторов, через которые должен пройти пакет, а только один IP-адрес - адрес следующего маршрутизатора, которому нужно передать пакет. Вместе с пакетом следующему маршрутизатору передается ответственность за выбор следующего шага маршрутизации. Одношаговый подход к маршрутизации означает распределенное решение задачи выбора маршрута. Это снимает ограничение на максимальное количество транзитных маршрутизаторов на пути пакета.

(Альтернативой одношаговому подходу является указание в пакете всей последовательности маршрутизаторов, которые пакет должен пройти на своем пути. Такой подход называется маршрутизацией от источника - Source Routing. В этом случае выбор маршрута производится конечным узлом или первым маршрутизатором на пути пакета, а все остальные маршрутизаторы только отрабатывают выбранный маршрут, осуществляя коммутацию пакетов, то есть передачу их с одного порта на другой. Алгоритм Source Routing применяется в сетях IP только для отладки, когда маршрут задается в поле Резерв (IP OPTIONS) пакета.).

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

При этом под расстоянием понимается любая метрика, используемая в соответствии с заданным в сетевом пакете классом сервиса. Это может быть количество транзитных маршрутизаторов в данном маршруте (количество хопов от hop - прыжок), время прохождения пакета по линиям связи, надежность линий связи, или другая величина, отражающая качество данного маршрута по отношению к конкретному классу сервиса. Если маршрутизатор поддерживает несколько классов сервиса пакетов, то таблица маршрутов составляется и применяется отдельно для каждого вида сервиса (критерия выбора маршрута).

Для отправки пакета следующему маршрутизатору требуется знание его локального адреса, но в стеке TCP/IP в таблицах маршрутизации принято использование только IP-адресов для сохранения их универсального формата, не зависящего от типа сетей, входящих в интерсеть. Для нахождения локального адреса по известному IP-адресу необходимо воспользоваться протоколом ARP.

Конечный узел, как и маршрутизатор, имеет в своем распоряжении таблицу маршрутов унифицированного формата и на основании ее данных принимает решение, какому маршрутизатору нужно передавать пакет для сети N. Решение о том, что этот пакет нужно вообще маршрутизировать, компьютер принимает в том случае, когда он видит, что адрес сети назначения пакета отличается от адреса его собственной сети (каждому компьютеру при конфигурировании администратор присваивает его IP-адрес или несколько IP-адресов, если компьютер одновременно подключен к нескольким сетям ). Когда компьютер выбрал следующий маршрутизатор, то он просматривают кэш-таблицу адресов своего протокола ARP и, может быть, находит там соответствие IP-адреса следующего маршрутизатора его MAC-адресу. Если же нет, то по локальной сети передается широковещательный ARP-запрос и локальный адрес извлекается из ARP-ответа.

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

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

Особенно часто приемом маршрутизации по умолчанию пользуются конечные узлы. Хотя они также в общем случае имеют в своем распоряжении таблицу маршрутизации, ее объем обычно незначителен, так как маршрутизация для компьютера - не основное занятие. Главная роль в маршрутизации пакетов в концепции протокола IP отводится, естественно, маршрутизаторам, которые должны обладать гораздо более полными таблицами маршрутизации, чем конечные узлы. Конечный узел часто вообще работает без таблицы маршрутизации, имея только сведения об IP-адресе маршрутизатора по умолчанию. При наличии одного маршрутизатора в локальной сети этот вариант - единственно возможный для всех конечных узлов. Но даже при наличии нескольких маршрутизаторов в локальной сети , когда проблема их выбора стоит перед конечным узлом, задание маршрута по умолчанию часто используется в компьютерах для сокращения объема их маршрутной таблицы.

Другим способом разгрузки компьютера от необходимости ведения больших таблиц маршрутизации является получение от маршрутизатора сведений о рациональном маршруте для какой-нибудь конкретной сети с помощью протокола ICMP.

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

Специфичный для узла маршрут содержит вместо номера сети полный IP-адрес, то есть адрес, имеющий ненулевую информацию не только в поле номера сети, но и в поле номера узла. Предполагается, что для такого конечного узла маршрут должен выбираться не так, как для всех остальных узлов сети, к которой он относится. В случае, когда в таблице есть разные записи о продвижении пакетов для всей сети N и ее отдельного узла, имеющего адрес N,D, при поступлении пакета, адресованного узлу N,D, маршрутизатор отдаст предпочтение записи для N,D.

Записи в таблице маршрутизации, относящиеся к сетям, непосредственно подключенным к маршрутизатору, в поле "Расстояние до сети назначения" содержат нули.

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

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

Алгоритмы фиксированной маршрутизации,

Алгоритмы простой маршрутизации,

Алгоритмы адаптивной маршрутизации.

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

Фиксированная маршрутизация.

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

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

Простая маршрутизация.

Алгоритмы простой маршрутизации подразделяются на три подкласса:

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

Лавинная маршрутизация - пакеты передаются во всех направлениях, кроме исходного (применяется в мостах для пакетов с неизвестным адресом доставки).

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

Адаптивная маршрутизация.

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

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

Пример взаимодействия узлов с использованием протокола IP.

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

Пусть в приведенном примере пользователь компьютера cit.dol.ru, находящийся в сети Ethernet с IP-адресом 194.87.23.0 (адрес класса С), хочет взаимодействовать по протоколу FTP с компьютером s1.msk.su, принадлежащем сети Ethernet с IP-адресом 142.06.0.0 (адрес класса В). Компьютер cit.dol.ru имеет IP-адрес 194.87.23.1.17, а компьютер s1.msk.su - IP-адрес 142.06.13.14.

Пользователь компьютера cit.dol.ru знает символьное имя компьютера s1.msk.su, но не знает его IP-адреса, поэтому он набирает команду.

> ftp s1.msk.su.

Для организации ftp-сеанса.

В компьютере cit.dol.ru должны быть заданы некоторые параметры для стека TCP/IP, чтобы он мог выполнить поставленную перед ним задачу.

В число этих параметров должны входить собственный IP-адрес, IP-адрес DNS-сервера и IP-адрес маршрутизатора по умолчанию. Так как к сети Ethernet, к которой относится компьютер cit.dol.ru, подключен только один маршрутизатор, то таблица маршрутизации конечным узлам этой сети не нужна, достаточно знать IP-адрес маршрутизатора по умолчанию. В данном примере он равен 194.87.23.1.

Так как пользователь в команде ftp не задал IP-адрес узла, с которым он хочет взаимодействовать, то стек TCP/IP должен определить его самостоятельно. Он может сделать запрос к серверу DNS по имеющемуся у него IP-адресу, но обычно каждый компьютер сначала просматривает свою собственную таблицу соответствия символьных имен и IP-адресов. Такая таблица хранится чаще всего в виде текстового файла простой структуры - каждая его строка содержит запись об одном символьном имени и его IP-адресе. В ОС Unix такой файл традиционно носит имя HOSTS.

Будем считать, что компьютер cit.dol.ru имеет файл HOSTS, а в нем есть строка.

142.06.13.14 s1.msk.su.

Поэтому разрешение имени выполняется локально, так что протокол IP может теперь формировать IP-пакеты с адресом назначения 142.06.13.14 для взаимодействия с компьютером s1.msk.su.

Протокол IP компьютера cit.dol.ru проверяет, нужно ли маршрутизировать пакеты для адреса 142.06.13.14. Так как адрес сети назначения равен 142.06.0.0, а адрес сети , к которой принадлежит компьютер , равен 194.87.23.0, то маршрутизация необходима.

Компьютер cit.dol.ru начинает формировать кадр Ethernet для отправки IP-пакета маршрутизатору по умолчанию с IP-адресом 194.87.23.1. Для этого ему нужен МАС-адрес порта маршрутизатора, подключенного к его сети. Этот адрес скорее всего уже находится в кэш-таблице протокола ARP компьютера , если он хотя бы раз за последнее включение обменивался данными с компьютерами других сетей . Пусть этот адрес в нашем примере был найден именно в кэш-памяти. Обозначим его МАС11, в соответствии с номером маршрутизатора и его порта.

В результате компьютер cit.dol.ru отправляет по локальной сети кадр Ethernet, имеющий следующие поля:

DA (Ethernet) ... DESTINATION IP ... ...

МАС11.

142.06.13.14.

Кадр принимается портом 1 маршрутизатора 1 в соответствии с протоколом Ethernet, так как МАС-узел этого порта распознает свой адрес МАС11. Протокол Ethernet извлекает из этого кадра IP-пакет и передает его программному обеспечению маршрутизатора, реализующему протокол IP. Протокол IP извлекает из пакета адрес назначения и просматривает записи своей таблицы маршрутизации. Пусть маршрутизатор 1 имеет в своей таблице маршрутизации запись.

142.06.0.0 135.12.0.11 2 1,

Которая говорит о том, что пакеты для сети 142.06. 0.0 нужно передавать маршрутизатору 135.12.0.11, подключенному к той же сети, что и порт 2 маршрутизатора 1.

Маршрутизатор 1 просматривает параметры порта 2 и находит, что он подключен к сети FDDI. Так как сеть FDDI имеет значение максимального транспортируемого блока MTU больше, чем сеть Ethernet, то фрагментация поля данных IP-пакета не требуется. Поэтому маршрутизатор 1 формирует кадр формата FDDI, в котором указывает MAC-адрес порта маршрутизатора 2, который он находит в своей кэш-таблице протокола ARP:

DA (FDDI) ... DESTINATION IP ... ...

МАС21.

142.06.13.14.

Аналогично действует маршрутизатор 2, формируя кадр Ethernet для передачи пакета маршрутизатору 3 по сети Ethernet c IP-адресом 203.21.4.0:

DA (Ethernet) ... DESTINATION IP ... ...

МАСЗ2.

142.06.13.14.

Наконец, после того, как пакет поступил в маршрутизатор сети назначения - маршрутизатор 3, появляется возможность передачи этого пакета компьютеру назначения. Маршрутизатор 3 видит, что пакет нужно передать в сеть 142.06.0.0, которая непосредственно подключена к его первому порту. Поэтому он посылает ARP-запрос по сети Ethernet c IP-адресом компьютера s1.msk.su (считаем, что этой информации в его кэше нет), получает ответ, содержащий адрес MACs1, и формирует кадр Ethernet, доставляющий IP-пакет по локальной сети адресату.

DA (Ethernet) ... DESTINATION IP ... ...

МАСs1.

142.06.13.14.

Структуризация сетей IP с помощью масок.

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

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

Маска - это число, двоичная запись которого содержит единицы в тех разрядах, которые должны интерпретироваться как номер сети.

Например, для стандартных классов сетей маски имеют следующие значения:

255.0.0.0.

Маска для сети класса А,

255.255.0.0.

Маска для сети класса В,

255.255.255.0.

Маска для сети класса С.

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

Пусть, например, маска имеет значение 255.255.192.0 (11111111 11111111 11000000 00000000). И пусть сеть имеет номер 129.44.0.0 (10000001 00101100 00000000 00000000), из которого видно, что она относится к классу В. После наложения маски на этот адрес число разрядов, интерпретируемых как номер сети, увеличилось с 16 до 18, то есть администратор получил возможность использовать вместо одного, централизованно заданного ему номера сети, четыре:

129.44.0.0.

(10000001 00101100 00000000 00000000).

129.44.64.0.

(10000001 00101100 01000000 00000000).

129.44.128.0.

(10000001 00101100 10000000 00000000).

129.44.192.0.

(10000001 00101100 11000000 00000000).

Например, IP-адрес 129.44.141.15 (10000001 00101100 10001101 00001111), который по стандартам IP задает номер сети 129.44.0.0 и номер узла 0.0.141.15, теперь, при использовании маски, будет интерпретироваться как пара:

129.44.128.0 - номер сети, 0.0. 13.15 - номер узла.

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

Еще один пример. Пусть некоторая сеть относится к классу В и имеет адрес 128.10.0.0 (рисунок 4.4). Этот адрес используется маршрутизатором, соединяющим сеть с остальной частью интерсети. И пусть среди всех станций сети есть станции, слабо взаимодействующие между собой. Их желательно было бы изолировать в разных сетях. Для этого сеть можно разделить на две сети, подключив их к соответствующим портам маршрутизатора, и задать для этих портов в качестве маски, например, число 255.255.255.0, то есть организовать внутри исходной сети с централизовано заданным номером две подсети класса C (можно было бы выбрать и другой размер для поля адреса подсети). Извне сеть по-прежнему будет выглядеть, как единая сеть класса В, а на местном уровне это будут две отдельные сети класса С. Приходящий общий трафик будет разделяться местным маршрутизатором между подсетями.

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

©Drkb::03352.

Взято с http://delphiworld.narod.ru.

Экспорт анимированных 3D персонажей из 3D STUDIO MAX 3.0 для DELPHI и OpenGL.

Введение.

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

Как создается двумерная анимация? Рисуется несколько кадров движения, затем поледовательно выводятся на экран и таким образом создается иллюзия движения. То же самое происходит в современных трехмерных компьютерных играх. Создается несколько 3D моделей (сеток), характеризующих фазы движения персонажа в различные моменты времени, затем поледовательно выводятся на экран, создавая иллюзию движения. Возможно, это приводит к повышенному расходу оперативной памяти, поскольку все сетки желательно хранить в памяти, но зато значительно упрощается процесс программирования и, скорее всего, увеличивается скорость работы приложения.

Следующая проблема возникла при попытке экспорта объектов из 3D Studio Max в какой-либо открытый формат, например DXF. Нет ничего сложного в создании трехмерного персонажа с последующей его анимаций, если пользоваться 3D Studio и Character Studio, вся проблема состоит в том, как экспортировать объект чтобы потом файл с сетками объекта можно было использовать в своем приложении. Для этого требуется покадровый экспорт анимированного персонажа, то есть в итоге должен получится файл, содержащий несколько сеток объекта изображающих фазы движений объекта в различные моменты времени, или несколько файлов содержащих одну сетку соответствующую определенному кадру движения. Однако, несмотря на обилие поддерживаемых форматов файлов, 3D Studio Max не обладает возможностью покадрового экспорта трехмерных объектов. Так, напрмер, файл формата 3DS может хранить информацию о положении объекта, его повороте и масштабе, но не в состоянии сохранять деформации сетки в различных кадрах анимации, а именно это нам и нужно. Про файлы формата DXF и ASC даже говорить в данном случае смешно. Я объясню, почему нам нужно сохранять именно деформацию сетки. Дело в том, что наш объект должен состоять из единой, цельной сетки, а не из нескольких объектов, чтобы не было стыков на местах соединений конечностей с телом. Создать анимацию, так чтобы персонаж мог двигать своими конечностями, в этом случае, можно только деформируя сетку, а именно перемещая одни вершины сетки относительно других. Так, например, чтобы персонаж поднял руку нужно переместить вершины руки вверх относительно вершин тела. Теперь, я надеюсь, все понятно? Итак, оказалось, что 3DStudio не в состоянии сохранить подобную анимацию. Однако, не все так печально. Например, есть такой дополнительный модуль для 3DStudio, называется Bones Pro Max, а у него есть инструмент SnapShot, который позволяет делать снимки различных кадров движения объекта. В результате его работы у Вас на рабочем поле 3D Studio Max появляется целое стадо одинаковых трехмерных объектов в различных позах. Правду сказать, я его не нашел, да и выпущен он был уже давно еще под первую версию 3D Studio Max. Поэтому я решил идти другим путем и окунулся во внутренний язык 3D Studi Max - Max Script. Результатом моей деятельности стала простенькая утилита Meshes Export for Games and Animation (MEGA), которая позволяет делать все, о чем я сказал выше и некоторые другие полезные вещи.

Знакомство с утилитой MEGA V 1.0.

Для ознакомления с этой утилитой Вам понадобится графический пакет 3D Studio Max 3.0 и, собственно, сама утилита. Она расположена в папке Utility и называется MEGA.ms. Это не исполняемый файл, а текстовый файл с набором команд для 3D Studio Max написанных на языке Max Script.

Запустите 3D Studio Max и создайте простой объект - сферу. Я полагаю, что даже те, кто никогда не видел этого графического редактора, без труда справятся с таким простым заданием.

Теперь, щелкайте на сфере правой кнопкой мыши пока не появится контекстное меню. Как правило, с первого раза оно не появляется. В контекстном меню выберите строку Convert to Editable Mesh (Преобразовать в Редактируемую Сетку). Обратите внимание: объект, непременно, должен быть Редактируемой Сеткой, если в выходном файле мы хотим получить список вершин и граней, иначе мы получим имя объекта и его свойства, такие как, радиус, количество сегментов - для сферы, высоту, ширину и глубину - для параллелепипеда и т.д.

Перейдите на командную панель (она расположена справа) и выберите вкладку с изображением молотка. Это вкладка утилит. Нажмите кнопку MAXScript, внизу панели развернется свиток MAXScript'a. Нажмите кнопку Запуск Макроса, появится диалоговое окно открытия файла. Запустите файл MEGA.ms. Внизу командной панели в списке утилит должна появится надпись MEGA, однако это еще не означает, что утилита уже запущена. Чтобы ее запустить, необходимо раскрыть спиок утилит и выделить строку MEGA. Внизу панели должен раскрыться свиток MEGA.

Введите в поле From зачение 1, в поле To - 100, в поле Step - 100. Нажмите кнопку Save As..., в диалоговом окне введите имя файла, куда бдете сохранять и нажмите кнопку сохранить. Объект экспортирован в файл с расширением GMS.

Как работает утилита: При экспорте файла, берется значение из поля From и ползунок счетчика кадров расположенный внизу экрана премещается на позицию, соответствующую этому значению. Затем в выходной файл экспортируется объект в том виде, в каком он пребывает на данный момент на экране. После чего снова передвигается ползунок кадров на величину, введенную в поле Step. Снова записывается модель соответствующая этому кадру. И так до тех пор, пока ползунок не переместится на позицию соответствующую значению, введенному в поле To. Поскольку в данном примере мы не создавали анимацию, то нам нужен был только один кадр. Утилита экспортировала кадр №1, затем добавила к нему значение 100. Номер кадра стал равен 101. Поскольку это значение больше значения введенного в поле To, процесс экспорта на этом остановился. Если бы в поле From было введено значение 0, то было бы экспортировано 2 кадра с номерами 0 и 100 соответственно. Если пометить галочкой опцию Selected Only, то экспортироваться будут только выделенные объекты, это иногда бывает очень нужно, в противном случае будут экспортированы все объекты сцены. Теперь рекомендую рассмотреть формат файла GMS.

Формат файла GMS.

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

// Указывает на начало нового объекта,

// следующая строка указывает тип объекта.

New object.

TriMesh() // Объект - сетка.

// Указывает, что следующая строка содержит количество.

// вершин и граней для данного объекта.

Numverts numfaces.

Mesh vertices:

// Здесь располагается блок вершин объекта в виде координат X Y Z.

End vertices.

Mesh faces:

// Здесь располагается блок граней объекта в виде индексов 1 2 3,

// где каждый индекс - индекс в массиве вершин, указывает на вершину грани.

End faces.

Faset normals:

// Здесь располагается блок фасетных нормалей в виде координат X Y Z.

// Их количество равно количеству граней.

End faset normals.

Smooth normals:

// Здесь располагается блок сглаживающих нормалей в виде координат X Y Z.

// Их количество равно количеству вершин.

End smooth normals.

End mesh // Конец описания объекта Tri Mesh.

End of file // Конец файла.

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

// Указывает на начало нового объекта,

// следующая строка указывает тип объекта.

New object.

<Тип объекта>, например: Box.

// Здесь идут параметры, зависящие от типа объекта.

// (Поверхности Безье и NURBS - поверхности не поддерживаются).

End <Тип объекта> // Конец описания объекта.

End of file // Конец файла.

Загрузка файла формата GMS в Delphi.

Пример загрузки файла GMS находится в папке Ch01. В проекте присутствует два модуля: frmMain.pas и Mesh.pas. Откомпилировав и запустив проект на выполнение вы должны увидеть вращающийся Тор (по-нашему: "Баранка"). Несмотря на то, что объект можно считать стандартным, он был в 3D Studio преобразован в сетку, поэтому в данном случае это именно сетчатый объект. Нажав пункт меню "загрузить", вы можете посмотреть любой объект из папки GMS или загрузить свою сферу, которую сделали сами, если правильно руководствовались моими инструкциями в разделе: Знакомство с утилитой MEGA V1.0. Теперь рассмотрим данный пример подробно. Почти весь код модуля frmMain.pas написан не мной. Он взят из книги "OpenGL графика в проектах Delphi" Михаила Краснова. Этот модуль выполняет инициализацию приложения и циклическую функцию отрисовки окна, поэтому подробно мы его рассматривать не будем. Если код покажется Вам непонятным, значит Вы недостаточно знакомы с OpenGL, в этом случае Вам надлежит обратится к первоисточнику (в смысле - к книге). Код модуля Mesh.pas выполняет загрузку данных из файла и отображение объектов в окне. Рассмотрим его подробнее:

Code: // Объявление типов данных. Type. // Указатель на вершину. PGLVertex = ^TGLVertex; TGLVertex = record. // Вершина, как три значения с плавающей точкой. X, y, z: GLFloat; End; // Указатель на вектор. PGLVector = ^TGLVector; // Вектор, как массив из трех элементов с плавающей точкой. TGLVector = array[0..2] of GLFloat; // Указатель на грань. PGLFace = ^TGLFace; // Грань, как массив из трех целочисленных значений. TGLFace = array[0..2] of GLInt; // Указатель на массив вершин. PGLVertexArray = ^TGLVertexArray; // Массив вершин. TGLVertexArray = array[Word] of TGLVertex; // Указатель на массив граней. PGLFacesArray = ^TGLFacesArray; // Массив граней. TGLFacesArray = array[word] of TGLFace;

Взаимодействуем с Winamp.

О пользе плагинов и спорить не приходиться. Потому многие крупные разработчики программного обеспечения предусматривают в своих творениях поддержку модулей, написанных другими людьми. Так поступила и компания Nullsoft, создатель известного компьютерного плеера - Winamp. Для непосредственного обращения к плееру были созданы специальные функции - WinampApi.

Алгоритм взаимодействия таков:

Находим Handle окна Winamp'a. (можно так - findwindow('Winamp v1.x',nil) ).

С помощью команды Sendmessage, посылаем окну сообщение вида WM_COMMAND или WM_USER c определёнными параметрами (см. Приложение).

Итак, напишем, например, процедуру для проигрывания заданного трека с заданной громкостью. В дальнейшем, её можно будет использовать в плагине или в программе, работающей совместно с Winamp.

Code: Procedure play_track_with_volume(track_number:integer;volume:integer); // Track_number - номер трека (от 1 до величины количества треков). // Volume - громкость (от 0 до 255). Var. H: hwnd; Begin. H:=findwindow('Winamp v1.x',g>nil); // Находим окно. Sendmessage(h,WM_USER,track_number-1,121); // Устанавливаем номер трека. Sendmessage(h,WM_USER,volume,122); // Устанавливаем громкость. Sendmessage(h,WM_COMMAND,40045,0); // Проигрываем трек. End;

Разработка MDI приложений в Delphi.

Перевод одноимённой статьи с delphi.about.com).

Что такое MDI?

MDI расшифровывается как multiple document interface (многодокументный интерфейс). В приложениях с MDI, в основном (родительском) окне можно окрыть более одного дочернего окна. Данная возможность обычно используется в электронных таблицах или текстовых редакторах.

Каждое MDI приложение имеет три основные составляющие:

Одну (и только одну) родительскую форму MDI, Одну и более (обычно больше) дочерних форм MDI, и основное меню MDI.

MDI "мать".

Как уже упоминалось, в проекте MDI приложения может присутствовать только один MDI контейнер (родительская форма) и он должен быть стартовой формой.

Для создания основного окна MDI приложения проделайте следующие шаги:

Запустите Delphi и выберите File | New Application... Delphi создаст новый проект с одной формой под названием form1 (по умолчанию).

В свойстве Name присвойте форме имя frMain.

Установите свойство FormStyle в fsMDIform.

Сохраните этот проект (имя проекта на Ваше усмотрение, например prMDIExample), вместе с uMain.pas в только что созданной директории.

Как Вы успели заметить, для создания основной формы MDI, мы установили свойство FormStyle в fsMDIform. В каждом приложении только одна форма может иметь свойство fsMDIform.

MDI "дети".

Каждое родительское окно MDI нуждается по крайней мере в одной дочерней форме. Дочерние формы MDI - это простые формы, за исключением того, что их видимая часть ограничена размерами родительского окна. Так же при минимизации такого окна, оно помещается не в панель задач, а остаётся внутри родительского окна ( на панель задач попадёт только родительское окно).

Теперь давайте создадим дополнительные формы, а точнее дочерние. Просто выберите File | New Form. Будет создан новый объект формы с именем form1 (по умолчанию). При помощи Object Inspector измените свойство Name в форме form1 на frChild, а свойство FormStyle на fsMDIChild. Сохраните эту форму с соответствующим ей файлом как uchild.pas. Обратите внимание, что при помощи данного свойства мы можем превратить любую существующую форму в дочернюю форму MDI.

Ваше приложение может включать множество дочерних MDI форм такого же или другого типа.

Так же хочется обратить Ваше внимание, что MDI приложение может включать в себя и самые обычные формы, но в отличие от дочерних, они будут отображаться как обычные модальные диалоговые окна (такие как about box, или файловый диалог).

Естевственно, что как на родительском так и на дочернем окнах можно располагать любые элементы управления, однако уже давно сложилась традиция, что на родительской форме располагается панель статуса (status bar) и панель инструментов (toolbar), в то время как на дочерних формах располагаются все остальные контролы, такие как гриды, картинки, поля вводи и т. д.

Автосодание -> Доступные.

Теперь давайте произведём некоторые настройки нашего проекта. Выберите Project | Options, откроется диалог опций проекта (Project Options). В левой панели выберите frChild (Авто-создание форм ("Auto-create forms")), и переместите её в правую панель (Доступные формы (Available forms)). Список правой панели содержит те формы, которые используются Вашим приложением, но которые не созданы автоматически. В MDI приложении, по умолчанию, все дочерние формы создаются автоматически и отображаются в родительской форме.

Создание и отображение...

Как упомянуто выше, настройка не позволяет автоматически создавать дочерние окна, поэтому нам необходимо добавить некоторый код, который будет производить создание объекта формы frChild. Следующую функцию CreateChildForm необходимо поместить внутри основной формы (MDI родитель) (наряду с заголовком в interface's private):

Code: Uses uchild; ... Procedure TfrMain.CreateChildForm. (const childName : string); Var Child: TfrChild; Begin. Child := TfrChild.Create(Application); Child.Caption := childName; End;

Данный код создаёт одну дочернюю форму с заголовком childName.

Не забудьте, что этот код находится разделе "uses uchild".

На закрытие не минимизировать!

Закрытие дочернего окна в MDI приложении всего навсего минимизирует его в клиентской области родительского окна. Поэтому мы должны обеспечить процедуру OnClose, и установить параметр Action в caFree:

Code: Procedure TfrChild.FormClose. (Sender: TObject; var Action: TCloseAction); Begin. Action := caFree; End;

Низкоуровневые процедуры обработки звука.

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

Включенный в код модуль RECUNIT делает всю изнурительную работу по извлечению звука со входа звуковой карты.

Code: Var. WaveRecorder: TWaveRecorder; ... WaveRecorder := TwaveRecorder(2048, 4); // 4 размером 2048 байт. { Устанавливает параметры дискретизации }. With WaveRecorder.pWavefmtEx do. Begin. WFormatTag := WAVE_FORMAT_PCM; NChannels := 1; NSamplesPerSec := 20000; WBitsPerSample := 16; NAvgBytesPerSec := nSamplesPerSec * (wBitsPerSample div 8) * nChannels; End; // Затем используем вариантную запись, поскольку я не знаю. // как получить адрес самого объекта. WaveRecorder.SetupRecord(@WaveRecorder); // Начинаем запись. WaveRecorder.StartRecord; ...При каждом заполнении буфера вызывается. Процедура WaveRecorder.Processbuffer. // Заканчиваем запись. WaveRecorder.StopRecord; WaveRecorder.Destroy;

Описание протокола SSH (Secure Shell).

В настоящей статье рассматривается ssh (secure shell), одно из самых распространенных программных средств повышения компьютерной безопасности при работе Unix-систем в Internet.

Число как средств защиты, так и инструментов, способствующих взлому, в Internet огромно. Однако складывается впечатление, что по крайней мере два средства tcpwrapper и ssh входят в состав своеобразного джентльменского набора ОС Unix, который можно рекомендовать любому системному администратору. В частности, эти средства используют все отечественные Internet-провайдеры, с которыми мне приходилось иметь дело. Возможно, это связано и со стандартной_ комплектацией ssh операционной системы FreeBSD, весьма популярной среди наших провайдеров.

Причиной нашего внимания к этой теме является не только популярность ssh среди пользователей, работающих в самых разных областях. Хотя ssh появился лишь в 1995 г., в настоящее время он уже рассматривается как проект стандарта Internet, подготовкой которого занимается специальная рабочая группа secsh в IETF Security Area. Строго говоря, в этой рабочей группе стандартизуется, конечно, не ssh как программный продукт, а набор протоколов ssh.

Тем временем, ssh уже завоевал статус фактического стандарта Internet на безопасные терминальные соединения. Автором первоначального варианта ssh является Т. Ялонен. В настоящее время выпущена вторая версия ssh; разработкой программного продукта SSH2 занимается компания SSH Communication Security Кроме версии ssh, доступной бесплатно, имеется и усовершенствованный коммерчески доступный вариант. Кроме того, с использованием этой программы разработаны и некоторые другие коммерческие продукты. Поставками коммерческой версии ssh занимается Data Fellows; эта компания предлагает, в частности, программные продукты F-secure SSH Server и F-Secure SSH Tunell & Terminal.

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

Что касается типов обеспечиваемого удаленного доступа, ssh поддерживает возможности работы с telnet; безопасную работу с протоколом X11 благодаря возможности перенаправления соответствующих данных по надежным ssh-каналам; безопасную замену многим r_-командам Unix (rsh, rlogin и т.д.), с которыми, как известно, традиционно связаны проблемы обеспечения безопасности.

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

Протокол ssh.

Проект стандарта ssh описывает протоколы ssh и состоит из нескольких документов, которые описывают общую архитектуру протокола, а также протоколы трех уровней: протокол транспортного уровня, протокол аутентификации и протокол соединения. Их задача _ обеспечивать безопасную сетевую службу наподобие удаленного login поверх небезопасной_ сети.

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

Протокол транспортного уровня предусматривает возможность сжатия данных. Этот протокол работает поверх соединения TCP/IP. Протокол аутентификации работает поверх протокола транспортного уровня, а протокол соединения ' поверх протокола аутентификации.

С целью повышения безопасности осуществляется не только аутентификация клиента для сервера, к которому обращается клиент, но и аутентификация сервера клиентом _ другими словами, происходит аутентификация обеих сторон.

Клиент шлет запрос на обслуживание в первый раз, когда устанавливается безопасное соединение транспортного уровня ssh. Второй запрос направляется уже после завершения аутентификации пользователя (клиента).

Прежде чем анализировать протоколы ssh подробнее, следует определить понятие ключ хоста_. Каждый работающий с ssh хост, на котором может выполняться как клиент, так и сервер, может иметь не менее одного ключа, причем для шифрования допускаются различные криптографические алгоритмы. Несколько хостов могут иметь общий ключ хоста. Однако каждый хост должен иметь хотя бы один ключ, с которым работает каждый из требуемых алгоритмов работы с открытыми ключами. В проекте стандарта в настоящее время требуемый алгоритм только один _ DSS (Digital Signature Standard).

Ключ хоста-сервера используется при обмене открытыми ключами с целью проверки того, что клиент действительно общается с настоящим_ (а не подмененным) сервером. Для этого клиент должен знать открытый ключ хоста-сервера. Это знание реализуется в рамках одной из двух моделей.

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

Протоколом предусмотрена возможность отказа от проверки ключа хоста-сервера при самом первом обращении клиента к этому серверу. При этом соединение клиент-сервер будет защищено от пассивного прослушивания сети, но возникает опасность атаки типа человек в середине_ (man-in-the-middle), т. е. попытки временной подмены сервера. Если эта возможность используется, ключ хоста-сервера будет автоматически передан клиенту и сохранен в его локальном файле.

Разработчики проекта протокола ssh особенно заботились о его долголетии_. Протокол будет расширяемым; планируется возможность дополнения криптографических алгоритмов, используемых при работе ssh. C этой целью проектом предусмотрено, что между клиентом и сервером происходят переговоры_, в результате которых выбираются методы шифрования, форматы открытых ключей и т.п., которые будут использованы в данном сеансе. При этом с целью обеспечения интероперабельности должен поддерживаться некоторый минимальный набор алть национальные криптографические стандарты.

Интервал номеров Тип сообщений Протокол.

1-19 Транспортный уровень (общая часть) Транспортный.

20-29 Переговоры клиента и сервера о выборе алгоритма.

30-49 Специфические для метода обмена ключами.

50-59 Протокол аутентификации (общая часть) Аутентификации.

60-79 Протокол аутентификации (часть, специфическая для метода аутентификации).

80-89 Протокол соединения (общая часть) Соединения.

90-127 Сообщения, относящиеся к каналам.

90-128 Резерв (для протоколов клиентов).

192-255 Локальные расширения.

Таблица 1. Номера сообщений ssh и их назначение.

Отдельного упоминания заслуживают вопросы увеличения трафика в связи с применением протоколов ssh. Ясно, что при передаче в сети больших пакетов дополнительная нагрузка, вызванная передачей управляющих заголовков ssh, невелика. Основное внимание следует обратить на приложения, для которых характерны короткие пакеты _ например, telnet. Минимальный размер заголовка TCP/IP равен 32 байта; минимальный же размер пакета при использовании ssh увеличится с 33 до (примерно) 51 байта.

Учитывая, что в Ethernet минимальная длина поля данных пакета равна 46 байт, дополнительный нагрузкой _ в 5 байт _ можно пренебречь. Наиболее существенным влияние ssh оказывается, вероятно, при использовании протокола PPP на низкоскоростных модемных соединениях, поскольку PPP сжимает заголовки TCP/IP. Однако существенный прогресс в скоростях передачи данных позволяет рассчитывать, что дополнительные задержки будут измеряться несколько миллисекундами и останутся незаметны человеку.

Наконец, несколько слов о кодировании сетевых адресов. Поскольку DNS ' ненадежный протокол, в ssh он не используется. При адресации применяются IP-адреса, причем в проекте заложена поддержка IPv6.

Все сообщения (пакеты) ssh содержат номер сообщения _ число от 1 до 255. Этот диапазон разбит на подинтервалы, причем разным уровням протокола ssh отвечают разные диапазоны.

Установка.

При установке всякого бесплатно распространяемого по Internet программного продукта и ssh здесь не исключение ' часто приходится сталкиваться с тем, что используемая Вами версия ОС Unix чуть-чуть_ отличается от того, чего ждали от нее разработчики данного продукта. В результате программный продукт может оказаться не вполне работоспособен, или вовсе транслироваться с ошибками. Автор столкнулся с некоторыми особенностями установки ssh в средах SGI Irix и Linux; о них будет рассказано ниже. Формально наше изложение относится к ssh версии 1.2.26, если явно не оговорено противное (процедуры установки различных версий ничем кардинальным не отличаются).

После того, как дистрибутив ssh получен и разархивирован, процедура установки включает три простых стадии. На первой следует выполнить командный файл configure. Все основные особенности создаваемого варианта ssh задаются параметрами, указываемыми при запуске configure. Можно задать целый ряд ключей (операндов).

В частности, указывается, какие методы шифрования сеанса будут использованы при работе ssh (предлагается, в частности, IDEA, DES, тройной_ DES, ARCFOUR, BLOWFISH). Поскольку в ARCFOUR найдена дыра_, по умолчанию этот метод исключается, а остальные, наоборот, включены. Основным по умолчанию является IDEA, использующий 128-разрядные ключи. Если он исключен, основным алгоритмом становится 3DES, трехкратное последовательное DES-шифрование c 56-разрядным ключом. Учитывая несколько нашумевших вскрытий_ однократного DES-ключа, это выглядит разумной предосторожностью. Нужно отметить также метод BLOWFISH, который при той же длине ключа (от 32 до 448 разрядов) работает быстрее IDEA и DES. Используемый по умолчанию метод шифрования можно указать явно, установив нужное значение SSH_FALL BACK_CIPHER во включаемом файле ssh.h.

При запуске configure можно специфицировать поддержку Kerberos 5, средств работы с сервером аутентификации TIS, с Secure Dynamics Secure ID card и т.д. Можно разрешить или запретить перенаправление портов TCP/IP клиентского и серверного хостов, а также ' отдельно _ перенаправление портов протокола X11.

Можно задать также замену стандартных команд rlogin и rsh соответствующими одноименными модулями из дистрибутива ssh. Тогда для соединений будет использоваться протокол ssh ' конечно, если удаленный компьютер его поддерживает (в противном случае после предупреждения будет осуществлен переход к обычным средствам rlogin/rsh).

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

./configure 'verbose.

'with-libwrap=ПУТЬ 'with-X.

Где ПУТЬ задает путь к библиотеке libwarp.a, которая требуется при использовании tcp_wrapper (в этом случае кроме libwrap.a для установки ssh понадобится также файл tcp.h). Последний операнд указывает на работу с протоколом X11.

При работе configure используется Autoconf, известная программа с лицензией GNU, которая автоматически определяет массу характеристик установленного на локальном компьютере программного обеспечения. При наличии операнда verbose выполнение configure сопровождается выдачей информационных сообщений, позволяющих проконтролировать генерируемые параметры.

В результате выполнения соnfigиге создает ряд новых файлов и каталогов, но главное для понимания процесса установки _ то, что при этом из файла-заготовки Makefile.in создается собственно Makefile.

На второй стадии установки запуск make приводит к компиляции всех основных модулей ssh. Наконец, третья стадия установки запускается по команде make install. При этом происходит запись порожденных программ в целевые_ каталоги (по умолчанию /usr/local/bin, /usr/local/sbin, /usr/local/man), а также создание нескольких файлов в каталоге /etc: ssh_config, sshd_config и ssh_host_key_pub.

В случае неудачи команда make distclean должна удалить все следы проделанного эксперимента_, кроме самого дистрибутива. Так написано в документации; на самом деле: в /usr/local/sbin и /usr/local/bin все остается.

В реальной жизни, конечно, возникают проблемы. Приведем некоторые конкретные примеры. Так, с ОС Irix не рекомендуется использовать версии ssh от 1.2.21 и более ранние из-за большого числа ошибок; желательно применять версии 1.2.25 и выше.

Поскольку применение ssh может вызвать задержки из-за загрузки процессора операциями шифрования, ssh желательно компилировать с оптимизацией. configure, кстати, имеет специальный операнд, разрешающий оптимизацию на уровне ассемблера. В качестве иллюстрации укажем, что для рабочей станции SGI O2 c микропроцессором R5000SC и ОС Irix 6.3, включение оптимизации Си-компилятора дает прирост производительности примерно на 25%. Однако есть сообщения, что такая оптимизация иногда вызывает ошибки при перенаправлении портов X11.

ОС ssh 1.2.26 ssh 2.0.9.

SGI Irix 5.2, 5.3, 6.0.1 6.2-6.4 6.2 6.4.

Digital Unix 4.0, 4.0a, 4.0b OSF/1: 3.0-3.2 4.0.

Sun Solaris 2.3-2.6 SunOS 4.1 Solaris 2.5.1 2.6.

HP-UX 9.x 10.x 10 20.

IBM AIX 4.1 4.2 4.1 4.2.

Linux Slackware 3.x RedHat 5.1 2.0.34.

FreeBSD 1.x 2.x 3.0 2.x 3.0.

Таблица 2. Некоторые поддерживаемые ssh операционные системы.

В ssh 2.0.8 при трансляции в ОС Irix рекомендуется использовать Си-компилятор версии 7.2, поскольку он позволяет создать более производительную программу по сравнению с 7.1. Однако следует использовать cc 7.2.1, поскольку исходный_ Си-компилятор версии 7.2 дает неработоспособный ssh.

В качестве еще одной иллюстрации обсудим Linux. Для компиляции ssh не годится gcc популярной версии 2.7.2: нужна версия 2.7.2.3 или новее. В RedHat Linux для работы с аутентификацией RSA домашний каталог пользователя и его подкаталог .ssh не должны иметь разрешение на запись членами группы.

Файлы ssh.

Обратимся сначала к образующимся после установки исполняемым файлам. Основных файлов два: собственно демон sshd в /usr/local/sbin и клиент ssh в /usr/local/bin. В последнем каталоге располагается также модуль scp (ssh-аналог rcp) и ряд модулей с префиксом ssh_, среди которых отметим модули ssh_agent (аутентификационный агент, хранящий RSA-ключи аутентификации) и ssh_add, служащий для регистрации новых ключей в этом агенте. Кроме того, в /usr/local/bin имеется две важных вспомогательных утилиты: ssh-keygen и make-ssh-known-hosts.

Неисполняемые файлы ssh (кроме справочных файлов, помещаемых в /usr/local/man) располагаются в каталоге /etc и в домашних каталогах пользователей. В каталоге /etc расположены конфигурационные файлы sshd_config и ssh_config, задающие конфигурационные параметры соответственно sshd и ssh; эти файлы образуются автоматически по завершению установки.

В каталог /etc помещается информация о ключах. В файле ssh_host_key задается ключ хоста-сервеssh_host_key_pub) помещается в файл ssh_known_hosts. Естественно, его надо создавать самостоятельно.

В каталоге /etc образуется также рабочий файл ssh_random_seed, который автоматически модифицируется при запуске демона sshd. Наконец, в каталоге /etc могут располагаться еще два файла. Файл shosts.equiv является аналогом файла rhosts.equiv при работе с ssh. Файл sshrc выполняется при процедуре login перед вызовом оболочки.

Файлы, отражающие пользовательские настройки, располагаются в их домашних каталогах _ в подкаталоге .ssh. В этом подкаталоге располагается, в частности, RSA _ ключ пользователя (в файле identity) и соответствующий открытый ключ (в файле identity.pub). Кроме того, в каталоге .ssh может иметься коллекция открытых ключей удаленных_ пользователей (из их файлов identity.pub), находящаяся в файле authorized.keys. Пользователь может создать также свой личный аналог файла /etc/ssh_known_hosts в файле known_hosts.

При первом вызове ssh (клиента) создается и автоматически корректируется при последующих вызовах файл random_seed. Собственные подразумеваемые параметры ssh можно задать в файле config. В файле rc можно указать действия, выполняемые при login до вызова пользовательской оболочки. Наконец, файл .shosts, аналог .rhosts при работе с ssh, располагается в домашнем каталоге пользователя.

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

Типичный вызов ssh-keygen (квадратные скобки, как обычно, означают возможность опустить соответствующий операнд) выглядит так:

Ssh-keygen [-b длина] [-N парольная_фраза] [-c комментарий].

Позволяет создать файлы identity и identity.pub с RSA-ключами, длина которых задается операндом b. По умолчанию длина ключа равна 1024; она не должна быть меньше 512. Поле комментария по умолчанию генерируется в форме user@host. ПАРОЛЬНАЯ_ФРАЗА используется для шифрования личного ключа пользователя; ее рекомендуемая длина _ от 10 до 30 символов. При генерации ключа хоста ПАРОЛЬНАЯ_ФРАЗА должна отсутствовать; такой вызов автоматически происходит в процессе установки.

Утилита make-ssh-known-hosts представляет собой сценарий на языке Perl5 и служит для автоматизации создания файлов типа ssh_known_hosts. Если на компьютере Perl5 не установлен, подобные файлы придется создавать вручную.

Данная утилита обладает развитые средства взаимодействия с DNS-серверами и позволяет выполнять достаточно изощренный опрос этих серверов. Простейшая форма вызова имеет следующий вид:

Make-ssh-known-hosts some.domain > /etc/ssh_known_hosts.

Это позволяет найти и записать в файл ssh_known_hosts открытые ключи всех хостов домена some.domain. Утилита имеет, в частности, средства работы с WKS-записями DNS-сервера. Если в этих записях указан признак наличия ssh, то можно сразу отобрать только хосты, поддерживающие ssh. Аналогично можно отобрать хосты, поддерживающие telnet:

Make-ssh-known-hosts some.domain Ё^wks=.*tе1nеtё > our_hosts.

Утилита может работать аналогичным образом с записями hinfo. Механизм ее работы следующий.

Получив от DNS-сервера список отобранных хостов, make-ssh-known-hosts пытается получить открытые ключи каждого из них. Для этого делается попытка соединиться на порт sshd (22 по умолчанию), и если соединение успешно, пытается выполнить на удаленном хосте команду cat /etc/ ssh_host_key.pub. Если это не удается, утилита проверяет, был ли получен ей в сеансе открытый ключ удаленного хоста; если да _ то он и используется (эту возможность можно отменить при вызове сценария).

Демон sshd.

Запуск демона sshd обычно происходит автоматически при загрузке операционной системы из командного файла наподобие /etc/rc.local. Поскольку sshd должен сгенерировать ключ еще до установления соединения, что требует определенного времени, sshd не рекомендуют запускать через демон inetd. Однако, если процессор достаточно быстр, и длина ключа мала (меньше 512 разрядов), демон может периодически запускаться через inetd при каждой попытке соединиться на порт 22.

Напомним, что в целях безопасности не рекомендуют применять ключи короче 512 разрядов. При запуске sshd длину ключа можно указать в операнде -b (по умолчанию 768 разрядов). Подчеркнем, что здесь речь идет о ключе сервера (демона sshd), используемом в сеансе, а не о ключе хоста-сервера.

Запуск sshd с операндом -d включает режим отладки, что рекомендуется при проверке работоспособности, поскольку при этом выдается ряд информационных сообщений, позволяющих отслеживать происходящее. При нормальной эксплуатации этот режим следует отключить.

Параметры демон sshd читает из файла /etc/sshd_conf. В нем задаются, в частности, ссылки на файлы ssh_host_key и ssh_random_seed, длина ключа сервера, разрешенные методы шифрования, номер используемого sshd порта, уровень протоколирования работы sshd в системном журнале и др. Обычно этот файл является вполне подходящим, и необходимости его корректировать не возникает.

Клиент ssh.

Клиент ssh служит в качестве замены командам rsh и rlogin. Типичная форма вызова ssh выглядит так:

Ssh [-l имя_пользоваетля] ИМЯ_ХОСТА [команда].

Здесь ИМЯ_ПОЛЬЗОВАТЕЛЯ означает имя пользователя на удаленном хосте, с которым происходит соединение (задается операндом ИМЯ_ХОСТА). Операнд КОМАНДА, если он не опущен, указывает выполняемую на удаленном хосте команду.

Команда ssh имеет еще целый ряд операндов. В операнде -с можно указать метод шифрования (idea/blowfish/des/3des/arcfour); в операнде -p указывается номер порта. Операнд -v рекомендуется использовать для получения информации о том, что происходит в процессе установления сеанса, например, при возникновении каких-либо проблем, в первую очередь задержках в соединении.

Два операнда позволяют осуществлять перенаправление портов:

- L ПОРТ:ХОСТ:ПОРТХОСТА.

Позволяет перенаправить ПОРТ локального компьютера на ПОРТХОСТА удаленного компьютера, заданного в аргументе ХОСТ;

-R ПОРТ:ХОСТ:ПОРТХОСТА.

Осуществляет перенаправление ПОРТа на удаленном ХОСТе на порт локального хоста (последний аргумент).

Конфигурационные файлы клиента включают общий файл /etc/ssh_config и личные пользовательские config-файлы. Последние перекрывают_ действие общего файла, и их, в свою очередь, можно заменить явным заданием операндов ssh. В конфигурационном файле задаются такие параметры, как методы шифрования, возможность перенаправления портов, разрешение на использование обычных механизмов rsh/rlogin при невозможности ssh-аутентификации, номер используемого на удаленном сервере порта и др.

©Drkb::03386.

Взято с http://delphiworld.narod.ru.

Локальные операторы языка SQL (BDE).

Вывод нужных полей.

Code: SELECT LastName, FirstName, Salary FROM employee.

Матрицы в Delphi.

Автор: Andrew M. Omutov.

Уважаемые сограждане. В ответ на вопросы Круглого Стола, в основном, от собратьев студентов, публикую алгоритмы матричного исчисления. В них нет ничего сложного, все базируется на функциях стандартного Borland Pascal еще версии 7.0.

Я понимаю, что уровень подготовки наших преподавателей весьма отстает не то, что от нынешних технологий, но даже и от весьма более ранних, но все-таки попробую помочь собратьям "по-несчастью".... :o))).

Перечень функций этой библиотеки:

Code: Unit Matrix; Interface. Type. MatrixPtr = ^MatrixRec; MatrixRec = record. MatrixRow : byte; MatrixCol : byte; MatrixArray : pointer; End; MatrixElement = real; (* Функция возвращает целочисленную степень *). Function IntPower(X,n : integer) : integer; (* Функция создает квадратную матрицу *). Function CreateSquareMatrix(Size : byte) : MatrixPtr; (* Функция создает прямоугольную матрицу *). Function CreateMatrix(Row,Col : byte) : MatrixPtr; (* Функция дублирует матрицу *). Function CloneMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция удаляет матрицу и возвращает TRUE в случае удачи *). Function DeleteMatrix(var MPtr : MatrixPtr) : boolean; (* Функция заполняет матрицу указанным числом *). Function FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean; (* Функция удаляет матрицу MPtr1 и присваивает ей значение MPtr2 *). Function AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr; (* Функция отображает матрицу на консоль *). Function DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean; (* Функция возвращает TRUE, если матрица 1x1 *). Function IsSingleMatrix(MPtr : MatrixPtr) : boolean; (* Функция возвращает TRUE, если матрица квадратная *). Function IsSquareMatrix(MPtr : MatrixPtr) : boolean; (* Функция возвращает количество строк матрицы *). Function GetMatrixRow(MPtr : MatrixPtr) : byte; (* Функция возвращает количество столбцов матрицы *). Function GetMatrixCol(MPtr : MatrixPtr) : byte; (* Процедура устанавливает элемент матрицы *). Procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement); (* Функция возвращает элемент матрицы *). Function GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; (* Функция исключает векторы из матрицы *). Function ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr; (* Функция заменяет строку(столбец) матрицы вектором *). Function SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr; (* Функция возвращает детерминант матрицы *). Function DetMatrix(MPtr : MatrixPtr) : MatrixElement; (* Функция возвращает детерминант треугольной матрицы *). Function DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement; (* Функция возвращает алгебраическое дополнение элемента матрицы *). Function AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; (* Функция создает матрицу алгебраических дополнений элементов матрицы *). Function CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция транспонирует матрицу *). Function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция возвращает обратную матрицу *). Function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция умножает матрицу на число *). Function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr; (* Функция умножает матрицу на матрицу *). Function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция суммирует две матрицы *). Function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция вычитает из первой матрицы вторую *). Function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция решает систему методом Гаусса и возвращает LU-матрицы *). (* Результат функции - вектор-столбец решений *). Function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr; Implementation. Function IntPower(X,n : integer) : integer; Var. Res,i : integer; Begin. If n < 1 then IntPower:= 0. Else begin. Res:= X; For i:=1 to n-1 do Res:= Res*X; IntPower:= Res; End; End; Function CreateSquareMatrix(Size : byte) : MatrixPtr; Var. TempPtr : MatrixPtr; Begin. TempPtr:= nil; GetMem(TempPtr,SizeOf(MatrixRec)); If TempPtr = nil then begin. CreateSquareMatrix:= nil; Exit; End; With TempPtr^ do begin. MatrixRow:= Size; MatrixCol:= Size; MatrixArray:= nil; GetMem(MatrixArray,Size*Size*SizeOf(MatrixElement)); If MatrixArray = nil then begin. FreeMem(TempPtr,SizeOf(MatrixRec)); CreateSquareMatrix:= nil; Exit; End; End; FillMatrix(TempPtr,0); CreateSquareMatrix:= TempPtr; End; Function CreateMatrix(Row,Col : byte) : MatrixPtr; Var. TempPtr : MatrixPtr; Begin. TempPtr:= nil; GetMem(TempPtr,SizeOf(MatrixRec)); If TempPtr = nil then begin. CreateMatrix:= nil; Exit; End; With TempPtr^ do begin. MatrixRow:= Row; MatrixCol:= Col; MatrixArray:= nil; GetMem(MatrixArray,Row*Col*SizeOf(MatrixElement)); If MatrixArray = nil then begin. FreeMem(TempPtr,SizeOf(MatrixRec)); CreateMatrix:= nil; Exit; End; End; FillMatrix(TempPtr,0); CreateMatrix:= TempPtr; End; Function DeleteMatrix(var MPtr : MatrixPtr) : boolean; Begin. If MPtr = nil then DeleteMatrix:= FALSE. Else with MPtr^ do begin. If MatrixArray <> nil then. FreeMem(MatrixArray,MatrixRow*MatrixCol*SizeOf(MatrixElement)); FreeMem(MPtr,SizeOf(MatrixRec)); MPtr:= nil; DeleteMatrix:= TRUE; End; End; Function CloneMatrix(MPtr : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; I,j : byte; Begin. If MPtr = nil then CloneMatrix:= nil. Else with MPtr^ do begin. TempPtr:= CreateMatrix(MPtr^.MatrixRow,MPtr^.MatrixCol); If TempPtr <> nil then begin. For i:= 1 to MatrixRow do. For j:= 1 to MatrixCol do. SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr,i,j)); CloneMatrix:= TempPtr; End else CloneMatrix:= nil; End; End; Function FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean; Var. I,j : byte; Begin. If MPtr = nil then FillMatrix:= FALSE. Else with MPtr^ do begin. For i:= 1 to MatrixRow do. For j:= 1 to MatrixCol do. SetMatrixElement(MPtr,i,j,Value); FillMatrix:= TRUE; End; End; Function AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr; Begin. DeleteMatrix(MPtr1); MPtr1:= MPtr2; AssignMatrix:= MPtr1; End; Function DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean; Var. I,j : byte; Begin. If MPtr = nil then DisplayMatrix:= FALSE. Else with MPtr^ do begin. For i:= 1 to MatrixRow do begin. For j:= 1 to MatrixCol do. Write(GetMatrixElement(MPtr,i,j) : _Int : _Frac); Writeln; End; DisplayMatrix:= TRUE; End; End; Function IsSingleMatrix(MPtr : MatrixPtr) : boolean; Begin. If MPtr <> nil then with MPtr^ do begin. If (MatrixRow = 1) and (MatrixCol = 1) then. IsSingleMatrix:= TRUE. Else IsSingleMatrix:= FALSE; End else IsSingleMatrix:= FALSE; End; Function IsSquareMatrix(MPtr : MatrixPtr) : boolean; Begin. If MPtr <> nil then with MPtr^ do begin. If MatrixRow = MatrixCol then. IsSquareMatrix:= TRUE. Else IsSquareMatrix:= FALSE; End else IsSquareMatrix:= FALSE; End; Function GetMatrixRow(MPtr : MatrixPtr) : byte; Begin. If MPtr <> nil then GetMatrixRow:= MPtr^.MatrixRow. Else GetMatrixRow:= 0; End; Function GetMatrixCol(MPtr : MatrixPtr) : byte; Begin. If MPtr <> nil then GetMatrixCol:= MPtr^.MatrixCol. Else GetMatrixCol:= 0; End; Procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement); Var. TempPtr : ^MatrixElement; Begin. If MPtr <> nil then. If (Row <> 0) or (Col <> 0) then with MPtr^ do begin. Pointer(TempPtr):= pointer(MatrixArray); Inc(TempPtr,MatrixRow*(Col-1)+Row-1); TempPtr^:= Value; End; End; Function GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; Var. TempPtr : ^MatrixElement; Begin. If MPtr <> nil then begin. If (Row <> 0) and (Col <> 0) then with MPtr^ do begin. Pointer(TempPtr):= pointer(MatrixArray); Inc(TempPtr,MatrixRow*(Col-1)+Row-1); GetMatrixElement:= TempPtr^; End else GetMatrixElement:= 0; End else GetMatrixElement:= 0; End; Function ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr; Var. NewPtr : MatrixPtr; NewRow, NewCol : byte; I,j : byte; DiffRow, DiffCol : byte; Begin. If MPtr <> nil then with MPtr^ do begin. If Row = 0 then NewRow:= MatrixRow. Else NewRow:= MatrixRow-1; If Col = 0 then NewCol:= MatrixCol. Else NewCol:= MatrixCol-1; NewPtr:= CreateMatrix(NewRow, NewCol); If (NewPtr = nil) or (NewPtr^.MatrixArray = nil) then begin. ExcludeVectorFromMatrix:= nil; Exit; End; DiffRow:= 0; DiffCol:= 0; For i:= 1 to MatrixRow do begin. If i = Row then DiffRow:= 1. Else for j:= 1 to MatrixCol do if j = Col then DiffCol:= 1. Else SetMatrixElement(NewPtr,i-DiffRow,j-DiffCol, GetMatrixElement(MPtr,i,j)); DiffCol:= 0; End; ExcludeVectorFromMatrix:= NewPtr; End else ExcludeVectorFromMatrix:= nil; End; Function SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr; Var. TempPtr : MatrixPtr; I : byte; Begin. If (MPtr <> nil) and (VPtr <> nil) then begin. TempPtr:= CloneMatrix(MPtr); If TempPtr = nil then begin. SetVectorIntoMatrix:= nil; Exit; End; If VPtr^.MatrixRow = 1 then begin. For i:= 1 to TempPtr^.MatrixCol do. SetMatrixElement(TempPtr,_Pos,i,GetMatrixElement(VPtr,1,i)); End else begin. For i:= 1 to TempPtr^.MatrixRow do. SetMatrixElement(TempPtr,i,_Pos,GetMatrixElement(VPtr,i,1)); End; SetVectorIntoMatrix:= TempPtr; End else SetVectorIntoMatrix:= nil; End; Function DetMatrix(MPtr : MatrixPtr) : MatrixElement; Var. TempPtr : MatrixPtr; I,j : byte; Sum : MatrixElement; Begin. If IsSquareMatrix(MPtr) then begin. If not IsSingleMatrix(MPtr) then begin. TempPtr:= nil; Sum:= 0; For j:= 1 to GetMatrixCol(MPtr) do begin. AssignMatrix(TempPtr,ExcludeVectorFromMatrix(MPtr,1,j)); Sum:= Sum+IntPower(-1,j+1)*GetMatrixElement(MPtr,1,j)*DetMatrix(TempPtr); End; DeleteMatrix(TempPtr); DetMatrix:= Sum; End else DetMatrix:= GetMatrixElement(MPtr,1,1); End else DetMatrix:= 0; End; Function DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement; Var. I : byte; Sum : MatrixElement; Begin. If IsSquareMatrix(MPtr) then begin. Sum:= 1; For i:= 1 to MPtr^.MatrixRow do. Sum:= Sum*GetMatrixElement(MPtr,i,i); DetTriangularMatrix:= Sum; End else DetTriangularMatrix:= 0; End; Function AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; Var. TempPtr : MatrixPtr; Begin. If IsSquareMatrix(MPtr) then begin. TempPtr:= ExcludeVectorFromMatrix(MPtr,Row,Col); If TempPtr = nil then begin. AppendixElement:= 0; Exit; End; AppendixElement:= IntPower(-1,Row+Col)*DetMatrix(TempPtr); DeleteMatrix(TempPtr); End else AppendixElement:= 0; End; Function CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; I,j : byte; Begin. If (MPtr <> nil) or (MPtr^.MatrixArray <> nil) or. (not IsSquareMatrix(MPtr)) then with MPtr^ do begin. TempPtr:= CreateMatrix(MatrixCol,MatrixRow); For i:= 1 to MatrixRow do. For j:= 1 to MatrixCol do. SetMatrixElement(TempPtr,i,j,AppendixElement(MPtr,i,j)); CreateAppendixMatrix:= TempPtr; End else CreateAppendixMatrix:= nil; End; Function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; I,j : byte; Begin. If (MPtr <> nil) or (MPtr^.MatrixArray <> nil) then with MPtr^ do begin. TempPtr:= CreateMatrix(MatrixCol,MatrixRow); For i:= 1 to MatrixRow do. For j:= 1 to MatrixCol do. SetMatrixElement(TempPtr,j,i,GetMatrixElement(MPtr,i,j)); TransponeMatrix:= TempPtr; End else TransponeMatrix:= nil; End; Function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; Determinant : MatrixElement; Begin. If MPtr <> nil then begin. TempPtr:= nil; AssignMatrix(TempPtr,CreateAppendixMatrix(MPtr)); AssignMatrix(TempPtr,TransponeMatrix(TempPtr)); Determinant:= DetMatrix(MPtr); If (TempPtr = nil) or (Determinant = 0) then begin. DeleteMatrix(TempPtr); ReverseMatrix:= nil; Exit; End; AssignMatrix(TempPtr,MultipleMatrixOnNumber(TempPtr,1/Determinant)); ReverseMatrix:= TempPtr; End else ReverseMatrix:= nil; End; Function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr; Var. TempPtr : MatrixPtr; I,j : byte; Begin. If MPtr <> nil then with MPtr^ do begin. TempPtr:= CreateMatrix(MatrixRow,MatrixCol); If TempPtr = nil then begin. MultipleMatrixOnNumber:= nil; Exit; End; For i:= 1 to MatrixRow do. For j:= 1 to MatrixCol do. SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr,i,j)*Number); MultipleMatrixOnNumber:= TempPtr; End else MultipleMatrixOnNumber:= nil; End; Function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; I,j,k : byte; Begin. If (MPtr1 <> nil) and (MPtr2 <> nil) then begin. TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol); If TempPtr = nil then begin. MultipleMatrixOnMatrix:= nil; Exit; End; For i:= 1 to TempPtr^.MatrixRow do. For j:= 1 to TempPtr^.MatrixCol do. For k:= 1 to MPtr1^.MatrixCol do. SetMatrixElement(TempPtr,i,j,GetMatrixElement(TempPtr,i,j)+ GetMatrixElement(MPtr1,i,k)*GetMatrixElement(MPtr2,k,j)); MultipleMatrixOnMatrix:= TempPtr; End else MultipleMatrixOnMatrix:= nil; End; Function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; I,j,k : byte; Begin. If (MPtr1 <> nil) and (MPtr2 <> nil) then begin. TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol); If TempPtr = nil then begin. AddMatrixOnMatrix:= nil; Exit; End; For i:= 1 to TempPtr^.MatrixRow do. For j:= 1 to TempPtr^.MatrixCol do. SetMatrixElement(TempPtr,i,j,GetMatrixElement(Mptr1,i,j)+ GetMatrixElement(MPtr2,i,j)); AddMatrixOnMatrix:= TempPtr; End else AddMatrixOnMatrix:= nil; End; Function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; I,j,k : byte; Begin. If (MPtr1 <> nil) and (MPtr2 <> nil) then begin. TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol); If TempPtr = nil then begin. SubMatrixOnMatrix:= nil; Exit; End; For i:= 1 to TempPtr^.MatrixRow do. For j:= 1 to TempPtr^.MatrixCol do. SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr1,i,j)- GetMatrixElement(MPtr2,i,j)); SubMatrixOnMatrix:= TempPtr; End else SubMatrixOnMatrix:= nil; End; Function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr; Var. TempPtr : MatrixPtr; TempVPtr : MatrixPtr; TempLPtr : MatrixPtr; TempUPtr : MatrixPtr; XSum : MatrixElement; I,j,k : byte; Begin. If (MPtr <> nil) and (VPtr <> nil) then begin. TempUPtr:= CloneMatrix(MPtr); If TempUPtr = nil then begin. GausseMethodMatrix:= nil; Exit; End; TempLPtr:= CreateMatrix(MPtr^.MatrixRow,MPtr^.MatrixCol); If TempLPtr = nil then begin. DeleteMatrix(TempUPtr); GausseMethodMatrix:= nil; Exit; End; TempVPtr:= CloneMatrix(VPtr); If TempVPtr = nil then begin. DeleteMatrix(TempLPtr); DeleteMatrix(TempUPtr); GausseMethodMatrix:= nil; Exit; End; TempPtr:= CreateMatrix(MPtr^.MatrixRow,1); If TempPtr = nil then begin. DeleteMatrix(TempVPtr); DeleteMatrix(TempLPtr); DeleteMatrix(TempUPtr); GausseMethodMatrix:= nil; Exit; End; For j:= 1 to MPtr^.MatrixCol-1 do begin. SetMatrixElement(TempLPtr,j,j,1); For i:= j+1 to MPtr^.MatrixRow do begin. SetMatrixElement(TempLPtr,i,j,GetMatrixElement(TempUPtr,i,j)/ GetMatrixElement(TempUPtr,j,j)); For k:= j to MPtr^.MatrixCol do begin. SetMatrixElement(TempUPtr,i,k,GetMatrixElement(TempUPtr,i,k)- GetMatrixElement(TempLPtr,i,j)*GetMatrixElement(TempUPtr,j,k)); End; SetMatrixElement(TempVPtr,i,1,GetMatrixElement(TempVPtr,i,1)- GetMatrixElement(TempLPtr,i,j)*GetMatrixElement(TempVPtr,j,1)); End; End; SetMatrixElement(TempLPtr,TempLPtr^.MatrixRow,TempLPtr^.MatrixCol,1); SetMatrixElement(TempPtr,TempPtr^.MatrixRow,1, GetMatrixElement(TempVPtr,TempVPtr^.MatrixRow,1)/ GetMatrixElement(TempUPtr,TempUPtr^.MatrixRow,TempUPtr^.MatrixCol)); For j:= MPtr^.MatrixCol-1 downto 1 do begin. XSum:= 0; For k:= j+1 to MPtr^.MatrixCol do. XSum:= XSum+GetMatrixElement(TempUPtr,j,k)* GetMatrixElement(TempPtr,k,1); SetMatrixElement(TempPtr,j,1,(GetMatrixElement(TempVPtr,j,1)-XSum)/ GetMatrixElement(TempUPtr,j,j)); End; LPtr:= TempLPtr; UPtr:= TempUPtr; BPtr:= TempVPtr; GausseMethodMatrix:= TempPtr; End else GausseMethodMatrix:= nil; End; End.

Декомпилляция звукового файла формата Wave и получение звуковых данных.

Интересно, есть ли технология преобразования Wave-формата в обычный набор звуковых данных? К примеру, мне необходимо удалить заголовок и механизм (метод) сжатия, которые могут компилироваться и сохраняться вместе с Wave-файлами.

У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.

Code: Unit LinearSystem; Interface. {============== Тип, описывающий формат WAV ==================}. Type. WAVHeader = record. NChannels: Word; NBitsPerSample: LongInt; NSamplesPerSec: LongInt; NAvgBytesPerSec: LongInt; RIFFSize: LongInt; FmtSize: LongInt; FormatTag: Word; NBlockAlign: LongInt; DataSize: LongInt; End; {============== Поток данных сэмпла ========================}. Const. MaxN = 300; { максимальное значение величины сэмпла }. Type. SampleIndex = 0..MaxN + 3; Type. DataStream = array[SampleIndex] of Real; Var. N: SampleIndex; {============== Переменные сопровождения ======================}. Type. Observation = record. Name: string[40]; {Имя данного сопровождения}. Yyy: DataStream; {Массив указателей на данные}. WAV: WAVHeader; {Спецификация WAV для сопровождения}. Last: SampleIndex; {Последний доступный индекс yyy}. MinO, MaxO: Real; {Диапазон значений yyy}. End; Var. K0R, K1R, K2R, K3R: Observation; K0B, K1B, K2B, K3B: Observation; {================== Переменные имени файла ===================}. Var. StandardDatabase: string[80]; BaseFileName: string[80]; StandardOutput: string[80]; StandardInput: string[80]; {=============== Объявления процедур ==================}. Procedure ReadWAVFile(var Ki, Kj: Observation); Procedure WriteWAVFile(var Ki, Kj: Observation); Procedure ScaleData(var Kk: Observation); Procedure InitAllSignals; Procedure InitLinearSystem; Implementation. {$R *.DFM}. Uses VarGraph, SysUtils; {================== Стандартный формат WAV-файла ===================}. Const. MaxDataSize: LongInt = (MaxN + 1) * 2 * 2; Const. MaxRIFFSize: LongInt = (MaxN + 1) * 2 * 2 + 36; Const. StandardWAV: WAVHeader = ( NChannels: Word(2); NBitsPerSample: LongInt(16); NSamplesPerSec: LongInt(8000); NAvgBytesPerSec: LongInt(32000); RIFFSize: LongInt((MaxN + 1) * 2 * 2 + 36); FmtSize: LongInt(16); FormatTag: Word(1); NBlockAlign: LongInt(4); DataSize: LongInt((MaxN + 1) * 2 * 2). ); {================== Сканирование переменных сопровождения ===================}. Procedure ScaleData(var Kk: Observation); Var. I: SampleIndex; Begin. {Инициализация переменных сканирования}. Kk.MaxO := Kk.yyy[0]; Kk.MinO := Kk.yyy[0]; {Сканирование для получения максимального и минимального значения}. For I := 1 to Kk.Last do. Begin. If Kk.MaxO < Kk.yyy[I] then. Kk.MaxO := Kk.yyy[I]; If Kk.MinO > Kk.yyy[I] then. Kk.MinO := Kk.yyy[I]; End; End; { ScaleData }. Procedure ScaleAllData; Begin. ScaleData(K0R); ScaleData(K0B); ScaleData(K1R); ScaleData(K1B); ScaleData(K2R); ScaleData(K2B); ScaleData(K3R); ScaleData(K3B); End; {ScaleAllData}. {================== Считывание/запись WAV-данных ===================}. Var. InFile, OutFile: file of Byte; Type. Tag = (F0, T1, M1); Type. FudgeNum = record. Case X: Tag of. F0: (chrs: array[0..3] of Byte); T1: (lint: LongInt); M1: (up, dn: Integer); End; Var. ChunkSize: FudgeNum; Procedure WriteChunkName(Name: string); Var. I: Integer; MM: Byte; Begin. For i := 1 to 4 do. Begin. MM := ord(Name[i]); Write(OutFile, MM); End; End; {WriteChunkName}. Procedure WriteChunkSize(LL: Longint); Var. I: integer; Begin. ChunkSize.x := T1; ChunkSize.lint := LL; ChunkSize.x := F0; For I := 0 to 3 do. Write(OutFile, ChunkSize.chrs[I]); End; Procedure WriteChunkWord(WW: Word); Var. I: integer; Begin. ChunkSize.x := T1; ChunkSize.up := WW; ChunkSize.x := M1; For I := 0 to 1 do. Write(OutFile, ChunkSize.chrs[I]); End; {WriteChunkWord}. Procedure WriteOneDataBlock(var Ki, Kj: Observation); Var. I: Integer; Begin. ChunkSize.x := M1; With Ki.WAV do. Begin. Case nChannels of. 1: if nBitsPerSample = 16 then. Begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}. ChunkSize.up := trunc(Ki.yyy[N] + 0.5); If N < MaxN then. ChunkSize.dn := trunc(Ki.yyy[N + 1] + 0.5); N := N + 2; End. Else. Begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}. For I := 0 to 3 do. ChunkSize.chrs[I]. := trunc(Ki.yyy[N + I] + 0.5); N := N + 4; End; 2: if nBitsPerSample = 16 then. Begin {2 Двухканальный 16-битный сэмпл}. ChunkSize.dn := trunc(Ki.yyy[N] + 0.5); ChunkSize.up := trunc(Kj.yyy[N] + 0.5); N := N + 1; End. Else. Begin {4 Двухканальный 8-битный сэмпл}. ChunkSize.chrs[1] := trunc(Ki.yyy[N] + 0.5); ChunkSize.chrs[3] := trunc(Ki.yyy[N + 1] + 0.5); ChunkSize.chrs[0] := trunc(Kj.yyy[N] + 0.5); ChunkSize.chrs[2] := trunc(Kj.yyy[N + 1] + 0.5); N := N + 2; End; End; {with WAV do begin..}. End; {четырехбайтовая переменная "ChunkSize" теперь заполнена}. ChunkSize.x := T1; WriteChunkSize(ChunkSize.lint); {помещаем 4 байта данных}. End; {WriteOneDataBlock}. Procedure WriteWAVFile(var Ki, Kj: Observation); Var. MM: Byte; I: Integer; OK: Boolean; Begin. {Приготовления для записи файла данных}. AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }. ReWrite(OutFile); With Ki.WAV do. Begin. DataSize := nChannels * (nBitsPerSample div 8) * (Ki.Last + 1); RIFFSize := DataSize + 36; FmtSize := 16; End; {Записываем ChunkName "RIFF"}. WriteChunkName('RIFF'); {Записываем ChunkSize}. WriteChunkSize(Ki.WAV.RIFFSize); {Записываем ChunkName "WAVE"}. WriteChunkName('WAVE'); {Записываем tag "fmt_"}. WriteChunkName('fmt '); {Записываем ChunkSize}. Ki.WAV.fmtSize := 16; {должно быть 16-18}. WriteChunkSize(Ki.WAV.fmtSize); {Записываем formatTag, nChannels}. WriteChunkWord(Ki.WAV.formatTag); WriteChunkWord(Ki.WAV.nChannels); {Записываем nSamplesPerSec}. WriteChunkSize(Ki.WAV.nSamplesPerSec); {Записываем nAvgBytesPerSec}. WriteChunkSize(Ki.WAV.nAvgBytesPerSec); {Записываем nBlockAlign, nBitsPerSample}. WriteChunkWord(Ki.WAV.nBlockAlign); WriteChunkWord(Ki.WAV.nBitsPerSample); {Записываем метку блока данных "data"}. WriteChunkName('data'); {Записываем DataSize}. WriteChunkSize(Ki.WAV.DataSize); N := 0; {первая запись-позиция}. While N <= Ki.Last do. WriteOneDataBlock(Ki, Kj); {помещаем 4 байта и увеличиваем счетчик N}. {Освобождаем буфер файла}. CloseFile(OutFile); End; {WriteWAVFile}. Procedure InitSpecs; Begin. End; { InitSpecs }. Procedure InitSignals(var Kk: Observation); Var. J: Integer; Begin. For J := 0 to MaxN do. Kk.yyy[J] := 0.0; Kk.MinO := 0.0; Kk.MaxO := 0.0; Kk.Last := MaxN; End; {InitSignals}. Procedure InitAllSignals; Begin. InitSignals(K0R); InitSignals(K0B); InitSignals(K1R); InitSignals(K1B); InitSignals(K2R); InitSignals(K2B); InitSignals(K3R); InitSignals(K3B); End; {InitAllSignals}. Var. ChunkName: string[4]; Procedure ReadChunkName; Var. I: integer; MM: Byte; Begin. ChunkName[0] := chr(4); For I := 1 to 4 do. Begin. Read(InFile, MM); ChunkName[I] := chr(MM); End; End; {ReadChunkName}. Procedure ReadChunkSize; Var. I: integer; MM: Byte; Begin. ChunkSize.x := F0; ChunkSize.lint := 0; For I := 0 to 3 do. Begin. Read(InFile, MM); ChunkSize.chrs[I] := MM; End; ChunkSize.x := T1; End; {ReadChunkSize}. Procedure ReadOneDataBlock(var Ki, Kj: Observation); Var. I: Integer; Begin. If N <= MaxN then. Begin. ReadChunkSize; {получаем 4 байта данных}. ChunkSize.x := M1; With Ki.WAV do. Case nChannels of. 1: if nBitsPerSample = 16 then. Begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}. Ki.yyy[N] := 1.0 * ChunkSize.up; If N < MaxN then. Ki.yyy[N + 1] := 1.0 * ChunkSize.dn; N := N + 2; End. Else. Begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}. For I := 0 to 3 do. Ki.yyy[N + I] := 1.0 * ChunkSize.chrs[I]; N := N + 4; End; 2: if nBitsPerSample = 16 then. Begin {2 Двухканальный 16-битный сэмпл}. Ki.yyy[N] := 1.0 * ChunkSize.dn; Kj.yyy[N] := 1.0 * ChunkSize.up; N := N + 1; End. Else. Begin {4 Двухканальный 8-битный сэмпл}. Ki.yyy[N] := 1.0 * ChunkSize.chrs[1]; Ki.yyy[N + 1] := 1.0 * ChunkSize.chrs[3]; Kj.yyy[N] := 1.0 * ChunkSize.chrs[0]; Kj.yyy[N + 1] := 1.0 * ChunkSize.chrs[2]; N := N + 2; End; End; If N <= MaxN then. Begin {LastN := N;}. Ki.Last := N; If Ki.WAV.nChannels = 2 then. Kj.Last := N; End. Else. Begin {LastN := MaxN;}. Ki.Last := MaxN; If Ki.WAV.nChannels = 2 then. Kj.Last := MaxN; End; End; End; {ReadOneDataBlock}. Procedure ReadWAVFile(var Ki, Kj: Observation); Var. MM: Byte; I: Integer; OK: Boolean; NoDataYet: Boolean; DataYet: Boolean; NDataBytes: LongInt; Begin. If FileExists(StandardInput) then. With Ki.WAV do. Begin { Вызов диалога открытия файла }. OK := True; {если не изменится где-нибудь ниже}. {Приготовления для чтения файла данных}. AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }. Reset(InFile); {Считываем ChunkName "RIFF"}. ReadChunkName; If ChunkName <> 'RIFF' then. OK := False; {Считываем ChunkSize}. ReadChunkSize; RIFFSize := ChunkSize.lint; {должно быть 18,678}. {Считываем ChunkName "WAVE"}. ReadChunkName; If ChunkName <> 'WAVE' then. OK := False; {Считываем ChunkName "fmt_"}. ReadChunkName; If ChunkName <> 'fmt ' then. OK := False; {Считываем ChunkSize}. ReadChunkSize; FmtSize := ChunkSize.lint; {должно быть 18}. {Считываем formatTag, nChannels}. ReadChunkSize; ChunkSize.x := M1; FormatTag := ChunkSize.up; NChannels := ChunkSize.dn; {Считываем nSamplesPerSec}. ReadChunkSize; NSamplesPerSec := ChunkSize.lint; {Считываем nAvgBytesPerSec}. ReadChunkSize; NAvgBytesPerSec := ChunkSize.lint; {Считываем nBlockAlign}. ChunkSize.x := F0; ChunkSize.lint := 0; For I := 0 to 3 do. Begin. Read(InFile, MM); ChunkSize.chrs[I] := MM; End; ChunkSize.x := M1; NBlockAlign := ChunkSize.up; {Считываем nBitsPerSample}. NBitsPerSample := ChunkSize.dn; For I := 17 to fmtSize do. Read(InFile, MM); NoDataYet := True; While NoDataYet do. Begin. {Считываем метку блока данных "data"}. ReadChunkName; {Считываем DataSize}. ReadChunkSize; DataSize := ChunkSize.lint; If ChunkName <> 'data' then. Begin. For I := 1 to DataSize do. {пропуск данных, не относящихся к набору звуковых данных}. Read(InFile, MM); End. Else. NoDataYet := False; End; NDataBytes := DataSize; {Наконец, начинаем считывать данные для байтов nDataBytes}. If nDataBytes > 0 then. DataYet := True; N := 0; {чтение с первой позиции}. While DataYet do. Begin. ReadOneDataBlock(Ki, Kj); {получаем 4 байта}. NDataBytes := nDataBytes - 4; If nDataBytes <= 4 then. DataYet := False; End; ScaleData(Ki); If Ki.WAV.nChannels = 2 then. Begin. Kj.WAV := Ki.WAV; ScaleData(Kj); End; {Освобождаем буфер файла}. CloseFile(InFile); End. Else. Begin. InitSpecs; {файл не существует}. InitSignals(Ki); {обнуляем массив "Ki"}. InitSignals(Kj); {обнуляем массив "Kj"}. End; End; { ReadWAVFile }. {================= Операции с набором данных ====================}. Const. MaxNumberOfDataBaseItems = 360; Type. SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems; Var. DataBaseFile: file of Observation; LastDataBaseItem: LongInt; {Номер текущего элемента набора данных}. ItemNameS: array[SignalDirectoryIndex] of string[40]; Procedure GetDatabaseItem(Kk: Observation; N: LongInt); Begin. If N <= LastDataBaseItem then. Begin. Seek(DataBaseFile, N); Read(DataBaseFile, Kk); End. Else. InitSignals(Kk); End; {GetDatabaseItem}. Procedure PutDatabaseItem(Kk: Observation; N: LongInt); Begin. If N < MaxNumberOfDataBaseItems then. If N <= LastDataBaseItem then. Begin. Seek(DataBaseFile, N); Write(DataBaseFile, Kk); LastDataBaseItem := LastDataBaseItem + 1; End. Else. While LastDataBaseItem <= N do. Begin. Seek(DataBaseFile, LastDataBaseItem); Write(DataBaseFile, Kk); LastDataBaseItem := LastDataBaseItem + 1; End. Else. ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}. End; {PutDatabaseItem}. Procedure InitDataBase; Begin. LastDataBaseItem := 0; If FileExists(StandardDataBase) then. Begin. Assign(DataBaseFile, StandardDataBase); Reset(DataBaseFile); While not EOF(DataBaseFile) do. Begin. GetDataBaseItem(K0R, LastDataBaseItem); ItemNameS[LastDataBaseItem] := K0R.Name; LastDataBaseItem := LastDataBaseItem + 1; End; If EOF(DataBaseFile) then. If LastDataBaseItem > 0 then. LastDataBaseItem := LastDataBaseItem - 1; End; End; {InitDataBase}. Function FindDataBaseName(Nstg: string): LongInt; Var. ThisOne: LongInt; Begin. ThisOne := 0; FindDataBaseName := -1; While ThisOne < LastDataBaseItem do. Begin. If Nstg = ItemNameS[ThisOne] then. Begin. FindDataBaseName := ThisOne; Exit; End; ThisOne := ThisOne + 1; End; End; {FindDataBaseName}. {======================= Инициализация модуля ========================}. Procedure InitLinearSystem; Begin. BaseFileName := '\PROGRA~1\SIGNAL~1\'; StandardOutput := BaseFileName + 'K0.wav'; StandardInput := BaseFileName + 'K0.wav'; StandardDataBase := BaseFileName + 'Radar.sdb'; InitAllSignals; InitDataBase; ReadWAVFile(K0R, K0B); ScaleAllData; End; {InitLinearSystem}. Begin {инициализируемый модулем код}. InitLinearSystem; End. {Unit LinearSystem}.

Как использовать в своей программе API DirectSound и DirectSound3D.

Представляю вашему вниманию рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WАV'файл в секундах (округление в сторону увеличения). При нажатии на кнопку происходит микширование из вторичных буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок, читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер данных, так как в некоторых WAV файлах существует текстовый довесок, и если его не убрать, в динамиках возможен треск).

Пример 1-ый.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Button1: TButton; Timer1: TTimer; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Procedure Button1Click(Sender: TObject); Private. { Private declarations }. DirectSound : IDirectSound; DirectSoundBuffer : IDirectSoundBuffer; SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer; Procedure AppCreateWritePrimaryBuffer; Procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer; SamplesPerSec: Integer; Bits: Word; isStereo:Boolean; Time: Integer); Procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer; OffSet: DWord; var SoundData; SoundBytes: DWord); Procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer); Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. If DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then. Raise Exception.Create('Failed to create IDirectSound object'); AppCreateWritePrimaryBuffer; AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050,8,False,10); AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050,16,True,1); End; Procedure TForm1.FormDestroy(Sender: TObject); Var. I: ShortInt; Begin. If Assigned(DirectSoundBuffer) then. DirectSoundBuffer.Release; For i:=0 to 1 do. If Assigned(SecondarySoundBuffer[i]) then. SecondarySoundBuffer[i].Release; If Assigned(DirectSound) then. DirectSound.Release; End; Procedure TForm1.AppWriteDataToBuffer; Var. AudioPtr1, AudioPtr2 : Pointer; AudioBytes1, AudioBytes2 : DWord; H : HResult; Temp : Pointer; Begin. H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0); If H = DSERR_BUFFERLOST then. Begin. Buffer.Restore; If Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then. Raise Exception.Create('Unable to Lock Sound Buffer'); End. Else. If H <> DS_OK then. Raise Exception.Create('Unable to Lock Sound Buffer'); Temp := @SoundData; Move(Temp^, AudioPtr1^, AudioBytes1); If AudioPtr2 <> nil then. Begin. Temp := @SoundData; Inc(Integer(Temp), AudioBytes1); Move(Temp^, AudioPtr2^, AudioBytes2); End; If Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK then. Raise Exception.Create('Unable to UnLock Sound Buffer'); End; Procedure TForm1.AppCreateWritePrimaryBuffer; Var. BufferDesc: DSBUFFERDESC; Caps: DSBCaps; PCM: TWaveFormatEx; Begin. FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0); FillChar(PCM, SizeOf(TWaveFormatEx),0); With BufferDesc do. Begin. PCM.wFormatTag:=WAVE_FORMAT_PCM; PCM.nChannels:=2; PCM.nSamplesPerSec:=22050; PCM.nBlockAlign:=4; PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign; PCM.wBitsPerSample:=16; PCM.cbSize:=0; DwSize:=SizeOf(DSBUFFERDESC); DwFlags:=DSBCAPS_PRIMARYBUFFER; DwBufferBytes:=0; LpwfxFormat:=nil; End; If DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then. Raise Exception.Create('Unable to set Coopeative Level'); If DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then. Raise Exception.Create('Create Sound Buffer failed'); If DirectSoundBuffer.SetFormat(PCM) <> DS_OK then. Raise Exception.Create('Unable to Set Format '); If DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then. Raise Exception.Create('Unable to set Coopeative Level'); End; Procedure TForm1.AppCreateWriteSecondaryBuffer; Var. BufferDesc: DSBUFFERDESC; Caps: DSBCaps; PCM: TWaveFormatEx; Begin. FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0); FillChar(PCM, SizeOf(TWaveFormatEx),0); With BufferDesc do. Begin. PCM.wFormatTag:=WAVE_FORMAT_PCM; If isStereo then. PCM.nChannels:=2. Else. PCM.nChannels:=1; PCM.nSamplesPerSec:=SamplesPerSec; PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels; PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign; PCM.wBitsPerSample:=Bits; PCM.cbSize:=0; DwSize:=SizeOf(DSBUFFERDESC); DwFlags:=DSBCAPS_STATIC; DwBufferBytes:=Time*PCM.nAvgBytesPerSec; LpwfxFormat:=@PCM; End; If DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK then. Raise Exception.Create('Create Sound Buffer failed'); End; Procedure TForm1.CopyWAVToBuffer; Var. Data : PChar; FName : TFileStream; DataSize : DWord; Chunk : string[4]; Pos : Integer; Begin. FName:=TFileStream.Create(name,fmOpenRead); Pos:=24; SetLength(Chunk,4); Repeat. FName.Seek(Pos, soFromBeginning); FName.read(Chunk[1],4); Inc(Pos); Until. Chunk = 'data'; FName.Seek(Pos+3, soFromBeginning); FName.read(DataSize, SizeOf(DWord)); GetMem(Data,DataSize); FName.read(Data^, DataSize); FName.Free; AppWriteDataToBuffer(Buffer,0,Data^,DataSize); FreeMem(Data,DataSize); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]); CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]); If SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK then. ShowMessage('Can not play the Sound'); If SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK then. ShowMessage('Can not play the Sound'); End; End.

©Drkb::03615.

Пример 2-ой.

Представляю вашему вниманию очередной пример работы с DirectSound на Delphi. В этом примере показан принцип работы с 3D буфером. Итак, процедуры AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил без изменения (см. письма с до этого). Процедура AppCreateWriteSecondary3DBuffer является полным аналогом процедуры AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который указывает на то, что со статическим вторичным буфером будет связан еще один буфер - SecondarySound3DBuffer. Чтобы его инициализировать, а также установить некоторые начальные значения (положение в пространстве, скорость и .т.д.) вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer. В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается положение источника звука в пространстве: SetPosition(Pos,1,1,0). X,Y,Z Таким образом в начальный момент времени источник находится на высоте 1 м (ось Y направлена вертикально вверх, а ось Z - "в экран"). Если смотреть сверху :

^ Z.

O----------------> X.

Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1). Разумеется понятие "метр" весьма условно. При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук 'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно 3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно повторяющийся звук; время в 0.01 с ухом практически не улавливается и получается непрерывный звук летящего вертолета. После этого запускется таймер (поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется вам совсем необязательно делать именно так, это просто пример. В процедуре Timer1Timer просто меняется координата X с шагом 0.1. В итоге получаем летящий вертолет слева направо. Заодно можете проверить, правильно ли у вас расположены колонки.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Button1: TButton; Timer1: TTimer; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Procedure Button1Click(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Private. { Private declarations }. DirectSound : IDirectSound; DirectSoundBuffer : IDirectSoundBuffer; SecondarySoundBuffer : IDirectSoundBuffer; SecondarySound3DBuffer : IDirectSound3DBuffer; Procedure AppCreateWritePrimaryBuffer; Procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer; SamplesPerSec: Integer; Bits: Word; IsStereo:Boolean; Time: Integer); Procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer; Var _3DBuffer: IDirectSound3DBuffer); Procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer; OffSet: DWord; var SoundData; SoundBytes: DWord); Procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer); Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Var. Result: HResult; Begin. If DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then. Raise Exception.Create('Failed to create IDirectSound object'); AppCreateWritePrimaryBuffer; AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer, 22050,8,False,4); AppSetSecondary3DBuffer(SecondarySoundBuffer, SecondarySound3DBuffer); Timer1.Enabled:=False; End; Procedure TForm1.FormDestroy(Sender: TObject); Var. I: ShortInt; Begin. If Assigned(DirectSoundBuffer) then. DirectSoundBuffer.Release; If Assigned(SecondarySound3DBuffer) then. SecondarySound3DBuffer.Release; If Assigned(SecondarySoundBuffer) then. SecondarySoundBuffer.Release; If Assigned(DirectSound) then. DirectSound.Release; End; Procedure TForm1.AppCreateWritePrimaryBuffer; Var. BufferDesc: DSBUFFERDESC; Caps: DSBCaps; PCM: TWaveFormatEx; Begin. FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0); FillChar(PCM, SizeOf(TWaveFormatEx),0); With BufferDesc do. Begin. PCM.wFormatTag:=WAVE_FORMAT_PCM; PCM.nChannels:=2; PCM.nSamplesPerSec:=22050; PCM.nBlockAlign:=4; PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign; PCM.wBitsPerSample:=16; PCM.cbSize:=0; DwSize:=SizeOf(DSBUFFERDESC); DwFlags:=DSBCAPS_PRIMARYBUFFER; DwBufferBytes:=0; LpwfxFormat:=nil; End; If DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then. Raise Exception.Create('Unable to set Cooperative Level'); If DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then. Raise Exception.Create('Create Sound Buffer failed'); If DirectSoundBuffer.SetFormat(PCM) <> DS_OK then. Raise Exception.Create('Unable to Set Format '); If DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then. Raise Exception.Create('Unable to set Cooperative Level'); End; Procedure TForm1.AppCreateWriteSecondary3DBuffer; Var. BufferDesc: DSBUFFERDESC; Caps: DSBCaps; PCM: TWaveFormatEx; Begin. FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0); FillChar(PCM, SizeOf(TWaveFormatEx),0); With BufferDesc do. Begin. PCM.wFormatTag:=WAVE_FORMAT_PCM; If isStereo then. PCM.nChannels:=2. Else. PCM.nChannels:=1; PCM.nSamplesPerSec:=SamplesPerSec; PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels; PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign; PCM.wBitsPerSample:=Bits; PCM.cbSize:=0; DwSize:=SizeOf(DSBUFFERDESC); DwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D; DwBufferBytes:=Time*PCM.nAvgBytesPerSec; LpwfxFormat:=@PCM; End; If DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then. Raise Exception.Create('Create Sound Buffer failed'); End; Procedure TForm1.AppWriteDataToBuffer; Var. AudioPtr1, AudioPtr2 : Pointer; AudioBytes1, AudioBytes2 : DWord; H : HResult; Temp : Pointer; Begin. H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0); If H = DSERR_BUFFERLOST then. Begin. Buffer.Restore; If Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then. Raise Exception.Create('Unable to Lock Sound Buffer'); End. Else. If H <> DS_OK then. Raise Exception.Create('Unable to Lock Sound Buffer'); Temp:=@SoundData; Move(Temp^, AudioPtr1^, AudioBytes1); If AudioPtr2 <> nil then. Begin. Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1); Move(Temp^, AudioPtr2^, AudioBytes2); End; If Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then. Raise Exception.Create('Unable to UnLock Sound Buffer'); End; Procedure TForm1.CopyWAVToBuffer; Var. Data : PChar; FName : TFileStream; DataSize : DWord; Chunk : string[4]; Pos : Integer; Begin. FName:=TFileStream.Create(name,fmOpenRead); Pos:=24; SetLength(Chunk,4); Repeat. FName.Seek(Pos, soFromBeginning); FName.read(Chunk[1],4); Inc(Pos); Until. Chunk = 'data'; FName.Seek(Pos+3, soFromBeginning); FName.read(DataSize, SizeOf(DWord)); GetMem(Data,DataSize); FName.read(Data^, DataSize); FName.Free; AppWriteDataToBuffer(Buffer,0,Data^,DataSize); FreeMem(Data,DataSize); End; Var. Pos: Single = -25; Procedure TForm1.AppSetSecondary3DBuffer; Begin. If Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then. Raise Exception.Create('Failed to create IDirectSound3D object'); If _3DBuffer.SetPosition(Pos,1,1,0) <> DS_OK then. Raise Exception.Create('Failed to set IDirectSound3D Position'); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer); If SecondarySoundBuffer.Play(0,0,DSBPLAY_LOOPING) <> DS_OK then. ShowMessage('Can not play the Sound'); Timer1.Enabled:=True; End; Procedure TForm1.Timer1Timer(Sender: TObject); Begin. SecondarySound3DBuffer.SetPosition(Pos,1,1,0); Pos:=Pos + 0.1; End; End.

Crystal Reports 8.0 через API.

Автор: Андрей Зубарев.

Специально для Королевства Delphi.

Вступление.

Crystal Reports (далее как CR) на сегодняшний день является лидирующим пакетом для разработки отчетности в крупных компаниях. Для доступа к отчетам компания Seagate предоставляет несколько вариантов:

Элемент управления Crystal ActiveX.

Компонент Report Designer Component.

Компоненты VCL сторонних разработчиков.

Automation Server.

Вызовы API реализуются через Report Engine API (далее RE).

По моему мнению, лучшим является доступ посредством API функций, т.к.:

Вы полностью контролируете все, что происходит.

Узнаете, как все это работает.

Не зависите от фирмы разработчика компонент и их версий.

Не платите денег (хотя этот момент расплывчат J).

В 90% случаев необходимо только вывести отчет и передать входящие параметры, т.е. вы получаете "тонкое" приложения на основе своих же наработок, что согласитесь, греет душу программиста. Предполагается, что читатель знаком с работой в Crystal Reports и понимает концепцию разработки отчетов в данной среде.

Примечание Vit: позволю себе внести поправку, фирма Seagate имеет свой собственный VCL компонент для работы со всеми версиями Crystal Report начиная с 4й и заканчивая 9й. К сожалению разработка VCL компонента обычно задерживается на пол-года, а иногда и дольше со времени выхода очередного релиза. Мне доводилось не однократно самому переделывать компонент от старой версии для более новой и обычно это не очень сложная задача. Компонент можно взять с FTP Seagate.

Необходимые файлы.

Библиотека [crpe32.dll] содержит интерфейс вызовов API функций.

Модуль [uCrystalApi.pas] с описаниями API функций. Он был подправлен мной, так как было несколько синтаксических ошибок.

Для работы примера необходим источник данных, в качестве которого используется демонстрационная БД MS Access 2000 [source_db.mdb]. В качестве драйвера связи используется OLE DB для MS Jet 4.0. БД должна находиться в той же папке, где и пример отчета.

Если вы хотите распространять ваше приложение с отчетами, тогда ознакомьтесь с содержимым файла [crpe32.dep], который содержит список необходимых файлов для работы RE.

Пример реализован на Delphi 6.0.

Программируем.

Первым надо "запустить машину" CR, посредством вызова функции PEOpenEngine для инициализации механизма отчетов. Надо заметить, что вызов данной функции справедлив только для одного потока.

Теперь можно и начать подготовку отчета для вывода. Вызов PEOpenPrintJob дает нам дескриптор задачи (отчета), который необходимо передавать в другие функции.

// Синтаксис функции.

PEOpenPrintJob(PathToReport: PChar): SmallInt;

{

Где,

PathToReport - путь к файлу отчета.

Результат функции - дескриптор полученной задачи.

Пример:

FHandleJob := PEOpenPrintJob(PChar(edtPathReport.Text));

}

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

Далее необходимо сказать системе, куда выводить отчет: в окно предварительного просмотра (…ToWindow) или на принтер (…ToPrinter).

// Синтаксис функций:

PEOutputToWindow(printJob : Smallint; title: PChar;

Left: Integer; top: Integer;

Width: Integer; height: Integer;

Style: DWord;

ParentWindow : HWnd): Bool;

PEOutputToPrinter(printJob: Word;

NCopies: Integer)): Bool;

{

Где,

PrintJob - дескриптор задачи.

Title - заголовок окна.

Left, top, width, height - координаты окна.

Style - стиль окна (типа WS_VSCROLL, WS_VISIBLE и т.д.).

ParentWindow - дескриптор окна в котором будет окно отчета.

NCopies - количество копий.

Пример:

Result:= PEOutputToWindow(FHandleJob,

PChar(TForm(Self).Caption),

0, 0, 0, 0, 0, FWindow);

}

Подготовив механизм вывода отправляем отчет для вывода функцией PEStartPrintJob.

// Синтаксис функции:

Function PEStartPrintJob(printJob: Word;

WaitUntilDone: Bool): Bool;

{

Где,

PrintJob - дескриптор задачи.

WaitUntilDone - зарезервирован. Всегда должен быть True.

Пример:

PEStartPrintJob(FHandleJob, True);

}

После отправки отчета, если не надо производить с ним операций, закрываем задание функцией PEClosePrintJob.

// Синтаксис функции:

Function PEClosePrintJob (printJob: Word): Bool;

{

Где,

PrintJob - дескриптор задачи.

Пример:

PEClosePrintJob(FHandleJob);

}

Между вызовами функций PEOpenPrintJob и PEClosePrintJob может стоять сколько угодно вызовов функций PEOutputTo…, PEStartPrintJob.

В итоге получается схема вызовов:

PEOpenEngine.

PEOpenPrintJob.

PEOutputToWindow.

PEStartPrintJob.

PEClosePrintJob.

PECloseEngine.

Пример просмотра отчета.

Ниже приведен код процедуры для просмотра отчета из примера.

Code: Procedure TFrmMain.btnReportPreviewClick(Sender: TObject); Var. // Дескриптор окна в котором производится просмотр отчета. FWindow: THandle; // Информация об источнике данных. // См. раздел "Получение параметров и свойств источника". Lt: PELogOnInfo; Begin. // В зависимости от флага устанавливаем дескриптор окна. // При нуле, отчет будет показан в независимом внешнем окне. If chkWindow.Checked then. FWindow := 0. Else. FWindow := pnlPreview.Handle; // Открываем отчет и получаем дескриптор задачи. FHandleJob := PEOpenPrintJob(PChar(edtPathReport.Text)); // Получение параметров источника данных отчета. FillChar(lt, SizeOf(PELogOnInfo), 0); Lt.StructSize := SizeOf(PELogOnInfo); PEGetNthTableLogOnInfo(FHandleJob, 0, lt); // Устанавливаем новые параметры источника данных отчета. StrPCopy(@lt.ServerName, ExtractFilePath(edtPathReport.Text) + 'source_db.mdb'); PESetNthTableLogOnInfo(FHandleJob, 0, lt, False); // Настраиваем окно вывода. PEOutputToWindow(FHandleJob, PChar(TForm(Self).Caption), 0, 0, 0, 0, 0, FWindow); // Выводим отчет. PEStartPrintJob(FHandleJob, True); // Закрываем дескриптор задания. PEClosePrintJob(FHandleJob); End;

Определение восхода и захода солнца и луны.

Автор: Александр Ермолаев.

Code: { Программа вычисляет время восхода и захода. Солнца по дате (с точностью до минуты) в пределах. Нескольких текущих столетий. Производит корректировку, если. Географическая. Точка находится в арктическом или антарктическом регионе, где заход. Или восход солнца. На текущую дату может не состояться. Вводимые данные: положительная. Северная широта и. Отрицательная западная долгота. Часовой пояс указывается относительно. Гринвича. (например, 5 для EST и 4 для EDT). Алгоритм обсуждался в. "Sky & Telescope" за август 1994, страница 84. } Program sunproject; Uses. Forms, Main in 'main.pas' {Sun}; {$R *.RES}. Begin. Application.Initialize; Application.Title := 'Sun'; Application.CreateForm(TSun, Sun); Application.Run; End.

Работа с последовательными портами.

Code: //{$DEFINE COMM_UNIT}. //Простой пример работы с последовательными портами. //Код содержит интуитивно понятные комментарии и строки на шведском языке, //нецелесообразные для перевода. //Compiler maakt Simple_Comm.Dll of Simple_Com.Dcu afhankelijk van 1e Regel. (COMM_UNIT). {$IFNDEF COMM_UNIT}. Library Simple_Comm; {$ELSE}. Unit Simple_Comm; Interface. {$ENDIF}. Uses Windows, Messages; Const. M_BaudRate = 1; Const. M_ByteSize = 2; Const. M_Parity = 4; Const. M_Stopbits = 8; {$IFNDEF COMM_UNIT}. {$R Script2.Res} //versie informatie. {$ENDIF}. {$IFDEF COMM_UNIT}. Function Simple_Comm_Info: PChar; StdCall; Function. Simple_Comm_Open(Port: PChar; BaudRate: DWORD; ByteSize, Parity, StopBits: Byte; Mas. K: Integer; WndHandle: HWND; WndCommand: UINT; var Id: Integer): Integer; StdCall; Function Simple_Comm_Close(Id: Integer): Integer; StdCall; Function. Simple_Comm_Write(Id: Integer; Buffer: PChar; Count: DWORD): Integer; StdCall; Function Simple_Comm_PortCount: DWORD; StdCall; Const. M_None = 0; Const. M_All = 15; Implementation. {$ENDIF}. Const. InfoString = 'Simple_Comm.Dll (c) by E.L. Lagerburg 1997'; Const. MaxPorts = 5; Const. BDoRun: array[0..MaxPorts - 1] of boolean. = (False, False, False, False, False); Const. HCommPort: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0); Const. HThread: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0); Const. DwThread: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0); Const. HWndHandle: array[0..MaxPorts - 1] of Hwnd = (0, 0, 0, 0, 0); Const. HWndCommand: array[0..MaxPorts - 1] of UINT = (0, 0, 0, 0, 0); Const. PortCount: Integer = 0; Function Simple_Comm_Info: PChar; stdcall; Begin. Result := InfoString; End; //Thread functie voor lezen compoort. Function Simple_Comm_Read(Param: Pointer): Longint; stdcall; Var. Count: Integer; Id: Integer; ReadBuffer: array[0..127] of byte; Begin. Id := Integer(Param); While bDoRun[id] do. Begin. ReadFile(hCommPort[id], ReadBuffer, 1, Count, nil); If (Count > 0) then. Begin. If ((hWndHandle[id] <> 0) and. (hWndCommand[id] > WM_USER)) then. SendMessage(hWndHandle[id], hWndCommand[id], Count, LPARAM(@ReadBuffer)); End; End; Result := 0; End; //Export functie voor sluiten compoort. Function Simple_Comm_Close(Id: Integer): Integer; stdcall; Begin. If (ID < 0) or (id > MaxPorts - 1) or (not bDoRun[Id]) then. Begin. Result := ERROR_INVALID_FUNCTION; Exit; End; BDoRun[Id] := False; Dec(PortCount); FlushFileBuffers(hCommPort[Id]); If not. PurgeComm(hCommPort[Id], PURGE_TXABORT + PURGE_RXABORT + PURGE_TXCLEAR + PURGE_RXCL. EAR) then. Begin. Result := GetLastError; Exit; End; If WaitForSingleObject(hThread[Id], 10000) = WAIT_TIMEOUT then. If not TerminateThread(hThread[Id], 1) then. Begin. Result := GetLastError; Exit; End; CloseHandle(hThread[Id]); HWndHandle[Id] := 0; HWndCommand[Id] := 0; If not CloseHandle(hCommPort[Id]) then. Begin. Result := GetLastError; Exit; End; HCommPort[Id] := 0; Result := NO_ERROR; End; Procedure Simple_Comm_CloseAll; stdcall; Var. Teller: Integer; Begin. For Teller := 0 to MaxPorts - 1 do. Begin. If bDoRun[Teller] then. Simple_Comm_Close(Teller); End; End; Function GetFirstFreeId: Integer; stdcall; Var. Teller: Integer; Begin. For Teller := 0 to MaxPorts - 1 do. Begin. If not bDoRun[Teller] then. Begin. Result := Teller; Exit; End; End; Result := -1; End; //Export functie voor openen compoort. Function. Simple_Comm_Open(Port: PChar; BaudRate: DWORD; ByteSize, Parity, StopBits: Byte; Mas. K: Integer; WndHandle: HWND; WndCommand: UINT; var Id: Integer): Integer; Stdcall; Var. PrevId: Integer; CtmoCommPort: TCOMMTIMEOUTS; //Lees specificaties voor de compoort. DcbCommPort: TDCB; Begin. If (PortCount >= MaxPorts) or (PortCount < 0) then. Begin. Result := error_invalid_function; Exit; End; Result := 0; Previd := id; Id := getfirstfreeid; If id = -1 then. Begin. Id := previd; Result := error_invalid_function; Exit; End; Hcommport[id] := createfile(port, generic_read or. Generic_write, 0, nil, open_existing, file_attribute_normal, 0); If hcommport[id] = invalid_handle_value then. Begin. Bdorun[id] := false; Id := previd; Result := getlasterror; Exit; End; //lees specificaties voor het comm bestand. Ctmocommport.readintervaltimeout := maxdword; Ctmocommport.readtotaltimeoutmultiplier := maxdword; Ctmocommport.readtotaltimeoutconstant := maxdword; Ctmocommport.writetotaltimeoutmultiplier := 0; Ctmocommport.writetotaltimeoutconstant := 0; //instellen specificaties voor het comm bestand. If not setcommtimeouts(hcommport[id], ctmocommport) then. Begin. Bdorun[id] := false; Closehandle(hcommport[id]); Id := previd; Result := getlasterror; Exit; End; //instellen communicatie. Dcbcommport.dcblength := sizeof(tdcb); If not getcommstate(hcommport[id], dcbcommport) then. Begin. Bdorun[id] := false; Closehandle(hcommport[id]); Id := previd; Result := getlasterror; Exit; End; If (mask and m_baudrate <> 0) then. DcbCommPort.BaudRate := BaudRate; If (Mask and M_ByteSize <> 0) then. DcbCommPort.ByteSize := ByteSize; If (Mask and M_Parity <> 0) then. DcbCommPort.Parity := Parity; If (Mask and M_Stopbits <> 0) then. DcbCommPort.StopBits := StopBits; If not SetCommState(hCommPort[Id], dcbCommPort) then. Begin. BDoRun[Id] := FALSE; CloseHandle(hCommPort[Id]); Id := PrevId; Result := GetLastError; Exit; End; //Thread voor lezen compoort. BDoRun[Id] := TRUE; HThread[Id] := CreateThread(nil, 0, @Simple_Comm_Read, Pointer(Id), 0, DwThread[Id]. ); If hThread[Id] = 0 then. Begin. BDoRun[Id] := FALSE; CloseHandle(hCommPort[Id]); Id := PrevId; Result := GetLastError; Exit; End. Else. Begin. SetThreadPriority(hThread[Id], THREAD_PRIORITY_HIGHEST); HWndHandle[Id] := WndHandle; HWndCommand[Id] := WndCommand; Inc(PortCount); Result := NO_ERROR; End; End; //Export functie voor schrijven naar compoort; Function. Simple_Comm_Write(Id: Integer; Buffer: PChar; Count: DWORD): Integer; stdcall; Var. Written: DWORD; Begin. If (Id < 0) or (id > Maxports - 1) or (not bDoRun[Id]) then. Begin. Result := ERROR_INVALID_FUNCTION; Exit; End; If not WriteFile(hCommPort[Id], Buffer, Count, Written, nil) then. Begin. Result := GetLastError(); Exit; End; If (Count <> Written) then. Result := ERROR_WRITE_FAULT. Else. Result := NO_ERROR; End; //Aantal geopende poorten voor aanroepende applicatie. Function Simple_Comm_PortCount: DWORD; stdcall; Begin. Result := PortCount; End; {$IFNDEF COMM_UNIT}. Exports. Simple_Comm_Info Index 1, Simple_Comm_Open Index 2, Simple_Comm_Close Index 3, Simple_Comm_Write Index 4, Simple_Comm_PortCount index 5; Procedure DLLMain(dwReason: DWORD); Begin. If dwReason = DLL_PROCESS_DETACH then. Simple_Comm_CloseAll; End; Begin. DLLProc := @DLLMain; DLLMain(DLL_PROCESS_ATTACH); //geen nut in dit geval. End. {$ELSE}. Initialization. Finalization. Simple_Comm_CloseAll; End. {$ENDIF}. Другое решение: создание модуля I / O(ввода / вывода)под Windows 95 / NT.Вот он: ) (с TDCB в SetCommStatus вы можете управлять DTR и т.д.). (Примечание: XonLim и XoffLim не должны быть больше 600, иначе под NT это. Работает неправильно). Unit My_IO; Interface. Function OpenComm(InQueue, OutQueue, Baud: LongInt): Boolean; Function SetCommTiming: Boolean; Function SetCommBuffer(InQueue, OutQueue: LongInt): Boolean; Function SetCommStatus(Baud: Integer): Boolean; Function SendCommStr(S: string): Integer; Function ReadCommStr(var S: string): Integer; Procedure CloseComm; Var. ComPort: Word; Implementation. Uses Windows, SysUtils; Const. CPort: array[1..4] of string = ('COM1', 'COM2', 'COM3', 'COM4'); Var. Com: THandle = 0; Function OpenComm(InQueue, OutQueue, Baud: LongInt): Boolean; Begin. If Com > 0 then. CloseComm; Com := CreateFile(PChar(CPort[ComPort]), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Result := (Com > 0) and SetCommTiming and. SetCommBuffer(InQueue, OutQueue) and. SetCommStatus(Baud); End; Function SetCommTiming: Boolean; Var. Timeouts: TCommTimeOuts; Begin. With TimeOuts do. Begin. ReadIntervalTimeout := 1; ReadTotalTimeoutMultiplier := 0; ReadTotalTimeoutConstant := 1; WriteTotalTimeoutMultiplier := 2; WriteTotalTimeoutConstant := 2; End; Result := SetCommTimeouts(Com, Timeouts); End; Function SetCommBuffer(InQueue, OutQueue: LongInt): Boolean; Begin. Result := SetupComm(Com, InQueue, OutQueue); End; Function SetCommStatus(Baud: Integer): Boolean; Var. DCB: TDCB; Begin. With DCB do. Begin. DCBlength := SizeOf(Tdcb); BaudRate := Baud; Flags := 12305; WReserved := 0; XonLim := 600; XoffLim := 150; ByteSize := 8; Parity := 0; StopBits := 0; XonChar := #17; XoffChar := #19; ErrorChar := #0; EofChar := #0; EvtChar := #0; WReserved1 := 65; End; Result := SetCommState(Com, DCB); End; Function SendCommStr(S: string): Integer; Var. TempArray: array[1..255] of Byte; Count, TX_Count: Integer; Begin. For Count := 1 to Length(S) do. TempArray[Count] := Ord(S[Count]); WriteFile(Com, TempArray, Length(S), TX_Count, nil); Result := TX_Count; End; Function ReadCommStr(var S: string): Integer; Var. TempArray: array[1..255] of Byte; Count, RX_Count: Integer; Begin. S := ''; ReadFile(Com, TempArray, 255, RX_Count, nil); For Count := 1 to RX_Count do. S := S + Chr(TempArray[Count]); Result := RX_Count; End; Procedure CloseComm; Begin. CloseHandle(Com); Com := -1; End; End.

©Drkb::01351.

Взято с http://delphiworld.narod.ru.

Как убрать заголовок в дочерней форме MDI?

Если в дочерней форме MDI установить BorderStyle в bsNone, то заголовок формы не исчезнет. (Об этом сказано в хелпе). А вот следующий пример решает эту проблему:

Code: Type. ... = class(TForm). { other stuff above }. Procedure CreateParams(var Params: TCreateParams); override; { other stuff below }. End; ... Procedure tMdiChildForm.CreateParams(var Params: tCreateParams); Begin. Inherited CreateParams(Params); Params.Style := Params.Style and (not WS_CAPTION); End;

Delphi и 1C - экспорт и импорт.

Автор: Александр Авдошин.

Специально для Королевства Delphi.

Довольно часто перед программистами, работающими в небольших компаниях, стоит проблема импорта данных из программы "1С:Предприятие", или экспорта в нее же. Причин тому может быть множество - например, желание автоматизировать обновление прайс-листа на веб-страничке компании на основании реальных данных, или же автоматизация ввода первичных документов, отправляемых по электронной почте компанией-поставщиком. Какая бы задача подобного рода ни стояла перед программистом, она, как правило, успешно решается с помощью связки Delphi-1C. В этой статье я хотел бы дать рекомендации и разъяснить некоторые аспекты использования механизма OLE Automation применительно к программе "1С:Предприятие версия 7.7".

Перед прочтением статьи я настоятельно рекомендую Вам ознакомиться с книгой "Delphi 4 Unleashed" Чарльза Калверта и с главой "Связь с внешними приложениями посредством механизмов DDE и OLE Automation" книги "1С:Предприятие 7.7 Описание встроенного языка". Также я предполагаю, что вы имеете опыт программирования как в среде Delphi, так и в среде "1С:Предприятие".

Первые шаги.

Ну, во-первых, прежде чем использовать все возможности программы "1С:Предприятие", необходимо сначала создать соответствующий OLE-объект. Идентификатор этого OLE-объекта зависит от версии и типа установленной программы "1С:Предприятие":

V1CEnterprise.Application - версия независимый ключ.

V77.Application - версия зависимый ключ.

V77S.Application - версия зависимый ключ, SQL-версия.

V77L.Application - версия зависимый ключ, локальная версия.

V77M.Application - версия зависимый ключ, сетевая версия.

Например, создадим OLE-объект для сервера "1С:Предприятие". Для простоты создадим объект без привязки к конкретной версии и типу программы:

Code: Procedure TForm1.Create1C; Var. Onesobj: Olevariant; Begin. Onesobj := createoleobject('V1CEnterprise.Application'); End;

Как копировать и вставлять TreeNode?

Code: Var. SL : TStringList; Procedure TForm1.CutBtnClick(Sender: TObject); Var. I, j, StartLevel : integer; TNSel : TTreeNode; Begin. TNSel := TreeView1.Selected; If TNSel <> nil then begin. StartLevel := TNSel.Level; I := TNSel.AbsoluteIndex; J := i; // note for later deletion. If SL = nil then. SL := TStringList.Create. Else. SL.Clear; SL.AddObject(TNSel.Text, pointer(0)); Inc(i); With TreeView1 do begin. While Items[i].Level > StartLevel do begin. {stop before next sibling to top node\}. SL.AddObject(Items[i].Text, pointer(Items[i].Level - StartLevel)); Inc(i); End; {while Items[i].Level > StartLevel\}. Items[j].Delete; End; {with TreeView1\}. End; {if TNSel <> nil\}. End; Procedure TForm1.PasteBtnClick(Sender: TObject); Var. I, Level : integer; TNSel, TN : TTreeNode; Begin. With TreeView1 do begin. TNSel := Selected; If TNSel <> nil then begin. TN := Items.Insert(TNSel, SL.Strings[0]); Level := integer(SL.Objects[0]); // should be 0. For i := 1 to SL.Count - 1 do begin. If integer(SL.Objects[i]) < Level then begin. {go up one level\}. TN := TN.Parent; Level := integer(SL.Objects[i]); End; {if integer(SL.Objects[i]) < Level\}. If Level = integer(SL.Objects[i]) then. {same level\}. TN := Items.Add(TN, SL.Strings[i]). Else begin. {go down one level\}. TN := Items.AddChild(TN, SL.Strings[i]); Level := integer(SL.Objects[i]); End; {if Level = integer(SL.Objects[i])\}. End; {for i := 1 to SL.Count - 1\}. End; {if TNSel <> nil\}. End; {with TreeView1\}. End;

Как копировать векторное изображение?

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Mf: TMetaFile; Mfc: TMetaFileCanvas; I: integer; ClipBrdFormat: word; Data: cardinal; Palette: hPalette; P: array [0..90] of TPoint; Begin. Mf := TMetaFile.Create; Mf.Width := 100; Mf.Height := 100; Mfc := TMetafileCanvas.Create(mf, 0); With mfc do. Begin. Pen.Color := clBlack; FrameRect(ClipRect); MoveTo(0, 50); LineTo(100, 50); LineTo(95, 48); MoveTo(100, 50); LineTo(95, 52); MoveTo(50, 100); LineTo(50, 0); LineTo(48, 5); MoveTo(50, 0); LineTo(52, 5); Brush.Style := bsClear; Font.name := 'arial'; Font.Size := 6; TextOut(55, 0, 'Y'); TextOut(95, 38, 'X'); Pen.Color := clRed; For i := low(p) to high(p) do. P[i] := Point(i, round(50 - 30 * sin((i - 50) / 5))); Polyline(p); End; Mfc.Free; Mf.SaveToClipboardFormat(ClipBrdFormat, data, palette); OpenClipboard(Application.Handle); EmptyClipboard; SetClipboardData(ClipBrdFormat, data); CloseClipboard; Mf.Inch := 200; Form1.Canvas.Draw(0, 0, mf); Mf.Free; End;

Работа с портами микропроцессора.

Автор: Pavlo Zolotarenki.

Модуль для работы с портами микропроцессора с сохранением синтаксиса.

Работает под Win9x.

НЕ работает под WinNT.

Code: //Copyright(c) 1998 Zolotarenko P.V pvz@mail.univ.kiev.ua. Unit Ports; Interface. Type. TPort = class. Private. Procedure Set_(index_: word; value: byte); register; Function Get_(index_: word): byte; register; Public. Property Element[index_: word]: byte read Get_ write Set_; default; End; TPortW = class. Private. Procedure Set_(index_: word; value: Word); register; Function Get_(index_: word): word; register; Public. Property Element[index_: word]: word read Get_ write Set_; default; End; Var. Port: TPort; PortW: TportW; Implementation. Procedure TPort.Set_(index_: word; value: byte); Begin. Asm. Mov dx,index_ Mov al,value. Out dx,al. End; End; Function TPort.Get_(index_: word): byte; Begin. Asm. Mov dx,index_ In al,dx. Mov @Result,al. End; End; Procedure TPortW.Set_(index_: word; value: word); Begin. Asm. Mov dx,index_ Mov ax,value. Out dx,ax. End; End; Function TPortW.Get_(index_: word): word; Begin. Asm. Mov dx,index_ In ax,dx. Mov @Result,ax. End; End; Initialization. Port := TPort.Create; PortW := TPortW.Create; Finalization. Port.free; PortW.free; End.

©Drkb::01435.

Взято с http://delphiworld.narod.ru.

Создание DTD для объекта (XML).

За созданием кода для сериализации и десериализации объектов в Delphi логично перейти к рассмотрению вопроса о возможности генерации соответствующего DTD для сохраняемых в XML классов. DTD понадобится нам, если мы захотим провести проверку XML документа на корректность и допустимость с помощью одного из XML анализаторов. Работа с анализатором MSXML рассмотрена в статье Загрузка и анализ документа XML..

Автоматическое создание DTD очень простая задача. У нас все для этого есть. Необходимо рекурсивно пройтись по всем свойствам объекта и сгенерировать модели содержания для каждого тега. При сериализации в XML мы не использовали атрибутов, а значит мы не сможем в DTD установить контроль над содержанием конкретных элементов. Остается только определить модель содержания для XML, т.е. вложенность тегов в друг друга.

Создадим процедуру GenerateDTD(), которая обеспечит запись формируемого DTD для заданного объекта Component в заданный поток Stream. Она создает список DTDList, в котором будут накапливаться атрибуты DTD, после чего передает всю черновую работу процедуре GenerateDTDInternal().

Code: { Процедура генерации DTD для заданного объекта в. Соответсвии с published интерфейсом его класса. Вход: Component - объект. Выход: Текст DTD в поток Stream. } Procedure GenerateDTD(Component: TObject; Stream: TStream); Var. DTDList: TStringList; Begin. DTDList := TStringList.Create; Try. GenerateDTDInternal(Component, DTDList, Stream, Component.ClassName); Finally. DTDList.Free; End; End;

Создаём Excel файл без OLE.

Code: Const. CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0); CXlsEof: array[0..1] of Word = ($0A, 00); CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0); CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0); CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0); Procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word); Begin. CXlsBof[4] := BuildNumber; XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof)); End; Procedure XlsEndStream(XlsStream: TStream); Begin. XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof)); End; Procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word; Const AValue: Integer); Var. V: Integer; Begin. CXlsRk[2] := ARow; CXlsRk[3] := ACol; XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk)); V := (AValue shl 2) or 2; XlsStream.WriteBuffer(V, 4); End; Procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word; Const AValue: Double); Begin. CXlsNumber[2] := ARow; CXlsNumber[3] := ACol; XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber)); XlsStream.WriteBuffer(AValue, 8); End; Procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word; Const AValue: string); Var. L: Word; Begin. L := Length(AValue); CXlsLabel[1] := 8 + L; CXlsLabel[2] := ARow; CXlsLabel[3] := ACol; CXlsLabel[5] := L; XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel)); XlsStream.WriteBuffer(Pointer(AValue)^, L); End; Procedure TForm1.Button1Click(Sender: TObject); Var. FStream: TFileStream; I, J: Integer; Begin. FStream := TFileStream.Create('c:\e.xls', fmCreate); Try. XlsBeginStream(FStream, 0); For I := 0 to 99 do. For J := 0 to 99 do. Begin. XlsWriteCellNumber(FStream, I, J, 34.34); // XlsWriteCellRk(FStream, I, J, 3434); // XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J])); End; XlsEndStream(FStream); Finally. FStream.Free; End; End;

Создание заставки при старте программы.

Перед появлением главного окна во всех серьёзных приложениях сначала появляется заставка. Теперь и у Вас есть возможность повыёживаться! Для создания заставки выполняем следующую последовательность действий:

Начинаем создание нового приложение командой "New Application" ("Новое приложение") из меню "File" ("Файл").

Добавьте ещё одну форму: "New Form"("Новая форма") из меню "File" ("Файл"). Это окно и будет заставкой. У него нужно убрать рамку с полосой заголовка, установив свойство "BorderStyle" в "bsNone". Теперь можно смело разработать дизайн окна заставки.

Из меню "Project" ("Проект") выбрать команду "Options"("Опции"). Зайти на закладку "Forms"("Формы") и Form2 из списка автоматически создаваемых форм (Auto-Create forms) перенести в список доступных форм (Available forms).

На форму-заставку с закладки System вынести компонент Timer. В его свойстве Interval установить значение 5000, а в событии OnTimer написать:

Timer1.Enabled := false;

Это сделано для того, чтобы заставка была видна в период указанного времени – 5000 миллисекунд, т.е. 5 секунд.

Перейти в файл проекта, нажав Ctrl+F12 и выбрав Project1. Исходный код должен выглядеть так:

Code: Program Project1; Uses. Forms, Unit1 in 'Unit1.pas' {Form1}, Unit2 in 'Unit2.pas' {Form2}; {$R *.RES}. Begin. Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; End.

Текущий модуль и проект.

Автор: Dr. Bob.

Компонент во время проектирования может знать имена текущих модулей и имя проекта. Все это можно получить с помощью ToolServices (см. файл TOOLINTF.PAS).

Имя текущего проекта можно получить с помощью вызова GetProjectName, список модулей/форм - с помощью функции GetUnitCount, которая возвратит количество модулей и затем с помощью GetUnitName(i) мы можем получить имя каждого модуля (также и с формами).

Вот примерный образец кода (получение и запись имен всех модулей/форм в StringGrid и имени проекта в Label):

Code: Procedure TInformationFrm.FormActivate(Sender: TObject); { необходимо: StringGrid1 (2 колонки, масса строк), Label1, Label2 }. Var. I, j: Integer; Tmp: string; Begin. StringGrid1.Cells[0, 0] := 'модулей:'; StringGrid1.Cells[1, 0] := 'форм:'; If ToolServices <> nil then. With ToolServices do. Begin. Label1.Caption := ExtractFileName(GetProjectName); { простое имя }. Label2.Caption := GetProjectName; { полное правильное имя пути }. For i := 0 to GetUnitCount do. Begin. Tmp := ExtractFileName(GetUnitName(i)); StringGrid1.Cells[0, i + 1] := Tmp; Tmp := ChangeFileExt(Tmp, '.DFM'); For j := 0 to GetFormCount do. If ExtractFileName(GetFormName(j)) = Tmp then. StringGrid1.Cells[1, i + 1] := Tmp. End; End; End;

©Drkb::00035.

Взято с http://delphiworld.narod.ru.

Кириллица в параметрах CGI-запроса.

Вопрос: Я хочу реализовать регистрацию своей программы через Internet. Для этого я вызываю CGI-скрипт, которому в качестве параметра передается имя пользователя. Однако, если имя набрано кириллицей, происходит ошибка. В чем дело?

Дело в том, что при передаче запроса по протоколу HTTP служебные символы и символы с кодами 128..255 надо кодировать. То есть, если пользователь ввел имя 'Вася Пупкин', то запрос для регистрации должен выглядеть не так:

Http://site/cgi-bin/reg.pl?user=Вася Пупкин.

А вот так:

Http://site/cgi-bin/reg.pl?user=%C2%E0%F1%FF+%CF%F3%EF%EA%E8%ED.

Решить проблему перекодировки туда и обратно может компонент TNMURL.

DK: Дополнительную информацию про кодирование URL'ов, можно прочитать в RFC1738.

©Drkb::03428.

Взято с http://delphiworld.narod.ru.

Сессия.

Из объекта-источника данных можно создавать объекты-сессии. Для этого используется метод.

Function CreateSession(const punkOuter: lUnknown; const riid: TGUID; out ppDBSession: lUnknown}: HResult; stdcall;

Интерфейса iDBCreateSession. Сессия предназначена для обеспечения работы транзакций и наборов рядов.

Как узнать, находится ли мышка на форме?

Для этого можно воспользоваться API функцией GetCapture().

Code: Procedure TForm1.FormDeactivate(Sender: TObject); Begin. ReleaseCapture; End; Procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If GetCapture = 0 then. SetCapture(Form1.Handle); If PtInRect(Rect(Form1.Left, Form1.Top, Form1.Left + Form1.Width, Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then. Form1.Caption := 'Мышка на форме' else. Form1.Caption := 'Мышка за пределами формы'; End;

Как синхронизировать время на 2х компьютерах?

WinExec('net time \\nts2 /set /yes',SW_HIDE);

©Drkb::03306.

Взято с http://delphiworld.narod.ru.

Синхронизация двух компонентов ScrollBox.

Решить задачу помогут обработчики событий OnScroll (в данном примере два компонента ScrollBox (ScrollBar1 и ScrollBar2) расположены на форме TMainForm):

Code: Procedure TMainForm.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); Begin. ScrollBar2.Position:=ScrollPos; End; Procedure TMainForm.ScrollBar2Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); Begin. ScrollBar1.Position := ScrollPos; End;

Как сделать окно системно-модальным?

Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией. В любой момент времени может быть возможен только один модально-системны диалог, чей дескриптор возвращается функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить показ диалога таким образом. Вот как примерно это должно выглядеть:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. X: word ; Begin. X := SetSysModalWindow(AboutBox.handle) ; AboutBox.showmodal ; SetSysModalWindow(x) ; End;

Имитация Tab.

SelectNext(screen.ActiveControl, True, True);

Разместите приведенный код в обработчике одного из собитий. SelectNext - защищенный метод TWinControl со следующим прототипом:

Code: Procedure SelectNext(CurControl: TWinControl; GoForward, CheckTabStop: Boolean);

Динамические создание объектов в TabbedNotebook.

Code: Procedure TForm1.TabbedNotebook1Click(Sender: TObject); Var. MyE: TEdit; Begin. With TabbedNotebook1 do. Begin. If PageIndex = 1 then. Begin. MyE := TEdit.Create(Self); MyE.Left := 12; MyE.Top := 12; MyE.Parent := Pages.Objects[PageIndex] as TWinControl; MyE.Show; End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. Button2:Tbutton; Begin. Button2:=tbutton.create(self); Button2.parent:=TabbedNotebook1.Pages.Object[0] as TTabPage; Button2.setbounds(30,30,60,30); End;

Недоступная закладка в компоненте TabbedNotebook.

Есть ли возможность в компоненте Tabbednotebook сделать какую-либо страницу недоступной? То есть не позволять пользователю щелкать на ней и видеть ее содержимое?

Да, такая возможность существует. Самый простой путь - удалить страницу, например так:

Code: With TabbedNotebook do. Pages.Delete(PageIndex);

Доступ к страницам Tabbednotebook.

При добавлении компонентов во время выполнения программы, вам необходимо присвоить для каждого компонента свойству parent (контейнер) _страницу_ компонента notebook, а не сам notebook.

Вы можете сделать это следующим образом (пример дан для кнопки):

Code: MyButton := TButton.Create( Form1 ); {как обычно...}. ... ... MyButton.Parent := TTabPage( TabbedNotebook1.Pages.Objects[n] ); { <== где 'n' - индекс желаемой страницы ==> }.

Свойство notebook 'Pages' имеет тип StringList и содержит список заголовков и объектов 'TTabPage'.

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

При добавлении компонента на страницу TabbedNotebook во время выполнения приложения, указатель на желаемую страницу для свойства Parent нового компонента должен быть назначен перед тем, как он будет реально показан. Способ получить доступ ко всем страницам TTabbedNotebook во время выполнения программы - с помощью свойства-массива Objects свойства TabbedNotebook Pages. Другими словами, страничные компоненты хранятся как объекты, присоединенные к имени страницы в списке строк свойства Pages. В следующим коде показано создание кнопки на второй странице компонента TabbedNotebook1:

Code: Var. NewButton : TButton; Begin. NewButton := TButton.Create(Self); NewButton.Parent := TWinControl(TabbedNotebook1.Pages.Objects[1]). ...

Вот как страница TNotebook может быть использована в качестве родителя для вновь создаваемого на ней компонента:

Code: NewButton.Parent := TWinControl(Notebook1.Pages.Objects[1]).

Вот как страница (закладка) TTabSet может быть использована в качестве родителя для вновь создаваемого на ней компонента:

Code: NewButton.Parent := TWinControl(TabSet1.Tabs.Objects[1]).

©Drkb::01163.

Взято с http://delphiworld.narod.ru.

Над какой закладкой курсор в TabControl?

Code: Function Form1.ItemAtPos(TabControlHandle : HWND; X, Y : Integer) : Integer; Var. HitTestInfo : TTCHitTestInfo; HitIndex : Integer; Begin. HitTestInfo.pt.x := X; HitTestInfo.pt.y := Y; HitTestInfo.flags := 0; HitIndex := SendMessage(TabControlHandle, TCM_HITTEST, 0, Longint(@HitTestInfo)); Result := HitIndex; End;

Как принимать ярлыки при перетягивании их на контрол.

Автор: Nomadic.

Code: TForm1 = class(TForm). ... Private. { Private declarations }. Procedure WMDropFiles(var M: TWMDropFiles); message WM_DROPFILES; ... End; Var. Form1: TForm1; Implementation. Uses. StrUtils, ShellAPI, ComObj, ShlObj, ActiveX; Procedure TForm1.FormCreate(Sender: TObject); Begin. ... DragAcceptFiles(Handle, True); ... End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. ... DragAcceptFiles(Handle, False); ... End; Procedure TForm1.WMDropFiles(var M: TWMDropFiles); Var. HDrop: Cardinal; N: Integer; S: string; Begin. HDrop := M.Drop; N := DragQueryFile(hDrop, 0, nil, 0); SetLength(s, n); DragQueryFile(hDrop, 0, PChar(s), n + 1); DragFinish(hDrop); M.Result := 0; FileOpen(s); End; Procedure TForm1.FileOpen(FileName: string); Begin. If CompareText(ExtractFileExt(FileName), '.lnk') = 0 then. FileName := ResolveShortcut(Application.Handle, FileName); DocName := ExtractFileName(FileName); Caption := Application.Title + ' - ' + DocName; ... End; Function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string; Var. Obj: IUnknown; Isl: IShellLink; Ipf: IPersistFile; Pfd: TWin32FindDataA; Begin. Result := ''; Obj := CreateComObject(CLSID_ShellLink); Isl := obj as IShellLink; Ipf := obj as IPersistFile; Ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ); With isl do. Begin. Resolve(Wnd, SLR_ANY_MATCH); SetLength(Result, MAX_PATH); GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY); Result := PChar(Result); End; End;

Определение координат расположения TaskBar.

Code: Uses.., ShellApi; Var. AppBarData: TAppBarData; BAlwaysOnTop: Boolean; {Поверх окон}. BAutoHide: boolean; {Авт. убирать с экрана}. ClRect: TRect; {Клиентские области}. Rect: TRect; Edge: UInt; {Местоположение TaskBar}. Procedure DetectTaskBar; Begin. AppBarData.hWnd := FindWindow('Shell_TrayWnd', nil); AppBarData.cbSize := sizeof(AppBarData); BAlwaysOnTop := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_ALWAYSONTOP) < > 0; BAutoHide := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_AUTOHIDE) < > 0; GetClientRect(AppBarData.hWnd, ClRect.rc); GetWindowRect(AppBarData.hwnd, rect); If (Rect.top > 0) then. Edge := ABE_BOTTOM. Else if (Rect.Bottom < Screen.Height) then. Edge := ABE_TOP. Else if Rect.Right < Screen.Width then. Edge := ABE_LEFT. Else. Edge := ABE_RIGHT; End;

Как прикрепить свою форму к другому приложению?

Для этого Вам понадобится переопределить процедуру CreateParams у желаемой формы. А в ней установить params.WndParent в дескриптор окна, к которому Вы хотите прикрепить форму.

Code: ... = class(TForm). ... Protected. Procedure CreateParams( var params: TCreateParams ); override; ... Procedure TForm2.Createparams(var params: TCreateParams); Var. AHWnd : HWND; Begin. Inherited; {как-нибудь получаем существующий дескриптор}. AhWnd := GetForegroundWindow; {а теперь:}. Params.WndParent := ahWnd; End;

Работа с TaskBar.

Code: Unit TaskBar; Interface. Uses Windows, ShellAPI; Const. // Дублируем описания из ShellAPI, чтобы не писать его в Uses. // везде, где мы используем этот модуль. NIF_TIP = ShellAPI.NIF_TIP; NIF_ICON = ShellAPI.NIF_ICON; Function TaskBarAddIcon( HWindow: THandle; // окно, создавшее значок. ID: Cardinal; // идентификатор значка. ICON: hIcon; // иконка. CallbackMessage: Cardinal; // сообщение, которое будет посылаться окну. Tip: PChar // ToolTip. ): Boolean; Function TaskBarModifyIcon( HWindow: THandle; ID: Cardinal; Flags: Cardinal; ICON: hIcon; Tip: PChar): Boolean; Function TaskBarDeleteIcon( HWindow: THandle; ID: Integer): Boolean; Implementation. Function TaskBarAddIcon( HWindow: THandle; ID: Cardinal; ICON: hIcon; CallbackMessage: Cardinal; Tip: PChar): Boolean; Var. NID: TNotifyIconData; Begin. FillChar(NID, SizeOf(TNotifyIconData), 0); With NID do. Begin. CbSize := SizeOf(TNotifyIconData); Wnd := hWindow; UID := ID; UFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP; UCallbackMessage := CallbackMessage; HIcon := Icon; Lstrcpyn(szTip, Tip, SizeOf(szTip)); End; Result := Shell_NotifyIcon(NIM_ADD, @NID); End; Function TaskBarModifyIcon( HWindow: THandle; ID: Cardinal; Flags: Cardinal; ICON: hIcon; Tip: PChar): Boolean; Var. NID: TNotifyIconData; Begin. FillChar(NID, SizeOf(TNotifyIconData), 0); With NID do. Begin. CbSize := SizeOf(TNotifyIconData); Wnd := hWindow; UID := ID; UFlags := Flags; HIcon := Icon; Lstrcpyn(szTip, Tip, SizeOf(szTip)); End; Result := Shell_NotifyIcon(NIM_MODIFY, @NID); End; Function TaskBarDeleteIcon( HWindow: THandle; ID: Integer): Boolean; Var. NID: TNotifyIconData; Begin. FillChar(NID, SizeOf(TNotifyIconData), 0); With NID do. Begin. CbSize := SizeOf(TNotifyIconData); Wnd := hWindow; UID := ID; End; Result := Shell_NotifyIcon(NIM_DELETE, @NID); End; End.

Каким драйвером пользуется TDATABASE?

Вы можете использовать вызов IDAPI dbiGetDatabaseDesc. Вот быстрая справка (не забудьте добавить DB в список используемых модулей):

Code: Var. PDatabase: DBDrsc: Begin. { pAlias - PChar, содержащий имя псевдонима }. DbiGetDatabaseDesc ( pAlias, @pDatabase ) ;

Завершение всех работающих приложений.

Как мне завершить все работающие задачи?

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

Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой операции.

Code: Procedure TForm1.ButtonKillAllClick(Sender: TObject); Var. PTask: PTaskEntry; Task: Bool; ThisTask: THANDLE; Begin. GetMem(pTask, SizeOf(TTaskEntry)); PTask^.dwSize := SizeOf(TTaskEntry); Task := TaskFirst(pTask); While Task do. Begin. If pTask^.hInst = hInstance then. ThisTask := pTask^.hTask. Else. TerminateApp(pTask^.hTask, NO_UAE_BOX); Task := TaskNext(pTask); End; TerminateApp(ThisTask, NO_UAE_BOX); End;

Как завершить любой процесс, в том числе и системный.

Code: // Включение, приминение и отключения привилегии. // Для примера возьмем привилегию отладки приложений 'SeDebugPrivilege' // необходимую для завершения ЛЮБЫХ процессов в системе (завершение процесов. // созданных текущим пользователем привилегия не нужна. Function ProcessTerminate(dwPID:Cardinal):Boolean; Var. HToken:THandle; SeDebugNameValue:Int64; Tkp:TOKEN_PRIVILEGES; ReturnLength:Cardinal; HProcess:THandle; Begin. Result:=false; // Добавляем привилегию SeDebugPrivilege. // Для начала получаем токен нашего процесса. If not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES. Or TOKEN_QUERY, hToken ) then. Exit; // Получаем LUID привилегии. If not LookupPrivilegeValue( nil, 'SeDebugPrivilege', SeDebugNameValue ). Then begin. CloseHandle(hToken); Exit; End; Tkp.PrivilegeCount:= 1; Tkp.Privileges[0].Luid := SeDebugNameValue; Tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; // Добавляем привилегию к нашему процессу. AdjustTokenPrivileges(hToken,false,tkp,SizeOf(tkp),tkp,ReturnLength); If GetLastError()< > ERROR_SUCCESS then exit; // Завершаем процесс. Если у нас есть SeDebugPrivilege, то мы можем. // завершить и системный процесс. // Получаем дескриптор процесса для его завершения. HProcess := OpenProcess(PROCESS_TERMINATE, FALSE, dwPID); If hProcess =0 then exit; // Завершаем процесс. If not TerminateProcess(hProcess, DWORD(-1)). Then exit; CloseHandle( hProcess ); // Удаляем привилегию. Tkp.Privileges[0].Attributes := 0; AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(tkp), tkp, ReturnLength); If GetLastError() < > ERROR_SUCCESS. Then exit; Result:=true; End; // Название добавление/удаление привилгии немного неправильные. Привилегия или. // есть в токене процесса или ее нет. Если привилегия есть, то она может быть в. // двух состояниях - или включеная или отключеная. И в этом примере мы только. // включаем или выключаем необходимую привилегию, а не добавляем ее.

Тест на корректность GUID и интерфейсов.

Автор: Nomadic.

Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch (и, следовательно, поддерживающих методы автоматизации)?

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

Code: Const. MyGUID = '{444...111}'; //Whatever the guid is... Var. Unk: IUnknown; Disp: IDispatch; Begin. { Make sure this line works correctly }. Unk := CreateRemoteComObject('server1', StringToGUID(MyGUID)); { If it does, then cast it to a IDispatch }. Disp := Unk as IDispatch; End;

Потоки и DLL.

Автор: Charles Calvert.

Потоки и DLL-ки.

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

Техническая сторона вопроса будет сфокусирована на потоках и функции DllEntryPoint. Функция DllEntryPoint не должна объявляться в ваших Delphi DLL. Фактически, большую часть, если не всю, Delphi DLL будет правильно работать и без вашего явного объявления DllEntryPoint. Тем не менее, я включил данный совет для тех Win32-программистов, которые понимают эту функцию и хотят связать с ней свое функциональное назначение, чтобы оно являлось частью DLL. Чтобы быть более конкрентым, это будет интересно тем программистам, которые хотят вызывать одну и ту же DLL из многочисленных потоков одной программы.

Исходный код данного проекта находится на FTP компании Borland. Данный код также доступен на Compuserve в секции Borland в виде файла BI42.ZIP.

При первом вызове DLL сначала выполняется секция инициализации, расположенная в нижней части кода. При загрузке двух модулей, каждый из которых использует DLL, секция инициализации будет вызвана дважды, для каждого модуля. Вот пример минимального кода Delphi DLL, который компилируется, но пока ничего не делает:

Code: Library MyDll; // Здесь код. // экспорта. Begin. // Расположенный здесь код выполняется в первую. // очередь при каждом вызове DLL любым exe-файлом. End.

Как вы можете здесь увидеть, здесь нет традиционного DLLEntryPoint, имеющегося в стандартных C/C++ DLL. Для тех, кто только начал изучать Win32, я сообщу, что DLLEntryPoint берет начало от функций LibMain и WEP, работающих в Windows 3.1. LibMain и WEP теперь считаются устаревшими, вместо них необходимо использовать DLLEntryPoint.

Для явной установки DLLEntryPoint в Delphi, используйте следующий код-скелет, имеющий преимущество перед переменной DLLProc, объявленной глобально в SYSTEM.PAS:

Code: Library DllEntry; Procedure DLLEntryPoint(Reason: DWORD); Begin. // Здесь организуется блок Case для Dll_Process_Attach, и др. End; // Здесь реализация экспортируемых функций. // экспорт. Begin. If DllProc = nil then begin. DllProc := @DLLEntryPoint; DllEntryPoint(Dll_Process_Attach); End; End.

Данный код назначает объявленный пользователей метод с именем DLLEntryPoint объявленной глобально переменной Delphi с именем DllProc, в свою очередь объявленой в SYSTEM.PAS следующим образом:

Code: Var. DllProc: Pointer; { Вызывается каждый раз при вызове точки входа DLL }.

Вы можете имитировать стандартную функциональность DLLEntryPoint, вызывая объявленный к тому времени локально DLLEntryPoint, и передавая ему Dll_Process_Attach в качестве переменной. В C/C++ DLL эта переменная должна передаваться определенной пользователем функции с именем DllEntryPoint автоматически при первом доступе к DLL из первой обратившейся к ней программы. В Delphi первый вызов этой функции может быть произведен вручную пользователем, но последующие вызовы происходят автоматически до тех пор, пока вы не назначите первый раз функцию переменной DllProc. Другими словами, вы можете форсировать первый вызов DllEntryPoint как показано выше, но последующие вызовы будут сделаны системой автоматически.

Dll_Process_Attach - одна из четырех возможных констант, которые система можете передавать функции DllEntryPoint. Эти константы объявлены в WINDOWS.PAS следующим образом:

Code: DLL_PROCESS_ATTACH = 1; // Программа подключается к DLL. DLL_THREAD_ATTACH = 2; // Поток программы подключается к DLL. DLL_THREAD_DETACH = 3; // Поток "оставляет" DLL. DLL_PROCESS_DETACH = 0; // Exe "отсоединяется" от DLL.

Более детальная скелетная конструкция DllEntryPoint с использованием приведенных констант:

Code: Procedure DLLEntryPoint(Reason: DWORD); Begin. Case Reason of. Dll_Process_Attach: MessageBox(DLLHandle, 'Подключение процесса', 'Инфо', mb_Ok); Dll_Thread_Attach: MessageBox(DLLHandle, 'Подключение потока', 'Инфо', mb_Ok); Dll_Thread_Detach: MessageBox(DLLHandle, 'Отключение потока', 'Инфо', mb_Ok); Dll_Process_Detach: MessageBox(DLLHandle, 'Отключение процесса', 'Инфо', mb_Ok); End; // case. End;

В приведенном примере я просто вызываю диалог MessageBox в ответ на возможные параметры, передаваемые DLLEntryPoint. Тем не менее, вы могли бы найти более достойное применение данным константам или вовсе игнорировать их.

Работа с потоками.

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

Code: Function MyFunc: ShortString; external 'DLLENTRY1' name 'MyFunc'; Procedure ThreadFunc(P: Pointer); stdcall; Var. S: array[0..255] of Char; Begin. StrPCopy(S, MyFunc); MessageBox(Form1.Handle, S, 'Инфо', mb_Ok); End; Procedure TForm1.UseThreadClick(Sender: TObject); Var. ThreadID: DWORD; HThread: THandle; Begin. HThread := CreateThread(nil, 0, @ThreadFunc, Nil, 0, ThreadID); If HThread = 0 then ShowMessage('Нет потоков'); End;

Приведенный здесь код делится на три секции. В первой декларируется MyFunc, являющаяся простой реализацией функции в DLL. ThreadFunc сама располагается в отдельном потоке, создаваемом программой. Процедура UseThreadClick создает поток. Сразу после создания потока система вызывает процедуру ThreadFunc.

Вот декларация CreateThread:

Code: Var. DWORD = Integer; Function CreateThread( LpThreadAttributes: Pointer; // атрибуты безопасности потока. DwStackSize: DWORD; // размер стека для потока. LpStartAddress: TFNThreadStartRoutine; // функция потока. LpParameter: Pointer; // аргумент для нового потока. DwCreationFlags: DWORD; // флаги создания. Var lpThreadId: DWORD): // Возвращаемый идентификатор потока. THandle; // Возвращаемый дескриптор потока.

В нормальной ситуации большинство параметров, передаваемых CreateThread, могут быть установлены в 0 или nil. Показан типичный пример вызова данной функции, но во многих случаях использование lpParameter неоправданно тяжело. Разумеется, любые переменные, установленные в данном параметре, передаются ThreadFunc в виде единственного аргумента.

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

Если вы создали программу с потоковой функцией как было показано выше, и создали DLL с функцией DLLEntryPoint, тоже показанной выше, то можно получить визуальное подтверждение того, как работает функция DLLEntryPoint. Поясняю: когда ваша программа загружается в память, DLL также должна быть автоматически загружена, тем самым вызывая MessageBox с текстом `Процесс подключен'. Диалоги появляются в зависимости от причины (Reason) вызова функции DllEntryPoint:

Code: Procedure DLLEntryPoint(Reason: DWORD); Begin. Case Reason of. Dll_Process_Attach: MessageBox(DLLHandle, 'Процесс подключен', 'Инфо', mb_Ok); Dll_Thread_Attach: MessageBox(DLLHandle, 'Поток подключен', 'Инфо', mb_Ok); Dll_Thread_Detach: MessageBox(DLLHandle, 'Поток отключен', 'Инфо', mb_Ok); Dll_Process_Detach: MessageBox(DLLHandle, 'Процесс отключен', 'Инфо', mb_Ok); End; // case. End;

Если вы создали процедуру ThreadFunc, показанную выше, то должно появиться диалоговое окно (MessageBox) с надписью "Поток подключен". При завершении работы подпрограммы ThreadFunc появится окошко с надписью "Поток отключен". Наконец, при закрытии программы должна появиться надпись "Процесс отключен". Пример, демонстрирующий процесс, доступен в сети.

Довольно сложно иллюстрировать технические возможности Delphi. Не все программисты Delphi захотят так глубоко вникать в дебри Windows API. Тем не менее, те, которые хотят воспользоваться мощью Windows 95 и Windows NT на полную катушку, могут видеть, что все современные технологии доступны всем без исключения программистам на Delphi. Приведенный выше пример доступен в Compuserve в виде файла DLLENT.ZIP и также размещен на Интернет-сервере Borland по адресу www.borland.com.

©Drkb::00302.

Взято с http://delphiworld.narod.ru.

Как создавать потоки без класса TThread?

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Procedure incedit1; stdcall; Procedure incedit2; stdcall; Type. TForm1 = class(TForm). Button1: TButton; Edit1: TEdit; Edit2: TEdit; Button6: TButton; Button7: TButton; Button2: TButton; Button3: TButton; Button5: TButton; Button4: TButton; Procedure Button1Click(Sender: TObject); Procedure Button6Click(Sender: TObject); Procedure Button7Click(Sender: TObject); Procedure Button4Click(Sender: TObject); Procedure Button5Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Procedure Button3Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. Var. Th1, th2: cardinal; H1, h2: integer; Procedure incedit1; Var. I: integer; Begin. I := 0; While true do. Begin. Form1.edit1.text := inttostr(i); I := i + 1; End; End; Procedure incedit2; Var. I: integer; Begin. I := 0; While true do. Begin. Form1.edit2.text := inttostr(i); I := i + 1; End; End; {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. H1 := beginthread(nil, 1024, @incedit1, nil, 0, th1); H2 := beginthread(nil, 1024, @incedit2, nil, 0, th2); End; Procedure TForm1.Button6Click(Sender: TObject); Begin. Terminatethread(h1, 0); End; Procedure TForm1.Button7Click(Sender: TObject); Begin. Terminatethread(h2, 0); End; Procedure TForm1.Button4Click(Sender: TObject); Begin. Resumethread(h1); End; Procedure TForm1.Button5Click(Sender: TObject); Begin. Resumethread(h2); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Suspendthread(h1); End; Procedure TForm1.Button3Click(Sender: TObject); Begin. Suspendthread(h2); End; End.

Эффект плавного перехода.

Автор: David C. Ullrich.

...существует ли для этого эффекта какой-либо алгоритм генерации изображений вместо использования кисточки?

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

Code: Procedure WaitAWhile(n: longint); Var. StartTime: longint; Begin. StartTime := timeGetTime; While timeGetTime < StartTime + n do. ; End; Procedure TForm1.Image1Click(Sender: TObject); Var. BrushBmp, BufferBmp, Buffer2Bmp, ImageBmp, Image2Bmp: TBitmap; J, k, row, col: longint; Begin. Row := 0; Col := 0; BrushBmp := TBitmap.Create; With BrushBmp do. Begin. Monochrome := false; Width := 8; Height := 8; End; ImageBmp := TBitmap.create; Imagebmp.loadfromfile('c:\huh.bmp'); Image2bmp := TBitmap.Create; Image2bmp.LoadFromFile('c:\whatsis.bmp'); {При 256 цветах лучше иметь ту же самую палитру!}. BufferBmp := TBitmap.Create; With BufferBmp do. Begin. Height := 200; Width := 200; Canvas.brush.bitmap := TBitmap.Create; End; Buffer2Bmp := TBitmap.Create; With Buffer2Bmp do. Begin. Height := 200; Width := 200; Canvas.brush.bitmap := TBitmap.Create; End; For k := 1 to 16 do. Begin. WaitAWhile(0); {Для пентиума необходимо добавить задержку}. For j := 0 to 3 do. Begin. Row := (row + 5) mod 8; Col := (col + 1) mod 8; If row = 0 then. Col := (col + 1) mod 8; BrushBmp.canvas.Pixels[row, col] := clBlack; End; With BufferBmp do. Begin. Canvas.copymode := cmSrcCopy; Canvas.brush.bitmap.free; Canvas.brush.style := bsClear; Canvas.brush.bitmap := TBitmap.Create; Canvas.brush.bitmap.Assign(BrushBmp); Canvas.Rectangle(0, 0, 200, 200); Canvas.CopyMode := cmMergeCopy; Canvas.copyrect(rect(0, 0, 200, 200), imageBmp.canvas, Rect(0, 0, 200, 200)); End; With Buffer2Bmp do. Begin. Canvas.copymode := cmSrcCopy; Canvas.brush.bitmap.free; Canvas.brush.style := bsClear; Canvas.brush.bitmap := TBitmap.Create; Canvas.brush.bitmap.Assign(BrushBmp); Canvas.Rectangle(0, 0, 200, 200); Canvas.copymode := cmSrcErase; Canvas.copyrect(rect(0, 0, 200, 200), image2bmp.canvas, Rect(0, 0, 200, 200)); End; BufferBmp.Canvas.CopyMode := cmSrcPaint; BufferBmp.Canvas.Copyrect(rect(0, 0, 200, 200), Buffer2Bmp.Canvas, rect(0, 0, 200, 200)); Canvas.copymode := cmSrcCopy; Canvas.copyrect(rect(0, 0, 200, 200), BufferBmp.Canvas, Rect(0, 0, 200, 200)); End; BufferBmp.canvas.brush.bitmap.free; Buffer2Bmp.canvas.brush.bitmap.free; BrushBmp.Free; BufferBmp.Free; Buffer2Bmp.Free; ImageBmp.Free; Image2Bmp.Free; End;

Теория и практика использования RTTI.

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

Информация о типах времени исполнения.(Runtime Type Information, RTTI) —это данные, генерируемые компилятором Delphi о большинстве объектов вашей программы. RTTI представляет собой возможность языка, обеспечивающее приложение информацией об объектах (его имя, размер экземпляра, указатели на класс-предок, имя класса и т. д.) и о простых типах во время работы программы. Сама среда разработки использует RTTI для доступа к значениям свойств компонент, сохраняемых и считываемых из dfm-файлов и для отображения их в Object Inspector,

Компилятор Delphi генерирует runtime информацию для простых типов, используемых в программе, автоматически. Для объектов, RTTI информация генерируется компилятором для свойств и методов, описанных в секции published в следующих случаях:

Объект унаследован от объекта, дня которого генерируется такая информация. В качестве примера можно назвать объект TPersistent.

Декларация класса обрамлена директивами компилятора {$M+} и {$M-}.

Необходимо отметить, что published свойства ограничены по типу данных. Они могут быть перечисляемым типом, строковым типом, классом, интерфейсом или событием (указатель на метод класса). Также могут использоваться множества (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (иначе говоря, множество должно помещаться в байте, слове или двойном слове). Также можно иметь published свойство любого из вещественных типов (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом.

Корневой базовый класс для всех VCL объектов и компонент, TObject, содержит ряд методов для работы с runtime информацией. Наиболее часто используемые из них приведены в таблице 1.

Наиболее часто используемые методы класса TObject для работы с RTTI.

Метод Описание.

ClassType Возвращает тип класса объекта. Вызывается неявно компилятором при определении типа объекта при использовании операторов is и as.

ClassName Возвращает строку, содержащую название класса объекта. Например, для объекта типа TForm вызов этой функции вернет строку "TForm".

ClassInfo Возвращает указатель на runtime информацию объекта.

InstanceSize Возвращает размер конкретного экземпляра объекта в байтах.

Object Pascal предоставляет в распоряжение программиста два оператора, работа которых основана на неявном для программиста использовании RTTI информации. Это операторы is и as. Оператор is предназначен для проверки соответствия экземпляра объекта заданному объектному типу. Так, выражение вида:

Code: AObject is TSomeObjectType.

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

Code: If Edit1 is TForm then ShowMessage('Враки!');

Даже не будет пропущен компилятором, и он выдаст сообщение о не совместимости типов (разумеется, что Edit1 — это компонент типа TEdit):

Incompatible types: 'TForm' and 'TEdit'.

Перейдем теперь к оператору as. Он введен в язык специально для приведения объектных типов. Посредством него можно рассматривать экземпляр объекта как принадлежащий к другому совместимому типу:

Code: AObject as TSomeObjectType.

Использование оператора as отличается от обычного способа приведения типов.

Code: TSomeObjectType(AObject).

Наличием проверки на совместимость типов. Так при попытке приведения этого оператора с несовместимым типом он сгенерирует исключение EInvalidCast. Определенным недостатком операторов is и as является то, что присваиваемый фактически тип должен быть известен на этапе компиляции программы и поэтому на месте TSomeObjectType не может стоять переменная указателя на класс.

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

Code: Var. I: Integer; Begin. For I := 0 to ComponentCount - 1 do. If Components[I] is TEdit then. (Components[I] as TEdit).Text := ''; { или так TEdit (Components[I]).Text := ''; }. End;

Хочу обратить ваше внимание, а то, что стандартное приведение типа в данном примере предпочтительнее, поскольку в операторе if мы уже установили что компонент является объектом нужного нам типа и дополнительная проверка соответствия типов, проводимая оператором as, нам уже не нужна.

Первые шаги в понимании RTTI мы уже сделали. Теперь переходим к подробностям. Все основополагающие определения типов, основные функции и процедуры для работы с runtime информацией находятся в модуле TypInfo. Этот модуль содержит две фундаментальные структуры для работы с RTTI — TTypeInfo и TTypeData (типы указателей на них — PTypeInfo и PTypeData соответственно). Суть работы с RTTI выглядит следующим образом. Получаем указатель на структуру типа TTypeInfo (для объектов указатель можно получить, вызвав метод, реализованный в TObject, ClassInfo, а для простых типов в модуле System существует функция TypeInfo). Затем, посредством имеющегося указателя и вызова функции GetTypeData получаем указатель на структуру типа TTypeData. Далее используя оба указателя и функции модуля TypInfo творим маленькие чудеса. Для пояснения написанного выше рассмотрим пример получения текстового вида значений перечисляемого типа. Пусть, например, это будет тип TBrushStyle. Этот тип описан в модуле Graphics следующим образом:

Code: TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, BsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);

Вот мы и попробуем получить конкретные значения этого типа в виде текстовых строк. Для этого создайте пустую форму. Поместите на нее компонент типа TListBox с именем ListBox1 и кнопку. Реализацию события OnClick кнопки замените следующим кодом:

Code: Var. ATypeInfo: PTypeInfo; ATypeData: PTypeData; I: Integer; S: string; Begin. ATypeInfo := TypeInfo(TBrushStyle); ATypeData := GetTypeData(ATypeInfo); For I := ATypeData.MinValue to ATypeData.MaxValue do. Begin. S := GetEnumName(ATypeInfo, I); ListBox1.Items.Add(S); End; End;

Ну вот, теперь, когда на вооружении у нас есть базовые знания о противнике, чье имя, на первый взгляд выглядит непонятно и пугающее — RTTI настало время большого примера. Мы приступаем к созданию объекта опций для хранения различных параметров, использующего в своей работе мощь RTTI на полную катушку. Чем же примечателен, будет наш будущий класс? А тем, что он реализует сохранение в ini-файл и считывание из него свои свойства секции published. Его потомки будут иметь способность сохранять свойства, объявленные в секции published, и считывать их, не имея для этого никакой собственной реализации. Надо лишь создать свойство, а все остальное сделает наш базовый класс. Сохранение свойств организуется при уничтожении объекта (т.е. при вызове деструктора класса), а считывание и инициализация происходит при вызове конструктора класса. Декларация нашего класса имеет следующий вид:

Code: {$M+}. TOptions = class(TObject). Protected. FIniFile: TIniFile; Function Section: string; Procedure SaveProps; Procedure ReadProps; Public. Constructor Create(const FileName: string); Destructor Destroy; override; End; {$M-}.

Класс TOptions является производным от TObject и по этому, что бы компилятор генерировал runtime информацию его надо объявлять директивами {$M+/-}. Декларация класса весьма проста и вызвать затруднений в понимании не должна. Теперь переходим к реализации методов.

Code: Constructor TOptions.Create(const FileName: string); Begin. FIniFile:=TIniFile.Create(FileName); ReadProps; End; Destructor TOptions.Destroy; Begin. SaveProps; FIniFile.Free; Inherited Destroy; End;

Как видно реализация конструктора и деструктора тривиальна. В конструкторе мы создаем объект для работы с ini-файлом и организуем считывание свойств. В деструкторе мы в сохраняем значения свойств в файл и уничтожаем файловый объект. Всю нагрузку по реализации сохранения и считывания published-свойств несут методы SaveProps и ReadProps соответственно.

Code: Procedure TOptions.SaveProps; Var. I, N: Integer; TypeData: PTypeData; List: PPropList; Begin. TypeData:= GetTypeData(ClassInfo); N:= TypeData.PropCount; If N <= 0 then. Exit; GetMem(List, SizeOf(PPropInfo)*N); Try. GetPropInfos(ClassInfo,List); For I:= 0 to N - 1 do. Case List[I].PropType^.Kind of. TkEnumeration, tkInteger: FIniFile.WriteInteger(Section, List[I]^.name,GetOrdProp(Self,List[I])); TkFloat: FIniFile.WriteFloat(Section, List[I]^.name, GetFloatProp(Self, List[I])); TkString, tkLString, tkWString: FIniFile.WriteString(Section, List[I]^.name, GetStrProp(Self, List[I])); End; Finally. FreeMem(List,SizeOf(PPropInfo)*N); End; End; Procedure TOptions.ReadProps; Var. I, N: Integer; TypeData: PTypeData; List: PPropList; AInt: Integer; AFloat: Double; AStr: string; Begin. TypeData:= GetTypeData(ClassInfo); N:= TypeData.PropCount; If N <= 0 then. Exit; GetMem(List, SizeOf(PPropInfo)*N); Try. GetPropInfos(ClassInfo, List); For I:= 0 to N - 1 do. Case List[I].PropType^.Kind of. TkEnumeration, tkInteger: Begin. AInt:= GetOrdProp(Self, List[I]); AInt:= FIniFile.ReadInteger(Section, List[I]^.name, AInt); SetOrdProp(Self, List[i], AInt); End; TkFloat: Begin. AFloat:=GetFloatProp(Self,List[i]); AFloat:=FIniFile.ReadFloat(Section, List[I]^.name,AFloat); SetFloatProp(Self,List[i],AFloat); End; TkString, tkLString, tkWString: Begin. AStr:= GetStrProp(Self,List[i]); AStr:= FIniFile.ReadString(Section, List[I]^.name, AStr); SetStrProp(Self,List[i], AStr); End; End; Finally. FreeMem(List,SizeOf(PPropInfo)*N); End; End; Function TOptions.Section: string; Begin. Result := ClassName; End;

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

Code: TMainOpt = class(TOptions). Private. FText: string; FHeight: Integer; FTop: Integer; FWidth: Integer; FLeft: Integer; Procedure SetText(const Value: string); Procedure SetHeight(Value: Integer); Procedure SetLeft(Value: Integer); Procedure SetTop(Value: Integer); Procedure SetWidth(Value: Integer); Published. Property Text: string read FText write SetText; Property Left: Integer read FLeft write SetLeft; Property Top: Integer read FTop write SetTop; Property Width: Integer read FWidth write SetWidth; Property Height: Integer read FHeight write SetHeight; End; TForm1 = class(TForm). Edit1: TEdit; Procedure Edit1Change(Sender: TObject); Private. FMainOpt: TMainOpt; Public. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; End;

А вот и реализация:

Code: Constructor TForm1.Create(AOwner: TComponent); Var. S: string; Begin. Inherited Create(AOwner); S := ChangeFileExt(Application.ExeName, '.ini'); FMainOpt := TMainOpt.Create(S); Edit1.Text := FMainOpt.Text; Left := FMainOpt.Left; Top := FMainOpt.Top; Width := FMainOpt.Width; Height := FMainOpt.Height; End; Destructor TForm1.Destroy; Begin. FMainOpt.Left := Left; FMainOpt.Top := Top; FMainOpt.Width := Width; FMainOpt.Height := Height; FMainOpt.Free; Inherited Destroy; End; { TMainOpt }. Procedure TMainOpt.SetText(const Value: string); Begin. FText := Value; End; Procedure TForm1.Edit1Change(Sender: TObject); Begin. FMainOpt.Text := Edit1.Text; End; Procedure TMainOpt.SetHeight(Value: Integer); Begin. FHeight := Value; End; Procedure TMainOpt.SetLeft(Value: Integer); Begin. FLeft := Value; End; Procedure TMainOpt.SetTop(Value: Integer); Begin. FTop := Value; End; Procedure TMainOpt.SetWidth(Value: Integer); Begin. FWidth := Value; End;

В заключение своей статьи хочу сказать, что RTTI является недокументированной возможностью Object Pascal и поэтому информации на эту тему в справочной системе и электронной документации весьма мало. Наиболее легкодоступный способ изучить более подробно эту фишку — просмотр и изучение исходного текста модуля TypInfo.

©Drkb::00262.

Взято с http://delphiworld.narod.ru.

Как сделать дырку в окне?

Code: Procedure TForm1.Button4Click(Sender: TObject); Var. HRegion1, Hreg2, Hreg3: THandle; Col: TColor; Begin. ShowMessage ('Ready for a real crash?'); Col := Color; Color := clRed; PlaySound ('boom.wav', 0, snd_sync); HRegion1 := CreatePolygonRgn (Pts, Sizeof (Pts) div 8, Alternate); SetWindowRgn ( Handle, HRegion1, True); ShowMessage ('Now, what have you done?'); Color := Col; ShowMessage ('Вам лучше купить новый монитор'); End;

Как реализовать обработку информации одновременно несколькими потоками.

Автор: Садыков Алексей Николаевич.

Запускайте Delphi. Итак, наша программа будет представлять из себя форму с двумя еdit'ами и кнопкой. Добавьте их на форму.

При нажатии на кнопку будут осуществляться некоторые долгие вычисления. Если бы мы не использовали потоки, то, пока эти вычисления не закончатся, делать мы ничего бы не смогли. Надо было бы ждать. Но, так как потоки у нас будут, то во время долгих вычислений можно будет что-нибудь вводить во второй edit (он, собственно, только для этого и существует). В первый же edit наш поток будет выводить некоторые промежуточные результаты своей работы.

Добавьте в программу еще один модуль (меню File, New, Unit).

Внесите в окно кода нового модуля следующий код:

Code: Unit Unit2; Interface. Uses. Classes; Type. TMyThread = class(TThread) //Новый класс. Private. Answer: Integer; Protected. Procedure ShowResult; Procedure Execute; override; End; Implementation. Uses. SysUtils, Unit1; //Процедура для вывода информации из потока. Procedure TMyThread.ShowResult; Begin. Form1.Edit1.Text := IntToStr(answer); End; //Длинная процедура. Procedure TMyThread.Execute; Var. I: Integer; Begin. For i := 1 to 10000 do. Begin. Answer := answer + 1; Synchronize(ShowResult); End; End; End.

Немного комментария по коду. В нашем модуле мы вводим новый класс TMyThread как «потомок» TThread. В экземпляре нашего класса и будет выполнятся отдельный поток программы. В классе есть процедура ShowResult для вывода информации из работающего потока в основной поток (форму) нашей программы. Кроме того, в классе есть наша версия метода Execute из родительского класса TThread. Обратите внимание, что в нашей реализации Execute мы пишем.

Synchronize(ShowResult);

Тем самым наш поток что-то отправляет в основной поток программы (в данном случае, значение переменной answer). Делаем мы это посредством вызова Synchronize, в котором в качестве параметра указываем имя нужной процедуры.

Теперь переходим к нашему основному модулю Unit1. Во-первых, добавьте в секцию uses ссылку на Unit2:

Code: Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Unit2;

Во-вторых, напишите обработчик для нажатия кнопки:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. MyThread: TMyThread; Begin. MyThread := TMyThread.Create(False); End;

Тут мы создаем второй поток для нашего приложения. Параметр False означает, что метод Execute для нашего потока вызовется немедленно.

Запускайте программу. Нажимайте на кнопку. В первом еdit'е замелькают промежуточные результаты работы второго потока. Во время его работы вы можете вводить информацию во второй edit — т.е. работа одного потока не мешает работе другого.

©Drkb::00304.

Взято с http://delphiworld.narod.ru.

Ханойская башня.

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

Code: Type. THanoiBin = 0..2; THanoiLevel = 0..9; Procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel); // Это Вы должны сделать сами. Переместите один диск с одного штырька на другой. // Диск окажется наверху (естественно, выше него дисков не будет).

Прокрутка TreeView, чтобы держать выделение посередине.

Code: Procedure TMyForm.TreeChange(Sender: TObject; Node: TTreeNode); Var. I : integer; Pp, cp : TTreeNode; Begin. If Assigned(Tree.Selected) then. Begin. Cp := Tree.Selected; Pp := cp; For i := 1 to Round(Tree.Height/30) do. If cp <> nil then. Begin. Pp := cp; Cp := cp.GetPrevVisible; End; Tree.TopItem := pp; End; End;

Как использовать форму из DLL.

Code: Library Form; Uses. Classes, Unit1 in 'Unit1.pas' {Form1}; Exports. CreateMyForm, DestroyMyForm; End.

Это его Unit1:

Code: Unit Unit1; Interface. // раздел uses и определение класса Form1. Procedure CreateMyForm(AppHandle: THandle); stdcall; Procedure DestroyMyForm; stdcall; Implementation. {$R *.DFM}. Procedure CreateMyForm(AppHandle: THandle); Begin. Application.Handle := AppHandle; Form1 := TForm1.Create(Application); Form1.Show. End; Procedure DestroyMyForm; Begin. Form1.Free; End; End.

Это UnitCall вызывающего EXE-шника:

Code: Unit. UnitCall; Interface. // раздел uses и определение класса Form1. Procedure CreateMyForm(AppHandle: THandle); stdcall; external 'Form.dll'; Procedure DestroyMyForm; stdcall; external 'Form.dll'; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. CreateMyForm(Application.Handle); End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. DestroyMyForm; End; End.

Работа с Sender.

Code: Unit TestInputForm; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, DdhInpuB; Type. TForm1 = class(TForm). Edit1: TEdit; Label1: TLabel; DdhInputButton1: TDdhInputButton; DdhInputButton2: TDdhInputButton; DdhInputButton3: TDdhInputButton; Procedure DdhInputButtonClick(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.DdhInputButtonClick(Sender: TObject); Begin. ShowMessage ('You have clicked the ' + (Sender as TButton).Name + ','#13 + 'having the caption ' + (Sender as TButton).Caption); End; End.

UUE кодирование.

Автор: Sergei Dubarev.

Для того, чтобы ОНО заработало, необходимо создать проект в составе:

Форма (form) - 1 шт.

Поле ввода (edit) - 2 шт., используются события OnDblClick.

Кнопка (button) - 1 шт., используется событие OnClick.

Диалог открытия файла (Open Dialog) - 1 шт.

Диалог сохранения файла (Save Dialog) - 1 шт.

Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text - выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE.".

Всего хорошего.

P. S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e.

P.P.S. Для стимулирования фантазии читателей "Советов..." высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.

Файл Unit1.pas.

Code: //UUE кодирование. Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtDlgs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Edit1: TEdit; Edit2: TEdit; OpenDialog1: TOpenDialog; SaveDialog1: TSaveDialog; Procedure Edit1DblClick(Sender: TObject); Procedure Edit2DblClick(Sender: TObject); Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Const. Ssz = (High(Cardinal) - $F) div sizeof(byte); //эта константа используется при выделении памяти. P: string = '0123456789ABCDEF'; //эта константа используется функцией toanysys. //выбор входного файла. Procedure TForm1.Edit1DblClick(Sender: TObject); Begin. If opendialog1.execute then. Edit1.text := opendialog1.filename; End; //выбор выходного (UUE) файла. Procedure TForm1.Edit2DblClick(Sender: TObject); Begin. If savedialog1.execute then. Edit2.text := savedialog1.filename; End; //выделение подстроки. Function mid(s: string; fromc, toc: byte): string; Var. S1: string; I: byte; Begin. S1 := ''; For i := fromc to toc do. S1 := s1 + s[i]; Mid := s1; End; //перевод числа (a) из десятичной системы в другую. //с основанием (r). Function toanysys(a, r: byte): string; Var. S, K: string; N, M, I: byte; Begin. S := ''; M := 1; While m <> 0 do. Begin. M := a div r; N := a - m * r + 1; K := p[n]; S := k + s; A := m; End; //добавляет незначащие нули. For i := 1 to 8 - length(s) do. S := '0' + s; Toanysys := s; End; //перевод 6-разрядного числа из двоичной системы в десятичную. //двоичное число подставляется в виде строки символов. Function frombin(s: string): byte; Var. I, E, B: byte; Begin. B := 0; For i := 1 to 6 do. Begin. E := 1 shl (6 - i); If s[i] = '1' then. B := b + e; End; Frombin := b; End; //непосредственно кодирование. Type. Tcoola = array[1..1] of byte; Pcoola = ^tcoola; Procedure TForm1.Button1Click(Sender: TObject); Var. Inf: file of byte; Ouf: textfile; Uue: pcoola; B: array[1..4] of byte; Bin, T: string; Szf, Oum, Szl, Szh, Sxl, Sxh, I, J: longint; Begin. {$I-}. Assignfile(inf, edit1.text); //входной файл. Reset(inf); Szf := filesize(inf); // Szh := (szf * 8) div 6; // If szf * 8 - szh * 6 = 0 then. Szl := 0. Else. Szl := 1; // Getmem(uue, szh + szl); //выделение памяти. Oum := 1; While not (eof(inf)) do. Begin. B[1] := 0; B[2] := 0; B[3] := 0; B[4] := 0; //чтение должно быть сделано посложнее, //дабы избежать "read beyond end of file". Read(inf, b[1], b[2], b[3]); //читаем 3 байта из входного файла. //и формируем "двоичную" строку. Bin := toanysys(b[1], 2) + Toanysys(b[2], 2) + Toanysys(b[3], 2); //разбиваем строку на куски по 6 бит и добавляем 32. T := mid(bin, 19, 24); B[4] := frombin(t) + 32; T := mid(bin, 13, 18); B[3] := frombin(t) + 32; T := mid(bin, 07, 12); B[2] := frombin(t) + 32; T := mid(bin, 01, 06); B[1] := frombin(t) + 32; //запихиваем полученнные байты во временный массив. Uue[oum] := b[1]; Oum := oum + 1; Uue[oum] := b[2]; Oum := oum + 1; Uue[oum] := b[3]; Oum := oum + 1; Uue[oum] := b[4]; Oum := oum + 1; End; //входной файл больше не нужен - закрываем его. Closefile(inf); //формируем выходной файл. Assignfile(ouf, edit2.text); //выходной файл. Rewrite(ouf); Oum := 1; Sxh := (szh + szl) div 60; //число строк в UUE файле. Sxl := (szh + szl) - sxh * 60; //заголовок UUE-файла. Writeln(ouf, 'begin 644 ' + extractfilename(edit1.text)); //записываем строки в файл. For i := 1 to sxh do. Begin. Write(ouf, 'M'); // 'M' значит, что в строке 60 символов. For j := 1 to 60 do. Begin. Write(ouf, chr(uue[oum])); Oum := oum + 1; End; Writeln(ouf); End; //записываем последнюю строку, которая. //обычно короче 60 символов. Sxh := (sxl * 6) div 8; Write(ouf, chr(sxh + 32)); For i := 1 to sxl do. Begin. Write(ouf, chr(uue[oum])); Oum := oum + 1; End; // "добиваем" строку незначащими символами. For i := sxl + 1 to 60 do. Write(ouf, '`'); //записываем последние строки файла. Writeln(ouf); Writeln(ouf, '`'); Writeln(ouf, 'end'); Closefile(ouf); Freemem(uue, szh + szl); //освобождаем память. Showmessage('DONE.'); //Готово. Забирайте! End; End.

Основы 3D математики - Векторные и матричные преобразования.

Векторы.

Вектор - направленный отрезок, имеющий направление и длину. Векторы обозначаются так: a = (x,y,z), например, b = (0,1,-2). Еще одно представление вектора : AB = (x,y,z).

AB = (x,y,z) = (bx-ax,by-ay,bz-az),

Где A и B - 2 точки, A(ax,ay,az) и B(bx,by,bz), A - начало вектора, B - конец вектора.

Длина вектора.

Длина вектора, |a|, считается так:

|a| = sqrt(ax2+ay2+az2).

Сложение векторов.

A + b = c;

A + b = (ax + bx, ay + by, az + bz).

Т. е. как результат мы получаем вектор.

Вычитание векторов.

C - a = b;

C - a = (cx - ax, cy - ay, cz - az).

Как результат - также мы получаем вектор.

Скалярное произведение векторов.(dot).

Скалярное произведение 2х векторов - произведение длин 2х векторов на cos угла между ними. Скалярное произведение векторов - это длина проекции вектора a на вектор b.

A . b = |a| |b| cos ?;

Или.

A . b = axbx + ayby + azbz;

Следствие: ? - угол между двумя векторами: cos ? = a . b / (|a| |b|);

Проекция одного вектора на другой.

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

C = (a . b) b;

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

Умножение вектора на вектор.(cross).

Умножая вектор a на вектор b, мы получим вектор, перпендикулярный плоскости, которую определяют вектора a и b.

A x b = ( aybz - byaz , azbx - bzax , axby - bxay );

Фактически, таким образом находиться вектор нормали к полигонам.

Матрицы.

Здесь я постарался вкратце изложить то, что мы будем делать с матрицами.

Скалярное произведение векторов:

[ a ] [ d ].

[ b ] * [ f ] = a*d + b*f + c*g.

[ c ] [ g ].

Векторное произведение:

[ a ] [ d ] [ b*f - c*e ].

AxB = [ b ] x [ e ] = [ c*d - a*f ].

[ c ] [ f ] [ a*e - b*d ].

Сложение матриц:

[ 1 2 3 ] [ 10 11 12 ] [ 1+10 2+11 3+12 ].

[ 4 5 6 ] + [ 13 14 15 ] = [ 4+13 5+14 6+15 ].

[ 7 8 9 ] [ 16 17 18 ] [ 7+16 8+17 9+18 ].

Умножение матриц:

[ 1 2 3 ] [ 10 11 12 ] [ 1*10+2*13+3*16 1*11+2*14+3*17 1*12+2*15+3*18 ].

[ 4 5 6 ] * [ 13 14 15 ] = [ 4*10+5*13+6*16 4*11+5*14+6*17 4*12+5*15+6*18 ].

[ 7 8 9 ] [ 16 17 18 ] [ 7*10+8*13+9*16 7*11+8*14+9*17 7*12+8*15+9*18 ].

Очень важным является тот факт, что (A*B)*С = A*(B*C).

Векторные и матричные преобразования.

Параллельный перенос:

Переносим точку (x,y,z) на вектор (dx,dy,dz), в результате получим точку с координатами (x+dx, y+dy, z+dz);

Поворот:

Поворачиваем точку (x,y) на угол ? :

X' = x cos ? - y*sin ?

Y' = x sin ? + y*cos ?

Для трехмерного случая - аналогично для каждой плоскости.

Ясно, что если нам потребуется (а нам потребуется :) ) проводить для каждой точки в пространстве параллельный перенос + поворот в пространстве, то придеться сделать огромное количество преобразований.

Можно построить матрицы преобразований, помножив точку - вектор на которую, мы получим результат - координаты искомой точки.

Матрица параллельного переноса:

[ 1 0 0 0 ].

[ 0 1 0 0 ].

[ 0 0 1 0 ].

[ x y z 1 ].

Матрица растяжения/сжатия:

[ z 0 0 0 ].

[ 0 y 0 0 ].

[ 0 0 x 0 ].

[ 0 0 0 1 ].

Матрица поворота вокруг оси x:

[ 0 0 0 0 ].

[ 0 cos ? sin ? 0 ].

[ 0 -sin ? cos ? 0 ].

[ 0 0 0 1 ].

Матрица поворота вокруг оси y:

[ cos ? 0 -sin ? 0 ].

[ 0 1 0 0 ].

[ sin ? 0 cos ? 0 ].

[ 0 0 0 1 ].

Матрица поворота вокруг оси z:

[ cos ? sin ? 0 0 ].

[-sin ? cos ? 0 0 ].

[ 0 0 1 0 ].

[ 0 0 0 1 ].

Теперь - зачем нужны матрицы в 3D-програмировании, если можно все сделать с помощью векторов, и если, например, поворот точки с помощью векторов занимает меньше операций, чем используя матрицы.

Например, мы отодвигаем камеру и поворачиваем ее. для этого требуется произвести серию операций (переносов, поворотов) с точками (вершинами полигонов) в 3D-сцене. т.е. для каждой точки произвести сначала параллельный перенос, а затем - повороты по всем осям. при использовании векторов мы просто проведем все эти операции отдельно для каждой точки... что весьма ресурсоемко. или - матричные параллельные переносы, повороты.... еще более ресурсоемко, но вспомним:

(A*B)*C = A*(B*C).

Для матриц.. а нам требуется провести такие преобразования: a*A*B*C*D, где - а-точка-вектор, над которым требуется произвести действия, а A,B,C,D - матрицы переноса и поворотов. Мы вполне можем не последовательно умножать точку-вектор a на матрицы переносов, а сначала перемножить эти матрицы, а затем просто умножать получившуюся матрицу на каждую точку, которую требуется сместить - перемножение 4х матриц, а затем умножение 1 вектора на 1 матрицу на каждую точку по сравнению с подвержением каждой точки векторным преобразованиям - весьма и весьма значительное сокращение производимых операций.

©Drkb::03959.

Взято с http://delphiworld.narod.ru.

Работа с OpenGL - Введение.

Введение.

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

Когда я начинал изучение этого, у меня не было ни одного примера использования OpenGL в Delphi, только ворох программ на C и C++, поэтому пришлось начинать с того, чтобы перекладывать эти программы на Delphi. Затем появились и полностью собственные проекты. Моя основная работа связана с преподаванием в вузе, после того, как я включил в учебные курсы изучение основ OpenGL, студенты с моей помощью смогли создать ряд интересных проектов.

Я решил опубликовать некоторые из проектов моей коллекции, озаглавил набор "ЖиЛистая Delphi" и предложил сайту "Королевство Delphi". На сайте мне предложили дополнить эти проекты серией статей по вопросам использования OpenGL в Delphi. Данная статья является первой статьей этого цикла.

Статьи я предполагаю писать на уровне, доступном для самой широкой аудитории - от новичков в программировании для Windows до умудренных профессионалов. Я постараюсь придерживаться краткости в своих рассуждениях, освещая только суть рассматриваемых вопросов. Многие вопросы, освещаемые здесь, ясно проиллюстрированы в проектах "ЖиЛистой Delphi".

OpenGL - стандартный для большинства платформ и операционных систем набор низкоуровневых функций двумерной и трехмерной графики, библиотека, широко используемая в промышленных CAD-системах и играх.

Поставляется в составе операционной системы Windows, начиная с версии OSR2 в виде двух DLL-файлов - opengl32.dll и glu32.dll. Первая из этих библиотек и есть собственно набор функций OpenGL, вторая содержит дополнительный набор функций, упрощающих кодирование, но построенных и выполняемых с подключением opengl32.dll и являющаяся надстройкой.

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

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

Для более подробной информации о OpenGL Вы можете обратиться на сайт http://www.opengl.org.

Вместе с Delphi, начиная с третьей версии, поставляется файл помощи по OpenGL фирмы MicroSoft и заголовочный файл opengl.pas, позволяющий использовать эту графическую библиотеку в приложениях, написанных на Delphi.

Есть также альтернативные версии заголовочных файлов независимых разработчиков и компоненты, использующие OpenGL, упрощающие доступ к его функциям и использующие ООП подход. Некоторые из этих файлов и компонентов могут использовать версию OpenGL для Windows фирмы SGI, имеющую собственное расширение функций и имеющую более высокие скоростные показатели. Одна из самых полных систем, реализующая набор функций всех версий OpenGL - это библиотека разработчика MGL фирмы SciTechSoft.

Мы в своих примерах будем опираться только на стандартные файлы и компоненты Delphi, так что Вам не придется искать и приобретать дополнительные файлы и компоненты. Умея самостоятельно использовать OpenGL, Вы легко сможете использовать готовые компоненты, скрывающие черновую работу подключения и использования функций OpenGL. Тем более, что многие из этих компонентов отличаются неустойчивой работой.

Итак, Delphi в стандартной поставке позволяет использовать OpenGL в разрабатываемых приложениях, но как это сделать, плохо понятно из файла помощи, а готовыми примерами использования OpenGL Delphi не сопровождается (по крайней мере, на сегодня). Поэтому начинающим часто тяжело самостоятельно разобраться, как же работать с OpenGL в Delphi. Рассмотрению вопросов использования OpenGL вообще и использованию в Delphi и будет посвящен данный курс статей.

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

Для понимания смысла этих действий желательно понимать смысл основных понятий операционной системы Windows - ссылка, контекст, сообщение, в проектах Delphi не всегда активно используемых программистами. Желательно иметь хотя бы минимальные знания о роли динамических библиотек в этой операционной системе. Хотя, конечно, можно успешно использовать OpenGL и без глубоких знаний в этой области, используя готовые шаблоны приложений и сосредоточившись собственно на функциях OpenGL.

Важно также отметить то, что чаще всего приложения, активно использующие графику, нуждаются от Delphi только в создании окна приложения, таймере и обработчике манипуляций с клавиатурой и мышью. Для таких приложений чаще всего и не требуется богатство библиотеки VCL. и крайне важны скорость работы и "профессиональная" миниатюрность откомпилированного модуля. Поскольку мы вынуждены с самого начала рассматривать и разбирать темы уровнем ниже RAD-технологий, то нам становится по силам и написание программ без визуальных средств вообще, программ, использующих только функции Windows API, стремительно компилируемых и занимающих после компиляции миниатюрные размеры (порядка двух десятков килобайт).

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

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

Событие. Сообщение. Контекст.

Начнем наш разговор с понятий "событие" и "сообщение".

Очень часто это синонимы одного и того же термина операционной системы, общающейся с приложениями посредством посылки сообщений. Код, написанный в проекте Delphi как обработчик события OnCreate, выполняется при получении приложением сообщения WM_CREATE, сообщению WM_PAINT соответствует событие OnPaint, и т.д..Такие события использует мнемонику, сходную с мнемоникой сообщений.

Как операционная система различает окна для осуществления диалога с ними? Все окна при своем создании регистрируются в операционной системе и получают уникальный идентификатор, называемый "ссылка на окно". Тип этой величины в Delphi - HWND (WiNDow Handle, ссылка на окно).

Ссылка на окно может использоваться не только операционной системой, но и приложениями для идентификации окна, с которым необходимо производить манипуляции.

Попробуем проиллюстрировать смысл ссылки на окно на несложном примере.

Откомпилируйте минимальное приложение Delphi и начните новый проект. Форму назовите Form2, разместите на форме кнопку, обработчик события OnClick кнопки приведите к следующему виду:

Code: Procedure TForm2.Button1Click(Sender: TObject); Var. H: HWND; Begin. H := FindWindow ('TForm1', 'Form1'); If H <> 0 then. ShowMessage ('Есть Form1!'). Else. ShowMessage ('Нет Form1!'). End;

Теперь при щелчке на кнопке выдается сообщение, есть ли запущенное приложение, класс окна которого зарегистрирован в операционной системе как 'TForm1', в заголовке которого записано 'Form1'. То есть если одновременно запустить обе наши программы, при нажатии на кнопку выдается одно сообщение, если окно с заголовком 'Form1' закрыть, при щелчке на кнопку выдается другое сообщение.

Здесь мы используем функцию API FindWindow, возвращающую величину типа HWND - ссылку на найденное окно либо ноль, если такое окно не найдено.

Итак, ссылка на окно однозначно определяет окно. Свойство Handle формы и есть эта ссылка, значение которой форма получает при выполнении функции API CreateWindow - создании окна. Имея ссылку на окно, операционная система общается с окном путем посылки сообщений-сигналов о том, что произошло какое-либо событие, имеющее отношение именно к этому окну. Если окно имеет намерение отреагировать на это событие, операционная система имеет это в виду и вместе с окном осуществляет эту реакцию. Окно может и не имея фокус получать сообщения и реагировать на них.

Проиллюстрируем это на примере.

Обработчик события OnMouseMove формы приведите к виду:

Code: Procedure TForm2.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. Caption := 'x=' + IntToStr (X) + ', y=' + IntToStr (Y); End;

Работа с OpenGL - Минимальная программа.

Содержимое контекста.

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

То есть схема здесь такая - приложение отдает команды машине OpenGL, получая результат на поверхности своего окна. Такая архитектура называется "клиент - серверной", в роли клиента выступает наше приложение, в роли сервера - система OpenGL. Задача сервера - отрабатывать команды клиента. В принципе, сервер может располагаться и не на нашем компьютере, а удаленно, возможно и за тысячи километров от нас. Наше приложение должно передать серверу требуемые для работы данные - контексты и команды на языке сервера. Также важно понимать, что основную работу выполняет не наше приложение, а сервер. Наше приложение лишь создает окно - платформу для работы сервера, и передает команды серверу. При грамотном подходе нет разницы, какими средствами мы спроектировали приложение - С или Delphi, скорость воспроизведения целиком зависит от производительности сервера - машины OpenGL. Мы выбрали в качестве средства разработки приложений именно Delphi за выдающуюся скорость компиляции и обаятельность концепций.

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

Мы знаем, что ссылка на контекст устройства - величина типа HDC, для получения которой вызываем функцию GetDC. Ссылке на контекст устройства в Delphi соответствует свойство Canvas.Handle формы, принтера и некоторых компонентов. Теоретически всюду в наших примерах в строках, использующих величину DC типа HDC, вместо DC можно использовать Canvas.Handle. В первых примерах для начинающих это так и сделано. Каков же все-таки смысл контекста устройства, если он и так связан с однозначно определенным объектом - окном, областью памяти или принтером, и зачем передавать дополнительно какую-то информацию об однозначно определенном объекте?

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

Строки:

Form1.Canvas.Ellipse (0, 0, 100, 100);

И.

Code: Printer.BeginDoc; Printer.Canvas.Ellipse (0,0,100,100); Printer.EndDoc;

Алгоритмы сортировки.

Владимир ТКАЧУК vova.tkachuk@ua.fm.

Взято с http://mycomp.com.ua.

См. также статьи в других разделах:

Сортировка столбцов в StringGrid.

Как изменить стандартный цвет ProgressBar?

Самый простой способ, это изменить цветовую схему в свойствах экрана...

А вот при помощи следующей команды можно разукрасить ProgressBar не изменяя системных настроек:

Code: PostMessage(ProgressBar1.Handle, $0409, 0, clGreen);

Информация о сетевых интерфейсах.

Code: Unit netinfo; Interface. Uses Libc; Type. INTERFACE_INFO = packed record. Name: string; IPAddress: string; Broadcast: string; NetMask: string; IsUp: boolean; IsRun: boolean; IsBroadcast: boolean; IsMulticast: boolean; IsLoopBack: boolean; IsPPP: boolean; End; TAInfo = record. INFO: array of INTERFACE_INFO; End; Function EnumInterfaces(var IInfo: TAInfo): Boolean; Implementation. Function EnumInterfaces(var IInfo: TAInfo): Boolean; Var SHandle: integer; Len: longint; BufChar; Ifc: ifconf; Pifr: pifreq; Ifr: ifreq; Lastlen, i: integer; PAddrChar; Begin. Result := False; //создать UDP сокет. SHandle := Socket(AF_INET, SOCK_DGRAM, 0); If SHandle = INVALID_SOCKET then exit; { При вызове SIOCGIFCONF некоторые реализации. Не возвращают ошибок, если буфер слишком мал. Для хранения результата вызова (результат просто обрезается). Поэтому надо сделать вызов, запомнить возвращенную длину, Увеличить буфер и сделать еще один вызов. Ксли после этого вызова длины будут равны - OK! Иначе надо циклично увеличивать буфер. } Lastlen := 0; Len := 100 * sizeof(ifreq); While true do. Begin. Buf := Malloc(len); Ifc.ifc_len := len; PChar(ifc.ifc_ifcu) := buf; If ioctl(SHandle, SIOCGIFCONF, @ifc) < 0 then. Begin. If (errno <> EINVAL) and (lastlen <> 0) then. Warn('ioctl error'); End. Else. Begin. If ifc.ifc_len = lastlen then break; Lastlen := ifc.ifc_len; End; Len := len + 10 * sizeof(ifreq); Free(buf); End; Result := True; //здесь результат получен полностью. //len - кол-во интерфейсов. Len := ifc.ifc_len div sizeof(ifreq); SetLength(IInfo.Info, len); //указатель - на начало буфера. Pifr := ifc.ifc_ifcu.ifcu_req; For i := 0 to len - 1 do. Begin. Fillchar(ifr, sizeof(ifreq), 0); //считать очередную порцию данных. Move(pifr^, ifr, sizeof(ifreq)); //имя интерфейса. IInfo.INFO[i].Name := ifr.ifrn_name; //адрес интерфейса. PAddr := inet_ntoa(ifr.ifru_addr.sin_addr); IInfo.INFO[i].IPAddress := pAddr; //ШВ адрес. Ioctl(SHandle, SIOCGIFBRDADDR, @ifr); PAddr := inet_ntoa(ifr.ifru_netmask.sin_addr); IInfo.INFO[i].Broadcast := pAddr; //маска сети. Ioctl(SHandle, SIOCGIFNETMASK, @ifr); PAddr := inet_ntoa(ifr.ifru_netmask.sin_addr); IInfo.INFO[i].NetMask := pAddr; //флаги. Ioctl(SHandle, SIOCGIFFLAGS, @ifr); IInfo.INFO[i].IsUP := (ifr.ifru_flags and IFF_UP) = IFF_UP; IInfo.INFO[i].IsRun := (ifr.ifru_flags and IFF_RUNNING) = IFF_RUNNING; IInfo.INFO[i].IsBroadcast := (ifr.ifru_flags and IFF_BROADCAST) = IFF_BROADCAST; IInfo.INFO[i].IsLoopBack := (ifr.ifru_flags and IFF_LOOPBACK) = IFF_LOOPBACK; IInfo.INFO[i].IsPPP := (ifr.ifru_flags and IFF_POINTOPOINT) = IFF_POINTOPOINT; IInfo.INFO[i].IsMulticast := (ifr.ifru_flags and IFF_MULTICAST) = IFF_MULTICAST; Inc(pifr); End; End; End.

Как преобразовать String в Binary и наоборот?

Автор: Rem.

Code: Function BinStrToByte(a_sBinStr: string): byte; Var. I: integer; Begin. Result := 0; For i := 1 to length(a_sBinStr) do. Result := (Result shl 1) or byte(a_sBinStr[i] = '1'); End; Function ByteToBinStr(a_bByte: byte): string; Var. I: integer; Begin. SetLength(Result, 8); For i := 8 downto 1 do. Begin. Result[i] := chr($30 + (a_bByte and 1)); A_bByte := a_bByte shr 1; End; End; // Примечание: вторая функция использует тот факт, // что в таблице ANSI коды '0' = $30 и '1' = $31.

Из строки в массив и наоборот.

Code: Function StrToArrays(str, r: string; out Temp: TStrings): Boolean; Var. J: integer; Begin. If temp <> nil then. Begin. Temp.Clear; While str <> '' do. Begin. J := Pos(r,str); If j=0 then. J := Length(str) + 1; Temp.Add(Copy(Str,1,j-1)); Delete(Str,1,j+length(r)-1); End; Result:=True; End. Else. Result:=False; End; Function ArrayToStr(str: TStrings; r: string): string; Var. I: integer; Begin. Result:=''; If str = nil then. Exit; For i := 0 to Str.Count-1 do. Result := Result + Str.Strings[i] + r; End;

Как подсчитать количество слов в строке?

Code: Function Seps(As_Arg: Char): Boolean; Begin. Seps := As_Arg in. [#0..#$1F, ' ', '.', ',', '?', ':', ';', '(', ')', '/', '\']; End; Function WordCount(CText: string): Longint; Var. Ix: Word; Work_Count: Longint; Begin. Work_Count := 0; Ix := 1; While Ix <= Length(CText) do. Begin. While (Ix <= Length(CText)) and (Seps(CText[Ix])) do. Inc(Ix); If Ix <= Length(CText) then. Begin. Inc(Work_Count); While (Ix <= Length(CText)) and (not Seps(CText[Ix])) do. Inc(Ix); End; End; Word_Count := Work_Count; End; { To count the number opf words in a TMemo Component, Call: WordCount(Memo1.Text). }

Как установить BDE?

Code: Program InstallPrfSt; { Программа иллюстрирует, как установить BDE с поддержкой PARADOX 7.0. На "чистой машине" и создать алиас. Пример использования в качестве простейшего инсталлятора для программы. C:\MyDir\MyProg.exe. 1.Создайте каталог C:\MyDir\BDE и скопируйте в него след. файлы: CHARSET.BLL. OTHER.BLL. IDAPI32.CFG. BLW32.DLL. IDAPI32.DLL. IDBAT32.DLL. IDPDX32.DLL. IDR20009.DLL. IDSQL32.DLL. BDEADMIN.EXE - по вкусу, т.к. необходимым не является. 2.Измените значение константы AliasName на имя необходимого вам алиаса. 3.Откомпиллируйте и запустите эту программу из каталога C:\MyDir. ВНИМАНИЕ!!! Если на машине уже установлено BDE, то перед экспериментами. Сохраните (на всякий случай) след. ключи из реестра: [HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine] и. [HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32]. } {$APPTYPE CONSOLE}. Uses. Windows, BDE, Registry; Const. AliasName: string = 'PrefStat'; Var. R: DBIResult; Path: string; Procedure WriteString(S1:string); Begin. S1 := S1 + #0; AnsiToOem(@S1[1], @S1[1]); Writeln(S1); End; Function GetExePath(S1:string):string; Var. I, K :Integer; S: string; Begin. K := 1; S := ''; For I := Length(S1) downto 1 do. Begin. If S1[I] = '\' then. Begin. K := I; Break; End; End; For I := 1 to K - 1 do. S := S + S1[I]; Result:=S; End; Procedure InstallBde; Const. Bor: string = 'SOFTWARE\Borland'; Var. A: TRegistry; BPath: string; Begin. BPath:=PATH + '\BDE'; A := TRegistry.Create; With a do. Begin. RootKey := HKEY_LOCAL_MACHINE; OpenKey(Bor + '\Database Engine', True); WriteString('CONFIGFILE01', BPath+'\IDAPI32.CFG'); WriteString('DLLPATH', BPath); WriteString('RESOURCE', '0009'); WriteString('SaveConfig', 'WIN32'); WriteString('UseCount', '2'); CloseKey; OpenKey(Bor+'\BLW32',True); WriteString('BLAPIPATH', BPath); WriteString('LOCALE_LIB3', BPath+'\OTHER.BLL'); WriteString('LOCALE_LIB4', BPath+'\CHARSET.BLL'); CloseKey; OpenKey(Bor+'\Database Engine\Settings\SYSTEM\INIT',True); WriteString('AUTO ODBC', 'FALSE'); WriteString('DATA REPOSITORY', ''); WriteString('DEFAULT DRIVER', 'PARADOX'); WriteString('LANGDRIVER', 'ancyrr'); WriteString('LOCAL SHARE', 'FALSE'); WriteString('LOW MEMORY USAGE LIMIT', '32'); WriteString('MAXBUFSIZE', '2048'); WriteString('MAXFILEHANDLES', '48'); WriteString('MEMSIZE', '16'); WriteString('MINBUFSIZE', '128'); WriteString('SHAREDMEMLOCATION', ''); WriteString('SHAREDMEMSIZE', '2048'); WriteString('SQLQRYMODE', ''); WriteString('SYSFLAGS', '0'); WriteString('VERSION', '1.0'); CloseKey; OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\DATE',True); WriteString('FOURDIGITYEAR', 'TRUE'); WriteString('LEADINGZEROD', 'FALSE'); WriteString('LEADINGZEROM', 'FALSE'); WriteString('MODE', '1'); WriteString('SEPARATOR', '.'); WriteString('YEARBIASED', 'TRUE'); CloseKey; OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\NUMBER',True); WriteString('DECIMALDIGITS', '2'); WriteString('DECIMALSEPARATOR', ','); WriteString('LEADINGZERON', 'TRUE'); WriteString('THOUSANDSEPARATOR', ' '); CloseKey; OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\TIME',True); WriteString('AMSTRING', 'AM'); WriteString('MILSECONDS', 'FALSE'); WriteString('PMSTRING', 'PM'); WriteString('SECONDS', 'TRUE'); WriteString('TWELVEHOUR', 'TRUE'); CloseKey; OpenKey(Bor+'\Database Engine\Settings\REPOSITORIES',True); CloseKey; OpenKey(Bor+'\Database Engine\Settings\DRIVERS\PARADOX\INIT',True); WriteString('LANGDRIVER', 'ancyrr'); WriteString('TYPE', 'FILE'); WriteString('VERSION', '1.0'); CloseKey; OpenKey(Bor+'\Database Engine\Settings\DRIVERS\PARADOX\TABLE. CREATE',True); WriteString('BLOCK SIZE', '4096'); WriteString('FILL FACTOR', '95'); WriteString('LEVEL', '7'); WriteString('STRICTINTEGRTY', 'TRUE'); CloseKey; End; A.Free; End; Begin. Path:=GetExePath(ParamStr(0)); R:=dbiInit(nil); If R<>DBIERR_NONE then. Begin. WriteString('Инициализация BDE ...'); InstallBDE; End; R:=dbiInit(nil); If R=DBIERR_NONE then. Begin. WriteString('Инициализация BDE прошла успешно'); DbiDeleteAlias(nil, PChar(AliasName)); R:=DbiAddAlias(nil, PChar(AliasName), szPARADOX, PChar('PATH:'+Path+'\DB'), True); If R=DBIERR_NONE then. WriteString('Псевдоним "'+AliasName+'" создан'). Else. WriteString('Ошибка создания псевдонима "'+AliasName+'"'); R:=DbiCfgSave(nil, nil, Bool(-1)); If R=DBIERR_NONE then. WriteString('Файл конфигурации сохранён'). Else. WriteString('Ошибка сохранения файла конфигурации'); DbiExit; End. Else. WriteString('Ошибка инициализации BDE'); End.

Использование указателей на целое.

Сначала вы должны создать тип:

Code: Type Pinteger : ^Integer; Var MyPtr : Pinteger;

Мне кажется, что в начале вы использовали плохой пример, имеет смысл использовать 32-битный указатель для 16-битной величины или распределять 10 байт для переменной.

Pascal позволяет вам использовать методы NEW и DISPOSE, которые автоматически распределяют и освобождают правильные размеры блока.

Например:

Code: NEW(MyPtr) = GetMem(MyPtr, Sizeof(MyPtr)).

Возможно, вы захотите подсчитать количество целочесленных переменных. В этом случае ознакомьтесь с возможностями TList. Пока лучше используйте линейный массив (или указатель на первый элемент, чтобы вычислить их количество, достаточно разделить количество занимаемой массивом памяти на количество элементов).

Для полноты, это должно быть:

Code: NEW(MyPtr) = GetMem(MyPtr, SizeOf(MyPtr^));

SizeOf(MyPtr) всегда будет равен 4 байта, как 16-битный указатель.

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

Code: Type. PIntArr = ^IntArr; IntArr = Array[1..1000] of Integer; Var. MyPtr : pIntArr; Begin. GetMem(MyPtr, 10); { 10 = SizeOf(Integer) * 5 !!). { MyPtr[2]:=1; }. // <<<< Заполняем массив >>>> MyPtr[2]^:=1; FreeMem(MyPtr,10); End;

Технология похожа на ту, которая Delphi использует при работе с pchar. Синтаксис очень похож:

Code: Type. Intarray = array[0..20000] of integer; Procedure TForm1.Button1Click(Sender: TObject); Var. Xptr: ^IntArray; Begin. GetMem(xptr, 10); Xptr^[idx] := 1; { где idx от 0 до 4, поскольку мы. Имеем 10 байте = 5 целых }. FreeMem(xptr, 10); End;

Обратите внимание на то, в вам в действительности нет необходимости распределять массив для 20,000 элементов, но проверка диапазона Delphi не будет работать, если диапазон равен 20,000. (Предостережение будущим пользователям!).

©Drkb::00258.

Взято с http://delphiworld.narod.ru.

Взаимодействие с чужими окнами.

Представьте себе, глупый пользователь сидит как ни в чём небывало с умным видом уже в какой раз пытается составить документ в Microsoft Word'e, но вдруг окно начинает бешено скакать по экрану, в его заголовке выводятся непристойные сообщения, оно то сворачивается, то разворачивается, меняя постоянно свои размеры, а под конец совсем исчезает, унося в небытиё весь текст, который с таким трудом набил ламерюга... а если так себя в любой момент может повести любая программа... впечатления от этого останутся на долго!!!

Для того, чтобы сделать что-нибудь над каким-либо окном нужно сначала получить его дескриптор, т.е. его положение в оперативной памяти. Для этого нужно использовать функцию FindWindow. Ей нужно указать всего два параметра: сначала класс искомого окна, затем его заголовок. Ну с заголовком проблем вообщем-то нет - его мы видим, но вот как определить класс... ведь он скрыт от глас пользователя. В действительности мы может указать только заголовок окна, а вместо класса ставим nil.

Для начала запустите стандартную программу "Блокнот" - и что же мы видим? В блокноте в заголовке окна отслеживается имя текущего файла. Изначально, т.к. файла нет в использовании, заголовок блокнота выглядит так: "Безымянный - Блокнот". Постараемся по этому критерию найти окно блокнота. Выглядеть это будет так:

Code: If FindWindow(nil, 'Безымянный - Блокнот') <> 0 then. ShowMessage('Окно найдено'). Else. ShowMessage('Окно НЕнайдено');

Как мы видим из кода, если наша программа найдёт окно блокнота, мы увидим сообщение, гласящее об этом.

Далее попробуем передвинуть это окно.

Code: Var. H: HWND; Begin. H := findwindow(nil, 'Безымянный - Блокнот'); If h <> 0 then. SetWindowPos(h, HWND_BOTTOM, 1, 1, 20, 20, swp_nosize); End;

Опять находим блокнот. Его дескриптор помещаем в переменную класса HWND[С английского Handle Window - дескриптор окна]. Далее используем функцию SetWindowPos для задания позиции. В качестве параметров нужно указать:

Дескриптор окна, которое хотим переместить.

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

HWND_BOTTOM Начало Z-последовательности.

HWND_NOTOPMOST Первое окно которое располагается не "поверх все окон".

HWND_TOP Вершина Z-последовательности.

HWND_TOPMOST Первое окно которое располагается "поверх все окон".

Позиция окна по горизонтали.

Позиция окна по вертикали.

Ширина окна.

Высота окна.

Спецификаторы изменения позиции и размеров окна[флаги]. Для задания значения можно комбинировать следующие константы.

SWP_DRAWFRAME Прорисовка фрейма вокруг окна.

SWP_FRAMECHANGED Посылает сообщение WM_NCCALCSIZE окну, даже если размер его не был изменён. Если этот флаг не указан, сообщение WM_NCCALCSIZE будет посылаться, только после изменения размеров окна.

SWP_HIDEWINDOW Скрывает окно.

SWP_NOACTIVATE Не активизирует окно. Если же этот флаг не будет поставлен, окно активизируется и будет перемещено поверх всех окон. А вот встанет ли окно даже выше тех окон, которым задано HWND_TOPMOST или нет зависит от параметра hWndInsertAfter.

SWP_NOCOPYBITS Если этот спецификатор не будет установлен, тогда содержимое клиентской области окна будет скопировано и вставлено во вновь отобразившееся окно после его перемещения.

SWP_NOMOVE Сообщает, что нужно игнорировать параметры задания позиции окну.

SWP_NOOWNERZORDER Сообщает, что не следует изменять позицию окна владельца в Z-последовательности.

SWP_NOREDRAW Не перерисовывает окно.

SWP_NOREPOSITION Такой же как и SWP_NOOWNERZORDER.

SWP_NOSENDCHANGING Мешает окну получить сообщение WM_WINDOWPOSCHANGING.

SWP_NOSIZE Сообщает, что нужно игнорировать параметры задания размеров окну.

SWP_NOZORDER Сохраняет текущее положение в Z-последовательности (игнорирует сообщение hWndInsertAfter parameter).

SWP_SHOWWINDOW Отображает окно.

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

Code: SetWindowText(FindWindow(nil, 'Безымянный - Блокнот'), 'Дарова, ламерюга, типа ты попал... ');

Функции setwindowtext нужно указать только два параметра: это дескриптор нужного окна и новое значение для заголовка. Вот вообщем-то и всё!

Есть ещё одна интересная функция ShowWindow, которая позволяет скрывать или отображать окна. Использовать её нужно так::

Code: ShowWindow(FindWindow(nil, 'Безымянный - Блокнот'), sw_hide);

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

SW_HIDE Скрывает окно и активизирует другое.

SW_MAXIMIZE Разворачивает окно.

SW_MINIMIZE Сворачивает окно.

SW_RESTORE Активизирует и выводит окно. Если окно было развёрнуто или свёрнуто - восстанавливает исходный размер и позицию.

SW_SHOW Активизирует и выводит окно с его оригинальным размером и положением.

SW_SHOWDEFAULT Активизирует с установками, заданными в структуре STARTUPINFO, которая была передана при создании процесса приложением запускающим нужную программу.

SW_SHOWMAXIMIZED Выводит окно в развёрнутом виде.

SW_SHOWMINIMIZED Выводит окно в виде пиктограммы на панели задач.

SW_SHOWMINNOACTIVE Выводит окно в свёрнутом виде на панели задач и не передаёт ему фокус ввода, т.е. окно, которое до этого было активно остаётся активно по прежнему.

SW_SHOWNA Отображает окно в его текущем состоянии. Активное окно остаётся активным по прежнему.

SW_SHOWNOACTIVATE Выводит окно в его последнем положении и с последними используемыми размерами. Активное окно остаётся активным по прежнему.

SW_SHOWNORMAL Выводит окно. Если оно было свёрнуто или развёрнуто - восстанавливает его оригинальные размеры и позицию.

Но вся сложность действий заключается в том, что в заголовке Блокнота отслеживается имя текущего файла и использовать значение "Безымянный - Блокнот" мы можем не всегда : (. Тем более это не только в случае с блокнотом... Но есть выход: ведь функции FindWindow для поиска окна мы указываем не только заголовок нужного окна, но ещё его класс. Какой же это выход скажете вы, заголовок окна мы видим, значит знаем, что указывать - а класс окна... в действительности тоже может найти приложив немного усилий!

В пакет Delphi входим специальная утилита для отслеживание всех активных процессов, она называется WinSight32. Вот ею мы и воспользуемся. Запустите её, покопайтесь в списке процессов, ищите строку где значится текущий заголовок нужного окна, например Блокнота, и в левой части этой строки в фигурных скобках вы найдёте имя класса окна. Для блокнота это будет "Notepad". Теперь зная имя класса окна мы можем переписать поиск окна таким способом:

Code: ShowWindow(FindWindow('Notepad', nil), sw_hide);

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

Есть ещё один замечательный способ передачи команд окнам.- функция PostMessage. Ей в качестве параметров нужно указать:

Дескриптор окна, которому посылается сообщение или следующие значения:

HWND_BROADCAST Сообщение будет послано всем окнам верхнего уровня системы, включая неактивные и невидимые окна, overlapped-окна, и PopUp-окна, но сообщение не будет посылаться дочерним[Child] окнам.

NULL Ведёт себя как функция PostThreadMessage с переданным ей dwThreadId параметром.

Посылаемое сообщение.

Первый параметр сообщения.

Второй параметр сообщения.

Например, если послать сообщение wm_quit блокноту - окно будет закрыто без вывода всяких сообщений о необходимости сохранения!

Code: PostMessage(FindWindow('Notepad', nil), wm_quit, 0, 0);

Как гарантированно сделать backup?

Как гарантированно сделать backup/restore БД InterBase с опцией 'Replace existing database' и записями протоколов в файлы с гарантированным отстрелом пользователей?

Att.bat:

At 01:00 /INTERACTIVE "e:\IB_DATA\BR.BAT".

BR.bat:

Del e:\IB_DATA\b.txt.

Del e:\IB_DATA\r.txt.

Del e:\ib_data\AR_IB.PRV.

Del e:\IB_DATA\AR_IB.GBK.

D:\ib_42\bin\gfix -shut -force 1 e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo".

Net stop "InterBase Server".

Copy e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.PRV.

Net start "InterBase Server".

D:\ib_42\bin\gbak e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.GBK -user "SYSDBA" -password "oooo" -B -L -Y "e:\IB_DATA\b.txt".

D:\ib_42\bin\gbak e:\ib_data\AR_IB.GBK e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo" -P 4096 -V -R -Y "e:\IB_DATA\r.txt".

Sergey Klochkovski.

©Drkb::02910.

Взято с http://delphiworld.narod.ru.

Проблемы с автоинкрементальными полями.

Оказывается, что Interbase триггер "before insert" срабатывает только после того, как запись "запостится" из Delphi приложения. В связи с чем становится невозможным увеличение автоинкрементальных ключевых полей. Есть решение?

Большинство программистов решило эту проблему созданием хранимой процедуры (stored procedure), позволяющей от InterBase получить следующий номер и поместить его в вашу запись посредством метода onBeforePost или onNewRecord.

©Drkb::02911.

Автор: Steve Koterski (Borland).

Я пытаюсь сгенерировать последовательный ключ для первичной ключевой колонки, но LIBS мне отвечает "nested select is not support in this context." (вложенный выбор не поддерживается в данном контексте.).

Как насчет:

Code: CREATE TRIGGER AUTOINCREMENT FOR MYTABLE. BEFORE INSERT AS. DECLARE VARIABLE new_key INTEGER; BEGIN. UPDATE AUTOKEYS. SET KEY_VALUE = KEY_VALUE + 1. WHERE (KEY_ID = "A"); SELECT KEY_VALUE. FROM AUTOKEYS. WHERE KEY_ID = "A". INTO :new_key; New.my_key_column = new_key; END ^

Изображения и InterBase Blob-поля.

DBASE и Paradox таблицы имеют в своем арсенале BLOB-поля, позволяющие хранить бинарные данные, в том числе bitmap-формат, отображаемый с помощью компонента TDBImage. В Database Desktop данный тип полей указан как Binary и Graphic (для dBASE и Paradox таблиц, соответственно). Тем не менее, процесс сохранения изображений в InterBase BLOB-полях и их использование в компонентах TDBImage не такой уж простой.

Таблицы InterBase не имеют простого типа BLOB-поля. Есть три варианта, или подтипа: тип 0, тип 1 и подтип, определенный пользователем. Типы 0 и 1 - "встроенные" типы. Тип 0 - BLOB-поля (тип по умолчанию) для хранения общих бинарных данных. Тип 1 - BLOB-поля для хранения текстовых BLOB-данных. Ни один из предопределенных типов не допускает автоматического извлечения данных изображения из BLOB-поля для его последующего отображения в компоненте TDBImage. BLOB-поля типа 0 могут использоваться для хранения данных bitmap-формата, но данные должны извлекаться и передаваться в объект типа TBitmap программным путем. Вот пример ручного извлечения данных изображения, хранящихся в BLOB-поле типа 0 (Table1BLOBField), и его показ в компоненте TImage (не предназначенным для работы с БД) :

Code: Procedure TForm1.ExtractBtnClick(Sender: TObject); Begin. Image1.Picture.Bitmap.Assign(Table1BLOBField); End;

Естественно, поскольку это должно делаться вручную, данный процесс менее желателен в приложении, нежели автоматическое отображение данных изображения в комбинации BDE и компонента TDBImage. Здесь происходит определение подтипа определенного пользователем BLOB-поля. При работе с данными подтип BLOB-поля учитывается, т.к. сохраненные первыми данные устанавливают тип данных для этого поля для всей таблицы целиком. Таким образом, если данные bitmap-формата оказывается первым загружаемым типом, то данный формат будет единственно возможным для данного поля. До сих пор по умолчанию тип бинарного BLOB-поля (предопределенный тип 0) позволял BDE читать и отображать данные в компоненте TDBImage без особых проблем.

Утилиты Database Desktop допускают создание бинарных BLOB-полей только типа 0 и не имеют возможности самим определять подтипы BLOB-полей. Из-за такого ограничения таблицы, подразумевающие хранение и вывод изображений, должны создаваться с помощью SQL-запросов. Обычно это делается посредством утилиты WISQL, но вполне достаточно выполнение SQL-запроса с помощью компонента TQuery. Ниже приведен SQL-запрос, создающий таблицу с определенным пользователем подтипом BLOB-поля:

Code: CREATE TABLE WITHBMP. ( FILENAME CHAR(12), BITMAP BLOB SUB_TYPE -1. )

После создания таблицы с совместимыми BLOB-полями, для хранения данных изображения в BLOB-поле и его вывода в компоненте TDBImage используются те же самые методы, что и при работе с таблицами dBASE и Paradox.

Имеется множество способов загрузки изображений в BLOB-поле. Три самых простых метода включают в себя:

Копирование данных из буфера обмена Windows в компонент TDBImage, связанный с BLOB-полем.

Использование метода LoadFromFile компонента TBLOBField.

Использование метода Assign для копирования объекта типа TBitmap в значение свойства Picture компонента TBDBImage.

Первый способ, когда происходит копирование изображения из буфера обмена, вероятно, наиболее удобен в случае, когда необходимо добавить изображение в таблицу при использовании приложения конечным пользователем. В этом случае компонент TDBImage используется в роли интерфейса между BLOB-полем таблицы и изображением, хранящимся в буфере обмена. Метод PasteFromClipboard компонента TDBImage как раз и занимается тем, что копирует изображение из буфера обмена в TDBImage. При сохранении записи изображение записывается в BLOB-поле таблицы.

Поскольку буфер обмена Windows может содержать данные различных форматов, то желательно перед вызовом метода CopyFromClipboard осуществлять проверку формата хранящихся в нем данных. Для этого необходимо создать объект TClipboard и использовать его метод HasFormat, позволяющий определить формат хранящихся в буфере данных. Имейте в виду, что для создания объекта TClipboard вам необходимо добавить модуль Clipbrd в секцию uses того модуля, в котором будет создаваться экземпляр объекта.

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. C: TClipboard; Begin. C := TClipboard.Create; Try. If Clipboard.HasFormat(CF_BITMAP) then. DBImage1.PasteFromClipboard. Else. ShowMessage('Буфер обмена не содержит изображения!'); Finally. C.Free; End; End;

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

Этот способ использует метод LoadFromFile компонента TBLOBField, который применяется в Delphi для работы с dBASE-таблицами и двоичными Windows полями или таблицами Paradox и графическими Windows полями; в обоих случаях с помощью данного метода возможно загрузить изображение и сохранить его в таблице.

Методу LoadFromFile компонента TBLOBField необходим единственный параметр типа String: имя загружаемого файла с изображением. Значение данного параметра может быть получено при выборе файла пользователем с помощью компонента TOpenDialog и его свойства FileName.

Вот пример, демонстрирующий работу метода LoadFromFile компонента TBLOBField с именем Table1Bitmap (поле с именем Bitmap связано с таблицей TTable, имеющей имя Table1):

Code: Procedure TForm1.Button2Clicck(Sender: TObject); Begin. Table1Bitmap.LoadFromFile( 'c:\delphi\images\splash\16color\construc.bmp'); End;

Третий способ для копирования содержимого объекта типа TBitmap в свойство Picture компонента TDBImage использует метод Assign. Объект типа TBitmap может быть как свойством Bitmap свойства-объекта Picture компонента TImage, так и отдельного объекта TBitmap. Как и в методе, копирующем данные из буфера обмена в компонент TDBImage, данные изображения компонента TDBImage сохраняются в BLOB-поле после успешного сохранения записи.

Ниже приведен пример, использующий метод Assign. В нашем случае используется отдельный объект TBitmap. Для помещения изображения в компонент TBitmap был вызван его метод LoadFromFile.

Code: Procedure TForm1.Button3Click(Sender: TObject); Var. B: TBitmap; Begin. B := TBitmap.Create; Try. B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp'); DBImage1.Picture.Assign(B); Finally. B.Free; End; End;

Как вывести цветной текст в TStatusBar?

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

Code: 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;

Как проверить, имеем ли мы административные привилегии в системе?

Code: Type. PTOKEN_GROUPS = TOKEN_GROUPS^; Function RunningAsAdministrator(): Boolean; Var. SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY; PsidAdmin: PSID; Ptg: PTOKEN_GROUPS = nil; HtkThread: Integer; { HANDLE }. CbTokenGroups: Longint; { DWORD }. IGroup: Longint; { DWORD }. BAdmin: Boolean; Begin. Result := false; If not OpenThreadToken(GetCurrentThread(), // get security token. TOKEN_QUERY, FALSE, htkThread) then. If GetLastError() = ERROR_NO_TOKEN then. Begin. If not OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, htkThread) then. Exit; End. Else. Exit; If GetTokenInformation(htkThread, // get #of groups. TokenGroups, nil, 0, cbTokenGroups) then. Exit; If GetLastError() <> ERROR_INSUFFICIENT_BUFFER then. Exit; Ptg := PTOKEN_GROUPS(getmem(cbTokenGroups)); If not Assigned(ptg) then. Exit; If not GetTokenInformation(htkThread, // get groups. TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then. Exit; If not AllocateAndInitializeSid(SystemSidAuthority, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdmin) then. Exit; IGroup := 0; While iGroup < ptg^.GroupCount do // check administrator group. Begin. If EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then. Begin. Result := TRUE; Break; End; Inc(iGroup); End; FreeSid(psidAdmin); End;

Определить, занят ли порт сокета.

Code: Var SockAddrIn : TSockAddrIn; FSocket : TSocket; ... If bind(FSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 Then. Begin. Обрабатываем WSAGetLastError. End;

Фон MDI-окон.

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

(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.).

Самая сложная часть кода осуществляет обработку системного сообщения, адресуемого дескриптору окна (ClientHandle), осуществляющему управление дочерними формами. Происходит это в момент вывода изображений в MDI-форме. Все что вам необходимо сделать - в режиме проектирования загрузить в imgTile необходимые изображения и перенести в свою программу следующий код:

Code: Unit UMain; Interface. Uses. Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms, Dialogs, ExtCtrls, Menus; Type. TfrmMain = class(TForm). MnuMain: TMainMenu; MnuFile: TMenuItem; MnuExit: TMenuItem; ImgTile: TImage; MnuOptions: TMenuItem; MnuBitmap: TMenuItem; MnuGradient: TMenuItem; Procedure mnuExitClick(Sender: TObject); Procedure FormCreate(Sender: TObject); Procedure mnuBitmapClick(Sender: TObject); Procedure mnuGradientClick(Sender: TObject); Procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); Procedure FormResize(Sender: TObject); Procedure FormPaint(Sender: TObject); Private. { Private declarations }. MDIDefProc: pointer; MDIInstance: TFarProc; Procedure MDIWndProc(var prmMsg: TMessage); Procedure CreateWnd; override; Procedure ShowBitmap(prmDC: hDC); Procedure ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte); Public. { Public declarations }. End; Var. FrmMain: TfrmMain; GlbImgWidth: integer; GlbImgHeight: integer; Implementation. {$R *.DFM}. Procedure TfrmMain.FormCreate(Sender: TObject); Begin. GlbImgHeight := imgTile.Picture.Height; GlbImgWidth := imgTile.Picture.Width; End; Procedure TfrmMain.FormResize(Sender: TObject); Begin. FormPaint(Sender); End; Procedure TfrmMain.MDIWndProc(var prmMsg: TMessage); Begin. With prmMsg do. Begin. If Msg = WM_ERASEBKGND then. Begin. If mnuBitmap.Checked then. ShowBitmap(wParam). Else. ShowGradient(wParam, 255, 0, 0); Result := 1; End. Else. Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam); End; End; Procedure TfrmMain.CreateWnd; Begin. Inherited CreateWnd; MDIInstance := MakeObjectInstance(MDIWndProc); { создаем ObjectInstance }. MDIDefProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(MDIInstance))); End; Procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean); Begin. { восстанавоиваем proc окна по умолчанию }. SetWindowLong(ClientHandle, GWL_WNDPROC, longint(MDIDefProc)); { избавляемся от ObjectInstance }. FreeObjectInstance(MDIInstance); End; Procedure TfrmMain.mnuExitClick(Sender: TObject); Begin. Close; End; Procedure TfrmMain.mnuBitmapClick(Sender: TObject); Var. WrkDC: hDC; Begin. WrkDC := GetDC(ClientHandle); ShowBitmap(wrkDC); ReleaseDC(ClientHandle, wrkDC); MnuBitmap.Checked := true; MnuGradient.Checked := false; End; Procedure TfrmMain.mnuGradientClick(Sender: TObject); Var. WrkDC: hDC; Begin. WrkDC := GetDC(ClientHandle); ShowGradient(wrkDC, 0, 0, 255); ReleaseDC(ClientHandle, wrkDC); MnuGradient.Checked := true; MnuBitMap.Checked := false; End; Procedure TfrmMain.ShowBitmap(prmDC: hDC); Var. WrkSource: TRect; WrkTarget: TRect; WrkX: integer; WrkY: integer; Begin. { заполняем (tile) окно изображением }. If FormStyle = fsNormal then. Begin. WrkY := 0; While wrkY < ClientHeight do { заполняем сверху вниз.. }. Begin. WrkX := 0; While wrkX < ClientWidth do { ..и слева направо. }. Begin. Canvas.Draw(wrkX, wrkY, imgTile.Picture.Bitmap); Inc(wrkX, glbImgWidth); End; Inc(wrkY, glbImgHeight); End; End. Else if FormStyle = fsMDIForm then. Begin. Windows.GetClientRect(ClientHandle, wrkTarget); WrkY := 0; While wrkY < wrkTarget.Bottom do. Begin. WrkX := 0; While wrkX < wrkTarget.Right do. Begin. BitBlt(longint(prmDC), wrkX, wrkY, imgTile.Width, imgTile.Height, ImgTile.Canvas.Handle, 0, 0, SRCCOPY); Inc(wrkX, glbImgWidth); End; Inc(wrkY, glbImgHeight); End; End; End; Procedure TfrmMain.ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte); Var. WrkBrushNew: hBrush; WrkBrushOld: hBrush; WrkColor: TColor; WrkCount: integer; WrkDelta: integer; WrkRect: TRect; WrkSize: integer; WrkY: integer; Begin. { процедура заполнения градиентной заливкой }. WrkDelta := 255 div (1 + ClientHeight); { желаемое количество оттенков }. If wrkDelta = 0 then. WrkDelta := 1; { да, обычно 1 }. WrkSize := ClientHeight div 240; { размер смешанных баров }. If wrkSize = 0 then. WrkSize := 1; For wrkY := 0 to 1 + (ClientHeight div wrkSize) do. Begin. WrkColor := RGB(prmRed, prmGreen, prmBlue); WrkRect := Rect(0, wrkY * wrkSize, ClientWidth, (wrkY + 1) * wrkSize); If FormStyle = fsNormal then. Begin. Canvas.Brush.Color := wrkColor; Canvas.FillRect(wrkRect); End. Else if FormStyle = fsMDIForm then. Begin. WrkBrushNew := CreateSolidBrush(wrkColor); WrkBrushOld := SelectObject(prmDC, wrkBrushNew); FillRect(prmDC, wrkRect, wrkBrushNew); SelectObject(prmDC, wrkBrushOld); DeleteObject(wrkBrushNew); End; If prmRed > wrkDelta then. Dec(prmRed, wrkDelta); If prmGreen > wrkDelta then. Dec(prmGreen, wrkDelta); If prmBlue > wrkDelta then. Dec(prmBlue, wrkDelta); End; End; Procedure TfrmMain.FormPaint(Sender: TObject); Begin. If FormStyle = fsNormal then. If mnuBitMap.Checked then. MnuBitMapClick(Sender). Else. MnuGradientClick(Sender); End; End.

©Drkb::00485.

Сначала установите свойство формы FormStyle в fsMDIForm. Затем разместите Image на форме и загрузите в него картинку. Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки:

Code: FClientInstance: TFarProc; FPrevClientProc: TFarProc; Procedure ClientWndProc(var message: TMessage);

Добавьте следующие строки в разделе implementation:

Code: Procedure TMainForm.ClientWndProc(var message: TMessage); Var. Dc: hDC; Row: Integer; Col: Integer; Begin. With message do. Case Msg of. WM_ERASEBKGND: Begin. Dc := TWMEraseBkGnd(message).Dc; For Row := 0 to ClientHeight div Image1.Picture.Height do. For Col := 0 to ClientWidth div Image1.Picture.Width do. BitBlt(Dc, Col * Image1.Picture.Width, Row * Image1.Picture.Height, Image1.Picture.Width, Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY); Result := 1; End; Else. Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam); End; End;

По созданию окна [событие OnCreate()] напишите такой код:

Code: FClientInstance := MakeObjectInstance(ClientWndProc); FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC)); SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild.

©Drkb::00486.

Взято с http://delphiworld.narod.ru.

Code: Procedure TForm.OnPaint(Sender: TObject); Procedure Tile(c: TCanvas; b: TBitMap); Var. X, y, h, w, i, j: integer; Begin. With b do. Begin. H := b.height; W := b.width; End; Y := 0; With c.Cliprect do. Begin. I := bottom - top - 1; //высота. J := right - left - 1; //ширина. End; While y < i do. Begin. X := 0; While x < j do. Begin. C.draw(x, y, b); Inc(x, w); End; Inc(y, h); End; End; Begin. If Sender is TForm then. Tile(TForm(Sender).Canvas, fTileWith); End;

Почему MDI Child форма при закрывании просто минимизируется?

Обрабатывайте событие OnClose для формы и выставляйте в нем параметр Action в caFree. Дело в том, что его значение по умолчанию для MDI Child форм caMinimize. Кстати, если сделать Action := caNone, то форму нельзя будет закрыть.

©Drkb::00491.

Взято с http://delphiworld.narod.ru.

Сколько открыто дочерних окон?

Code: Form1.MDIChildCount.

Открытие MDI-окон определенного размера.

Code: Var. ProjectWindow: TWndProject; Begin. If ProjectActive=false then. Begin. LockWindowUpdate(ClientHandle); ProjectWindow:=TWndProject.Create(self); ProjectWindow.Left:=10; ProjectWindow.Top:=10; ProjectWindow.Width:=373; ProjecTwindow.Height:=222; ProjectWindow.Show; LockWindowUpdate(0); End; End;

Проблема всплывающих подсказок в дочерних MDI-формах.

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

Объявите следующую процедуру в классе вашей главной формы:

Code: Private. {============================================================} { Процедура, вызываемая приложением всякий раз, когда }. { приложение хотело бы показать всплывающую подсказку. }. { Добавляет хинт на панель статуса. }. {============================================================} Procedure ShowHint(Sender : TObject);

Затем в процедуре главной формы .create добавьте следующую строку:

Code: { Отображает хинт на статусной панели}. Application.OnHint := ShowHint;

Меню дочерних MDI-форм.

Так как MDI-приложения всегда объединяют меню дочерних окон с главным меню родительского окна, вы можете установить определенное значение для указания позиции элементов меню в новой, объединенной строке меню. Это называется индексом группы. Но работает оно только для видимых пунктов меню.

Так, например, если ваше MDI-меню имеет:

[Файл] [Вид] [О программе] (со значениями индексов групп 1 5 10) (Значения не имеют никакого значения (извините за невольный каламбур), они используются только лишь для сортировки),

А меню дочерней MDI-формы имеет:

[Файл] [Редактирование] (и им присвоены значения 1 и 3),

То при открытии дочернего MDI-окна пункт меню [Файл] заменит соответствующий пункт меню родительской MDI-формы. Пункт меню [Редактирование] будет расположен перед пунктами [Вид] и [О программе] родительской формы.

Это может оказаться весьма полезным, поскольку меню [Файл] MDI-формы в нормальной ситуации может содержать меньшее количество пунктов меню по сравнению с ситуацией, когда имеется открытая дочерняя MDI-форма.

К примеру, в описанной выше ситуации в меню [Файл] MDI-формы необходимы только пункты [Сохранить] или [Закрыть], а в случае отсутствия дочерних окон - [Открыть] и [Новое].

Все описанные выше пункты вы должны ввести в меню дочерней формы, поскольку оно заменит существующий пункт [Файл].

Вы все еще можете использовать код родительской формы в дочерней.

Так, если у вас имеется процедура "parent.open1click", вы можете вызывать ее из меню [Файл] дочернего окна после его открытия.

©Drkb::00495.

Взято с http://delphiworld.narod.ru.

Позиция дочерних MDI-окон.

Автор: Richard Cox.

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

У меня была аналогичная проблема -- она проявлялась при условии, когда свойство главной формы WindowState устанавливалось на wsMinimized.

Вот мое решение: добавьте этот небольшой метод к вашей главной форме:

Code: Interface. Procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED; Implementation. Procedure TMainForm.CMShowingChanged(var Message: TMessage); Var. TheRect: TRect; Begin. Inherited; TheRect := GetClientRect; AlignControls(nil, theRect); End;

Это работает, поскольку вызов AlignControls (в TForm) делает две вещи:

Выравнивает элементы управления (включая ваш проблемный StatusBar) и.

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

©Drkb::00496.

Взято с http://delphiworld.narod.ru.

Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов?

Вариант 1. CoolBar.

Code: Procedure TMainForm.SetBands(AControls: array of TWinControl; ABreaks: array of boolean); Var. I: integer; Begin. With CoolBar do. Begin. For i:=0 to High(AControls) do. Begin. If Bands.Count=succ(i) then. TCoolBand.Create(Bands); With Bands[succ(i)] do. Begin. If Assigned(Control) then. Control.Hide; MinHeight:=AControls[i].Height; Break:=ABreaks[i]; Control:=AControls[i]; Control.Show; Visible:=true; End. End; For i:=High(AControls)+2 to pred(Bands.Count) do. Bands[i].Free. End. End;

И.

Code: Procedure TMsgForm.FormActivate(Sender: TObject); Begin. MainForm.SetBands([ToolBar],[false]). End;

Настройка монитора.

Иногда требуется, чтобы программа работала при чётко заданных параметрах монитора: разрешение, глубина цвета, частота обновления… Определить текущее разрешение просто, достаточно обратиться к объекту TScreen и посмотреть значения его полей Width и Height. А вот чтобы установить свои значения требуется обратиться к функции Api: ChangeDisplaySettings. Если мы хотим вернуть текущие настройки по завершении работы программы, то перед вызовом изменений надо запомнить эти настройки например таким образом:

Code: Uses ShellApi; Var. DefWidth, DefHeight, BPP: word; ... Procedure SaveSettings; Var. DC: hDC; Begin. DefWidth := Screen.Width; DefHeight := Screen.Height; DC := CreateDC('DISPLAY', nil, nil, nil); BPP := GetDeviceCaps(DC, BITSPIXEL); End;

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

Code: Procedure SetScreen(BPP:byte;width,height,FR:integer); Var. D: TDevMode; H: HWND; Begin. H:=0; D.dmDeviceName:='DISPLAY'; D.dmBitsPerPel:=BPP; D.dmDisplayFrequency:=FR; D.dmPelsWidth:=Width; D.dmPelsHeight:=Height; D.dmFields:=DM_BITSPERPEL+DM_PELSWIDTH+DM_PELSHEIGHT+DM_DISPLAYFREQUENCY; D.dmSize:=SizeOf(D); If ChangeDisplaySettings(D,CDS_TEST)=DISP_CHANGE_SUCCESSFUL then. ChangeDisplaySettings(D,CDS_UPDATEREGISTRY). Else. MessageBox(h,'This mode is not supported by your video.', 'Failed to change mode', MB_ICONWarning); End;

Вызывается так: SetScreen(глубина цвета, разрешение по горизонтали, разрешение по вертикали, частота в герцах); Например:

Code: SetScreen(16,800,600,80); {16 бит цвет, 800х600, 80Гц.}.

При завершении программы для восстановления старых параметров вызываем эту процедуру с сохраненными ранее значениями:

Code: SetScreen(BPP,DefWidth,DefHeight,80);

Я не стал здесь беспокоиться о сохранении/возвращении частоты обновления, а сразу установил 80Гц, но если кто желает, может сохранить и этот параметр при запуске.

Code: DefFR:=GetDeviceCaps(DC, VREFRESH);

И восстановить при закрытии программы:

Code: SetScreen(BPP,DefWidth,DefHeight,DefFR);

Пример применения этой возможности можно посмотреть в моей программе SDisplay, которая вешается в трей и позволяет быстро изменить параметры экрана.

©Drkb::01456.

Взято с http://delphiworld.narod.ru.

Придание MDI-формам большей трехмерности.

Code: Constructor TMainForm.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); SetWindowLong(ClientHandle, GWL_EXSTYLE, GetWindowLong(ClientHandle, GWL_EXSTYLE) or WS_EX_CLIENTEDGE); SetWindowPos(ClientHandle, 0, 0, 0, 0, 0, Swp_DrawFrame or swp_NoMove or swp_NoSize. Or swp_NoZOrder); End;

Перестроить вкладки TPageControl с помощью Drag and Drop.

Code: // In the PageControl's OnMouseDown event handler: Procedure TForm1.PageControl1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. PageControl1.BeginDrag(False); End; // In the PageControl's OnDragDrop event handler: Procedure TForm1.PageControl1DragDrop(Sender, Source: TObject; X, Y: Integer); Const. TCM_GETITEMRECT = $130A; Var. I: Integer; R: TRect; Begin. If not (Sender is TPageControl) then Exit; With PageControl1 do. Begin. For i := 0 to PageCount - 1 do. Begin. Perform(TCM_GETITEMRECT, i, lParam(@r)); If PtInRect(r, Point(X, Y)) then. Begin. If i <> ActivePage.PageIndex then. ActivePage.PageIndex := i; Exit; End; End; End; End; // In the PageControl's OnDragOver event handler: Procedure TForm1.PageControl1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Begin. If Sender is TPageControl then. Accept := True; End;

Негатив картинки.

Code: Var. Line: pByteArray; I, j: integer; Begin. // считываем высоту картинки. For i := 0 to Image1.Picture.Bitmap.Height - 1 do. Begin. //сканируем по линиям рисунок. Line := Image1.Picture.Bitmap.ScanLine[i]; For j := 0 to Image1.Picture.Bitmap.Width * 3 - 1 do. //меняем цвет на обратный исходя из RGB. Line^[j] := 255 - Line^[j]; End; Image1.Refresh; End;

Как сделать анимацию немерцающей.

Мерцание возникает, когда цвет точки меняется два раза подряд. Например, правильнее объект при его перемещении стирать и затем рисовать на новом месте не на экране, а в памяти, и выводить на форму уже готовое изображение поверх предыдущего. В таком случае смена цветов на экране происходит только один раз.

Code: Var. Bm: TBitMap; Procedure TForm1.FormCreate(Sender: TObject); Begin. Bm := TBitMap.Create; Bm.Width := Form1.ClientWidth; Bm.Height := Form1.ClientHeight; With bm.Canvas do. Begin. Font.name := 'Arial'; Font.Size := 50; Font.Color := clBlue; End; Timer1.Interval := 100; End; Procedure TForm1.Timer1Timer(Sender: TObject); Var. S: string; Hour, Min, Sec, MSec: Word; Begin. DecodeTime(Time, Hour, Min, Sec, MSec); With bm.Canvas do. Begin. Brush.Style := bsSolid; Brush.Color := clWhite; FillRect(ClipRect); S := TimeToStr(Time); TextOut((bm.Width - TextWidth(s)) div 2, (bm.Height - TextHeight(s)) div 2, s); Pen.Mode := pmMask; Pen.Width := 20; Pen.Color := clLime; Brush.Style := bsClear; Rectangle(bm.Width div 2 - (MSec * bm.Width) div 5000, Bm.Height div 2 - (MSec * bm.Height) div 5000, Bm.Width div 2 + (MSec * bm.Width) div 5000, Bm.Height div 2 + (MSec * bm.Height) div 5000); End; Form1.Canvas.Draw(0, 0, bm); End;

ODBC соединения.

...я обращал ваше внимание на трудности коннекта Delphi-приложений с Watcom. За исключением досадной проблемы с чуствительностью регистров у ODBC драйверов (которая пропадает после установки соответствующих заплаток), мое приложение действительно лучше соединяется с базой данных Watcom, чем LIBS. Вот функция, которую я использую для подключения к серверу:

Code: Function TLogonForm.LogonToServer: Boolean; Begin. LogonToServer := FALSE; MyDatabase.AliasName := DatabaseEdit.Text; MyDatabase.Params.Values['USER NAME'] := UserIDEdit.Text; MyDatabase.Params.Values['PASSWORD'] := PasswordEdit.Text; MyDatabase.Params.Values['SERVER NAME'] := ServerName; Try. MyDatabase.Connected := TRUE; LogonToServer := TRUE; Except. On E: EDatabaseError do. MessageDlg('Программа не в состоянии подключиться к. Серверу баз данных по следующей причине: ' + #10 + #10 + E.Message, mtError, [mbOK], 0); End; End;

Эта функция находится в модуле с формой диалога подключения, на которой расположены три поля редактирования: идентификатор пользователя, пароль и имя базы данных. При щелчке пользователем на кнопке OK, значение из поля с именем базы данных используется для поиска в файле ODBC.INI:

Code: ServerName := ODBCIni.ReadString(DatabaseEdit.Text, 'Database', '');

Этой строчкой мы получаем фактическое имя файла базы данных, к которому нам необходимо получить доступ ('SERVER NAME' - параметр соединения).

Во время разработки я выставил в своем компоненте TDatabase следующие параметры:

Connected: FALSE.

DatabaseName: DCAC {это псевдоним, используемый приложением}.

KeepConnection: TRUE.

LoginPrompt: FALSE.

Name: MyDatabase.

TransIsolation: tiReadCommitted.

AliasName, DriverName и Params в режиме проектирования остаются пусты, DriverName не используется совсем, т.к. во время выполнения приложения используется AliasName (они являются взаимоисключающими, вы можете установить что-то одно, но не оба сразу).

Вот секции Interbase и Watcom моего файла ODBC.INI:

[DCAC_IB].

Driver=C:\WIN\SYSTEM\BLINT04.DLL.

Description=DC Aquatics (Interbase).

Database=D:\DCAC_IB\DCAC.GDB.

[DCAC_WSQL].

Driver=D:\WSQL\wsqlodbc.dll.

Description=DC Aquatics (Watcom).

Database=D:\DCAC_WAT\DCAC.DB.

Start=D:\wsql\db32w %d.

Если мне необходимо подключиться к базе данных Watcom, все, что мне нужно сделать - изменить содержимое поля редактирования имени базы данных в диалоге подключения на 'DCAC_WSQL'. Если мне нужно использовать базу данных Interbase, я набираю 'DCAC_IB'. Работает замечательно.

Надеюсь это поможет... успехов...

©Drkb::02677.

Взято с http://delphiworld.narod.ru.

Установка ODBC.

Автор: Johannes M. Becher (CODATA GmbH Krefeld, Germany).

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

A) ODBCINST.INI - описание всех установленных драйверов ODBC.

Секция [ODBC Drivers] в каждой строчке описывает один драйвер. Здесь прописано формальное имя драйвера, использующегося позже для идентификации драйвера.

Каждый драйвер, как вы увидите позже, имеет собственную секцию, к примеру, вот секция для Watcom :

{1} [Watcom SQL 4.0].

{2} Driver=D:\WIN31\SYSTEM\WOD40W.DLL.

{3} Setup=D:\WIN31\SYSTEM\WOD40W.DLL.

Строка 1 содержит имя секции драйвера из [ODBC Drivers].

Строка 2 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для доступа к базам данных Watcom.

Строка 3 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для административных целей.

Все, что имеется в файле ODBCINST.INI - теперь содержится в файле #2 (таком же легком для изучения):

B) ODBC.INI - описание всех ваших баз данных (источников данных, говоря языком ODBC).

Секция [ODBC Data Sources] в каждой строчке описывает одну базу данных; формат:

{описание базы данных} = {описание драйвера из ODBCINST.INI}.

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

Каждая база данных, как вы увидите позже, имеет собственную секцию, к примеру, вот секция PB Demo:

{1} [Powersoft Demo DB=Watcom SQL 4.0].

{2} DatabaseFile=E:\PB4\EXAMPLES\PSDEMO.DB.

{3} DatabaseName=PSDEMODB.

{4} UID=dba.

{5} PWD=sql.

{6} Driver=D:\WIN31\SYSTEM\WOD40W.DLL.

{7} Start=D:\WSQL40\DBSTARTW -d -c512.

Строка 1 содержит ссылку на секцию [ODBC Data Sources].

Строка 2 содержит физический путь к файлу базы данных.

Строка 3 - описание, только для вашего чтения.

Строка 4 - User ID, которое Watcom применяет для установления связи.

Строка 5 - Пароль, используемый для установления соединения.

- Это не очень секретно; если вы оставите эту строку пустой, Watcom сам спросит пароль при получении доступа к базе данных.

Строка 6 содержит имя драйвера (снова - сравните с OBDCINST.INI).

Строка 7 содержит имя движка базы данных для ее запуска (это необходимо лишь для баз данных SQL, например, в версии Client / Server).

Все это может быть отредактировано как вручную (в любом текстовом редакторе), так и в ODBCADM (ODBC Administration). Что касается меня лично, то я более не использую ODBCADM; я ощущаю себя гораздо лучше, если имею больший контроль над INI-файлами, редактируя строки вручную.

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

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

©Drkb::02678.

Взято с http://delphiworld.narod.ru.

Конфигурирование ODBC.

Автор: Mark Nelson (Delphi Tech Support).

Представляю вашему вниманию инструкцию по конфигурированию ODBC и источника данных.

Для того, чтобы Borland Database Engine мог пользоваться драйверами ODBC, они должны быть сконфигурированы следующим образом:

Инсталлируйте драйвер и установите его в Панель Управления/ОDВС administrator.

Если это файл базового драйвера типа dBase, Paradox, Excel, FoxPro и др., то вы должны указать каталог, содержащий ваши файлы.

Access и Local Btrieve файлы должны указывать на конкретный файл базы данных (Btreive на File.ddf, Access должен указывать на файл с расширением .MDB).

Если это линк (connection) к базе данных, например Oracle, Sybase, Interbase, и др., вы должны указать на этот линк. Обычно транспорт посредством TCPIP, SPX/IPX, NetBEUI и т.п. предусматривается поставщиком программного обеспечения. Каждый драйвер работает с транспортным протоколом по-своему.

Запустите Database Engine Configuration Utility. (BDECFG.EXE).

Выберите New ODBC Driver.

Задайте имя вашему драйверу (к имени автоматически добавится "ODBC_".).

Выберите ваш ODBC Driver из списка Default ODBC Driver List.

Выберите имя источника данных по умолчанию.

Создайте псевдоним (alias), указывающий на установленный вами драйвер.

Установите ссылку с именем псевдонима на ваш драйвер.

Примечание относительно баз данных Access 2.0: вам необходимо иметь самые последние драйверы от Microsoft. Имеющиеся драйверы позволяют работать только с базами данных Access 1.0, не выше.

Стоимость нового набора драйверов у самой Microsoft составляет $10, что эквивалентно цене носителя и пересылки.

Для работы с Access 2.0 вам необходимо использовать источник данных с именем "Microsoft Access Driver" или "Microsoft Access 2.0 Databases".

Имейте в виду, что "Access Data" и "Access Files" по умолчанию являются источниками данных только для Access 1.0. Поэтому для получения доступа к MDB-файлам Access 1.0 пользуйтесь "Access Data".

Btrieve также создает источник данных по умолчанию "Btrieve Data" и "Btrieve Files". Используйте "Btrieve Data" как ваш источник данных по умолчанию. Драйверы Btrieve позволяют использовать данные btrieve вплоть до версии 5.0. Для работы с Btrive данными более новой версии, необходим новый набор драйверов Microsoft или Intersolve Q+E.

©Drkb::02679.

Взято с http://delphiworld.narod.ru.

Позиция курсора в TRichEdit.

Так как вопрос давольно часто поднимается в форумах, то хотелось бы привести ответ на него. Итак, как же получить текущие координаты курсора (Row и Col) в TRichEdit ?

Вот пример решения данной проблемы:

Code: Procedure TForm1.GetPosition(Sender: TRichEdit); Var. IX,iY : Integer; TheRichEdit : TRichEdit; Begin. IX := 0; iY := 0; TheRichEdit := TRichEdit(Sender); IY := SendMessage(TheRichEdit.Handle, EM_LINEFROMCHAR, TheRichEdit.SelStart, 0); IX := TheRichEdit.SelStart - SendMessage(TheRichEdit.Handle, EM_LINEINDEX, IY, 0); Panel1.Caption := IntToStr(iY + 1) + ':' + IntToStr(iX + 1) ; End; Procedure TForm1.RichEditMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. GetPosition(RichEdit); End; Procedure TForm1.RichEditKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. GetPosition(RichEdit); End;

Конфигурирование ODBC и псевдонима.

Настройка ODBC в Панели Управления.

При инсталляции, Delphi устанавливает в Панель Управления апплет "ODBC" (далее - "настройка ODBC"). "Настройка ODBC" содержит доступные источники данных (драйвера), установленных для использования ODBC. Как вы можете видеть на главной странице "Data Sources", ODBC содержит внушительный набор форматов, которые могут использоваться в Delphi. Дополнительные форматы поддерживаются установленными драйверами и могут быть добавлены с помощью кнопки "Add...".

Для добавления нового или удаления существующего драйвера:

В окне "Data Sources" нажмите кнопку "Drivers...". В появившемся диалоговом окне "Drivers" нажмите кнопку "Add..." и укажите путь к новому драйверу ODBC.

Возвратитесь в окно "Data Sources" и добавьте доступные с новым драйвером источники данных с помощью кнопки "Add...".

Для настройки конкретного источника данных используйте кнопку "Setup...". Функция кнопки "Setup..." меняется с каждым форматом данных. Частенько настройки типа рабочей директории для драйвера настраиваются как раз в этом месте.

Разделы электронной справки доступны для каждой страницы и диалогового окна "Настроки ODBC".

BDE CONFIGURATION UTILITY.

После установки драйвера ODBC, запустите BDE Configuration utility для конфигурации BDE для работы с новым драйвером.

На странице драйверов нажмите на кнопку "New ODBC driver".

Появится диалог с заголовком "Add ODBC driver". Опция "SQL link driver" позволяет выяснить, с какими типами баз данных можно работать с помощью данного драйвера ODBC.

Затем выбирайте default ODBC driver (драйвер ODBC по-умолчанию). Выпадающий список содержит список типов файлов, поддерживаемых установленными в системе драйверами ODBC.

Выберите для ODBC-драйвера источник данных по-умолчанию (default data source). Имея уже установленный на шаге 3 драйвер ODBC, список этого соmbоbох'а будет содержать имена источников данных, подходящих для использования с выбранным драйвером.

Нажмите Ok.

Возвратитесь на страницу драйверов, выберите File/Save из главного меню и сохраните данную конфигурацию.

Создание псевдонима в DATABASE DESKTOP.

Хотя создать псевдоним ODBC можно и из BDE Configuration utility, Database Desktop предоставляет более комфортное решение.

В меню "File" выберите пункт "Aliases..".

В появившемся диалоге "Alias Manager" нажмите кнопку "New".

Введите имя вашего нового псевдонима в поле редактирования, помеченной как "Database Alias".

Используя выпадающий список "Driver Type" (типы драйверов), выберите драйвер, подходящий для данного псевдонима. Таблицы Paradox и dBase считаются STANDARD. Если в BDE Configuration utility драйвер ODBC был правильно сконфигурирован, то его имя появится в списке.

Дополнительные опции опции могут появляться в зависимости от выбранного типа драйвера.

После завершения всех описанных действий сохраните новый псевдоним, выбрав "Keep New". Затем нажмите "Ok". Появится подсказка, спрашивающая о необходимости сохранения псевдонима в IDAPI.CFG. Выберите "Ok".

Теперь псевдоним будет работать и в Database Desktop, и в Delphi.

©Drkb::02680.

Взято с http://delphiworld.narod.ru.

Получение переменных среды.

Code: Procedure GetEnvironmentStrings(ss: TStrings); {Переменные среды}. Var. Ptr: PChar; S: string; Done: boolean; Begin. Ss.Clear; S := ''; Done := FALSE; Ptr := windows.GetEnvironmentStrings; While Done = false do begin. If ptr^ = #0 then begin. Inc(ptr); If ptr^ = #0 then Done := TRUE. Else ss.Add(s); S := ptr^; End else s := s + ptr^; Inc(ptr); End; End;

Как, зная Handle окна программы, определить имя EXE?

Code: Function ExeNameByHandle(aWinHandle:HWND):string; {исправлено для ©Drkb v.3(2007): www.drkb.ru}. // Для начала определяешь какому процессу принадлежит окно: Var pProcID: ^DWORD; Begin. GetMem(pProcID, SizeOf(DWORD)); GetWindowThreadProcessId(aWinHandle, pProcID); Result:=GetExeNameByProcID(pProcID^); FreeMem(pProcID); End; // а после этого используешь TProcessEntry32 примерно так: Function GetExeNameByProcID(ProcID: DWord): string; Var. ContinueLoop: BOOL; FSnapshotHandle: THandle; FProcessEntry32: TProcessEntry32; Begin. FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); FProcessEntry32.dwSize := Sizeof(FProcessEntry32); ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); Result := ''; While (Integer(ContinueLoop) <> 0) and (Result = '') do. Begin. If FProcessEntry32.th32ProcessID = ProcID then. Result := FProcessEntry32.szExeFile; ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32); End; CloseHandle(FSnapshotHandle); End; // Не забудь в uses добавить Tlhelp32.

Ускорение работы TreeView.

Представляем вашему вниманию немного переработанный компонент TreeView, работающий быстрее своего собрата из стандартной поставки Delphi. Кроме того, была добавлена возможность вывода текста узлов и пунктов в жирном начертании (были использованы методы TreeView, хотя, по идее, необходимы были свойства TreeNode. Мне показалось, что это будет удобнее).

Для сравнения:

TreeView:

128 сек. для загрузки 1000 элементов (без сортировки)*

270 сек. для сохранения 1000 элементов (4.5 минуты!!!).

HETreeView:

1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!! (2.3 секунды без сортировки = stText)*

0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!!

Примечание:

Все операции выполнялись на медленной машине 486SX 33 Мгц, 20 Мб RAM.

Если TreeView пуст, загрузка происходит за 1.5 секунды, плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды). В этих условиях стандартный компонент TTreeView показал общее время 129.5 секунд. Очистка компонента осуществлялась вызовом функции SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).

Проведите несколько приятных минут, развлекаясь с компонентом.

Code: Unit HETreeView; {$R-}. // Описание: Реактивный TreeView. (* TREEVIEW: 128 сек. для загрузки 1000 элементов (без сортировки)* 270 сек. для сохранения 1000 элементов (4.5 минуты!!!). HETREEVIEW: 1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!! (2.3 секунды без сортировки = stText)* 0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!! NOTES: - Все операции выполнялись на медленной машине 486SX 33 Мгц, 20 Мб RAM. - * Если TTreeView пуст, загрузка происходит за 1.5 секунды, Плюс 1.5 секунды на стирание 1000 элементов. (общее время загрузки составило 3 секунды). В этих условиях стандартный компонент TreeView показал общее время 129.5 секунд. Очистка компонента осуществлялась вызовом функции. SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)). *) Interface. Uses. SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, CommCtrl; Type. THETreeView = class(TTreeView). Private. FSortType: TSortType; Procedure SetSortType(Value: TSortType); Protected. Function GetItemText(ANode: TTreeNode): string; Public. Constructor Create(AOwner: TComponent); override; Function AlphaSort: Boolean; Function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean; Procedure LoadFromFile(const AFileName: string); Procedure SaveToFile(const AFileName: string); Procedure GetItemList(AList: TStrings); Procedure SetItemList(AList: TStrings); //Жирное начертание шрифта 'Bold' должно быть свойством TTreeNode, но... Function IsItemBold(ANode: TTreeNode): Boolean; Procedure SetItemBold(ANode: TTreeNode; Value: Boolean); Published. Property SortType: TSortType read FSortType write SetSortType default. StNone; End; Procedure Register; Implementation. Function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer; Stdcall; Begin. {with Node1 do. If Assigned(TreeView.OnCompare) then. TreeView.OnCompare(Node1.TreeView, Node1, Node2, lParam, Result). Else}. Result := lstrcmp(PChar(Node1.Text), PChar(Node2.Text)); End; Constructor THETreeView.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); FSortType := stNone; End; Procedure THETreeView.SetItemBold(ANode: TTreeNode; Value: Boolean); Var. Item: TTVItem; Template: Integer; Begin. If ANode = nil then. Exit; If Value then. Template := -1. Else. Template := 0; With Item do. Begin. Mask := TVIF_STATE; HItem := ANode.ItemId; StateMask := TVIS_BOLD; State := stateMask and Template; End; TreeView_SetItem(Handle, Item); End; Function THETreeView.IsItemBold(ANode: TTreeNode): Boolean; Var. Item: TTVItem; Begin. Result := False; If ANode = nil then. Exit; With Item do. Begin. Mask := TVIF_STATE; HItem := ANode.ItemId; If TreeView_GetItem(Handle, Item) then. Result := (state and TVIS_BOLD) <> 0; End; End; Procedure THETreeView.SetSortType(Value: TSortType); Begin. If SortType <> Value then. Begin. FSortType := Value; If ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or. (SortType in [stText, stBoth]) then. AlphaSort; End; End; Procedure THETreeView.LoadFromFile(const AFileName: string); Var. AList: TStringList; Begin. AList := TStringList.Create; Items.BeginUpdate; Try. AList.LoadFromFile(AFileName); SetItemList(AList); Finally. Items.EndUpdate; AList.Free; End; End; Procedure THETreeView.SaveToFile(const AFileName: string); Var. AList: TStringList; Begin. AList := TStringList.Create; Try. GetItemList(AList); AList.SaveToFile(AFileName); Finally. AList.Free; End; End; Procedure THETreeView.SetItemList(AList: TStrings); Var. ALevel, AOldLevel, i, Cnt: Integer; S: string; ANewStr: string; AParentNode: TTreeNode; TmpSort: TSortType; Function GetBufStart(Buffer: PChar; var ALevel: Integer): PChar; Begin. ALevel := 0; While Buffer^ in [' ', #9] do. Begin. Inc(Buffer); Inc(ALevel); End; Result := Buffer; End; Begin. // Удаление всех элементов - в обычной ситуации. // подошло бы Items.Clear, но уж очень медленно. SendMessage(handle, TVM_DELETEITEM, 0, Longint(TVI_ROOT)); AOldLevel := 0; AParentNode := nil; //Снятие флага сортировки. TmpSort := SortType; SortType := stNone; Try. For Cnt := 0 to AList.Count - 1 do. Begin. S := AList[Cnt]; If (Length(S) = 1) and (S[1] = Chr($1A)) then. Break; ANewStr := GetBufStart(PChar(S), ALevel); If (ALevel > AOldLevel) or (AParentNode = nil) then. Begin. If ALevel - AOldLevel > 1 then. Raise Exception.Create('Неверный уровень TreeNode'); End. Else. Begin. For i := AOldLevel downto ALevel do. Begin. AParentNode := AParentNode.Parent; If (AParentNode = nil) and (i - ALevel > 0) then. Raise Exception.Create('Неверный уровень TreeNode'); End; End; AParentNode := Items.AddChild(AParentNode, ANewStr); AOldLevel := ALevel; End; Finally. //Возвращаем исходный флаг сортировки... SortType := TmpSort; End; End; Procedure THETreeView.GetItemList(AList: TStrings); Var. I, Cnt: integer; ANode: TTreeNode; Begin. AList.Clear; Cnt := Items.Count - 1; ANode := Items.GetFirstNode; For i := 0 to Cnt do. Begin. AList.Add(GetItemText(ANode)); ANode := ANode.GetNext; End; End; Function THETreeView.GetItemText(ANode: TTreeNode): string; Begin. Result := StringOfChar(' ', ANode.Level) + ANode.Text; End; Function THETreeView.AlphaSort: Boolean; Var. I: Integer; Begin. If HandleAllocated then. Begin. Result := CustomSort(nil, 0); End. Else. Result := False; End; Function THETreeView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean; Var. SortCB: TTVSortCB; I: Integer; Node: TTreeNode; Begin. Result := False; If HandleAllocated then. Begin. With SortCB do. Begin. If not Assigned(SortProc) then. LpfnCompare := @DefaultTreeViewSort. Else. LpfnCompare := SortProc; HParent := TVI_ROOT; LParam := Data; Result := TreeView_SortChildrenCB(Handle, SortCB, 0); End; If Items.Count > 0 then. Begin. Node := Items.GetFirstNode; While Node <> nil do. Begin. If Node.HasChildren then. Node.CustomSort(SortProc, Data); Node := Node.GetNext; End; End; End; End; //Регистрация компонента. Procedure Register; Begin. RegisterComponents('Win95', [THETreeView]); End; End.

Управление игрой FreeCell.

Если вы решили перепробовать ВСЕ номера игры FreeCell, вас можно квалифицировать как законченного маньяка. В этом случае вас, возможно, заинтересует эта маленькая программка. При ее запуске она загружает FreeCell и начинает игру, следующую за той, которую вы не смогли завершить в прошлый раз. А еще она отвечает на глупые вопросы типа "Do you really want to resign the game?". После выигрыша программа изменяет счетчик таким образом, чтобы при очередном запуске номер игры изменялся на следующий автоматически.

Для создания программы расположите на новой форме таймер, установите ее свойство WindowState на wsMinimized и используйте следующий код:

Code: ... Private. { Private declarations }. InstHandle: Word; WndHandle: hWnd; NextGame: Word; Function EnumFunc(H: HWnd): Word; Procedure WMQUERYOPEN(var Msg: TWMQueryOpen); message WM_QUERYOPEN; ... Interface. USES. ShellApi, IniFiles; Const GWW_HINSTANCE = -6; {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Var. H, SubH: hMenu; NewGameID: Word; FreeCellPath: string; Begin. With TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do. Try. FreeCellPath := ReadString('FreeCell', 'Path', 'C:\WIN32APP\FREECELL\FREECELL.EXE') + #0; NextGame := ReadInteger('FreeCell', 'NextGame', 1); Finally. Free; End; InstHandle := ShellExecute(Handle, nil, @FreeCellPath[1], Nil, nil, SW_SHOW); WndHandle := 0; If InstHandle >= 32 then. EnumWindows(@TForm1.EnumFunc, LongInt(Self)); If WndHandle <> 0 then. Begin. {Вычисляем ID пункта меню "Select Game"}. H := GetMenu(WndHandle); SubH := GetSubMenu(H, 0); NewGameID := GetMenuItemID(SubH, 1); Winprocs.SetFocus(WndHandle); {вызываем "Select Game"}. PostMessage(WndHandle, WM_COMMAND, NewGameID, 0); Timer1.Enabled := True; End. Else. Close; End; Procedure TForm1.WMQUERYOPEN(var Msg: TWMQueryOpen); Begin. Msg.Result := 0; End; Function TForm1.EnumFunc(H: HWnd): Word; Begin. If GetWindowWord(H, GWW_HINSTANCE) = InstHandle then. Begin. WndHandle := H; Result := 0; End. Else. Result := 1; End; Procedure TForm1.Timer1Timer(Sender: TObject); Var. Buffer: array[0..10] of Char; DlgHandle: Word; Begin. {Если пользователь закрыл FreeCell, выходим!}. If GetModuleUsage(InstHandle) = 0 then. Begin. Close; Exit; End; {При необходимости укажите номер игры}. DlgHandle := FindWindow('#32770', 'Game Number'); If DlgHandle <> 0 then. Begin. Str(NextGame, Buffer); SendDlgItemMessage(DlgHandle, $CB, WM_SETTEXT, 0, LongInt(@Buffer)); PostMessage(DlgHandle, WM_COMMAND, 1, MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED)); End; {Если игра окончена, увеличиваем счетчик}. DlgHandle := FindWindow('#32770', 'Game Over'); If DlgHandle <> 0 then. Begin. Inc(NextGame); With TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do. Try. WriteInteger('FreeCell', 'NextGame', NextGame); Finally Free; End; PostMessage(DlgHandle, WM_COMMAND, 6, MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED)); End; {Если игра спрашивает, хотите ли вы выйти, отвечем соответственно yes или OK}. DlgHandle := FindWindow('#32770', 'FreeCell'); If DlgHandle <> 0 then. Begin. If (not (GetDlgItemText(DlgHandle, 6, Buffer, 10) in [0, 10])). And (StrComp(Buffer, '&Yes') = 0) then. PostMessage(DlgHandle, WM_COMMAND, 6, MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED)). Else if (not (GetDlgItemText(DlgHandle, 2, Buffer, 10) in [0, 10])). And (StrComp(Buffer, 'Cancel') = 0) then. PostMessage(DlgHandle, WM_COMMAND, 1, MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED)). End; End;

Установка каретки в RichEdit.

Узнать положение курсора в RichEdit не составляет труда (richedit.getcaret). А вот как установить каретку в нужное место?

Code: Procedure setline(WhichEdit:TRichedit;Linepos,charpos:integer); Begin. With WhichEdit do. Begin. Selstart:=perform(EM_LineIndex,Linenum,0)+charpos; Perform(EM_ScrollCaret,0,0); End; End;

Использование открытых интерфейсов.

Одной и наиболее сильных сторон среды программирования Delphi является ее открытая архитектура, благодаря которой Delphi допускает своего рода метапрограммирование, позволяя "программировать среду программирования". Такой подход переводит Delphi на качественно новый уровень систем разработки приложений и позволяет встраивать в этот продукт дополнительные инструментальные средства, поддерживающие практически все этапы создания прикладных систем. Столь широкий спектр возможностей открывается благодаря реализованной в Delphi концепции так называемых открытых интерфейсов, являющихся связующим звеном между IDE (Integrated Development Environment) и внешними инструментами. Данная статья посвящена открытым интерфейсам Delphi и представляет собой обзор представляемых ими возможностей.

В Delphi определены шесть открытых интерфейсов: Tool Interface, Design Interface, Expert Interface, File Interface, Edit Interface и Version Control Interface. Вряд ли в рамках данной статьи нам удалось бы детально осветить и проиллюстрировать возможности каждого из них. Более основательно разобраться в рассматриваемых вопросах вам помогут исходные тексты Delphi, благо разработчики снабдили их развернутыми комментариями. Объявления классов, представляющих открытые интерфейсы, содержатся в соответствующих модулях в каталоге ...\Delphi\Source\ToolsAPI.

Design Interface (модуль DsgnIntf.pas).

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

Version Control Interface (модуль VCSIntf.pas).

Предназначен для создания систем контроля версий. Начиная с версии 2.0, Delphi поддерживает интегрированную систему контроля версий Intersolv PVCS, поэтому в большинстве случаев в разработке собственной системы нет необходимости. По этой причине рассмотрение Version Control Interface мы также опустим.

File Interface (модуль FileIntf.pas).

Позволяет переопределить рабочую файловую систему IDE, что дает возможность выбора собственного способа хранения файлов (в Memo-полях на сервере БД, например).

Edit Interface (модуль EditIntf.pas).

Предоставляет доступ к буферу исходных текстов, что позволяет проводить анализ кода и выполнять его генерацию, определять и изменять позицию курсора в окне редактора кода, а также управлять синтаксическим выделением исходного текста. Специальные классы предоставляют интерфейсы к помещенным на форму компонентам (определение типа компонента, получение ссылок на родительский и дочерние компоненты, доступ к свойствам, передача фокуса, удаление и т.д.), к самой форме и к ресурсному файлу проекта. Также Edit Interface позволяет идентифицировать так называемые модульные нотификаторы, определяющие реакцию на такие события, как изменение исходного текста модуля, модификация формы, переименование компонента, сохранение, переименование или удаление модуля, изменение ресурсного файла проекта и т. д.

Tool Interface (модуль ToolIntf.pas).

Предоставляет разработчикам средства для получения общей информации о состоянии IDE и выполнения таких действий, как открытие, сохранение и закрытие проектов и отдельных файлов, создание модуля, получение информации о текущем проекте (число модулей и форм, их имена и т. д.), регистрация файловой системы, организация интерфейсов к отдельным модулям и т.д. В дополнение к модульным нотификаторам Tool Interface определяет add-in нотификаторы, уведомляющие о таких событиях, как открытие/закрытие файлов и проектов, загрузка и сохранение desktop-файла проекта, добавление/исключение модулей проекта, инсталляция/деинсталляция пакетов, компиляция проекта, причем в отличие от модульных нотификаторов add-in нотификаторы позволяют отменить выполнение некоторых событий. Кроме того, Tool Interface предоставляет средства доступа к главному меню IDE Delphi, позволяя встраивать в него дополнительные пункты.

Expert Interface (модуль ExptIntf.pas).

Представляет собой основу для создания экспертов — программных модулей, встраиваемых в IDE c целью расширения ее функциональности. В качестве примера эксперта можно привести входящий в Delphi Database Form Wizard, выполняющий генерацию формы для просмотра и изменения содержимого таблицы БД.

Эксперты бывают нескольких типов (стилей):

Стиль Описание.

EsStandard Для каждого эксперта такого стиля IDE добавляет пункт меню Tools/..., при выборе которого эксперт активизируется (IDE вызывает его метод Execute).

EsForm.

EsProject IDE рассматривает эксперты данного стиля как шаблоны форм/проектов и помещает активизирующие их изображения в галерею Object Repository.

EsAddIn Эксперты подобного стиля обеспечивают собственный интерфейс с IDE.

Класс каждого эксперта является потомком базового класса TIExpert, содержащего серию абстрактных методов, которые необходимо перекрыть в порождаемом классе:

Метод Описание.

GetName Должен возвращать имя эксперта.

GetAuthor Должен возвращать имя автора эксперта. Это имя отображается в Object Repository.

GetComment Должен возвращать комментарий (1-2 предложения), поясняющий назначение эксперта. Используется в Object Repository.

GetPage Должен возвращать название страницы Object Repository, на которую IDE поместит соответствующее эксперту изображение.

GetGlyph Должен возвращать дескриптор (HICON, в Delphi 1.0 – HBITMAP) соответствующего эксперту изображения в ObjectRepository.

GetStyle Должен возвращать константу, соответствующую стилю эксперта (esStandard/esForm/esProject/esAddIn).

GetState Если возвращаемое множество содержит константу esChecked, IDE пометит соответствующий эксперту пункт меню "галочкой", а если множество содержит константу esEnabled, то IDE сделает этот пункт меню доступным для выбора.

GetIDString Должен возвращать строку – идентификатор эксперта, уникальную среди всех установленных экспертов. По соглашению, формат этой строки таков:

Имя_Компании.Назначение_эксперта,

Например: Borland.WidgetExpert.

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

Execute Вызывается при вызове эксперта через меню или Object Repository (в зависимости от стиля).

Набор методов, подлежащих перекрытию, зависит от стиля эксперта:

Метод esStandard esForm esProject esAddIn.

GetName + + + +

GetAuthor + +

GetComment + +

GetPage + +

GetGlyph + +

GetStyle + + + +

GetState +

GetIDString + + + +

GetMenuText +

Execute + + +

Определив класс эксперта, необходимо позаботиться о том, чтобы Delphi "узнала" о нашем эксперте. Для этого его нужно зарегистрировать посредством вызова процедуры RegisterLibraryExpert, передав ей в качестве параметра экземпляр класса эксперта.

В качестве иллюстрации создадим простой эксперт в стиле esStandard, который при выборе соответствующего ему пункта меню Delphi выводит сообщение о том, что он запущен. Как видно из вышеприведенной таблицы, стиль esStandard обязывает перекрыть шесть методов:

Code: Unit exmpl_01; { STANDARD EXPERT }. Interface. Uses. Dialogs, ExptIntf; Type. { класс эксперта является потомком базового класса TIExpert }. TEMyExpert = class( TIExpert). Function GetName: string; override; Function GetStyle: TExpertStyle; override; Function GetIDString: string; override; Function GetMenuText: string; override; Function GetState: TExpertState; override; Procedure Execute; override; End; Procedure register; Implementation. { возвращаем имя эксперта }. Function TEMyExpert.GetName: string; Begin. Result := 'My Simple Expert 1'; End; { возвращаем стиль эксперта }. Function TEMyExpert.GetStyle: TExpertStyle; Begin. Result := esStandard; End; { возвращаем строку - идентификатор эксперта }. Function TEMyExpert.GetIDString: string; Begin. Result := 'Doomy.SimpleAddInExpert_1'; End; { возвращаем текст пункта меню }. Function TEMyExpert.GetMenuText: string; Begin. Result := 'Simple Expert 1'; End; { возвращаем множество, характеризующее состояние пункта меню эксперта }. { (доступность, наличие "галочки"); в данном случае пункт меню доступен, }. { а "галочка" отсутствует }. Function TEMyExpert.GetState: TExpertState; Begin. Result := [esEnabled]; End; { при выборе пункта меню эксперта отображаем сообщение }. Procedure TEMyExpert.Execute; Begin. MessageDlg('Standard Expert Started!', mtInformation, [mbOK], 0); End; { регистрируем эксперт }. Procedure register; Begin. RegisterLibraryExpert( TEMyExpert.Create); End; End.

Для того чтобы эксперт был "приведен в действие", необходимо выбрать пункт меню Component/Install Component ... , выбрать в диалоге Browse модуль, содержащий эксперт (в нашем случае exmpl_01.pas), нажать ОК, и после компиляции пакета dclusr30.dpk в главном меню Delphi в разделе Help должен появиться пункт Simple Expert 1, при выборе которого появляется информационное сообщение "Standard Expert started!".

Почему Delphi помещает пункт меню эксперта в раздел Help, остается загадкой. Если вам не нравится то, что пункт меню появляется там, где угодно Delphi, а не там, где хотите вы, возможен следующий вариант: создать эксперт в стиле add-in, что исключает автоматическое создание пункта меню, а пункт меню добавить "вручную", используя средства Tool Interface. Это позволит задать местоположение нового пункта в главном меню произвольным образом. Для добавления пункта меню используется класс TIToolServices — основа Tool Interface — и классы TIMainMenuIntf, TIMenuItemIntf, реализующие интерфейсы к главному меню IDE и его пунктам. Экземпляр ToolServices класса TIToolServices создается самой IDE при ее инициализации. Обратите внимание на то, что ответственность за освобождение интерфейсов к главному меню Delphi и его пунктам целиком ложится на разработчика. Попутно немного усложним функциональную нагрузку эксперта: при активизации своего пункта меню он будет выдавать справку об имени проекта, открытого в данный момент в среде:

Code: Unit exmpl_02; { ADD-IN EXPERT, ДОБАВЛЕНИЕ ПУНКТА В ГЛАВНОЕ МЕНЮ IDE DELPHI }. Interface. Uses. Classes, Dialogs, ToolIntF, ExptIntf, Menus; Type. { класс эксперта является потомком базового класса TIExpert }. TEMyExpert = class( TIExpert). Private. MenuItem: TIMenuItemIntf; Public. Constructor Create; Destructor Destroy; override; Function GetName: string; override; Function GetStyle: TExpertStyle; override; Function GetIDString: string; override; Procedure MenuItemClick( Sender: TIMenuItemIntf); End; Procedure register; Function AddIDEMenuItem( const Caption, name, PreviousItemName: string; Const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf; Implementation. { добавляем пункт в главное меню IDE Delphi: }. { 1) текст вставляемого пункта меню - 'Simple Expert 2'; }. { 2) идентификатор вставляемого пункта меню - 'ViewMyExpertItem2'; }. { 3) идентификатор пункта меню, перед которым добавляется новый }. { пункт меню - 'ViewWatchItem' (для Delphi 5 - 'ViewWatchesItem');}. { 4) горячая клавиша вставляемого пункта - 'Ctrl + 2'; }. { 5) обработчик события, соответствующего выбору вставляемого пункта }. { меню - MenuItemClick }. Constructor TEMyExpert.Create; Begin. Inherited Create; MenuItem:= AddIDEMenuItem( 'Simple Expert 2', 'ViewMyExpertItem2', {$IFDEF VER130}. 'ViewWatchesItem', '2', MenuItemClick); {$ELSE}. 'ViewWatchItem', '2', MenuItemClick); {$ENDIF}. End; Destructor TEMyExpert.Destroy; Begin. If Assigned( MenuItem) then. MenuItem.Free; Inherited Destroy; End; { при выборе пункта меню эксперта отображаем сообщение, содержащее }. { имя активного проекта }. Procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf); Begin. MessageDlg( 'Current project name is ' + ToolServices.GetProjectName, MtInformation, [mbOK], 0); End; { возвращаем имя эксперта }. Function TEMyExpert.GetName: string; Begin. Result := 'My Simple Expert 2'; End; { возвращаем стиль эксперта }. Function TEMyExpert.GetStyle: TExpertStyle; Begin. Result := esAddIn; End; { возвращаем строку - идентификатор эксперта }. Function TEMyExpert.GetIDString: string; Begin. Result := 'Doomy.SimpleAddInExpert_2'; End; Function AddIDEMenuItem( const Caption, name, PreviousItemName: string; Const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf; Var. MainMenu: TIMainMenuIntf; MenuItems, PreviousItem, ParentItem: TIMenuItemIntf; Begin. Result:= nil; { получаем интерфейс пунктов главного меню IDE }. MainMenu:= ToolServices.GetMainMenu; If Assigned( MainMenu) then. Try. { получаем интерфейс пунктов верхнего уровня меню }. MenuItems:= MainMenu.GetMenuItems; If Assigned( MenuItems) then. Try. { ищем пункт меню перед которым необходимо вставить новый пункт }. PreviousItem:= MainMenu.FindMenuItem( PreviousItemName); If Assigned( PreviousItem) then. Try. { получаем интерфейс к родительскому пункту меню }. ParentItem:= PreviousItem.GetParent; If Assigned( ParentItem) then. Try. { вставляем новый пункт меню и в качестве результата функции }. { возвращаем его интерфейс }. Result:= ParentItem.InsertItem( PreviousItem.GetIndex, Caption, Name, '', ShortCut( Word( ShortCutKey), [ssCtrl]), 0, 0, [mfVisible, mfEnabled], OnClick); Finally. { освобождаем интерфейс родительского пункта меню }. ParentItem.Free; End; Finally. { освобождаем интерфейс пункта меню перед которым вставили }. { новый пункт }. PreviousItem.Free; End; Finally. { освобождаем интерфейс пунктов верхнего уровня меню }. MenuItems.Free; End; Finally. { освобождаем интерфейс главного меню IDE }. MainMenu.Free; End; End; Procedure register; Begin. { регистрируем эксперт }. RegisterLibraryExpert( TEMyExpert.Create); End; End.

В этом примере центральное место занимает функция AddIDEMenuItem, осуществляющая добавление пункта меню в главное меню IDE Delphi. В качестве параметров ей передаются текст нового пункта меню, его идентификатор, идентификатор пункта, перед которым вставляется новый пункт, символьное представление клавиши, которая вместе с клавишей Ctrl может использоваться для быстрого доступа к новому пункту, и обработчик события, соответствующего выбору нового пункта. Мы добавили новый пункт меню в раздел View перед пунктом Watches.

Теперь познакомимся с нотификаторами. Определим add-in нотификатор, отслеживающий моменты закрытия/открытия проектов и корректирующий соответствующим образом поле, хранящее имя активного проекта (реализацию методов, не претерпевших изменений по сравнению с предыдущим примером, для краткости опустим):

Code: Unit exmpl_03; { ИСПОЛЬЗОВАНИЕ ADD-IN НОТИФИКАТОРОВ }. Interface. Uses. Classes, Dialogs, ToolIntF, ExptIntf, Menus; Type. TEMyExpert = class; { касс add-in нотификатора порождаем от TIAddInNotifier}. TAddInNotifier = class(TIAddInNotifier). Private. Expert: TEMyExpert; Public. Constructor Create( anExpert: TEMyExpert); Procedure FileNotification( NotifyCode: TFileNotification; Const FileName: string; var Cancel: Boolean); override; End; { класс эксперта является потомком базового класса TIExpert }. TEMyExpert = class( TIExpert). Private. ProjectName: string; MenuItem: TIMenuItemIntf; AddInNotifier: TAddInNotifier; Public. Constructor Create; Destructor Destroy; override; Function GetName: string; override; Function GetStyle: TExpertStyle; override; Function GetIDString: string; override; Procedure MenuItemClick( Sender: TIMenuItemIntf); End; Procedure register; Function AddIDEMenuItem( const Caption, name, PreviousItemName: string; Const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf; Implementation. Constructor TAddInNotifier.Create; Begin. Inherited Create; Expert := anExpert; End; Procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification; Const FileName: string; var Cancel: Boolean); Begin. With Expert do. Case NotifyCode of. FnProjectOpened: ProjectName:= FileName; { открытие проекта }. FnProjectClosing: ProjectName:= 'unknown' { закрытие проекта }. End; End; Constructor TEMyExpert.Create; Begin. Inherited Create; { добавляем пункт в главное меню IDE Delphi }. MenuItem:= AddIDEMenuItem( 'Simple Expert 3', 'ViewMyExpertItem3', {$IFDEF VER130}. 'ViewWatchesItem', '3', MenuItemClick); {$ELSE}. 'ViewWatchItem', '3', MenuItemClick); {$ENDIF}. Try. { создаем add-in нотификатор }. AddInNotifier:= TAddInNotifier.Create( Self); { регистрируем add-in нотификатор }. ToolServices.AddNotifier( AddInNotifier); Except. AddInNotifier:= nil; End; { инициализируем поле, хранящее имя активного проекта }. ProjectName:= ToolServices.GetProjectName; End; Destructor TEMyExpert.Destroy; Begin. If Assigned( MenuItem) then. MenuItem.Free; If Assigned( AddInNotifier) then. Begin. { снимаем регистрацию add-in нотификатора }. ToolServices.RemoveNotifier( AddInNotifier); { уничтожаем add-in нотификатор }. AddInNotifier.Free; End; Inherited Destroy; End; { при выборе пункта меню эксперта отображаем сообщение, содержащее }. { имя активного проекта }. Procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf); Begin. MessageDlg( 'Current project name is ' + ProjectName, MtInformation, [mbOK], 0); End; ... End.

Для реализации нотификатора мы определили класс TAddInNotifier, являющийся потомком TIAddInNotifier, и перекрыли метод FileNotification. IDE будет вызывать этот метод каждый раз, когда происходит событие, на которое способен среагировать add-in нотификатор (каждое такое событие обозначается соответствующей константой типа TFileNotification). Поле Expert в классе TAddInNotifier служит для обратной связи с экспертом (метод TAddInNotifier.FileNotification). В деструкторе эксперта регистрация нотификатора снимается, и нотификатор уничтожается.

А теперь проиллюстрируем использование модульных нотификаторов. Создадим add-in эксперт, выдающий сообщения о каждом акте сохранения проектного файла (реализацию уже знакомых нам методов для краткости не приводим):

Code: Unit exmpl_04; { ИСПОЛЬЗОВАНИЕ МОДУЛЬНЫХ НОТИФИКАТОРОВ }. Interface. Uses. Classes, Dialogs, ToolIntF, ExptIntf, Menus. {$IFDEF VER130}, EditIntf{$ENDIF}; Type. { класс модульного нотификатора порождаем от TIModuleNotifier }. TModuleNotifier = class( TIModuleNotifier). Private. FileName: string; Public. Constructor Create(const aFileName: string); Procedure Notify( NotifyCode: TNotifyCode); override; {$IFDEF VER130}. Procedure ComponentRenamed(ComponentHandle: Pointer; Const OldName, NewName: string); override; {$ELSE}. Procedure ComponentRenamed( const oldName, newName: string); override; {$ENDIF}. End; TEMyExpert = class; { класс add-in нотификатора порождаем от TIAddInNotifier}. TAddInNotifier = class(TIAddInNotifier). Private. Expert: TEMyExpert; Public. Constructor Create( anExpert: TEMyExpert); Procedure FileNotification( NotifyCode: TFileNotification; Const FileName: string; var Cancel: Boolean); override; End; { класс эксперта является потомком базового класса TIExpert }. TEMyExpert = class( TIExpert). Private. AddInNotifier: TAddInNotifier; ModuleInterface: TIModuleInterface; ModuleNotifier: TModuleNotifier; Public. Constructor Create; Destructor Destroy; override; Function GetName: string; override; Function GetStyle: TExpertStyle; override; Function GetIDString: string; override; Procedure AddModuleNotifier( const FileName: string); Procedure RemoveModuleNotifier; End; Procedure register; Implementation. Constructor TModuleNotifier.Create(const aFileName: string); Begin. Inherited Create; FileName := aFileName; End; Procedure TModuleNotifier.Notify( NotifyCode: TNotifyCode); Begin. { если произошло сохранение соответствующего нотификатору файла, }. { то выдаем сообщение об этом }. If NotifyCode = ncAfterSave then. MessageDlg(FileName + 'saved', mtInformation, [mbOK], 0); End; Procedure TModuleNotifier.ComponentRenamed; Begin. { ничего здесь не делаем, но метод необходимо перекрыть }. End; Procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification; Const FileName: string; var Cancel: Boolean); Begin. With Expert do. Case NotifyCode of. FnProjectOpened: { открытие проекта }. { добавляем модульный нотификатор }. AddModuleNotifier( FileName); FnProjectClosing: { закрытие проекта }. { освобождаем модульный нотификатор }. RemoveModuleNotifier; End; End; Constructor TEMyExpert.Create; Begin. Inherited Create; Try. { создаем add-in нотификатор }. AddInNotifier:= TAddInNotifier.Create( Self); { регистрируем add-in нотификатор }. ToolServices.AddNotifier( AddInNotifier); Except. AddInNotifier:= nil; End; { добавляем модульный нотификатор }. AddModuleNotifier( ToolServices.GetProjectName); End; Destructor TEMyExpert.Destroy; Begin. If Assigned( AddInNotifier) then. Begin. { снимаем регистрацию add-in нотификатора }. ToolServices.RemoveNotifier( AddInNotifier); { уничтожаем add-in нотификатор }. AddInNotifier.Free; End; { освобождаем модульный нотификатор }. RemoveModuleNotifier; Inherited Destroy; End; Procedure TEMyExpert.AddModuleNotifier; Begin. { если модульный нотификатор для проектного файла уже зарегистрирован, }. { то никаких действий не выполняем, во избежание появления дубликатов }. { нотификаторов; в противном случае дубликаты могли бы появиться, }. { например, при открытии Delphi: один нотификатор добавился бы при }. { создании эксперта (в конструкторе класса эксперта), а второй - при }. { открытии проекта (в TAddNotifier.FileNotification }. If Assigned( ModuleInterface) and Assigned( ModuleNotifier) then. Exit; Try. { получаем интерфейс модуля }. ModuleInterface:= ToolServices.GetModuleInterface( FileName); Try. { создаем модульный нотификатор }. ModuleNotifier:= TModuleNotifier.Create( FileName); { регистрируем модульный нотификатор }. ModuleInterface.AddNotifier( ModuleNotifier); Except. ModuleNotifier:= nil; End; Except. ModuleInterface:= nil; End; End; Procedure TEMyExpert.RemoveModuleNotifier; Begin. If Assigned(ModuleNotifier) then. Begin. If Assigned( ModuleInterface) then. { снимаем регистрацию модульного нотификатора }. ModuleInterface.RemoveNotifier( ModuleNotifier); { уничтожаем модульный нотификатор }. ModuleNotifier.Free; ModuleNotifier:= nil; End; If Assigned( ModuleInterface) then. Begin. { освобождаем модульный интерфейс }. ModuleInterface.Free; ModuleInterface:= nil; End; End; ... End.

В данном примере add-in эксперт отслеживает события, соответствующие открытию/закрытию проектов. При каждом открытии проекта регистрируется модульный нотификатор, соответствующий файлу проекта. В плане реализации модульные нотификаторы схожи с add-in нотификаторами: мы определяем класс TModuleNotifier, являющийся потомком TIModuleNotifier и перекрываем его методы Notify и ComponentRenamed. IDE вызывает метод Notify при возникновении определенных событий, имеющих отношение к данному модулю; внутри этого метода и определяется реакция на то или иное событие. Метод ComponentRenamed вызывается при изменении имени компонента, лежащего на форме модуля. Обратите внимание на то, что мы не используем этот метод, но обязаны его перекрыть, иначе при изменении имени компонента будет происходить вызов абстрактного метода базового класса, что приводит к непредсказуемым последствиям. Регистрация модульного нотификатора является несколько более сложным процессом по сравнению с регистрацией add-in нотификатора: сначала мы получаем интерфейс модуля (TIModuleInterface), а затем с помощью интерфейса модуля регистрируем нотификатор. При закрытии проекта регистрация модульного нотификатора снимается (снова с использованием TIModuleInterface), и нотификатор уничтожается.

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

Code: Unit exmpl_05; { ОПРЕДЕЛЕНИЕ ПОЗИЦИИ КУРСОРА }. Interface. Uses. SysUtils, Classes, Dialogs, ToolIntF, ExptIntf, EditIntf, Menus; Type. { класс эксперта является потомком базового класса TIExpert }. TEMyExpert = class( TIExpert). Private. MenuItem: TIMenuItemIntf; Public. Constructor Create; Destructor Destroy; override; Function GetName: string; override; Function GetStyle: TExpertStyle; override; Function GetIDString: string; override; Procedure MenuItemClick( Sender: TIMenuItemIntf); Function GetCursorPos: TEditPos; End; Procedure register; Function AddIDEMenuItem( const Caption, name, PreviousItemName: string; Const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf; Implementation. { при выборе пункта меню эксперта отображаем сообщение, содержащее }. { имя активного проекта }. Procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf); Var. CurPos: TEditPos; Begin. CurPos:= GetCursorPos; If CurPos.Line > 0 then. MessageDlg( 'Current file: ' + ToolServices.GetCurrentFile + #13 + 'Current cursor position: ' + IntToStr( CurPos.Line) + ', ' + IntToStr( CurPos.Col), mtInformation, [mbOK], 0); End; Function TEMyExpert.GetCursorPos: TEditPos; Var. ModuleInterface: TIModuleInterface; EditorInterface: TIEditorInterface; EditView: TIEditView; FileName: string; Begin. { определяем имя активного файла }. FileName:= ToolServices.GetCurrentFile; Result.Line:= 0; Result.Col:= 0; { для простоты определяем позицию только в pas- файлах }. If ExtractFileExt( FileName) = '.pas' then. Begin. { получаем интерфейс модуля }. ModuleInterface:= ToolServices.GetModuleInterface( FileName); Try. { получаем интерфейс редактора кода }. EditorInterface:= ModuleInterface.GetEditorInterface; Try. { получаем интерфейс представления модуля в редакторе }. { передавая методу GetView индекс нужного нам представления; }. { если файл открыт в нескольких окнах редактора кода, то для }. { простоты берем первое (хотя конечно, это не совсем }. { правильно }. EditView:= EditorInterface.GetView( 0); Try. Result:= EditView.CursorPos; Finally. EditView.Free; End; Finally. EditorInterface.Free; End; Finally. ModuleInterface.Free; End; End; End; ...

Для определения позиции курсора мы должны получить следующую последовательность интерфейсов:

Модульный интерфейс (TIModuleInterface);

Интерфейс редактора кода (TIEditorInterface);

Интерфейс представления модуля в окне редактора (TIEditView).

Если при выборе пункта меню эксперта активным является файл с исходным текстом (*.pas), то выдается сообщение, содержащее имя активного файла и текущую позицию курсора в нем. Если активным является не pas-файл, то сообщение не выдается.

Для получения имени активного файла используется метод GetCurrentFile класса TIToolServices.

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

©Drkb::00034.

Взято с http://delphiworld.narod.ru.

Как прокрутить TRichEdit в конец?

Существует множество способов, включая и:

Code: ---DO NOT USE THIS EXAMPLE - SEE BELOW INSTEAD--- With MainFrm.RichEdit1 do. Begin. Perform (WM_VSCROLL, SB_BOTTOM, 0); Perform (WM_VSCROLL, SB_PAGEUP, 0); End;

Как свернуть прогу в tray?

Проще всего использовать RxTrayIcon компонент из библиотеки RxLib.

Code: Procedure TForm1.ApplicationMinimize(Sender : TObject); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Begin. RxTrayIcon1.Show; ShowWindow(Application.Handle,SW_HIDE); End; Procedure TForm1.RxTrayIcon1Click(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. Application.Restore; SetForeGroundWindow(Application.MainForm.Handle); RxTrayIcon1.Hide; End;

SQL-запросы в Delphi.

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

1. Введение.

Компоненты Delphi для работы с базами данных были созданы в расчете на работу с SQL и архитектурой клиент/сервер. При работе с ними вы можете воспользоваться характеристиками расширенной поддержки удаленных серверов. Delphi осуществляет эту поддержку двумя способами. Во-первых, непосредственные команды из Delphi позволяют разработчику управлять таблицами, устанавливать пределы, удалять, вставлять и редактировать существующие записи. Второй способ заключается в использовании запросов на языке SQL, где строка запроса передается на сервер для ее разбора, оптимизации, выполнения и передачи обратно результатов.

Данный документ делает акцент на втором методе доступа к базам данных, на основе запросов SQL (pass-through). Авторы не стремились создать курсы по изучению синтаксиса языка SQL и его применения, они ставили перед собой цель дать несколько примеров использования компонентов TQuery и TStoredProc. Но чтобы сделать это, необходимо понимать концепцию SQL и знать как работают selects, inserts, updates, views, joins и хранимые процедуры (stored procedures). Документ также вскользь касается вопросов управления транзакциями и соединения с базой данных, но не акцентирует на этом внимание. Итак, приступая к теме, создайте простой запрос типа SELECT и отобразите результаты.

2. Компонент TQuery.

Если в ваших приложениях вы собираетесь использовать SQL, то вам непременно придется познакомиться с компонентом TQuery. Компоненты TQuery и TTable наследуются от TDataset. TDataset обеспечивает необходимую функциональность для получения доступа к базам данных. Как таковые, компоненты TQuery и TTable имеют много общих признаков. Для подготовки данных для показа в визуальных компонентах используется все тот же TDatasource. Также, для определения к какому серверу и базе данных необходимо получить доступ, необходимо задать имя псевдонима. Это должно выполняться установкой свойства aliasName объекта TQuery.

Свойство SQL.

Все же TQuery имеет некоторую уникальную функциональность. Например, у TQuery имеется свойство с именем SQL. Свойство SQL используется для хранения SQL-запроса. Ниже приведены основные шаги для составления запроса, где все служащие имеют зарплату свыше $50,000.

Создайте объект TQuery.

Задайте псевдоним свойству DatabaseName. (Данный пример использует псевдоним IBLOCAL, связанный с демонстрационной базой данных employee.gdb).

Выберите свойство SQL и щелкните на кнопке с текстом - '...' (три точки, Инспектор Объектов - В.О.). Должен появиться диалог редактора списка строк (String List Editor).

Введите:

Code: Select * from EMPLOYEE where SALARY>50000.

Kylix Tutorial. Работа с DBExpress (статья).

Эта серия статей была любезно предоставлена автором Mike Goblin для нашего FAQ.

©Drkb::04580.

Взято с сайта http://www.delphimaster.ru/

Встроенные форматы буфера обмена.

Автор: Peter Below.

Code: Procedure TForm1.BtnShowFormatsClick(Sender: TObject); Var. Buf: array[0..60] of Char; N: Integer; Fmt: Word; Name: string[30]; Begin. MemFormats.Clear; For n := 0 to Clipboard.FormatCount - 1 do. Begin. Fmt := Clipboard.Formats[n]; If GetclipboardFormatName(fmt, buf, Pred(Sizeof(buf))) <> 0 then. MemFormats.Lines.Add(StrPas(buf)). Else. Begin. Case fmt of. 1: name := 'CF_TEXT'; 2: name := 'CF_BITMAP'; 3: name := 'CF_METAFILEPICT'; 4: name := 'CF_SYLK'; 5: name := 'CF_DIF'; 6: name := 'CF_TIFF'; 7: name := 'CF_OEMTEXT'; 8: name := 'CF_DIB'; 9: name := 'CF_PALETTE'; 10: name := 'CF_PENDATA'; 11: name := 'CF_RIFF'; 12: name := 'CF_WAVE'; 13: name := 'CF_UNICODETEXT'; 14: name := 'CF_ENHMETAFILE'; 15: name := 'CF_HDROP (Win 95)'; 16: name := 'CF_LOCALE (Win 95)'; 17: name := 'CF_MAX (Win 95)'; $0080: name := 'CF_OWNERDISPLAY'; $0081: name := 'CF_DSPTEXT'; $0082: name := 'CF_DSPBITMAP'; $0083: name := 'CF_DSPMETAFILEPICT'; $008E: name := 'CF_DSPENHMETAFILE'; $0200..$02FF: name := 'частный формат'; $0300..$03FF: name := 'Объект GDI'; Else. Name := 'неизвестный формат'; End; MemFormats.Lines.Add(name); End; End; End;

Имя класса компонента и модуля.

Мне необходима функция, которая возвращала бы имя класса компонента и имя модуля, где определен данный класс.

Например: xxx('TPanel') возвращала бы 'ExtCtrls'

Также мне необходима функция, возвращающая список имен страниц палитры компонентов.

Code: Uses TypInfo; Function ObjectsUnit (Obj: TClass): String; Begin. Result := GetTypeData (PTypeInfo(Obj.ClassInfo))^.UnitName. End;

Для создания описанной вами функции "Какой модуль" могут использоваться описанные в TOOLINTF.INT методы GetModuleCount, GetModuleName, GetComponentCount и GetComponentName.

Для получения представления о формате палитры компонентов обратитесь к файлу DELPHI.INI.

©Drkb::00287.

Взято с http://delphiworld.narod.ru.

Несколько колонок в TComboBox.

Code: Procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); Var. StrVal, strAll: string; Pos1, pos2: Integer; Rc: TRect; ArrWidth: array [0..3] of Integer; Begin. Combobox1.Canvas.Brush.Style := bsSolid; Combobox1.Canvas.FillRect(Rect); // the columns must be separated by ';' StrAll := Combobox1.Items[Index]; ArrWidth[0] := 0; ArrWidth[1] := 100; // Width of column 1. ArrWidth[2] := 200; // Width of column 2. ArrWidth[3] := 300; // Width of colimn 3. // Drawingrange for first column. Rc.Left := Rect.Left + arrWidth[0] + 2; Rc.Right := Rect.Left + arrWidth[1] - 2; Rc.Top := Rect.Top; Rc.Bottom := Rect.Bottom; // Get text for first column. Pos1 := Pos(';', strAll); StrVal := Copy(strAll, 1, pos1 - 1); // Draw Text. Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal); // Draw separating line betwenn columns. Combobox1.Canvas.MoveTo(rc.Right, rc.Top); Combobox1.Canvas.LineTo(rc.Right, rc.Bottom); // Drawingrange for second column. Rc.Left := Rect.Left + arrWidth[1] + 2; Rc.Right := Rect.Left + arrWidth[2] - 2; // Text fur zweite Spalte ausfiltern. // Get text for second column. StrAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1); Pos1 := Pos(';', strAll); StrVal := Copy(strAll, 1, pos1 - 1); // Text ausgeben. // Draw Text. Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal); // Trennlinie zwischen Spalten zeichnen. // Draw separating line betwenn columns. Combobox1.Canvas.MoveTo(rc.Right, rc.Top); Combobox1.Canvas.LineTo(rc.Right, rc.Bottom); // Drawingrange for third column. Rc.Left := Rect.Left + arrWidth[2] + 2; Rc.Right := Rect.Left + arrWidth[3] - 2; // Get text for third column. StrAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1); Pos1 := Pos(';', strAll); StrVal := Copy(strAll, 1, pos1 - 1); // Draw Text. Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal); // Draw separating line betwenn columns. Combobox1.Canvas.MoveTo(rc.Right, rc.Top); Combobox1.Canvas.LineTo(rc.Right, rc.Bottom); StrAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1); End; // Example/ Beispiel: Procedure TForm1.Button1Click(Sender: TObject); Begin. With Combobox1.Items do. Begin. Add('first;second;third;'); Add('column1;column2;column3;'); End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. //Oder im Objekt Inspektor einstellen. //Or set this Property in the Object Inspector. Combobox1.Style := csOwnerDrawFixed; End;

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

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

Code: 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;

Язык программирования Дельфи.

Нет, я не ошибся! Начиная с версии Delphi 7 фирма Борланд официально называет язык программирования Delphi и Kylix языком "Дельфи". В этом разделе собраны вопросы по работе с конструкциями языка Дельфи, не затрагивая конкретной реализации большинства классов VCL.

Vit.

©Drkb::00066.

Транзакции.

Управление транзакциями в OLE DB реализовано на двух уровнях. Во-первых, всеми необходимыми методами обладает объект сессии. Он имеет интерфейсы ITransaction, ITransactionJoin, ITransactionLocal, ITransactionObject.

Внутри сессии транзакция управляется интерфейсами ITransactionLocal, ItransactionSC, ITransaction и их методами StartTransaction, Commit, Rollback.

Во-вторых, для объекта сессии можно создать объект транзакции при помощи метода.

Function GetTransactionObject(ulTransactionLevel: UINT; out ppTransactionObject: ITransaction): HResult; stdcall;

Интерфейса ITransactionObject, который возвращает ссылку на интерфейс объекта-транзакции.

Как менять шрифт в RichEdit горячими клавишами?

Следующий пример показывает, как можно изменять шрифт в компоненте TRichEdit при помощи следующих комбинаций клавиш:

Ctrl + B - Включает и выключает жирность (Bold) шрифта.

Ctrl + I - Включает и выключает (Italic) шрифта.

Ctrl + S - Включает и выключает зачёркивание (Strikeout) шрифта.

Ctrl + U - Включает и выключает подчёркивание (Underline) шрифта.

Замечание: Так же можно устанавливать сразу несколько типов шрифта.

Пример:

Code: Const. KEY_CTRL_B = 02; KEY_CTRL_I = 9; KEY_CTRL_S = 19; KEY_CTRL_U = 21; Procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char); Begin. Case Ord(Key) of. KEY_CTRL_B: begin. Key := #0; If fsBold in (Sender as TRichEdit).SelAttributes.Style then. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsBold] else. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsBold]; End; KEY_CTRL_I: begin. Key := #0; If fsItalic in. (Sender as TRichEdit).SelAttributes.Style then. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsItalic]. Else. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsItalic]; End; KEY_CTRL_S: begin. Key := #0; If fsStrikeout in. (Sender as TRichEdit).SelAttributes.Style then. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsStrikeout]. Else. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsStrikeout]; End; KEY_CTRL_U: begin. Key := #0; If fsUnderline in. (Sender as TRichEdit).SelAttributes.Style then. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsUnderline]. Else. (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsUnderline]; End; End; End;

Hex ---> Integer.

Code: Var. I: integer. S: string; Begin. S := '$' + ThatHexString; I := StrToInt(a); End;

Code: Const HEX: array['A'..'F'] of INTEGER = (10, 11, 12, 13, 14, 15); Var str: string; Int, i: integer; Begin. READLN(str); Int := 0; For i := 1 to Length(str) do. If str[i] < 'A' then. Int := Int * 16 + ORD(str[i]) - 48. Else. Int := Int * 16 + HEX[str[i]]; WRITELN(Int); READLN; End.

Unix-строки (чтение и запись Unix-файлов).

Code: Unit StreamFile; Interface. Uses SysUtils; Procedure AssignStreamFile(var F: Text; Filename: string); Implementation. Const. BufferSize = 128; Type. TStreamBuffer = array[1..High(Integer)] of Char; TStreamBufferPointer = ^TStreamBuffer; TStreamFileRecord = record. Case Integer of. 1: ( Filehandle: Integer; Buffer: TStreamBufferPointer; BufferOffset: Integer; ReadCount: Integer; ); 2: ( Dummy: array[1..32] of Char. ) End; Function StreamFileOpen(var F: TTextRec): Integer; Var. Status: Integer; Begin. With TStreamFileRecord(F.UserData) do. Begin. GetMem(Buffer, BufferSize); Case F.Mode of. FmInput: FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone); FmOutput: FileHandle := FileCreate(StrPas(F.Name)); FmInOut: Begin. FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone or. FmOpenWrite or fmOpenRead); If FileHandle <> -1 then. Status := FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }. F.Mode := fmOutput; End; End; BufferOffset := 0; ReadCount := 0; F.BufEnd := 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }. If FileHandle = -1 then. Result := -1. Else. Result := 0; End; End; Function StreamFileInOut(var F: TTextRec): Integer; Procedure Read(var Data: TStreamFileRecord); Procedure CopyData; Begin. While (F.BufEnd < Sizeof(F.Buffer) - 2). And (Data.BufferOffset <= Data.ReadCount). And (Data.Buffer[Data.BufferOffset] <> #10) do. Begin. F.Buffer[F.BufEnd] := Data.Buffer^[Data.BufferOffset]; Inc(Data.BufferOffset); Inc(F.BufEnd); End; If Data.Buffer[Data.BufferOffset] = #10 then. Begin. F.Buffer[F.BufEnd] := #13; Inc(F.BufEnd); F.Buffer[F.BufEnd] := #10; Inc(F.BufEnd); Inc(Data.BufferOffset); End; End; Begin. F.BufEnd := 0; F.BufPos := 0; F.Buffer := ''; Repeat. Begin. If (Data.ReadCount = 0) or (Data.BufferOffset > Data.ReadCount) then. Begin. Data.BufferOffset := 1; Data.ReadCount := FileRead(Data.FileHandle, Data.Buffer^, BufferSize); End; CopyData; End until (Data.ReadCount = 0). Or (F.BufEnd >= Sizeof(F.Buffer) - 2); Result := 0; End; Procedure Write(var Data: TStreamFileRecord); Var. Status: Integer; Destination: Integer; II: Integer; Begin. With TStreamFileRecord(F.UserData) do. Begin. Destination := 0; For II := 0 to F.BufPos - 1 do. Begin. If F.Buffer[II] <> #13 then. Begin. Inc(Destination); Buffer^[Destination] := F.Buffer[II]; End; End; Status := FileWrite(FileHandle, Buffer^, Destination); F.BufPos := 0; Result := 0; End; End; Begin. Case F.Mode of. FmInput: Read(TStreamFileRecord(F.UserData)); FmOutput: Write(TStreamFileRecord(F.UserData)); End; End; Function StreamFileFlush(var F: TTextRec): Integer; Begin. Result := 0; End; Function StreamFileClose(var F: TTextRec): Integer; Begin. With TStreamFileRecord(F.UserData) do. Begin. FreeMem(Buffer); FileClose(FileHandle); End; Result := 0; End; Procedure AssignStreamFile(var F: Text; Filename: string); Begin. With TTextRec(F) do. Begin. Mode := fmClosed; BufPtr := @Buffer; BufSize := Sizeof(Buffer); OpenFunc := @StreamFileOpen; InOutFunc := @StreamFileInOut; FlushFunc := @StreamFileFlush; CloseFunc := @StreamFileClose; StrPLCopy(Name, FileName, Sizeof(Name) - 1); End; End; End.

Число английской строкой.

Code: Unit uNum2Str; // Possible enhancements. // Move strings out to resource files. // Put in a general num2str utility. Interface. Function Num2Dollars(dNum: double): string; Implementation. Uses SysUtils; Function LessThan99(dNum: double): string; forward; // floating point modulus. Function FloatMod(i, j: double): double; Begin. Result := i - (Int(i / j) * j); End; Function Hundreds(dNum: double): string; Var. WorkVar: double; Begin. If (dNum < 100) or (dNum > 999) then raise Exception.Create('hundreds range exceeded'); Result := ''; WorkVar := Int(dNum / 100); If workVar > 0 then result := LessThan99(workVar) + ' Hundred'; End; Function OneToNine(dNum: Double): string; Begin. If (dNum < 1) or (dNum > 9) then raise exception.create('onetonine: value out of range'); Result := 'woops'; If dNum = 1 then result := 'One' else. If dNum = 2 then result := 'Two' else. If dNum = 3 then result := 'Three' else. If dNum = 4 then result := 'Four' else. If dNum = 5 then result := 'Five' else. If dNum = 6 then result := 'Six' else. If dNum = 7 then result := 'Seven' else. If dNum = 8 then result := 'Eight' else. If dNum = 9 then result := 'Nine'; End; Function ZeroTo19(dNum: double): string; Begin. If (dNum < 0) or (dNum > 19) then raise Exception.Create('Bad value in dNum'); Result := ''; If dNum = 0 then result := 'Zero' else. If (dNum <= 1) and (dNum >= 9) then result := OneToNine(dNum) else. If dNum = 10 then result := 'Ten' else. If dNum = 11 then result := 'Eleven' else. If dNum = 12 then result := 'Twelve' else. If dNum = 13 then result := 'Thirteen' else. If dNum = 14 then result := 'Fourteen' else. If dNum = 15 then result := 'Fifteen' else. If dNum = 16 then result := 'Sixteen' else. If dNum = 17 then result := 'Seventeen' else. If dNum = 18 then result := 'Eighteen' else. If dNum = 19 then result := 'Nineteen' else. Result := 'woops!'; End; Function TwentyTo99(dNum: double): string; Var BigNum: string; Begin. If (dNum < 20) or (dNum > 99) then raise exception.Create('TwentyTo99: dNum out of range!'); BigNum := 'woops'; If dNum >= 90 then BigNum := 'Ninety' else. If dNum >= 80 then BigNum := 'Eighty' else. If dNum >= 70 then BigNum := 'Seventy' else. If dNum >= 60 then BigNum := 'Sixty' else. If dNum >= 50 then BigNum := 'Fifty' else. If dNum >= 40 then BigNum := 'Forty' else. If dNum >= 30 then BigNum := 'Thirty' else. If dNum >= 20 then BigNum := 'Twenty'; // lose the big num. DNum := FloatMod(dNum, 10); If dNum > 0.00 then. Result := BigNum + ' ' + OneToNine(dNum). Else. Result := BigNum; End; Function LessThan99(dNum: double): string; Begin. If dNum <= 19 then. Result := ZeroTo19(dNum). Else. Result := TwentyTo99(dNum); End; Function Num2Dollars(dNum: double): string; Var. CentsString: string; Cents: double; WorkVar: double; Begin. Result := ''; If dNum < 0 then raise Exception.Create('Negative numbers not supported'); If dNum > 999999999.99 then. Raise Exception.Create('Num2Dollars only supports up to the millions at this point!'); Cents := (dNum - Int(dNum)) * 100.0; If cents = 0.0 then centsString := 'and 00/100 Dollars' else. If cents < 10 then centsString := Format('and 0%1.0f/100 Dollars', [cents]) else. CentsString := Format('and %2.0f/100 Dollars', [cents]); DNum := Int(dNum - (cents / 100.0)); // lose the cents. // deal with million's. If (dNum >= 1000000) and (dNum <= 999999999) then. Begin. WorkVar := dNum / 1000000; WorkVar := Int(workVar); If (workVar <= 9) then result := ZeroTo19(workVar) else. If (workVar <= 99) then result := LessThan99(workVar) else. If (workVar <= 999) then result := Hundreds(workVar) else. Result := 'mill fubar'; Result := result + ' Million'; DNum := dNum - (workVar * 1000000); End; // deal with 1000's. If (dNum >= 1000) and (dNum <= 999999.99) then. Begin. // doing the two below statements in one line of code yields some really. // freaky floating point errors. WorkVar := dNum / 1000; WorkVar := Int(workVar); If (workVar <= 9) then result := ZeroTo19(workVar) else. If (workVar <= 99) then result := LessThan99(workVar) else. If (workVar <= 999) then result := Hundreds(workVar) else. Result := 'thou fubar'; Result := result + ' Thousand'; DNum := dNum - (workVar * 1000); End; // deal with 100's. If (dNum >= 100.00) and (dNum <= 999.99) then. Begin. Result := result + ' ' + Hundreds(dNum); DNum := FloatMod(dNum, 100); End; // format in anything less than 100. If (dNum > 0) or ((dNum = 0) and (Length(result) = 0)) then. Begin. Result := result + ' ' + LessThan99(dNum); End; Result := result + ' ' + centsString; End; End.

©Drkb::00209.

Code: Function HundredAtATime(TheAmount: Integer): string; Var. TheResult: string; Begin. TheResult := ''; TheAmount := Abs(TheAmount); While TheAmount > 0 do. Begin. If TheAmount >= 900 then. Begin. TheResult := TheResult + 'Nine hundred '; TheAmount := TheAmount - 900; End; If TheAmount >= 800 then. Begin. TheResult := TheResult + 'Eight hundred '; TheAmount := TheAmount - 800; End; If TheAmount >= 700 then. Begin. TheResult := TheResult + 'Seven hundred '; TheAmount := TheAmount - 700; End; If TheAmount >= 600 then. Begin. TheResult := TheResult + 'Six hundred '; TheAmount := TheAmount - 600; End; If TheAmount >= 500 then. Begin. TheResult := TheResult + 'Five hundred '; TheAmount := TheAmount - 500; End; If TheAmount >= 400 then. Begin. TheResult := TheResult + 'Four hundred '; TheAmount := TheAmount - 400; End; If TheAmount >= 300 then. Begin. TheResult := TheResult + 'Three hundred '; TheAmount := TheAmount - 300; End; If TheAmount >= 200 then. Begin. TheResult := TheResult + 'Two hundred '; TheAmount := TheAmount - 200; End; If TheAmount >= 100 then. Begin. TheResult := TheResult + 'One hundred '; TheAmount := TheAmount - 100; End; If TheAmount >= 90 then. Begin. TheResult := TheResult + 'Ninety '; TheAmount := TheAmount - 90; End; If TheAmount >= 80 then. Begin. TheResult := TheResult + 'Eighty '; TheAmount := TheAmount - 80; End; If TheAmount >= 70 then. Begin. TheResult := TheResult + 'Seventy '; TheAmount := TheAmount - 70; End; If TheAmount >= 60 then. Begin. TheResult := TheResult + 'Sixty '; TheAmount := TheAmount - 60; End; If TheAmount >= 50 then. Begin. TheResult := TheResult + 'Fifty '; TheAmount := TheAmount - 50; End; If TheAmount >= 40 then. Begin. TheResult := TheResult + 'Fourty '; TheAmount := TheAmount - 40; End; If TheAmount >= 30 then. Begin. TheResult := TheResult + 'Thirty '; TheAmount := TheAmount - 30; End; If TheAmount >= 20 then. Begin. TheResult := TheResult + 'Twenty '; TheAmount := TheAmount - 20; End; If TheAmount >= 19 then. Begin. TheResult := TheResult + 'Nineteen '; TheAmount := TheAmount - 19; End; If TheAmount >= 18 then. Begin. TheResult := TheResult + 'Eighteen '; TheAmount := TheAmount - 18; End; If TheAmount >= 17 then. Begin. TheResult := TheResult + 'Seventeen '; TheAmount := TheAmount - 17; End; If TheAmount >= 16 then. Begin. TheResult := TheResult + 'Sixteen '; TheAmount := TheAmount - 16; End; If TheAmount >= 15 then. Begin. TheResult := TheResult + 'Fifteen '; TheAmount := TheAmount - 15; End; If TheAmount >= 14 then. Begin. TheResult := TheResult + 'Fourteen '; TheAmount := TheAmount - 14; End; If TheAmount >= 13 then. Begin. TheResult := TheResult + 'Thirteen '; TheAmount := TheAmount - 13; End; If TheAmount >= 12 then. Begin. TheResult := TheResult + 'Twelve '; TheAmount := TheAmount - 12; End; If TheAmount >= 11 then. Begin. TheResult := TheResult + 'Eleven '; TheAmount := TheAmount - 11; End; If TheAmount >= 10 then. Begin. TheResult := TheResult + 'Ten '; TheAmount := TheAmount - 10; End; If TheAmount >= 9 then. Begin. TheResult := TheResult + 'Nine '; TheAmount := TheAmount - 9; End; If TheAmount >= 8 then. Begin. TheResult := TheResult + 'Eight '; TheAmount := TheAmount - 8; End; If TheAmount >= 7 then. Begin. TheResult := TheResult + 'Seven '; TheAmount := TheAmount - 7; End; If TheAmount >= 6 then. Begin. TheResult := TheResult + 'Six '; TheAmount := TheAmount - 6; End; If TheAmount >= 5 then. Begin. TheResult := TheResult + 'Five '; TheAmount := TheAmount - 5; End; If TheAmount >= 4 then. Begin. TheResult := TheResult + 'Four '; TheAmount := TheAmount - 4; End; If TheAmount >= 3 then. Begin. TheResult := TheResult + 'Three '; TheAmount := TheAmount - 3; End; If TheAmount >= 2 then. Begin. TheResult := TheResult + 'Two '; TheAmount := TheAmount - 2; End; If TheAmount >= 1 then. Begin. TheResult := TheResult + 'One '; TheAmount := TheAmount - 1; End; End; HundredAtATime := TheResult; End; Function Real2CheckAmount(TheAmount: Real): string; Var. IntVal: LongInt; TmpVal: Integer; TmpStr, RetVal: string; Begin. TheAmount := Abs(TheAmount); { центы }. TmpVal := Round(Frac(TheAmount) * 100); IntVal := Trunc(TheAmount); TmpStr := HundredAtATime(TmpVal); If TmpStr = '' then TmpStr := 'Zero '; RetVal := TmpStr + 'cents'; If IntVal > 0 then RetVal := 'dollars and ' + RetVal; { сотни }. TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); RetVal := TmpStr + RetVal; { тысячи }. TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' then. RetVal := TmpStr + 'Thousand ' + RetVal; { миллионы }. TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' then. RetVal := TmpStr + 'Million ' + RetVal; { миллиарды }. TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' then. RetVal := TmpStr + 'Billion ' + RetVal; Real2CheckAmount := RetVal; End;

Число русской строкой.

Автор Александр.

Code: {------------------------ Деньги прописью ---------------------}. Function TextSum(S: double): string; Function Conv999(M: longint; fm: integer): string; Const. C1to9m: array[1..9] of string[6] = ('один', 'два', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять'); C1to9f: array[1..9] of string[6] = ('одна', 'две', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять'); C11to19: array[1..9] of string[12] = ('одиннадцать', 'двенадцать', 'тринадцать', 'четырнадцать', 'пятнадцать', 'шестнадцать', 'семнадцать', 'восемнадцать', 'девятнадцать'); C10to90: array[1..9] of string[11] = ('десять', 'двадцать', 'тридцать', 'сорок', 'пятьдесят', 'шестьдесят', 'семьдесят', 'восемьдесят', 'девяносто'); C100to900: array[1..9] of string[9] = ('сто', 'двести', 'триста', 'четыреста', 'пятьсот', 'шестьсот', 'семьсот', 'восемьсот', 'девятьсот'); Var. S: string; I: longint; Begin. S := ''; I := M div 100; If i <> 0 then s := c100to900[i] + ' '; M := M mod 100; I := M div 10; If (M > 10) and (M < 20) then. S := s + c11to19[M - 10] + ' ' Else. Begin. If i <> 0 then s := s + c10to90[i] + ' '; M := M mod 10; If M <> 0 then. If fm = 0 then. S := s + c1to9f[M] + ' ' Else. S := s + c1to9m[M] + ' '; End; Conv999 := s; End; {--------------------------------------------------------------} Var. I: longint; J: longint; R: real; T: string; Begin. T := ''; J := Trunc(S / 1000000000.0); R := j; R := S - r * 1000000000.0; I := Trunc(r); If j <> 0 then. Begin. T := t + Conv999(j, 1) + 'миллиард'; J := j mod 100; If (j > 10) and (j < 20) then. T := t + 'ов ' Else. Case j mod 10 of. 0: t := t + 'ов '; 1: t := t + ' '; 2..4: t := t + 'а '; 5..9: t := t + 'ов '; End; End; J := i div 1000000; If j <> 0 then. Begin. T := t + Conv999(j, 1) + 'миллион'; J := j mod 100; If (j > 10) and (j < 20) then. T := t + 'ов ' Else. Case j mod 10 of. 0: t := t + 'ов '; 1: t := t + ' '; 2..4: t := t + 'а '; 5..9: t := t + 'ов '; End; End; I := i mod 1000000; J := i div 1000; If j <> 0 then. Begin. T := t + Conv999(j, 0) + 'тысяч'; J := j mod 100; If (j > 10) and (j < 20) then. T := t + ' ' Else. Case j mod 10 of. 0: t := t + ' '; 1: t := t + 'а '; 2..4: t := t + 'и '; 5..9: t := t + ' '; End; End; I := i mod 1000; J := i; If j <> 0 then t := t + Conv999(j, 1); T := t + 'руб. '; I := Round(Frac(S) * 100.0); T := t + Long2Str(i) + ' коп.'; TextSum := t; End;

Число украинской строкой.

Code: Unit UkrRecog; {копирайт непомню чей. Был для русских циферок, а я переделал под. Украинские}. {если кто что найдет пришлите. } {by Andrew Tkachenko, proektwo@netcity.ru, Ukraine, } Interface. Const. UkrMonthString: array[1..12] of string[9] = ( 'січня', 'лютого', 'березня', 'квiтня', 'травня', 'червня', 'липня', 'серпня', 'вересня', 'жовтня', 'листопада', 'грудня'); Function UkrRecognizeAmount(Amount: real; CurrName, CurrSubname: string): string; Implementation. Uses Sysutils; Function UkrRecognizeAmount(Amount: real; CurrName, CurrSubname: string): string; {* CurrName in [грн.]. CurrSubName in [коп.]. Распознается число <= 999 999 999 999.99*}. Const suffBL: string = ' '; SuffDCT: string = 'дцять'; SuffNA: string = 'надцять '; SuffDCM: string = 'десят'; SuffMZ: string = 'ь'; Sot: string = 'сот'; St: string = 'ст'; Aa: string = 'а'; Ee: string = 'и'; {e}. Ii: string = 'і'; {и}. Oo: string = 'о'; Ov: string = 'ів'; {ов}. C2: string = 'дв'; C3: string = 'три'; C4: string = 'чотир'; C5: string = 'п''ят'; C6: string = 'шіст'; C7: string = 'сім'; C8: string = 'вісім'; C9: string = 'дев''ят'; Var. I: byte; SAmount, sdInt, sdDec: string; IsMln, IsTha {,IsDcm}, IsRange1019: boolean; CurrNum, endMlx, sResult: string; Begin. If (amount <= 0) or (amount > 999999999999.99) then. Begin. Result := '<<<< Ошибка в диапазоне >>>>'; Exit; End; STR(Amount: 16: 2, sAmount); SdInt := Copy(sAmount, 1, 13); SdDec := Copy(sAmount, 15, 2); IsMln := false; //IsDcm:=false; IsTha := false; IsRange1019 := false; SResult := ''; For i := 1 to 13 do. Begin. CurrNum := Copy(sdInt, i, 1); If currNum <> suffBL then. Begin. Case i of. 5, 6, 7: if currNum <> '0' then IsMln := true; 8, 9, 10: if currNum <> '0' then IsTha := true; End; If i in [2, 5, 8, 11] then {сотни}. Begin. If currNum = '1' then sResult := sResult + st + oo + suffBL; If currNum = '2' then sResult := sResult + C2 + ii + st + ii + suffBL; If currNum = '3' then sResult := sResult + C3 + st + aa + suffBL; If currNum = '4' then sResult := sResult + C4 + ee + st + aa + suffBL; If currNum = '5' then sResult := sResult + C5 + sot + suffBL; If currNum = '6' then sResult := sResult + C6 + sot + suffBL; If currNum = '7' then sResult := sResult + C7 + sot + suffBL; If currNum = '8' then sResult := sResult + C8 + sot + suffBL; If currNum = '9' then sResult := sResult + C9 + sot + suffBL; End; If i in [3, 6, 9, 12] then {десятки}. Begin. If currNum = '1' then IsRange1019 := true; If currNum = '2' then sResult := sResult + C2 + aa + suffDCT + suffBL; If currNum = '3' then sResult := sResult + C3 + suffDCT + suffBL; If currNum = '4' then sResult := sResult + 'сорок '; If currNum = '5' then. SResult := sResult + C5 + suffMZ + suffDCM + suffBL; If currNum = '6' then. SResult := sResult + C6 + suffMZ + suffDCM + suffBL; If currNum = '7' then. SResult := sResult + C7 + suffMZ + suffDCM + suffBL; If currNum = '8' then. SResult := sResult + C8 + suffMZ + suffDCM + suffBL; If currNum = '9' then. SResult := sResult + 'дев''ян' + oo + st + oo + suffBL; End; If i in [4, 7, 10, 13] then {единицы}. Begin. If (currNum = '0') then. If IsRange1019 then sResult := sResult + suffDCM + suffMZ + suffBL; If (currNum = '1') then. Begin. If (i = 13) and (not IsRange1019) then. SResult := sResult + 'одна ' Else. Begin. If (i = 10) and (IsRange1019) then. SResult := sResult + 'оди' Else if (i = 10) and (not IsRange1019) then. SResult := sResult + 'одна ' Else. SResult := sResult + 'один' {ин}; If IsRange1019 and (i = 13) then. SResult := sResult + 'адцять' + suffBL. Else if IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffBL; End; End; If (currNum = '2') then. Begin. SResult := sResult + C2; If (i = 10) and (IsRange1019 = False) then. SResult := sResult + ii. Else if (i = 10) or (IsRange1019) then. SResult := sResult + aa. Else. SResult := sResult + {aa} ii; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffBL; End; If (currNum = '3') then. Begin. SResult := sResult + C3; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffBL; End; If (currNum = '4') then. Begin. SResult := sResult + C4; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + ee + suffBL; End; If (currNum = '5') then. Begin. SResult := sResult + C5; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffMZ + suffBL; End; If (currNum = '6') then. Begin. SResult := sResult + C6; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffMZ + suffBL; End; If (currNum = '7') then. Begin. SResult := sResult + C7; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffBL; End; if (currNum = '8') then. Begin. SResult := sResult + C8; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffBL; End; if (currNum = '9') then. Begin. SResult := sResult + C9; If IsRange1019 then. SResult := sResult + suffNA. Else. SResult := sResult + suffMZ + suffBL; End; End; EndMlx := ''; Case i of. 4: Begin. If IsRange1019 then. EndMlx := ov + suffBL. Else if currNum = '1' then. EndMlx := suffBL. Else if (currNum = '2') or (currNum = '3') or (currNum = '4') then. EndMlx := aa + suffBL. Else. EndMlx := ov + suffBL; SResult := sResult + 'мiльярд' + endMlx; End; 7: if IsMln then. Begin. If IsRange1019 then. EndMlx := ov + suffBL. Else if currNum = '1' then. EndMlx := suffBL. Else if (currNum = '2') or (currNum = '3') or (currNum = '4') then. EndMlx := aa + suffBL. Else. EndMlx := ov + suffBL; SResult := sResult + 'мiльйон' + endMlx; End; 10: if IsTha then. Begin. If IsRange1019 then. EndMlx := suffBL. Else if currNum = '1' then. EndMlx := aa + suffBL. Else if (currNum = '2') or (currNum = '3') or (currNum = '4') then. EndMlx := ii + suffBL. Else. EndMlx := suffBL; SResult := sResult + 'тисяч' + endMlx; End; End; {case}. If i in [4, 7, 10, 13] then IsRange1019 := false; End; {IF}. End; {FOR}. SResult := sResult + CurrName + ',' + suffBL + sdDec + suffBL + CurrSubname; SResult := AnsiUpperCase(sResult[1]) + Copy(sResult, 2, length(sResult) - 1); Result := sResult; End; End.

Как получить определённую часть текста из RichEdit?

Иногда бывает необходимо полудить только часть текста из RichEdit не выделяя его, то есть не используя свойство SelText. Ниже представлен код, который позволяет сделать это.

Code: {Переопределяем неправильное объявление TTextRange в RichEdit.pas}. TTextRange = record. Chrg: TCharRange; LpstrText: PAnsiChar; End; Function REGetTextRange(RichEdit: TRichEdit; BeginPos, MaxLength: Integer): string; {RichEdit - RichEdit control. BeginPos - абсолютное значение первого символа. MaxLength - максимально число получаемых символов}. Var. TextRange: TTextRange; Begin. If MaxLength>0 then. Begin. SetLength(Result, MaxLength); With TextRange do. Begin. Chrg.cpMin := BeginPos; Chrg.cpMax := BeginPos+MaxLength; LpstrText := PChar(Result); End; SetLength(Result, SendMessage(RichEdit.Handle, EM_GETTEXTRANGE, 0, Longint(@TextRange))); End. Else Result:=''; End;

Следующую функцию можно использовать для получения слова, над которым находится курсор мышки:

Code: Function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer; { функция возвращает абсолютное положение символа для данных координат курсора}. Var. P: TPoint; Begin. P := Point(X, Y); Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, longint(@P)); End; Function REExtractWordFromPos(RichEdit: TRichEdit; X, Y: Integer):= String; { X, Y - координаты в rich edit }. {возвращает слово в текущих координатах курсора}. Var. BegPos, EndPos: Integer; Begin. BegPos := RECharIndexByPos(RichEdit, X, Y); If (BegPos < 0) or. (SendMessage(RichEdit.Handle,EM_FINDWORDBREAK,WB_CLASSIFY,BegPos) and. (WBF_BREAKLINE or WBF_ISWHITE) <> 0 ) then. Begin. Result:=''; Exit; End; If SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,WB_CLASSIFY,BegPos-1) and. (WBF_BREAKLINE or WBF_ISWHITE) = 0 then. BegPos:=SendMessage(RichEdit.Handle, EM_FINDWORDBREAK, WB_MOVEWORDLEFT, BegPos); EndPos:=SendMessage(RichEdit.Handle,EM_FINDWORDBREAK,WB_MOVEWORDRIGHT,BegPos); Result:=TrimRight(REGetTextRange(RichEdit, BegPos, EndPos - BegPos)); End;

©Drkb::00565.

Взято из http://forum.sources.ru.

Как поместить TCheckBox внутри TRichEdit?

Для использования следующего примера, необходимо создать новую форму, перетащить на неё TRichEdit (RichEdit1) и создать checkbox (acb) в событии FormCreate().

Code: Procedure TForm1.FormCreate(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Var. Acb: TCheckBox; Begin. RichEdit1.Left := 20; Acb := TCheckBox.Create(RichEdit1); Acb.Left := 30; Acb.Top := 30; Acb.Caption := 'my checkbox'; Acb.Parent := RichEdit1; End;

Отслеживаем позицию курсора в EditBox.

В форму добавляются TEditBox и TLabel, при этом TLabel постоянно показывает позицию курсора в элементе редактирования.

Code: Procedure TForm1.Edit1Change(Sender: TObject); Begin. CurPos := Edit1.SelStart; Label1.Caption := IntToStr(CurPos); End; Procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. If Key = VK_LEFT then dec(CurPos); If Key = VK_RIGHT then inc(CurPos); Label1.Caption:= IntToStr(CurPos); End;

Элемент управления Edit, реагирующий на событие OnTimer.

Как-то раз встала такая проблема: если пользователь какое-то время ничего не вводит в элемент управления Edit, то предупредить его об этом.

Code: Unit EditOnTime; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; Type. TEditOnTime = class(TEdit). Private. FInterval: integer; FTimer: TTimer; FOnTimer: TNotifyEvent; Procedure SetInterval(Interval: integer); Procedure Timer(Sender: TObject); Protected. Procedure KeyPress(var Key: char); override; Public. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; Published. Property Interval: integer read FInterval write SetInterval default 750; Property OnTimer: TNotifyEvent read FOnTimer write FOnTimer; End; Procedure Register; Implementation. //******************* RegisterComponent. // Здесь мы регистрируем компонент в IDE. Procedure Register; Begin. RegisterComponents('MPS', [TEditOnTime]); End; //******************* TEditOnTime.SetInterval. // устанавливаем интервал таймера. Procedure TEditOnTime.SetInterval(Interval: integer); Begin. FInterval := Interval; If Assigned(FTimer) then. FTimer.Interval := FInterval; End; //******************* TEditOnTime.Create. Constructor TEditOnTime.Create(AOwner: TComponent); Begin. FInterval := 750; Inherited Create(AOwner); If not (csDesigning in ComponentState) then. Try. FTimer := TTimer.Create(self); FTimer.Enabled := false; FTimer.Interval := FInterval; FTimer.OnTimer := Timer; Except. FreeAndNil(FTimer); End; End; //******************* TEditOnTime.Destroy. Destructor TEditOnTime.Destroy; Begin. If Assigned(FTimer) then FreeAndNil(FTimer); Inherited Destroy; End; //******************* TEditOnTime.OnTimer. Procedure TEditOnTime.Timer(Sender: TObject); Begin. FTimer.Enabled := false; If Assigned(FOnTimer) then FOnTimer(self); End; //******************* TEditOnTime.KeyPress. Procedure TEditOnTime.KeyPress(var Key: char); Begin. FTimer.Enabled := false; Inherited KeyPress(Key); FTimer.Enabled := (Text <> '') and Assigned(FTimer) and Assigned(FOnTimer); End; End.

Как получить координаты курсора в memo-поле?

Code: Procedure CaretPos(H: THandle; var L,C : Word); Begin. L := SendMessage(H,EM_LINEFROMCHAR,-1,0); C := LoWord(SendMessage(H,EM_GETSEL,0,0)) - SendMessage(H,EM_LINEINDEX,-1,0); End; Procedure TForm1.Button1Click(Sender: TObject); Var. LineNum,ColNum : Word; Begin. CaretPos(Memo1.Handle,LineNum,ColNum); Edit1.Text := IntToStr(LineNum) + ' ' + IntToStr(ColNum); End;

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

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

Code: Type. TMyMemo = class(TMemo). Protected. Procedure WMPaint(var Message: TWMPaint); message WM_PAINT; End;

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

Code: Procedure TMyMemo.WMPaint(var Message: TWMPaint); Var. MCanvas: TControlCanvas; DrawBounds : TRect; Begin. Inherited; MCanvas:=TControlCanvas.Create; DrawBounds := ClientRect; // Работаем с временной записью TRect. 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;

Как вставить содержимое файла в текущую позицию TMemo?

Для чтения файла будем использовать TMemoryStream, а затем используем метод SetSelTextBuf() из TMemo, чтобы вставить в него текст:

Code: Var. TheMStream : TMemoryStream; Zero : char; Begin. TheMStream := TMemoryStream.Create; TheMStream.LoadFromFile('C:\AUTOEXEC.BAT'); TheMStream.Seek(0, soFromEnd); //Буфер завершается нулём! Zero := #0; TheMStream.Write(Zero, 1); TheMStream.Seek(0, soFromBeginning); Memo1.SetSelTextBuf(TheMStream.Memory); TheMStream.Free; End;

Наборы рядов.

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

Объект сессии имеет обязательный интерфейс IOpenRowset с методом.

Function OpenRowset(const punkOuter: lUnknown; pTablelD: PDBID; plndexID: PDBID; const riid: TGUID; cPropertySets: UINT; rgPropertySets: PDBPropSetArray; ppRowset: PlUnknown): HResult; stdcall;

Который открывает необходимый набор рядов.

В зависимости от возможностей источника данных набор рядов может поддерживать различные интерфейсы. Но пять из них являются обязательными:

IRowset — обеспечивает навигацию по рядам;

IAccessor — обеспечивает представление информации о формате рядов, содержащихся в буфере набора рядов;

IRowsetinfo — позволяет получить информацию о наборах рядов (например, число рядов или число обновленных рядов);

Icoiumnsinfo — позволяет получить информацию о колонках рядов (наименование, тип данных, возможность обновления и т. д.);

IconvertType — содержит единственный метод canConvert, позволяющий определить возможность преобразования типов данных в наборе рядов.

Примечание.

В отличие от привычной практики разработки интерфейсов в рамках модели СОМ, интерфейсы OLE DB часто имеют всего один-два метода. В результате большая группа интерфейсов реализует несколько вполне стандартных функций.

Дополнительные возможности по управлению набором рядов предоставляют следующие интерфейсы:

IRowsetchange — выполняет изменения в наборе рядов (вносит изменения, добавляет новые ряды, удаляет ряды и т. д.);

IRowsetidentity — позволяет сравнивать ряды разных рядов;

IRowsetindex — обеспечивает использование индексов;

IRowsetLocate — выполняет поиск в наборе рядов;

IRowsetupdate — реализует механизм кэширования изменений.

Как узнать количество видимых строчек в TMemo?

Code: Function LinesVisible(Memo: TMemo): integer; Var. OldFont : HFont; Hand : THandle; TM : TTextMetric; Rect : TRect; Tempint : integer; Begin. Hand := GetDC(Memo.Handle); Try. OldFont := SelectObject(Hand, Memo.Font.Handle); Try. GetTextMetrics(Hand, TM); Memo.Perform(EM_GETRECT, 0, longint(@Rect)); Tempint := (Rect.Bottom - Rect.Top) div. (TM.tmHeight + TM.tmExternalLeading); Finally. SelectObject(Hand, OldFont); End; Finally. ReleaseDC(Memo.Handle, Hand); End; Result := tempint; End;

Как перехватить Ctrl-V в компоненте TMemo?

Следующий пример демонстрирует, как перехватить комбинацию Ctrl-V в компоненте TMemo и поместить в него свой текст вместо того, который в буфере обмена.

Пример:

Code: Uses ClipBrd; Procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. If ((Key = ord('V')) and (ssCtrl in Shift)) then begin. If Clipboard.HasFormat(CF_TEXT) then. ClipBoard.Clear; Memo1.SelText := 'Delphi is RAD!'; Key := 0; End; End;

Как заставить TEdit не пикать при нажатии недопустимых клавиш?

Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш.

Code: Procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); Begin. If ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then Key := #0; End;

Как автоматически расширить TEdit?

Следующий компонент автоматически подстраивается под текст, вводимый в него:

Code: Unit ExpandingEdit; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TExpandingEdit = class(TEdit). Private. FCanvas: TControlCanvas; Protected. Procedure Change; override; Public. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; End; Procedure Register; Implementation. Constructor TExpandingEdit.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); FCanvas := TControlCanvas.Create; FCanvas.Control := Self; End; Destructor TExpandingEdit.Destroy; Begin. FCanvas.Free; Inherited Destroy; End; Procedure TExpandingEdit.Change; Const. EditMargin = 8; Var. W: Integer; Begin. Inherited Change; If not HandleAllocated then Exit; FCanvas.Font := Font; W := FCanvas.TextWidth(Text) + (2 * EditMargin); If (Width < W) then Width := W; End; Procedure Register; Begin. RegisterComponents('Samples', [TExpandingEdit]); End; End.

Как очистить все окошки редактирования на форме?

Code: Procedure ClearEdits; Var i : Integer; Begin. For i := 0 to ComponentCount-1 do. If (Components[i] is TEdit) then. (Components[i] as TEdit).Text := ''; End;

Как перехватить клавишу табуляции (Tab) в TEdit?

Это можно давольно легко сделать переопределив на форме процедуру CMDialogKey. Чтобы посмотреть как это работает, поместите на форму Edit и введите следующий код:

Code: Procedure CMDialogKey(Var Msg: TWMKey); Message CM_DIALOGKEY; ... Procedure TForma.CMDialogKey(Var Msg: TWMKEY); Begin. If (ActiveControl is TEdit) and. (Msg.Charcode = VK_TAB) then. Begin. ShowMessage('Нажата клавиша TAB?'); End; Inherited; End;

Как поместить данные в RichEdit контрол?

Code: Unit dbrich; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, DB, DBTables, Menus, ExtCtrls, Mask, Buttons, DBCtrls; //Замечание: вызывать Tablex.Edit необходимо перед изменением свойства paragraph. Type. TDBRichEdit = class(TRichEdit). Private. FDataLink: TFieldDataLink; FAutoDisplay: Boolean; FFocused: Boolean; FMemoLoaded: Boolean; FPaintControl: TPaintControl; Procedure DataChange(Sender: TObject); Procedure EditingChange(Sender: TObject); Function GetDataField: string; Function GetDataSource: TDataSource; Function GetField: TField; Function GetReadOnly: Boolean; Procedure SetDataField(const Value: string); Procedure SetDataSource(Value: TDataSource); Procedure SetReadOnly(Value: Boolean); Procedure SetAutoDisplay(Value: Boolean); Procedure SetFocused(Value: Boolean); Procedure UpdateData(Sender: TObject); Procedure WMCut(var Message: TMessage); message WM_CUT; Procedure WMPaste(var Message: TMessage); message WM_PASTE; Procedure CMEnter(var Message: TCMEnter); message CM_ENTER; Procedure CMExit(var Message: TCMExit); message CM_EXIT; Procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); Message WM_LBUTTONDBLCLK; Procedure WMPaint(var Message: TWMPaint); message WM_PAINT; Procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; Protected. Procedure Change; override; Procedure KeyDown(var Key: Word; Shift: TShiftState); override; Procedure KeyPress(var Key: Char); override; Procedure Notification(AComponent: TComponent; Operation: TOperation); override; Procedure WndProc(var Message: TMessage); override; Public. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; Procedure LoadMemo; Property Field: TField read GetField; Published. Property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay. Default True; Property DataField: string read GetDataField write SetDataField; Property DataSource: TDataSource read GetDataSource write SetDataSource; Property ReadOnly: Boolean read GetReadOnly write SetReadOnly. Default False; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Data Controls', [TDBRichEdit]); End; {Mostly copied from DBMemo}. Constructor TDBRichEdit.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); Inherited ReadOnly := True; FAutoDisplay := True; FDataLink := TFieldDataLink.Create; FDataLink.Control := Self; FDataLink.OnDataChange := DataChange; FDataLink.OnEditingChange := EditingChange; FDataLink.OnUpdateData := UpdateData; FPaintControl := TPaintControl.Create(Self, 'EDIT'); End; Destructor TDBRichEdit.Destroy; Begin. FPaintControl.Free; FDataLink.Free; FDataLink := nil; Inherited Destroy; End; Procedure TDBRichEdit.Notification(AComponent: TComponent; Operation: TOperation); Begin. Inherited Notification(AComponent, Operation); If (Operation = opRemove) and (FDataLink <> nil) and. (AComponent = DataSource) then DataSource := nil; End; Procedure TDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState); Begin. Inherited KeyDown(Key, Shift); If FMemoLoaded then. Begin. If (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then. FDataLink.Edit; End else. Key := 0; End; Procedure TDBRichEdit.KeyPress(var Key: Char); Begin. Inherited KeyPress(Key); If FMemoLoaded then. Begin. If (Key in [#32..#255]) and (FDataLink.Field <> nil) and. Not FDataLink.Field.IsValidChar(Key) then. Begin. MessageBeep(0); Key := #0; End; Case Key of. ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: FDataLink.Edit; #27: FDataLink.Reset; End; End else. Begin. If Key = #13 then LoadMemo; Key := #0; End; End; Procedure TDBRichEdit.Change; Begin. With FdataLink do. Begin. {if Assigned(FdataLink) and (Assigned(DataSource))and. (DataSource.State = dsBrowse) then. Edit; } {make sure edits on Attributes change}. If FMemoLoaded then Modified; End; FMemoLoaded := True; Inherited Change; End; Function TDBRichEdit.GetDataSource: TDataSource; Begin. Result := FDataLink.DataSource; End; Procedure TDBRichEdit.SetDataSource(Value: TDataSource); Begin. FDataLink.DataSource := Value; If Value <> nil then Value.FreeNotification(Self); End; Function TDBRichEdit.GetDataField: string; Begin. Result := FDataLink.FieldName; End; Procedure TDBRichEdit.SetDataField(const Value: string); Begin. FDataLink.FieldName := Value; End; Function TDBRichEdit.GetReadOnly: Boolean; Begin. Result := FDataLink.ReadOnly; End;

Команды.

Программные средства ADO были бы неполными, если бы не имели возможности использовать для работы с данными язык SQL. Операторы DML и DDL, ряд специальных операторов ADO носят общее название текстовых команд.

Объект-команда инкапсулирует саму текстовую команду и механизм обработки и передачи команды. Объект команды выполняет следующие операции:

Разбор текста команды;

Связывание команды с источником данных;

Оптимизацию команды;

Передачу команды источнику данных.

Главный интерфейс объекта команды icommand имеет три метода:

Function Cancel: HResult; stdcall;

Отменяет выполнение команды;

Function Execute(const punkOuter: lUnknown; const riid: TGUID; var pParams: DBPARAMS; pcRowsAffected: PInteger; ppRowset: PlUnknown): HResult; stdcall;

Исполняет команду;

Function GetDBSession(const riid: TGUID; out ppSession: lUnknown): HResult; stdcall;

Возвращает ссылку на интерфейс сессии, вызвавший данную команду.

Помимо основного, объект команды обеспечивает доступ к дополнительным интерфейсам:

ICommandPrepare — содержит два метода (Prepare И Unprepare) для подготовки команды;

IcommandProperties — задает для команды свойства, которые должны поддерживаться возвращаемым командой набором данных;

ICommandText — управляет текстом команды (этот интерфейс обязателен для объекта команды);

IcommandwithParameters — обеспечивает работу с параметрами команды.

Как осуществить ввод текста в компоненте Label?

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

Первый шаг, это кнопка, которая может отображать вводимый текст:

Code: Type. TInputButton = class(TButton). Private. Procedure WmChar (var Msg: TWMChar); Message wm_Char; End; Procedure TInputButton.WmChar (var Msg: TWMChar); Var. Temp: String; Begin. If Char (Msg.CharCode) = #8 then. Begin. Temp := Caption; Delete (Temp, Length (Temp), 1); Caption := Temp; End. Else. Caption := Caption + Char (Msg.CharCode); End;

Цветные ячейки в StringGrid / DBGrid?

Автор: Alex Schlecht.

StringGrids / DBGrids с цветными ячейками смотрятся очень красиво, и Вы можете информировать пользователя о важных данных внутри Grid.

Совместимость: все версии Delphi.

К сожалению, невозможно применить один и тот же метод к StringGrids и к DBGrids. Итак сперва рассмотрим как это сделать в StringGrid:

1. StringGrid.

=============

Для раскрашивания будем использовать событие "OnDrawCell". Следующий код показывает, как сделать в Grid красный бэкраунд. Бэкграунд второй колонки будет зелёным.

Code: Procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); Const //сдесь определяем Ваш цвет. Так же можно использовать. //цвета по умолчанию. ClPaleGreen = TColor($CCFFCC); ClPaleRed = TColor($CCCCFF); Begin. //Если ячейка получает фокус, то нам надо закрасить её другими цветами. If (gdFocused in State) then begin. StringGrid1.Canvas.Brush.Color := clBlack; StringGrid1.Canvas.Font.Color := clWhite; End. Else //Если же ячейка теряет фокус, то закрашиваем её красным и зелёным. If ACol = 2 //Вторая колонка будет зелёной , другие - ячейки красными. Then StringGrid1.Canvas.Brush.color := clPaleGreen. Else StringGrid1.canvas.brush.Color := clPaleRed; //Теперь закрасим ячейки, но только, если ячейка не Title- Row/Column. //Естевственно это завит от того, есть у Вас title-Row/Columns или нет. If (ACol > 0) and (ARow>0) then. Begin. //Закрашиваем бэкграунд. StringGrid1.canvas.fillRect(Rect); //Закрашиваем текст (Text). Также здесь можно добавить выравнивание и т.д.. StringGrid1.canvas.TextOut(Rect.Left,Rect.Top,StringGrid1.Cells[ACol,ARow]); End; End;

Как снять выделение в StringGrid?

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

Code: Procedure TForm1.GridClean(Sender: TObject); Var hGridRect: TGridRect; Begin. HGridRect.Top := -1; HGridRect.Left := -1; HGridRect.Right := -1; HGridRect.Bottom := -1; (Sender as TStringgrid).Selection := hGridRect; End;

Следующий код можно использовать например в событии грида OnExit:

Code: Var MyGrid: TStringGrid; ... GridClean(MyGrid);

Символы разного цвета в StringGrid.

Ниже представлен юнит, который позволяет поместить текст в String Grid с символами различного цвета:

Code: Unit Strgr; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Grids, StdCtrls, DB; Type. TForm1 = class(TForm). StringGrid1: TStringGrid; Procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState); Const. CharOffset = 3; Begin. With StringGrid1.canvas do. Begin. Font.color := clMaroon; Textout(rect.left + CharOffset, rect.top + CharOffset, 'L'); Font.color := clNavy; Textout(rect.left + CharOffset + TextWidth('L'), Rect.top + CharOffset, 'loyd'); End; End; End.

Сортировка StringGrid.

Code: Procedure GridSort(StrGrid: TStringGrid; NoColumn: Integer); Var Line, PosActual: Integer; Row: TStrings; Begin. Renglon := TStringList.Create; For Line := 1 to StrGrid.RowCount-1 do. Begin. PosActual := Line; Row.Assign(TStringlist(StrGrid.Rows[PosActual])); While True do. Begin. If (PosActual = 0) Or (StrToInt(Row.Strings[NoColumn-1]) >= StrToInt(StrGrid.Cells[NoColumn-1,PosActual-1])) then. Break; StrGrid.Rows[PosActual] := StrGrid.Rows[PosActual-1]; Dec(PosActual); End; If StrToInt(Row.Strings[NoColumn-1]) < StrToInt(StrGrid.Cells[NoColumn-1,PosActual]) then. StrGrid.Rows[PosActual] := Row; End; Renglon.Free; End;

Удаление колонки в StringGrid.

Code: Procedure GridRemoveColumn(StrGrid: TStringGrid; DelColumn: Integer); Var Column: Integer; Begin. If DelColumn <= StrGrid.ColCount then. Begin. For Column := DelColumn To StrGrid.ColCount-1 do. StrGrid.Cols[Column-1].Assign(StrGrid.Cols[Column]); StrGrid.ColCount := StrGrid.ColCount-1; End; End;

©Drkb::00600.

Code: Procedure RemoveColumn(SG : TStringGrid; ColNumber : integer); Var Column : integer; Begin. ColNumber := abs(ColNumber); If ColNumber <= SG.ColCount then begin. For Column := ColNumber to SG.ColCount - 2 do begin. SG.Cols[Column].Assign(SG.Cols[Column + 1]); SG.Colwidths[Column] := SG.Colwidths[Column + 1]; End; SG.ColCount := SG.ColCount - 1; End; End;

Добавление колонки в StringGrid.

Code: Procedure GridAddColumn(StrGrid: TStringGrid; NewColumn: Integer); Var Column: Integer; Begin. StrGrid.ColCount := StrGrid.ColCount+1; For Column := StrGrid.ColCount-1 downto NewColumn do. StrGrid.Cols[Column].Assign(StrGrid.Cols[Column-1]); StrGrid.Cols[NewColumn-1].Text := ''; End;

©Drkb::00601.

Code: Procedure AddColumn(SG : TStringGrid; AtColNumber : integer; ColWidth : integer = 0); Var Column : integer; Wdth : integer; Begin. AtColNumber := abs(AtColNumber); SG.ColCount := SG.ColCount + 1; If abs(ColWidth) = 0 then. Wdth := SG.DefaultColWidth. Else. Wdth := ColWidth; If AtColNumber <= SG.ColCount then begin. For Column := SG.ColCount - 1 downto AtColNumber + 1 do begin. SG.Cols[Column].Assign(SG.Cols[Column - 1]); SG.Colwidths[Column] := SG.Colwidths[Column - 1]; End; SG.Cols[AtColNumber].Text := ''; SG.Colwidths[AtColNumber] := Wdth; End; End;

Как перемещать строки и колонки в StringGrid?

Пользователь может перемещать строки и колонки StringGrid при помощи мышки. Можно ли это сделать программно? В описании TCustomGrid можно увидеть методы MoveColumn и MoveRow, однако они скрыты в TStringGrid. Но нам ничего не мешает просабклассить TStringGrid и объявить эти методы как public:

Code: Type. TStringGridX = class(TStringGrid). Public. Procedure MoveColumn(FromIndex, ToIndex: Longint); Procedure MoveRow(FromIndex, ToIndex: Longint); End;

Чтобы воспользоваться этими методами, достаточно вызвать соответствующий метод предка:

Code: Procedure TStringGridX.MoveColumn(FromIndex, ToIndex: Integer); Begin. Inherited; End; Procedure TStringGridX.MoveRow(FromIndex, ToIndex: Integer); Begin. Inherited; End;

Этот компонент не нужно регистрировать в палитре компонентов. Просто используйте потомка TStringGrid или любого TCustomGrid, и вызывайте его методы:

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. TStringGridX(StringGrid1).MoveColumn(1, 3); End;

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

Ниже приведён примен кода, который позволяет автоматически подогнать размер колонки в компененте TStringGrid, под размер самой длинной строки текста в колонке:

Code: Procedure AutoSizeGridColumn(Grid : TStringGrid; Column : integer); Var. I : integer; Temp : integer; Max : integer; Begin. Max := 0; For i := 0 to (Grid.RowCount - 1) do begin. Temp := Grid.Canvas.TextWidth(grid.cells[column, i]); If temp > max then max := temp; End; Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. AutoSizeGridColumn(StringGrid1, 1); End;

Реализация ADO в Delphi.

Механизм доступа к данным через ADO и многочисленные объекты и интерфейсы реализованы в VCL Delphi в виде набора компонентов, расположенных на странице ADO. Все необходимые интерфейсы, обеспечивающие работу компонентов, объявлены и описаны в файлах OleDB.pas и ADODB.pas в папке \Delphi7\Source\Vcl.

Компонент TADOConnection вобрал возможности перечислителя, источника данных и сессии с возможностями обслуживания транзакций.

Текстовые команды ADO реализованы в компоненте TADOCommand.

Наборы рядов (нотация Microsoft) можно получить при помощи компонентов TADOTable, TADOQuery, TADOstoredProc. Каждый из них реализует способ доступа к конкретному типу представления данных в хранилище. Далее по тексту, применительно к компонентам Delphi, совокупность возвращаемых из хранилища данных строк будем называть набором записей, что соответствует документации Inprise (см. www.borland.com или www.borland.ru) и стилю изложения предыдущих глав.

Набор свойств и методов компонентов ADO обеспечивает реализацию всех необходимых приложению БД функций. Способы использования компонентов ADO немногим отличаются от стандартных компонентов VCL доступа к данным (см. гл. 11).

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

Компоненты доступа к данным ADO могут использовать два варианта подключения к хранилищу данных. Это стандартный метод ADO и стандартный метод Delphi.

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

Свойство connectionstring предназначено для хранения информации о соединении с объектом ADO. В нем через точку с запятой перечисляются все необходимые параметры. Как минимум, это должны быть имена провайдера соединения или удаленного сервера:

Connectionstring:='Remote Server=ServerName;Provider=ProviderName';

При необходимости указываются путь к удаленному провайдеру:

Connectionstring:='Remote Provider=ProviderName';

И параметры, необходимые провайдеру:

'User Name=User_Name;Password=Password';

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

Поэтому целесообразно реализовать механизм соединения ADO через специальный компонент — TADOConnection. Этот компонент открывает соединение, также заданное свойством Connectionstring (см. выше), и предоставляет разработчику дополнительные средства управления соединением.

Компоненты, работающие с хранилищем данных ADO через данное соединение, подключаются к компоненту TADOConnection при помощи свойства.

Property Connection: TADOConnection;

Которое имеет каждый компонент, инкапсулирующий набор данных ADO.

Многострочные ячейки в StringGrid.

Сперва необходимо установить свойство DefaultDrawing в False. Далее, необходимо вставить следующий код в обработчик события OnDrawCell:

Code: Procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState); Var. Line1: string; Line2: string; Ptr: integer; Padding: integer; HGrid: TStringGrid; Begin. HGrid:= (Sender as TStringGrid); Ptr := Pos(';', hGrid.Cells[Col, Row]); If ptr > 0 then. Begin. Line1 := Copy(hGrid.Cells[Col, Row], 1, ptr - 1); Line2 := Copy(hGrid.Cells[Col, Row], ptr + 1, Length(hGrid1.Cells[Col,Row]) - ptr); End. Else Line1 := hGrid.Cells[Col, Row]; HGrid.Canvas.FillRect(Rect); HGrid.Canvas.TextOut(Rect.Left, Rect.Top + 2, Line1); If ptr > 0 then. HGrid.Canvas.TextOut(Rect.Left, Rect.Top - HGrid.Canvas.Font.Height + 3, Line2); End;

Дельфи 2005 - отчёт, как я был на конференции Борланда.

Вчера (21 декабря 2005 года) был на конференции Борланда посвященной Дельфи 2005. Конференцию проводил один из менеджеров команды разработчиков John Kastor, сама конференция проводилась в штате Висконсин, город Милуоки, это примерно в 150 км от моего дома.

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

Сразу бросилось в глаза что Дельфи 2005 по большей части аутсорсинговый продукт и Джон назвал 7 стран в которых велась разработка - Россия (СПБ) на первом месте, учитывая как легко и правильно он прочитал мою и моего друга имя и фамилию он с русскими работает достаточно тесно и долго.

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

Первый момент: упор на единую интегрированную среду разработки для Дельфи, Дельфи.Net, С# и ASP.NET. В дальнейшем туда будет добавлен C++ и возможно Kylix (тут отдельный разговор). Т.е. уже не будет отдельных сред разработки, компилляторы и дебаггеры подключаются на лету, Есть возможность использовать разнотипные компилляторы и дебаггеры одновременно. Насколько я понял борландевцев - удар был сделан на переделку архитектуры и концепции самой среды так, чтобы подключение нового языка или платформы было максимально лёгким, в дальнейшем планируется при появлении новых популярных языков - легко интегрировать их в единую среду разработки.

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

1) Переименование любых идентификаторов глобально, во всех модулях по ссылкам. Т.е. любую переменную в коде можно переименовать из "Foo" в "TestMethod" и эта переменная будет переименована во всех местах где она уже описана.

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

3) Автоматическая очистка кода от неиспользуемых идентификаторов и т.п.

Были ещё пункты, я все не запомнил, за 2.5 часа он смог лишь очень бегло коснуться всех новаций.

Третий момент: документация кода. Автоматические генераторы XML которые перерабатывают исходный код проекта, определяют структуру связей объектов и методов, выцепляют из кода комментарии и генерируют XML документ для исходных кодов, на базе которого очень легко создавать документацию к исходникам.

Четвёртый момент: средства для тестирования проектов. Буквально одним кликом создаётся полный план тестирования с комментариями внутри кода что и где тестировать - типа в начале процедуры проверить передаваемые данные, в конце выходные, всякие скользкие места.... Документы для тестировщиков делаются динамическими, по мере тестирования тестировочные комментарии автоматически удаляются, по мере правки кода меняются и сами тестировочные документы.

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

Были существенно доработанны ADO и dbExpress, добавлена ADO.NET и существенно доработана BDE для .NET. Был удивлён, но борландовцы утверждают что будут и впредь двигать BDE для локальных баз данных. Однако они сворачивают поддержку BDE серверных баз, так из BDE был исключён окончательно SQL-Link. Были сильно доработаны средства работы с базами данных, включая и массовые реструктуризации базы данных, копирование таблиц и т.п. вне зависимости от типа базы данных (если я правильно понял, то нечно типа BatchMove но работающем в ADO/dbExpress). BDE теперь не требует установки (наконец-то!) - достаточно просто положить нужные библиотеки в доступное место (только я не уверен что этио под все платформы, возможно это только под .NET). Существенно улучшена поддержка BLOB полей.

В языке (и Дельфи под win32) появилась .NET фишка - оператор For...in...do позволяющий проходить циклом по элементам коллекции ( и по-моему спискам тоже) что то типа:

For item in List1 do.

Begin.

End;

Появилась перезагрузка операторов, record method, nested types, parametrizided types, multicast events.

Добавлена поддержка Multitier под .NET, в общем-то идеология MIDAS осталась, просто немного доработана и расширена.

Очень много сделано в плане оптимизации кэширования клиент-серверных техноголий, например в ASP.NET при навигации браузера на страницу назад не приводит к перезапросам в таблицах и т.п. Вообще в ASP.NET очень много доработано, складывается вечатление, что разработка web теперь почти не отличается от разработки локальных приложений - на web форму можно бросить DBGrid и DBNavigator и они сразу будут работать как в локальном приложении, можно побросать свои кнопки и обрабатывать события на сервере, появился даже ActionList для web форм, мало того, сложилось впечатление что и перенос кода с обычного приложения на web теперь очень облегчён, а если он на платформе .NET то вообще почти автоматично.

С++ под Win32 платформу - планируется включить ещё до выхода следующего релиза Дельфи. Кстати следующий релиз будет одновременно с выходом .NET 2х - борландовцы подчёркивали что они работают совместно с MS и обмениваются информацией по ходу дела. Кстати Борланд является единственным сертифицированным дистрибьютером .NET помимо MS.

Компоненты ECO (Enterprise Core Objects)- это вообще класс! Я проникся! Идея офигенная (впрочем не новая)... При нас Джон берёт тестовую MS базу данных Northwind и тремя кликами мышки делает:

1) Полный UML структуры таблиц со всеми ключами и взаимосвязами.

2) Весь скелет классов для приложения соответственно этой структуре.

3) Целиком готовое приложение для редактирования этой таблицы из десятков (если не сотен!) форм со всеми элементами, очень круто. Можно в собственном репозитории определить свои дизайны на любой вкус и на случаи жизни. Кто работал с базми данных - меня поймёт, приложение на которое в ручную тратится несколько недель делается за 1-2 минуты, пусть оно не совершенное, но оно уже сразу рабочее! День-два работы "напильником" и готово, вместо месяцев... Это впечатлило-так впечатлило. Причём исходная аза данных не имеет значения - всё будет работать прекрастно с любыми базами данных при любом доступе. В поставку входит более 60 примеров работы с ECO. ECO были уже для предыдущей Дельфи, но в этом релизе борландовцы утверждают что они были существенно доработаны, многое добавлено. Сделаны ECO и для ASP.NET.

Очень существенно доработан Дебаггер под Win32 и .NET - всего я не упомнил, но по список доработок был внушительным.

Существенно дополнили средства планированя приложений, лёгкое трансформирование UML <-> код, стредства для Reverse Engeneering и облегчение переписывания кода на другой язык.

Поразили факты разработки самого Дельфи 2005 - он разрабатывался 3.5 года, причём 2.5 года производилось планировние, и только 1 год - программирование. Причём точность с которой за отведенное время было разработано рассчитанное количество нововведений составила 1%! Это на мой взгляд - на пределе возможностей для продуктов такого уровня сложности.

(с) Vit (Сссылка на оригинал статьи при перепечатке: http://forum.vingrad.ru/index.php?showtopic=37936 обязательна, это единственное ограничение при перепечатке статьи).

©Drkb::04639.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Как защитить запись в DBGrid от удаления?

Поместите следующий код в событие OnKeyDown в DBGrid.

Code: Procedure TForm1.DBGrid1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. If (ssctrl in shift) and (key=vk_delete) then key:=0; End;

Как изменить шрифт определённой строки в DBGrid?

Для этого надо воспользоваться событием OnDrawDataCell в dbgrid.

Code: Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); Begin. // If the record's CustNo is 4711 draw the entire row with a. // line through it. (set the font style to strike out). If (Sender as TDBGrid).DataSource.DataSet.FieldByName('CustNo').AsString = '4711' then. With (Sender as TDBGrid).Canvas do. Begin. FillRect(Rect); // Set the font style to StrikeOut. Font.Style := Font.Style + [fsStrikeOut]; // Draw the cell right aligned for floats + offset. If (Field.DataType = ftFloat) then. TextOut(Rect.Right - TextWidth(Field.AsString) - 3, Rect.Top + 3, Field.AsString). // Otherwise draw the cell left aligned + offset. Else. TextOut(Rect.Left + 2, Rect.Top + 3, Field.AsString); End; End;

INI-файлы (чтение/запись).

Code: Function ReadIni(ASection, AString: string): string; Var. SIniFile: TIniFile; SPath: string[60]; Const. S = 'xyz'; { стандартная строка для выдачи ошибок чтения }. Begin. GetDir(0, sPath); { текущий каталог }. SIniFile := TIniFile.Create(sPath + '\Name.INI'); Result := sIniFile.ReadString(ASection, AString, S); { [Section] String=Value}. SIniFile.Free; End; Procedure WriteIni(ASection, AString, AValue: string); Var. SIniFile: TIniFile; SPath: string[60]; Begin. GetDir(0, sPath); { текущий каталог }. SIniFile := TIniFile.Create(sPath + '\Name.INI'); SIniFile.WriteString(ASection, AString, AValue); { [Section] String=Value }. SIniFile.Free; End; {ReadSection считывает все пункты указанной секции - т.е. ключи перед знаком "=". ReadSectionValues полностью считывает все строки указанной секции, т.е. Punkt=xyz }.

Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid?

Для этого необходимо переопределить метод Paint. Внутри метода Paint Вы должны вызвать API процедуру SetScrollRange для установки минимального и максимального значений скроллирования в ноль (тем самым запретив скроллбар), а затем вызвать inherited. Следующий код, это unit содержащий новый компонент под названием TNoScrollBarDBGrid, который делает это.

Code: Type. TNoScrollBarDBGrid = class(TDBGrid). Private. Protected. Procedure Paint; override; Public. Published. End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Samples', [TNoScrollBarDBGrid]); End; { TNoScrollBarDBGrid }. Procedure TNoScrollBarDBGrid.Paint; Begin. SetScrollRange(Handle, SB_VERT, 0, 0, false); Inherited; End;

Как копировать и вставлять картинки через буфер обмена?

Некоторые функции для копирования и вставки Bitmap-объектов через буфер обмена.

Code: Function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer; Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean; Var. TempBitmap: HBitmap; Begin. Result := False; CopyDC := 0; CopyBitmap := 0; If DC <> 0 then. Begin. CopyDC := CreateCompatibleDC(DC); If CopyDC <> 0 then. Begin. CopyBitmap := CreateCompatibleBitmap(DC, Width, Height); If CopyBitmap <> 0 then. Begin. TempBitmap := CopyBitmap; CopyBitmap := SelectObject(CopyDC, CopyBitmap); Result := BitBlt(CopyDC, 0, 0, Width, Height, DC, Left, Top, Rop); CopyBitmap := TempBitmap; End; End; End; End;

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

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

Code: 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;

Как узнать значения, которые пользователь вводит в TDBGrid?

Code: Procedure TForm1.DBGrid1KeyUp(Sender: TObject; Var Key: Word; Shift: TShiftState); Var. B: byte; Begin. For B := 0 to DBGrid1.ControlCount - 1 do. If DBGrid1.Controls[B] is TInPlaceEdit then. Begin. With DBGrid1.Controls[B] as TInPlaceEdit do. Begin. Label1.Caption := 'Text = ' + Text; End; End; End;

Сортировка DBGrid по клику на колонке?

На форме расположены TQuery, TDatasource и TDbGrid связанные вместе.

QuerySQL, это глобальная строка, которая содержит SQL-выражение.

Code: Begin. QuerySQL := 'SELECT * FROM Customer.DB'; Query1.SQL.Add(QuerySQL); Query1.Open; End;

В DBGrid в событии OnTitleClick, достаточно добавить ORDER-BY к sql-строке и обновить запрос.

Code: Procedure TForm1.DBGrid1TitleClick(Column: TColumn); Begin. Witzh Query1 do. Begin. DisableControls; Close; SQL.Clear; SQL.Add(QuerySQL); SQL.Add('ORDER BY ' + Column.FieldName); Open; // Восстанавливаем настройки заголовка, иначе всё станет синим. DBGrid1.Columns.RestoreDefaults; Column.Title.Font.Color := clBlue; EnableControls; End; End;

Как показать содержимое Memo-поля в DBGrid?

Поумолчанию, DBGrid не может отображать memo-поля. Однако, проблему можно решить при помощи события OnDrawDataCell в DBGrid.

Code: Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const. Rect: TRect; Field: TField; State: TGridDrawState); Var. P: array [0..50] of char; {размер массива, это количество необходимых символов}. Bs: TBlobStream; {из memo-поля}. HStr: String; Begin. If Field is TMemoField then. Begin. With (Sender as TDBGrid).Canvas do. Begin {Table1Notes это TMemoField}. Bs := TBlobStream.Create(Table1Notes, bmRead); FillChar(P,SizeOf(P),#0); {строка завершается нулём}. Bs.Read(P, 50); {читаем 50 символов из memo в blobStream}. Bs.Free; HStr := StrPas(P); While Pos(#13, hStr) > 0 do {удаляем переносы каретки и}. HStr[Pos(#13, hStr)] := ' '; While Pos(#10, hStr) > 0 do {отступы строк}. S[Pos(#10, hStr)] := ' '; FillRect(Rect); {очищаем ячейку}. TextOut(Rect.Left, Rect.Top, hStr); {заполняем ячейку данными из memo}. End; End; End;

Как остановить автодобавление из DBGrid?

Добавьте в событие "BeforeInsert" Вашего TTables следующие строки:

Code: Procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset); Begin. Abort; End;

Как изменить число фиксированных колонок в TDbGrid?

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. TStringGrid(DbGrid1).FixedCols := 2; End;

Наборы данных ADO.

На странице ADO Палитры компонентов Delphi, кроме компонентов соединения есть стандартные компоненты, инкапсулирующие набор данных и адаптированные для работы с хранилищем данных ADO (рис. 19.7). Это компоненты:

TADODataSet — универсальный набор данных;

ТАDОтаь1е — таблица БД;

TADOQuery — запрос SQL;

TADOstoredProc — хранимая процедура.

Как и положено для компонентов, инкапсулирующих набор данных, их общим предком является класс TDataSet, предоставляющий базовые функции управления набором данных.

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

Как показать DbGrid в режиме disabled?

Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу управления (в данном случае TDBGrid) запрещен (disabled).

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. DbGrid1.Enabled := false; DbGrid1.Font.Color := clGray; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. DbGrid1.Enabled := true; DbGrid1.Font.Color := clBlack; End;

Критерии выбора базы данных (статья).

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

1)Размер базы данных - параметер весьма критичен!

- несколько мегабайт: MS Access, XML, CSV, MS Excel, Парадокс, Dbase, Foxpro/VFP, MySQL, PostgreSQL.

- до сотни мегабайт: MS Access, Парадокс, Dbase, Foxpro/VFP, MySQL, PostgreSQL, Interbase.

- гигабайты: MySQL, PostgreSQL, Interbase, Informix, MS SQL Server, Oracle, SyBase, DB/2.

- сотни гигабайт и больше: MS SQL Server, Oracle, SyBase, DB/2.

2) Количество одновременных пользователей - пожалуй это самый критичный параметер!

- эксклюзивный доступ одного пользователя: MS Excel, XML, CSV, Парадокс, Dbase, Foxpro/VFP, MS Access, MySQL, PostgreSQL.

- до десятка пользователей: Парадокс, Dbase, Foxpro/VFP, MS Access, MySQL, PostgreSQL.

- несколько десятков пользователей: MySQL, PostgreSQL, Interbase, Informix.

- сотни пользователей: PostgreSQL, Interbase, MS SQL Server, Oracle, SyBase, DB/2.

- тысячи пользователей: MS SQL Server, Oracle, SyBase, DB/2.

3) Цена базы данных - параметер весьма критичен!

- полностью бесплатно: XML, CSV, MySQL, PostgreSQL, Interbase (некоторые клоны).

- формат бесплатен, для разработки желательно купить дешёвую всего одну систему:MS Excel, Парадокс, Dbase, Foxpro/VFP, MS Access.

- дешёвые сервера: Interbase (некоторые клоны), Informix, старые версии SyBase.

- дорогие сервера: MS SQL Server, Oracle, SyBase.

- сверхдорогие сервера: DB/2.

4) Платформа - параметер весьма критичен!

- любая: XML, CSV.

- Windows only: MS SQL Server, SyBase, Парадокс, Dbase, Foxpro/VFP, MS Access, MS Excel.

- Unix/Linux only:PostgreSQL.

- Windows+Linux:Oracle, DB/2, Interbase, MySQL.

- Мейнфреймы: DB/2.

- Кластеры:MS SQL Server, Oracle, SyBase, DB/2.

5) язык программирования - рекомендательный параметер:

- Языки от Microsoft: MS SQL Server, SyBase, Foxpro/VFP, MS Access, MS Excel.

- Языки от Борланда: MS SQL Server, Interbase, Парадокс, MS Access.

- Системы под Linux: Oracle, DB/2, Interbase, MySQL, PostgreSQL, XML.

6) Тип программы - рекомендательный параметер:

- маленький web сервер: MySQL.

- мощный web сервер: MS SQL Server, Oracle, SyBase, DB/2.

- локальная утилита: Парадокс, Dbase, Foxpro/VFP, MS Access, MS Excel, XML, CSV.

- сложная система:MS SQL Server, Oracle, SyBase, DB/2, Interbase, Informix.

7) Защита данных - параметер весьма критичен!

- никакая: MS Excel, XML, CSV.

- очень слабая: Парадокс, Dbase, Foxpro/VFP, MS Access.

- сильная:MS SQL Server, Oracle, SyBase, DB/2, Interbase, Informix, MySQL, PostgreSQL.

8) Мощность языка SQL, возможности базы данных (View, Stored procedures, agents, backup, репликации и т.п.) - параметер весьма критичен!

- очень слабые: MS Excel, XML, CSV.

- слабые: Парадокс, Dbase, Foxpro/VFP, MS Access, MySQL.

- развитые:Interbase, Informix, PostgreSQL.

- мощные:MS SQL Server, Oracle, SyBase, DB/2.

9) Требования к железу - параметер весьма критичен!:

- неприхотливые:MySQL, PostgreSQL, Парадокс, Dbase, Foxpro/VFP, MS Access,MS Excel, XML, CSV.

- чуствительные: Interbase, Informix, SyBase.

- требуют отдельных мощных серверов с большой RAM, желательно на нескольких процессорах: MS SQL Server, Oracle, DB/2.

10) Способ доступа - рекомендательны параметер:

- ODBC: CSV.

- OLE DB/ADO: MS Excel,MS Access,MS SQL Server, SyBase.

- DAO:MS Excel,MS Access,Foxpro/VFP.

- BDE:Парадокс, Dbase,Foxpro/VFP.

- DBExpress:MySQL, Interbase, Oracle, DB/2.

- Собственные:XML,MySQL,Interbase, Informix, PostgreSQL, Oracle, SyBase, DB/2.

11) Сложность настройки, установки, администрирования, желательность специально обученного персонала для администрирования - параметер весьма критичен!:

- никаких сложностей, администрирование не требуется: MS Excel, XML, CSV.

- минимальные либо небольшие сложности: Парадокс, Dbase, Foxpro/VFP, MS Access.

- первоначальная настройка плюс минимальная поддержка: PostgreSQL, MySQL.

- требуются специальные знания в достаточно большом объёме: Interbase, Informix.

- желательно наличие специалиста по базам данных: MS SQL Server, Oracle, SyBase, DB/2.

12) Стоимость программистов и администраторов - параметер весьма критичен!:

- небольшая: MS Excel, XML, CSV, Парадокс, Dbase, Foxpro/VFP, MS Access, PostgreSQL, MySQL.

- значительная: Interbase, Informix, SyBase.

- высокая и очень высокая: MS SQL Server, Oracle, DB/2.

13) Перспективы развития базы данных, стабильность фирм-хозяев, выпуск новых релизов и т.п-рекомендательный параметер.

- "мёртвые" или почти мёртвые базы: Парадокс, Dbase, Foxpro/VFP, CSV.

- медленно развивающиеся, сомнительные перспективы, фирмы производители не устойчиво стоящие на ногах: Interbase, Informix, PostgreSQL, SyBase.

- Гарантированно продолжение, только развивать дальше некуда: MS Excel, MS Access, DB/2.

- Бурно развивающиеся базы, частые релизы и апдейты: MS SQL Server, Oracle, XML, MySQL.

14) Трудоёмкость и возможность перевода программы от одной базы к другой - рекомендательный параметер:

Лёгкие переходы:

Парадокс<->Dbase<->Foxpro/VFP.

CSV->MS Excel.

SyBase -> MS SQL Server.

MS Excel->MS Access.

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

©Drkb::02417.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Работа с типом Comp.

Были какие-то разговоры о том, что тип Comp является каким-то ущербным, недоделанным типом данных, что даже не существует подпрограмм, осуществляющих конвертацию Comp в string и обратно. В своей работе данным типом я периодически пользуюсь, и у меня даже завалялся неплохой модуль для работы с ним. Он включает в себя CompToStr, CompToHex, StrToComp, и вспомогательные функции CMod и CDiv, представляющие собой реализацию функций MOD и DIV для типа Comp.

Элементы спектрального анализа (Фурье, Хартман etc.).

Code: {$A+,B-,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}. {$MINSTACKSIZE $00004000}. {$MAXSTACKSIZE $00100000}. {$IMAGEBASE $00400000}. {$APPTYPE GUI}. Unit Main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, ExtCtrls, ComCtrls, Menus; Type. TfmMain = class(TForm). MainMenu1: TMainMenu; N1: TMenuItem; N2: TMenuItem; StatusBar1: TStatusBar; N3: TMenuItem; ImgInfo: TImage; Panel1: TPanel; BtnStart: TSpeedButton; Procedure btnStartClick(Sender: TObject); Procedure FormCreate(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); End; Var. FmMain: TfmMain; Implementation. Uses PFiles; {$R *.DFM}. Function Power2(lPower: Byte): LongInt; Begin. Result := 1 shl lPower; End; Procedure ClassicDirect(var aSignal, aSpR, aSpI: array of Double; N: LongInt); Var lSrch: LongInt; Var lGarm: LongInt; Var dSumR: Double; Var dSumI: Double; Begin. For lGarm := 0 to N div 2 - 1 do. Begin. DSumR := 0; DSumI := 0; For lSrch := 0 to N - 1 do. Begin. DSumR := dSumR + aSignal[lSrch] * Cos(lGarm * lSrch / N * 2 * PI); DSumI := dSumI + aSignal[lSrch] * Sin(lGarm * lSrch / N * 2 * PI); End; ASpR[lGarm] := dSumR; ASpI[lGarm] := dSumI; End; End; Procedure ClassicInverce(var aSpR, aSpI, aSignal: array of Double; N: LongInt); Var lSrch: LongInt; Var lGarm: LongInt; Var dSum: Double; Begin. For lSrch := 0 to N - 1 do. Begin. DSum := 0; For lGarm := 0 to N div 2 - 1 do. DSum := dSum. + aSpR[lGarm] * Cos(lSrch * lGarm * 2 * Pi / N). + aSpI[lGarm] * Sin(lSrch * lGarm * 2 * Pi / N); ASignal[lSrch] := dSum * 2; End; End; Function InvertBits(BF, DataSize, Power: Word): Word; Var BR: Word; Var NN: Word; Var L: Word; Begin. Br := 0; Nn := DataSize; For l := 1 to Power do. Begin. NN := NN div 2; If (BF >= NN) then. Begin. BR := BR + Power2(l - 1); BF := BF - NN. End; End; InvertBits := BR; End; Procedure FourierDirect(var RealData, VirtData, ResultR, ResultV: array of. Double; DataSize: LongInt); Var A1: Real; Var A2: Real; Var B1: Real; Var B2: Real; Var D2: Word; Var C2: Word; Var C1: Word; Var D1: Word; Var I: Word; Var J: Word; Var K: Word; Var Cosin: Real; Var Sinus: Real; Var wIndex: Word; Var Power: Word; Begin. C1 := DataSize shr 1; C2 := 1; For Power := 0 to 15 //hope it will be faster then. Round(ln(DataSize) / ln(2)) do. If Power2(Power) = DataSize then Break; For I := 1 to Power do. Begin. D1 := 0; D2 := C1; For J := 1 to C2 do. Begin. WIndex := InvertBits(D1 div C1, DataSize, Power); Cosin := +(Cos((2 * Pi / DataSize) * wIndex)); Sinus := -(Sin((2 * Pi / DataSize) * wIndex)); For K := D1 to D2 - 1 do. Begin. A1 := RealData[K]; A2 := VirtData[K]; B1 := ((Cosin * RealData[K + C1] - Sinus * VirtData[K + C1])); B2 := ((Sinus * RealData[K + C1] + Cosin * VirtData[K + C1])); RealData[K] := A1 + B1; VirtData[K] := A2 + B2; RealData[K + C1] := A1 - B1; VirtData[K + C1] := A2 - B2; End; Inc(D1, C1 * 2); Inc(D2, C1 * 2); End; C1 := C1 div 2; C2 := C2 * 2; End; For I := 0 to DataSize div 2 - 1 do. Begin. ResultR[I] := +RealData[InvertBits(I, DataSize, Power)]; ResultV[I] := -VirtData[InvertBits(I, DataSize, Power)]; End; End; Procedure Hartley(iSize: LongInt; var aData: array of Double); Type taDouble = array[0..MaxLongInt div SizeOf(Double) - 1] of Double; Var prFI, prFN, prGI: ^taDouble; Var rCos, rSin: Double; Var rA, rB, rTemp: Double; Var rC1, rC2, rC3, rC4: Double; Var rS1, rS2, rS3, rS4: Double; Var rF0, rF1, rF2, rF3: Double; Var rG0, rG1, rG2, rG3: Double; Var iK1, iK2, iK3, iK4: LongInt; Var iSrch, iK, iKX: LongInt; Begin. IK2 := 0; For iK1 := 1 to iSize - 1 do. Begin. IK := iSize shr 1; Repeat. IK2 := iK2 xor iK; If (iK2 and iK) <> 0 then Break; IK := iK shr 1; Until False; If iK1 > iK2 then. Begin. RTemp := aData[iK1]; AData[iK1] := aData[iK2]; AData[iK2] := rTemp; End; End; IK := 0; While (1 shl iK) < iSize do. Inc(iK); IK := iK and 1; If iK = 0 then. Begin. PrFI := @aData; PrFN := @aData; PrFN := @prFN[iSize]; While Word(prFI) < Word(prFN) do. Begin. RF1 := prFI^[0] - prFI^[1]; RF0 := prFI^[0] + prFI^[1]; RF3 := prFI^[2] - prFI^[3]; RF2 := prFI^[2] + prFI^[3]; PrFI^[2] := rF0 - rF2; PrFI^[0] := rF0 + rF2; PrFI^[3] := rF1 - rF3; PrFI^[1] := rF1 + rF3; PrFI := @prFI[4]; End; End. Else. Begin. PrFI := @aData; PrFN := @aData; PrFN := @prFN[iSize]; PrGI := prFI; PrGI := @prGI[1]; While Word(prFI) < Word(prFN) do. Begin. RC1 := prFI^[0] - prGI^[0]; RS1 := prFI^[0] + prGI^[0]; RC2 := prFI^[2] - prGI^[2]; RS2 := prFI^[2] + prGI^[2]; RC3 := prFI^[4] - prGI^[4]; RS3 := prFI^[4] + prGI^[4]; RC4 := prFI^[6] - prGI^[6]; RS4 := prFI^[6] + prGI^[6]; RF1 := rS1 - rS2; RF0 := rS1 + rS2; RG1 := rC1 - rC2; RG0 := rC1 + rC2; RF3 := rS3 - rS4; RF2 := rS3 + rS4; RG3 := Sqrt(2) * rC4; RG2 := Sqrt(2) * rC3; PrFI^[4] := rF0 - rF2; PrFI^[0] := rF0 + rF2; PrFI^[6] := rF1 - rF3; PrFI^[2] := rF1 + rF3; PrGI^[4] := rG0 - rG2; PrGI^[0] := rG0 + rG2; PrGI^[6] := rG1 - rG3; PrGI^[2] := rG1 + rG3; PrFI := @prFI[8]; PrGI := @prGI[8]; End; End; If iSize < 16 then Exit; Repeat. Inc(iK, 2); IK1 := 1 shl iK; IK2 := iK1 shl 1; IK4 := iK2 shl 1; IK3 := iK2 + iK1; IKX := iK1 shr 1; PrFI := @aData; PrGI := prFI; PrGI := @prGI[iKX]; PrFN := @aData; PrFN := @prFN[iSize]; Repeat. RF1 := prFI^[000] - prFI^[iK1]; RF0 := prFI^[000] + prFI^[iK1]; RF3 := prFI^[iK2] - prFI^[iK3]; RF2 := prFI^[iK2] + prFI^[iK3]; PrFI^[iK2] := rF0 - rF2; PrFI^[000] := rF0 + rF2; PrFI^[iK3] := rF1 - rF3; PrFI^[iK1] := rF1 + rF3; RG1 := prGI^[0] - prGI^[iK1]; RG0 := prGI^[0] + prGI^[iK1]; RG3 := Sqrt(2) * prGI^[iK3]; RG2 := Sqrt(2) * prGI^[iK2]; PrGI^[iK2] := rG0 - rG2; PrGI^[000] := rG0 + rG2; PrGI^[iK3] := rG1 - rG3; PrGI^[iK1] := rG1 + rG3; PrGI := @prGI[iK4]; PrFI := @prFI[iK4]; Until not (Word(prFI) < Word(prFN)); RCos := Cos(Pi / 2 / Power2(iK)); RSin := Sin(Pi / 2 / Power2(iK)); RC1 := 1; RS1 := 0; For iSrch := 1 to iKX - 1 do. Begin. RTemp := rC1; RC1 := (rTemp * rCos - rS1 * rSin); RS1 := (rTemp * rSin + rS1 * rCos); RC2 := (rC1 * rC1 - rS1 * rS1); RS2 := (2 * (rC1 * rS1)); PrFN := @aData; PrFN := @prFN[iSize]; PrFI := @aData; PrFI := @prFI[iSrch]; PrGI := @aData; PrGI := @prGI[iK1 - iSrch]; Repeat. RB := (rS2 * prFI^[iK1] - rC2 * prGI^[iK1]); RA := (rC2 * prFI^[iK1] + rS2 * prGI^[iK1]); RF1 := prFI^[0] - rA; RF0 := prFI^[0] + rA; RG1 := prGI^[0] - rB; RG0 := prGI^[0] + rB; RB := (rS2 * prFI^[iK3] - rC2 * prGI^[iK3]); RA := (rC2 * prFI^[iK3] + rS2 * prGI^[iK3]); RF3 := prFI^[iK2] - rA; RF2 := prFI^[iK2] + rA; RG3 := prGI^[iK2] - rB; RG2 := prGI^[iK2] + rB; RB := (rS1 * rF2 - rC1 * rG3); RA := (rC1 * rF2 + rS1 * rG3); PrFI^[iK2] := rF0 - rA; PrFI^[0] := rF0 + rA; PrGI^[iK3] := rG1 - rB; PrGI^[iK1] := rG1 + rB; RB := (rC1 * rG2 - rS1 * rF3); RA := (rS1 * rG2 + rC1 * rF3); PrGI^[iK2] := rG0 - rA; PrGI^[0] := rG0 + rA; PrFI^[iK3] := rF1 - rB; PrFI^[iK1] := rF1 + rB; PrGI := @prGI[iK4]; PrFI := @prFI[iK4]; Until not (LongInt(prFI) < LongInt(prFN)); End; Until not (iK4 < iSize); End; Procedure HartleyDirect( Var aData: array of Double; ISize: LongInt); Var rA, rB: Double; Var iI, iJ, iK: LongInt; Begin. Hartley(iSize, aData); IJ := iSize - 1; IK := iSize div 2; For iI := 1 to iK - 1 do. Begin. RA := aData[ii]; RB := aData[ij]; AData[iJ] := (rA - rB) / 2; AData[iI] := (rA + rB) / 2; Dec(iJ); End; End; Procedure HartleyInverce( Var aData: array of Double; ISize: LongInt); Var rA, rB: Double; Var iI, iJ, iK: LongInt; Begin. IJ := iSize - 1; IK := iSize div 2; For iI := 1 to iK - 1 do. Begin. RA := aData[iI]; RB := aData[iJ]; AData[iJ] := rA - rB; AData[iI] := rA + rB; Dec(iJ); End; Hartley(iSize, aData); End; //not tested. Procedure HartleyDirectComplex(real, imag: array of Double; n: LongInt); Var a, b, c, d: double; Q, r, s, t: double; I, j, k: LongInt; Begin. J := n - 1; K := n div 2; For i := 1 to k - 1 do. Begin. A := real[i]; b := real[j]; q := a + b; r := a - b; C := imag[i]; d := imag[j]; s := c + d; t := c - d; Real[i] := (q + t) * 0.5; real[j] := (q - t) * 0.5; Imag[i] := (s - r) * 0.5; imag[j] := (s + r) * 0.5; Dec(j); End; Hartley(N, Real); Hartley(N, Imag); End; //not tested. Procedure HartleyInverceComplex(real, imag: array of Double; N: LongInt); Var a, b, c, d: double; Q, r, s, t: double; I, j, k: longInt; Begin. Hartley(N, real); Hartley(N, imag); J := n - 1; K := n div 2; For i := 1 to k - 1 do. Begin. A := real[i]; b := real[j]; q := a + b; r := a - b; C := imag[i]; d := imag[j]; s := c + d; t := c - d; Imag[i] := (s + r) * 0.5; imag[j] := (s - r) * 0.5; Real[i] := (q - t) * 0.5; real[j] := (q + t) * 0.5; Dec(j); End; End; Procedure DrawSignal(var aSignal: array of Double; N, lColor: LongInt); Var lSrch: LongInt; Var lHalfHeight: LongInt; Begin. With fmMain do. Begin. LHalfHeight := imgInfo.Height div 2; ImgInfo.Canvas.MoveTo(0, lHalfHeight); ImgInfo.Canvas.Pen.Color := lColor; For lSrch := 0 to N - 1 do. Begin. ImgInfo.Canvas.LineTo(lSrch, Round(aSignal[lSrch]) + lHalfHeight); End; ImgInfo.Repaint; End; End; Procedure DrawSpector(var aSpR, aSpI: array of Double; N, lColR, lColI: LongInt); Var lSrch: LongInt; Var lHalfHeight: LongInt; Begin. With fmMain do. Begin. LHalfHeight := imgInfo.Height div 2; For lSrch := 0 to N div 2 do. Begin. ImgInfo.Canvas.Pixels[lSrch, Round(aSpR[lSrch] / N) + lHalfHeight] := LColR; ImgInfo.Canvas.Pixels[lSrch + N div 2, Round(aSpI[lSrch] / N) + LHalfHeight] := lColI; End; ImgInfo.Repaint; End; End; Const N = 512; Var aSignalR: array[0..N - 1] of Double; // Var aSignalI: array[0..N - 1] of Double; // Var aSpR, aSpI: array[0..N div 2 - 1] of Double; // Var lFH: LongInt; Procedure TfmMain.btnStartClick(Sender: TObject); Const Epsilon = 0.00001; Var lSrch: LongInt; Var aBuff: array[0..N - 1] of ShortInt; Begin. If lFH > 0 then. Begin. // Repeat. If F.Read(lFH, @aBuff, N) <> N then. Begin. Exit; End; For lSrch := 0 to N - 1 do. Begin. ASignalR[lSrch] := ShortInt(aBuff[lSrch] + $80); ASignalI[lSrch] := 0; End; ImgInfo.Canvas.Rectangle(0, 0, imgInfo.Width, imgInfo.Height); DrawSignal(aSignalR, N, $D0D0D0); // ClassicDirect(aSignalR, aSpR, aSpI, N); //result in aSpR & aSpI, ASignal unchanged. // FourierDirect(aSignalR, aSignalI, aSpR, aSpI, N); //result in aSpR & ASpI, aSiggnalR & aSignalI modified. HartleyDirect(aSignalR, N); //result in source aSignal ;-). DrawSpector(aSignalR, aSignalR[N div 2 - 1], N, $80, $8000); DrawSpector(aSpR, aSpI, N, $80, $8000); { for lSrch := 0 to N div 2 -1 do begin //comparing classic & Hartley. If (Abs(aSpR[lSrch] - aSignal[lSrch]) > Epsilon). Or ((lSrch > 0) And (Abs(aSpI[lSrch] - aSignal[N - lSrch]) > Epsilon)). Then MessageDlg('Error comparing',mtError,[mbOK],-1); End;}. HartleyInverce(aSignalR, N); //to restore original signal with. HartleyDirect. // ClassicInverce(aSpR, aSpI, aSignalR, N); //to restore original. Signal with ClassicDirect or FourierDirect. For lSrch := 0 to N - 1 do. ASignalR[lSrch] := aSignalR[lSrch] / N; //scaling. DrawSignal(aSignalR, N, $D00000); Application.ProcessMessages; // Until False; End; End; Procedure TfmMain.FormCreate(Sender: TObject); Begin. LFH := F.Open('input.pcm', ForRead); End; Procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction); Begin. F.Close(lFH); End; End.

TColor --> String.

В модуле graphics имеется недокументированная функция:

Function ColorToString(Color: TColor): string;

©Drkb::03676.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

String --> TColor.

В модуле graphics имеется недокументированная функция:

Function StringToColor(S: string): TColor;

©Drkb::03678.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

DBGrid компонент c разными цветами удалённые, обновлённые и добавленные записи.

Code: Unit atcDBGrid; { (c) Aveen Tech. 2001 - 2002. FileName: atcDBGrid.pas. Version Date Author Comment. 1.0 13/06/2000 Majid Vafai Jahan Create. OVERVIEW. - This grid is inherited from DBGrid and add some required functionality to it. Functionality: - Record type are all records that may be modified, unmodified, inserted, deleted. - Coloring according to Record type. - show selected Record Type. } Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, dbTables, db; Const. AlignFlags : array [TAlignment] of Integer = ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX ); RTL: array [Boolean] of Integer = (0, DT_RTLREADING); Type. TCachedShow = (csModify, csUnModify, csRemoved, csInserted, csAll, csNormal); TatcDBGrid = class(TDBGrid). Private. FCachedShow: TCachedShow; FModifiedColor: TColor; FInsertedColor: TColor; FDeletedColor: TColor; Procedure SetCachedShow(const Value: TCachedShow); Protected. Procedure DrawDataCell(const Rect: TRect; Field: TField; State: TGridDrawState); override; Procedure DrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); override; Public. Constructor Create(AOwner: TComponent); override; Published. Property atcCachedShow: TCachedShow read FCachedShow write SetCachedShow; Property atcDeletedColor: TColor read FDeletedColor write FDeletedColor; Property atcInsertedColor: TColor read FInsertedColor write FInsertedColor; Property atcModifiedColor: TColor read FModifiedColor write FModifiedColor; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('ATC DB Compo', [TatcDBGrid]); End; Constructor TatcDBGrid.Create(AOwner: TComponent); {Description: Record Type Showing is All except Deletes. }. Begin. Inherited; FCachedShow := csNormal; FDeletedColor := clGray; FInsertedColor := clAqua; FModifiedColor := clRed; End; Procedure TatcDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); {Description: On Drawing Column Color Updated Records.}. Var. ARect: TRect; Begin. Inherited; If not Assigned(Column.Field) then. Exit; // Copy Rect into Variable. CopyRect(ARect, Rect); If Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then. Begin. // если текущая запись изменена. If DataLink.DataSet.UpdateStatus = usModified then. Begin. Canvas.Brush.Color := atcModifiedColor; Canvas.Font.Color := clBlack; Canvas.FillRect(Rect); DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect, AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]); End. // если текущая запись добавлена. Else if DataLink.DataSet.UpdateStatus = usInserted then. Begin. Canvas.Brush.Color := atcInsertedColor; Canvas.Font.Color := clBlack; Canvas.FillRect(Rect); DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect, AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]); End. // если текущая запись удалена. Else if DataLink.DataSet.UpdateStatus = usDeleted then. Begin. Canvas.Brush.Color := atcDeletedColor; Canvas.Font.Color := clWhite; Canvas.FillRect(Rect); DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect, AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]); End; End; End; Procedure TatcDBGrid.DrawDataCell(const Rect: TRect; Field: TField; State: TGridDrawState); {Описание: Рисуем ячейки}. Var. ARect: TRect; Begin. Inherited; CopyRect(ARect, Rect); If Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then. Begin. // если текущая запись изменена. If DataLink.DataSet.UpdateStatus = usModified then. Begin. Canvas.Brush.Color := clRed; Canvas.Font.Color := clBlack; Canvas.FillRect(Rect); DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect, AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]); End. // если текущая запись добавлена. Else if DataLink.DataSet.UpdateStatus = usInserted then. Begin. Canvas.Brush.Color := clAqua; Canvas.Font.Color := clBlack; Canvas.FillRect(Rect); DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect, AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]); End. // если текущая запись удалена. Else if DataLink.DataSet.UpdateStatus = usDeleted then. Begin. Canvas.Brush.Color := clGray; Canvas.Font.Color := clWhite; Canvas.FillRect(Rect); DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect, AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]); End; End; End; Procedure TatcDBGrid.SetCachedShow(const Value: TCachedShow); {Description: Record type for showing in grid. Parameters: Value cached record show. }. Begin. FCachedShow := Value; If ComponentState = [csDesigning] then. Exit; If not Assigned(DataSource) or not Assigned(DataSource.DataSet) then. Exit; // для показа только выбранного типа записей. If Assigned(DataLink) and Assigned(DataLink.DataSet) and (DataLink.Active) then. Begin. Case FCachedShow of. CsAll: TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted, rtDeleted, rtUnmodified]; CsModify: TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified]; CsUnModify: TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtUnmodified]; CsInserted: TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtInserted]; CsRemoved: TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtDeleted]; CsNormal: TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted, rtUnmodified]; End; End; End; End.

Как поместить картинку в заголовок TListView?

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

Code: Procedure TForm1.SetColumnImage( List: TListView; Column, Image: Integer; ShowImage: Boolean); Var. Align,hHeader: integer; HD: HD_ITEM; Begin. HHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0); With HD do. Begin. Case List.Columns[Column].Alignment of. TaLeftJustify: Align := HDF_LEFT; TaCenter: Align := HDF_CENTER; TaRightJustify: Align := HDF_RIGHT; Else. Align := HDF_LEFT; End; Mask := HDI_IMAGE or HDI_FORMAT; PszText := PChar(List.Columns[Column].Caption); If ShowImage then. Fmt := HDF_STRING or HDF_IMAGE or HDF_BITMAP_ON_RIGHT. Else. Fmt := HDF_STRING or Align; IImage := Image; End; SendMessage(hHeader, HDM_SETITEM, Column, Integer(@HD)); End;

Как узнать, по какой колонке был клик в TListView?

Метод GetItemAt позволяет получить координаты ListItem, по которой был клик, но только для первой колонки TListView. Если нужно узнать по какому элементу из другой колонки кликнул пользователь, то прийдётся объявить новый метод в наследованном классе:

Code: Uses ComCtrls; {©Drkb v.3(2007): www.drkb.ru}. Type. TListViewX = class(TListView). Public. Function GetItemAtX(X, Y: integer; var Col: integer): TListItem; End; Implementation. Function TListViewX.GetItemAtX(X, Y: integer; Var Col: integer): TListItem; Var. I, n, RelativeX, ColStartX: Integer; ListItem: TlistItem; Begin. Result := GetItemAt(X, Y); If Result <> nil then begin. Col := 0; // Первая колонка. End else if (ViewStyle = vsReport). And (TopItem <> nil) then begin. // Первая, попробуем найти строку. ListItem := GetItemAt(TopItem.Position.X, Y); If ListItem <> nil then begin. // Теперь попробуем найти колонку. RelativeX := X-ListItem.Position.X-BorderWidth; ColStartX := Columns[0].Width; N := Columns.Count - 1; For i := 1 to n do begin. If RelativeX < ColStartX then break; If RelativeX <= ColStartX + StringWidth(ListItem.SubItems[i-1]) then. Begin. Result := ListItem; Col := i; Break; End;//if. Inc(ColStartX, Columns[i].Width); End;//for. End;//if. End;//if. End;

А вот так выглядит событие MouseDown:

Code: Procedure TForm1.ListView1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Var. Col: integer; Li: TListItem; Begin. Li := TListViewX(ListView1).GetItemAtX(x, y, col); If li <> nil then. ShowMessage('Column #' + IntToStr(col)); End;

Virtual ListView с контекстным меню.

В Delphi5/Demos есть пример Virtual ListView. программка чем-то напоминает explorer, но без контекстного меню. контекстное меню приделывается так:

Code: Procedure TForm1.PopupMenu1Popup(Sender: TObject); Var. ContextMenu : IContextMenu; Menu : HMENU; Begin. FIShellFolder.GetUIObjectOf(Handle, 1, ShellItem(ListView.Selected.Index).ID, IID_IContextMenu, nil, ContextMenu); Menu := CreatePopupMenu(); ContextMenu.QueryContextMenu(menu, 0, 1, $7FFF, CMF_EXPLORE); TrackPopupMenu(menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD, Mouse.CursorPos.x, Mouse.CursorPos.y, 0, Handle, nil); DestroyMenu(menu); End;

Как изменить фоновый цвет текста в различных строчках TListBox?

После того, как поместите TListBox на форму, необходимо изменить свойство Style в TListBox на lbOwnerDrawFixed. Если не изменить свойство Style, то событие OnDrawItem никогда не вызовется. Теперь поместите следующий код в обработчик события OnDrawItem Вашего TListBox:

Code: Procedure TForm1.ListBox1DrawItem. (Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); Var. MyColor: TColor; MyBrush: TBrush; Begin. MyBrush := TBrush.Create; With (Control as TListBox).Canvas do. Begin. If not Odd(Index) then. MyColor := clSilver. Else. MyColor := clYellow; MyBrush.Style := bsSolid; MyBrush.Color := myColor; Windows.FillRect(handle, Rect, myBrush.Handle); Brush.Style := bsClear; TextOut(Rect.Left, Rect.Top, (Control as TListBox).Items[Index]); MyBrush.Free; End; End;

TCheckListBox: использование методов LoadFromFile/SaveToFile.

Автор: Bjarne Winkler.

Пример показывает как можно сохранять в файл содержимое TCheckListBox и соответственно восстанавливать из файла ранее сохранённые состояния Чекбоксов.

На самом деле всё просто. Метод SaveToFile просто напросто сохраняет в обычном текстовом виде значения чекбоксов. Но предварительно нам нужно преобразовать состояния чекбоксов в текстовый вид, соответственно "1" или "0".

Далее задача метода LoadFromFile считать эти значения и преобразовать сначало в числовой вид, а затем в логический (true или false).

Code: {====================================} Procedure TFrameRuleEngine.SaveRules; {====================================} Var. I: Integer; Begin. I := 0; While i < CheckListBoxRule.Items.Count Do. Begin. If CheckListBoxRule.Items[i] = '' Then. Begin. // Если ячейка пустая, то удаляем её. CheckListBoxRule.Items.Delete(i); End. Else. Begin. // Добавляем 1 или 0 соответственно checked или not checked. CheckListBoxRule.Items[i] := IntToStr(Integer(CheckListBoxRule.Checked[i])) + CheckListBoxRule.Items[i]; Inc(i); End; End; // Сохраняем весь список. CheckListBoxRule.Items.SaveToFile(ExtractFilePath(Application.ExeName) + 'Rule.Txt'); End; {===================================} Procedure TFrameRuleEngine.LoadRules; {===================================} Var. SChecked: String; I: Integer; Begin. If FileExists(ExtractFilePath(Application.ExeName) + 'Rule.Txt') Then. Begin. // Считываем файл. CheckListBoxRule.Items.LoadFromFile(ExtractFilePath(Application.ExeName) + 'Rule.Txt'); I := 0; While i < CheckListBoxRule.Items.Count Do. Begin. If CheckListBoxRule.Items[i] = '' Then. Begin. // Удаляем пустую ячейку. CheckListBoxRule.Items.Delete(i); End. Else. Begin. // получаем состояние чекбокса. SChecked := Copy(CheckListBoxRule.Items[i], 1, 1); CheckListBoxRule.Items[i] := Copy(CheckListBoxRule.Items[i], 2, Length(CheckListBoxRule.Items[i])); // Обновляем свойство Checked. CheckListBoxRule.Checked[i] := Boolean(StrToInt(sChecked)); Inc(i); End; End; End; End;

Компонент FontListBox.

Автор: Maarten de Haan.

Надеюсь, что любители Delphi уже не один раз приукрашивали всякие ЛистБоксы и тому подобное. Автор исходника предлагает создать этот компонент своими силами. Впрочем, Вы сами можете увидеть как можно играться со шрифтами в ListBox.

Code: { ================================================================== Написан в Delphi V5.0. Тестировался под: Windows 95, version A, servicepack 1. И Windows NT4.0, servicepack 5. =================================================================== } Unit FontListBox; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TFontListBox = class(TCustomListbox). Private. { Private declarations }. FFontSample : Boolean; // Добавляемое свойство. FShowTrueType : Boolean; // Добавляемое свойство. FCanvas : TControlCanvas; // Необходимо. Procedure SetFontSample(B : Boolean); // внутренняя процедура. Procedure SetShowTrueType(B : Boolean); // внутренняя процедура. Protected. { Protected declarations }. Procedure CreateWnd; override; Public. { Public declarations }. Constructor Create(AOwner : TComponent); override; Destructor Destroy; override; Procedure DrawItem(Index : Integer; R : TRect; State : TOwnerDrawState); override; Published. { Published declarations }. { Properties }. Property Fontsample : Boolean // Добавляемое свойство. Read fFontSample Write SetFontSample; Property Align; Property Anchors; Property BiDiMode; Property BorderStyle; Property Color; Property Columns; Property Constraints; Property Cursor; Property DragCursor; Property DragKind; Property DragMode; Property Enabled; //Poperty ExtendedSelection; Не существует в базовом классе. Property Font; Property Height; Property HelpContext; Property Hint; Property ImeMode; Property ImeName; Property IntegralHeight; Property Itemheight; Property Items; Property Left; Property MultiSelect; Property Name; Property ParentBiDiMode; Property ParentColor; Property ParentFont; Property ParentShowHint; Property PopupMenu; Property ShowTrueType : Boolean // Добавляемое свойство. Read fShowTrueType Write SetShowTrueType; Property ShowHint; Property Sorted; Property Style; Property TabOrder; Property TabStop; Property TabWidth; Property Tag; Property Top; Property Visible; Property Width; { Events }. Property OnClick; Property OnContextPopup; Property OnDblClick; Property OnDragDrop; Property OnDragOver; Property OnDrawItem; Property OnEndDock; Property OnEnter; Property OnExit; Property OnKeyDown; Property OnKeyPress; Property OnKeyUp; Property OnMeasureItem; Property OnMouseDown; Property OnMouseMove; Property OnMouseUp; Property OnStartDock; Property OnStartDrag; End; Procedure Register; Implementation. {--------------------------------------------------------------------} Procedure Register; // Hello. Begin. RegisterComponents('Samples', [TFontListBox]); End; {--------------------------------------------------------------------} Procedure TFontListBox.SetShowTrueType(B : Boolean); Begin. If B <> fShowTrueType then. Begin. FShowTrueType := B; Invalidate; // Заставляет апдейтится во время прорисовки. End; End; {--------------------------------------------------------------------} Procedure TFontListBox.SetFontSample(B : Boolean); Begin. If fFontSample <> B then. Begin. FFontSample := B; Invalidate; // Заставляет апдейтится во время прорисовки. End; End; {--------------------------------------------------------------------} Destructor TFontListBox.Destroy; Begin. FCanvas.Free; // освобождает холст. Inherited Destroy; End; {-----------------------------------------------------------------------} Constructor TFontListBox.Create(AOwner : TComponent); Begin. Inherited Create(AOwner); // Initialize properties. ParentFont := True; Font.Size := 8; Font.Style := []; Sorted := True; FFontSample := False; Style := lbOwnerDrawFixed; FCanvas := TControlCanvas.Create; FCanvas.Control := Self; ItemHeight := 16; FShowTrueType := False; End; {--------------------------------------------------------------------} Procedure TFontListBox.CreateWnd; Begin. Inherited CreateWnd; Items := Screen.Fonts; // Копируем все шрифты в ListBox.Items. ItemIndex := 0; // Выбираем первый фонт. End; {--------------------------------------------------------------------} Procedure TFontListBox.DrawItem(Index : Integer; R : TRect; State : TOwnerDrawState); Var. Metrics : TTextMetric; LogFnt : TLogFont; OldFont,newFont : HFont; IsTrueTypeFont : Boolean; FFontStyle : TFontStyles; FFontName : TFontName; FFontColor : TColor; Begin. LogFnt.lfHeight := 10; LogFnt.lfWidth := 10; LogFnt.lfEscapement := 0; LogFnt.lfWeight := FW_REGULAR; LogFnt.lfItalic := 0; LogFnt.lfUnderline := 0; LogFnt.lfStrikeOut := 0; LogFnt.lfCharSet := DEFAULT_CHARSET; LogFnt.lfOutPrecision := OUT_DEFAULT_PRECIS; LogFnt.lfClipPrecision := CLIP_DEFAULT_PRECIS; LogFnt.lfQuality := DEFAULT_QUALITY; LogFnt.lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE; StrPCopy(LogFnt.lfFaceName,Items[Index]); NewFont := CreateFontIndirect(LogFnt); OldFont := SelectObject(fCanvas.Handle,newFont); GetTextMetrics(fCanvas.Handle,Metrics); // Теперь вы можете проверить на TrueType-ность. IsTrueTypeFont := True; If (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then. IsTrueTypeFont := False; Canvas.FillRect(R); If fShowTrueType and IsTrueTypeFont then. Begin. // Записываем параметры шрифтов. FFontName := Canvas.Font.Name; FFontStyle := Canvas.Font.Style; FFontColor := Canvas.Font.Color; // Устанавливаем новые параметры шрифтов. Canvas.Font.Name := 'Times new roman'; Canvas.Font.Style := [fsBold]; //Canvas.Font.Color := clBlack; Canvas.TextOut(R.Left + 2,R.Top,'T'); If fFontColor <> clHighLightText then. Canvas.Font.Color := clGray; Canvas.TextOut(R.Left + 7,R.Top + 3,'T'); //Восстанавливаем параметры шрифтов. Canvas.Font.Style := fFontStyle; Canvas.Font.Color := fFontColor; Canvas.Font.Name := fFontName; End; If fFontSample then. // Шрифт будет прорисован фактически как шрифт. Canvas.Font.Name := Items[Index]. Else. // Шрифт будет прорисован в свойстве "Font". Canvas.Font.Name := Font.Name; If fShowTrueType then. Canvas.TextOut(R.Left + 20,R.Top,Items[Index]) // Показывать TrueType. Else. Canvas.TextOut(R.Left,R.Top,Items[Index]); // Не показывать TrueType. SelectObject(fCanvas.Handle,oldFont); DeleteObject(newFont); End; {--------------------------------------------------------------------} End. {====================================================================}

Как добавлять колонки в обычный Listbox (TListbox)?

Класс TListbox содержит свойство TabWith:

Code: ListBox1.TabWith := 50; ListBox1.Items.Add('Column1'^I'Column2'); // ^I это символ Tab.

Команды ADO.

Команде ADO, которой мы уделяли так много внимания в этой главе в VCL Delphi, соответствует компонент TADOCormand. Методы этого компонента во многом совпадают с методами класса TCustomADODataSet, хотя этот класс не является предком компонента. Он предназначен для выполнения команд, которые не возвращают наборы данных.

Так как компоненту TADOCommand нет необходимости обеспечивать работу набора записей, его непосредственным предком является класс TComponent. К его функциональности просто добавлен механизм соединения с БД через ADO и средства представления команды.

Команда передается в хранилище данных ADO через собственное соединение или через компонент TAOocormection, аналогично другим компонентам ADO (см. выше).

Текстовое представление выполняемой команды должно содержаться в свойстве.

Property CommandText: WideString;

Однако команду можно задать и другим способом. Прямая ссылка на нужный объект команды ADO может быть задана свойством.

Property CommandObject: _Command;

Тип команды определяется свойством.

Type TCommandType = (cmdUnknown, cmdText, cmdTable, cmdStoredProc, cmdFile, cmdTableDirect);

Property CommandType: TCommandType;

Так как тип TCommandType также используется в классе TCustomADODataSet, где необходимо представлять все возможные виды команд, по отношению к компоненту TADOcommand этот тип обладает избыточностью. Здесь нельзя установить значения cmdTable, cmdFile, cmdTableDirect, а тип cmdStoredProc должен обозначать только те хранимые процедуры, которые не возвращают набор данных.

Если команда должна содержать текст запроса SQL, свойство CommandType должно иметь значение cmdText.

Для вызова хранимой процедуры необходимо задать тип cmdStoredProc, a в свойстве CommandText ввести имя процедуры.

Если для выполнения команды необходимо задать параметры, используется свойство.

Property Parameters: TParameters;

Выполнение команды осуществляется методом Execute:

Function Execute: _RecordSet; overload;

Function Execute(const Parameters: OleVariant): _Recordset;overload;

Function Execute(var RecordsAffected: Integer; var Parameters: OleVariant; ExecuteOptions: TExecuteOptions = []): _RecordSet; overload;

Разработчик может использовать любую из представленных нотаций перегружаемого метода:

Параметр RecordsAffected возвращает число обработанных записей;

Параметр Parameters задает параметры команды;

Параметр ExecuteOptions определяет условия выполнения команды:

TExecuteOption = (eoAsyncExecute, eoAsyncFetch, eoAsyncFetchNonBlocking, eoExecuteNoRecords);

TExecuteOptions = set of TExecuteOption;

EoAsyncExecute — асинхронное выполнение команды;

EoAsyncFetch — асинхронная передача данных;

EoAsyncFetchNonBlocking — асинхронная передача данных без блокирования потока;

EoExecuteNoRecords — если команда возвращает набор записей, то они не передаются в компонент.

При работе с компонентом TADOConnection желательно использовать опцию eoExecuteNoRecords.

Для прерывания выполнения команды используется метод.

Procedure Cancel;

Текущее состояние команды можно определить свойством.

Type.

TObjectState = (stClosed, stOpen, stConnecting, stExecuting, stFetching);

TObjectStates = set of TObjectState; property States: TObjectStates;

Как присвоить значение свойству selected в ListBox?

Свойство "selected" компонента ТListВох может быть использованно только если свойство MultiSelect установленно в True. Если Вы работаете с ListВох'ом у которого MultiSelect=false то используйте свойство ItemIndex.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. ListBox1.Items.Add('1'); ListBox1.Items.Add('2'); {This will fail on a single selection ListBox}. // ListBox1.Selected[1] := true; ListBox1.ItemIndex := 1; {This is ok}. End;

RTF-->HTML.

Приведу программу, которую я использую для преобразования содержимого RichEdit в SGML-код. Она не формирует полный HTML-аналог, но вы сами можете добавить необходимый RTF-код и его интерпретацию в HTML-тэги.

Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.

Code: Function rtf2sgml(text: string): string; {Funktion for att konvertera en RTF-rad till SGML-text.}. Var. Temptext: string; Start: integer; Begin. Text := stringreplaceall(text, '&', '##amp;'); Text := stringreplaceall(text, '##amp', '&amp'); Text := stringreplaceall(text, '\' + chr(39) + 'e5', 'å'); Text := stringreplaceall(text, '\' + chr(39) + 'c5', 'Å'); Text := stringreplaceall(text, '\' + chr(39) + 'e4', 'ä'); Text := stringreplaceall(text, '\' + chr(39) + 'c4', 'Ä'); Text := stringreplaceall(text, '\' + chr(39) + 'f6', 'ö'); Text := stringreplaceall(text, '\' + chr(39) + 'd6', 'Ö'); Text := stringreplaceall(text, '\' + chr(39) + 'e9', 'é'); Text := stringreplaceall(text, '\' + chr(39) + 'c9', 'É'); Text := stringreplaceall(text, '\' + chr(39) + 'e1', 'á'); Text := stringreplaceall(text, '\' + chr(39) + 'c1', 'Á'); Text := stringreplaceall(text, '\' + chr(39) + 'e0', 'à'); Text := stringreplaceall(text, '\' + chr(39) + 'c0', 'À'); Text := stringreplaceall(text, '\' + chr(39) + 'f2', 'ò'); Text := stringreplaceall(text, '\' + chr(39) + 'd2', 'Ò'); Text := stringreplaceall(text, '\' + chr(39) + 'fc', 'ü'); Text := stringreplaceall(text, '\' + chr(39) + 'dc', 'Ü'); Text := stringreplaceall(text, '\' + chr(39) + 'a3', '£'); Text := stringreplaceall(text, '\}', '#]#'); Text := stringreplaceall(text, '\{', '#[#'); Text := stringreplaceall(text, '{\rtf1\ansi\deff0\deftab720', ''); {Skall alltid tas bort}. Text := stringreplaceall(text, '{\fonttbl', ''); {Skall alltid tas bort}. Text := stringreplaceall(text, '{\f0\fnil MS Sans Serif;}', ''); {Skall alltid tas bort}. Text := stringreplaceall(text, '{\f1\fnil\fcharset2 Symbol;}', ''); {Skall alltid tas bort}. Text := stringreplaceall(text, '{\f2\fswiss\fprq2 System;}}', ''); {Skall alltid tas bort}. Text := stringreplaceall(text, '{\colortbl\red0\green0\blue0;}', ''); {Skall alltid tas bort}. {I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort. Det efter \fs16 och la istallet en egen tvatt av \cf0.}. //temptext := hamtastreng (text,'{\rtf1','\deflang'); //text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}. Text := stringreplaceall(text, '\cf0', ''); Temptext := hamtastreng(text, '\deflang', '\pard'); {Plocka fran deflang till pard for att fa }. Text := stringreplace(text, temptext, ''); {oavsett vilken lang det ar. Norska o svenska ar olika}. {Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}. //text := stringreplaceall (text,'\fs16','');{8 punkter}. //text := stringreplaceall (text,'\fs20','');{10 punkter}. {Nu stadar vi istallet bort alla tvasiffriga fontsize.}. While pos('\fs', text) > 0 do. Begin. Application.processmessages; Start := pos('\fs', text); Delete(text, start, 5); End; Text := stringreplaceall(text, '\pard\plain\f0 ', '<P>'); Text := stringreplaceall(text, '\par \plain\f0\b\ul ', '</P><MELLIS>'); Text := stringreplaceall(text, '\plain\f0\b\ul ', '</P><MELLIS>'); Text := stringreplaceall(text, '\plain\f0', '</MELLIS>'); Text := stringreplaceall(text, '\par }', '</P>'); Text := stringreplaceall(text, '\par ', '</P><P>'); Text := stringreplaceall(text, '#]#', '}'); Text := stringreplaceall(text, '#[#', '{'); Text := stringreplaceall(text, '\\', '\'); Result := text; End; //Нижеприведенный кусок кода вырезан из довольно большой программы, вызывающей вышеприведенную функцию. //Я знаю что мог бы использовать потоки вместо использования отдельного файла, но у меня не было времени для реализации этого. Utfilnamn := mditted.exepath + stringreplace(stringreplace(extractfilename(pathname), '.TTT', ''), '.ttt', '') + 'ut.RTF'; Brodtext.lines.savetofile(utfilnamn); Temptext := ''; Assignfile(tempF, utfilnamn); Reset(tempF); Try. While not eof(tempF) do. Begin. Readln(tempF, temptext2); Temptext2 := stringreplaceall(temptext2, '\' + chr(39) + 'b6', ''); Temptext2 := rtf2sgml(temptext2); If temptext2 <> '' then temptext := temptext + temptext2; Application.processmessages; End; Finally. Closefile(tempF); End; Deletefile(utfilnamn); Temptext := stringreplaceall(temptext, '</MELLIS> ', '</MELLIS>'); Temptext := stringreplaceall(temptext, '</P> ', '</P>'); Temptext := stringreplaceall(temptext, '</P>' + chr(0), '</P>'); Temptext := stringreplaceall(temptext, '</MELLIS></P>', '</MELLIS>'); Temptext := stringreplaceall(temptext, '<P></P>', ''); Temptext := stringreplaceall(temptext, '</P><P></MELLIS>', '</MELLIS><P>'); Temptext := stringreplaceall(temptext, '</MELLIS>', '<#MELLIS><P>'); Temptext := stringreplaceall(temptext, '<#MELLIS>', '</MELLIS>'); Temptext := stringreplaceall(temptext, '<P><P>', '<P>'); Temptext := stringreplaceall(temptext, '<P> ', '<P>'); Temptext := stringreplaceall(temptext, '<P>-', '<P>_'); Temptext := stringreplaceall(temptext, '<P>_', '<CITAT>_'); While pos('<CITAT>_', temptext) > 0 do. Begin. Application.processmessages; Temptext2 := hamtastreng(temptext, '<CITAT>_', '</P>'); Temptext := stringreplace(temptext, temptext2 + '</P>', temptext2 + '</CITAT>'); Temptext := stringreplace(temptext, '<CITAT>_', '<CITAT>-'); End; Writeln(F, '<BRODTEXT>' + temptext + '</BRODTEXT>');

Масштабирование окон приложений, в зависимости от разрешения экрана.

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

2. Если вы не собираетесь делать форму масштабируемой, установите св-во Scaled=False и дальше не читайте. В противном случае Scaled=True.

3. Установите AutoScroll=False. AutoScroll = True означает не менять размер окна формы при выполнении что не очень хорошо выглядит, когда содержимое формы размер меняет.

4. Установите фонты в форме на TrueType фонты, например Arial. Если такого фонта не окажется на пользовательском компьютере, то Windows выберет альтернативный фонт из того же семейства. Этот фонт может не совпадать по размеру, что вызовет проблемы.

5. Установите св-во Position в любое значение, отличное от poDesigned. poDesigned оставляет форму там, где она была во время дизайна, и, например, при разрешении 1280x1024 форма окажется в левом верхнем углу и совершенно за экраном при 640x480.

6. Оставляйте по-крайней мере 4 точки между компонентами, чтобы при смене положения границы на одну позицию компоненты не "наезжали" друг на друга. Для однострочных меток (TLabel) с выравниванием alLeft или alRight установите AutoSize=True. Иначе AutoSize=False.

7. Убедитесь, что достаточно пустого места у TLabel для изменения ширины фонта - 25\% пустого места многовато, зато безопасно. При AutoSize=False Убедитесь, что ширина метки правильная, при AutoSize=True убедитесь, что есть ссвободное место для роста метки.

8. Для многострочных меток (word-wrapped labels), оставьте хотя бы одну пустую строку снизу.

9. Будьте осторожны при открытии проекта в среде Delphi при разных разрешениях. Свойство PixelsPerInch меняется при открытии формы. Лучше тестировать приложения при разных разрешениях, запуская готовый скомпилированный проект, а редактировать его при одном разрешении. Иначе это вызовет проблемы с размерами.

10. Не изменяйте свойство PixelsPerInch !

11. В общем, нет необходимости тестировать приложение для каждого разрешения в отдельности, но стоит проверить его на 640x480 с маленькими и большими фонтами и на более высоком разрешении перед продажей.

12. Уделите пристальное внимание принципиально однострочным компонентам типа TDBLookupCombo. Многострочные компоненты всегда показывают только целые строки, а TEdit покажет урезанную снизу строку. Каждый компонент лучше сделать на несколько точек больше.

©Drkb::04528.

Автор: Song.

Использование ловушек, блокировка мышки, клавиатуры и т.д.

Возможные вариации: Любые вопросы, связанные с постановкой хука. Например "Как отследить [что-то]", "Как подменить [какое-то действие]", "Как заблокировать комбинации клавиш, как заблокировать определённые действия", "Как не дать запускаться определённым приложениям, не дать открываться определённым окнам?", "Как получить список запущенных оконных приложений?" и т.д.

Рабочий пример глобальной блокировки правой кнопки мыши:

DLL:

Code: Library Project2; Uses Windows,Messages; Var SysHook:HHook=0; Function SysMsgProc(Code:Integer; WParam:LongInt; LParam:LongInt):LongInt; stdcall; Var Msg:TMessage; Begin. IF Code=HC_ACTION then. Case TMsg(Pointer(LParam)^).Message OF. WM_RBUTTONDOWN,WM_RBUTTONUP,WM_RBUTTONDBLCLK: TMsg(Pointer(LParam)^).Message:=WM_NULL. Else Result:=CallNextHookEx(SysHook,Code,WParam,LParam); End; End; Procedure Hook(Flag:Boolean); export; stdcall; Begin. IF Flag then SysHook:=SetWindowsHookEx(WH_GETMESSAGE,@SysMsgProc,HInstance,0) Else. Begin. UnhookWindowsHookEx(SysHook); SysHook:=0; End; End; Exports Hook; {$R *.res}. Begin. End.

Коллекции и работа с ними.

1. ТЕОРИЯ.

1.1. Почему коллекции?

Действительно, а почему, собственно, коллекции? Ведь существует класс TList, это классический список, принципы построения и использования таких списков хорошо известны и подробно описаны в литературе, сам этот класс достаточно прост, но содержит все необходимое - так зачем же еще какие-то ухищрения?

Ответ на этот вопрос, очевидно, следующий - разработчики Delphi ввели класс TCollection для удобства своих пользователей. И, конечно, для расширения возможностей самой Delphi.

Главное отличие класса TCollection от класса TList состоит в том, что он, во-первых, предназначен, в основном, для создания не обычных, а как бы <визуальных> списков и, во-вторых, Delphi содержит готовые средства, поддерживающие работу с коллекциями в design-time.

Что значит <визуальный> список? Это список, элементы которого должны каким-то образом отображаться на экране. Возьмем, например, шапку какой-либо таблицы. Ясно, что она содержит заголовки столбцов, причем каждый заголовок - это строка, которую видит пользователь. Это и есть <визуальный> список, а сами заголовки, очевидно, являются элементами этого списка.

А что значит <поддержка в design-time>? Это значит, что добавлять элементы к коллекции, удалять их и настраивать их свойства можно так же легко и просто, как мы это делаем, работая с компонентами. Для этого используется Object Inspector и еще один встроенный в Delphi редактор, который так и называется - Collection Editor. И еще, что очень важно, коллекции построены на основе класса TPersistent (в отличие от TList, являющегося прямым потомком TObject) - а это означает, что Delphi умеет запоминать в файле формы все настройки коллекции и ее элементов, которые мы делаем в design-time. Со списком TList без его модификации такое невозможно.

Вернемся к примеру с заголовками столбцов в шапке таблицы. Можно реализовать их список на основе класса TList? Безусловно, можно. Но работать с элементами такого списка нам придется только в run-time, что, согласитесь, не очень удобно (ведь потребуется <ручное> написание дополнительного кода, в котором, кстати, не исключены и ошибки). Если программист знает механизмы работы самой Delphi, то на основе класса TList он, конечно, может написать специальный объект-список, специальный редактор для него и получить поддержку списка в design-time. Но что делать другим программистам? Ответ - использовать уже существующие именно для подобных целей коллекции с их готовым редактором Collection Editor. И, конечно, не забыть сказать <спасибо> разработчикам Delphi, позаботившимся о нашем удобстве.

Только ли для построения <визуальных> списков предназначены коллекции? Естественно, нет, с их помощью можно создавать любые списки. Но именно при построении <визуальных> списков преимущества коллекций проявляются особенно отчетливо. Вы легко убедитесь в этом, поработав, например, с компонентом THeaderControl и его свойством Sections.

Посмотрев исходный текст модуля Classes, легко убедиться, что сами коллекции построены на основе все того же списка TList. Таким образом, можно сказать, что коллекции - это <списки специального назначения>.

Наверх.

1.2. Основные особенности коллекций и их элементов.

Любая коллекция - это объект (но не компонент), потомок класса TCollection. Она содержит элементы, причем каждый элемент - это тоже объект (но тоже не компонент), потомок класса TCollectionItem. Оба этих класса являются лишь базовыми, то есть имеют только ту функциональность, которая нужна для самой коллекции и ее взаимодействия с IDE. Чтобы получить что-то полезное в прикладном смысле, мы должны построить свой класс <элемент коллекции> и свой класс <коллекция>, введя в них нужные свойства и методы (а, если требуется, то и события). Это делается обычным образом, с использованием наследования и будет рассмотрено ниже. Сейчас, для того, чтобы лучше понять отличия коллекций от списков на основе класса TList, разберем их основные особенности. Именно основные и именно особенности, потому что все подробности, конечно, есть в справке Delphi и в ее исходных текстах (модуль Classes). Начнем с класса TCollectionItem.

Свойство Collection. Указывает на коллекцию, которой принадлежит данный элемент. Требуется для корректной работы коллекции с внутренним списком своих элементов. Автоматически назначается при создании элемента. Позволяет легко <перебросить> элемент из одной коллекции в другую, что при использовании списков на основе TList было бы все же посложнее.

Свойство DisplayName. Строка, представляющая элемент в Collection Editor. По умолчанию это всего лишь имя класса элемента, но может быть использовано и более полезным образом (например, для того же заголовка столбца таблицы). В последнем случае это свойство часто сопоставляется с каким-то другим, которое и появляется в Object Inspector под более смысловым именем (например, под именем Text в THeaderSection или TStatusPanel).

Свойство ID. Уникальный целочисленный идентификатор элемента внутри коллекции. Доступен только для чтения и автоматически назначается при вставке элемента в коллекцию. Может измениться только при <переброске> элемента в другую коллекцию (в отличие от свойства Index, которое может меняться при вставке, удалении или переупорядочивании элементов в пределах одной коллекции). Даже если элемент был удален из коллекции, его ID для новых элементов повторно не используется.

Свойство Index. Порядковый номер элемента в коллекции. Аналог индекса элемента в TList.

Метод GetNamePath. Используется в IDE для идентификации элемента коллекции. Возвращает строку, которая появляется в верхнем окошке Object Inspector, когда данный элемент выбирается в Collection Editor. Этот метод - часть поддержки работы в design-time, но вряд ли может быть полезен для прикладной программы.

Метод Changed. Этот protected-метод должен вызываться наследниками TCollectionItem каждый раз, когда меняются существенные свойства элемента и требуется уведомить об этом коллекцию. Приводит к вызову метода Update коллекции, что может быть использовано, например, для перерисовки, для обновления каких-то связей между элементами коллекции (если таковые существуют), да и вообще для любых других целей. При создании и уничтожении элемента метод Update коллекции вызывается автоматически.

Других свойств класс TCollectionItem не содержит, а его остальные методы, в общем, вполне стандартны (за исключением конструктора и деструктора, которые, конечно, выполняют свои обычные функции, но имеют несколько необычную реализацию, а также дополнительных методов для взаимодействия с IDE в design-time). События в этом классе не определены, но, если требуется, то никто не мешает нам определить любые события в потомках этого класса.

Теперь рассмотрим особенности класса TCollection.

Свойство Count. Количество элементов в коллекции. Аналог такого же свойства TList.

Свойство ItemClass. Дает фактический класс элементов коллекции. Этот класс задается при создании коллекции и в дальнейшем быть изменен не может. Все элементы коллекции имеют один и тот же класс (в этом смысле список на основе TList более гибок, так как не имеет подобного ограничения).

Свойство Items. Массив элементов коллекции. Аналог такого же свойства TList.

Методы Add, Clear и Insert. Аналоги соответствующих методов TList, но с одним важнейшим отличием. При добавлении (вставке) объекта в список TList или его удалении из списка сам объект не создается и, соответственно, не уничтожается. Те же операции с коллекцией приводят к автоматическому созданию и уничтожению экземпляра объекта. Конечно, это возможно именно потому, что в случае коллекции класс объекта известен заранее, а в случае TList объект может быть любым.

Метод Assign. Копирует элементы одной коллекции в другую. Конечно, если классы элементов этих коллекций не совпадают, возникнет ошибка. Кстати, такое копирование стало возможным как раз потому, что коллекции и их элементы построены на основе класса TPersistent, в то время как подобная операция со списками TList требует дополнительного кода.

Методы BeginUpdate и EndUpdate. Эти методы проще всего рассмотреть на примере перерисовки. Выше отмечалось, что коллекции предназначены, в основном, для создания <визуальных> списков. Если один из элементов коллекции обновляется, это приводит к его обновлению и на экране. Если же обновляются сразу несколько элементов, то нет смысла выполнять промежуточные перерисовки экрана, а надо выполнить только одну - после обновления всех элементов. Это и позволяют сделать два рассматриваемых метода. Важно знать, что перерисовка происходит только после того, как метод EndUpdate будет вызван ровно столько раз, сколько перед этим был вызван BeginUpdate. Чтобы гарантировать правильную работу, обычно эти вызовы используются совместно с блоком try:finally. Конечно, этот механизм может быть использован при любом обновлении элементов коллекции, а не только для их перерисовки.

Метод FindItemID. Дает элемент коллекции с заданным ID (либо Nil, если такового нет).

Метод GetNamePath. Используется для внутренних нужд IDE, как часть поддержки работы в design-time. Для прикладного программиста этот метод вряд ли представляет интерес.

Метод Changed. Этот protected-метод должен вызываться наследниками TCollection при изменении существенных свойств коллекции. Приводит к вызову метода Update, но не сразу, а после ее полного обновления (см. BeginUpdate и EndUpdate).

Метод Update. В классе TCollection этот protected-метод не делает ничего, но потомки могут заместить его для фактического обновления коллекции (например, для той же перерисовки).

В остальном класс TCollection - это, в общем-то, обычный объект (за исключением того, что имеет ряд дополнительных методов, обеспечивающих взаимодействие с IDE в design-time). Никакие события в этом классе не определены, но могут быть определены в его потомках.

Наверх.

1.3. Владелец коллекции и класс TOwnedCollection.

В большинстве случаев коллекции используются, как свойства компонентов (собственно, это и есть их основное назначение). Пусть, например, мы разрабатываем компонент, который должен содержать список некоторых объектов. Тогда сначала мы определяем класс <элемент коллекции>, затем класс самой коллекции и, наконец, вводим в наш компонент свойство, как объект этого класса. Это свойство и будет представлять искомый список объектов, причем мы сможем работать с ним в design-time, не предпринимая для этого никаких дополнительных усилий.

В рассмотренном случае наш компонент будет владельцем (owner) коллекции. Согласно общей идеологии Delphi и для обеспечения правильной работы IDE в классе самой коллекции следует заместить метод GetOwner, который любая коллекция наследует от класса TPersistent. Все, что этот метод должен делать - это возвращать ссылку на компонент-владелец и в Delphi определен еще один класс - TOwnedCollection, в котором такая функциональность уже реализована.

Вопрос - если мы создаем коллекцию, планируя использовать ее именно как свойство компонента, то должны ли мы в качестве ее предка выбирать только класс TOwnedCollection, или можно использовать общий класс TCollection?

Ответ - правильно и то, и другое, но во втором случае мы должны сами позаботиться о замещении метода GetOwner. Можно даже в раздел public (но только не в published) ввести read-only свойство Owner, также дающее ссылку на владельца (через тот же метод GetOwner). Тем самым, не затрачивая лишних ресурсов (свойства не требуют памяти) мы дополнительно усиливаем сходство создаваемой коллекции с компонентом - ведь все компоненты имеют свойство Owner.

Наверх.

1.4. Резюме по теоретической части.

Итак, коллекция - это объект, реализующий список других объектов. Его основное отличие от общего списка TList заключается в том, что, не будучи компонентом, он в design-time допускает работу с собой, как с компонентом. Для этого используются общий редактор всех компонентов Object Inspector и специальный редактор свойства Collection Editor. Такая особенность поддерживается как IDE, так и самой коллекцией, что налагает на ее реализацию ряд требований.

Наверх.

2. ПРАКТИКА.

Прикладным программистам, особенно мало знакомым с работой самой IDE все предыдущее вполне могло показаться слишком неинтересным или слишком сложным. Настало время показать, что это вовсе не так. Создадим учебный компонент - потомок TShape, содержащий коллекцию визуальных точек. Его практическая ценность довольно сомнительна, но для демонстрационных целей такой компонент неплох, поскольку он достаточно прост и поэтому <лес не будет слишком заслонен деревьями> (ведь наша основная цель - научиться работать с коллекциями).

Итак, запускаем Delphi, щелкаем по File | New, выбираем и нажимаем OK. В поле пишем слово , а в поле - слово и нажимаем . Переходим на вкладку , нажимаем и задаем путь к создаваемому пакету, а в качестве его имени указываем, например, . Далее на все вопросы отвечаем нажимом кнопок <Да> - и в итоге на странице Samples палитры получаем свежесозданный компонент DappledShape, который пока еще ничем не отличается от своего предка - стандартного Shape.

На экране будет окно, в котором отображается состав нового пакета HelloWorld. Не нужно его закрывать, оно еще понадобится - ведь после всех изменений пакет надо перекомпилировать (кнопка ). А мы перейдем в окно редактора с текстом модуля DappledShape и, наконец, займемся настоящим программированием. Практически весь код нам придется писать вручную, но что может быть интереснее, не правда ли?

Наверх.

2.1. Создание элемента коллекции.

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

В разделе interface сразу после слова type пишем следующее объявление класса, который и будет представлять элемент нашей коллекции.

Code: TSpot = class(TCollectionItem). Private. FCenterX: integer; FCenterY: integer; FColor: TColor; Public. Constructor Create(Collection: TCollection); override; Published. Property CenterX: integer read FCenterX write SetCenterX default 3; Property CenterY: integer read FCenterY write SetCenterY default 3; Property Color: TColor read FColor write SetColor default clBlack; End;

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

Теперь ставим курсор куда-то в середину этого объявления и нажимаем Ctrl+Shift+C. Умница Delphi добавляет еще три метода и создает скелет реализации. Остается только на языке Object Pascal объяснить, чего же мы, собственно, хотим. Итак, пишем реализацию.

Code: Constructor TSpot.Create(Collection: TCollection); Begin. // Создаем сам объект и инициализируем его поля. Inherited Create(Collection); FCenterX := 3; FCenterY := 3; FColor := clBlack. End; Procedure TSpot.SetCenterX(const Value: integer); Begin. // Если значение новое, запоминаем его и запрашиваем перерисовку. If FCenterX <> Value then. Begin. FCenterX := Value; Changed(False). End. End; Procedure TSpot.SetCenterY(const Value: integer); Begin. If FCenterY <> Value then. Begin. FCenterY := Value; Changed(False). End. End; Procedure TSpot.SetColor(const Value: TColor); Begin. If FColor <> Value then. Begin. FColor := Value; Changed(False). End. End;

String --> PChar.

Code: Var S: String; P: PChar; .... P:=PChar(S);

Парсинг строк.

Code: Unit splitfns; Interface. Uses Classes, Sysutils; Function GetNextToken(Const S: string; Separator: TSysCharSet; var StartPos: integer): String; {Returns the next token (substring) from string S, starting at index StartPos and ending 1 character. Before the next occurrence of Separator (or at the end of S, whichever comes first).}. {StartPos returns the starting position for the next token, 1 more than the position in S of. The end of this token}. Procedure Split(const S: String; Separator: TSysCharSet; MyStringList: TStringList); {Splits a string containing designated separators into tokens and adds them to MyStringList NOTE: MyStringList must be Created before being passed to this procedure and Freed after use}. Function AddToken (const aToken, S: String; Separator: Char; StringLimit: integer): String; {Used to join 2 strings with a separator character between them and can be used in a Join function}. {The StringLimit parameter prevents the length of the Result String from exceeding a preset maximum}. Implementation. Function GetNextToken(Const S: string; Separator: TSysCharSet; var StartPos: integer): String; Var Index: integer; Begin. Result := ''; {Step over repeated separators}. While (S[StartPos] in Separator) and (StartPos <= length(S)) do StartPos := StartPos + 1; If StartPos > length(S) then Exit; {Set Index to StartPos}. Index := StartPos; {Find the next Separator}. While not (S[Index] in Separator) and (Index <= length(S))do Index := Index + 1; {Copy the token to the Result}. Result := Copy(S, StartPos, Index - StartPos); {SetStartPos to next Character after the Separator}. StartPos := Index + 1; End; Procedure Split(const S: String; Separator: TSysCharSet; MyStringList: TStringList); Var Start: integer; Begin. Start := 1; While Start <= Length(S) do MyStringList.Add(GetNextToken(S, Separator, Start)); End; Function AddToken (const aToken, S: String; Separator: Char; StringLimit: integer): String; Begin. If Length(aToken) + Length(S) < StringLimit then. Begin. {Add a separator unless the Result string is empty}. If S = '' then Result := '' else Result := S + Separator; {Add the token}. Result := Result + aToken; End. Else. {if the StringLimit would be. Exceeded, raise an exception}. Raise Exception.Create('Cannot add token'); End; End.

Как установить обои в формате jpeg?

Как установить обои в формате jpeg.

SystemParametersInfo только для bmp.

Code: Uses. ComObj, ShlObj; Procedure ChangeActiveWallpaper; Const. CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}'; Var. ActiveDesktop: IActiveDesktop; Begin. ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop; ActiveDesktop.SetWallpaper('c:\windows\forest.jpg', 0); ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE); End;

Как скрыть программу от Alt - Tab.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowWindow(Handle, SW_HIDE); ShowWindow(Application.Handle, SW_HIDE); End;

©Drkb::01481.

Автор: Song.

Взято из http://forum.sources.ru.

Code: With Application do. Begin. ShowWindow(Handle, SW_HIDE); SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW); End; {With}. SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);

Автор: Stavros.

©Drkb::01482.

Взято из http://forum.sources.ru.

Простые алгоритмы шифрования текста.

Code: Function Decode(S: String; Code: Integer): String; Var t: Integer; Begin. For t:=1 to Length(S) Do S[t]:=Chr(Ord(S[t]) xor Code); Result:=S; End;

Hex --> String.

Code: Procedure TForm1.Button1Click(Sender: TObject); Const Source: string = '4D 5A'; Var S: string; T: Integer; Begin. With TStringList.Create do. Try. Text := StringReplace(Source, #32, #13#10, [rfReplaceAll]); S := ''; For t := 0 to Count - 1 do. S := S + Chr(StrToInt('$' + Strings[t])); ShowMessage(S); Finally. Free; End; End;

Можно ли задать шаг в For?

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. For i:=0 to Maximum do if i mod step = 0 then. Begin. End;

EOleSysError - как бороться?

Перед тем как Дельфи сможет использовать любые ActiveX/COM (в том числе и ADO компоненты) должна быть выполнена строка Application.Initialize - которая инициализирует использование COM. Если пишется DLL или консольное приложение, которые не имеют объекта Application, то надо просто добавить в Uses ещё один модуль: "oleauto".

©Drkb::00027.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято из http://forum.sources.ru.

Unresolved external malloc referenced, Ошибка линкера Kylix 3.

Ошибка возникает на Kilyx 3 (C++ IDE) установленном на новых версиях Linux.

Требуется установить специальный Патч.

Http://forum.sources.ru/index.php?act=Attach&type=post&id=262358.

©Drkb::04610.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято из http://forum.sources.ru.

Запуск программы на Kylix.

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

В простейшем случае достаточно предпринять следующие шаги:

1) создать папку.

/usr/lib/borland.

2) В эту папку скопировать файл libborqt-6.9.0-qt2.3.so с машины где установлен Kylix.

3) Создать символьный линк libborqt-6.9-qt2.3.so на этот файл (команда linux ln -s ).

4) Отредактирвоать файл в папке /home/[ваш логин] по имени .bash_profile (внимение файл скрытый!).

PATH=$PATH:$HOME/bin:.

Export LD_LIBRARY_PATH=/usr/lib/borland.

Export PATH.

5) Убедиться что у пользователя под которым вы собираетесь работать есть права на чтение и запуск libborqt-6.9.0-qt2.3.so и libborqt-6.9-qt2.3.so.

5) Перезагрузить компьютер.

©Drkb::04611.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято из http://forum.sources.ru.

Режим замены.

Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength еdit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".

Пример:

Code: Type. TForm1 = class(TForm). Memo1: TMemo; Procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Procedure Memo1KeyPress(Sender: TObject; var Key: Char); Private. {Private declarations}. InsertOn : bool; Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. If (Key = VK_INSERT) and (Shift = []) then. InsertOn := not InsertOn; End; Procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); Begin. If ((Memo1.SelLength = 0) and (not InsertOn)) then. Memo1.SelLength := 1; End;

Как использовать верхние и нижние индексы?

RichEdit поддерживает верхние/нижние индексы;

Вот как это делается:

Code: Uses RichEdit; Procedure TForm1.Button1Click(Sender: TObject); Var. CF: TCharFormat; Begin. Cf.cbSize := sizeof(cf); Cf.dwMask := CFM_OFFSET; Cf.yOffset := 70; // смещение по y; положительное/отрицательное для смещение верх/вниз. RichEdit1.Perform(EM_SETCHARFORMAT, SCF_SELECTION, integer(@cf)); End;

Поиск значения по любому столбцу.

Частенько встречается следующая ситуация. Вы работате с базой данных, в.

Которой множество таблиц. К концу рабочего дня голова идёт кругом от.

Названий столбцов, ...

Ещё ситуация: вы знаете, что где то в таблице должно было появиться опреде-

Лённое число (с помощью клиентской программы ввели, например, год своего рождения,

Но не желаете разбираться в таблице 200*150000, в какое именно поле и в какой строке.

Оно оказалось записано...

Или вам просто лень...

В общем - лень - двигатель прогресса.

Сформулируем задачу: можно ли выбрать из таблицы все записи в которых встречается.

Определённое значение поля в любом из столбцов?

Можно!

Именно для этого я и написал приблуду, которую и хочу представить вашему вниманию.

Надеюсь, что код достаточно хорошо прокомментирован.

Code: Declare. @sColumnName varchar(30), @sQuery varchar(200), @sTempQuery varchar(200), @sTabname varchar(30), @nSearchParam int. ----установим рабочие переменные: SELECT @sTabname = 'relTable' ----имя таблицы, из которой будем производить выборку. SELECT @nSearchParam = 9348 ----искомое значение, в данном случае - неккий id. ----все имена колонок нашей БД хранятся в таблице syscolumns, все объекты: в таблице sysobjects. ----эти две таблицы мы свяжем по полю id, следующим заполним временную таблицу #cname, ----в которой будут храниться имена всех столбцов интересующей нас таблицы. SELECT c.name INTO #cname. FROM syscolumns c, sysobjects o. WHERE c.id = o.id. AND c.xtype = 56. AND o.xtype = 'U' AND c.type = 38. AND o.name = @sTabname. ---Примечание: ---c.xtype = 56 - означает, что нас интересуют только поля таблиц. ---c.type = 38 - означает, что нас интересуют числовые поля. SELECT @sColumnName = '' --начальная инициализация - на всякий пожарный. WHILE 1 = 1. BEGIN. SET rowcount 1 --данные из таблицы будем выбирать по одной строке. SELECT @sColumnName = name --получили имя. FROM #cname. WHERE name > @sName --следующей колонки. ORDER BY name --обязательно отсортировать по полю, которое выбираем! IF @@rowcount = 0 --если дошли до конца временно таблицы. BEGIN. SET rowcount 0. BREAK --завершим цикл. END. SET rowcount 0. --используем динамическое создание SQL запроса. SELECT @sTempQuery = ' WHERE ' + @sColumnName + '= ' + Str(@nSearchParam). SELECT @sQuery = 'IF EXIST (SELECT 1 FROM ' + @sTabname + @sTempQuery + ') BEGIN ' + ' SELECT ' + @sColumnName + ',* FROM ' + @sTabname + @sTempQuery + ' END' --исполним его. EXEC (@sQuery). --такие сложности с EXIST нам нужны для того, что бы QueryAnalyzer не мучал нас выводом пустых. --результатов запроса. END. DROP TABLE #cname ---уничтожим временную таблицу.

3d engines для Дельфи.

3DEL: Delphi

3D Engines List Delphi. This list contains 9 rendering engines written in/for Delphi .

Texture-mapping Engines.

23.03.1999 3D TT

01.03.1999

3D TT is a 3D game engine for a game like Transport Tycoon for Windows from Peter Dobrovka ( dobrovka@hkn.de ) and WAY-X (a group of hobby programmers). Based on OpenGL Multitextured landscape (without shading) Perspective and isometric view Large maps (1024x1024) 3D Sprites Moving objects (esp. trains) Integrated editor Written in Delphi Pascal More information, screenshots and a demo can be found on the (german) WAY-X Homepage under 3DTT (click one of the four icons in the top frame to view screenshots etc).

14.01.1999 3D API Bindings for Delphi

14.01.1999

Erik Unger manages a site for 3D API Bindings for Delphi: Support for DirectX 6.0 for Delphi 2, 3 and 4 (Erik Unger ) Support for OpenGL 1.1 ( Mike Lischke ) Support for Glide 2.43 (Erik Unger and Eric Nowinski) More information and the source can be found on the Delphi Graphics Homepage.

20.11.1998 TGMP

01.04.1997

TGMP is a 3D graphics engine for PCs using DELPHI by Peter Dove (peterd@graphicalmagick.com) and Don Peer (dpeer@mgl.ca). Shaded linear texture mapping. Gouraud shading and wireframe rendering. Z sorting. 16 bit color support for Windows 95. Object Pascal / Delphi 2 source with good comments. A longer text document describes the techniques used. The source files can be found at the Delphi Informat 1997 File Library under the name DI9704DP.ZIP.

03.11.1997 OpenGL Component for Delphi

07.10.1997

OGLCFD are Delphi 3.0 VCL components providing an object oriented interface to the OpenGL API for Windows 95 and Windows NT. The OGLCFD is distributed by SignSoft GmbH. Simple API wrapper around OpenGL, the standard OpenGL calls are also awailable. OpenGL view Cameras Camera controllers Light sources Materials Textures 3D objects More information, screenshots and a demo can be found on the OpenGL Component for Delphi Homepage or the german OpenGL Component for Delphi Homepage

08.04.1997 TGMP V2

08.04.1997

TGMP V2 is a commercial real-time rendering system for PCs written in Delphi 2.0 from Graphical Magick Productions Ltd, written by Peter Dove (peterd@graphicalmagick.com). Shaded linear texture mapping. Gouraud and flat shading, wireframe and point rendering. Z-buffer rendering. Uses DirectX 3 for rendering. BMP and PPM texture file support. Cylindrical and spherical texture wrapping. Loads DirectX X format, convertor available for 3DS to X . Written in Object Pascal / Delphi 2 (also the api). More information and a demo can be found on the TGMP V2 Homepage.

16.07.1996 Convex Renderer in 3D

16.07.1996

The CR3D is a 3D graphics engine for Delphi 2.0 from Romesh (prakash@earthlink.net). Support for DirectDraw or WinG under Windows 95 / NT 4.0. 8 and 16-bit color mode. Linear texture mapping. Flat shading. Z-buffer rendering. 3DS and PLG file reader. More information and a beta version on the CR3D Homepage.

Gouraud-shading Engines.

12.03.1998 MegaGraph Graphics Library

01.01.1995

The MGL is a 3D graphics library for PCs from SciTech. Flat and gouraud shading. Support for DOS, Windows 3.1 / 95 / NT. SVGA support. BSP sorting and zbuffer rendering 2D and 3D functions. 3D modeling system. Written in C++ and ASM. Support for Borland C++, Watcom C++, Delphi, Visual C++. Support for DirectDraw acceleration functions. Support for OpenGL for Windows ( Microsoft, Silicon Graphics and Mesa ) API within the MGL framework. Support for stereo LC shutter glasses (requires hardware stereo support) More information and source can be found on the MGL Homepage.

Doom/Wolfenstein Engines.

09.04.1999 BSP

15.08.1997

BSP is a doom level viewer for PCs from Ivailo Belchev (ivob@geocities.com ) . Non orthogonal walls. Floor and ceiling texture mapping. Depthcueing. C++ / ASM source. The demo and source can be found on the Homepage of Ivailo Belchev . Paul Toth has made two pascal versions of the BSP engine (for Delphi 2+ and BP7) that can be found on the Mysoft Homepage.

02.05.1997 4DX

06.07.1995

The 4DX Rendering Engine is a commercial doom/heretic game engine from Jaimi McEntire (jaimimc@aol.com) from Eldermage Corp. Animated sky mapping. Non rectangular walls with different height. Looking up/down is done via y-shearing (as in Heretic, Dark Forces etc). Animated sprite objects. Transparent textures. Interactive level and texture editor. 2D effects like snow. Sound support. DOS and Windows libraries available. 4DX is a C++ Library and requires Watcom C++ v 10.0, 4DX is fully 32bit. Doom WAD file importer. Available as Delphi 2.0 VCL, as ActiveX control for Visual Basic, as Linkable Library for Visual C++ or as DLL. Map editor. More information and a demo can be found on the Eldermage Homepage. An older demo can be found on x2ftp.oulu.fi . More info in the 4DX Readme. All the 3D Engine.de pages are &#169 by Cristian Yaming

Источник: http://www.3dengines.de/lang_dp.html.

©Drkb::03955.

Взято из http://forum.sources.ru.

Разбудить компьютер по сети, Использование Bios Wake-on-Lan.

Code: {$APPTYPE CONSOLE}. Uses. SysUtils, Classes, IdBaseComponent, IdComponent, IdUDPBase, IdUDPClient; Function HexStringToBinString(const HexStr: string): string; Var. I, l: integer; Begin. Result := ''; L := length(HexStr); L := l div 2; SetLength(Result, l); For i := 1 to l do. If HexToBin(PChar(Copy(HexStr, (i - 1) * 2 + 1, 2)), PChar(@Result[i]), 1) = 0 then. Raise Exception.Create('Invalid hex value'); End; Procedure SendMagicPacket(MACAddress: string); Var. S, packet: string; I: integer; Begin. If Length(MACAddress) <> 12 then. Raise Exception.CreateFmt('Invalid MAC Address: %s', [MACAddress]); Packet := HexStringToBinString('FFFFFFFFFFFF'); S := HexStringToBinString(MACAddress); For i := 1 to 16 do. Packet := packet + s; With TIdUDPClient.Create(nil) do. Try. Active := true; BroadcastEnabled := true; Broadcast(packet, 9); Finally. Free; End; End; Begin. If ParamCount <> 1 then. WriteLn('usage: WakeOnLan MACAddress' + #10 + #13 + 'exmple: WakeOnLan 000102030405'). Else. SendMagicPacket(ParamStr(1)); End.

©Drkb::01364.

Автор: Song.

Взято из http://forum.sources.ru.

Набор dialup соединения по умолчанию.

Для w9x, me:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var cmd, par, fil, dir: PChar; Begin. Cmd := 'open'; Fil := 'rasdial.exe'; Par := PChar(edtEntry.Text + ' ' + EdtUser.Text + ' ' + EdtPass.Text); Dir := 'C:'; ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE); End; Procedure TForm1.Button2Click(Sender: TObject); Var Cmd, Par, Fil, Dir: PChar; Begin. Cmd := 'open'; Fil := 'rasdial.exe'; Par := PChar(EdtEntry.Text + ' /DISCONNECT'); Dir := 'C:'; ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE); End;

©Drkb::01469.

Code: Uses Registry, Windows; Function DUNDialDefault(Hide: Boolean): Boolean; Var Reg: TRegistry; TempResult: Boolean; Name, Con: string; ASW: Integer; Begin. With TRegistry.Create do. Try. RootKey := HKEY_CURRENT_USER; If OpenKey('\RemoteAccess', False) then. Begin. TempResult := True; Name := ReadString('Default'); End. Else. TempResult := False; Finally. Free; End; If TempResult then. Begin. If Hide then. ASW := SW_HIDE. Else. ASW := SW_SHOWDEFAULT; Con := 'rnaui.dll,RnaDial ' + Name; ShellExecute(0, nil, 'rundll32.exe', PChar(Con), 'C:\windows\', ASW); End; {IF}. Result := TempResult; End;

©Drkb::01470.

Для Nt, w2k, XP:

Code: Uses ..., WinInet; InternetAutoDial (INTERNET_AUTODIAL_FORCE_ONLINE, Handle);

Handle - окно, из которого вызывается функция.

©Drkb::01471.

Автор: Song.

Взято из http://forum.sources.ru.

Где взять примеры использования Indy?

В стандартную поставку Дельфи примеры работы с компонентами Indy отсутствуют, но это не значит, что их нет. Надо обратиться на официальные сайты разработчиков этих компонентов:

Http://www.indyproject.org/

Http://www.nevrona.com/indy

©Drkb::03580.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято из http://forum.sources.ru.

Win1251 <-> Koi8r.

Code: Type TConvertChars = array[#128..#255] of char; Const Win_KoiChars: TConvertChars = (#128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#060,#139,#140,#141,#142,#143,#144,#145,#146,#147,#148,#169,#150,#151,#152,#153,#154,#062,#176,#157,#183,#159,#160,#246,#247,#074,#164,#231,#166,#167,#179,#169,#180,#060,#172,#173,#174,#183,#156,#177,#073,#105,#199,#181,#182,#158,#163,#191,#164,#062,#106,#189,#190,#167,#225,#226,#247,#231,#228,#229,#246,#250,#233,#234,#235,#236,#237,#238,#239,#240,#242,#243,#244,#245,#230,#232,#227,#254,#251,#253,#154,#249,#248,#252,#224,#241,#193,#194,#215,#199,#196,#197,#214,#218,#201,#202,#203,#204,#205,#206,#207,#208,#210,#211,#212,#213,#198,#200,#195,#222,#219,#221,#223,#217,#216,#220,#192,#209); Koi_WinChars: TConvertChars = (#128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#138,#139,#140,#141,#142,#143,#144,#145,#146,#147,#148,#149,#150,#151,#152,#153,#218,#155,#17. 6,#157,#183,#159,#160,#161,#162,#184,#186,#165,#166,#191,#168,#169,#170,#171,#172,#173,#174,#175,#156,#177,#178,#168,#170,#181,#182,#175,#184,#185,#186,#187,#188,#189,#190,#185,#254,#224,#225,#246,#228,#229,#244,#227,#245,#232,#233,#234,#235,#236,#237,#238,#239,#255,#240,#241,#242,#243,#230,#226,#252,#251,#231,#248,#253,#249,#247,#250,#222,#192,#193,#214,#196,#197,#212,#195,#213,#200,#201,#202,#203,#204,#205,#206,#207,#223,#208,#209,#210,#211,#198,#194,#220,#219,#199,#216,#221,#217,#215,#218); Function Win_KoiConvert(const St: string): string; Var i: integer; Begin. Result:=St; For i:=1 to Length(St) do. If St[i]>#127 then Result[i]:=Win_KoiChars[St[i]]; End;

Алгоритм хэширования MD5.

Code: Function md5(s:string):string; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var a:array[0..15] of byte; I:integer; LenHi, LenLo: longword; Index: DWord; HashBuffer: array[0..63] of byte; CurrentHash: array[0..3] of DWord; Procedure Burn; Begin. LenHi:= 0; LenLo:= 0; Index:= 0; FillChar(HashBuffer,Sizeof(HashBuffer),0); FillChar(CurrentHash,Sizeof(CurrentHash),0); End; Procedure Init; Begin. Burn; CurrentHash[0]:= $67452301; CurrentHash[1]:= $efcdab89; CurrentHash[2]:= $98badcfe; CurrentHash[3]:= $10325476; End; Function LRot32(a, b: longword): longword; Begin. Result:= (a shl b) or (a shr (32-b)); End; Procedure Compress; Var. Data: array[0..15] of dword; A, B, C, D: dword; Begin. Move(HashBuffer,Data,Sizeof(Data)); A:= CurrentHash[0]; B:= CurrentHash[1]; C:= CurrentHash[2]; D:= CurrentHash[3]; A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 0] + $d76aa478,7); D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 1] + $e8c7b756,12); C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[ 2] + $242070db,17); B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[ 3] + $c1bdceee,22); A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 4] + $f57c0faf,7); D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 5] + $4787c62a,12); C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[ 6] + $a8304613,17); B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[ 7] + $fd469501,22); A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 8] + $698098d8,7); D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 9] + $8b44f7af,12); C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[10] + $ffff5bb1,17); B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[11] + $895cd7be,22); A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[12] + $6b901122,7); D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[13] + $fd987193,12); C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[14] + $a679438e,17); B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[15] + $49b40821,22); A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 1] + $f61e2562,5); D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[ 6] + $c040b340,9); C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[11] + $265e5a51,14); B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 0] + $e9b6c7aa,20); A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 5] + $d62f105d,5); D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[10] + $02441453,9); C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[15] + $d8a1e681,14); B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 4] + $e7d3fbc8,20); A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 9] + $21e1cde6,5); D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[14] + $c33707d6,9); C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[ 3] + $f4d50d87,14); B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 8] + $455a14ed,20); A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[13] + $a9e3e905,5); D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[ 2] + $fcefa3f8,9); C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[ 7] + $676f02d9,14); B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[12] + $8d2a4c8a,20); A:= B + LRot32(A + (B xor C xor D) + Data[ 5] + $fffa3942,4); D:= A + LRot32(D + (A xor B xor C) + Data[ 8] + $8771f681,11); C:= D + LRot32(C + (D xor A xor B) + Data[11] + $6d9d6122,16); B:= C + LRot32(B + (C xor D xor A) + Data[14] + $fde5380c,23); A:= B + LRot32(A + (B xor C xor D) + Data[ 1] + $a4beea44,4); D:= A + LRot32(D + (A xor B xor C) + Data[ 4] + $4bdecfa9,11); C:= D + LRot32(C + (D xor A xor B) + Data[ 7] + $f6bb4b60,16); B:= C + LRot32(B + (C xor D xor A) + Data[10] + $bebfbc70,23); A:= B + LRot32(A + (B xor C xor D) + Data[13] + $289b7ec6,4); D:= A + LRot32(D + (A xor B xor C) + Data[ 0] + $eaa127fa,11); C:= D + LRot32(C + (D xor A xor B) + Data[ 3] + $d4ef3085,16); B:= C + LRot32(B + (C xor D xor A) + Data[ 6] + $04881d05,23); A:= B + LRot32(A + (B xor C xor D) + Data[ 9] + $d9d4d039,4); D:= A + LRot32(D + (A xor B xor C) + Data[12] + $e6db99e5,11); C:= D + LRot32(C + (D xor A xor B) + Data[15] + $1fa27cf8,16); B:= C + LRot32(B + (C xor D xor A) + Data[ 2] + $c4ac5665,23); A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 0] + $f4292244,6); D:= A + LRot32(D + (B xor (A or (not C))) + Data[ 7] + $432aff97,10); C:= D + LRot32(C + (A xor (D or (not B))) + Data[14] + $ab9423a7,15); B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 5] + $fc93a039,21); A:= B + LRot32(A + (C xor (B or (not D))) + Data[12] + $655b59c3,6); D:= A + LRot32(D + (B xor (A or (not C))) + Data[ 3] + $8f0ccc92,10); C:= D + LRot32(C + (A xor (D or (not B))) + Data[10] + $ffeff47d,15); B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 1] + $85845dd1,21); A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 8] + $6fa87e4f,6); D:= A + LRot32(D + (B xor (A or (not C))) + Data[15] + $fe2ce6e0,10); C:= D + LRot32(C + (A xor (D or (not B))) + Data[ 6] + $a3014314,15); B:= C + LRot32(B + (D xor (C or (not A))) + Data[13] + $4e0811a1,21); A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 4] + $f7537e82,6); D:= A + LRot32(D + (B xor (A or (not C))) + Data[11] + $bd3af235,10); C:= D + LRot32(C + (A xor (D or (not B))) + Data[ 2] + $2ad7d2bb,15); B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 9] + $eb86d391,21); Inc(CurrentHash[0],A); Inc(CurrentHash[1],B); Inc(CurrentHash[2],C); Inc(CurrentHash[3],D); Index:= 0; FillChar(HashBuffer,Sizeof(HashBuffer),0); End; Procedure Update(const Buffer; Size: longword); Var. PBuf: ^byte; Begin. Inc(LenHi,Size shr 29); Inc(LenLo,Size*8); If LenLo< (Size*8) then. Inc(LenHi); PBuf:= @Buffer; While Size> 0 do. Begin. If (Sizeof(HashBuffer)-Index)<= DWord(Size) then. Begin. Move(PBuf^,HashBuffer[Index],Sizeof(HashBuffer)-Index); Dec(Size,Sizeof(HashBuffer)-Index); Inc(PBuf,Sizeof(HashBuffer)-Index); Compress; End. Else. Begin. Move(PBuf^,HashBuffer[Index],Size); Inc(Index,Size); Size:= 0; End; End; End; Procedure Final(var Digest); Begin. HashBuffer[Index]:= $80; If Index>= 56 then Compress; PDWord(@HashBuffer[56])^:= LenLo; PDWord(@HashBuffer[60])^:= LenHi; Compress; Move(CurrentHash,Digest,Sizeof(CurrentHash)); Burn; End; Begin. Init; Update(s[1],Length(s)); Final(a); Result:=''; For i:=0 to 15 do. Result:=result+IntToHex(a[i],2); Burn; End;

Определение количества заданий в спулере печати.

Spooler печати Windows посылает WM_SPOOLERSTATUS каждый раз при добавлении и удалении заданий в очереди печати. В следующем примере показано как перехватить это сообщение:

Code: Type. TForm1 = class(TForm). Label1: TLabel; Private. { Private declarations }. Procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); message WM_SPOOLERSTATUS; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); Begin. Lable1.Caption := IntToStr(msg.JobsLeft) + ' Jobs currenly in spooler'; Msg.Result := 0; End;

Печать с масштабированием.

Code: Procedure TForm1.Button1Click(Sender: TObject); // © Song. Var ScaleX, ScaleY: Integer; Begin. Printer.BeginDoc; With Printer Do. Try. ScaleX:=GetDeviceCaps(Handle,LogPixelsX) div PixelsPerInch; ScaleY:=GetDeviceCaps(Handle,LogPixelsY) div PixelsPerInch; Canvas.StretchDraw(Rect(0,0,Image1.Picture.Width*ScaleX,Image1.Picture.Height*ScaleY),Image1.Picture.Graphic); Finally. EndDoc; End; End;

Приёмы работы с BLOB (OLE/Memo) полями.

Загрузка файла из TImage:

Code: QAll.Edit; QAll.FieldByName('Logo').assign(Image.Picture); QAll.post;

Подмена данных в визуальных DB компонентах.

У всех TField существует свойство DisplayText которое используется всеми визуальными компонентами чувствительными к данным (DataAware), в том числе и ТDВGrid'ом. Т.е. TDBGrid выводит именно это свойство. В свою очередь, значение этого свойства по умолчанию равно значению из поля БД, с учетом свойства DisplayFormat (у кого оно есть). Но это по умолчанию.

Реально-же, у всех TField есть событие OnGetText. Если оно определено для поля, то DisplayText этого поля будет возвращать то, что вернет OnGetText.

Словами слишком запутанно, проще на примере:

Если поля созданы в дизайнере, то требуемому полю (например FFF) вешаем обработчик FFFOnGetText событию OnGetText.

Если-же поля создаются динамически, то соответственно вешаем обработчик динамически.

Пример обработчика:

Code: Procedure FFFOnGetText(Sender: TField; var Text: string; DisplayText: Boolean); Begin. If DisplayText then Text := AnsiUpperCase(Text); End;

Защита данных.

Давайте принципиально различать 2 ситуации:

Ситуация I.

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

Для этого случая сила криптографических алгоритмов не принципиальна. Против ламера поможет любая защита, против хакера - никакая защита не сработает, так как пароль/ключ и алгоритм уже находятся в руках, всё зашито в базе данных, exe и т.п. у пользователя на компьютере, то так или иначе эта защита вскрывается - программа дизассемблируется, трассируется, запросы к базе перехватываются и т.д. В данном случае что Парадокс, что MS Access, что любая другая база данных - не имеет значения, вопрос в том сломают её за 5 минут или за час.

Ситуация II.

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

Вот здесь надо обратить внимание на базу данных. Сразу скажу - базы данных типа Парадокс, Foxpro, MS Access - подходят только если использовать шифрование данных, надеятся на их встроенные системы защиты нельзя. Лучше всего защищены промышленные сервера, типа MS SQL Server, Oracle, DB/2, SyBase. И тем ни менее, даже при их использовании, для максимальной защиты лучше шифровать вносимые данные по какому-нибудь криптостойкому алгоритму, например:

Берётся строка: "Логин+Пароль", введенные пользователем.

На этой строке делается MD5 - получается 32 битный ключ.

Все данные читаются и пишутся с предварительной шифровкой/дешифровкой с полученным ключём использую алгоритм "трипл-дес".

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

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

©Drkb::02409.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято из http://forum.sources.ru.

Нужна база данных, работающая без каких-либо драйверов, Без ODBC/BDE/ADO/DAO etc.

Компонент называемый VolgaDB: www.volgadb.com.

©Drkb::02410.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято из http://forum.sources.ru.

Как получить список таблиц в базе Access?

Code: T:Tstringlist; ... ADOConnection.GetTableNames(t, false).

Help по синтаксису SQL для MS Access (DAO/ADO/ODBC).

Поставляется с MS Office, искать примерно здесь:

C:\Program Files\Common Files\Microsoft Shared\Office10\1033\JETSQL40.CHM.

©Drkb::02746.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято из http://forum.sources.ru.

BDE: Несколько SQL-запросов одним махом.

BDE такую возможность не поддерживает, но есть компонент в библиотеке RxLib - TSQLScript (соответственно и в JVCL - TJvSQLScript), поставляются они в исходниках, и переделать их на любой другой доступ проще-простого. Компонет делает парсинг SQL и выполняет несколько SQL запросов.

©Drkb::02633.

Автор: Петрович.

Взято из http://forum.sources.ru.

Отследить завершение работы, (перезагрузку, смену пользователя) в Windows.

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

Если мы не будем отслеживать такую ситуацию, то в худшем случае у нас могут просто потеряться какие-либо данные или Windows просто не сможет выполнить перезагрузку до конца. Ей будет мешать наша программа. Не нужно думать, что Windows перед перезагрузкой рассылает приложениям сообщения о закрытии, так чтобы у тех выпаолнились обработчкики TForm.onCloseQuery/onClose.

ОС Windows отсылает перед перезагрузкой, выключением или сменой пользователя сообщения WM_QUERYENDSESSION, а потом по его успешному завершению WM_ENDSESSION. Наше приложение должно поймать эти сообщения и отреагировать так чтобы дать понять, что мы согласны перезагружаться. В частности на сообщение WM_QUERYENDSESSION мы должны вернуть не 0:

The WM_QUERYENDSESSION message is sent when the user chooses to end the Windows session or when an application calls the ExitWindows function. If any application returns zero, the Windows session is not ended. Windows stops sending WM_QUERYENDSESSION messages as soon as one application returns zero.

Практически мы уже здесь можем завершить свою программу.

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

Code: Protected procedure IsWindowsShutDown(var Msg: TMessage);WM_ENDSESSION; .. Procedure TForm1.IsWindowsShutDown(var Msg: TMessage); Begin. Inherited; If Msg.WParam = 1 then MainForm.Close; // выгружаем приложение. End;

Получить информацию о ВIОSе.

Вот пример как можно даты БИОС материнской платы и видеокарты выдрать.

То же самое можно с названием производителя и версией.

В WinNT приходится читать не из ПЗУ а из реестра но это достаточно надежно.

- соотв ключи WinNT закрывает на запись и обновляет при каждом старте (?).

Для Win9x можешь хоть весь БИОС напрямую читать.

Получить заводской номер винчестера (не тот что getvolumeinfo дает) ИМХО.

Невозможно - порты IDE даже Win9x блокирует.

Code: Type. TRegistryRO = class (TRegistry). Function OpenKeyRO (const Key: string): Boolean; End; { это уже ветхая история - был один глюк у D3}. Implementation. Uses WAPIInfo, Windows, SysUtils, StrUtils; Function TRegistryRO.OpenKeyRO (const Key: string): Boolean; Function. IsRelative(const Value: string): Boolean; Begin Result := not ((Value <> '') and (Value[1] = '\')) end; Var. TempKey: HKey; S: string; Relative: Boolean; Begin. S := Key; Relative := IsRelative(S); If not Relative then Delete(S, 1, 1); TempKey := 0; Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0, KEY_READ, TempKey) = ERROR_SUCCESS; If Result then begin. If (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S; ChangeKey(TempKey, S); End; End; Function GetBIOSDate : string; Const. BIOSDatePtr. = $0ffff5; SystemKey = 'HARDWARE\DESCRIPTION\System'; BiosDateParam = 'SystemBiosDate'; Var. P : pointer; S : string[128]; Begin. If OSisNT then begin. With TRegistryRO.Create do try. RootKey := HKEY_LOCAL_MACHINE; If OpenKeyRO (SystemKey) then begin. S := ReadString (BiosDateParam); End; Finally Free; End; { of try}. End. Else try. S[0] := #8; P := Pointer(BIOSDatePtr); Move (p^, s[1], 8); Except FillChar (s[1], 8, '9'); End; { of try}. Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2); End; Function GetVideoDate : string; Const. VideoDatePtr = $0C0000; SystemKey = 'HARDWARE\DESCRIPTION\System'; VideoDateParam = 'VideoBiosDate'; Var. P : pointer; S : string[255]; Begin. If OSisNT then begin. With TRegistryRO.Create do try. RootKey := HKEY_LOCAL_MACHINE; If OpenKeyRO (SystemKey). Then s := ReadString (VideoDateParam). Else s := 'NT/de/tected'; Finally Free; End; { of. Try}. End. Else try. S[0] := #255; P := Pointer(VideoDatePtr + 60); { первые $60 - строка CopyRight}. Move (p^, s[1], 255); If pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8). Else begin. P := Pointer(VideoDatePtr + 60 + 250); Move (p^, s[1], 255); If pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8); End; Except FillChar (s[1], 8, '9'); End; { of try}. Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2); End;

Code: Unit WAPIInfo; Interface. Uses. Registry, SysUtils, Windows; Procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string); Function OSisNT : boolean; Procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string); Procedure GetMemInfo (var MemStr : string); Implementation. Procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string); Var. OSVerInfo : TOSVersionInfo; Reg : TRegistry; S : string; Begin. OSVerInfo.dwOSVersionInfoSize := SizeOf (OSVerInfo); GetVersionEx (OSVerInfo); OSID := OSVerInfo.dwPlatformID; Case OSID of. VER_PLATFORM_WIN32S : OSStr := 'Windows 3+'; VER_PLATFORM_WIN32_WINDOWS : OSStr := 'Windows 95+'; VER_PLATFORM_WIN32_NT : begin. OSStr := 'Windows NT'; Reg := TRegistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; If Reg.OpenKey ('SYSTEM\CurrentControlSet\Control\', False). Then try. S := Reg.ReadString ('ProductOptions'). Except s := '' End; If s = 'WINNT' then OSStr := OSStr + ' WorkStation' Else if s = 'SERVERNT' then OSStr := OSStr + ' Server 3.5 & hi' Else if s = 'LANMANNT' then OSStr := OSStr + ' Advanced server 3.1'; Reg.Free; End; End; With OSVerInfo do OSStr := OSStr + Format (' %d.%d (выпуск %d)', [dwMajorVersion, dwMinorVersion, LoWord(dwBuildNumber)]); End; Function OSisNT : boolean; Var. S : string; I : DWORD; Begin. GetOSVerInfo (i, s); Result := (i = VER_PLATFORM_WIN32_NT); End; Procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string); Var SI : TSystemInfo; Begin. GetSystemInfo (SI); CPUID := SI.dwProcessorType; Case CPUID of. 386: CPUStr := '80386-совместимый процессор'; 486: CPUStr := '80486-совместимый процессор'; 586: CPUStr := 'Pentium-совместимый процессор'; Else CPUStr := 'Неизвестный процессор'; End; { case SI.wProcessorArchitecture of. PROCESSOR_ARCHITECTURE_INTEL: ; MIPS. ALPHA. PPC. UNKNOWN. End;}. End; Procedure GetMemInfo (var MemStr : string); Var MemInfo : TMemoryStatus; Begin. MemInfo.dwLength := SizeOf (MemInfo); GlobalMemoryStatus (MemInfo); With MemInfo do MemStr := Format ('ОЗУ: %0.2f M (свободно %0.2f M)'#$d+ ' Файл подкачки: %0.2f M (свободно: %0.2f M)'#$d, [(dwTotalPhys div 1024) / 1024, (dwAvailPhys div 1024) / 1024, (dwTotalPageFile div 1024) / 1024, (dwAvailPageFile div 1024) / 1024]); End; End.

PS Возможно, эти процедуры не всегда дату возвращают но то что практически всегда для разных материнских/видео плат возвращаются разные значения - проверено, что мне собственно и требовалось.

Andrey Sorokin from sunny Статьи по Delphi (020)… Saint-Petersburg anso@mail.ru.

Russian Technology http://attend.to/rt anso@rt.spb.ru.

©Drkb::01365.

Автор: Song.

Взято из http://forum.sources.ru.

Прочитать boot сектор.

Вообще-то загрузочный сектор можно прочитать вот так:

Code: Type. TSector = array[0..511] of Byte; Var. Boot: TSector; Begin. ReadBoot(Drive, Boot);

Но учитывая разницу платформ 95, 98, Me и NT, 2000, XP можно сделать 2 процедуры, а в главной части проги вызывать необходимую:

Code: //для 95, 98, Me. Type. TDiocRegisters = record. EBX, EDX, ECX, EAX, EDI, ESI, Flags: LongWord end; TVWin32CtlCode = (ccNone, ccVWin32IntIoctl, ccVWin32Int25, CcVWin32Int26, ccVWin32Int13); Function VWin32(CtlCode: TVWin32CtlCode; Var Regs: TDiocRegisters): Boolean; // вспомогательная процедура. Var. Device: THandle; Count: LongWord; Begin. Device := CreateFile('\.\VWIN32', 0, 0, nil, 0, FILE_FLAG_DELETE_ON_CLOSE, 0); If Device = INVALID_HANDLE_VALUE then. Raise Exception.Create(SysErrorMessage(GetLastError)); Try. Result := DeviceIoControl(Device, Ord(CtlCode), @Regs, SizeOf(Regs), @Regs, SizeOf(Regs), Count, nil); Finally. CloseHandle(Device) end end; //само чтение. Procedure ReadBoot95(Drive: Char; var Boot: TSector); Var. Regs: TDiocRegisters; Begin. With Regs do begin. EAX := Ord(UpCase(Drive)) - Ord('A'); EBX := LongWord(@Boot); ECX := 1; EDX := 0 end; If not VWin32(ccVWin32Int25, Regs) then. Raise Exception.Create(SysErrorMessage(GetLastError)) end; //для NT, 2000, XP попроще. Type. TSector = array[0..511] of Byte; Procedure ReadBootNT(Drive: Char; var Boot: TSector); Var. BytesRead: Cardinal; H: THandle; Begin. H := CreateFile(PChar(Format('\.\%s:', [UpCase(Drive)])), GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); If H = INVALID_HANDLE_VALUE then. Raise Exception.Create(SysErrorMessage(GetLastError)); Try. If not ReadFile(H, Boot, SizeOf(Boot), BytesRead, nil)then. Raise Exception.Create(SysErrorMessage(GetLastError)); Finally. CloseHandle(H) end end; // а юзать так. Var. Boot: TSector; Begin. Case Win32Platform of. VER_PLATFORM_WIN32_WINDOWS: ReadBoot95(Drive, Boot); VER_PLATFORM_WIN32_NT: ReadBootNT(Drive, Boot) end;

Boot и есть необходимый массив.

Автор: startinger.

©Drkb::01380.

Взято из http://forum.sources.ru.

Перехват API функций, на примере MessageBoxA.

DLL:

Code: Library Mouse_mes; Uses. Sysutils, Windows, Messages; Type. TImageImportDescriptor=packed record. OriginalFirstThunk : DWORD; TimeDateStamp : DWORD; ForwarderChain : DWORD; Name : DWORD; FirstThunk : DWORD; End; PImageImportDescriptor=^TImageImportDescriptor; Var filename:array[0..max_path-1] of char; Hook:HHook=0; PEHeader:PImageNtHeaders; ImageBase:cardinal; Function MyHookProcedure(hWnd: HWND; lpText, lpCaption: PWideChar; uType: UINT): Integer; Stdcall; Begin. Result:=MessageBoxA(0, 'Notepad', 'my hook', 0); //Но уже через нашу табл. импорта. End; Procedure ProcessImports(PImports:PImageImportDescriptor); Var. PImport:PImageImportDescriptor; PRVA_Import:LPDWORD; ProcAddress:pointer; Temp_Cardinal:cardinal; Begin{1}. ProcAddress:=GetProcAddress(GetModuleHandle('USER32.DLL'), 'MessageBoxA'); PImport:=PImports; While PImport.Name<>0 do. Begin{2}. PRVA_Import:=LPDWORD(pImport.FirstThunk+ImageBase); While PRVA_Import^<>0 do. Begin{3}. If PPointer(PRVA_Import)^=ProcAddress. Then. Begin{4}. VirtualProtect(PPointer(PRVA_Import),4,PAGE_READWRITE,Temp_Cardinal); PPointer(PRVA_Import)^:=@MyHookProcedure; //пишем свою... VirtualProtect(PPointer(PRVA_Import),4,Temp_Cardinal,Temp_Cardinal); End;{1}. Inc(PRVA_Import); End;{2}. Inc(PImport); End;{3}. End;{4}. Procedure DllEntryPoint(reson:longint);stdcall; Begin. Case reson of. DLL_PROCESS_ATTACH: Begin. DisableThreadLibraryCalls(hInstance); ZeroMemory(@FileName, SizeOf(FileName)); GetModuleFileName(GetModuleHandle(nil), @FileName, SizeOf(FileName)); If Pos('NOTEPAD.EXE',AnsiUpper(@FileName))<>0 then //сейчас я хочу попробовать все это дело надо нотепадом. Begin. ImageBase:=GetModuleHandle(nil); PEHeader:=pointer(int64(ImageBase)+PImageDosHeader(ImageBase)._lfanew);//pe header. ProcessImports(pointer(PEHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress+ImageBase)); End; End; End; End; Function nexthook(code:integer;wParam,lParam:longint):longint;stdcall; Begin. Result:=callnexthookex(hook,code,wParam,lParam); End; Procedure sethook(flag:bool);export; stdcall; Begin. If flag then. Hook:=setwindowshookex(wh_getmessage,@nexthook,hInstance,0). Else. Begin. Unhookwindowshookex(hook); Hook:=0; End; End; Exports sethook; Begin. DLLProc:=@DllEntryPoint; DllEntryPoint(DLL_PROCESS_ATTACH). End.

Как стать невидимым в Windows NT (статья)?

Как стать невидимым в Windows NT.

Author: Holy_Father <holy_father@phreaker.net>

Version: 1.2 russian.

Date: 05.08.2003.

Translation: Kerk <kerk_p@yahoo.com>

Вступление.

Эта статья описывает техники скрытия объектов, файлов, сервисов,

Процессов и т.д. в ОС Windows NT. Эти методы основаны на перехвате функций.

Windows API, что описано в моей статье "Hooking Windows API".

Данная информация была получена мною в процессе написания rооtкit'а,

Поэтому есть вероятность, что это может быть реализовано более эффективно или.

Намного более просто.

Под скрытием объектов в этой статье подразумевается замена некоторых.

Системных функций, которые работают с этим объектом таким образом, чтобы они.

Его пропускали. В случае, если объект - всего лишь возвращаемое значение.

Функции, мы просто возвратим значение, как будто бы объекта не существует.

Простейший метод (исключая случаи, когда сказано обратное) - это.

Вызов оригинальной функции с оригинальными аргументами и замена ее выходных.

Данных.

В этой версии статьи описаны методы скрытия файлов, процессов,

Ключей и значений реестра, системных сервисов и драйверов, выделенной памяти и.

Хэндлов.

Файлы.

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

Видеть. Мы сконцентрируемся на изменении API и отбросим такие техники, как.

Использование возможностей файловой системы. К тому же это намного проще, т.к.

В этом случае нам не нужно знать как работает конкретная файловая система.

NtQueryDirectoryFile.

Поиск файла в wNT в какой-либо директории заключается в просмотре всех.

Файлов этой директории и файлов всех ее поддиректорий. Для перечисления файлов.

Используется функция NtQueryDirectoryFile.

NTSTATUS NtQueryDirectoryFile(

IN HANDLE FileHandle,

IN HANDLE Event OPTIONAL,

IN PIO_APC_ROUTINE ApcRoutine OPTIONAL,

IN PVOID ApcContext OPTIONAL,

OUT PIO_STATUS_BLOCK IoStatusBlock,

OUT PVOID FileInformation,

IN ULONG FileInformationLength,

IN FILE_INFORMATION_CLASS FileInformationClass,

IN BOOLEAN ReturnSingleEntry,

IN PUNICODE_STRING FileName OPTIONAL,

IN BOOLEAN RestartScan.

);

Для нас важны параметры FileHandle, FileInformation.

И FileInformationClass. FileHandle - хэндл объекта директории, который может.

Быть получен с использованием функции NtOpenFile. FileInformation - указатель.

На выделенную память, куда функция запишет необходимые данные.

FileInformationClass определяет тип записей в FileInformation.

FileInformationClass перечислимого типа, но нам необходимы только.

Четыре его значения, используемые для просмотра содержимого директории.

#define FileDirectoryInformation 1.

#define FileFullDirectoryInformation 2.

#define FileBothDirectoryInformation 3.

#define FileNamesInformation 12.

Структура записи в FileInformation для FileDirectoryInformation:

Typedef struct _FILE_DIRECTORY_INFORMATION {

ULONG NextEntryOffset;

ULONG Unknown;

LARGE_INTEGER CreationTime;

LARGE_INTEGER LastAccessTime;

LARGE_INTEGER LastWriteTime;

LARGE_INTEGER ChangeTime;

LARGE_INTEGER EndOfFile;

LARGE_INTEGER AllocationSize;

ULONG FileAttributes;

ULONG FileNameLength;

WCHAR FileName[1];

} FILE_DIRECTORY_INFORMATION, *PFILE_DIRECTORY_INFORMATION;

Для FileFullDirectoryInformation:

Typedef struct _FILE_FULL_DIRECTORY_INFORMATION {

ULONG NextEntryOffset;

ULONG Unknown;

LARGE_INTEGER CreationTime;

LARGE_INTEGER LastAccessTime;

LARGE_INTEGER LastWriteTime;

LARGE_INTEGER ChangeTime;

LARGE_INTEGER EndOfFile;

LARGE_INTEGER AllocationSize;

ULONG FileAttributes;

ULONG FileNameLength;

ULONG EaInformationLength;

WCHAR FileName[1];

} FILE_FULL_DIRECTORY_INFORMATION, *PFILE_FULL_DIRECTORY_INFORMATION;

Для FileBothDirectoryInformation:

Typedef struct _FILE_BOTH_DIRECTORY_INFORMATION {

ULONG NextEntryOffset;

ULONG Unknown;

LARGE_INTEGER CreationTime;

LARGE_INTEGER LastAccessTime;

LARGE_INTEGER LastWriteTime;

LARGE_INTEGER ChangeTime;

LARGE_INTEGER EndOfFile;

LARGE_INTEGER AllocationSize;

ULONG FileAttributes;

ULONG FileNameLength;

ULONG EaInformationLength;

UCHAR AlternateNameLength;

WCHAR AlternateName[12];

WCHAR FileName[1];

} FILE_BOTH_DIRECTORY_INFORMATION, *PFILE_BOTH_DIRECTORY_INFORMATION;

И для FileNamesInformation:

Typedef struct _FILE_NAMES_INFORMATION {

ULONG NextEntryOffset;

ULONG Unknown;

ULONG FileNameLength;

WCHAR FileName[1];

} FILE_NAMES_INFORMATION, *PFILE_NAMES_INFORMATION;

Функция записывает набор этих структур в буфер FileInformation.

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

NextEntryOffset - размер данного элемента списка. Первый элемент.

Расположен по адресу FileInformation + 0, а второй элемент по адресу.

FileInformation + NextEntryOffset первого элемента. У последнего элемента.

Поле NextEntryOffset содержит нуль.

FileName - это полное имя файла.

FileNameLength - это длина имени файла.

Для скрытия файла, необходимо сравнить имя каждой возвращаемой записи.

И имя файла, который мы хотим скрыть. Если мы хотим скрыть первую запись,

Нужно сдвинуть следующие за ней структуры на размер первой записи. Это приведет.

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

Мы можем просто изменить значение NextEntryOffset предыдущей записи. Новое.

Значение NextEntryOffset будет нуль, если мы хотим скрыть последнюю запись,

Иначе значение будет суммой полей NextEntryOffset записи, которую мы хотим.

Скрыть и предыдущей записи. Затем необходимо изменить значение поля Unknown.

Предыдущей записи, которое предоставляет индекс для последующего поиска.

Значение поля Unknown предыдущей записи должно равняться значению поля Unknown.

Записи, которую мы хотим скрыть.

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

STATUS_NO_SUCH_FILE.

#define STATUS_NO_SUCH_FILE 0xC000000F.

NtVdmControl.

По неизвестной причине эмуляция DOS - NTVDM может получить список.

Файлов еще и с помощью функции NtVdmControl.

NTSTATUS NtVdmControl(

IN ULONG ControlCode,

IN PVOID ControlData.

);

ControlCode указывает подфункцию, которая будет применена к данным.

В буфере ControlData. Если ControlCode равняется VdmDirectoryFile, эта.

Функция делает то же, что и NtQueryDirectoryFile с FileInformationClass.

Равным FileBothDirectoryInformation.

#define VdmDirectoryFile 6.

Тогда буфер ControlData используется как FileInformation. Единственная.

Разница в том, что мы не знаем длину этого буфера. Поэтому мы должны вычислить.

Ее вручную. Мы можем сложить NextEntryOffset всех записей, FileNameLength.

Последней записи и 0x5E (длина последней записи исключая длину имени файла).

Методы скрытия такие же как и в случае с NtQueryDirectoryFile.

Процессы.

Различная системная информация доступна через NtQuerySystemInformation.

NTSTATUS NtQuerySystemInformation(

IN SYSTEM_INFORMATION_CLASS SystemInformationClass,

IN OUT PVOID SystemInformation,

IN ULONG SystemInformationLength,

OUT PULONG ReturnLength OPTIONAL.

);

SystemInformationClass указывает тип информации, которую мы хотим.

Получить, SystemInformation - это указатель на результирующий буфер,

SystemInformationLength - размер этого буфера и ReturnLength - количество.

Записанных байт.

Для перечисления запущенных процессов мы устанавливаем в параметр.

SystemInformationClass значение SystemProcessesAndThreadsInformation.

#define SystemInformationClass 5.

Возвращаемая структура в буфере SystemInformation:

Typedef struct _SYSTEM_PROCESSES {

ULONG NextEntryDelta;

ULONG ThreadCount;

ULONG Reserved1[6];

LARGE_INTEGER CreateTime;

LARGE_INTEGER UserTime;

LARGE_INTEGER KernelTime;

UNICODE_STRING ProcessName;

KPRIORITY BasePriority;

ULONG ProcessId;

ULONG InheritedFromProcessId;

ULONG HandleCount;

ULONG Reserved2[2];

VM_COUNTERS VmCounters;

IO_COUNTERS IoCounters; // только Windows 2000.

SYSTEM_THREADS Threads[1];

} SYSTEM_PROCESSES, *PSYSTEM_PROCESSES;

Скрытие процессов похоже на скрытие файлов. Мы должны изменить.

NextEntryDelta записи предшествующей записи скрываемого процесса. Обычно.

Не требуется скрывать первую запись, т.к. это процесс Idle.

Реестр.

Реестр Windows - это достаточно большая древовидная структура,

Содержащая два важных типа записей, которые мы можем захотеть скрыть. Первый.

Тип - ключи реестра, второй - значения реестра. Благодаря структуре реестра.

Скрытие его ключей не так тривиально, как скрытие файлов или процессов.

NtEnumerateKey.

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

В какой-либо его части. Мы можем получить информацию только об одном ключе,

Указанном его индексом. Используется функция NtEnumerateKey.

NTSTATUS NtEnumerateKey(

IN HANDLE KeyHandle,

IN ULONG Index,

IN KEY_INFORMATION_CLASS KeyInformationClass,

OUT PVOID KeyInformation,

IN ULONG KeyInformationLength,

OUT PULONG ResultLength.

);

KeyHandle - это дескриптор ключа, в котором мы хотим получить.

Информацию о подключе, указанном параметром Index. Тип полученной информации.

Определяется полем KeyInformationClass. Данные записываются в буфер.

KeyInformation, длина которого указана в параметре KeyInformationLength.

Количество записанных байт возвращается в ResultLength.

Наиболее важным является понимание того, что если мы скроем ключ, то.

Индексы всех последующих ключей будут сдвинуты. И так как нам придется получать.

Информацию о ключе с большим индексом запрашивая ключ с меньшим индексом, мы.

Должны подсчитать количество записей до скрытой и вернуть правильное значение.

Давайте разберем пример. Допустим в какой-то части реестра есть ключи с.

Именами A, B, C, D, E и F. Индекс начинается с нуля, это означает, что ключ E.

Имеет индекс 4. Теперь, если мы хотим скрыть ключ B и приложение вызвало.

NtEnumerateKey с Index равным 4, мы должны вернуть информацию о ключе F, так.

Как индекс сдвинут. Проблема в том, что нам неизвестно, что нужно произвести.

Сдвиг. А если мы не позаботимся о сдвиге, то вернем E вместо F, когда будет.

Запрашиваться ключ с индексом 4, или ничего не вернем для ключа с индексом 1,

Хотя должны вернуть C. В обоих случаях ошибка. Вот почему мы должны подумать.

О сдвиге.

Если мы будем вычислять сдвиг вызовом функции для каждого индекса.

От 0 до Index, иногда нам придется ждать годами (на 1ГГц процессоре это может.

Занять до 10 секунд со стандартным реестром, который очень большой). Поэтому.

Мы должны придумать более совершенный метод.

Мы знаем, что ключи (исключая ссылки) отсортированы по алфавиту. Если.

Мы пренебрежем ссылками (которые мы не хотим скрывать), мы сможем вычислить.

Сдвиг следующим методом. Мы отсортируем по алфавиту список имен ключей, которые.

Необходимо скрыть (используя RtlCompareUnicodeString), затем, когда приложение.

Вызывает NtEnumerateKey, мы не будем перевызывать ее с неизмененными.

Аргументами, а определим имя записи указанной параметром Index.

NTSTATUS RtlCompareUnicodeString(

IN PUNICODE_STRING String1,

IN PUNICODE_STRING String2,

IN BOOLEAN CaseInSensitive.

);

String1 и String2 - строки, которые необходимо сравнить,

CaseInSensitive - True, если мы хотим провести сравнение, игнорируя регистр.

Результат функции описывает отношение между String1 и String2:

Result > 0: String1 > String2.

Result = 0: String1 = String2.

Result < 0: String1 < String2.

Теперь мы должны найти границу. Мы сравним имя, указанное параметром Index с.

Именами в нашем списке. Границей будет последнее меньшее имя из нашего списка.

Мы знаем, что сдвиг не превышает номер граничного элемента в нашем списке.

Но не все элементы списка являются действительными ключами в той части реестра,

Где мы находимся. Поэтому мы должны определить элементы списка до границы,

Которые являются частью реестра. Мы можем сделать это используя NtOpenKey.

NTSTATUS NtOpenKey(

OUT PHANDLE KeyHandle,

IN ACCESS_MASK DesiredAccess,

IN POBJECT_ATTRIBUTES ObjectAttributes.

);

KeyHandle - это хэндл родительского ключа. Мы будем использовать.

Значение, переданное в NtEnumerateKey. DesiredAccess - права доступа,

Используем значение KEY_ENUMERATE_SUB_KEYS. ObjectAttributes описывают.

Подключ, которых мы хотим открыть (включая его имя).

#define KEY_ENUMERATE_SUB_KEYS 8.

Если NtOpenKey вернет 0 - ключ был открыт успешно - это значит, что.

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

NtClose.

NTSTATUS NtClose(

IN HANDLE Handle.

);

При каждом вызове функции NtEnumerateKey мы должны вычислять сдвиг,

Как количество ключей из нашего списка, которые существуют в данной части.

Реестра. Затем мы должны прибавить этот сдвиг к аргументу Index и, наконец,

Вызвать оригинальную NtEnumerateKey.

Для получения имени ключа, указанного параметром Index, мы используем.

KeyBasicInformation в качестве значения для KeyInformationClass.

#define KeyBasicInformation 0.

NtEnumerateKey вернет в буфере KeyInformation структуру:

Typedef struct _KEY_BASIC_INFORMATION {

LARGE_INTEGER LastWriteTime;

ULONG TitleIndex;

ULONG NameLength;

WCHAR Name[1];

} KEY_BASIC_INFORMATION, *PKEY_BASIC_INFORMATION;

Единственное что нам нужно - это Name, и его длина - NameLength.

Если ключа для сдвинутого параметра Index не существует, мы.

Должны вернуть ошибку STATUS_EA_LIST_INCONSISTENT.

#define STATUS_EA_LIST_INCONSISTENT 0x80000014.

NtEnumerateValueKey.

Значения реестра не отсортированы. К счастью, их количество в одном.

Ключе достаточно мало, поэтому мы можем перевызывать функцию, чтобы получить.

Сдвиг. API для получения информации об одном значении реестра.

Назывется NtEnumarateValueKey.

NTSTATUS NtEnumerateValueKey(

IN HANDLE KeyHandle,

IN ULONG Index,

IN KEY_VALUE_INFORMATION_CLASS KeyValueInformationClass,

OUT PVOID KeyValueInformation,

IN ULONG KeyValueInformationLength,

OUT PULONG ResultLength.

);

KeyHandle - это снова хэндл родительского ключа. Index - это индекс.

В списке значений данного ключа. KeyValueInformationClass описывает тип.

Информации, которая будет помещена в буфер KeyValueInformation размером.

KeyValueInformationLength байт. Количество записанных в буфер байт возвращается.

В ResultLength.

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

Индексов от 0 до Index. Имя значения может быть получено при использовании.

KeyValueBasicInformation в качестве значения для KeyValueInformationClass.

#define KeyValueBasicInformation 0.

Тогда в буфере KeyValueInformation мы получим следующую структуру:

Typedef struct _KEY_VALUE_BASIC_INFORMATION {

ULONG TitleIndex;

ULONG Type;

ULONG NameLength;

WCHAR Name[1];

} KEY_VALUE_BASIC_INFORMATION, *PKEY_VALUE_BASIC_INFORMATION;

Нас снова интересуют только Name и NameLength.

Если для сдвинутого параметра Index не существует соответствующего.

Значения реестра, то мы должны вернуть STATUS_NO_MORE_ENTRIES.

#define STATUS_NO_MORE_ENTRIES 0x8000001A.

Сервисы и драйверы.

Системные сервисы и драйверы обрабатываются четырьмя независимыми.

API-функциями. Их связи различны в каждой версии Windows. Поэтому мы вынуждены.

Перехватывать все четыре функции.

BOOL EnumServicesStatusA(

SC_HANDLE hSCManager,

DWORD dwServiceType,

DWORD dwServiceState,

LPENUM_SERVICE_STATUS lpServices,

DWORD cbBufSize,

LPDWORD pcbBytesNeeded,

LPDWORD lpServicesReturned,

LPDWORD lpResumeHandle.

);

BOOL EnumServiceGroupW(

SC_HANDLE hSCManager,

DWORD dwServiceType,

DWORD dwServiceState,

LPBYTE lpServices,

DWORD cbBufSize,

LPDWORD pcbBytesNeeded,

LPDWORD lpServicesReturned,

LPDWORD lpResumeHandle,

DWORD dwUnknown.

);

BOOL EnumServicesStatusExA(

SC_HANDLE hSCManager,

SC_ENUM_TYPE InfoLevel,

DWORD dwServiceType,

DWORD dwServiceState,

LPBYTE lpServices,

DWORD cbBufSize,

LPDWORD pcbBytesNeeded,

LPDWORD lpServicesReturned,

LPDWORD lpResumeHandle,

LPCTSTR pszGroupName.

);

BOOL EnumServicesStatusExW(

SC_HANDLE hSCManager,

SC_ENUM_TYPE InfoLevel,

DWORD dwServiceType,

DWORD dwServiceState,

LPBYTE lpServices,

DWORD cbBufSize,

LPDWORD pcbBytesNeeded,

LPDWORD lpServicesReturned,

LPDWORD lpResumeHandle,

LPCTSTR pszGroupName.

);

Наиболее важен здесь параметр lpServices, которое указывает на буфер,

Где должен быть размещен список сервисов. lpServicesReturned, которое указывает.

На количество записей в буфере, также важно. Структура данных в выходном буфере.

Зависит от типа функции. Для функций EnumServicesStatusA и EnumServicesGroupW.

Возвращается структура:

Typedef struct _ENUM_SERVICE_STATUS {

LPTSTR lpServiceName;

LPTSTR lpDisplayName;

SERVICE_STATUS ServiceStatus;

} ENUM_SERVICE_STATUS, *LPENUM_SERVICE_STATUS;

Typedef struct _SERVICE_STATUS {

DWORD dwServiceType;

DWORD dwCurrentState;

DWORD dwControlsAccepted;

DWORD dwWin32ExitCode;

DWORD dwServiceSpecificExitCode;

DWORD dwCheckPoint;

DWORD dwWaitHint;

} SERVICE_STATUS, *LPSERVICE_STATUS;

А для EnumServicesStatusExA и EnumServicesStatusExW:

Typedef struct _ENUM_SERVICE_STATUS_PROCESS {

LPTSTR lpServiceName;

LPTSTR lpDisplayName;

SERVICE_STATUS_PROCESS ServiceStatusProcess;

} ENUM_SERVICE_STATUS_PROCESS, *LPENUM_SERVICE_STATUS_PROCESS;

Typedef struct _SERVICE_STATUS_PROCESS {

DWORD dwServiceType;

DWORD dwCurrentState;

DWORD dwControlsAccepted;

DWORD dwWin32ExitCode;

DWORD dwServiceSpecificExitCode;

DWORD dwCheckPoint;

DWORD dwWaitHint;

DWORD dwProcessId;

DWORD dwServiceFlags;

} SERVICE_STATUS_PROCESS, *LPSERVICE_STATUS_PROCESS;

Нас интересует только поле lpServiceName, которое содержит имя.

Сервиса. Записи имеют фиксированный размер, поэтому, если мы хотим скрыть.

Одну, мы передвинем все последующие записи на ее размер. Здесь мы должны.

Помнить о различии размеров SERVICE_STATUS и SERVICE_STATUS_PROCESS.

Перехват и распространение.

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

Процессы, а также процессы, которые будут запущены позже. Новые процессы должны.

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

Наши скрытые объекты до того, как функции будут перехвачены.

Привелегии.

Нам нужны как минимум администраторские права, чтобы получить доступ ко.

Всем запущенным процессам. Лучшая возможность - это запуск нашего процесса как.

Системного сервиса, который работает с правами пользователя SYSTEM. Чтобы.

Установить сервис нам тоже нужны специальные привелегии.

Также очень полезно получение привелегии SeDebugPrivilege. Это может.

Быть сделано с помощью функций OpenProcessToken, LookupPrivilegeValue и.

AdjustTokenPrivileges.

BOOL OpenProcessToken(

HANDLE ProcessHandle,

DWORD DesiredAccess,

PHANDLE TokenHandle.

);

BOOL LookupPrivilegeValue(

LPCTSTR lpSystemName,

LPCTSTR lpName,

PLUID lpLuid.

);

BOOL AdjustTokenPrivileges(

HANDLE TokenHandle,

BOOL DisableAllPrivileges,

PTOKEN_PRIVILEGES NewState,

DWORD BufferLength,

PTOKEN_PRIVILEGES PreviousState,

PDWORD ReturnLength.

);

Игнорируя возможные ошибки, это может быть сделано так:

#define SE_PRIVILEGE_ENABLED 0x0002.

#define TOKEN_QUERY 0x0008.

#define TOKEN_ADJUST_PRIVILEGES 0x0020.

HANDLE hToken;

LUID DebugNameValue;

TOKEN_PRIVILEGES Privileges;

DWORD dwRet;

OpenProcessToken(GetCurrentProcess(),

TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,hToken);

LookupPrivilegeValue(NULL,"SeDebugPrivilege",&DebugNameValue);

Privileges.PrivilegeCount=1;

Privileges.Privileges[0].Luid=DebugNameValue;

Privileges.Privileges[0].Attributes=SE_PRIVILEGE_ENABLED;

AdjustTokenPrivileges(hToken,FALSE,&Privileges,sizeof(Privileges),

NULL,&dwRet);

CloseHandle(hToken);

Перехват.

Перечисление процессов производится уже упомянутой API-функцией.

NtQuerySystemInformation. Для перехвата функций используется метод перезаписи.

Ее первых инструкций. Это делается для каждого запущеного процесса. Мы выделим.

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

Перехватить. Затем заменим первые пять байт этих функций на инструкцию jmp.

Эта инструкция будет перенаправлять выполнение на наш код. Так, инструкция jmp.

Будет выполнена сразу, как только функция будет вызвана. Мы должны сохранить.

Первые инструкции каждой перезаписанной функции - они необходимы для вызова.

Оригинального кода перехваченной функции. Сохранение инструкций описывается в.

Разделе 3.2.3 статьи "Hooking Windows API".

Сначала мы должны открыть нужный процесс с помощью NtOpenProcess и.

Получить его хэндл. Произойдет ошибка, если у нас недостаточно привелегий.

NTSTATUS NtOpenProcess(

OUT PHANDLE ProcessHandle,

IN ACCESS_MASK DesiredAccess,

IN POBJECT_ATTRIBUTES ObjectAttributes,

IN PCLIENT_ID ClientId OPTIONAL.

);

ProcessHandle - указатель на хэндл, где будет сохранен результат.

DesiredAccess следует установить равным PROCESS_ALL_ACCESS. Мы установим.

Поле UniqueProcess структуры ClientId равным PID нужного процесса, UniqueThread.

Должно быть равно нулю. Открытый хэндл должен быть закрыт с помощью NtClose.

#define PROCESS_ALL_ACCESS 0x001F0FFF.

Теперь мы выделим память для нашего кода. Это может быть сделано.

С помощью функции NtAllocateVirtualMemory.

NTSTATUS NtAllocateVirtualMemory(

IN HANDLE ProcessHandle,

IN OUT PVOID BaseAddress,

IN ULONG ZeroBits,

IN OUT PULONG AllocationSize,

IN ULONG AllocationType,

IN ULONG Protect.

);

Используется значение ProcessHandle возвращенное функцией.

NtOpenProcess. BaseAddress - указатель на указатель на желаемое начало блока.

Выделенной памяти. Здесь будет сохранен указатель на выделенную память.

Входное значение может быть равно NULL. AllocationSize - указатель на.

Переменную, содержащую размер буфера, который мы хотим выделить. И также.

Здесь будет сохранено количество реально выделенных байт. Рекомендую включить.

Значение MEM_TOP_DOWN в параметр AllocationType в дополнение к MEM_COMMIT, т.к.

В этом случае память будет выделена как можно выше рядом с DLL.

#define MEM_COMMIT 0x00001000.

#define MEM_TOP_DOWN 0x00100000.

Теперь мы можем записать наш код, используя NtWriteVirtualMemory.

NTSTATUS NtWriteVirtualMemory(

IN HANDLE ProcessHandle,

IN PVOID BaseAddress,

IN PVOID Buffer,

IN ULONG BufferLength,

OUT PULONG ReturnLength OPTIONAL.

);

В параметре BaseAddress используем значение возвращенное.

NtAllocateVirtual. Buffer указывает на байты, которые мы хотим записать,

BufferLength - количество этих байтов.

Теперь мы перехватим функции. Единственная DLL, которая загружается в.

Каждый процесс - ntdll.dll. Так, мы должны проверить импортирована ли функция,

Которую мы хотим перехватить, в процесс, если эта функция не из ntdll.dll.

Но память, которую эта функция (из другой DLL) могла бы занимать может быть.

Выделена, и перезапись этих байт повлечет за собой сбой в процессе. Поэтому.

Мы должны проверить загружена ли эта библиотека (в которой нужная нам функция).

В процесс.

Мы должны получить PEB (Process Environment Block) нужного процесса,

Используя NtQueryInformationProcess.

NTSTATUS NtQueryInformationProcess(

IN HANDLE ProcessHandle,

IN PROCESSINFOCLASS ProcessInformationClass,

OUT PVOID ProcessInformation,

IN ULONG ProcessInformationLength,

OUT PULONG ReturnLength OPTIONAL.

);

Присвоим значение ProcessBasicInformation параметру.

ProcessInformationClass. Тогда в буфер ProcessInformation, размер которого.

Указан в параметре ProcessInformationLength, будет возвращена структура.

PROCESS_BASIC_INFORMATION.

#define ProcessBasicInformation 0.

Typedef struct _PROCESS_BASIC_INFORMATION {

NTSTATUS ExitStatus;

PPEB PebBaseAddress;

KAFFINITY AffinityMask;

KPRIORITY BasePriority;

ULONG UniqueProcessId;

ULONG InheritedFromUniqueProcessId;

} PROCESS_BASIC_INFORMATION, *PPROCESS_BASIC_INFORMATION;

PebBaseAddress - то, что мы ищем. PebBaseAddress+0x0C - это адрес.

PPEB_LDR_DATA. Он может быть получен вызовом NtReadVirtualMemory.

NTSTATUS NtReadVirtualMemory(

IN HANDLE ProcessHandle,

IN PVOID BaseAddress,

OUT PVOID Buffer,

IN ULONG BufferLength,

OUT PULONG ReturnLength OPTIONAL.

);

Параметры такие же как и у NtWriteVirtualMemory.

PPEB_LDR_DATA+0x1C - адрес InInitializationOrderModuleList. Это список.

Библиотек, загруженных в процесс. Нас интересует только часть этой структуры.

Typedef struct _IN_INITIALIZATION_ORDER_MODULE_LIST {

PVOID Next,

PVOID Prev,

DWORD ImageBase,

DWORD ImageEntry,

DWORD ImageSize,

...

);

Next - указатель на следующую запись, Prev - на предыдущую. Последняя.

Запись указывает на первую. ImageBase - адрес модуля в памяти. ImageEntry - это.

Точка входа модуля, ImageSize - его размер.

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

ImageBase (например, используя GetModuleHandle или LoadLibrary). Эту ImageBase.

Мы сравним с ImageBase каждого элемента в InInitializationOrderModuleList.

Теперь мы готовы к перехвату. Из-за того, что мы перехватываем функции.

В работающих процессах, существует вероятность, что код, который мы будем.

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

Поэтому сначала мы остановим все потоки этого процесса. Список потоков можно.

Получить, используя функцию NtQuerySystemInformation с классом.

SystemProcessesAndThreadsInformation. Результат работы этой функции описан в.

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

Содержит информацию о потоке.

Typedef struct _SYSTEM_THREADS {

LARGE_INTEGER KernelTime;

LARGE_INTEGER UserTime;

LARGE_INTEGER CreateTime;

ULONG WaitTime;

PVOID StartAddress;

CLIENT_ID ClientId;

KPRIORITY Priority;

KPRIORITY BasePriority;

ULONG ContextSwitchCount;

THREAD_STATE State;

KWAIT_REASON WaitReason;

} SYSTEM_THREADS, *PSYSTEM_THREADS;

Для каждого потока мы должны получить его хэндл, используя.

NtOpenThread. Мы используем для этого ClientId.

NTSTATUS NtOpenThread(

OUT PHANDLE ThreadHandle,

IN ACCESS_MASK DesiredAccess,

IN POBJECT_ATTRIBUTES ObjectAttributes,

IN PCLIENT_ID ClientId.

);

Хэндл, который нам нужен, будет сохранен в ThreadHandle. Параметр.

DesiredAccess должен быть равен THREAD_SUSPEND_RESUME.

#define THREAD_SUSPEND_RESUME 2.

ThreadHandle будет использован при вызове NtSuspendThread.

NTSTATUS NtSuspendThread(

IN HANDLE ThreadHandle,

OUT PULONG PreviousSuspendCount OPTIONAL.

);

Приостановленный процесс готов к перезаписи. Мы поступим, как описано.

В разделе 3.2.2 статьи "Hooking Windows API". Единственная разница в том, что.

Функции будут использоваться для других процессов.

После перехвата мы возобновим работу всех потоков процесса, используя.

NtResumeThread.

NTSTATUS NtResumeThread(

IN HANDLE ThreadHandle,

OUT PULONG PreviousSuspendCount OPTIONAL.

);

Новые процессы.

Заражение всех запущенных процессов не затронет процессы, которые будут.

Запущены позже. Мы должны получить список процессов, через некоторое время.

Получить новый, сравнить их, а затем заразить те процессы, которые есть во.

Втором списке и отсутствуют в первом. Но этот метод очень ненадежен.

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

Новый процесс. Так как все запущенные в системе процессы заражены, мы не сможем.

Пропустить ни один новый процесс, используя данный метод. Мы можем перехватить.

NtCreateThread, но это не самый простой путь. Мы будем перехватывать функцию.

NtResumeThread, которая также всегда вызывается при старте нового процесса.

Она вызвается после NtCreateThread.

Единственная проблема с NtResumeThread состоит в том, что она.

Вызывается не только при запуске нового процесса. Но мы легко решим эту.

Проблему. NtQueryInformationThread предоставит нам информацию о том, какой.

Процесс владеет данным потоком. Мы должны просто проверить, заражен ли этот.

Процесс. Это можно определить прочитав первые байты любой из функций, которые.

Мы перехватываем.

NTSTATUS NtQueryInformationThread(

IN HANDLE ThreadHandle,

IN THREADINFOCLASS ThreadInformationClass,

OUT PVOID ThreadInformation,

IN ULONG ThreadInformationLength,

OUT PULONG ReturnLength OPTIONAL.

);

В нашем случае параметр ThreadInformationClass должен быть равен.

ThreadBasicInformation. ThreadInformation - это буфер для результата, размер.

Этого буфера указан в параметре ThreadInformationLength.

#define ThreadBasicInformation 0.

Для класса ThreadBasicInformation возвращается такая структура:

Typedef struct _THREAD_BASIC_INFORMATION {

NTSTATUS ExitStatus;

PNT_TIB TebBaseAddress;

CLIENT_ID ClientId;

KAFFINITY AffinityMask;

KPRIORITY Priority;

KPRIORITY BasePriority;

} THREAD_BASIC_INFORMATION, *PTHREAD_BASIC_INFORMATION;

В параметре ClientId находится PID процесса, владеющего этим потоком.

Теперь мы должны заразить новый процесс. Проблема в том, что процесс.

Имеет в своей памяти только ntdll.dll. Все остальные модули загружаются сразу.

После вызова NtResumeThread. Существует несколько путей решения этой проблемы.

Например, можно перехватить функцию LdrInitializeThunk, которая вызывается при.

Инициализации процесса.

NTSTATUS LdrInitializeThunk(

DWORD Unknown1,

DWORD Unknown2,

DWORD Unknown3.

);

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

Нужные функции в новом процессе. Затем лучше снять перехват LdrInitializeThunk,

Так как она будет вызвана позже много раз, а мы не хватим заново перехватывать.

Все функции. Все это будет сделано до выполнения первых инструкций процесса,

Поэтому нет вероятности того, что этот процесс вызовет какую-нибудь из.

Перехватываемых функций до того, как мы ее перехватим.

Перехват функций в своем процессе такой же как и перехват в запущенном.

Процессе, но нам не нужно беспокоиться о потоках.

DLL.

В каждом процессе в системе есть копия ntdll.dll. Это значит, что мы.

Можем перехватить любую функцию этого модуля при инициализации процесса.

Но как быть с функциями из других модулей, например, kernel32.dll или.

Advapi32.dll? Есть несколько процессов, у которых есть только ntdll.dll.

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

Перехвата процесса. Вот почему мы должны перехватить LdrLoadDll, которая.

Загружает новые модули.

NTSTATUS LdrLoadDll(

PWSTR szcwPath,

PDWORD pdwLdrErr,

PUNICODE_STRING pUniModuleName,

PHINSTANCE pResultInstance.

);

Наиболее важно для нас pUniModuleName - имя модуля. pResultInstance.

Будет адресом модуля, если вызов был успешен.

Мы вызовем оригинальную LdrLoadDll и затем перехватим все функции в.

Загруженном модуле.

Память.

Когда мы перехватываем функцию, мы изменяем ее первые байты. Вызвав.

NtReadVirtualMemory, кто угодно сможет определить, что функция перехвачена.

Поэтому мы должны перехватить NtReadVirtualMemory, чтобы избежать обнаружения.

NTSTATUS NtReadVirtualMemory(

IN HANDLE ProcessHandle,

IN PVOID BaseAddress,

OUT PVOID Buffer,

IN ULONG BufferLength,

OUT PULONG ReturnLength OPTIONAL.

);

Мы заменили байты в начале тех функций, которые перехватили, и еще.

Выделили память для нового кода. Необходимо проверить читает ли функция.

Какие-либо из этих байт. Если наши байты находятся в диапазоне от BaseAddress.

До (BaseAddress + BufferLength), мы должны заменить некоторые байты в Buffer.

Если кто-либо пытается прочитать байты из нашей выделенной памяти,

Следует вернуть пустой Buffer и ошибку STATUS_PARTIAL_COPY. Это значение.

Говорит о том, что не все запрошенные байты были скопированы в буфер Buffer.

Это также происходит при попытке доступа к невыделенной памяти. ReturnLength.

Должно быть установлено в нуль в данном случае.

#define STATUS_PARTIAL_COPY 0x8000000D.

Если кто-нибудь запрашивает первые байты перехваченной нами функции,

Мы должны вызвать оригинальный код, а затем скопировать оригинальные байты.

(мы их сохранили) в буфер Buffer.

Теперь процесс не сможет определить, что функции перехвачены, чтением.

Памяти. Также, если вы отлаживаете перехватываченные функции, у отладчика будут.

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

Чтобы сделать скрытие совершенным, мы еще должны перехватить функцию.

NtQueryVirtualMemory, которая используется для получения информации о.

Виртуальной памяти. Мы можем перехватить ее, чтобы предотвратить обнаружение.

Выделенной нами памяти.

NTSTATUS NtQueryVirtualMemory(

IN HANDLE ProcessHandle,

IN PVOID BaseAddress,

IN MEMORY_INFORMATION_CLASS MemoryInformationClass,

OUT PVOID MemoryInformation,

IN ULONG MemoryInformationLength,

OUT PULONG ReturnLength OPTIONAL.

);

MemoryInformationClass определяет тип возвращаемых данных. Нас.

Интересуют первые два типа.

#define MemoryBasicInformation 0.

#define MemoryWorkingSetList 1.

Для MemoryBasicInformation возвращается структура:

Typedef struct _MEMORY_BASIC_INFORMATION {

PVOID BaseAddress;

PVOID AllocationBase;

ULONG AllocationProtect;

ULONG RegionSize;

ULONG State;

ULONG Protect;

ULONG Type;

} MEMORY_BASIC_INFORMATION, *PMEMORY_BASIC_INFORMATION;

Каждая секция памяти имеет размер - RegionSize и тип - Type. Свободная.

Память имеет тип MEM_FREE.

#define MEM_FREE 0x10000.

Если секция перед нашей имеет тип MEM_FREE, следует прибавить размер.

Нашей секции к ее RegionSize. Если следующая секция также имеет тип MEM_FREE,

Следует прибавить размер следующей секции к RegionSize.

Если секция перед нашей имеет другой тип, мы вернем MEM_FREE для нашей.

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

Для MemoryWorkingSetList возвращается структура:

Typedef struct _MEMORY_WORKING_SET_LIST {

ULONG NumberOfPages;

ULONG WorkingSetList[1];

} MEMORY_WORKING_SET_LIST, *PMEMORY_WORKING_SET_LIST;

NumberOfPages - количество элементов в WorkingSetList. Это число должно.

Быть уменьшено. Мы должны найти нашу секцию в WorkingSetList и передвинуть.

Следующие записи на нее. WorkingSetList - массив DWОRD'ов, где старшие 20 бит -

Это старшие 20 бит адреса секции, а младшие 12 бит содержат флаги.

Хэндлы.

Вызов NtQuerySystemInformation с классом SystemHandleInformation дает.

Нам массив всех открытых хэндлов в структуре _SYSTEM_HANDLE_INFORMATION_EX.

#define SystemHandleInformation 0x10.

Typedef struct _SYSTEM_HANDLE_INFORMATION {

ULONG ProcessId;

UCHAR ObjectTypeNumber;

UCHAR Flags;

USHORT Handle;

PVOID Object;

ACCESS_MASK GrantedAccess;

} SYSTEM_HANDLE_INFORMATION, *PSYSTEM_HANDLE_INFORMATION;

Typedef struct _SYSTEM_HANDLE_INFORMATION_EX {

ULONG NumberOfHandles;

SYSTEM_HANDLE_INFORMATION Information[1];

} SYSTEM_HANDLE_INFORMATION_EX, *PSYSTEM_HANDLE_INFORMATION_EX;

ProcessId указывает процесс, владеющий этим хэндлом. ObjectTypeNumber -

Это тип хэндла. NumberOfHandles - количество записей в массиве Information.

Скрытие одного элемента тривиально. Нужно сдвинуть последующие записи на одну.

И уменьшить значение NumberOfHandles. Сдвиг последующих записей требуется,

Потому что хэндлы в массиве сгруппированы по ProcessId. Это значит, что все.

Хэндлы одного процесса расположены последовательно. И для каждого процесса.

Значение поля Handle растет.

Вспомните структуру _SYSTEM_PROCESSES, которая возвращается этой.

Функцией с классом SystemProcessesAndThreadsInformation. Здесь мы можем.

Увидеть, что каждый процесс имеет информацию о количестве хэндлов в.

HandleCount. Если мы хотим сделать все идеально, нам следует изменить поле.

HandleCount (в соответствии с тем, сколько хэндлов мы скрыли), когда функция.

Будет вызвана с классом SystemProcessesAndThreadsInformation. Но эта поправка.

Может требовать слишком много времени. Множество хэндлов открываются и.

Закрываются в течении очень короткого времени при нормальной работе системы.

Легко может случиться, что количество хэндлов изменилось между двумя вызовами.

Функции, поэтому нам не нужно изменять здесь поле HandleCount.

Именование хэндлов и получение типа.

Скрытие хэндлов тривиально, но немного сложнее определить какие хэндлы.

Мы должны скрыть. Если у нас есть, например, скрытый процесс, нас следует.

Скрыть все его хэндлы и все хэндлы связанные с ним. Скрытие хэндлов этого.

Процесса также тривиально. Мы просто сравниваем ProcessId хэндла и PID нашего.

Процесса, если они равны мы прячем хэндл. Но хэндлы других процессов должны.

Быть проименованы прежде, чем мы сможем сравнивать их с чем-либо. Количество.

Хэндлов в системе обычно очень велико, поэтому лучшее, что мы можем сделать -

Это сравнить тип хэндла прежде, чем попытаться проименовать его. Именование.

Типов сохранит много времени для хэндлов, которые нас не интересуют.

Именование хэндла и типа хэндла может быть выполнено с помощью функции.

NtQueryObject.

NTSTATUS ZwQueryObject(

IN HANDLE ObjectHandle,

IN OBJECT_INFORMATION_CLASS ObjectInformationClass,

OUT PVOID ObjectInformation,

IN ULONG ObjectInformationLength,

OUT PULONG ReturnLength OPTIONAL.

);

ObjectHandle - хэндл, информацию о котором мы хотим получить,

ObjectInformationClass - тип информации, которая будет сохранена в буфер.

ObjectInformation размером ObjectInformationLength байт.

Мы будем использовать классы ObjectNameInformation и.

ObjectAllTypesInformation. Класс ObjectNameInfromation заполнит буфер.

Структурой OBJECT_NAME_INFORMATION, а класс ObjectAllTypesInformation.

Структурой OBJECT_ALL_TYPES_INFORMATION.

#define ObjectNameInformation 1.

#define ObjectAllTypesInformation 3.

Typedef struct _OBJECT_NAME_INFORMATION {

UNICODE_STRING Name;

} OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION;

Поле Name определяет имя хэндла.

Typedef struct _OBJECT_TYPE_INFORMATION {

UNICODE_STRING Name;

ULONG ObjectCount;

ULONG HandleCount;

ULONG Reserved1[4];

ULONG PeakObjectCount;

ULONG PeakHandleCount;

ULONG Reserved2[4];

ULONG InvalidAttributes;

GENERIC_MAPPING GenericMapping;

ULONG ValidAccess;

UCHAR Unknown;

BOOLEAN MaintainHandleDatabase;

POOL_TYPE PoolType;

ULONG PagedPoolUsage;

ULONG NonPagedPoolUsage;

} OBJECT_TYPE_INFORMATION, *POBJECT_TYPE_INFORMATION;

Typedef struct _OBJECT_ALL_TYPES_INFORMATION {

ULONG NumberOfTypes;

OBJECT_TYPE_INFORMATION TypeInformation;

} OBJECT_ALL_TYPES_INFORMATION, *POBJECT_ALL_TYPES_INFORMATION;

Поле Name определяет имя типа объекта, которое следует сразу после.

Каждой структуры OBJECT_TYPE_INFORMATION. Следующая структура.

OBJECT_TYPE_INFORMATION расположена после этого имени и выровнена на границу.

Четырех байт.

ObjectTypeNumber из структуры SYSTEM_HANDLE_INFORMATION - это индекс.

В массиве TypeInformation.

Сложнее получить имя хэндла из другого процесса. Существуют два способа.

Сделать это. Первый состоит в том, чтобы скопировать хэндл функцией.

NtDuplicateObject в наш процесс и затем проименовать его. Этот метод не.

Сработает для некоторых специфических типов хэндлов. Но он не срабатывает.

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

NtDuplicateObject(

IN HANDLE SourceProcessHandle,

IN HANDLE SourceHandle,

IN HANDLE TargetProcessHandle,

OUT PHANDLE TargetHandle OPTIONAL,

IN ACCESS_MASK DesiredAccess,

IN ULONG Attributes,

IN ULONG Options.

);

SourceProcessHandle - хэндл процесса, который владеет SourceHandle,

То есть хэндлом, который мы хотим скопировать. TargetProcessHandle - это хэндл.

Процесса, в который мы хотим копировать. Это хэндл нашего процесса в нашем.

Случае. TargetHandle - указатель, куда будет сохранена копия хэндла. Параметр.

DesiredAccess должен быть равен PROCESS_QUERY_INFORMATION, а Attribures.

И Options - нулю.

Второй способ именования, работающий со всеми хэндлами, состоит в.

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

Проекте OpHandle на моем сайте http://rootkit.host.sk.

Порты.

Самый простой путь для перечисления открытых портов - это использование.

Функций AllocateAndGetTcpTableFromStack и AllocateAndGetUdpTableFromStack,

И/или AllocateAndGetTcpExTableFromStack и AllocateAndGetUdpExTableFromStack из.

Iphlpapi.dll. Ex-функции доступны начиная с Windows XP.

Typedef struct _MIB_TCPROW {

DWORD dwState;

DWORD dwLocalAddr;

DWORD dwLocalPort;

DWORD dwRemoteAddr;

DWORD dwRemotePort;

} MIB_TCPROW, *PMIB_TCPROW;

Typedef struct _MIB_TCPTABLE {

DWORD dwNumEntries;

MIB_TCPROW table[ANY_SIZE];

} MIB_TCPTABLE, *PMIB_TCPTABLE;

Typedef struct _MIB_UDPROW {

DWORD dwLocalAddr;

DWORD dwLocalPort;

} MIB_UDPROW, *PMIB_UDPROW;

Typedef struct _MIB_UDPTABLE {

DWORD dwNumEntries;

MIB_UDPROW table[ANY_SIZE];

} MIB_UDPTABLE, *PMIB_UDPTABLE;

Typedef struct _MIB_TCPROW_EX.

{

DWORD dwState;

DWORD dwLocalAddr;

DWORD dwLocalPort;

DWORD dwRemoteAddr;

DWORD dwRemotePort;

DWORD dwProcessId;

} MIB_TCPROW_EX, *PMIB_TCPROW_EX;

Typedef struct _MIB_TCPTABLE_EX.

{

DWORD dwNumEntries;

MIB_TCPROW_EX table[ANY_SIZE];

} MIB_TCPTABLE_EX, *PMIB_TCPTABLE_EX;

Typedef struct _MIB_UDPROW_EX.

{

DWORD dwLocalAddr;

DWORD dwLocalPort;

DWORD dwProcessId;

} MIB_UDPROW_EX, *PMIB_UDPROW_EX;

Typedef struct _MIB_UDPTABLE_EX.

{

DWORD dwNumEntries;

MIB_UDPROW_EX table[ANY_SIZE];

} MIB_UDPTABLE_EX, *PMIB_UDPTABLE_EX;

DWORD WINAPI AllocateAndGetTcpTableFromStack(

OUT PMIB_TCPTABLE *pTcpTable,

IN BOOL bOrder,

IN HANDLE hAllocHeap,

IN DWORD dwAllocFlags,

IN DWORD dwProtocolVersion;

);

DWORD WINAPI AllocateAndGetUdpTableFromStack(

OUT PMIB_UDPTABLE *pUdpTable,

IN BOOL bOrder,

IN HANDLE hAllocHeap,

IN DWORD dwAllocFlags,

IN DWORD dwProtocolVersion;

);

DWORD WINAPI AllocateAndGetTcpExTableFromStack(

OUT PMIB_TCPTABLE_EX *pTcpTableEx,

IN BOOL bOrder,

IN HANDLE hAllocHeap,

IN DWORD dwAllocFlags,

IN DWORD dwProtocolVersion;

);

DWORD WINAPI AllocateAndGetUdpExTableFromStack(

OUT PMIB_UDPTABLE_EX *pUdpTableEx,

IN BOOL bOrder,

IN HANDLE hAllocHeap,

IN DWORD dwAllocFlags,

IN DWORD dwProtocolVersion;

);

Есть и другой способ. Когда программа создает сокет и начинает его.

Слушать, она, конечно, имеет открытый хэндл для него и для открытого порта.

Мы можем перечислить все открытые хэндлы в системе и послать им специальный.

Буфер, используя функцию NtDeviceIoControlFile, чтобы определить хэндлы.

Для открытых портов. Это также даст нам информацию о портах. Так как открытых.

Хэндлов очень много, мы будем тестировать только хэндлы с типом File и именем.

\Device\Tcp или \Device\Udp. Открытые порты имеют только этот тип и имя.

Когда мы смотрели код перечисленных функций в iphlpapi.dll, мы.

Обнаружили, что эти функции вызывают NtDeviceIoControlFile и посылают.

Специальный буфер для того, чтобы получить список всех открытых портов в.

Системе. Это значит, что единственная функция, которую нужно перехватить для.

Скрытия портов - это NtDeviceIoControlFile.

NTSTATUS NtDeviceIoControlFile(

IN HANDLE FileHandle.

IN HANDLE Event OPTIONAL,

IN PIO_APC_ROUTINE ApcRoutine OPTIONAL,

IN PVOID ApcContext OPTIONAL,

OUT PIO_STATUS_BLOCK IoStatusBlock,

IN ULONG IoControlCode,

IN PVOID InputBuffer OPTIONAL,

IN ULONG InputBufferLength,

OUT PVOID OutputBuffer OPTIONAL,

IN ULONG OutputBufferLength.

);

Интересующие нас параметры - это FileHandle (определяет хэндл.

Устройства), IoStatusBlock (указывает на переменную, которая получает.

Информацию о статусе выполнения и информацию об операции), IoControlCode.

(число, определяющее тип устройства, метод, права доступа и функцию).

InputBiffer содержит данные размером InputBufferLength байт. И тоже самое в.

OutputBuffer и OutputbufferLength.

Netstat, OpPorts в WinXP, FPort в WinXP.

Получение списка открытых портов в первую очередь использутеся,

Например, в OpPorts и FPort в Windows XP, а также Netstat.

Программы вызывают NtDeviceIoControlFile дважды с IoControlCode равным.

0x000120003. OutputBuffer заполняется после второго вызова. Имя FileHandle.

Здесь всегда \Device\Tcp. InputBuffer различается для разных типов вызова:

1) Для получения массива из MIB_TCPROW InputBuffer должен быть таким:

Первый вызов:

0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

Второй вызов:

0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x01 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

2) Чтобы получить массив из MIB_UDPROW:

Первый вызов:

0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

Второй вызов:

0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x01 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

3) Чтобы получить массив из MIB_TCPROW_EX:

Первый вызов:

0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

Второй вызов:

0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x02 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

4) Чтобы получить массив из MIB_UDPROW_EX:

Первый вызов:

0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

Второй вызов:

0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00.

0x02 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00.

0x00 0x00 0x00 0x00.

Вы можете заметить, что буферы различаются только в нескольких байтах.

Мы можем объяснить это.

Интересующие нас вызовы имеют в InputBuffer[1] 0x04 и, в основном,

InputBuffer[17] содержит 0x01. Только при таких входных данных мы получим.

В OutputBuffer нужные таблицы. Если мы хотим получить информацию о TCP-портах,

Нужно установить в InputBuffer[0] значение 0x00, или 0x01 для получения.

Информации о UDP-портах. Если нам нужны Ex-таблицы (MIB_TCPROW_EX или.

MIB_UDPROW_EX), нужно во втором вызове установить в Inputbuffer[16] 0x02.

Если мы перехватили вызов с этими параметрами, нужно просто изменить.

Выходной буфер. Чтобы получить количество строк в выходном буфере, просто.

Разделите Information из IoStatusBlock на размер строки. Скрыть одну строку.

Очень просто. Просто перезапишите ее последующими строками и удалить последнюю.

Строку. Не забудьте изменить OutputBufferLength и IoStatusBlock.

OpPorts в Win2k и NT4, FPort в Win2k.

Мы используем NtDeviceIoControlFile с IoControlCode равным 0x00210012,

Чтобы определить, что хэндл с типом File и именем \Device\Tcp или \Device\Udp -

Это хэндл открытого порта.

Во-первых, мы сравним IoControlCode, а затем тип и имя хэндла. Если.

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

Быть равным длине структуры TDI_CONNECTION_IN. Ее длина 0x18. Выходной буфер -

TDI_CONNETION_OUT.

Typedef struct _TDI_CONNETION_IN.

{

ULONG UserDataLength,

PVOID UserData,

ULONG OptionsLength,

PVOID Options,

ULONG RemoteAddressLength,

PVOID RemoteAddress.

} TDI_CONNETION_IN, *PTDI_CONNETION_IN;

Typedef struct _TDI_CONNETION_OUT.

{

ULONG State,

ULONG Event,

ULONG TransmittedTsdus,

ULONG ReceivedTsdus,

ULONG TransmissionErrors,

ULONG ReceiveErrors,

LARGE_INTEGER Throughput.

LARGE_INTEGER Delay,

ULONG SendBufferSize,

ULONG ReceiveBufferSize,

ULONG Unreliable,

ULONG Unknown1[5],

USHORT Unknown2.

} TDI_CONNETION_OUT, *PTDI_CONNETION_OUT;

Конкретная реализация, того как определить то, что хэндл - это хэндл.

Открытого порта, доступна в исходном коде OpPorts на моем сайте.

Http://rootkit.host.sk. Сейчас нам необходимо скрыть определенные порты. Мы.

Уже проверили InputBufferLength и IoControlCode. Теперь мы должны проверить.

RemoteAddressLength - для открытого порта всегда 3 или 4. Наконец, мы должны.

Сравнить поле ReceivedTsdus из OutputBuffer, которое содержит порт в.

Сетевой форме, со списком портов, которые мы хотим скрыть. Мы можем различать.

TCP и UDP в соответствии с именем хэндла. Удалив OutputBuffer, изменив.

IoStatusBlock и вернув значение STATUS_INVALID_ADDRESS, мы скроем порт.

Окончание.

Конкретная реализация описанных техник доступна в исходном коде.

Hacker Defender Rootkit версии 1.0.0 на сайте http://rootkit.host.sk и на.

Http://www.rootkit.com.

Возможно, я добавлю информацию о невидимости в Windows NT в будущем.

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

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

Отдельное спасибо Rаttеr'у, который дал мне много ноу-хау, которые были.

Необходимы для написания этой статьи и кода проекта Hacker Defender.

Все комментарии присылаете на holy_father@phreaker.net или на доску на.

Сайте http://rootkit.host.sk.

©Drkb::02055.

Взято из http://forum.sources.ru.

Как правильно работать с прозрачными окнами?

Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?

Стиль окна-формы указывается в CreateParams. Только вот когда перемещаешь его, фон остается со старым куском экрана. Чтобы этого не происходило, то когда рисуешь своё окно, запоминай, что было под ним,а при перемещении восстанавливай.

HDC hDC = GetDC(GetDesktopWindow()) тебе поможет..

Andrei Bogomolov.

Http://cardy.hypermart.net.

ICQ UIN:7329451.

Admin@cardy.hypermart.net.

E-pager: 7329451@pager.mirabilis.com.

(2:5013/11.3).

©Drkb::00350.

Автор: StayAtHome.

Взято с Vingrad.ru http://forum.vingrad.ru.

OpenGL: Каким образом выбирать размер шрифта.

OpneGL: Каким образом выбирать размер шрифта, т.к. все мои страдания по выбору параметров шрифта в CreateFont() никак не отражались на его размере.

Все что я придумал, это юзать glScale(), но в этом случае получаем плохое качество (по сравнению с той-же Вордой) при малом размере символов. Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

Code: Procedure GLSetupRC( pData: Pointer ). //void GLSetupRC(void *pData). //{ Var. // HDC hDC; HDC: HDC; // HFONT hFont; HFont: HFONT; // GLYPHMETRICSFLOAT agmf[128]; Agmf: array [0..127] of GLYPHMETRICSFLOAT; // LOGFONT logfont; Logfont: LOGFONT; Begin. Logfont.lfHeight := -10; Logfont.lfWidth := 0; Logfont.lfEscapement := 0; Logfont.lfOrientation := 0; Logfont.lfWeight := FW_BOLD; Logfont.lfItalic := FALSE; Logfont.lfUnderline := FALSE; Logfont.lfStrikeOut := FALSE; Logfont.lfCharSet := ANSI_CHARSET; Logfont.lfOutPrecision := OUT_DEFAULT_PRECIS; Logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS; Logfont.lfQuality := DEFAULT_QUALITY; Logfont.lfPitchAndFamily := DEFAULT_PITCH; //strcpy(logfont.lfFaceName,"Arial"); // strcpy(logfont.lfFaceName,"Decor"); StrPCopy( logfont.lfFaceName, 'Decor' ); GlDepthFunc(GL_LESS); GlEnable(GL_DEPTH_TEST); // Hidden surface removal. GlFrontFace(GL_CCW); // Counter clock-wise polygons face out. GlEnable(GL_CULL_FACE); // Do not calculate insides. GlShadeModel(GL_SMOOTH); // Smooth shading. GlEnable(GL_AUTO_NORMAL); GlEnable(GL_NORMALIZE); GlEnable(GL_COLOR_MATERIAL); GlClearColor(0.0, 0.0, 0.0, 1.0 ); GlEnable(GL_LIGHTING); GlLightfv(GL_LIGHT0,GL_AMBIENT,ambientLight); GlLightfv(GL_LIGHT0,GL_DIFFUSE,diffuseLight); GlLightfv(GL_LIGHT0,GL_SPECULAR,specular); GlLightfv(GL_LIGHT0,GL_POSITION,lightPos); GlEnable(GL_LIGHT0); GlColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE); GlMaterialfv(GL_FRONT, GL_SPECULAR,specular); GlMateriali(GL_FRONT,GL_SHININESS,100); // Blue 3D Text. GlRGB(0, 0, 255); // Select the font into the DC. HDC := (HDC)pData; // hFont = CreateFontIndirect(&logfont); HFont := CreateFontIndirect( Addr(logfont) ); SelectObject (hDC, hFont); //create display lists for glyphs 0 through 255 with 0.3 extrusion. // and default deviation. The display list numbering starts at 1000. // (it could be any number). // if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3, // WGL_FONT_POLYGONS, agmf)). If not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3, //> ``` - это тебе поможет. //> Выводить текст можно в любым масштабе. WGL_FONT_POLYGONS, agmf) then. Windows.MessageBox(nil,'Could not create Font Outlines', 'Error',MB_OK or MB_ICONSTOP); // Delete the font now that we are done. DeleteObject(hFont); //}. End; // void GLRenderScene(void *pData). Procedure GLRenderScene(pData: Pointer); Begin. (* ... *) // Draw 3D text. GlListBase(1000); GlPushMatrix(); // Set up transformation to draw the string. GlTranslatef(-35.0, 0.0, -5.0); GlScalef(60.0, 60.0, 60.0); GlCallLists(3, GL_UNSIGNED_BYTE, 'Decor'); GlPopMatrix(); // Clear the window with current clearing color. (* ... *) End;

Как по IP адресу получить HostName (и обратно).

Code: Function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD; Const AddressStrMaxLen = 256; Var len : DWORD; Ptr : PChar; PHE : PHostEnt; Addr : TSockAddr; Buf : Array [0..AddressStrMaxLen-1] of Char; Begin. If FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is. Not defined',WSAHOST_NOT_FOUND); Len := SizeOf(TSockAddr); If getpeername(FSocket,addr,len)<>0 then. RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()'); Case addr.sin_family of. AF_INET: // TCP/IP. Begin. PHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr), AF_INET ); If pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds: Gethostbyaddr()'); FPeerNodeName := pHE^.h_name; If FNet.NodeByName(FPeerNodeName)=nil then. Begin. Ptr := StrScan(pHE^.h_name,'.'); If ptr<>nil then FPeerNodeName := Copy(pHE^.h_name,1,ptr-pHE^.h_name); End; End; Else. Len := AddressStrMaxLen; If WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then. RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()'); Ptr := StrRScan(buf,':'); If ptr<>nil then len := ptr-buf; FPeerNodeName := Copy(buf,1,len); End; Result := FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR. AiseError]); End; {TGenericNetTask.GetPeerOrigin}.

Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?

Code: Procedure TDbGridEx.ColEnter; Procedure ProcessColEnter; Begin. // ----------------------------------------------------------- If (SelectedIndex _Mark) then. Begin. ColumnMoved(Columns.Count, StaticCol + 1); SelectedField := Fields[StaticCol]; End; Exit; End; // ----------------------------------------------------------- If (SelectedIndex > StaticCol) then. Begin. If _LastSelectedIndex = StaticCol then. Begin. If _Mark = Columns[SelectedIndex].Title.Caption then. Begin. ColumnMoved(StaticCol + 1, Columns.Count); SelectedField := Fields[Columns.Count - 1]; End. Else. Begin. ColumnMoved(StaticCol + 1, Columns.Count); SelectedField := Fields[StaticCol]; End; End; End; End; Begin. If (_EntryCol > 0) or _MouseDown or (StaticCol = 0) then. Begin. _MouseDown := FALSE; End else. Begin. Inc(_EntryCol); ProcessColEnter; Dec(_EntryCol); End; If Assigned(OnColEnter) then OnColEnter(Self); _LastSelectedIndex := SelectedIndex; End;

Использование HOOK в Дельфи.

Что такое НООК?

НООК - это механизм перехвата сообщений, предоставляемый системой Microsoft Windows. Программист пишет специального вида функцию (НООК-функция), которая затем при помощи функции SetWindowsHookEx вставляется на верх стека НООК-функций системы. Ваша НООК-функция сама решает, передать ли ей сообщение в следующую НООК-функцию при помощи CallNextHookEx или нет.

Какие бывает НООК'и?

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

Как создавать НООК?

НООК устанавливается в систему при помощи функции SetWindowsHookEx, вот её заголовок:

Function SetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc; hmod: HINST; dwThreadId: DWORD): HHOOK;

IdHook.

Константа, определяющая тип вставляемого НООК'а, должна быть одна из нижеследующих констант:

WH_CALLWNDPROC.

Вставляемая НООК-функция следит за всеми сообщения перед их отпралением в соответствующую оконную функцию.

WH_CALLWNDPROCRET.

Вставляемая НООК-функция следит за всеми сообщениями после их отправления в оконную функцию.

WH_CBT.

Вставляемая НООК-функция следит за окнами, а именно: за созданием, активацией, уничтожением, сменой размера; перед завершением системной команды меню, перед извлечением события мыши или клавиатуры из очереди сообщений, перед установкой фокуса и т.д.

WH_DEBUG.

Вставляемая НООК-функция следит за другими НООК-функциями.

WH_GETMESSAGE.

Вставляемая НООК-функция следит за сообщениями, посылаемыми в очередь сообщений.

WH_JOURNALPLAYBACK.

Вставляемая НООК-функция посылает сообщения, записанные до этого WH_JOURNALRECORD НООК'ом.

WH_JOURNALRECORD.

Эта НООК-функция записывает все сообщения куда-либо в специальном формате, причем позже они могут быть "воспроизведены" при помощи НООК'а WH_JOURNALPLAYBACK. Это в некотором роде аналог магнитофонной записи сообщений.

WH_KEYBOARD.

Вставляемая НООК-функция следит за сообщениями клавиатуры.

WH_MOUSE.

Вставляемая НООК-функция следит за сообщениями мыши.

WH_MSGFILTER.

WH_SHELL.

WH_SYSMSGFILTER.

Lpfn.

Указатель на непосредственно функцию. Обратите внимание, что если Вы ставите глобальный НООК, то НООК-функция обязательно должна находиться в некоторой DLL!!!

Hmod.

Описатель DLL, в которой находится код функции.

DwThreadId.

Идентификатор потока, в который вставляется НООК.

Подробнее о НООК-функциях смотри справку по Win32API.

Как удалять НООК?

НООК удаляется при помощи функции UnHookWindowsEx.

Пример использования НООК.

Ставим НООК, следящий за мышью (WH_MOUSE). Программа следит за нажатием средней кнопки мыши, и когда она нажимается, делает окно, находящееся непосредственно под указателем, поверх всех остальных (TopMost). Код самой НООК-функции помещен в библиотеку lib2.dll, туда же помещены и функции Start - для установки НООК, и Remove - для удаления НООК.

Файл sticker.dpr.

Code: Program sticker; Uses windows, messages; Var. Wc : TWndClassEx; MainWnd : THandle; Mesg : TMsg; //экспортируем две функции из библиотеки с НООК'ами. Procedure Start; external 'lib2.dll' name 'Start'; Procedure Remove; external 'lib2.dll' name 'Remove'; Function WindowProc(wnd:HWND; Msg : Integer; Wparam:Wparam; Lparam:Lparam):Lresult; stdcall; Var. NCode, ctrlID : word; Begin. Case msg of. Wm_destroy : Begin. Remove;//удаляем НООК. Postquitmessage(0); exit; Result:=0; End; Else. Result:=DefWindowProc(wnd,msg,wparam,lparam); End; End; Begin. Wc.cbSize:=sizeof(wc); Wc.style:=cs_hredraw or cs_vredraw; Wc.lpfnWndProc:=@WindowProc; Wc.cbClsExtra:=0; Wc.cbWndExtra:=0; Wc.hInstance:=HInstance; Wc.hIcon:=LoadIcon(0,idi_application); Wc.hCursor:=LoadCursor(0,idc_arrow); Wc.hbrBackground:=COLOR_BTNFACE+1; Wc.lpszMenuName:=nil; Wc.lpszClassName:='WndClass1'; RegisterClassEx(wc); MainWnd:=CreateWindowEx(0,'WndClass1','Caption',ws_overlappedwindow, Cw_usedefault,cw_usedefault,cw_usedefault,cw_usedefault,0,0, Hinstance,nil); ShowWindow(MainWnd,CmdShow); Start;//вставляем НООК. While GetMessage(Mesg,0,0,0) do. Begin. TranslateMessage(Mesg); DispatchMessage(Mesg); End; End.

Как получить доступ к битам переменной и управлять их значением?

Code: Unit Bitwise; Interface. Function IsBitSet(const val: longint; const TheBit: byte): boolean; Function BitOn(const val: longint; const TheBit: byte): LongInt; Function BitOff(const val: longint; const TheBit: byte): LongInt; Function BitToggle(const val: longint; const TheBit: byte): LongInt; Implementation. Function IsBitSet(const val: longint; const TheBit: byte): boolean; Begin. Result := (val and (1 shl TheBit)) <> 0; End; Function BitOn(const val: longint; const TheBit: byte): LongInt; Begin. Result := val or (1 shl TheBit); End; Function BitOff(const val: longint; const TheBit: byte): LongInt; Begin. Result := val and ((1 shl TheBit) xor $FFFFFFFF); End; Function BitToggle(const val: longint; const TheBit: byte): LongInt; Begin. Result := val xor (1 shl TheBit); End; End.

Как послать сообщение всем окнам Windows?

Code: Var. FM_FINDPHOTO: Integer; // Для использовать hwnd_Broadcast нужно сперва. // зарегистрировать уникальное сообщение. Initialization. FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll'); // Чтобы поймать это сообщение в другом приложении. //(приемнике) нужно перекрыть DefaultHandler. Procedure TForm1.DefaultHandler(var Message); Begin. With TMessage(Message) do. Begin. If Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM) else. Inherited DefaultHandler(Message); End; End; // А тепрь можно. SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);

Как отчитывать промежутки времени с точностью, большей чем 60 мсек?

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

Code: Procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD);stdcall; Begin. // // Тело процедуры. End;

А дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь на него созданную процедуру.

Code: UTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC);

Как указать максимальный размер текста для RichEdit Control?

У этого компонента есть свойство MaxLength, которое работает некорректно. Поэтому лучше пользоваться.

RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);

Причем перед каждом открытии файла это действие необходимо повторять.

Maxim Liverovskiy.

(2:5030/254.38).

Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки.

Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT.

Stas Mehanoshin.

©Drkb::00573.

Автор: StayAtHome.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как рисовать картинки в пунктах меню?

Code: Unit DN_Win; {©Drkb v.3(2007): www.drkb.ru}. 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;{TDNForm.FormCreate}. Procedure TDNForm.cm_MainExitClick(Sender: TObject); Begin. DNForm.Close; End;{TDNForm.cmExitClick}. Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem); Begin. With Msg.MeasureItemStruct^ do. If ItemID=comm then begin ItemWidth:=yMenu; Itemheight:=yMenu; end; End;{WMMeasureItem}. 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);{hDC ? TDrawItemStruct}. SelectObject(MemDC,BM); {rcItem ? TDrawItemStruct}. 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{with}. End;{TDNForm.WMDrawItem}. End.

Eugeny Sverchkov.

Es906@kolnpp.elektra.ru.

(2:5031/12.23).

©Drkb::01305.

Автор: StayAtHome.

Взято с Vingrad.ru http://forum.vingrad.ru.

Использование WSAAsyncSelect в DLL.

Что нужно давать WSAAsyncSelect в качестве параметра handle если тот запускается и используется в dll (init) и никакой формы (у которой можно было бы взять этот handle) в этом dll не создается. Что бы такого сделать чтобы работало?

Code: Const. WM_ASYNCSELECT = WM_USER+0; Type. TNetConnectionsManager = class(TObject). Protected. FWndHandle : HWND; Procedure WndProc( var MsgRec : TMessage ); ... End; Constructor TNetConnectionsManager.Create. Begin. Inherited Create; FWndHandle := AllocateHWnd(WndProc); ... End; Destructor TNetConnectionsManager.Destroy; Begin. ... If FWndHandle<>0 then DeallocateHWnd(FWndHandle); Inherited Destroy; End; Procedure TNetConnectionsManeger.WndProc( var MsgRec : TMessage ); Begin. With MsgRec do. If Msg=WM_ASYNCSELECT then. WMAsyncSelect(MsgRec). Else. DefWindowProc( FWndHandle, Msg, wParam, lParam ); End;

Как в ListBox нарисовать Item своим цветом?

Code: 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;

Как осуществить быстрый поиск в Listbox?

Очень просто, смотри пример....

Считаем, сто есть поле Edit1, в котором набираем текст, и ListBox, в котором ищем нужную строку, (как в Не1р).

Code: Procedure TForm1.Edit1Change(Sender: TObject); Begin. ListBox1.Perform(LB_SELECTSTRING,-1,longint(Pchar(Edit1.text))); End;

Как получить размер развёрнутого TComboBox?

В течение события FormShow, выпадающему списке дважды посылается сообщение CB_SHOWDROPDOWN , один раз, чтобы он открылся, а второй - чтобы свернулся. Затем посылается сообщение CB_GETDROPPEDCONTROLRECT, передающее адрес TRect.

Когда вызов SendMessage возвращается, то TRect будет содержать прямоугольник, который соответствует раскрытому ComboBox-у относительно окна. Затем можно вызвать ScreenToClient для преобразования координат TRect-а в координаты относительно клиентской области формы.

Code: Var. R : TRect; Procedure TForm1.FormShow(Sender: TObject); Var. T : TPoint; Begin. SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0); SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0); SendMessage(ComboBox1.Handle, CB_GETDROPPEDCONTROLRECT, 0, LongInt(@r)); T := ScreenToClient(Point(r.Left, r.Top)); R.Left := t.x; R.Top := t.y; T := ScreenToClient(Point(r.Right, r.Bottom)); R.Right := t.x; R.Bottom := t.y; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Form1.Canvas.Rectangle(r.Left, R.Top, R.Right, R.Bottom ); End;

Как поместить картинки в Combo Box?

Автор: Allan Carlton.

Делается это при помощи стиля ownerdraw, который присутствует в TComboBox. Нас интересуют два свойства этого стиля:

CsOwnerDrawFixed - используется, если все битмапы имеют одинаковую высоту.

CsOwnerDrawVariable - используется для битмапов с разной высотой.

После того как стиль будет установлен на один из вышеперечисленных, то можно воспользоваться событием onDrawItem. Это событие возникает каждый раз, когда приложению необходимо нарисовать пункт в выпадающем списке (combo box). Событие определяется следующим образом:

Procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;

Rect: TRect; State: TOwnerDrawState).

Если выпадающему списку был присвоен стиль csOwnerDrawFixed, то всё, что надо сделать, это написать процедуру, которая будет рисовать битмап и текст в событии onDrawItem.

Для выпадающего списка со стилем csOwnerDrawVariable необходимо пройти ещё одну дополнительную стадию. Заключается эта стадия в создании обработчика для события onMeasureItem. Это событие вызывается перед DrawItem, для того, чтобы Вы могли установить фактическую высоту для каждого элемента списка. Вот его определение:

Procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;

Var Height: Integer);

Создайте новое приложение.

Разместите на форме combobox и imagelist (если Вы используете delphi 1, то Вам прийдётся хранить битмапы каким-то другим способом).

Code: Procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index:Integer; Rect: TRect; State: TOwnerDrawState); Begin. (* Заполняем прямоугольник *). Combobox1.canvas.fillrect(rect); (* Рисуем сам битмап *). Imagelist1.Draw(comboBox1.Canvas,rect.left,rect.top,Index); (* Пишем текст после картинки *). Combobox1.canvas.textout(rect.left+imagelist1.width+2,rect.top, Combobox1.items[index]); End;

Как создать поле Lookup во время выполнения приложения?

Code: Uses. Forms, Classes, Controls, StdCtrls, Db, DBTables, DBCtrls; Type. TForm1 = class(TForm). Table1: TTable; // DBDemos customer table. Table2: TTable; // DBDemos orders table. Button1: TButton; DBLookupComboBox1: TDBLookupComboBox; DataSource1: TDataSource; Table2CustNo: TFloatField; // CustNo key field object used for Lookup. Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. With TStringField.Create(Table2) do begin. FieldName := 'MyLookup'; FieldKind:= fkLookup; DataSet := Table2; Name := Dataset.Name + FieldName; KeyFields:= 'CustNo'; LookUpDataset:= Table1; LookUpKeyFields:= 'CustNo'; LookUpResultField:= 'Company'; DbLookupCombobox1.DataField:= FieldName; DataSource1.DataSet:= Dataset; Table2.FieldDefs.Add(Name, ftString, 20, false); End; DbLookupCombobox1.DataSource:= Datasource1; Table1.Active:= True; Table2.Active:= True; End; End.

TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog.

Перевод одноимённой статьи с сайта delphi.about.com ).

Стандарные диалоговые окошки.

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

В этой статье мы рассмотрим основные свойства и методы этих диалогов и, особенно, сфокусируем внимание на диалогах Open и Save.

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

TOpenDialog и TSaveDialog.

Диалоговые окошки File Open и File Save имеют несколько общих свойств. File Open в основном используется для выбора и открытия файлов, в то время как диалог File Save (так же используется как диалоговое окошко Save As) используется для получения от пользователя имени файла, чтобы сохранить файл. Далее мы рассмотрим некоторые важные свойства TOpenDialog и TSaveDialog:

Свойство Options предназначено для задания конечного вида окна. Например, при помощи следующего кода:

With OpenDialog1 do.

Options := Options +

[ofAllowMultiSelect, ofFileMustExist];

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

Свойство InitialDir используется для указания директории, которая будет показана при создании диалога. Следующий код установит начальную директорию, из которой было запущено приложение:

SaveDialog1.InitialDir :=

ExtractFilePath(Application.ExeName);

Свойство Filter содержит список типов файлов, которые сможет выбирать пользователь. Когда пользователь выберет тип файлов, то в диалоговом окне будут отображаться только файлы данного расширения. Фильтр можно легко установить на стадии создания приложения при помощи диалога редактора фильтра (Filter Editor):

Так же фильтр можно задать программно. Строка фильтра должна содержать описание и расширение для данного типа файлов, разделённые вертикальной чертой:

OpenDialog1.Filter :=

'Text files (*.txt)|*.txt|All files (*.*)|*.*';

Свойство FileName. Когда пользователь нажмёт на диалоге кнопку OK, то это свойство будет содержать полный путь и имя выбранного файла.

Вызов диалогового окошка.

Для создания и отображения стандартного диалога необходимо выполнить метод Execute для нужного диалога. За исключением диалогов TFindDialog и TReplaceDialog, все остальные диалоги отображаются модально.

Все стандартные диалоговые окошки позволяют определить нажал ли пользователь кнопку "Отмена" (Cancel) (или нажал ESC). Если метод Execute вернул True значит пользователь нажал OK или сделал двойной щелчёк по файлу либо нажал Enter на клавиатуре, иначе, если была нажата кнопка Cancel, клавиша Esc или Alt-F4, будет возвращено значение False.

If OpenDialog1.Execute then.

ShowMessage(OpenDialog1.FileName);

Этот код показывает диалог File Open и, если пользователь нажал "Открыть" (Open), то будет показано имя выбранного файла.

Использование только кода.

Чтобы работать диалогом Open (или любым другим) не помещая при этом на форму компонент OpenDialog, можно воспользоваться следующим кодом:

Code: Procedure TForm1.btnFromCodeClick(Sender: TObject); Var OpenDlg : TOpenDialog; Begin OpenDlg := TOpenDialog.Create(Self); {здесь устанавливаем опции...}. If OpenDlg.Execute then begin. {здесь что-нибудь делаем}. End; OpenDlg.Free; End;

Обратите внимание, что перед вызовом Execute, можно установить различные свойства компонента OpenDialog.

TOpenPictureDialog и TSavePictureDialog.

Эти два диалога есть ничто иное как обычные File Open и File Save с дополнительной возможностью предварительного просмотра выбранной картинки.

Мой Блокнот.

А теперь предлагаю применить теорию на практике. Создадим простейший блокнот, и посмотрим как работают диалоговые окошки Open и Save:

Для создания блокнота проделаем следующее:

. Запустите Delphi и выберите в меню File-New Application.

. Поместите на форму Memo, OpenDialog, SaveDialog и две кнопки.

. Переименуйте Button1 в btnOpen, а Button2 в btnSave.

Код.

1. Поместите в событие формы FormCreate следующий код:

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. With OpenDialog1 do begin. Options:=Options+[ofPathMustExist,ofFileMustExist]; InitialDir:=ExtractFilePath(Application.ExeName); Filter:='Text files (*.txt)|*.txt'; End; With SaveDialog1 do begin. InitialDir:=ExtractFilePath(Application.ExeName); Filter:='Text files (*.txt)|*.txt'; End; Memo1.ScrollBars := ssBoth; End;

Добавляем компонент в стандартный Message dialog.

Автор: Terrance Hui.

Пример показывает стандартное диалоговое окно, которое обычно используется для подтверждения дальнейших действий в любой программе с галочкой "Don't show this message again.".

Используем функцию CreateMessageDialog и добавляем любой компонент до того как будет вызвана ShowModal.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. AMsgDialog: TForm; ACheckBox: TCheckBox; Begin. AMsgDialog := CreateMessageDialog('This is a test message.', mtWarning, [mbYes, mbNo]); ACheckBox := TCheckBox.Create(AMsgDialog); With AMsgDialog do. Try. Caption := 'Dialog Title' ; Height := 169; With ACheckBox do. Begin. Parent := AMsgDialog; Caption := 'Do not show me again.'; Top := 121; Left := 8; End; Case ShowModal of. ID_YES: ;//здесь Ваш код после того как диалог будет закрыт. ID_NO: ; End; If ACheckBox.Checked then. Begin. //... End; Finally. ACheckBox.Free; Free; End; End;

Объект ошибок ADO.

При рассказе о компонентах ADO в данной главе мы довольно часто упоминали об объектах ошибок ADO. Эти объекты содержат информацию об ошибке, возникшей при выполнении операции каким-либо объектом ADO.

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

TRecordsetEvent = procedure(DataSet: TCustomADODataSet; const Error: Error;

Var EventStatus: TEventStatus) of object;

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

Рассмотрим полезные свойства объекта ошибок ADO.

Свойство.

Property Description: WideString read Get_Description;

Возвращает описание ошибки, переданное из объекта, в котором ошибка произошла.

Свойство.

Property SQLState: WideString read Get_SQLState;

Содержит текст команды, вызвавшей ошибку. Свойство.

Property NativeError: Integer read Get_NativeError;

Возвращает код ошибки, переданный из объекта, в котором ошибка произошла.

Как перехватить сообщения скроллирования в TScrollBox?

Следующий пример перхватывает сообщения скроллирования в компоненте TScrollBox, тем самым синхронизируя два скролбара. Если один из скролбаров изменяет своё положение, то значение второго скролбара изменяется на такую же величину. Сообщения скролирования перехватываются путём сабклассинга оконной процедуры (WinProc) у скролбара.

Пример:

Code: Type. {$IFDEF WIN32}. WParameter = LongInt; {$ELSE}. WParameter = Word; {$ENDIF}. LParameter = LongInt; {Объявляем переменную для хранения подменённой оконной процедуры}. Var. OldWindowProc : Pointer; Function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt. {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}. Var. TheRangeMin : integer; TheRangeMax : integer; TheRange : integer; Begin. If TheMessage = WM_VSCROLL then begin. {Получаем минимальное и максимальное значения scroll box}. GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax); {Получаем вертикальную позицию scroll box}. TheRange := GetScrollPos(WindowHandle, SB_VERT); {Проверим, чтобы не выйти за диапазон}. If TheRange < TheRangeMin then. TheRange := TheRangeMin else. If TheRange > TheRangeMax then. TheRange := TheRangeMax; {Устанавливаем горизонтальный scroll bar}. SetScrollPos(WindowHandle, SB_HORZ, TheRange, True); End; If TheMessage = WM_HSCROLL then begin. {Получаем мин. и макс. диапазон горизонтального scroll box}. GetScrollRange(WindowHandle, SB_VERT, TheRangeMin, TheRangeMax); {Получаем позицию горизонтального scroll box}. TheRange := GetScrollPos(WindowHandle, SB_HORZ); {Проверим, чтобы не выйти за диапазон}. If TheRange < TheRangeMin then. TheRange := TheRangeMin else. If TheRange > TheRangeMax then. TheRange := TheRangeMax; {Устанавливаем вертикальный scroll bar}. SetScrollPos(WindowHandle, SB_VERT, TheRange, True); End; { Вызываем старую оконную процедуру }. { чтобы обработались сообщения. }. NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage, ParamW, ParamL); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. { Устанавливаем новую оконную процедуру для контрола }. { и запоминаем старую оконную процедуру. }. OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc))); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. { Возвращаем обратно старую оконную процедуру. }. SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc)); End;

Расширяем возможности кнопок в Delphi.

Автор: Maarten de Haan.

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

Также можно создать до 4-х изображений для индикации состояния кнопки.

<--------- Ширина --------->

+------+------+-----+------+ ^

| пке |делами| | | |

+------+------+-----+------+ v.

Вы так же можете присвоить кнопке текстовый заголовок. Можно расположить текст и изображение в любом месте кнопки. Для этого в пример добавлены четыре свойства:

TextTop и TextLeft, Для расположения текста заголовка на кнопке,

И:

GlyphTop и GlyphLeft, Для расположения Glyph на кнопке.

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

Найденные баги.

----------

1) Если двигать мышку очень быстро, то кнопка может не вернуться в исходное состояние.

2) Если кнопка находится в запрещённом состоянии, то при нажатии на неё, будет наблюдаться неприятное мерцание.

Code: Unit NewButton; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; Const. FShift = 2; // Изменяем изображение и заголовок , когда кнопка нажата. FHiColor = $DDDDDD; // Цвет нажатой кнопки (светло серый). // Windows создаёт этот цвет путём смешивания пикселей clSilver и clWhite (50%). // такой цвет хорошо выделяет нажатую и отпущенную кнопки. Type. TNewButton = Class(TCustomControl). Private. { Private declarations }. FMouseOver,fMouseDown : Boolean; FEnabled : Boolean; // То же, что и всех компонент. FGlyph : TPicture; // То же, что и в SpeedButton. FGlyphTop,fGlyphLeft : Integer; // Верх и лево Glyph на изображении кнопки. FTextTop,fTextLeft : Integer; // Верх и лево текста на изображении кнопки. FNumGlyphs : Integer; // То же, что и в SpeedButton. FCaption : String; // Текст на кнопке. FFaceColor : TColor; // Цвет изображения (да-да, вы можете задавать цвет изображения кнопки. Procedure fLoadGlyph(G : TPicture); Procedure fSetGlyphLeft(I : Integer); Procedure fSetGlyphTop(I : Integer); Procedure fSetCaption(S : String); Procedure fSetTextTop(I : Integer); Procedure fSetTextLeft(I : Integer); Procedure fSetFaceColor(C : TColor); Procedure fSetNumGlyphs(I : Integer); Procedure fSetEnabled(B : Boolean); Protected. { Protected declarations }. Procedure Paint; override; Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Procedure WndProc(var Message : TMessage); override; // Таким способом компонент определяет - находится ли курсор мышки на нём или нет. // Если курсор за пределами кнопки, то она всё равно продолжает принимать сообщения мышки. // Так же кнопка будет принимать сообщения, если на родительском окне нет фокуса. Public. { Public declarations }. Constructor Create(AOwner : TComponent); override; Destructor Destroy; override; Published. { Published declarations }. {----- Properties -----}. Property Action; // Property AllowUp не поддерживается. Property Anchors; Property BiDiMode; Property Caption : String. Read fCaption write fSetCaption; Property Constraints; Property Cursor; // Property Down не поддерживается. Property Enabled : Boolean. Read fEnabled write fSetEnabled; // Property Flat не поддерживается. Property FaceColor : TColor. Read fFaceColor write fSetFaceColor; Property Font; Property Glyph : TPicture // Такой способ позволяет получить серую кнопку, которая сможет. // находиться в трёх положениях. // После нажатия на кнопку, с помощью редактора картинок Delphi. // можно будет создать картинки для всех положений кнопки.. Read fGlyph write fLoadGlyph; // Property GroupIndex не поддерживается. Property GlyphLeft : Integer. Read fGlyphLeft write fSetGlyphLeft; Property GlyphTop : Integer. Read fGlyphTop write fSetGlyphTop; Property Height; Property Hint; // Property Layout не поддерживается. Property Left; // Property Margin не поддерживается. Property Name; Property NumGlyphs : Integer. Read fNumGlyphs write fSetNumGlyphs; Property ParentBiDiMode; Property ParentFont; Property ParentShowHint; // Property PopMenu не поддерживается. Property ShowHint; // Property Spacing не поддерживается. Property Tag; Property Textleft : Integer. Read fTextLeft write fSetTextLeft; Property TextTop : Integer. Read fTextTop write fSetTextTop; Property Top; // Property Transparent не поддерживается. Property Visible; Property Width; {--- События ---}. Property OnClick; Property OnDblClick; Property OnMouseDown; Property OnMouseMove; Property OnMouseUp; End; Procedure Register; // Hello. Implementation. {--------------------------------------------------------------------} Procedure TNewButton.fSetEnabled(B : Boolean); Begin. If B <> fEnabled then. Begin. FEnabled := B; Invalidate; End; End; {--------------------------------------------------------------------} Procedure TNewButton.fSetNumGlyphs(I : Integer); Begin. If I > 0 then. If I <> fNumGlyphs then. Begin. FNumGlyphs := I; Invalidate; End; End; {--------------------------------------------------------------------} Procedure TNewButton.fSetFaceColor(C : TColor); Begin. If C <> fFaceColor then. Begin. FFaceColor := C; Invalidate; End; End; {--------------------------------------------------------------------} Procedure TNewButton.fSetTextTop(I : Integer); Begin. If I >= 0 then. If I <> fTextTop then. Begin. FTextTop := I; Invalidate; End; End; {--------------------------------------------------------------------} Procedure TNewButton.fSetTextLeft(I : Integer); Begin. If I >= 0 then. If I <> fTextLeft then. Begin. FTextLeft := I; Invalidate; End; End; {--------------------------------------------------------------------} Procedure TNewButton.fSetCaption(S : String); Begin. If (fCaption <> S) then. Begin. FCaption := S; SetTextBuf(PChar(S)); Invalidate; End; End; {--------------------------------------------------------------------} Procedure TNewButton.fSetGlyphLeft(I : Integer); Begin. If I <> fGlyphLeft then. If I >= 0 then. Begin. FGlyphLeft := I; Invalidate; End; End; {--------------------------------------------------------------------} Procedure TNewButton.fSetGlyphTop(I : Integer); Begin. If I <> fGlyphTop then. If I >= 0 then. Begin. FGlyphTop := I; Invalidate; End; End; {--------------------------------------------------------------------} Procedure tNewButton.fLoadGlyph(G : TPicture); Var. I : Integer; Begin. FGlyph.Assign(G); If fGlyph.Height > 0 then. Begin. I := fGlyph.Width div fGlyph.Height; If I <> fNumGlyphs then. FNumGlyphs := I; End; Invalidate; End; {--------------------------------------------------------------------} Procedure Register; // Hello. Begin. RegisterComponents('Samples', [TNewButton]); End; {--------------------------------------------------------------------} Constructor TNewButton.Create(AOwner : TComponent); Begin. Inherited Create(AOwner); { Инициализируем переменные }. Height := 37; Width := 37; FMouseOver := False; FGlyph := TPicture.Create; FMouseDown := False; FGlyphLeft := 2; FGlyphTop := 2; FTextLeft := 2; FTextTop := 2; FFaceColor := clBtnFace; FNumGlyphs := 1; FEnabled := True; End; {--------------------------------------------------------------------} Destructor TNewButton.Destroy; Begin. If Assigned(fGlyph) then. FGlyph.Free; // Освобождаем glyph. Inherited Destroy; End; {--------------------------------------------------------------------} Procedure TNewButton.Paint; Var. FBtnColor,fColor1,fColor2, FTransParentColor : TColor; Buffer : Array[0..127] of Char; I,J : Integer; X0,X1,X2,X3,X4,Y0 : Integer; DestRect : TRect; TempGlyph : TPicture; Begin. X0 := 0; X1 := fGlyph.Width div fNumGlyphs; X2 := X1 + X1; X3 := X2 + X1; X4 := X3 + X1; Y0 := fGlyph.Height; TempGlyph := TPicture.Create; TempGlyph.Bitmap.Width := X1; TempGlyph.Bitmap.Height := Y0; DestRect := Rect(0,0,X1,Y0); GetTextBuf(Buffer,SizeOf(Buffer)); // получаем caption. If Buffer <> '' then. FCaption := Buffer; If fEnabled = False then. FMouseDown := False; // если недоступна, значит и не нажата. If fMouseDown then. Begin. FBtnColor := fHiColor; // Цвет нажатой кнопки. FColor1 := clWhite; // Правая и нижняя окантовка кнопки, когда на неё нажали мышкой. FColor2 := clBlack; // Верхняя и левая окантовка кнопки, когда на неё нажали мышкой. End. Else. Begin. FBtnColor := fFaceColor; // fFaceColor мы сами определяем. FColor2 := clWhite; // Цвет левого и верхнего края кнопки, когда на неё находится курсор мышки. FColor1 := clGray; // Цвет правого и нижнего края кнопки, когда на неё находится курсор мышки. End; // Рисуем лицо кнопки :). Canvas.Brush.Color := fBtnColor; Canvas.FillRect(Rect(1,1,Width - 2,Height - 2)); If fMouseOver then. Begin. Canvas.MoveTo(Width,0); Canvas.Pen.Color := fColor2; Canvas.LineTo(0,0); Canvas.LineTo(0,Height - 1); Canvas.Pen.Color := fColor1; Canvas.LineTo(Width - 1,Height - 1); Canvas.LineTo(Width - 1, - 1); End; If Assigned(fGlyph) then // Bitmap загружен? Begin. If fEnabled then // Кнопка разрешена? Begin. If fMouseDown then // Мышка нажата? Begin. // Mouse down on the button so show Glyph 3 on the face. If (fNumGlyphs >= 3) then. TempGlyph.Bitmap.Canvas.CopyRect(DestRect, FGlyph.Bitmap.Canvas,Rect(X2,0,X3,Y0)); If (fNumGlyphs < 3) and (fNumGlyphs > 1)then. TempGlyph.Bitmap.Canvas.CopyRect(DestRect, FGlyph.Bitmap.Canvas,Rect(X0,0,X1,Y0)); If (fNumGlyphs = 1) then. TempGlyph.Assign(fGlyph); // Извините, лучшего способа не придумал... // Glyph.Bitmap.Прозрачность цвета не работает, если Вы выберете в качестве. // прозрачного цвета clWhite... FTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1]; For I := 0 to X1 - 1 do. For J := 0 to Y0 - 1 do. If TempGlyph.Bitmap.Canvas.Pixels[I,J] = FTransParentColor then. TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor; //Рисуем саму кнопку. Canvas.Draw(fGlyphLeft + 2,fGlyphTop + 2,TempGlyph.Graphic); End. Else. Begin. If fMouseOver then. Begin. // Курсор на кнопке, но не нажат, показываем Glyph 1 на морде кнопки. // (если существует). If (fNumGlyphs > 1) then. TempGlyph.Bitmap.Canvas.CopyRect(DestRect, FGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0)); If (fNumGlyphs = 1) then. TempGlyph.Assign(fGlyph); End. Else. Begin. // Курсор за пределами кнопки, показываем Glyph 2 на морде кнопки (если есть). If (fNumGlyphs > 1) then. TempGlyph.Bitmap.Canvas.CopyRect(DestRect, FGlyph.Bitmap.Canvas,Rect(X1,0,X2,Y0)); If (fNumGlyphs = 1) then. TempGlyph.Assign(fGlyph); End; // Извиняюсь, лучшего способа не нашёл... FTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1]; For I := 0 to X1 - 1 do. For J := 0 to Y0 - 1 do. If TempGlyph.Bitmap.Canvas.Pixels[I,J] = FTransParentColor then. TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor; //Рисуем bitmap на морде кнопки. Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic); End; End. Else. Begin. // Кнопка не доступна (disabled), показываем Glyph 4 на морде кнопки (если существует). If (fNumGlyphs = 4) then. TempGlyph.Bitmap.Canvas.CopyRect(DestRect, FGlyph.Bitmap.Canvas,Rect(X3,0,X4,Y0)). Else. TempGlyph.Bitmap.Canvas.CopyRect(DestRect, FGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0)); If (fNumGlyphs = 1) then. TempGlyph.Assign(fGlyph.Graphic); // Извините, лучшего способа не нашлось... FTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1]; For I := 0 to X1 - 1 do. For J := 0 to Y0 - 1 do. If TempGlyph.Bitmap.Canvas.Pixels[I,J] = FTransParentColor then. TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor; //Рисуем изображение кнопки. Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic); End; End; // Рисуем caption. If fCaption <> '' then. Begin. Canvas.Pen.Color := Font.Color; Canvas.Font.Name := Font.Name; Canvas.Brush.Style := bsClear; //Canvas.Brush.Color := fBtnColor; Canvas.Font.Color := Font.Color; Canvas.Font.Size := Font.Size; Canvas.Font.Style := Font.Style; If fMouseDown then. Canvas.TextOut(fShift + fTextLeft,fShift + fTextTop,fCaption). Else. Canvas.TextOut(fTextLeft,fTextTop,fCaption); End; TempGlyph.Free; // Освобождаем временный glyph. End; {--------------------------------------------------------------------} // Нажата клавиша мышки на кнопке ? Procedure TNewButton.MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer); Var. FfMouseDown,ffMouseOver : Boolean; Begin. FfMouseDown := True; FfMouseOver := True; If (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then. Begin. FMouseDown := ffMouseDown; FMouseOver := ffMouseOver; Invalidate; // не перерисовываем кнопку без необходимости. End; Inherited MouseDown(Button,Shift,X,Y);; End; {--------------------------------------------------------------------} // Отпущена клавиша мышки на кнопке ? Procedure TNewButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Var. FfMouseDown,ffMouseOver : Boolean; Begin. FfMouseDown := False; FfMouseOver := True; If (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then. Begin. FMouseDown := ffMouseDown; FMouseOver := ffMouseOver; Invalidate; // не перерисовываем кнопку без необходимости. End; Inherited MouseUp(Button,Shift,X,Y); End; {--------------------------------------------------------------------} // Эта процедура перехватывает события мышки, если она даже за пределами кнопки. // Перехватываем оконные сообщения. Procedure TNewButton.WndProc(var Message : TMessage); Var. P1,P2 : TPoint; Bo : Boolean; Begin. If Parent <> nil then. Begin. GetCursorPos(P1); // Получаем координаты курсона на экране. P2 := Self.ScreenToClient(P1); // Преобразуем их в координаты относительно кнопки. If (P2.X > 0) and (P2.X < Width) and. (P2.Y > 0) and (P2.Y < Height) then. Bo := True // Курсор мышки в области кнопки. Else. Bo := False; // Курсор мышки за пределами кнопки. If Bo <> fMouseOver then // не перерисовываем кнопку без необходимости. Begin. FMouseOver := Bo; Invalidate; End; End; Inherited WndProc(Message); // отправляем сообщение остальным получателям. End; {--------------------------------------------------------------------} End. {====================================================================}

Автоматически нажимающаяся кнопка.

Этот компонент представляет из себя кнопку, на которую не надо нажимать, чтобы получить событие OnClick. Достаточно переместить курсор мышки на кнопку. При создании такого компонента традиционным способом, требуется довольно много времени, так как необходимо обрабатывать мышку, перехватывать её и т.д. Однако результат стоит того!

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

Code: Type. TAutoButton1 = class(TButton). Private. Procedure WmMouseMove (var Msg: TMessage); Message wm_MouseMove; End; Procedure TAutoButton1.WmMouseMove (var Msg: TMessage); Begin. Inherited; If Assigned (OnClick) then. OnClick (self); End;

Кнопка со звуком.

Когда Вы нажимаете на кнопку, то видите трёхмерный эффект нажатия. А как же насчёт четвёртого измерения, например звука ? Ну тогда нам понадобится звук для нажатия и звук для отпускания кнопки. Если есть желание, то можно добавить даже речевую подсказку, однако не будем сильно углубляться.

Компонент звуковой кнопки имеет два новых свойства:

Code: Type. TDdhSoundButton = class(TButton). Private. FSoundUp, FSoundDown: string; Protected. Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Published. Property SoundUp: string. Read FSoundUp write FSoundUp; Property SoundDown: string. Read FSoundDown write FSoundDown; End;

Видоизменяем чекбоксы в Delphi.

В WIN3.1 чекбоксы заполняются символом "X". В WIN95 и WINNT - символом "V". В тандартной палитре Delphi чекбоксы заполняются символом "X". Спрашивается - почему фирма Borland/Inprise не исправила значёк чекбокса для W95/W98 ?. Данный пример позволяет заполнять чекбокс такими значками как: "X", "V", "o", "закрашенным прямоугольником", или бриллиантиком.

Пример тестировался под WIN95 и WINNT.

Code: { ==================================================================== Обозначения. ==================================================================== X = крестик. V = галочка. O = кружок. +-+ |W| = заполненный прямоугольник. +-+ /\ = бриллиантик. \/ ==================================================================== Преимущества этого чекбокса. ==================================================================== Вы можете найти множество чекбоксов в интернете. Но у них есть недостаток, они не обрабатывают сообщение WM_KILLFOCUS. Приведённый ниже пример делает это. ==================================================================== } Unit CheckBoxX; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Const. { другие константы }. FRBoxWidth : Integer = 13; // ширина квадрата checkbox. FRBoxHeight : Integer = 13; // высота квадрата checkbox. Type. TState = (cbUnchecked,cbChecked,cbGrayed); // такой же как в Delphi. TType = (cbCross,cbMark,cbBullet,cbDiamond,cbRect); // добавленный. TMouseState = (msMouseUp,msMouseDown); TAlignment = (taRightJustify,taLeftJustify); // The same. TCheckBoxX = class(TCustomControl). Private. { Private declarations }. FChecked : Boolean; FCaption : String; FColor : TColor; FState : TState; FFont : TFont; FAllowGrayed : Boolean; FFocus : Boolean; FType : TType; FMouseState : TMouseState; FAlignment : TAlignment; FTextTop : Integer; // отступ текта с верху. FTextLeft : Integer; // отступ текта с лева. FBoxTop : Integer; // координата чекбокса сверху. FBoxLeft : Integer; // координата чекбокса слева. Procedure fSetChecked(Bo : Boolean); Procedure fSetCaption(S : String); Procedure fSetColor(C : TColor); Procedure fSetState(cbState : TState); Procedure fSetFont(cbFont : TFont); Procedure fSetAllowGrayed(Bo : Boolean); Procedure fSetType(T : TType); Procedure fSetAlignment(A : TAlignment); Protected. { Protected declarations }. Procedure Paint; override; Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Procedure WMKillFocus(var Message : TWMKillFocus); Message WM_KILLFOCUS; // это убирает контур фокуса! Procedure WMSetFocus(var Message : TWMSetFocus); Message WM_SETFOCUS; // Если вы используете клавишу TAB или Shift-Tab. Procedure KeyDown(var Key : Word; Shift : TShiftState); override; // перехват KeyDown. Procedure KeyUp(var Key : Word; Shift : TShiftState); override; // перехват KeyUp. Public. { Public declarations }. // Если поместить Create и Destroy в раздел protected, // то Delphi начинает ругаться. Constructor Create(AOwner : TComponent); override; Destructor Destroy; override; Published. { Published declarations }. { --- Свойства --- }. Property Action; Property Alignment : TAlignment. Read fAlignment write fSetAlignment; Property AllowGrayed : Boolean. Read fAllowGrayed write fSetAllowGrayed; Property Anchors; Property BiDiMode; Property Caption : String. Read fCaption write fSetCaption; Property CheckBoxType : TType. Read fType write fSetType; Property Checked : Boolean. Read fChecked write fSetChecked; Property Color : TColor. Read fColor write fSetColor; Property Constraints; //Property Ctrl3D; Property Cursor; Property DragCursor; Property DragKind; Property DragMode; Property Enabled; Property Font : TFont. Read fFont write fSetFont; //Property Height; Property HelpContext; Property Hint; Property Left; Property Name; //Property PartenBiDiMode; Property ParentColor; //Property ParentCtrl3D; Property ParentFont; Property ParentShowHint; //Property PopMenu; Property ShowHint; Property State : TState. Read fState write fSetState; Property TabOrder; Property TabStop; Property Tag; Property Top; Property Visible; //Property Width; { --- Events --- }. Property OnClick; Property OnContextPopup; Property OnDragDrop; Property OnDragOver; Property OnEndDock; Property OnEndDrag; Property OnEnter; Property OnExit; Property OnKeyDown; Property OnKeyPress; Property OnKeyUp; Property OnMouseDown; Property OnMouseMove; Property OnMouseUp; Property OnStartDock; Property OnStartDrag; End; Procedure Register; //Hello! Implementation. {-------------------------------------------------------------------} Procedure TCheckBoxX.KeyDown(var Key : Word; Shift : TShiftState); Begin. If fFocus then. If Shift = [] then. If Key = 0032 then. Begin. FMouseState := msMouseDown; If fState <> cbGrayed then. Begin. SetFocus; // Устанавливаем фокус на этот компонент. // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS. FFocus := True; Invalidate; End; End; Inherited KeyDown(Key,Shift); End; {-------------------------------------------------------------------} Procedure TCheckBoxX.KeyUp(var Key : Word; Shift : TShiftState); Begin. If fFocus then. If Shift = [] then. If Key = 0032 then. Begin. If fState <> cbGrayed then. FSetChecked(not fChecked); // Изменяем состояние. FMouseState := msMouseUp; End; Inherited KeyUp(Key,Shift); End; {-------------------------------------------------------------------} Procedure TCheckBoxX.WMSetFocus(var Message : TWMSetFocus); Begin. FFocus := True; Invalidate; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.WMKillFocus(var Message : TWMKillFocus); Begin. FFocus := False; // Удаляем фокус у всех компонент, которые не имеют фокуса. Invalidate; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetAlignment(A : TAlignment); Begin. If A <> fAlignment then. Begin. FAlignment := A; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetType(T : TType); Begin. If fType <> T then. Begin. FType := T; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetFont(cbFont : TFont); Var. FontChanged : Boolean; Begin. FontChanged := False; If fFont.Style <> cbFont.Style then. Begin. FFont.Style := cbFont.Style; FontChanged := True; End; If fFont.CharSet <> cbFont.Charset then. Begin. FFont.Charset := cbFont.Charset; FontChanged := True; End; If fFont.Size <> cbFont.Size then. Begin. FFont.Size := cbFont.Size; FontChanged := True; End; If fFont.Name <> cbFont.Name then. Begin. FFont.Name := cbFont.Name; FontChanged := True; End; If fFont.Color <> cbFont.Color then. Begin. FFont.Color := cbFont.Color; FontChanged := True; End; If FontChanged then. Invalidate; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. // Процедура MouseDown вызывается, когда кнопка мышки нажимается в пределах. // кнопки, соответственно мы не можем получить значения координат X и Y. Inherited MouseDown(Button, Shift, X, Y); FMouseState := msMouseDown; If fState <> cbGrayed then. Begin. SetFocus; // Устанавливаем фокус на этот компонент. // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS. FFocus := True; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. // Процедура MouseUp вызывается, когда кнопка мышки отпускается в пределах. // кнопки, соответственно мы не можем получить значения координат X и Y. Inherited MouseUp(Button, Shift, X, Y); If fState <> cbGrayed then. FSetChecked(not fChecked); // Изменяем состояние. FMouseState := msMouseUp; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetAllowGrayed(Bo : Boolean); Begin. If fAllowGrayed <> Bo then. Begin. FAllowGrayed := Bo; If not fAllowGrayed then. If fState = cbGrayed then. Begin. If fChecked then. FState := cbChecked. Else. FState := cbUnChecked; End; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetState(cbState : TState); Begin. If fState <> cbState then. Begin. FState := cbState; If (fState = cbChecked) then. FChecked := True; If (fState = cbGrayed) then. FAllowGrayed := True; If fState = cbUnChecked then. FChecked := False; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetColor(C : TColor); Begin. If fColor <> C then. Begin. FColor := C; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetCaption(S : String); Begin. If fCaption <> S then. Begin. FCaption := S; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.fSetChecked(Bo : Boolean); Begin. If fChecked <> Bo then. Begin. FChecked := Bo; If fState <> cbGrayed then. Begin. If fChecked then. FState := cbChecked. Else. FState := cbUnChecked; End; Invalidate; End; End; {-------------------------------------------------------------------} Procedure TCheckBoxX.Paint; Var. Buffer: array[0..127] of Char; I: Integer; FTextWidth, fTextHeight: Integer; Begin. {Get Delphi's componentname and initially write it in the caption}. GetTextBuf(Buffer, SizeOf(Buffer)); If Buffer <> '' then. FCaption := Buffer; Canvas.Font.Size := Font.Size; Canvas.Font.Style := Font.Style; Canvas.Font.Color := Font.Color; Canvas.Font.Charset := Font.CharSet; FTextWidth := Canvas.TextWidth(fCaption); FTextHeight := Canvas.TextHeight('Q'); If fAlignment = taRightJustify then. Begin. FBoxTop := (Height - fRBoxHeight) div 2; FBoxLeft := 0; FTextTop := (Height - fTextHeight) div 2; FTextLeft := fBoxLeft + fRBoxWidth + 4; End. Else. Begin. FBoxTop := (Height - fRBoxHeight) div 2; FBoxLeft := Width - fRBoxWidth; FTextTop := (Height - fTextHeight) div 2; FTextLeft := 1; //If fTextWidth > (Width - fBoxWidth - 4) then. // fTextLeft := (Width - fBoxWidth - 4) - fTextWidth; End; // выводим текст в caption. Canvas.Pen.Color := fFont.Color; Canvas.Brush.Color := fColor; Canvas.TextOut(fTextLeft, fTextTop, fCaption); // Рисуем контур фокуса. If fFocus = True then. Canvas.DrawFocusRect(Rect(fTextLeft - 1, FTextTop - 2, FTextLeft + fTextWidth + 1, FTextTop + fTextHeight + 2)); If (fState = cbChecked) then. Canvas.Brush.Color := clWindow; If (fState = cbUnChecked) then. Canvas.Brush.Color := clWindow; If (fState = cbGrayed) then. Begin. FAllowGrayed := True; Canvas.Brush.Color := clBtnFace; End; // Создаём бокс clBtnFace когда кнопка мыши нажимается. // наподобие "стандартного" CheckBox. If fMouseState = msMouseDown then. Canvas.Brush.Color := clBtnFace; Canvas.FillRect(Rect(fBoxLeft + 2, FBoxTop + 2, FBoxLeft + fRBoxWidth - 2, FBoxTop + fRBoxHeight - 2)); // Рисуем прямоугольный чекбокс. Canvas.Brush.Color := clBtnFace; Canvas.Pen.Color := clGray; Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBoxTop); Canvas.LineTo(fBoxLeft, fBoxTop); Canvas.LineTo(fBoxLeft, fBoxTop + fRBoxHeight); Canvas.Pen.Color := clWhite; Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBoxTop); Canvas.LineTo(fBoxLeft + fRBoxWidth - 1, FBoxTop + fRBoxHeight - 1); Canvas.LineTo(fBoxLeft - 1, fBoxTop + fRBoxHeight - 1); Canvas.Pen.Color := clBlack; Canvas.MoveTo(fBoxLeft + fRBoxWidth - 3, fBoxTop + 1); Canvas.LineTo(fBoxLeft + 1, fBoxTop + 1); Canvas.LineTo(fBoxLeft + 1, fBoxTop + fRBoxHeight - 2); Canvas.Pen.Color := clBtnFace; Canvas.MoveTo(fBoxLeft + fRBoxWidth - 2, fBoxTop + 1); Canvas.LineTo(fBoxLeft + fRBoxWidth - 2, FBoxTop + fRBoxHeight - 2); Canvas.LineTo(fBoxLeft, fBoxTop + fRBoxHeight - 2); // Теперь он должен быть таким же как чекбокс в Delphi. If fChecked then. Begin. Canvas.Pen.Color := clBlack; Canvas.Brush.Color := clBlack; // Рисуем прямоугольник. If fType = cbRect then. Begin. Canvas.FillRect(Rect(fBoxLeft + 4, fBoxTop + 4, FBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4)); End; // Рисуем значёк "о". If fType = cbBullet then. Begin. Canvas.Ellipse(fBoxLeft + 4, fBoxTop + 4, FBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4); End; // Рисуем крестик. If fType = cbCross then. Begin. {Right-top to left-bottom}. Canvas.MoveTo(fBoxLeft + fRBoxWidth - 5, fBoxTop + 3); Canvas.LineTo(fBoxLeft + 2, fBoxTop + fRBoxHeight - 4); Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBoxTop + 3); Canvas.LineTo(fBoxLeft + 2, fBoxTop + fRBoxHeight - 3); Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBoxTop + 4); Canvas.LineTo(fBoxLeft + 3, fBoxTop + fRBoxHeight - 3); {Left-top to right-bottom}. Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 4); Canvas.LineTo(fBoxLeft + fRBoxWidth - 4, FBoxTop + fRBoxHeight - 3); Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 3); Canvas.LineTo(fBoxLeft + fRBoxWidth - 3, FBoxTop + fRBoxHeight - 3); //mid. Canvas.MoveTo(fBoxLeft + 4, fBoxTop + 3); Canvas.LineTo(fBoxLeft + fRBoxWidth - 3, FBoxTop + fRBoxHeight - 4); End; // Рисуем галочку. If fType = cbMark then. For I := 0 to 2 do. Begin. {Left-mid to left-bottom}. Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 5 + I); Canvas.LineTo(fBoxLeft + 6, fBoxTop + 8 + I); {Left-bottom to right-top}. Canvas.MoveTo(fBoxLeft + 6, fBoxTop + 6 + I); Canvas.LineTo(fBoxLeft + 10, fBoxTop + 2 + I); End; // Рисуем бриллиантик. If fType = cbDiamond then. Begin. Canvas.Pixels[fBoxLeft + 06, fBoxTop + 03] := clBlack; Canvas.Pixels[fBoxLeft + 06, fBoxTop + 09] := clBlack; Canvas.MoveTo(fBoxLeft + 05, fBoxTop + 04); Canvas.LineTo(fBoxLeft + 08, fBoxTop + 04); Canvas.MoveTo(fBoxLeft + 05, fBoxTop + 08); Canvas.LineTo(fBoxLeft + 08, fBoxTop + 08); Canvas.MoveTo(fBoxLeft + 04, fBoxTop + 05); Canvas.LineTo(fBoxLeft + 09, fBoxTop + 05); Canvas.MoveTo(fBoxLeft + 04, fBoxTop + 07); Canvas.LineTo(fBoxLeft + 09, fBoxTop + 07); Canvas.MoveTo(fBoxLeft + 03, fBoxTop + 06); Canvas.LineTo(fBoxLeft + 10, fBoxTop + 06); // middle line. End; End; End; {-------------------------------------------------------------------} Procedure Register; Begin. RegisterComponents('Samples', [TCheckBoxX]); End; {-------------------------------------------------------------------} Destructor TCheckBoxX.Destroy; Begin. Inherited Destroy; End; {-------------------------------------------------------------------} Constructor TCheckBoxX.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); Height := 17; Width := 97; FChecked := False; FColor := clBtnFace; FState := cbUnChecked; FFont := inherited Font; FAllowGrayed := False; FFocus := False; FMouseState := msMouseUp; FAlignment := taRightJustify; TabStop := True; // Sorry. End; {-------------------------------------------------------------------} End. {===================================================================}

Показываем всплывающие подсказки в различных панелях StatusBar.

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

Code: { Добавьте CommCtrl в uses. }. { в интерфейсе формы для статусбара }. Private. Procedure AppShowHint(var HintStr: string; var CanShow: boolean; Var HintInfo: THintInfo); Procedure TForm1.FormCreate(Sender: TObject); Begin. Application.OnShowHint := AppShowHint; End; Procedure TForm1.AppShowHint(var HintStr: string; var CanShow: boolean; Var HintInfo: THintInfo); Const. PanelHints: array [0..6] of string = ('Cursor position', 'Ascii char', 'Bookmarks', 'Caps lock', 'Insert/Overwrite', 'File size', 'File name'); Var. X: integer; R: TRect; Begin. If HintInfo.HintControl = StatusBar1 then. Begin. For x := 0 to StatusBar1.Panels.Count-1 do. Begin. SendMessage(StatusBar1.Handle, SB_GETRECT, x, Longint(@R)); If PtInRect(R, HintInfo.CursorPos) then. Begin. HintStr := PanelHints[x]; InflateRect(R, 3, 3); { Устанавливаем CursorRect говоря системе проверить новые. Строки с подсказками, когда курсор покинет этот прямоугольник. }. HintInfo.CursorRect := R; Break; End; End; End; End;

Как поместить иконку в окошко подсказки?

Следующий код помещает главную иконку приложения в окошки подсказок:

Code: Unit HintX; Interface. Uses. Windows, Messages, Controls; Type. TIconHintX = class(THintWindow). Protected. Procedure Paint; override; Public. Function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override; End; Implementation. Uses Forms; { TIconHintX }. {-Вычисляем новый размер окошка подсказки для помещения в него иконки:-}. Function TIconHintX.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; Begin. Result := inherited CalcHintRect(MaxWidth, AHint, AData); Result.Right := (Length(AHint) * 5) + Application.Icon.Width; Result.Bottom := (Application.Icon.Height) * 2; End; Procedure TIconHintX.Paint; Const. MARGIN = 5; Begin. Inherited; Canvas.Draw(MARGIN, MARGIN * 5, Application.Icon); SendMessage(Handle, WM_NCPAINT, 0, 0); //рисуем рамку окошка подсказки. End; Initialization. //связываем наш новый класс с классом окошка подсказки установленным поумолчанию: HintWindowClass := TIconHintX; End.

Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?

Code: Var hintWnd: THintWindow; Procedure TForm1.ActivateHintNOW( x,y: Integer); Var rect: TRect; Begin. HintTxt := 'qq'; If hintTxt <> '' then. Begin. Rect := hintWnd.CalcHintRect( Screen.Width, hinttxt, nil); Rect.Left := rect.Left + x; Rect.Right := rect.Right + x; Rect.Top := rect.Top + y; Rect.Bottom := rect.Bottom + y; HintWnd.ActivateHint( rect, hinttxt); End; End;

Добавляем пункты в системное меню Windows.

Автор: MAD Rodrguez.

Вы, наверное, задавались вопросом, почему системное меню постоянно одно и тоже ? Пример показывает, как добавить туда такие пункты как "About" или "Information", или что-нибудь ещё.

Нам понадобится две вещи, первая это Item ID, который может быть любым целым числом. Второе это Описание(Caption) для нашего пункта меню. Нам понадобится также процедура, которая будет принимать сообщения Window для определения нажатия на наш пункт меню.

Code: Unit OhYeah; Interface. Uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus; Type. TForm1 = Class (TForm). Procedure FormCreate (Sender : TObject); Private {Private declarations}. Public {Public declarations}. Procedure WinMsg (Var Msg : TMsg; Var Handled : Boolean); Procedure DoWhatEever; End; Var Form1 : TForm1; Implementation. {$R *.DFM}. Const ItemID = 99; // ID номер для пункта меню. Может быть любым. Procedure Tform1.WinMsg (Var Msg : TMsg; Var Handled : Boolean); Begin. If Msg.Message = WM_SYSCOMMAND Then. If Msg.WParam = ItemID Then DoWhatEver; End; Procedure TForm1.FormCreate (Sender : TObject); Begin. Application.OnMessage := WinMsg; AppendMenu (GetSystemMenu (Form1.Handle, False), MF_SEPARATOR, 0, ''); AppendMenu (GetSystemMenu (Form1.Handle, False), MF_BYPOSITION, ItemID, '&My menu'); AppendMenu (GetSystemMenu (Application.Handle, False), MF_SEPARATOR, 0, ''); AppendMenu (GetSystemMenu (Application.Handle, False), MF_BYPOSITION, ItemID,'&My menu minimized'); End; Procedure TForm1.DoWhatEver; Begin. Exit; // Вы можете добавить здесь всё, что угодно. End; End.

Пишем свой текст в Меню.

Автор: Ido Kanner.

Когда играешь во встроенную в Windows игру freecell, то справа в меню постоянно пишется сколько осталось карт. Давайте посмотрим, как это делается.

Перво наперво положим компонент главного меню на форму.

Теперь установим свойство OwnerDraw в true.

Далее создайте, то что Вы хотите вырисовывать в меню и создайте OnDrawItem.

И добавьте в него следующую строку:

Code: ... ACanvas.TextOut(1,ARect.Top+1,'I am in the MainMenuDrawbar'); ...

Не забудьте, если Вы используете изменяющуюся переменную, то измените её в другой функции и всё что надо будет сделать - это вызвать API функцию DrawMenuBar.

Если Вы используете Delphi 2,3 пользуйтесь сообщениями WM_MESUREITEM и WM_DRAWITEM, чтобы сделать данный эффект.

©Drkb::01297.

Взято из http://forum.sources.ru.

Как сделать пункты меню с картинками?

Следующий код показывает, как добавить картинку в виде объекта TImage в объект TMenuItem.

Code: Var. HHandle: THandle; X: integer; // visual controls: HMenu: TMenuItem; Image1: TImage; ... X:= 10; // десятый пункт меню. HHandle := GetMenuItemID(hMenu.handle, x); ModifyMenu(hMenu.handle, hHandle, MF_BYCOMMAND Or MF_BITMAP, hHandle, PChar(Image1.picture.bitmap.handle)).

©Drkb::01298.

Взято из http://forum.sources.ru.

Как поместить маленькие битмапы в TPopUpMenu?

Следующий пример демонстрирует добавление битмапа в пункт PopUpMenu при помощи API функции SetMenuItemBitmaps(). Эта функция имеет следующие параметры: дескриптор всплывающего меню, номер (начиная с нуля) пункта меню в который мы хотим добаить битмап, и два дескриптора битмапов (одна картинка для меню в активном состоянии, а вторая для неактивного состояния).

Code: Type. TForm1 = class(TForm). PopupMenu1: TPopupMenu; Pop11: TMenuItem; Pop21: TMenuItem; Pop31: TMenuItem; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Private. { Private declarations }. BmUnChecked : TBitmap; BmChecked : TBitmap; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. BmUnChecked := TBitmap.Create; BmUnChecked.LoadFromFile( 'C:\Program Files\Borland\BitBtns\ALARMRNG.BMP'); BmChecked := TBitmap.Create; BmChecked.LoadFromFile( 'C:\Program Files\Borland\BitBtns\CHECK.BMP'); {Добавляем битмапы в пункт меню начиная с 1 в PopUpMenu}. SetMenuItemBitmaps(PopUpMenu1.Handle, 1, MF_BYPOSITION, BmUnChecked.Handle, BmChecked.Handle); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. BmUnChecked.Free; BmChecked.Free; End; Procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Var. Pt : TPoint; Begin. Pt := ClientToScreen(Point(x, y)); PopUpMenu1.Popup(pt.x, pt.y); End;

©Drkb::01299.

Взято из http://forum.sources.ru.

Более быстрый способ добавлять пункты меню.

Обычно, когда Вы создаёте меню в приложении, то код выглядит примерно так:

Code: PopupMenu1 := TPopupMenu.Create(Self); Item := TMenuItem.Create(PopupMenu1); Item.Caption := 'First Menu'; Item.OnClick := MenuItem1Click; PopupMenu1.Items.Add(Item); Item := TMenuItem.Create(PopupMenu1); Item.Caption := 'Second Menu'; Item.OnClick := MenuItem2Click; PopupMenu1.Items.Add(Item); Item := TMenuItem.Create(PopupMenu1); Item.Caption := 'Third Menu'; Item.OnClick := MenuItem3Click; PopupMenu1.Items.Add(Item); Item := TMenuItem.Create(PopupMenu1); Item.Caption := '-'; PopupMenu1.Items.Add(Item); Item := TMenuItem.Create(PopupMenu1); Item.Caption := 'Fourth Menu'; Item.OnClick := MenuItem4Click; PopupMenu1.Items.Add(Item);

Однако есть более быстрый способ! Воспользуйтесь функциями NewItem и NewLine:

Code: PopupMenu1 := TPopupMenu.Create(Self); With PopUpMenu1.Items do. Begin. Add(NewItem('First Menu',0,False,True,MenuItem1Click,0,'MenuItem1')); Add(NewItem('Second Menu',0,False,True,MenuItem2Click,0,'MenuItem2')); Add(NewItem('Third Menu',0,False,True,MenuItem3Click,0,'MenuItem3')); Add(NewLine); // Добавляем разделитель. Add(NewItem('Fourth Menu',0,False,True,MenuItem4Click,0,'MenuItem4')); End;

©Drkb::01300.

Взято из http://forum.sources.ru.

Сервер приложения (статья).

Сервер приложения.

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

· обеспечивает авторизацию пользователей;

· принимает и передает запросы пользователей и пакеты данных;

· регулирует доступ клиентских запросов к серверу БД, балансируя нагрузку сервера БД;

· может содержать часть бизнес-логики распределенного приложения, обеспечивая существование "тонких" клиентов.

Delphi обеспечивает разработку серверов приложений на основе использования ряда технологий:

· Web;

· Автоматизация;

· MTS;

· SOAP.

Структура сервера приложения.

Итак, сервер приложения — это ПО промежуточного слоя трехзвенного распределенного приложения. Его основой является удаленный модуль данных. В Delphi предусмотрено использование удаленных модулей данных пяти типов (см. ниже).

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

Каждый удаленный модуль данных инкапсулирует интерфейс IAppServer, методы которого используются в механизме удаленного доступа клиентов к серверу БД.

Для обмена данными с сервером БД модуль данных может содержать некоторое количество компонентов доступа к данным (компонентов соединений и компонентов, инкапсулирующих набор данных).

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

Внимание.

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

Для создания нового сервера приложения достаточно выполнить несколько простых операций.

1. Создать новый проект, выбрав в качестве типа проекта обычное приложение (пункт меню File | New | Application) и сохранить его.

2. В зависимости от используемой технологии, выбрать из Репозитория Delphi необходимый тип удаленного модуля данных (см. рис. 20.3). Удаленные модули данных располагаются на страницах Multitier, WebSnap и WebServices.

3. Настроить параметры создаваемого удаленного модуля данных (см. ниже).

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

Наборов компонентов (см. часть IV) в зависимости от используемого сервера БД и требуемых характеристик создаваемого приложения.

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

6. При необходимости создать для потомка интерфейса IAppServer, используемого в удаленном модуле данных, дополнительные методы. Для этого создается новая библиотека типов (см. низке).

7. Скомпилировать проект и создать исполняемый файл сервера приложения.

8. Зарегистрировать сервер приложения и при необходимости настроить дополнительное ПО.

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

Далее в этой главе на простом примере рассматриваются все перечисленные этапы создания сервера приложения.

Интерфейс IAppServer.

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

При создании удаленных модулей данных (см. ниже) каждому такому модулю ставится в соответствие вновь создаваемый интерфейс, предком которого является интерфейс IAppServer.

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

Свойство.

Property AppServer: Variant;

В клиентском приложении имеется как в компонентах удаленного соединения, так и клиентском наборе данных.

По умолчанию интерфейс является несохраняющим состояние (stateless). Это означает, что вызовы методов интерфейса независимы и не привязаны.

К предыдущему вызову. Поэтому интерфейс IAppServer не имеет свойств, которые бы хранили информацию о состоянии между вызовами.

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

Методы интерфейса IAppServar.

Function AS ApplyUpdates (const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant) : OleVariant; safecall; Передает изменения, полученные от клиентского набора данных, компоненту-провайдеру, определяемому параметром ProviderName. Изменения содержатся в параметре Delta. Параметр MaxErrors задает максимальное число ошибок, пропускаемых при сохранении данных перед прерыванием операции. Реальное число возникших ошибок возвращается параметром ErrorCount. Параметр OwnerData содержит дополнительную информацию, передаваемую между клиентом и сервером (например, значения параметров методов-обработчиков). Функция возвращает пакет данных, содержащий все записи, которые не были сохранены в базе данных по какой-либо причине.

Function AS DataRequest (const ProviderName: WideString; Data: OleVariant) : OleVariant; safecall; Генерирует событие OnDataRequest для указанного провайдера ProviderName.

Procedure AS Execute (const ProviderName: WideString; const CommandText : WideString; var Params : OleVariant; var OwnerData: OleVariant) ; safecall;

Выполняет запрос или хранимую процедуру, определяемые параметром CommandText для провайдера, указанного параметром ProviderName. Параметры запроса или хранимой процедуры содержатся в параметре Params.

Function AS GetParams (const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall; Передает провайдеру ProviderName текущие значения параметров клиентского набора данных.

Function AS GetProviderNames: OleVariant; safecall; Возвращает список всех доступных провайдеров удаленного модуля данных.

Function AS GetRecords (const ProviderName : WideString, Count: Integer; out RecsOut: Integer; Options: Integer; const CommandText: WideString; var Params : OleVariant; var OwnerData :OieVariant) : OleVariant; safecall;

Возвращает пакет данных с записями набора данных сервера, связанного с компонентом-провайдером. Параметр CommandText содержит имя таблицы, текст запроса или имя хранимой процедуры, откуда необходимо получить записи. Но он работает только в случае, если для провайдера в параметре Options включена опция poAllowCommandText. Параметры запроса или процедуры помещаются в параметре Params. Параметр задает требуемое число записей, начиная с текущей, если его значение больше нуля. Если параметр равен нулю — возвращаются только метаданные, если он равен -1 — возвращаются все записи. Параметр RecsOut возвращает реальное число переданных записей.

Function AS RowRequest (const ProviderName: WideString; Row: OleVariant; RequestType: Integer; var OwnerData: OleVariant): OleVariant; safecall;

Возвращает запись набора данных (предоставляемого провайдером ProviderName), определяемую параметром Row. Параметр RequestType содержит значение типа TfetchOptions.

Большинство методов интерфейса используют параметры ProviderName и OwnerData. Первый определяет имя компонента-провайдера, а второй содержит набор параметров, передаваемых для использования в методах-обработчиках.

Внимательный читатель обратил внимание, что использование метода AS_GetRecords подразумевает сохранение информации при работе интерфейса, т. к. метод возвращает записи, начиная с текущей, хотя интерфейс IAppServer имеет тип stateless. Поэтому перед использованием метода рекомендуется обновлять набор данных клиента.

Тип.

TFetchOption = (foRecord, foBlobs, foDetails);

TFetchOptions = set of TFetchOption;

Используется в параметре RequestType метода AS_RowRequest.

FoRecord — возвращает значения полей текущей записи;

FoBlobs — возвращает значения полей типа BLOB текущей записи;

FoDetails — возвращает все подчиненные записи вложенных наборов данных для текущей записи.

Интерфейс IProviderSupport.

Для организации взаимодействия клиентов с сервером БД удаленный модуль данных сервера приложения должен содержать компоненты-провайдеры TDataSetProvider. При этом используются методы интерфейса IAppServer.

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

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

Удаленные модули данных.

Удаленный модуль данных является основой сервера приложения (см. рис. 20.2) для многозвенного распределенного приложения. Во-первых, он выполняет функции обычного модуля данных — на нем можно размещать компоненты доступа к данным. Во-вторых, удаленный модуль данных инкапсулирует интерфейс IAppServer, обеспечивая тем самым выполнение функций сервера и обмен данными с удаленными клиентами.

В зависимости от используемой технологии в Delphi можно использовать удаленные модули данных пяти типов.

Remote Data Module. Класс TRemoteDataModule инкапсулирует сервер Автоматизации.

Transactional Data Module. Класс TMTSDataModule является потомком класса TRemoteDataModule и к функциям обычного сервера Автоматизации добавляет возможности MTS.

WebSnap Data Module. Класс TWebDataModule создает сервер приложения, использующий возможности Internet-технологий.

Soap Server Data Module. Класс TSOAPDataModule инкапсулирует сервер SOAP.

CORBA Data Module. Класс TCORBADataModule является потомком класса TRemoteDataModule и реализует функции сервера CORBA.

Ниже мы рассмотрим процесс создания сервера приложения на основе удаленного модуля данных TRemoteDataModule. Остальные модули данных (за исключением удаленного модуля данных для CORBA) детально рассматриваются далее в этой книге.

Удаленный модуль данных для сервера Автоматизации.

Для создания удаленного модуля данных TRemoteDataModule используется Репозиторий Delphi (команда File | New | Other). Значок класса TRemoteDataModuie находится на странице Multitier. Перед созданием экземпляра удаленного модуля данных появляется диалоговое окно, в котором необходимо предустановить три параметра.

Строка CoClass Name должна содержать имя нового модуля данных, которое будет также использовано для именования нового класса, создаваемого для поддержки нового модуля данных.

Список Instancing позволяет задать способ создания модуля данных.

Internal — модуль данных обеспечивает функционирование лишь внутреннего сервера Автоматизации.

Single Instance — для каждого клиентского соединения создается собственный экземпляр удаленного сервера Автоматизации в собственном процессе.

Multiple Instance — для каждого клиентского соединения создается собственный экземпляр удаленного сервера Автоматизации в одном общем процессе.

Список Threading Model задает механизм обработки запросов клиентов.

Single — поток запросов клиентов обрабатывается строго последовательно.

Apartment — модуль данных одновременно обрабатывает один запрос. Однако если DLL для выполнения запросов создает экземпляры СОМ объектов, то для запросов могут создаваться отдельные нити, в которых обработка ведется параллельно.

Free — модуль данных может создавать нити для параллельного выполнения запросов.

Both — аналогична модели Free, за исключением того, что все ответы клиентам возвращаются строго один за другим.

Neutral — запросы клиентов могут направляться модулям данных в нескольких нитях одновременно. Используется только для технологии СОМ+.

При создании нового удаленного модуля данных создается специальный класс — наследник класса TRemoteDataModule. И фабрика класса на основе класса TComponentFactory.

Класс TComponentFactory представляет собой фабрику класса для компонентов Delphi, инкапсулирующих интерфейсы. Поддерживает интерфейс IClass Factory.

Создадим, например, удаленный модуль данных simpleRDM. В мастере создания модуля данных в качестве способа создания выберем Single Instance, a Free — как модель обработки запросов.

Code: Type. TSimpleRDM = class(TRemoteDataModuie, ISimpleRDM). Private. Protected. Class procedure UpdateRegistry(Register: Boolean; const Classic, ProgID: string); override; Public. End; Implementation. {$R *.DFM}. Class procedure TSimpleRDM.UpdateRegistry(Register: Boolean; const. ClassID, ProgID: string); Begin. If Register then. Begin. Inherited UpdateRegistry(Register, Classic, ProgID); EnableSocketTransport(ClassID); EnableWebTransport(ClassID); End. Else. Begin. DisableSocketTransport(ClassID); DisableWebTransport(ClassID); Inherited UpdateRegistry(Register, ClassID, ProgID); End; End; Initialization. TComponentFactory.Create(ComServer, TSimpleRDM, Class_SimpleRDM, ciMultilnstance, tmApartment); End.

Как программно заставить выпасть меню?

Автор: InSAn.

В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. //Allow button to finish painting in response to the click. Application.ProcessMessages; {Alt Key Down}. Keybd_Event(VK_MENU, 0, 0, 0); {F Key Down - Drops the menu down}. Keybd_Event(ord('F'), 0, 0, 0); {F Key Up}. Keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0); {Alt Key Up}. Keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0); {F Key Down}. Keybd_Event(ord('S'), 0, 0, 0); {F Key Up}. Keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0); End;

©Drkb::01301.

Взято из http://forum.sources.ru.

Как узнать о нажатии non-menu клавиши в момент когда меню показано?

Автор: Arx ( http://arxoft.tora.ru ).

Создайте обработчик сообщения WM_MENUCHAR.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus; Type. TForm1 = class(TForm). MainMenu1: TMainMenu; One1: TMenuItem; Two1: TMenuItem; THree1: TMenuItem; Private. {Private declarations}. Procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR; Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WmMenuChar(var m : TMessage); Begin. Form1.Caption := 'Non standard menu key pressed'; M.Result := 1; End; End.

©Drkb::01302.

Взято из http://forum.sources.ru.

Как поместить TMenuItem справа у формы?

Допустим, у Вас есть TMainMenu MainMenu1 и HelpMenuItem в конце панели меню (Menubar). Если Вызвать следующий обработчик события OnCreate, то HelpMenuItem сместится вправо.

Code: Uses. Windows; Procedure TForm1.FormCreate(Sender: TObject); Begin. ModifyMenu(MainMenu1.Handle, 0, mf_ByPosition or mf_Popup. Or mf_Help, HelpMenuItem1.Handle, '&Help'); End;

©Drkb::01304.

Взято из http://forum.sources.ru.

Как заставить приложение показывать различные иконки при различных разрешениях дисплея?

Для этого достаточно текущее разрешение экрана и в соответствии с ним изменить дескриптор иконки приложения. Естевственно, что Вам прийдётся создать в ресурсах новые иконки.

Поместите следующий код в файл проекта (.DPR) Вашего приложения:

Code: Application.Initialize; Application.CreateForm(TForm1, Form1); Case GetDeviceCaps(GetDC(Form1.Handle), HORZRES) of. 640: Application.Icon.Handle := LoadIcon(hInstance, 'ICON640'); 800: Application.Icon.Handle := LoadIcon(hInstance, 'ICON800'); 1024: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1024'); 1280: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1280'); End; Application.Run;

Как сделать фон у текста прозрачным?

Для этого можно воспользоваться API функцией SetBkMode().

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. OldBkMode : integer; Begin. With Form1.Canvas do begin. Brush.Color := clRed; FillRect(Rect(0, 0, 100, 100)); Brush.Color := clBlue; TextOut(10, 20, 'Not Transparent!'); OldBkMode := SetBkMode(Handle, TRANSPARENT); TextOut(10, 50, 'Transparent!'); SetBkMode(Handle, OldBkMode); End; End;

Как читать/писать в I/O порты?

В Delphi 1 записывать и считывать из портов можно через глобальный массив 'ports'. Однако данная возможность отсутствует в '32-битном' Delphi.

Следующие две функции можно использовать в любой версии delphi:

Code: Function InPort(PortAddr:word): byte; {$IFDEF WIN32}. Assembler; stdcall; Asm. Mov dx,PortAddr. In al,dx. End; {$ELSE}. Begin. Result := Port[PortAddr]; End; {$ENDIF}. Procedure OutPort(PortAddr: Word; Databyte: byte); {$IFDEF WIN32}. Assembler; stdcall; Asm. Mov al,Databyte. Mov dx,PortAddr. Out dx,al. End; {$ELSE}. Begin. Port[PortAddr] := DataByte; End; {$ENDIF}.

©Drkb::01339.

Взято из http://forum.sources.ru.

Как прочитать байт из параллельного порта?

Первый способ:

Code: Var. BytesRead : BYTE; Begin. Asm \{ Читаем порт (LPT1) через встроенный ассемблер \}. MOV dx,$379; IN al,dx; MOV BytesRead,al; End; BytesRead:=(BytesRead OR $07); \{ OR а затем XOR данных \}. BytesRead:=(BytesRead XOR $80); \{ маскируем неиспользуемые биты \}.

Второй способ :

Используем команды Turbo Pascal ...

Code: Value:=port[$379]; \{ Прочитать из порта \}. Port[$379]:=value; \{ Записать в порт \}.

©Drkb::01340.

Взято из http://forum.sources.ru.

Как узнать адрес LPT-порта?

Эта функция работает в Win95 и Win98.

Code: Function GetPortAddress(PortNo: integer): word; assembler; stdcall; Asm. Push es. Push ebx. Mov ebx, PortNo. Shl ebx,1. Mov ax,40h // Dos segment adress. Mov es,ax. Mov ax,ES:[ebx+6] // get port adress in 16Bit way :). Pop ebx. Pop es. End;

Для NT можно заглянуть сюда: http://www.wideman-one.com/gw/tech/Delphi/iopm/index.htm.

©Drkb::01341.

Взято из http://forum.sources.ru.

Как программно установить конфигурацию COM-порта в Windows 95?

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. CommPort : string; HCommFile : THandle; Buffer : PCommConfig; Size : DWORD; Begin. CommPort := 'COM1'; {Открываем Com-порт}. HCommFile := CreateFile(PChar(CommPort), GENERIC_WRITE, 0, Nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); If hCommFile=INVALID_HANDLE_VALUE then. Begin. ShowMessage('Unable to open '+ CommPort); Exit; End; {Выделяем временный буфер}. GetMem(Buffer, sizeof(TCommConfig)); {Получаем размер структуры CommConfig}. Size := 0; GetCommConfig(hCommFile, Buffer^, size); {Освобождаем временный буфер}. FreeMem(Buffer, sizeof(TCommConfig)); {Выделяем память для структуры CommConfig}. GetMem(Buffer, size); GetCommConfig(hCommFile, Buffer^, size); {Изменяем скорость передачи}. Buffer^.dcb.BaudRate := 1200; {Устанавливаем новую конфигурацию для COM-порта}. SetCommConfig(hCommFile, Buffer^, size); {Освобождаем буфер}. FreeMem(Buffer, size); {Закрываем COM-порт}. CloseHandle(hCommFile); End;

©Drkb::01342.

Взято из http://forum.sources.ru.

Как узнать имена установленных в системе COM-портов?

Code: Uses Registry; Procedure TForm1.Button1Click(Sender: TObject); Var. Reg : TRegistry; Ts : TStrings; I : integer; Begin. Reg := TRegistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey('hardware\devicemap\serialcomm', False); Ts := TStringList.Create; Reg.GetValueNames(ts); For i := 0 to ts.Count -1 do begin. Memo1.Lines.Add(reg.ReadString(ts.Strings[i])); End; Ts.Free; Reg.CloseKey; Reg.free; End;

©Drkb::01343.

Взято из http://forum.sources.ru.

Клиент многозвенного распределенного приложения (статья).

Клиент многозвенного распределенного приложения.

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

Клиенты многозвенных приложений обеспечивают выполнение следующих функций:

· соединение с сервером приложений, прием и передача данных;

· отображение средствами пользовательского интерфейса;

· простейшие операции редактирования;

· сохранение локальных копий данных.

При разработке клиентских частей многозвенных приложений в Delphi используются компоненты DataSnap, а также компонент TClientoataSet, роль которого трудно переоценить.

Помимо новых компонентов в процессе разработки применяются стандартные компоненты отображения данных.

Структура клиентского приложения.

По своей структуре клиентское приложение подобно обычному приложению баз данных.

Соединение клиента с сервером приложений осуществляется специализированными компонентами DataSnap. Эти компоненты взаимодействуют с удаленным модулем данных, входящим в состав сервера, при помощи методов интерфейса IAppServer.

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

Внимание.

Соединение с сервером приложений обеспечивает динамическая библиотека MIDAS.DLL, которая должна быть зарегистрирована на компьютере клиента.

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

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

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

Примечание.

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

Для получения набора данных сервера компонент TclientDataSet взаимодействует с компонентом TDataSetProvider, используя методы интерфейса IProviderSupport (см. гл. 21).

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

Клиентские наборы данных.

В Палитре компонентов Delphi представлено несколько компонентов, инкапсулирующих клиентский набор данных. В то же время при разработке настоящих удаленных клиентских приложений применяется компонент TClientDataSet. Внесем ясность в этот вопрос. Итак, помимо компонента TClientDataSet, расположенного на странице Data Access, существуют еще два компонента:

TSimpleDataSet — разработан для технологии доступа к данным dbExpress и, по существу, является единственным полноценным средством для работы с набором данных в рамках этой технологии;

TiBdientDataSet — используется в технологии доступа к данным сервера InterBase — InterBase Express.

Все перечисленные компоненты произошли от общего предка — класса TCustomClientoataSet. Они обеспечивают локальное кэширование данных и взаимодействие с серверным набором данных при посредстве интерфейса IProviderSupport.

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

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

Для этого он имеет защищенное свойство.

Property Provider: TDataSetProvider;

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

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

Компонент TClientDataSet.

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

Получение данных от удаленного сервера и передача ему сделанных изменений с использованием удаленного компонента-провайдера;

Представление набора данных при помощи локального буфера и поддержка основных операций, унаследованных от класса TDataSet;

Объединение записей набора данных при помощи агрегатных функций для получения суммарных данных;

Локальное сохранение набора данных в файле и последующее восстановление набора данных из файла;

Представление набора данных в формате XML.

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

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

Как и обычный компонент, компонент TclientDataSet может использоваться совместно с визуальными компонентами отображения данных. Для этого нужен компонент TDataSource.

Рассмотрим основные функции, реализуемые компонентом TclientDataSet.

Получение данных от компонента - провайдера.

Компонент TClientDataSet получает доступ к удаленным данным через компонент соединения DataSnap (см. гл. 20). В зависимости от используемой технологии, это могут быть технологии TDCOMConnection, TSocketConnection, TWebConnection ИЛИ TCorbaConnection.

Компонент TClientDataSet связывается с компонентом соединения при помощи свойства.

Property RemoteServer: TCustomRemoteServer;

Если соединение настроено правильно, то ссылка на интерфейс IAppServer в свойстве.

Property AppServer: IAppServer;

Совпадает со свойством.

ClientDataSet.RemoteServer.AppServer;

После настройки соединения в свойстве property ProviderName: string;

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

Если провайдер был подключен правильно, свойство только для чтения.

Property HasAppServer: Boolean;

Автоматически принимает значение True.

Теперь компонент готов к приему данных. При использовании метода.

Procedure Open;

Или свойства.

Property Active: Boolean;

Компонент получает от провайдера первый пакет данных.

Размер пакета определяется свойством.

Property PacketRecords: Integer;

Которое задает число записей, передаваемое в одном пакете. Если свойство имеет значение —1 (это значение по умолчанию), передаются все записи набора данных. Если оно равно 0 — клиенту передаются только метаданные о наборе данных.

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

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

Function GetNextPacket: Integer;

Например, это можно сделать следующим образом:

Procedure TDataModulel.ClientDataSetAfterScroll(DataSet: TDataSet);

Begin.

If ClientDataSet.EOF then ClientDataSet.GetNextPacket;

End;

Свойство.

Property FetchOnDemand: Boolean;

Должно иметь значение False. При значении True оно разрешает компоненту получать новые пакеты данных по мере надобности, например, при необходимости прокрутки записей в компоненте TDBGrid.

До и после получения очередного пакета соответственно выполняются обработчики событий:

Type.

TRemoteEvent = procedure(Sender: TObject; var OwnerData: OleVariant) of object;

Property BeforeGetRecords: TRemoteEvent;

Property AfterGetRecords: TRemoteEvent;

Содержимое очередного пакета представлено свойством.

Property Data: OleVariant;

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

Var OwnerData: OleVariant;

MaxErrors, ErrorCount: Integer;

MaxErrors := 0;

ResultDataSet.Data := SourceDataSet.AppServer.AS_ApplyUpdates('', SourceDataSet.Delta, MaxErrors, ErrorCount, OwnerData);

Метод AS_AppiyUpdates передает данные, содержащиеся в буфере Delta, провайдеру на сервер и возвращает записи, сохранить которые не удалось.

Размер буфера Data в байтах возвращает свойство.

Property DataSize: Integer;

Кэширование и редактирование данных.

После получения записей от провайдера набор данных сохраняется в локальном буфере памяти. И все вносимые изменения после применения метода Post также сохраняются локально и не пересылаются на сервер. Буфер изменений доступен при помощи свойства.

Property Delta: OleVariant;

Для передачи изменений на сервер используется метод.

Function ApplyUpdates(MaxErrors: Integer); Integer; virtual;

Где параметр MaxErrors задает число ошибок, которые игнорируются при сохранении данных на сервере. Если параметр равен —1, сохранение на сервере прерывается при первой же ошибке. Метод возвращает число сохраненных записей.

После выполнения метода ApplyUpdates все записи, сохранить которые не удалось, возвращаются клиенту в локальный буфер Delta.

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

AfterPost:

Procedure TForml.ClientDataSetAfterPost(DataSet: TDataSet);

Begin.

ClientDataSet.ApplyUpdates(-1);

End;

Свойство только для чтения.

Property ChangeCount: Integer;

Возвращает общее число изменений, содержащееся в буфере Delta. Для очистки буфера изменений используется метод.

Procedure CancelUpdates;

После вызова метода свойство ChangeCount принимает значение 0.

До и после сохранения изменений на сервере соответственно вызываются методы-обработчики.

Property BeforeApplyUpdates: TRemoteEvent;

Property AfterApplyUpdates: TRemoteEvent;

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

Procedure RefreshRecord;

Получает от провайдера первоначальный вариант текущей записи, сохраненный на сервере.

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

Property BeforeRowRequest: TRemoteEvent;

Property AfterRowRequest: TRemoteEvent;

Но что делать, если необходимо восстановить удаленную запись? В обычном наборе данных после сохранения это невозможно. В компоненте TClientDataSet существует метод.

Function UndoLastChange(FollowChange: Boolean): Boolean;

Который возвращает набор данных к состоянию до последней выполненной операции редактирования, добавления или удаления записи. Если параметр FollowChange имеет значение True, курсор набора данных будет установлен на восстановленную запись.

О состоянии текущей записи позволяет судить метод.

Function UpdateStatus: TUpdateStatus; override;

Который возвращает значение типа.

TUpdateStatus = (usUnmodified, usModified, uslnserted, usDeleted);

Означающее состояние текущей записи:

UsUnmodified — запись осталась неизменной;

UsModified — запись была изменена;

Uslnserted — запись была добавлена;

UsDeleted — запись была удалена.

Например, при закрытии набора данных можно выполнить проверку:

If ClientDataSet.UpdateStatus = usModified then ShowMessage('Record was changed');

На основе типа можно управлять видимостью записей в наборе данных. Свойство.

Property StatusFilter: TUpdateStatusSet;

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

ClientDataSet.StatusFilter := usDeleted;

Отобразит в наборе данных только удаленные записи (при этом изменения не сохранены на сервере).

Управление запросом на сервере.

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

Свойство.

Property CornmandText: string;

Содержит текст запроса SQL, имя таблицы или хранимой процедуры в зависимости от типа серверного компонента.

Изменив значение этого свойства на клиенте, можно, например, модифицировать запрос SQL на сервере. Но для этого в свойстве Options соответствующего компонента-провайдера TDataSetProvider должно быть установлено значение.

PoAliowCommandText := True;

Новое значение свойства CommandText отправляется на сервер только после открытия клиентского набора данных или выполнения метода.

Procedure Execute; virtual;

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

Property Params: TParams;

До выполнения запроса присваиваются значения входным параметрам. После выполнения хранимой процедуры в выходных параметрах размещаются полученные от сервера значения.

Обратите внимание, что при выполнении запросов или хранимых процедур может измениться порядок следования параметров. Поэтому обращаться к параметрам желательно по их именам. Например, так:

Editl.Text := ClientDataSet.Params .ParamByName('OutputParam') .AsString;

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

Procedure FetchParams;

Перед и после получения параметров от провайдера, клиентский набор данных вызывает методы-обработчики событий:

Property BeforeGetParams: TRemoteEvent;

Property AfterGetParams: TRemoteEvent;

Использование индексов.

Обычно использование индексов — прерогатива сервера БД. Из компонентов Delphi только табличные компоненты могут в какой-то степени управлять использованием индексов. Очевидно, что удаленное соединение не способствует эффективному управлению индексами набора данных на сервере. Поэтому компонент TclientDataSet предоставляет разработчику возможность создавать и использовать локальные индексы.

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

Для создания локального индекса используется метод.

Procedure Addlndex(const Name, Fields: string; Options: TIndexOptions;

Const DescFields: string = '';

Const CaselnsFields: string = '';

Const GroupingLevel: Integer = 0);

Параметр Name определяет имя нового индекса. Параметр Fields должен содержать имена полей, которые разработчик хочет включить в индекс. Имена полей должны разделяться точкой с запятой. Параметр options позволяет задать тип индекса:

TIndexOption = (ixPrimary, ixUnique, ixDescending, ixCaselnsensitive, ixExpression, ixNonMaintained);

TIndexOptions = set of TIndexOption;

IxPrimary — первичный индекс;

IxUnique — значения индекса уникальны;

IxDescending — индекс сортирует записи в обратном порядке;

IxCaselnsensitive — индекс сортирует записи без учета регистра символов;

IxExpression — в индексе используется выражение (для индексов dBASE);

IxNonMaintained — индекс не обновляется при открытии таблицы.

При этом можно задать поля, порядок сортировки которых будет обратным. Для этого их необходимо перечислить через точку с запятой в параметре DescFields. Параметр CaselnsFields аналогичным образом позволяет задать поля, на сортировку которых не влияет регистр символов.

Параметры DescFields и CaselnsFields используются вместо параметра Options.

Параметр GroupingLevel задает уровень группировки полей индекса. Подробнее об этом см. ниже в разд. "Агрегаты" этой главы.

Основные свойства компонента, обеспечивающие управление индексами, совпадают с аналогичными свойствами табличных компонентов (подробнее об этом см. гл. 12). Поэтому лишь кратко перечислим их.

При работе с компонентом разработчик имеет возможность управлять индексами.

Созданный индекс подключается к набору данных свойством.

Property IndexName: String;

Которое должно включать имя индекса или использовать свойство.

Property IndexFieldNames: String;

В котором можно задать произвольное сочетание имен индексированных полей таблицы. Имена полей разделяются точкой с запятой. Свойства IndexName и IndexFieldNames нельзя использовать одновременно.

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

Property IndexFieldCount: Integer;

Свойство.

Property IndexFields: [Index: Integer]: TField;

Представляет собой индексированный список полей, входящих в текущий индекс.

Параметры созданных индексов доступны в свойстве.

Property IndexDefs: TIndexDefs;

Класс TIndexDefs подробно рассматривается в гл. 12.

После создания и подключения индекса записи набора данных "переупорядочиваются" в соответствии со значениями индексированных долей.

Удаление локального индекса обеспечивает метод.

Procedure Deletelndex(const Name: string);

После удаления текущего индекса или его отмены (обнуления свойства IndexName) записи набора данных "переупорядочиваются" в исходном порядке, соответствующем порядку записей набора данных на сервере.

Имена всех существующих в наборе данных индексов можно загрузить в список при помощи метода.

Procedure GetlndexNames(List: TStrings);

Например:

Memol.Lines.Clear;

ClientDataSet.GetlndexNames(Memol.Lines);

Сохранение набора данных в файлах.

Клиентское приложение может использовать одну очень удобную функцию компонента TClientDataSet. Представим, что соединение между сервером и клиентом обладает малой пропускной способностью и к тому же часто обрывается. Что в этом случае делать пользователю, который внес много изменений и не может сохранить их на сервере?

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

Для сохранения данных (по существу это буфер Data) в файле используется метод.

Procedure SaveToFile(const FileName: string = ''; Format: TDataPacketFormat=dfBinary);

Причем, если параметр FileName пуст, имя файла берется из свойства.

Property FileName: string;

Также можно передать данные в поток:

Procedure SaveToStream(Stream: TStream; Format: TDataPacketFormat=dfBinary);

Формат, в котором данные будут сохранены, определяется параметром.

Format!

Type TDataPacketFormat = (dfBinary, dfXML, dfXMLUTFS);

Где dfBinary — бинарный вид, dfXML — формат XML, dfXMLUTFS — формат XML в кодировке UTF8.

Обратная загрузка данных, соответственно, выполняется методами:

Procedure LoadFromFile(const FileName: string = '');

И.

Procedure LoadFromStreamfStream: TStream);

После загрузки набор данных полностью готов к работе:

If LoadFileDialog.Execute then.

Begin.

ClientDataSet.LoadFromFile(LoadFileDialog.FileName);

ClientDataSet.Open;

End;

Работа с данными типа BLOB.

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

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

В компоненте TCHentDataSet процессом передачи полей типа BLOB можно управлять, используя свойство.

Property FetchOnDemand: Boolean;

По умолчанию оно равно значению True и клиентский набор данных "выкачивает" данные BLOB по мере необходимости автоматически. Это означает, что приложение будет останавливаться и заново получать данные при любом просмотре данных, прокрутке и т. д. Если свойство имеет значение False, для получения данных клиент должен явно вызвать метод.

Procedure FetchBlobs;

Но, кроме этого, в свойстве options компонента-провайдера TDataSetProvider обязательно должно быть установлено значение:

PoFetchBlobsOnDemand := True;

Представление данных в формате XML.

Набор данных клиента легко можно представить в формате XML. Для этого достаточно использовать свойство.

Property XMLData: OleVariant;

Которое возвращает данные, содержащиеся в буфере Data (см. выше) в бинарном виде, в формате XML.

Например, клиентский набор данных можно сохранить в файле формата XML:

Code: If SaveDialog.Execute then. With TFileStream.Create(SaveDialog.FileName, fmCreate) do. Try. Write(Pointer(ClientDataSet.XMLData)^, Length(ClientDataSet.XMLData)); Finally. Free ; End;

Как узнать, есть ли в приёмном буфере RS232 данные?

При помощи функции ClearCommError можно узнать, сколько байт данных находится в буфере приёма (и буфере передачи) последовательного интерфейса.

Code: Procedure DataInBuffer(Handle: THandle; Var InQueue, OutQueue: integer); Var ComStat: TComStat; E: integer; Begin. If ClearCommError(Handle, e, @ComStat) then. Begin. InQueue := ComStat.cbInQue; OutQueue := ComStat.cbOutQue; End. Else. Begin. InQueue := 0; OutQueue := 0; End; End;

©Drkb::01344.

Взято из http://forum.sources.ru.

Компонент для последовательного устройства (TRS232).

Компонент, который представлен здесь, выполняет функции синхронного чтения и записи в последовательный интерфейс RS232.

В цикле выполняется Application.ProcessMessages, чтобы все сообщения от основной программы обрабатывались.

Code: // ---------------------------------------------------------------------- // | RS232 - Basic Driver for the RS232 port 1.0 | // ---------------------------------------------------------------------- // | © 1997 by Marco Cocco | // | © 1998 by enhanced by Angerer Bernhard | // ---------------------------------------------------------------------- Unit uRS232; Interface. Uses. Windows, Messages, SysUtils, Classes, Forms, ExtCtrls; // TTimer. //////////////////////////////////////////////////////////////////////////////// Type. TReceiveDataEvent = procedure(Sender: TObject; Msg, lParam, wParam:longint) of object; // COM Port Baud Rates. TComPortBaudRate = ( br110, br300, br600, br1200, br2400, br4800, Br9600, br14400, br19200, br38400, br56000, Br57600, br115200 ); // COM Port Numbers. TComPortNumber = ( pnCOM1, pnCOM2, pnCOM3, pnCOM4 ); // COM Port Data bits. TComPortDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS ); // COM Port Stop bits. TComPortStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS ); // COM Port Parity. TComPortParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE ); // COM Port Hardware Handshaking. TComPortHwHandshaking = ( hhNONE, hhRTSCTS ); // COM Port Software Handshaing. TComPortSwHandshaking = ( shNONE, shXONXOFF ); TCommPortDriver = class(TComponent). Private. HTimer: TTimer; FActive: boolean; Procedure SetActive(const Value: boolean); Protected. FComPortHandle : THANDLE; // COM Port Device Handle. FComPort : TComPortNumber; // COM Port to use (1..4). FComPortBaudRate : TComPortBaudRate; // COM Port speed (brXXXX). FComPortDataBits : TComPortDataBits; // Data bits size (5..8). FComPortStopBits : TComPortStopBits; // How many stop bits to use. // (1,1.5,2). FComPortParity : TComPortParity; // Type of parity to use. // (none,odd,even,mark,space). FComPortHwHandshaking : TComPortHwHandshaking; // Type of hw. // handshaking to use. FComPortSwHandshaking : TComPortSwHandshaking; // Type of sw. // handshaking to use. FComPortInBufSize : word; // Size of the input buffer. FComPortOutBufSize : word; // Size of the output buffer. FComPortReceiveData : TReceiveDataEvent; FComPortPollingDelay : word; // ms of delay between COM port pollings. FTimeOut : integer; // sec until timeout. FTempInBuffer : pointer; Procedure SetComPort( Value: TComPortNumber ); Procedure SetComPortBaudRate( Value: TComPortBaudRate ); Procedure SetComPortDataBits( Value: TComPortDataBits ); Procedure SetComPortStopBits( Value: TComPortStopBits ); Procedure SetComPortParity( Value: TComPortParity ); Procedure SetComPortHwHandshaking( Value: TComPortHwHandshaking ); Procedure SetComPortSwHandshaking( Value: TComPortSwHandshaking ); Procedure SetComPortInBufSize( Value: word ); Procedure SetComPortOutBufSize( Value: word ); Procedure SetComPortPollingDelay( Value: word ); Procedure ApplyCOMSettings; Procedure TimerEvent(Sender: TObject); virtual; Public. Constructor Create( AOwner: TComponent ); override; Destructor Destroy; override; Function Connect: boolean; //override; Function Disconnect: boolean; //override; Function Connected: boolean; Function SendData( DataPtr: pointer; DataSize: integer ): boolean; Function SendString( aStr: string ): boolean; // Event to raise when there is data available (input buffer has data). Property OnReceiveData: TReceiveDataEvent read FComPortReceiveData. Write FComPortReceiveData; Published. // Which COM Port to use. Property ComPort: TComPortNumber read FComPort write SetComPort. Default pnCOM2; // COM Port speed (bauds). Property ComPortSpeed: TComPortBaudRate read FComPortBaudRate. Write SetComPortBaudRate default br9600; // Data bits to used (5..8, for the 8250 the use of 5 data bits with 2 stop. // bits is an invalid combination, as is 6, 7, or 8 data bits with 1.5. // stop bits). Property ComPortDataBits: TComPortDataBits read FComPortDataBits. Write SetComPortDataBits default db8BITS; // Stop bits to use (1, 1.5, 2). Property ComPortStopBits: TComPortStopBits read FComPortStopBits. Write SetComPortStopBits default sb1BITS; // Parity Type to use (none,odd,even,mark,space). Property ComPortParity: TComPortParity read FComPortParity. Write SetComPortParity default ptNONE; // Hardware Handshaking Type to use: // cdNONE no handshaking. // cdCTSRTS both cdCTS and cdRTS apply (This is the more common method). Property ComPortHwHandshaking: TComPortHwHandshaking. Read FComPortHwHandshaking write SetComPortHwHandshaking default hhNONE; // Software Handshaking Type to use: // cdNONE no handshaking. // cdXONXOFF XON/XOFF handshaking. Property ComPortSwHandshaking: TComPortSwHandshaking. Read FComPortSwHandshaking write SetComPortSwHandshaking default shNONE; // Input Buffer size. Property ComPortInBufSize: word read FComPortInBufSize. Write SetComPortInBufSize default 2048; // Output Buffer size. Property ComPortOutBufSize: word read FComPortOutBufSize. Write SetComPortOutBufSize default 2048; // ms of delay between COM port pollings. Property ComPortPollingDelay: word read FComPortPollingDelay. Write SetComPortPollingDelay default 100; Property TimeOut: integer read FTimeOut write FTimeOut default 30; Property Active: boolean read FActive write SetActive default false; End; TRS232 = class(TCommPortDriver). Protected. Public. // new comm parameters are set. Constructor Create( AOwner: TComponent ); override; // ReadStrings reads direct from the comm-buffer and waits for. // more characters and handles the timeout. Function ReadString(var aResStr: string; aCount: word ): boolean; Published. End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Additional', [TRS232]); End; Constructor TCommPortDriver.Create( AOwner: TComponent ); Begin. Inherited Create( AOwner ); // Initialize to default values. FComPortHandle := 0; // Not connected. FComPort := pnCOM2; // COM 2. FComPortBaudRate := br9600; // 9600 bauds. FComPortDataBits := db8BITS; // 8 data bits. FComPortStopBits := sb1BITS; // 1 stop bit. FComPortParity := ptNONE; // no parity. FComPortHwHandshaking := hhNONE; // no hardware handshaking. FComPortSwHandshaking := shNONE; // no software handshaking. FComPortInBufSize := 2048; // input buffer of 512 bytes. FComPortOutBufSize := 2048; // output buffer of 512 bytes. FComPortReceiveData := nil; // no data handler. FTimeOut := 30; // sec until timeout. FComPortPollingDelay := 500; GetMem( FTempInBuffer, FComPortInBufSize ); // Temporary buffer. // for received data. // Timer for teaching and messages. HTimer := TTimer.Create(Self); HTimer.Enabled := false; HTimer.Interval := 500; HTimer.OnTimer := TimerEvent; If ComponentState = [csDesigning] then. EXIT; If FActive then. HTimer.Enabled := true; // start the timer only at application start. End; Destructor TCommPortDriver.Destroy; Begin. // Be sure to release the COM device. Disconnect; // Free the temporary buffer. FreeMem( FTempInBuffer, FComPortInBufSize ); // Destroy the timer's window. Inherited Destroy; End; Procedure TCommPortDriver.SetComPort( Value: TComPortNumber ); Begin. // Be sure we are not using any COM port. If Connected then. Exit; // Change COM port. FComPort := Value; End; Procedure TCommPortDriver.SetComPortBaudRate( Value: TComPortBaudRate ); Begin. // Set new COM speed. FComPortBaudRate := Value; // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortDataBits( Value: TComPortDataBits ); Begin. // Set new data bits. FComPortDataBits := Value; // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortStopBits( Value: TComPortStopBits ); Begin. // Set new stop bits. FComPortStopBits := Value; // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortParity( Value: TComPortParity ); Begin. // Set new parity. FComPortParity := Value; // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortHwHandshaking(Value: TComPortHwHandshaking); Begin. // Set new hardware handshaking. FComPortHwHandshaking := Value; // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortSwHandshaking(Value: TComPortSwHandshaking); Begin. // Set new software handshaking. FComPortSwHandshaking := Value; // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortInBufSize( Value: word ); Begin. // Free the temporary input buffer. FreeMem( FTempInBuffer, FComPortInBufSize ); // Set new input buffer size. FComPortInBufSize := Value; // Allocate the temporary input buffer. GetMem( FTempInBuffer, FComPortInBufSize ); // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortOutBufSize( Value: word ); Begin. // Set new output buffer size. FComPortOutBufSize := Value; // Apply changes. If Connected then. ApplyCOMSettings; End; Procedure TCommPortDriver.SetComPortPollingDelay( Value: word ); Begin. FComPortPollingDelay := Value; HTimer.Interval := Value; End; Const. Win32BaudRates: array[br110..br115200] of DWORD = ( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200 ); Const. Dcb_Binary = $00000001; Dcb_ParityCheck = $00000002; Dcb_OutxCtsFlow = $00000004; Dcb_OutxDsrFlow = $00000008; Dcb_DtrControlMask = $00000030; Dcb_DtrControlDisable = $00000000; Dcb_DtrControlEnable = $00000010; Dcb_DtrControlHandshake = $00000020; Dcb_DsrSensivity = $00000040; Dcb_TXContinueOnXoff = $00000080; Dcb_OutX = $00000100; Dcb_InX = $00000200; Dcb_ErrorChar = $00000400; Dcb_NullStrip = $00000800; Dcb_RtsControlMask = $00003000; Dcb_RtsControlDisable = $00000000; Dcb_RtsControlEnable = $00001000; Dcb_RtsControlHandshake = $00002000; Dcb_RtsControlToggle = $00003000; Dcb_AbortOnError = $00004000; Dcb_Reserveds = $FFFF8000; // Apply COM settings. Procedure TCommPortDriver.ApplyCOMSettings; Var dcb: TDCB; Begin. // Do nothing if not connected. If not Connected then. Exit; // Clear all. Fillchar( dcb, sizeof(dcb), 0 ); // Setup dcb (Device Control Block) fields. Dcb.DCBLength := sizeof(dcb); // dcb structure size. Dcb.BaudRate := Win32BaudRates[ FComPortBaudRate ]; // baud rate to use. Dcb.Flags := dcb_Binary or // Set fBinary: Win32 does not support non. // binary mode transfers. // (also disable EOF check). Dcb_RtsControlEnable; // Enables the RTS line when the device. // is opened and leaves it on. // dcb_DtrControlEnable; // Enables the DTR line when the device. // is opened and leaves it on. Case FComPortHwHandshaking of // Type of hw handshaking to use. HhNONE:; // No hardware handshaking. HhRTSCTS: // RTS/CTS (request-to-send/clear-to-send) hardware handshaking. Dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake; End; Case FComPortSwHandshaking of // Type of sw handshaking to use. ShNONE:; // No software handshaking. ShXONXOFF: // XON/XOFF handshaking. Dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX; End; Dcb.XONLim := FComPortInBufSize div 4; // Specifies the minimum number. // of bytes allowed. // in the input buffer before the. // XON character is sent. Dcb.XOFFLim := 1; // Specifies the maximum number of bytes allowed in the. // input buffer before the XOFF character is sent. // The maximum number of bytes allowed is calculated by. // subtracting this value from the size, in bytes, // of the input buffer. Dcb.ByteSize := 5 + ord(FComPortDataBits); // how many data bits to use. Dcb.Parity := ord(FComPortParity); // type of parity to use. Dcb.StopBits := ord(FComPortStopbits); // how many stop bits to use. Dcb.XONChar := #17; // XON ASCII char. Dcb.XOFFChar := #19; // XOFF ASCII char. SetCommState( FComPortHandle, dcb ); // Setup buffers size. SetupComm( FComPortHandle, FComPortInBufSize, FComPortOutBufSize ); End; Function TCommPortDriver.Connect: boolean; Var comName: array[0..4] of char; Tms: TCOMMTIMEOUTS; Begin. // Do nothing if already connected. Result := Connected; If Result then exit; // Open the COM port. StrPCopy( comName, 'COM' ); ComName[3] := chr( ord('1') + ord(FComPort) ); ComName[4] := #0; FComPortHandle := CreateFile( ComName, GENERIC_READ or GENERIC_WRITE, 0, // Not shared. Nil, // No security attributes. OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 // No template. ) ; Result := Connected; If not Result then exit; // Apply settings. ApplyCOMSettings; // Setup timeouts: we disable timeouts because we are polling the com port! Tms.ReadIntervalTimeout := 1; // Specifies the maximum time, in milliseconds, // allowed to elapse between the arrival of two. // characters on the communications line. Tms.ReadTotalTimeoutMultiplier := 0; // Specifies the multiplier, in. // milliseconds, used to calculate. // the total time-out period. // for read operations. Tms.ReadTotalTimeoutConstant := 1; // Specifies the constant, in milliseconds, // used to calculate the total time-out. // period for read operations. Tms.WriteTotalTimeoutMultiplier := 0; // Specifies the multiplier, in. // milliseconds, used to calculate. // the total time-out period. // for write operations. Tms.WriteTotalTimeoutConstant := 0; // Specifies the constant, in. // milliseconds, used to calculate. // the total time-out period. // for write operations. SetCommTimeOuts( FComPortHandle, tms ); Sleep(1000); // to avoid timing problems, wait until the Comm-Port is opened. End; Function TCommPortDriver.Disconnect: boolean; Begin. Result:=false; If Connected then. Begin. CloseHandle( FComPortHandle ); FComPortHandle := 0; End; Result := true; End; Function TCommPortDriver.Connected: boolean; Begin. Result := FComPortHandle > 0; End; Function TCommPortDriver.SendData(DataPtr: pointer; DataSize: integer): boolean; Var nsent: DWORD; Begin. Result := WriteFile( FComPortHandle, DataPtr^, DataSize, nsent, nil ); Result := Result and (nsent=DataSize); End; Function TCommPortDriver.SendString( aStr: string ): boolean; Begin. If not Connected then. If not Connect then raise Exception.CreateHelp('RS232.SendString:'+ ' Connect not possible !', 101); Result:=SendData( pchar(aStr), length(aStr) ); If not Result then raise. Exception.CreateHelp('RS232.SendString: Send not possible !', 102); End; // Event for teaching and messages. Procedure TCommPortDriver.TimerEvent(Sender: TObject); Var InQueue, OutQueue: integer; // Test if data in inQueue(outQueue). Procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: integer); Var ComStat: TComStat; E: cardinal; Begin. AInQueue := 0; AOutQueue := 0; If ClearCommError(Handle, e, @ComStat) then. Begin. AInQueue := ComStat.cbInQue; AOutQueue := ComStat.cbOutQue; End; End; Begin. If not Connected then. If not Connect then raise Exception.CreateHelp('RS232.TimerEvent:'+ ' Connect not possible !', 101); If Connected then. Begin. DataInBuffer(FComPortHandle, InQueue, OutQueue); // data in inQueue. If InQueue > 0 then. If Assigned(FComPortReceiveData) then FComPortReceiveData(Self , 0, 0, 0); End; End; // RS232 implementation //////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// Constructor TRS232.Create( AOwner: TComponent ); Begin. Inherited Create( AOwner ); //OnReceiveData := ReceiveData; FComPort := pnCOM1; // COM 1. FComPortBaudRate := br9600; // 9600 bauds. FComPortDataBits := db8BITS; // 8 data bits. FComPortStopBits := sb1BITS; // 1 stop bits. FComPortParity := ptEVEN; // even parity. FComPortHwHandshaking := hhNONE; // no hardware handshaking. FComPortSwHandshaking := shNONE; // no software handshaking. FComPortInBufSize := 2048; // input buffer of 512 ? bytes. FComPortOutBufSize := 2048; // output buffer of 512 ? bytes. FTimeOut := 30; // sec until timeout. End; Function TRS232.ReadString(VAR aResStr: string; aCount: word ): boolean; Var. NRead: dword; Buffer: string; Actual, Before: TDateTime; TimeOutMin, TimeOutSec, lCount: word; Begin. Result := false; If not Connected then. If not Connect then raise Exception.CreateHelp('RS232.ReadString:'+ ' Connect not possible !', 101); AResStr := ''; TimeOutMin:=TimeOut div 60; TimeOutSec:=TimeOut mod 60; If (not Connected) or (aCount <= 0) then EXIT; NRead := 0; lCount := 0; Before := Time; While lCount<aCount do. Begin. Application.ProcessMessages; SetLength(Buffer,1); If ReadFile( FComPortHandle, PChar(Buffer)^, 1, nRead, nil ) then. Begin. If nRead > 0 then. Begin. AResStr := aResStr + Buffer; Inc(lCount); End; Actual := Time; If Actual-Before>EncodeTime(0, TimeOutMin, TimeOutSec, 0). Then raise Exception.CreateHelp('RS232.ReadString: TimeOut !', 103); End. Else begin. Raise Exception.CreateHelp('RS232.ReadString: Read not possible !', 104); End; End; // while. Result:=true; End; [OBJECT]{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J+,K-,L-,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}. {$MINSTACKSIZE $00004000}. {$MAXSTACKSIZE $00100000}. {$IMAGEBASE $51000000}. {$APPTYPE GUI}. Unit ComportDriverThread; Interface. Uses. //Include "ExtCtrl" for the TTimer component. Windows, Messages, SysUtils, Classes, Forms, ExtCtrls; Type. TComPortNumber = (pnCOM1,pnCOM2,pnCOM3,pnCOM4); TComPortBaudRate = (br110,br300,br600,br1200,br2400,br4800,br9600, Br14400,br19200,br38400,br56000,br57600,br115200); TComPortDataBits = (db5BITS,db6BITS,db7BITS,db8BITS); TComPortStopBits = (sb1BITS,sb1HALFBITS,sb2BITS); TComPortParity = (ptNONE,ptODD,ptEVEN,ptMARK,ptSPACE); TComportHwHandshaking = (hhNONE,hhRTSCTS); TComPortSwHandshaking = (shNONE,shXONXOFF); TTimerThread = class(TThread). Private. { Private declarations }. FOnTimer : TThreadMethod; FEnabled: Boolean; Protected. { Protected declarations }. Procedure Execute; override; Procedure SupRes; Public. { Public declarations }. Published. { Published declarations }. Property Enabled: Boolean read FEnabled write FEnabled; End; TComportDriverThread = class(TComponent). Private. { Private declarations }. FTimer : TTimerThread; FOnReceiveData : TNotifyEvent; FReceiving : Boolean; Protected. { Protected declarations }. FComPortActive : Boolean; FComportHandle : THandle; FComportNumber : TComPortNumber; FComportBaudRate : TComPortBaudRate; FComportDataBits : TComPortDataBits; FComportStopBits : TComPortStopBits; FComportParity : TComPortParity; FComportHwHandshaking : TComportHwHandshaking; FComportSwHandshaking : TComPortSwHandshaking; FComportInputBufferSize : Word; FComportOutputBufferSize : Word; FComportPollingDelay : Word; FTimeOut : Integer; FTempInputBuffer : Pointer; Procedure SetComPortActive(Value: Boolean); Procedure SetComPortNumber(Value: TComPortNumber); Procedure SetComPortBaudRate(Value: TComPortBaudRate); Procedure SetComPortDataBits(Value: TComPortDataBits); Procedure SetComPortStopBits(Value: TComPortStopBits); Procedure SetComPortParity(Value: TComPortParity); Procedure SetComPortHwHandshaking(Value: TComportHwHandshaking); Procedure SetComPortSwHandshaking(Value: TComPortSwHandshaking); Procedure SetComPortInputBufferSize(Value: Word); Procedure SetComPortOutputBufferSize(Value: Word); Procedure SetComPortPollingDelay(Value: Word); Procedure ApplyComPortSettings; Procedure TimerEvent; virtual; Procedure doDataReceived; virtual; Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; Function Connect: Boolean; Function Disconnect: Boolean; Function Connected: Boolean; Function Disconnected: Boolean; Function SendData(DataPtr: Pointer; DataSize: Integer): Boolean; Function SendString(Input: String): Boolean; Function ReadString(var Str: string): Integer; Published. { Published declarations }. Property Active: Boolean read FComPortActive write SetComPortActive default False; Property ComPort: TComPortNumber read FComportNumber write SetComportNumber. Default pnCOM1; Property ComPortSpeed: TComPortBaudRate read FComportBaudRate write. SetComportBaudRate default br9600; Property ComPortDataBits: TComPortDataBits read FComportDataBits write. SetComportDataBits default db8BITS; Property ComPortStopBits: TComPortStopBits read FComportStopBits write. SetComportStopBits default sb1BITS; Property ComPortParity: TComPortParity read FComportParity write. SetComportParity default ptNONE; Property ComPortHwHandshaking: TComportHwHandshaking read FComportHwHandshaking. Write SetComportHwHandshaking default. HhNONE; Property ComPortSwHandshaking: TComPortSwHandshaking read FComportSwHandshaking. Write SetComportSwHandshaking default. ShNONE; Property ComPortInputBufferSize: Word read FComportInputBufferSize. Write SetComportInputBufferSize default. 2048; Property ComPortOutputBufferSize: Word read FComportOutputBufferSize. Write SetComportOutputBufferSize default. 2048; Property ComPortPollingDelay: Word read FComportPollingDelay write. SetComportPollingDelay default 100; Property OnReceiveData: TNotifyEvent read FOnReceiveData. Write FOnReceiveData; Property TimeOut: Integer read FTimeOut write FTimeOut default 30; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Self-made Components', [TComportDriverThread]); End; { TComportDriver }. Constructor TComportDriverThread.Create(AOwner: TComponent); Begin. Inherited; FReceiving := False; FComportHandle := 0; FComportNumber := pnCOM1; FComportBaudRate := br9600; FComportDataBits := db8BITS; FComportStopBits := sb1BITS; FComportParity := ptNONE; FComportHwHandshaking := hhNONE; FComportSwHandshaking := shNONE; FComportInputBufferSize := 2048; FComportOutputBufferSize := 2048; FOnReceiveData := nil; FTimeOut := 30; FComportPollingDelay := 500; GetMem(FTempInputBuffer,FComportInputBufferSize); If csDesigning in ComponentState then. Exit; FTimer := TTimerThread.Create(False); FTimer.FOnTimer := TimerEvent; If FComPortActive then. FTimer.Enabled := True; FTimer.SupRes; End; Destructor TComportDriverThread.Destroy; Begin. Disconnect; FreeMem(FTempInputBuffer,FComportInputBufferSize); Inherited Destroy; End; Function TComportDriverThread.Connect: Boolean; Var. ComName: array[0..4] of Char; Tms: TCommTimeouts; Begin. If Connected then. Exit; StrPCopy(comName,'COM'); ComName[3] := chr(ord('1') + ord(FComportNumber)); ComName[4] := #0; FComportHandle := CreateFile(comName,GENERIC_READ OR GENERIC_WRITE,0,nil, OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0); If not Connected then. Exit; ApplyComPortSettings; Tms.ReadIntervalTimeout := 1; Tms.ReadTotalTimeoutMultiplier := 0; Tms.ReadTotalTimeoutConstant := 1; Tms.WriteTotalTimeoutMultiplier := 0; Tms.WriteTotalTimeoutConstant := 0; SetCommTimeouts(FComportHandle,tms); Sleep(1000); End; Function TComportDriverThread.Connected: Boolean; Begin. Result := FComportHandle > 0; End; Function TComportDriverThread.Disconnect: Boolean; Begin. Result := False; If Connected then. Begin. CloseHandle(FComportHandle); FComportHandle := 0; End; Result := True; End; Function TComportDriverThread.Disconnected: Boolean; Begin. If (FComportHandle <> 0) then. Result := False. Else. Result := True; End; Const. Win32BaudRates: array[br110..br115200] of DWORD = (CBR_110,CBR_300,CBR_600,CBR_1200,CBR_2400,CBR_4800,CBR_9600,CBR_14400, CBR_19200,CBR_38400,CBR_56000,CBR_57600,CBR_115200); Const. Dcb_Binary = $00000001; Dcb_ParityCheck = $00000002; Dcb_OutxCtsFlow = $00000004; Dcb_OutxDsrFlow = $00000008; Dcb_DtrControlMask = $00000030; Dcb_DtrControlDisable = $00000000; Dcb_DtrControlEnable = $00000010; Dcb_DtrControlHandshake = $00000020; Dcb_DsrSensitvity = $00000040; Dcb_TXContinueOnXoff = $00000080; Dcb_OutX = $00000100; Dcb_InX = $00000200; Dcb_ErrorChar = $00000400; Dcb_NullStrip = $00000800; Dcb_RtsControlMask = $00003000; Dcb_RtsControlDisable = $00000000; Dcb_RtsControlEnable = $00001000; Dcb_RtsControlHandshake = $00002000; Dcb_RtsControlToggle = $00003000; Dcb_AbortOnError = $00004000; Dcb_Reserveds = $FFFF8000; Procedure TComportDriverThread.ApplyComPortSettings; Var. //Device Control Block (= dcb). Dcb: TDCB; Begin. If not Connected then. Exit; FillChar(dcb,sizeOf(dcb),0); Dcb.DCBlength := sizeOf(dcb); Dcb.Flags := dcb_Binary or dcb_RtsControlEnable; Dcb.BaudRate := Win32BaudRates[FComPortBaudRate]; Case FComportHwHandshaking of. HhNONE : ; HhRTSCTS: Dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake; End; Case FComportSwHandshaking of. ShNONE : ; ShXONXOFF: Dcb.Flags := dcb.Flags or dcb_OutX or dcb_Inx; End; Dcb.XonLim := FComportInputBufferSize div 4; Dcb.XoffLim := 1; Dcb.ByteSize := 5 + ord(FComportDataBits); Dcb.Parity := ord(FComportParity); Dcb.StopBits := ord(FComportStopBits); Dcb.XonChar := #17; Dcb.XoffChar := #19; SetCommState(FComportHandle,dcb); SetupComm(FComportHandle,FComPortInputBufferSize,FComPortOutputBufferSize); End; Function TComportDriverThread.ReadString(var Str: string): Integer; Var. BytesTrans, nRead: DWORD; Buffer : String; I : Integer; Temp : string; Begin. BytesTrans := 0; Str := ''; SetLength(Buffer,1); ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil); While nRead > 0 do. Begin. Temp := temp + PChar(Buffer); ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil); End; //Remove the end token. BytesTrans := Length(temp); SetLength(str,BytesTrans-2); For i:=0 to BytesTrans-2 do. Begin. Str[i] := temp[i]; End; Result := BytesTrans; End; Function TComportDriverThread.SendData(DataPtr: Pointer; DataSize: Integer): Boolean; Var. Nsent : DWORD; Begin. Result := WriteFile(FComportHandle,DataPtr^,DataSize,nsent,nil); Result := Result and (nsent = DataSize); End; Function TComportDriverThread.SendString(Input: String): Boolean; Begin. If not Connected then. If not Connect then. Raise Exception.CreateHelp('Could not connect to COM-port !',101); Result := SendData(PChar(Input),Length(Input)); If not Result then. Raise Exception.CreateHelp('Could not send to COM-port !',102); End; Procedure TComportDriverThread.TimerEvent; Var. InQueue, OutQueue: Integer; Buffer : String; NRead : DWORD; Procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: Integer); Var. ComStat : TComStat; E : Cardinal; Begin. AInQueue := 0; AOutQueue := 0; If ClearCommError(Handle,e,@ComStat) then. Begin. AInQueue := ComStat.cbInQue; AOutQueue := ComStat.cbOutQue; End; End; Begin. If csDesigning in ComponentState then. Exit; If not Connected then. If not Connect then. Raise Exception.CreateHelp('TimerEvent: Could not connect to COM-port !',101); Application.ProcessMessages; If Connected then. Begin. DataInBuffer(FComportHandle,InQueue,OutQueue); If InQueue > 0 then. Begin. If (Assigned(FOnReceiveData) ) then. Begin. FReceiving := True; FOnReceiveData(Self); End; End; End; End; Procedure TComportDriverThread.SetComportBaudRate(Value: TComPortBaudRate); Begin. FComportBaudRate := Value; If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.SetComportDataBits(Value: TComPortDataBits); Begin. FComportDataBits := Value; If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.SetComportHwHandshaking(Value: TComportHwHandshaking); Begin. FComportHwHandshaking := Value; If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.SetComportInputBufferSize(Value: Word); Begin. FreeMem(FTempInputBuffer,FComportInputBufferSize); FComportInputBufferSize := Value; GetMem(FTempInputBuffer,FComportInputBufferSize); If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.SetComportNumber(Value: TComPortNumber); Begin. If Connected then. Exit; FComportNumber := Value; End; Procedure TComportDriverThread.SetComportOutputBufferSize(Value: Word); Begin. FComportOutputBufferSize := Value; If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.SetComportParity(Value: TComPortParity); Begin. FComportParity := Value; If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.SetComportPollingDelay(Value: Word); Begin. FComportPollingDelay := Value; End; Procedure TComportDriverThread.SetComportStopBits(Value: TComPortStopBits); Begin. FComportStopBits := Value; If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.SetComportSwHandshaking(Value: TComPortSwHandshaking); Begin. FComportSwHandshaking := Value; If Connected then. ApplyComPortSettings; End; Procedure TComportDriverThread.DoDataReceived; Begin. If Assigned(FOnReceiveData) then FOnReceiveData(Self); End; Procedure TComportDriverThread.SetComPortActive(Value: Boolean); Var. DumpString : String; Begin. FComPortActive := Value; If csDesigning in ComponentState then. Exit; If FComPortActive then. Begin. //Just dump the contents of the input buffer of the com-port. ReadString(DumpString); FTimer.Enabled := True; End. Else. FTimer.Enabled := False; FTimer.SupRes; End; { TTimerThread }. Procedure TTimerThread.Execute; Begin. Priority := tpNormal; Repeat. Sleep(500); If Assigned(FOnTimer) then Synchronize(FOnTimer); Until Terminated; End; Procedure TTimerThread.SupRes; Begin. If not Suspended then. Suspend; If FEnabled then. Resume; End; End.

©Drkb::01345.

Взято из http://forum.sources.ru.

Code: Procedure TCommPortDriver.SetActive(const Value: boolean); Begin. FActive := Value; End; End.

©Drkb::01346.

Взято из http://forum.sources.ru.

Количество активных потоков и загруженность процессора.

Автор: Vimil Saju.

В реестре есть раздел HKEY_DYN_DATA. Основная информация о системе хранится в ключе PerfStats.

О получении информации,например, о загруженности процессора, необходимо проделать следующие шаги:

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

Например.

Просто считываем значение ключа 'PerfStats\StartStat\KERNEL\CPUusage' в секции HKEY_DYN_DATA. данное действие запускает счётчик. После этого в ключе 'PerfStats\StatData\KERNEL\CPUusage' будет храниться значение в процентах о загруженности процессора.

Далее, если добавить считывание загруженности процессора в событие On timer, то мы сможем наблюдать изменение загруженности процессора в динамике.

По завершении, Ваша программа должна остановить счётчик в реестре. Для этого просто считай ключ 'PerfStats\StopStat\KERNEL\CPUusage'.Это остановит счётчик.

Так же в системе есть много других счётчиков. Весь список счётчиков можно посмотреть в ключе PerfStats\StatData, используя редактор реестра.

Представленный ниже исходник получает значения всех счётчиков, расположенных в секции HKEY_DYN_DATA.

Code: Unit SystemInfo; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,extctrls; Type TDialupAdapterInfo = record //Информация о Dialup адаптере. Alignment:dword; Buffer:dword; Bytesrecieved:dword; BytesXmit:dword; ConnectSpeed:dword; CRC:dword; Framesrecieved:dword; FramesXmit:dword; Framing:dword; Runts:dword; Overrun:dword; Timeout:dword; Totalbytesrecieved:dword; TotalbytesXmit:dword; End; Type TKernelInfo = record. CpuUsagePcnt:dword; Numthreads:dword; NumVMS:dword; End; Type TVCACHEInfo = record. Ccurpages:dword; CMacPages:dword; Cminpages:dword; FailedRecycles:dword; Hits:dword; LRUBuffers:dword; LRURecycles:dword; Misses:dword; RandomRecycles:dword; End; Type TFATInfo = record. BreadsSec:dword; BwritesSec:dword; Dirtydata:dword; ReadsSec:dword; WritesSec:dword; End; Type TVMMInfo = record. CDiscards:dword; CInstancefaults:dword; CPageFaults:dword; CPageIns:dword; CPageOuts:dword; CpgCommit:dword; CpgDiskCache:dword; CpgDiskCacheMac:dword; CpgDiskCacheMid:dword; CpgDiskCacheMin:dword; Cpgfree:dword; Cpglocked:dword; CpglockedNoncache:dword; Cpgother:dword; Cpgsharedpages:dword; Cpgswap:dword; Cpgswapfile:dword; Cpgswapfiledefective:dword; Cpgswapfileinuse:dword; End; Type. TSysInfo = class(TComponent). Private. FDialupAdapterInfo:TDialupAdapterInfo; FKernelInfo:TKernelInfo; FVCACHEInfo:TVCACHEInfo; FFATInfo:TFATInfo; FVMMInfo:TVMMInfo; Ftimer:TTimer; Fupdateinterval:integer; Tmp:dword; Vsize:dword; Pkey:hkey; Regtype:pdword; Fstopped:boolean; Procedure fupdatinginfo(sender:tobject); Procedure fsetupdateinterval(aupdateinterval:integer); Protected. FsysInfoChanged:TNotifyEvent; Public. Constructor Create(Aowner:Tcomponent);override; Destructor Destroy;override; Property DialupAdapterInfo: TDialupAdapterInfo read fDialupAdapterInfo; Property KernelInfo: TKernelInfo read fKernelInfo; Property VCACHEInfo: TVCACHEInfo read fVCACHEInfo; Property FATInfo: TFATInfo read fFATInfo; Property VMMInfo: TVMMInfo read fVMMInfo; Procedure StartRecievingInfo; Procedure StopRecievingInfo; Published. Property SysInfoChanged:TNotifyEvent read fsysInfoChanged write. FsysInfoChanged;//Это событие вызывается после определённого интервала времени. Property UpdateInterval:integer read fupdateInterval write. Fsetupdateinterval default 5000; End; Procedure Register; Implementation. Constructor TSysInfo.Create(Aowner:Tcomponent); Begin. Inherited; Ftimer:=ttimer.Create(self); Ftimer.enabled:=false; Ftimer.OnTimer:=fupdatinginfo; Vsize:=4; Fstopped:=true; End; Procedure TSysInfo.startrecievingInfo; Var. Res:integer; Begin. Res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StartStat',0,KEY_ALL_ACCESS,pkey); If res<>0 then. Raise exception.Create('Could not open registry key'); Fstopped:=false; // Для Dial Up Адаптера. RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize); // Для VCACHE. RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize); //Для VFAT. RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize); //Для VMM. RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize); //Для KERNEL. RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize); RegCloseKey(pkey); Ftimer.enabled:=true; End; Procedure tsysinfo.fupdatinginfo(sender:tobject); Var. Res:integer; Begin. Res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StatData',0,KEY_ALL_ACCESS,pkey); If res<>0 then. Raise exception.Create('Could not open registry key'); //Для Dial Up Адаптера. RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@fDialupAdapterInfo.alignment,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@fDialupAdapterInfo.buffer,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@fDialupAdapterInfo.framing,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@fDialupAdapterInfo.overrun,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@fDialupAdapterInfo.timeout,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@fDialupAdapterInfo.crc,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@fDialupAdapterInfo.runts,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@fDialupAdapterInfo.framesxmit,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@fDialupAdapterInfo.framesrecieved,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@fDialupAdapterInfo.bytesxmit,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@fDialupAdapterInfo.bytesrecieved,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@fDialupAdapterInfo.totalbytesxmit,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@fDialupAdapterInfo.totalbytesrecieved,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@fDialupAdapterInfo.connectspeed,@vsize); // Для VCACHE. RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@fVCACHEInfo.lrubuffers,@vsize); RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@fVCACHEInfo.failedrecycles,@vsize); RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@fVCACHEInfo.randomrecycles,@vsize); RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@fVCACHEInfo.lrurecycles,@vsize); RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@fVCACHEInfo.misses,@vsize); RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@fVCACHEInfo.hits,@vsize); RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@fVCACHEInfo.cmacpages,@vsize); RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@fVCACHEInfo.cminpages,@vsize); RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@fVCACHEInfo.ccurpages,@vsize); //Для VFAT. RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@ffatinfo.dirtydata,@vsize); RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@ffatinfo.breadssec,@vsize); RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@ffatinfo.bwritessec,@vsize); RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@ffatinfo.readssec,@vsize); RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@ffatinfo.writessec,@vsize); //Для VMM. RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@fvmminfo.cpglockednoncache,@vsize); RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@fvmminfo.cpgcommit,@vsize); RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@fvmminfo.cpgsharedpages,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@fvmminfo.cpgdiskcacheMid,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@fvmminfo.cpgdiskcacheMac,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@fvmminfo.cpgdiskcacheMin,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@fvmminfo.cpgdiskcache,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@fvmminfo.cpgswapfiledefective,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@fvmminfo.cpgswapfileinuse,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@fvmminfo.cpgswapfile,@vsize); RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@fvmminfo.cdiscards,@vsize); RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@fvmminfo.cpageouts,@vsize); RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@fvmminfo.cpageins,@vsize); RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@fvmminfo.cinstancefaults,@vsize); RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@fvmminfo.cpagefaults,@vsize); RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@fvmminfo.cpgother,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@fvmminfo.cpgswap,@vsize); RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@fvmminfo.cpglocked,@vsize); RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@fvmminfo.cpgfree,@vsize); //Для KERNEL. RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@fkernelinfo.cpuusagepcnt,@vsize); RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@fkernelinfo.numvms,@vsize); RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@fkernelinfo.numThreads,@vsize); RegCloseKey(pkey); If assigned(SysInfoChanged) then. SysInfoChanged(self); End; Procedure TSysInfo.stoprecievingInfo; Var. Res:integer; Begin. Res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StopStat',0,KEY_ALL_ACCESS,pkey); If not fstopped then. Begin. If res<>0 then. Raise exception.Create('Could not open registry key'); //Для Dial Up Адаптера. RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize); // Для VCACHE. RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize); //Для VFAT. RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize); //Для VMM. RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize); //Для KERNEL. RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize); RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize); RegCloseKey(pkey); Ftimer.enabled:=false; Fstopped:=true; End; End; Procedure tsysinfo.fsetupdateinterval(aupdateinterval:integer); Begin. If (ftimer<>nil) and(aupdateinterval>0) then. Begin. Ftimer.Interval:=aupdateinterval; Fupdateinterval:=aupdateinterval; End; If (ftimer<>nil) and(aupdateinterval=0) then. Begin. Ftimer.Interval:=500; Fupdateinterval:=500; End; End; Destructor tsysinfo.Destroy; Begin. StopRecievingInfo; Ftimer.Destroy; Inherited; End; Procedure Register; Begin. RegisterComponents('Samples', [TSysInfo]); End;

©Drkb::01427.

Поддерживает ли процессор технологию 3DNow.

Code: {$ifndef ver80} // так как будем использовать 32-битный регистр. Function 3DNowSupport: Boolean; assembler; Asm. Push ebx. Mov @Result, True. Mov eax, $80000000. Dw $A20F. Cmp eax, $80000000. Jbe @NOEXTENDED // 3DNow не поддерживается. Mov eax, $80000001. Dw $A20F. Test edx, $80000000. Jnz @EXIT // 3DNow поддерживается. @NOEXTENDED: Mov @Result, False. @EXIT: Pop ebx. End; {$endif}.

©Drkb::01428.

Как узнать состояние модема в Win32?

Следующий пример демонстрирует получение состояния управляющих регистров модема.

Пример:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. CommPort : string; HCommFile : THandle; ModemStat : DWord; Begin. CommPort := 'COM2'; {Открываем com-порт}. HCommFile := CreateFile(PChar(CommPort), GENERIC_READ, 0, Nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); If hCommFile = INVALID_HANDLE_VALUE then. Begin. ShowMessage('Unable to open '+ CommPort); Exit; End; {Получаем состояние модема}. If GetCommModemStatus(hCommFile, ModemStat) <> false then begin. If ModemStat and MS_CTS_ON <> 0 then. ShowMessage('The CTS (clear-to-send) is on.'); If ModemStat and MS_DSR_ON <> 0 then. ShowMessage('The DSR (data-set-ready) is on.'); If ModemStat and MS_RING_ON <> 0then. ShowMessage('The ring indicator is on.'); If ModemStat and MS_RLSD_ON <> 0 then. ShowMessage('The RLSD (receive-line-signal-detect) is. On.'); End; {Закрываем com-порт}. CloseHandle(hCommFile); End;

©Drkb::01462.

Взято из http://forum.sources.ru.

Как прочитать из модема?

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

Code: Var. PortSpec : array[0..255] of char; PortNo : Word; Success : Boolean; Error:integer; Begin. FillChar(PortSpec,Sizeof(PortSpec),#0); StrPCopy(PortSpec,'Com1:19200,n,8,1'); PortSpec[3]:=Char(Ord(PortSpec[3])+Ord(PortNo)); If not BuildCommDCB(PortSpec,Mode) Then. Begin. //какая-то ошибка... Exit; End; PortSpec[5]:=#0; { 'Com1:' }. Mode.Flags:=EV_RXCHAR + EV_EVENT2; { $1001 }. Com := CreateFile(PortSpec,GENERIC_READ or GENERIC_WRITE, 0, //* comm устройство открывается с эксклюзивным доступом*/ Nil, //* нет security битов */ OPEN_EXISTING, //* comm устройства должны использовать OPEN_EXISTING*/ 0, //* not overlapped I/O */ 0 //* hTemplate должен быть NULL для comm устройств */ ); If Com = INVALID_HANDLE_VALUE then Error := GetLastError; Success := GetCommState(Com,Mode); If not Success then // Обработчик ошибки. Begin. End; Mode.BaudRate := 19200; Mode.ByteSize := 8; Mode.Parity := NOPARITY; Mode.StopBits := ONESTOPBIT;//нужен был для перезаписи в NT. Success := SetCommState(Com, Mode); If not Success then // Обработчик ошибки. Begin. End; End;

Переменная "com" типа dword.

Вы так же можете очистить буфер COM порта PurgeComm(Com,PURGE_RXCLEAR or PURGE_TXCLEAR); И прочитать из него.

Code: Function ReadCh(Var Ch:Byte):dword; Var. N : dword; Begin. Readfile(Com,ch,1,result,nil); End;

©Drkb::01463.

Взято из http://forum.sources.ru.

Получаем и устанавливаем различные режимы видео адаптера?

Перевод одноимённой статьи с сайта delphi.about.com ).

Display Device Modes.

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

В данной статье мы рассмотрим принципы работы с API функцией EnumDisplaySettings, которая позволяет получить список доступных разрешений дисплея, а так же с функцией ChangeDisplaySettings для смены текущего видео-режима.

Полечение возможных видео-режимов.

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

Данная функция имеет на входе переменную типа TDevMode, в которой помещаются параметры. Сам тип TDevMode имеет множество переменных, относящихся к видео адаптеру. А именно, он включает в себя разрешение видео адаптера в пикселях (dmPelsWidth, dmPelsHeight), разрядность цвета (в битах на пиксель), поддерживаемая при данном разрешении (dmBitsPerPel), частота обновления (dmDisplayFrequency) и другие.

Code: Procedure TForm1.FormCreate(Sender: TObject); Var. I : Integer; DevMode : TDevMode; Begin. I:=0; While EnumDisplaySettings(nil,i,DevMode) do begin. With Devmode do. ListBox1.Items.Add. (Format('%dx%d %d Colors', [dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel])); Inc(i); End; End;

Установка видео-режима.

После того как мы получим все доступные режимы, то установить желательный не составляет особого труда. Для этого мы воспользуемся функцией ChangeDisplaySettings. Так же данная функция при необходимости обновит реестр Windows.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. DevMode : TDeviceMode; LiRetValue : Longint; Begin. If EnumDisplaySettings. (nil,Listbox1.ItemIndex,Devmode) then. LiRetValue := ChangeDisplaySettings. (DevMode, CDS_UPDATEREGISTRY); SendMessage(HWND_BROADCAST, WM_DISPLAYCHANGE, SPI_SETNONCLIENTMETRICS, 0); End;

Функция ChangeDisplaySettings возвращает значение long integer. Это значение можно использовать для определения успешности выполнения функции, сравнив со значениями из списка констант.

Внимание: Не рекомендуется устанавливать значение видео-режима, который не присутствует в списке доступных. Это может привести к мерцанию экрана либо вообще к исчезновению изображения.

Внимание: Многие адаптеры (особенно старые) могут не поддерживать смену разрешения без перезагрузки компьютера.

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

Отслеживание изменений дисплея.

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

Code: ... Type. TForm1 = class(TForm). ListBox1: TListBox; ... Private. Procedure WMDisplayChange(var Message:TMessage); Message WM_DISPLAYCHANGE; ... Procedure. TForm1.WMDisplayChange(var Message: TMessage); Begin. ShowMessage('Changes in display detected!'); Inherited; End;

©Drkb::01450.

Взято из http://forum.sources.ru.

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

Как определить, нажата ли в данный момент клавиша Shift, Ctrl или Alt?

Следующий пример демонстрирует проверку состояния клавиши Shift (нажата она или нет), в то время когда выделен пункт меню. А так же в примере содержатся функции, позволяющие определить состояние клавишь Alt, Ctrl, и shift:

Code: Function CtrlDown : Boolean; Var. State : TKeyboardState; Begin. GetKeyboardState(State); Result := ((State[vk_Control] And 128) <> 0); End; Function ShiftDown : Boolean; Var. State : TKeyboardState; Begin. GetKeyboardState(State); Result := ((State[vk_Shift] and 128) <> 0); End; Function AltDown : Boolean; Var. State : TKeyboardState; Begin. GetKeyboardState(State); Result := ((State[vk_Menu] and 128) <> 0); End; Procedure TForm1.MenuItem12Click(Sender: TObject); Begin. If ShiftDown then. Form1.Caption := 'Shift' else. Form1.Caption := ''; End;

©Drkb::01500.

Взято из http://forum.sources.ru.

Регистрируем горячие клавиши.

Пример демонстрирует установку горячей клавиши CTRL-F7:

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls; Type. TForm1 = class(TForm). Procedure FormActivate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. Procedure WMHotKey(var Message: TMessage); message WM_HOTKEY; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure Tform1.WMHotKey(var Message: TMessage); Begin. Application.Restore; Application.bringtofront; Showmessage('Нажата CTRL-F7!'); End; Procedure TForm1.FormActivate(Sender: TObject); Begin. RegisterHotKey(form1.Handle,123,mod_control,vk_f7); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. UnregisterHotKey(Handle, 123). End; End.

©Drkb::01501.

Взято из http://forum.sources.ru.

Code: { The following example demonstrates registering hotkeys with the. System to globally trap keys. Das Folgende Beispiel zeigt, wie man Hotkeys registrieren und. Darauf reagieren kann, wenn sie gedruckt werden. (systemweit). } Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. { Private declarations }. Id1, id2, id3, id4: Integer; Procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. // Trap Hotkey Messages. Procedure TForm1.WMHotKey(var Msg: TWMHotKey); Begin. If Msg.HotKey = id1 then. ShowMessage('Ctrl + A pressed !'); If Msg.HotKey = id2 then. ShowMessage('Ctrl + Alt + R pressed !'); If Msg.HotKey = id3 then. ShowMessage('Win + F4 pressed !'); If Msg.HotKey = id4 then. ShowMessage('Print Screen pressed !'); End; Procedure TForm1.FormCreate(Sender: TObject); // Different Constants from Windows.pas. Const. MOD_ALT = 1; MOD_CONTROL = 2; MOD_SHIFT = 4; MOD_WIN = 8; VK_A = $41; VK_R = $52; VK_F4 = $73; Begin. // Register Hotkey Ctrl + A. Id1 := GlobalAddAtom('Hotkey1'); RegisterHotKey(Handle, id1, MOD_CONTROL, VK_A); // Register Hotkey Ctrl + Alt + R. Id2 := GlobalAddAtom('Hotkey2'); RegisterHotKey(Handle, id2, MOD_CONTROL + MOD_Alt, VK_R); // Register Hotkey Win + F4. Id3 := GlobalAddAtom('Hotkey3'); RegisterHotKey(Handle, id3, MOD_WIN, VK_F4); // Globally trap the Windows system key "PrintScreen". Id4 := GlobalAddAtom('Hotkey4'); RegisterHotKey(Handle, id4, 0, VK_SNAPSHOT); End; // Unregister the Hotkeys. Procedure TForm1.FormDestroy(Sender: TObject); Begin. UnRegisterHotKey(Handle, id1); GlobalDeleteAtom(id1); UnRegisterHotKey(Handle, id2); GlobalDeleteAtom(id2); UnRegisterHotKey(Handle, id3); GlobalDeleteAtom(id3); UnRegisterHotKey(Handle, id4); GlobalDeleteAtom(id4); End; End. { RegisterHotKey fails if the keystrokes specified for the hot key have. Already been registered by another hot key. Windows NT4 and Windows 2000/XP: The F12 key is reserved for use by the. Debugger at all times, so it should not be registered as a hot key. Even. When you are not debugging an application, F12 is reserved in case a. Kernel-mode debugger or a just-in-time debugger is resident. }

©Drkb::01502.

Взято с сайта: http://www.swissdelphicenter.ch.

Соглашения о вызовах.

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

Стандартный вызов в языках C++ и Object Pascal различается, но набор директив смены типа вызова позволяет обеспечить любую реализацию.

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

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

Если очистка стека осуществляется вызываемой процедурой, то перед этим она помещает возвращаемые значения во временную область памяти.

Помимо рассмотренных ниже директив имеются еще три типа вызовов, которые не используются и сохранены для обеспечения обратной совместимости. Это директивы near, far, export.

Директива register.

Эта директива используется по умолчанию. Поэтому нет необходимости добавлять ключевое слов register после объявления функции. Вызов такого типа называется быстрым (fast call). В нем используются три расширенных регистра процессора, в которые помещаются переменные длиной не более 32-х разрядов и указатели. Остальные параметры помещаются в стек слева направо. После использования стек очищается вызываемой процедурой.

Директива pascal.

Реализует вызовы в стиле языка Pascal. За очистку стека отвечает вызываемая процедура. Параметры помещаются в стек слева направо. Этот способ вызова является очень быстрым, но не поддерживает переменное число параметров. Используется для обеспечения обратной совместимости.

Директива stdcall.

Параметры помещаются в стек слева направо. Очистка стека осуществляется вызываемой процедурой. Этот вызов обеспечивает обработку фиксированного числа параметров.

Директива cdecl.

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

Эта директива в основном применяется для обращения к динамическим библиотекам, использующим соглашения о вызовах в стиле языка С. Использование директивы cdecl для библиотек Delphi не вызовет ошибку компиляции, но переменное число параметров не обеспечит.

Директива safecall.

Параметры помещаются в стек справа налево. Очистка стека осуществляется вызываемой процедурой. Используется в СОМ и основанных на ней технологиях.

©Drkb::01993.

Как определить, нажал ли пользователь клавишу PrintScreen?

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

Событие OnIdle в TApplication как раз подходит для вызова этой API функции:

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. Application.OnIdle := AppIdle; End; Procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean); Begin. If GetAsyncKeyState(VK_SNAPSHOT) <> 0 then. Form1.Caption := 'PrintScreen нажата !'; Done := True; End;

©Drkb::01504.

Взято из http://forum.sources.ru.

The PrintScreen system key is not processed during the TForm keydown event. The following example tests if the PrintScreen key has.

Been pressed by calling the Windows API function GetAsyncKeyState() during the Application.OnIdle event.

Как конвертировать виртуальную клавишу в ASCII код?

Получаем символ, соответствующий виртуальной клавише:

Code: Function GetCharFromVKey(vkey: Word): string; Var. Keystate: TKeyboardState; Retcode: Integer; Begin. Win32Check(GetKeyboardState(keystate)); SetLength(Result, 2); Retcode := ToAscii(vkey, MapVirtualKey(vkey, 0), Keystate, @Result[1], 0); Case retcode of. 0: Result := ''; 1: SetLength(Result, 1); 2: ; Else. Result := ''; End; End; { Использование: Procedure TForm1.Edit1KeyDown. (Sender: TObject; var Key: Word; Shift: TShiftState); Begin. ShowMessage(GetCharFromVKey(Key)); End; }

©Drkb::01508.

Взято из http://forum.sources.ru.

Как узнать состояние клавиши CAPS LOCK?

Code: Function IsCapsLockOn : Boolean; Begin. Result := 0 <> (GetKeyState(VK_CAPITAL) and $01); End;

©Drkb::01497.

Взято из http://forum.sources.ru.

Code: Procedure AppOnIdle(Sender: TObject; var Done: Boolean); ... Procedure TForm1.AppOnIdle(Sender: TObject; var Done: Boolean); Begin. CheckBox1.Checked := Odd(GetKeyState(VK_CAPITAL)); CheckBox2.Checked := Odd(GetKeyState(VK_SHIFT)); CheckBox3.Checked := Odd(GetKeyState(VK_NUMLOCK)); CheckBox4.Checked := Odd(GetKeyState(VK_SCROLL)); Done := False; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Application.OnIdle := AppOnIdle; End;

Симфония на клавиатуре(статья).

Перевод одноимённой статьи с сайта delphi.about.com ).

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

События клавиатуры, наряду с событиями мыши, являются основными элементами взаимодействия пользователя с программой. В данной статье пойдёт речь о трёх событиях, которые позволяют отлавливать нажатия клавиш в приложении Delphi: OnKeyDown, OnKeyUp и OnKeyPress.

Для получения ввода с клавиатуры, приложения Delphi могут использовать два метода. Самый простой способ, это воспользоваться одним из компонентов, автоматически реагирущем на нажатия клавиш, таким как Edit. Второй способ заключается в создании процедур в форме, которые будут обрабатывать нажатия и отпускания клавиш. Эти обработчики могут обрабатывать как нажатия одиночных клавиш, так и комбинаций. Итак, вот эти события:

OnKeyDown - вызывается, когда на клавиатуре нажимается любая клавиша. OnKeyUp - вызывается, когда любая клавиша на клавиатуре отпускается. OnKeyPress - вызывается, когда нажимается клавиша, отвечающая за определённый ASCII символ.

Теперь самое время посмотреть, как выглядят в программе заголовки обработчиков:

Code: Procedure TForm1.FormKeyDown. (Sender: TObject; var Key: Word; Shift: TShiftState); ... Procedure TForm1.FormKeyUp. (Sender: TObject; var Key: Word; Shift: TShiftState); ... Procedure TForm1.FormKeyPress. (Sender: TObject; var Key: Char);

Все события имеют один общий параметр, обычно называемый Key. Этот параметр используется для передачи кода нажатой клавиши. Параметр Shift (в процедурах OnKeyDown и OnKeyUp), указывает на то, была ли нажата клавиша в сочетании с Shift, Alt, и Ctrl.

Фокус.

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

Некоторые компоненты, такие как TImage, TPaintBox, TPanel и TLabel не могут получать фокус, другими словами, это компоненты, наследованные от TGraphicControl. Так же не могут получать фокус невидимые компоненты, такие как TTimer.

OnKeyDown, OnKeyUp.

События OnKeyDown и OnKeyUp обеспечивают самый низкий уровень ответа клавиатуры. Обработчики OnKeyDown и OnKeyUp могут реагировать на все клавиши клавиатуры, включая функциональные и комбинации с клавишами Shift, Alt, и Ctrl.

События клавиатуры - не взаимоисключающие. Когда пользователь нажимает клавишу, то генерируются два события OnKeyDown и OnKeyPress, а когда отпускает, то только одно: OnKeyUp. Если пользователь нажмёт одну из клавиш, которую OnKeyPress не сможет определить, то будет сгенерировано только одно событие OnKeyDown, а при отпускании OnKeyUp.

OnKeyPress.

OnKeyPress возвращает различные значения ASCII для 'g' и 'G,'. Однако, OnKeyDown и OnKeyUp не делают различия между верхним и нижним регистром.

Параметры Key и Shift.

Параметр Key можно изменять, чтобы приложение получило другой код нажатой клавиши. Таким образом можно ограничивать набор различных символов, которые пользователь может ввести с клавиатуры. Например разрешить вводить только цифры. Для этого добавьте в обработчик события OnKeyPress следующий код и установите KeyPreview в True (см. ниже).

Code: If Key in ['a'..'z'] + ['A'..'Z'] then Key:=#0.

Это выражение проверяет, содержит ли параметр Key символы нижнего регистра ('a'..'z') и символы верхнего регистра ('A'..'Z'). Если так, то в параметр заносится значение нуля, чтобы предотвратить ввод в компонент Edit (например).

В Windows определены специальные константы для каждой клавиши. Например, VK_RIGHT соответствует коду клавиши для правой стрелки.

Чтобы получить состояния специальных клавиш, таких как TAB или PageUp можно воспользоваться API функцией GetKeyState. Клавиши состояния могут находиться в трёх состояниях: отпущена, нажата, и включена. Если старший бит равен 1, то клавиша нажата, иначе отпущена. Для проверки этого бита можно воспользоваться API функцией HiWord. Если младший бит равен 1, то клавиша включена. Вот пример получения сосотояния специальной клавиши:

Code: If HiWord(GetKeyState(vk_PageUp)) <> 0 then. ShowMessage('PageUp - DOWN'). Else. ShowMessage('PageUp - UP');

В событиях OnKeyDown и OnKeyUp, Key является беззнаковым двухбайтовым (Word) значением, которое представляет виртуальную клавишу Windows. Для получания значения символа можно воспользоваться функцией Chr. В событии OnKeyPress параметр Key является значением Char, которое представляет символ ASCII.

События OnKeyDown и OnKeyUp имеют параметр Shift с типом TShiftState. В Delphi тип TShiftState определён как набор флагов, определяющих состояние Alt, Ctrl, и Shift при нажатии клавиши.

Например, следующий код (из обработчика OnKeyUp) соединяет строку 'Ctrl +' с нажатой клавишей и отображает результат в заголовке формы:

Code: If ssCtrl in Shift then. Form1.Caption:= 'Ctrl +' + Chr(Key);

Если нажать Ctrl + A, то будут сгенерированы следующие события:

KeyDown (Ctrl) // ssCtrl.

KeyDown (Ctrl+A) //ssCtrl + 'A'

KeyPress (A).

KeyUp (Ctrl+A).

Переадресация событий клавиатуры в форму.

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

Чтобы перехватить нажатия клавиш на уровне формы, до того как они будут переданы компонентам на форме, необходимо установить свойство KeyPreview в True. После этого компонент как и раньше будет получать события, однако сперва они будут попадать в форму, чтобы дать возможность программе разрешить или запретить ввод различных символов.

Допустим, У Вас на форме есть несколько компонентов Edit и процедура Form.OnKeyPress выглядит следующим образом:

Code: Procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); Begin. If Key in ['0'..'9'] then Key := #0. End;

Если один из компонентов Edit имеет фокус и свойство KeyPreview установлено в False, то этот код не будет выполнен - другими словами, если пользователь нажмёт клавишу '5', то в компоненте Edit, имеющем фокус, появится символ "5".

Однако, если KeyPreview установлено в True, то событие формы OnKeyPress будет выполнено до того, как компонент Edit увидит нажатую клавишу. Поэтому, если пользователь нажмёт клавишу '5', то в Key будет подставлено нулевое значение, предотвращая тем самым попадание числовых символов в Edit.

ПРИЛОЖЕНИЕ: Таблица кодов виртуальных клавиш.

Symbolic constant name Value (hexadecimal) Keyboard (or mouse) equivalent

VK_LBUTTON	01	Left mouse button
VK_RBUTTON	02	Right mouse button
VK_CANCEL	03	Control-break processing
VK_MBUTTON	04	Middle mouse button (three-button mouse)
VK_BACK	08	BACKSPACE key
VK_TAB	09	TAB key
VK_CLEAR	0C	CLEAR key
VK_RETURN	0D	ENTER key
VK_SHIFT	10	SHIFT key
VK_CONTROL	11	CTRL key
VK_MENU	12	ALT key
VK_PAUSE	13	PAUSE key
VK_CAPITAL	14	CAPS LOCK key
VK_ESCAPE	1B	ESC key
VK_SPACE	20	SPACEBAR
VK_PRIOR	21	PAGE UP key
VK_NEXT	22	PAGE DOWN key
VK_END	23	END key
VK_HOME	24	HOME key
VK_LEFT	25	LEFT ARROW key
VK_UP	26	UP ARROW key
VK_RIGHT	27	RIGHT ARROW key
VK_DOWN	28	DOWN ARROW key
VK_SELECT	29	SELECT key
VK_PRINT	2A	PRINT key
VK_EXECUTE	2B	EXECUTE key
VK_SNAPSHOT	2C	PRINT SCREEN key
VK_INSERT	2D	INS key
VK_DELETE	2E	DEL key
VK_HELP	2F	HELP key
	30	0 key
	31	1 key
	32	2 key
	33	3 key
	34	4 key
	35	5 key
	36	6 key
	37	7 key
	38	8 key
	39	9 key
	41	A key
	42	B key
	43	C key
	44	D key
	45	E key
	46	F key
	47	G key
	48	H key
	49	I key
	4A	J key
	4B	K key
	4C	L key
	4D	M key
	4E	N key
	4F	O key
	50	P key
	51	Q key
	52	R key
	53	S key
	54	T key
	55	U key
	56	V key
	57	W key
	58	X key
	59	Y key
	5A	Z key
VK_NUMPAD0	60	Numeric keypad 0 key
VK_NUMPAD1	61	Numeric keypad 1 key
VK_NUMPAD2	62	Numeric keypad 2 key
VK_NUMPAD3	63	Numeric keypad 3 key
VK_NUMPAD4	64	Numeric keypad 4 key
VK_NUMPAD5	65	Numeric keypad 5 key
VK_NUMPAD6	66	Numeric keypad 6 key
VK_NUMPAD7	67	Numeric keypad 7 key
VK_NUMPAD8	68	Numeric keypad 8 key
VK_NUMPAD9	69	Numeric keypad 9 key
VK_SEPARATOR	6C	Separator key
VK_SUBTRACT	6D	Subtract key
VK_DECIMAL	6E	Decimal key
VK_DIVIDE	6F	Divide key
VK_F1	70	F1 key
VK_F2	71	F2 key
VK_F3	72	F3 key
VK_F4	73	F4 key
VK_F5	74	F5 key
VK_F6	75	F6 key
VK_F7	76	F7 key
VK_F8	77	F8 key
VK_F9	78	F9 key
VK_F10	79	F10 key
VK_F11	7A	F11 key
VK_F12	7B	F12 key
VK_F13	7C	F13 key
VK_F14	7D	F14 key
VK_F15	7E	F15 key
VK_F16	7F	F16 key
VK_F17	80H	F17 key
VK_F18	81H	F18 key
VK_F19	82H	F19 key
VK_F20	83H	F20 key
VK_F21	84H	F21 key
VK_F22	85H	F22 key
VK_F23	86H	F23 key
VK_F24	87H	F24 key
VK_NUMLOCK	90	NUM LOCK key
VK_SCROLL	91	SCROLL LOCK key
VK_LSHIFT	A0	Left SHIFT key
VK_RSHIFT	A1	Right SHIFT key
VK_LCONTROL	A2	Left CONTROL key
VK_RCONTROL	A3	Right CONTROL key
VK_LMENU	A4	Left MENU key
VK_RMENU	A5	Right MENU key
VK_PLAY	FA	Play key
VK_ZOOM	FB	Zoom key

©Drkb::01509.

Взято из http://forum.sources.ru.

Программно нажимаем Print Screen.

Автор: Simon Carter.

Совместимость: Delphi 3.x (или выше).

Приведённая здесь функция делает копию изображения экрана и сохраняет её в буфере обмена (Clipboard). Так же необходимо включить в Ваш проект файл ClipBrd.pas.

Code: Procedure SendScreenImageToClipboard; Var. Bmp: TBitmap; Begin. Bmp := TBitmap.Create; Try. Bmp.Width := Screen.Width; Bmp.Height := Screen.Height; BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, GetDC(GetDesktopWindow), 0, 0, SRCCopy); Clipboard.Assign(bmp); Finally. Bmp.Free; End; End;

Следующая функция скопирует изображение экрана в в bitmap. Переменная bitmap *должна* быть инициализирована до вызова этой функции.

Code: Procedure GetScreenImage(bmp: TBitmap); Begin. Bmp.Width := Screen.Width; Bmp.Height := Screen.Height; BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, GetDC(GetDesktopWindow), 0, 0, SRCCopy); End;

©Drkb::01510.

Взято из http://forum.sources.ru.

Как заставить кнопку Enter работать наподобие Tab?

Автор: Khaled Shagrouni.

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

Совместимость: Все версии Delphi.

Пример обработчика события:

Code: Procedure Tform1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Var. ACtrl: TWinControl; Begin. If key = 13 then. Begin. ACtrl := ActiveControl; If ACtrl is TCustomMemo then exit; Repeat. ACtrl:= FindNextControl(ACtrl,true,true,false); Until (ACtrl is TCustomEdit) or. (ACtrl is TCustomComboBox) or. (ACtrl is TCustomListBox) or. (ACtrl is TCustomCheckBox) or. (ACtrl is TRadioButton); ACtrl.SetFocus ; End; End;

Не забудьте установить свойство формы KeyPreview в true.

Как Вы можете видеть; этот код использует функцию FindNextControl, которая ищет следующий свободный контрол.

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

©Drkb::01484.

Взято из http://forum.sources.ru.

Существует множество методов решения этой проблемы, но самый быстрый способ, это перехват нажатия клавиш, перед тем как их получит форма:

В секции формы PRIVATE добавьте:

Code: Procedure CMDialogKey(Var Msg:TWMKey); message CM_DIALOGKEY;

В секции IMPLEMENTATION добавьте:

Code: Procedure TForm1.CMDialogKey(Var Msg: TWMKey); Begin. If NOT (ActiveControl Is TButton) Then. If Msg.Charcode = 13 Then. Msg.Charcode := 9; Inherited; End;

Тем самым мы исключаем срабатывания нашей подмены, если фокус находится на кнопке.

Чтобы ускорить работу приложения, не надо активизировать свойство формы KEYPREVIEW.

©Drkb::01485.

Взято из http://forum.sources.ru.

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. Form1.KeyPreview := true; End; Procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Var. C: TControl; Begin. If Key <> 13 then. Exit; Repeat. C := Form1.FindNextControl(Form1.ActiveControl, true, true, true); (c as TWinControl).SetFocus; Until. C is TEdit; End;

Как програмно переключить раскладку клавиатуры?

Code: Procedure TForm1.Button1Click(Sender: TObject);//На русский. Var. Layout: array[0.. KL_NAMELENGTH] of char; Begin. LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE); End; Procedure TForm1.Button2Click(Sender: TObject);//На английский. Var. Layout: array[0.. KL_NAMELENGTH] of char; Begin. LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE); End;

©Drkb::01511.

Взято из http://forum.sources.ru.

Как запретить Ctrl-Alt-Del?

Code: Var. I : integer; Begin. I := 0; {запрещаем Ctrl-Alt-Del}. SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @i, 0); End. // необходим unit WinProcs. // для Alt-Tab: SPI_SETFASTTASKSWITCH.

©Drkb::01512.

Взято из http://forum.sources.ru.

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

Автор: Full ( http://full.hotmail.ru/ ).

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

Code: Procedure TForm1.WMKeyDown(var Message: TWMKeyDown); Begin. Inherited; Case Message.CharCode of. VK_RETURN: Begin // ENTER pressed. If (Message.KeyData and $1000000 <> 0) then. Begin. { ENTER on numeric keypad }. End. Else. Begin. { ENTER on the standard keyboard }. End; End; End; End;

©Drkb::01513.

Взято из http://forum.sources.ru.

Как заставить дополнительную клавиатуру всегда работать в режиме цифр?

Для этого необходимо написать процедуру-обработчик для Application.OnMessage:

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. Application.OnMessage := AppOnMessage; End; Procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean); Var ccode: Word; Begin. Case Msg.Message of. WM_KEYDOWN, WM_KEYUP: Begin. If (GetKeyState( VK_NUMLOCK ) >= 0) //NumLock не включён. And ((Msg.lparam and $1000000) = 0). Then. Begin. Ccode := 0; Case Msg.wparam of. VK_HOME: ccode := VK_NUMPAD7; VK_UP : ccode := VK_NUMPAD8; VK_PRIOR: ccode := VK_NUMPAD9; VK_LEFT: ccode := VK_NUMPAD4; VK_CLEAR: ccode := VK_NUMPAD5; VK_RIGHT: ccode := VK_NUMPAD6; VK_END : ccode := VK_NUMPAD1; VK_DOWN : ccode := VK_NUMPAD2; VK_NEXT : ccode := VK_NUMPAD3; VK_INSERT:ccode := VK_NUMPAD0; VK_DELETE:ccode := VK_DECIMAL; End; If ccode <> 0 then Msg.Wparam := ccode; End; End; End; End;

©Drkb::01514.

Взято из http://forum.sources.ru.

Использование модуля ShareMem.

Если динамическая библиотека в процессе работы использует переменные или функции, осуществляющие динамическое выделение памяти под собственные нужды (длинные строки, динамические массивы, функции New и GetMem), а также, если такие переменные передаются в параметрах и возвращаются в результатах, то в таких библиотеках обязательно должен использоваться модуль ShareMem. При этом в секции uses модуль должен располагаться на первом месте. Об этом напоминает комментарий, автоматически добавляемый в файл динамической библиотеки при создании (см. листинг 28.1).

Управление этими операциями осуществляет специальный диспетчер печати BORLANDMM.DLL. Он должен распространяться вместе с динамическими библиотеками, использующими модуль ShareMem.

©Drkb::01994.

Как отловить изменение раскладки клавиатуры?

Автор: InSAn.

Нужно ловить сообщение WM_INPUTLANGCHANGEREQUEST.

©Drkb::01515.

Взято из http://forum.sources.ru.

Как перехватить нажатия функциональных клавиш и стрелок?

Автор: Arx ( http://arxoft.tora.ru ).

Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы.

Code: Procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. If Key = VK_RIGHT then. Form1.Caption := 'Right'; If Key = VK_F1 then. Form1.Caption := 'F1'; End;

©Drkb::01516.

Взято из http://forum.sources.ru.

Обработка нажатий клавиш вверх-вниз.

Как програмно переключить состояние клавиш Num Lock, Caps Lock, Scroll Lock?

Code: VAR. KS: TKeyboardState; Begin. GetKeyboardState(KS); KS[020] := KS[020] XOR 1; //Caps Lock. KS[144] := KS[144] XOR 1; //Num Lock. KS[145] := KS[145] XOR 1; //Scroll Lock. SetKeyboardState(KS); End;

©Drkb::01492.

Взято из http://forum.sources.ru.

Во-первых, предложенный способ работает только под 9x (лично проверил)...

Во-вторых, для понятности лучше вместо цифр подставить нормальные константы...

В-третьих, тут еще способ и для NT...

Способ для 9x (на NT не работает):

Code: Var. {©Drkb v.3(2007): www.drkb.ru}. KeyState : TKeyboardState; Begin. GetKeyboardState(KeyState); KeyState[VK_SCROLL] := KeyState[VK_SCROLL] xor 1; KeyState[VK_CAPITAL] := KeyState[VK_CAPITAL] xor 1; KeyState[VK_NUMLOCK] := KeyState[VK_NUMLOCK] xor 1; SetKeyboardState (KeyState); End; Способ для NT (на 9x не работает): Begin. Keybd_event (VK_SCROLL, 0, KEYEVENTF_EXTENDEDKEY, 0); Keybd_event (VK_SCROLL, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0); Keybd_event (VK_CAPITAL, 0, KEYEVENTF_EXTENDEDKEY, 0); Keybd_event (VK_CAPITAL, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0); Keybd_event (VK_NUMLOCK, 0, KEYEVENTF_EXTENDEDKEY, 0); Keybd_event (VK_NUMLOCK, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0); End;

Т.е. в программе надо будет сделать проверку на версию Windows,

И потом уже вызывать одну из этих функций,

Либо же можно их обе вызывать - одна да сработает...

©Drkb::01493.

Автор: p0s0l.

Как программно включить или выключить NumLock.

Code: Var. AbKeyState: array [0..255] of byte; Begin. GetKeyboardState( Addr( abKeyState[ 0 ] ) ); AbKeyState[ VK_NUMLOCK ] := abKeyState[ VK_NUMLOCK ] or $01; SetKeyboardState( Addr( abKeyState[ 0 ] ) ); End;

©Drkb::01494.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Code: Procedure TMyForm.Button1Click(Sender: TObject); Var. KeyState: TKeyboardState; Begin. GetKeyboardState(KeyState); If (KeyState[VK_NUMLOCK] = 0) then. KeyState[VK_NUMLOCK] := 1. Else. KeyState[VK_NUMLOCK] := 0; SetKeyboardState(KeyState); End;

Как узнать, присутствует ли мышка?

Code: Function MousePresent : Boolean; Begin. If GetSystemMetrics(SM_MOUSEPRESENT) <> 0 then. Result := true. Else. Result := false; End;

Как использовать mouse_event() для эмулирования событий мышки?

Следующий пример демонстрирует использование API функции mouse_event() для эмуляции событий мышки. Когда Button2 нажата, то мышь перемещается на Button1 и щёлкает по ней. Координаты мыши даны в "Mickeys", где 65535 соответствует ширине экрана.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage('Button 1 clicked'); End; Procedure TForm1.Button2Click(Sender: TObject); Var. Pt : TPoint; Begin. {Allow Button2 to repaint it's self}. Application.ProcessMessages; {Получаем координаты центра button 1}. Pt.x := Button1.Left + (Button1.Width div 2); Pt.y := Button1.Top + (Button1.Height div 2); {Преобразуем Pt в координаты экрана}. Pt := ClientToScreen(Pt); {Преобразуем Pt в mickeys}. Pt.x := Round(Pt.x * (65535 / Screen.Width)); Pt.y := Round(Pt.y * (65535 / Screen.Height)); {Перемещаем мышку}. Mouse_Event(MOUSEEVENTF_ABSOLUTE or. MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0); {Эмулируем нажатие левой кнопки мыши}. Mouse_Event(MOUSEEVENTF_ABSOLUTE or. MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);; {Эмулируем отпускание левой кнопки мыши}. Mouse_Event(MOUSEEVENTF_ABSOLUTE or. MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);; End;

Как поменять функции кнопок мышки?

Code: Begin. //--------- SwapMouseButton(true); // Поменять обратно - SwapMouseButton(false); //--------- End;

Как ограничить движения мышки определённой областью?

Для этого можно воспользоваться API функцией ClipCursor(). Например, можно вставить следующий код в обработчик события формы OnMouseDown:

ClipCursor(&BoundsRect);

А следующий код в обработчик события формы OnMouseUp:

ClipCursor(NULL);

Если нажать кнопку мыши на форме и удерживать её, то курсор мышки не сможет покинуть пределы формы.

©Drkb::01588.

Взято из http://forum.sources.ru.

Сначала определяете ограничивающий прямоугольник, затем используете функцию ClipCursor(), передав ей в качестве параметра указатель на этот прямоугольник. Например, вот так можно по 100 пикселей скостить по краям экрана:

Как узнать, находится ли мышка на форме?

Для этого можно воспользоваться API функцией GetCapture().

Пример:

Как программно двигать курсор мышки?

Следующий пример показывает, как "подтолкнуть мышку" без вмешательства пользователя.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Pt : TPoint; Begin. Application.ProcessMessages; Screen.Cursor := CrHourglass; GetCursorPos(pt); SetCursorPos(pt.x + 1, pt.y + 1); Application.ProcessMessages; SetCursorPos(pt.x - 1, pt.y - 1); End;

Как автоматически помещать курсор мышки в центр контрола получившего фокус?

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

Вот пример вызова нашей функции:

Code: Procedure TForm1.Button1Enter(Sender: TObject); Begin. MoveMouseOverControl(Sender); End;

Многомерное представление данных (статья).

Многомерное представление данных.

Помимо стандартных компонентов отображения данных в VCL Delphi имеются дополнительные компоненты, которые позволяют представлять данные в виде кросстаба. При этом заставить работать кросстаб с двумя и более полями почти так же просто, как и обычный компонент TDBGrid. Эти компоненты расположены на странице Decision Cube Палитры компонентов.

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

Понятие кросстаба.

Обычная таблица данных имеет строго заданное число столбцов, причем каждый столбец всегда предназначен для представления данных из одного поля. Для кросстаба число и назначение столбцов зависит от значений какого-либо поля. Число строк в кросстабе не равно числу строк в таблице БД, а также зависит от значений какого-либо поля. В ячейках кросстаба всегда располагается суммирующая информация по значениям полей горизонтали и вертикали .

Создать подобную двумерную структуру отображения данных при помощи обычных компонентов со страницы Data Controls Палитры компонентов очень непросто и хлопотно.

Пример кросстаба.

Статьи по Delphi (020)…

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

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

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

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

Взаимосвязь компонентов многомерного представления данных.

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

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

· перед отображением данных необходимо настроить параметры размерностей кросстаба;

· непосредственный показ данных в кросстабе;

· работающий кросстаб должен эффективно управляться на уровне размерностей.

Для этого в форме приложения требуется разместить как минимум пять компонентов со страницы Decision Cube Палитры компонентов.

Для создания запроса SQL можно использовать компонент TDecisionQuery или обычный компонент TQuery.

Запрос должен быть связан с компонентом TDecisionCube, который осуществляет подготовку набора данных запроса к многомерному показу.

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

Непосредственный показ многомерного набора данных проводится при помощи компонентов TDecisionGrid и TDecisionGraph. Они должны поддерживать соединение с компонентом TDecisionSource.

Наконец, управление многомерным представлением данных реализует компонент TDecisionPivot, он также должен быть связан с компонентом TDecisionSource.

Допустим, что на форме расположены следующие компоненты:

· TDecisionQuery по имени DecisionQuery1;

· TDecisionCube по имени DecisionCubel;

· TDecisionSource по имени DecisionSourcel;

· TDecisionGrid по имени DecisionGrid1;

· TDecisionPivot по имени DecisionPivotl.

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

Как связать компоненты многомерного представления данных.

TBecisionCube.

DataSet=DecisionQuery1 Определяет компонент доступа к данным, который создает набор данных.

TDecisionSource.

DecisionCube=DecisionCubel Указывает на компонент формирования многомерного набора данных.

TDecisionGrid.

DecisionSource=DecisionSourcel Ссылается на компонент TDecisionSource.

TDecisionPivot.

DecisionSource= DecisionSourcel Ссылается на компонент TDecisionSource.

Если задать текст запроса SQL и открыть набор данных, то вся цепочка заработает, причем ее поведение ничем не отличается от поведения во время выполнения приложения.

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

Подготовка набора данных.

Компоненты многомерного представления данных работают со специально созданным и подготовленным набором данных. Эта работа выполняется специальным компонентом доступа к данным — TDecisionQuery. Его непосредственным предком является компонент TQuery.

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

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

2. Поля запроса должны быть сгруппированы при помощи оператора GROUP BY.

3. Запрос должен содержать агрегатные функции, которые определяют вид.

Информации, отображаемой в ячейках кросстаба.

Компонент TDecisionQuery должен только обеспечить выполнение запроса и создание набора данных, он не имеет никаких дополнительных свойств или методов. Поэтому для создания набора данных можно использовать и обычный компонент TQuery. Преимущество компонента TDecisionQuery состоит в том, что он имеет специализированный редактор для создания текста запроса (рис. 30.2). Он вызывается командой Decision Query Editor из всплывающего меню компонента или двойным щелчком на компоненте. Элементы управления страницы Dimensions/Summaries позволяют создавать текст запроса, манипулируя именами полей таблиц. Псевдоним базы данных выбирается в комбинированном списке Database. После этого в списке Table задается нужная таблица. Если в запросе требуется использовать несколько таблиц, то для их выбора можно воспользоваться утилитой SQL Builder, которая вызывается щелчком на одноименной кнопке.

Специализированный редактор компонента TDecisionQuery.

Статьи по Delphi (020)…

Из списка доступных полей при помощи кнопок Add требуемые поля можно перенести в список полей — размерностей Dimensions и список суммирующих полей Summaries. Поля из этих списков используются при создании запроса.

Запрос формируется автоматически при работе с описанными элементами управления. Текст запроса доступен для просмотра и редактирования на странице SQL Query.

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

Компонент TDecisionCube формирует размерности при открытии набора данных, причем созданное многомерное представление данных полностью работоспособно уже во время разработки. Для этого достаточно присвоить свойству Active Компонентов TDecisionQuery или TQuery значение True. После этого любой визуальный компонент многомерного представления начинает работать так же, как и во время выполнения.

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

Все основные настройки компонента выполняются при помощи специализированного редактора свойства DecisionMap.

Специализированный редактор свойства DecisionMap компонента TDecisionCube.

Статьи по Delphi (020)…

Для настроек размерностей используется страница Dimension Settings этого редактора. В расположенном слева списке Available Fields содержатся все поля набора данных. В элементах управления справа приведены параметры размерности для выбранного поля.

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

Неактивный список выбора Туре показывает, является ли поле основой для размерности или суммы.

Список выбора Active Type определяет, когда данные поля появляются в визуальных компонентах. Его элементы обозначают следующее:

Active — данные поля видны сразу после открытия формы и набора данных во время выполнения или сразу после открытия набора данных во время разработки;

AS Needed — данные поля становятся видны после выполнения пользователем во время выполнения или разработчиком во время разработки действий по отображению данных;

Inactive — данные поля не видны.

Однострочный редактор Format содержит строку форматирования для данных поля.

Комбинированный список Grouping необходим для того, чтобы определить, какие значения будут показаны. Варианты Year, Quarter, Month возможны только для полей с календарным типом данных.

Однострочный редактор Initial Value задает начальное значение для поля.

Страница Memory Control используется для управления расходом памяти для нужд компонента. Однострочные редакторы Dimensions, Summaries и Cells в ряду Maximum позволяют задать максимальное число размерностей, сумм и ячеек, соответственно.

Специализированный редактор свойства DecisionMap компонента TDecisionCube.

Статьи по Delphi (020)…

Аналогичные значения в ряду Current показывают текущее число этих структур.

Аналогичные значения в ряду Active+Needed показывают общее возможное число размерностей, сумм и ячеек.

Значения в ряду Active показывают число видимых размерностей сумм и ячеек.

Кнопка Get Cell Counts выполняет запрос, который возвращает число ячеек в кросстабе.

Группа радиокнопок Designer Data Options задает режим показа данных во время разработки:

Display Dimension Names — отображаются только названия размерностей;

Display Names and Values — отображаются названия размерностей и значения;

Display Names, Values, and Totals — отображаются названия, значения и суммы размерностей;

Run Time Display Only — визуализация данных осуществляется только во время выполнения.

Подготовленный к использованию для многомерного отображения набор данных необходимо связать с визуальными компонентами. Это делается при помощи компонента TDecisionSource. Через один такой компонент с набором данных можно связать несколько визуальных компонентов (см. табл. 30.1).

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

Компонент TDecisionQuery.

Компонент доступа к данным TDecisionQuery предназначен для создания набора данных, который был бы пригоден для многомерного представления. Для создания набора данных используется запрос SQL. Требования к запросу приведены выше.

Этот компонент является прямым наследником компонента TQuery и не имеет собственных свойств и методов. Для создания запросов можно воспользоваться специализированным редактором, который автоматизирует этот процесс.

Компонент TDecisionCube.

Компонент TDecisionCube осуществляет преобразование набора данных, который содержится в компоненте TDecisionQuery, к виду, доступному для отображения визуальными компонентами многомерного представления данных (табл. 30.2). Обычную таблицу набора данных компонент преобразует в многомерный кросстаб. Число размерностей создаваемого кросстаба зависит от числа полей данных набора данных. Значения в ячейках кросстаба зависят от типа агрегатной функции в запросе SQL.

Property Active: Boolean; Разрешает или запрещает преобразование набора данных в кросстаб.

Property BinData: Boolean; Значение True означает, что хотя бы одна размерность находится в свернутом состоянии (данные не отображаются).

Property Capacity: Integer; Определяет число байтов, используемых для хранения многомерного массива.

Property CurrentSuramary: Integer; Содержит индекс текущей суммы кросстаба.

Property DataSet: TDataSet; Ссылка на экземпляр набора данных, который отображается в кросстабе.

Type TCubeDesignState = (dsNoData, dsMetaData, dsDimensionData, dsAHData);

Property DesignState: TCubeDesignState; Задает режим отображения данных в кросстабе:

DsNoData — во время разработки данные не видны;

DsMetaData — видны названия размерностей;

DsDimensionData — видны названия размерностей и значения, суммы не видны;

DsAHData — видны все данные.

Property DimensionCount: Integer; Возвращает число размерностей.

Property DimensionMap: TCubeDims; Индексированный список ссылок на объекты параметров размерностей.

Property DimensionMapCount: Integer; Общее число полей набора данных, включая поля размерностей и сумм.

Property MaxCells: Integer; Задает максимальное число ячеек кросстаба.

Property MaxDimensions: Integer;

Задает максимальное число размерностей.

Property MaxSummaries: Integer; Задает максимальное число сумм.

Property ShowProgressDialog: Boolean; При значении True при подготовке кросстаба отображается индикатор.

Property SummaryCount: Integer; Возвращает число активных сумм кросстаба.

Function GetDetailSQL (ValueArray : TSmalllntArray; SelectList: string; bActive: Boolean) : string; Возвращает текст запроса SQL, который может быть использован для создания набора данных, включающего данные из кросстаба без сумм.

Function GetSQL(ValueArray: TSrralllntArray; bActive: Boolean): string;

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

Procedure ShowCubeDialog;

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

Procedure Refresh (DimensionMap : TCubeDims; bForce: Boolean); Обновляет список объектов параметров размерностей.

Type TCubeRefreshEvent = procedure (DataCube: TCustomDataStore; DimMap: TCubeDims) of object;

Property OnRefresh: TCubeRefreshEvent; property AfterClose: TCubeNotifyEvent; Вызывается сразу после закрытия компонента (Active := False).

Property AfterOpen: TCubeNotifyEvent; Вызывается сразу после открытия компонента (Active := False).

Property BeforeClose: TCubeNotifyEvent ;Вызывается перед закрытием компонента (Active := False).

Property BeforeOpen: TCubeNotifyEvent; Вызывается перед открытием компонента (Active := False).

TErrorAction = (eaFail, eaContinue) ;

TCapacityErrorEvent = procedure (var EAction: TErrorAction) of object;

Property OnLowCapacity: TCapacityErrorEvent ;

Вызывается после того, как занимаемый кросстабом объем памяти превысит заданный предел.

При помощи методов GetDetailsQL и GetSQL можно получить тексты запросов, которые возвращают набор данных, соответствующий кросстабу с заданным параметрами состояниями. Массив vaiueArray содержит условия для полей размерностей. Первой размерности соответствует первый элемент массива, второй размерности — второй элемент и т. д. Если значение элемента меньше нуля, то в результат запроса попадают все значения поля размерности. Значение элемента, равное или больше нуля, определяет индекс значения поля размерности. Параметр selectList содержит разделенный запятыми список дополнительных полей, которые нужно включить в запрос. Параметр bActive накладывает дополнительное ограничение на размерности. При значении True в результат запроса автоматически (без использования параметра selectList) попадают только активные размерности.

Ключевым свойством компонента является свойство DecisionMap, которое позволяет установить параметры размерностей и максимальный размер используемой памяти. Для этих целей применяется специализированный редактор (см. рис. 30.4).

Это свойство представляет собой экземпляр класса TCubeDims, который инкапсулирует индексированный список экземпляров объектов TCubeDim, каждый из которых содержит информацию о параметрах одной размерности. Основные свойства этого класса:

Type TActiveFlags = (diActive, diAsNeeded, dilnactive);

Property ActiveFlag: TActiveFlags;

Определяет режим отображения данных размерности.

Property BaseName: string;

Содержит имя поля размерности в таблице базы данных.

Property BinFormat: string;

Определяет способ форматирования диапазона значений размерности.

Type TBinType = (binNone, binYear, binQuarter, binMonth, binSet, binCustom) ;

Property BinType: TBinType;

Определяет способ группирования данных в размерности.

Type TDimFlags = (dimDimension, dimSum, dimCount, dimAverage, dimMin, dimMax, dimGenericAgg, dimUnknown) ;

Property DimensionType: TDimFlags ;

Определяет тип размерности.

Property FieldName: String; Содержит имя поля в наборе данных.

Property FieldType: TFieldType; Определяет тип поля.

Property Format: String; Задает форматирование данных размерности.

Property Loaded: Boolean; Значение True говорит о том, что данный элемент загружен в многомерный набор данных.

Property StartDate: TDate;Определяет начальный элемент для группировки по дате.

Property StartValue: String;Определяет начальный элемент : для группировки по значению.

Property ValueCount: Integer;Возвращает число уникальных элементов в размерности.

Компонент TDecisionSource.

Компонент TDecisionSource предназначен для связывания визуальных компонентов многомерного представления с компонентом TDecisionCube (табл. 30.4). Кроме того, за счет возможности подключения к этому компоненту нескольких визуальных компонентов одновременно, при изменении состояния одного визуального компонента осуществляется синхронизация многомерного представления во всех остальных компонентах.

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

Основные свойства компонента TDecisionSource.

Type TDecisionControlType= (xtCheck, xtRadio, xtRadioEx) ;

Property ControlT ype: TDecisionControlType;

Определяет способ управления отдельной размерностью в компоненте TDecisionGrid.

Property CurrentSum: Integer;

Содержит индекс текущей суммы в компоненте TDecisionGrid.

Property DecisionCube: TDecisionCube;

Связывает данный компонент с компонентом TDecisionCube. Содержит ссылку на экземпляр компонента TDecisionCube.

Property Ready: Boolean;

Значение True означает, что данный компонент связан с активным компонентом TDecisionCube.

Property SparseCols: Boolean;

При значении True из компонента TDecisionGrid удаляются пустые колонки.

Property SparseRows: Boolean;

При значении True из компонента TDecisionGrid удаляются пустые строки.

Компонент имеет средства для управления состоянием многомерного представления в визуальных компонентах. Для этого используется свойство ControlType. Рассмотрим его возможные значения:

Xtcheck — щелчок на кнопках размерности в компонентах TDecisionGrid и TDecisionPivot приводит к открытию или закрытию размерности;

XtRadio — щелчок на кнопках размерности в компонентах TDecisionGrid и TDecisionPivot приводит к открытию или закрытию данной размерности и закрытию всех остальных в этом направлении;

XtRadioEx — щелчок на кнопках размерности в компонентах TDecisionGrid и TDecisionPivot приводит к открытию или закрытию данной размерности и закрытию или открытию всех остальных размерностей в этом направлении.

Отображение данных.

При работе с кросстабом пользователь имеет дело с двумя визуальными компонентами многомерного представления данных. Это компонент TDecisionGrid, который представляет данные в табличном виде, и компонент TDecisionGraph, который представляет данные в виде графика.

С компонентом TDecisionCube они связаны при помощи компонента TDecisionSource.

Данные в визуальных компонентах появляются после открытия набора данных в соответствующем компоненте TDecisionQuery. Причем эти компоненты полностью работоспособны уже во время разработки приложения.

Компонент TDecisionGrid.

Компонент TDecisionGrid предназначен для многомерного представления данных в табличном виде. Параметры отображаемого набора данных (какие размерности будут видны при открытии, как группировать данные, как управлять размерностями) настраиваются при помощи других компонентов многомерного представления. В компоненте TDecisionGrid можно настроить только свойства самой сетки.

Для управления графиком во время выполнения можно использовать компонент TDecisionPivot.

Компонент TDecisionGrid является предком класса TCustomGrid и поэтому обладает всеми базовыми свойствами и методами, присущими сетке.

Для доступа к значению каждой ячейки используется свойство cells. Адресация ячеек осуществляется с левой верхней ячейки, которая имеет индексы [0,0].

Свойство Dimensions является экземпляром объекта TDisplayDims, который инкапсулирует индексированный список указателей на экземпляры объектов TDispiayDim. Каждый такой объект содержит важнейшие визуальные свойства размерностей. При щелчке на кнопке в однострочном редакторе свойства в Инспекторе объектов разворачивается список всех таких объектов.

Компонент TDecisionGraph.

Компонент TDecisionGraph создает график на основе многомерного представления набора данных. Конкретный вид графика (назначение горизонтальной и вертикальной осей) зависит от настроек компонентов TDecisionCube и TDecisionPivot. По умолчанию к оси абсцисс привязывается первая вертикальная размерность, к оси ординат — первая сумма. Первая горизонтальная размерность отображается в легенде графика.

Одним из предков компонента TDecisionGraph является класс TChart, от которого унаследованы все многочисленные свойства и методы для настройки графика.

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

Property DecisionSource: TDecisionSource;

Которое ссылается на экземпляр компонента источника данных.

Сразу после подключения автоматически строится график с осями, заданными по умолчанию.

Для управления графиком во время выполнения можно использовать компонент TDecisionPivot.

Управление данными.

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

Взаимное положение и расположение размерностей по сторонам кросстаба никак не связано с местом полей в запросе компонента TDecisionQuery.

Все операции по управлению многомерным представлением сосредоточены в одном компоненте — TDecisionPivot (см. рис. 30.2). В некоторой степени это аналог компонента TDBNavigator, только TDecisionPivot управляет не записями набора данных, а размерностями многомерного представления данных.

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

Компонент TDecisionPivot.

Компонент TDecisionPivot предоставляет пользователю средства управления размерностями многомерного представления данных. В стандартном состоянии компонент представляет собой панель, разделенную на три части (табл. 30.6). Каждая часть имеет собственный набор кнопок.

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

Выбор поля приводит к изменению значений в ячейках кросстаба. Например, выбор поля с функцией зим изменит значения в ячейках на суммы полей, поле с функцией COUNT произведет подсчет количества элементов в полях.

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

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

Кнопка в нажатом состоянии показывает размерность. Одновременно отображается и общая сумма по размерности.

Размерности можно менять местами и перемещать с вертикали на горизонталь и обратно. Для этого можно выбрать команду Moved to Column Area из всплывающего меню кнопки. Во время выполнения можно использовать обычное перетаскивание кнопок при помощи мыши.

Всплывающее меню кнопки размерности имеет еще одну команду — Drilled In. По этой команде размерность переходит в режим детального просмотра по каждому значению поля. Конкретное значение можно выбрать из списка, который открывается при щелчке на кнопке. В этом случае суммы в ячейках кросстаба рассчитываются не по всей размерности, а только по выбранному значению.

©Drkb::02457.

Перемещение контролов мышкой во время выполнения приложения?

Для этого необходимо перехватить событие OnMouseDown, запомнив координаты x и y и захватить мышку. После этого можно будет отслеживать движение мышки при помощи события OnMouseMove, перемещая контрол пока срабатывает событие OnMouseUp. Затем надо поместить контрол на своё окончательное место и снять захват мышки.

Следующий пример показывает как мышкой двигать компонент TButton по форме.

Code: Type. TForm1 = class(TForm). Button1: TButton; Procedure Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Procedure Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Private. { Private declarations }. Public. { Public declarations }. MouseDownSpot : TPoint; Capturing : bool; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If ssCtrl in Shift then begin. SetCapture(Button1.Handle); Capturing := true; MouseDownSpot.X := x; MouseDownSpot.Y := Y; End; End; Procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If Capturing then begin. Button1.Left := Button1.Left - (MouseDownSpot.x - x); Button1.Top := Button1.Top - (MouseDownSpot.y - y); End; End; Procedure TForm1.Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If Capturing then begin. ReleaseCapture; Capturing := false; Button1.Left := Button1.Left - (MouseDownSpot.x - x); Button1.Top := Button1.Top - (MouseDownSpot.y - y); End; End;

Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?

Как добавить документ в меню Пуск -> Документы?

Используйте функцию SHAddToRecentDocs.

Code: Uses ShlOBJ; Procedure TForm1.Button1Click(Sender: TObject); Var. S : string; Begin. S := 'C:\DownLoad\ntkfaq.html'; SHAddToRecentDocs(SHARD_PATH, pChar(s)); End;

Как очистить пункт меню Документы кнопки Пуск?

Вызовите Windows API функцию SHAddToRecentDocs() передав nil вместо имени файла в качестве параметра.

Code: Uses ShlOBJ; Procedure TForm1.Button1Click(Sender: TObject); Begin. SHAddToRecentDocs(SHARD_PATH, nil); End;

Как работать с буфером обмена (clipboard)?

Этот пример использует картинку, кнопку и компонент shape на форме. Когда пользователь кликает по кнопке, то изображение формы сохраняется в в переменной FormImage и копируется в буфер обмена (Clipboard). Затем изображение формы копируется обратно в компонент картинки, тем самым создавая интересный эффект, особенно, если кнопку понажимать несколько раз.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. FormImage: TBitmap; Begin. FormImage := GetFormImage; Try. Clipboard.Assign(FormImage); Image1.Picture.Assign(Clipboard); Finally. FormImage.Free; End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Shape1.Shape := stEllipse; Shape1.Brush.Color := clLime; Image1.Stretch := True; End;

Как программно реализовать Cut, Copy и Paste?

Следущие операции производятся с активным контролом на форме:

Code: Procedure TForm1.Cut1Click(Sender: TObject); Begin. SendMessage (ActiveControl.Handle, WM_Cut, 0, 0); End; Procedure TForm1.Copy1Click(Sender: TObject); Begin. SendMessage (ActiveControl.Handle, WM_Copy, 0, 0); End; Procedure TForm1.Paste1Click(Sender: TObject); Begin. SendMessage (ActiveControl.Handle, WM_Paste, 0, 0); End;

Буфер обмена (Clipboard) и TMemoryStream.

Обычно, это нужно для того, чтобы запихнуть в буфер обмена данные собственного формата. Сначала необходимо зарегистрировать этот формат при помощи функции RegisterClipboardFormat():

CF_MYFORMAT := RegisterClipboardFormat('My Format Description');

Затем необходимо проделать следующие шаги:

1. Создать поток (stream) и записать в него данные.

2. Создать в памяти глобальный буфер и скопировать в него поток (stream).

3. При помощи Clipboard.SetAsHandle() поместить глобальный буфер в буфер обмена.

Пример:

Code: Var. Hbuf : THandle; Bufptr : Pointer; Mstream : TMemoryStream; Begin. Mstream := TMemoryStream.Create; Try. {-- Записываем данные в mstream. --}. Hbuf := GlobalAlloc(GMEM_MOVEABLE, mstream.size); Try. Bufptr := GlobalLock(hbuf); Try. Move(mstream.Memory^, bufptr^, mstream.size); Clipboard.SetAsHandle(CF_MYFORMAT, hbuf); Finally. GlobalUnlock(hbuf); End; Except. GlobalFree(hbuf); Raise; End; Finally. Mstream.Free; End; End;

Как работать с реестром Windows?

Вот небольшой пример работы с системным реестром;

Code: Uses. Registry, Windows; Procedure TForm1.Button1Click(Sender: TObject); Var. Registry: TRegistry; Begin. { создаём объект TRegistry }. Registry := TRegistry.Create; { устанавливаем корневой ключ; напрмер hkey_local_machine или hkey_current_user }. Registry.RootKey := hkey_local_machine; { открываем и создаём ключ }. Registry.OpenKey('software\MyRegistryExample',true); { записываем значение }. Registry.WriteString('MyRegistryName','MyRegistry Value'); { закрываем и освобождаем ключ }. Registry.CloseKey; Registry.Free; End; // для удаления ключа используется функция Registry.DeleteKey.

©Drkb::02268.

Взято из http://forum.sources.ru.

Автозапуск Windows: помещение и удаление програм из автозапуска.

Для этого надо добавить ключ в реестр:

Code: Procedure SetAutorun(aProgTitle,aCmdLine: string; aRunOnce: boolean ); Var. HKey: string; HReg: TRegIniFile; Begin. If aRunOnce then hKey := 'Once' Else. HKey := ''; HReg := TRegIniFile.Create( '' ); HReg.RootKey := HKEY_LOCAL_MACHINE; HReg.WriteString('Software\Microsoft\Windows\CurrentVersion\Run' + hKey + #0, AProgTitle, ACmdLine ); HReg.destroy; End;

2D Бампмэппинг ( Bumpmapping ).

2D Бампмэппинг ( Bumpmapping ) Статьи по Delphi (020)…

Чтобы сделать правильный 2d бампмэппинг надо посчитать нормаль для каждого пиксела в bumpmap (карте высот) и для вычисления цвета каждого пиксела использовать угол между источником света и данной нормалью.

Для бампмэппинга в нашем случае используется источник света, бесконечно близкий к освещаемой плоскости: координаты нормали nx и ny просто разность высот между соседними пикселaми в bumpmap по осям X и Y.

Так как нормаль - просто вектор направления, и ее длина равна единице, то nz=1-sqrt(nx2 + ny2).

1. Заранее вычисляем интенсивность света (light map) по вышеприведенной формуле. (Световое пятно с максимальной интенсивностью в центре). Полагаем как обычно, что интенсивность зависит от n_z. Пусть размер таблички будет для удобства 256x256.

2. Подбирая из lightmap интенсивность по формуле: outvalue = lightmap[n_x+128][n_y+128] (если использовать нормали в диапазоне -128...+127) мы получим корректную картину освещения для бесконечно близкого источника.

n_x = bumpmap[x+1][y] - bumpmap[x-1][y] n_y = bumpmap[x][y+1] - bumpmap[x][y-1] Конечный цвет определяется так: outvalue:=lightmap[(n_x-(lightx-currentx))][(n_y-(lighty-currenty))]. Также нужно проверить, находимся ли мы внутри диапазона lightmap. Вот пример:

Code: Program Bumpy_Surface; {Ничего не USES}. Type Tscr=array[0..199,0..319] of byte; SegmentT = Array[0..65534] of byte; Virseg = ^SegmentT; Var. Scr:Tscr absolute $A000:0000; Buf:Tscr; Ilx,ily:integer; I,j,k,nx,ny,nz,rx,ry,x,y,lx,ly,x1,y1:integer; Tx,ty,tz:real; Var segm,offs:integer; Segment : Virseg; Litemap : word; Procedure SetUpSegment(VAR segname:virseg;VAR add : word); Begin GetMem (Segname,65534); add := seg (Segname^); end; Procedure wait; assembler; Asm mov dx,3DAh; @l1:in al,dx;and al,08h;jnz @l1; @l2:in al,dx;and al,08h;jz @l2;end; Procedure SetMode (Mode:word);assembler; asm mov ax,Mode; int 10h end; Procedure FillBox(x,y,w,h:integer; color:byte); Var i,j,k:integer; Begin for i:=y to y+h-1 do for j:=x to x+w-1 do buf[i,j]:=color; end; Procedure Print(x,y:integer; s:string; xs,ys:integer; color:byte); Var i,j,k,c,px,py:integer; b:byte; Begin px:=x;py:=y; for k:=1 to length(s) do begin c:=ord(s[k]); For i:=0 to 7. Do begin b:=mem[segm:offs+c*8+i]; for j:=0 to 7 do begin. If b shl j and 128<>0. Then FillBox(x,y,xs,ys,color); x:=x+xs; end; X:=px; y:=y+ys; end; y:=py; px:=px+xs*8; x:=px; end; End; Procedure SetGradientPalette; var k,r,g,b:byte; Begin asm mov dx,03c8h; xor al,al;out dx,al;end; R:=0; g:=0; for k:=0 to 255 do begin b:=(k*63 div 255); {r:=b; g:=b;{} if k>200 then begin r:=r+1;g:=g+1;end; Asm mov dx,03c9h; mov al,r;out dx,al; Mov al,g;out dx,al; mov al,b;out dx,al end; End;end; Procedure Blur; Var i,j,k:integer; Begin for i:=0 to 199 do for j:=0 to 319 do. Buf[i,j]:=(buf[i-1,j]+buf[i+1,j]+buf[i,j-1]+buf[i,j+1]) div 4; End; Procedure ASMBumpmapping;assembler; Asm. {few times faster ;) }. Mov ax, seg buf. Mov es,ax. Mov ax, offset buf. Mov bx,320*3. Add ax,bx. Mov di,ax. Mov si,bx. Mov dx,199. Sub dx,5. @1: mov cx,320. @2: xor bh,bh; xor ah,ah; Mov al, es:[di+1]. Mov bl, es:[di-1]. Sub ax,bx. Sub ax,320; add ax,cx; add ax,lx; add ax,128; Cmp ax,255; jc @ok1; mov ax,255; @ok1: Push ax. Xor ah,ah; Mov al, es:[di+320]. Mov bl, es:[di-320]. Sub ax,bx. Sub ax,197; add ax,dx; add ax,ly; add ax,128; Cmp ax,255; jc @ok2; mov ax,255; @ok2: Pop bx. Mov bh,bl; mov bl,al. Push es. Mov ax, litemap. Mov es,ax. And bx,0FFFEh. Mov bx,[es:bx]. Mov ax, 0A000h. Mov es,ax. Mov [es:si],bx. Pop es. Inc di. Inc si. Loop @2. Dec dx; Jnz @1. Mov ax,$0a000. Mov es,ax. Xor ax,ax. Mov [es:si-1],ax. End;{asm Bumpmaping}. Procedure Bumpmapping; Begin. {Bumpmapping}. For y:=0+3 to 199-3 do begin. For x:=0 to 319 do begin. Nx:=buf[y+1,x]-buf[y-1,x]; Ny:=buf[y,x+1]-buf[y,x-1]; Nx:=nx-x+lx; Ny:=ny-y+ly; Nx:=nx+128; Ny:=ny+128; If (nx<0) or (nx>255) then nx:=0; If (ny<0) or (ny>255) then ny:=0; Scr[y,x]:=mem[litemap:nX+nY*256]; end; End;{ Bumpmapping }. End; BEGIN. {Достанем адрес знакогенератора}. Asm. Mov ax,$1130; Mov bh,03h; Int 10h; Mov segm,es; Mov offs,bp; End; {установим режим и палитру}. Setmode($13); setgradientpalette; {Сгенерируем световое пятно}. SetUpSegment(Segment,litemap); For y:=0 to 255 do for x:=0 to 255 do begin. TX:=(x-128)/128.0; TY:=(y-128)/128.0; TZ:=1-sqrt(tX*tX+tY*tY); If (tZ<0) then tZ:=0; mem[litemap:x+y*256]:=round(tz*254); end; { Очистим буфер }. Fillchar(buf,64000,0); {набросаем точек}. For i:=0 to 10000 do fillbox(random(320),random(200),1,1,255); {...и размоем их}. Blur; {Напишем текст}. Print(60,65,'BUMPY',5,5,255); Print(47,115,'SURFACE',4,4,255); {...и опять размоем}. Blur;blur;blur; Ilx:=5;ily:=5; Ly:=100;lx:=80; REPEAT. {move(buf,scr,64000);}. Wait; {Bumpmapping;}. ASMBumpmapping; Lx:=lx+ilx;if (lx>320) or (lx<0) then ilx:=-ilx; Ly:=ly+ily;if (ly>200) or (ly<0) then ily:=-ily; UNTIL port[$60]=1;{ESC}. {сбросим буфер клавиатуры}. Memw[$000:$041a]:=memw[$000:$041c]; Setmode($3); END.

Соединение с сервером баз данных.

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

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

Property ConnectionName: string;

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

Property DriverName: string; определяет используемый драйвер;

Property LibraryName: string; задает динамическую библиотеку драйвера dbExpress;

Property VendorLib: string; определяет динамическую библиотеку клиентского ПО сервера.

Property Params: TStrings; список этого свойства содержит настройки для выбранного соединения.

При необходимости все перечисленные свойства можно установить дополнительно.

Разработчик может дополнять и изменять список настроенных соединений. Для этого используется специализированный Редактор соединений dbExpress Connections (рис. 17.1). Он открывается после двойного щелчка на компоненте TSQLConnection или выбора команды Edit Connection Properties из всплывающего меню компонента.

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

Список соединений в левой части соответствует списку выбора свойства ConnectionName в Инспекторе объектов. Настройки соединения из правой части отображаютсяв свойствее Params.

Настроенные соединения и их параметры сохраняются в файле \Borland Shared\DBExpress\dbxconnections.ini.

Примечание.

При установке Delphi 7 поверх Delphi 6 сведения о соединениях из старого файла dbxconnections.ini добавляются в новый.

Конкретные значения настроек соединений зависят от используемого сервера БД и требований приложения (табл. 17.2).

Настройка соединения dbExpress.

Общие настройки.

BlobSize Задает ограничение на объем пакета данных для данных BLOB.

DriverName Имя драйвера.

ErrorResourceFile Файл сообщений об ошибках.

LocaleCode Код локализации, определяющий влияние национальных символов на сортировку данных.

User Name Имя пользователя.

Password Пароль.

DB2.

Database Имя клиентского ядра.

DB2 Translsolation Уровень изоляции транзакций.

Informix.

HostName Имя компьютера, на котором работает сервер Informix.

Informix Translsolation Уровень изоляции транзакции.

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

Interbase.

CommitRetain Задает поведение курсора по завершении транзакции. При значении True курсор обновляется, иначе — удаляется.

Database Имя файла базы данных (файл GDB).

InterBase Translsolation Уровень изоляции транзакции.

RoleName Роль пользователя.

SQLDialect Используемый диалект SQL. Для IntreBase 5 возможно только одно значение -1.

WaitOnLocks Разрешение на ожидание занятых ресурсов.

Microsoft SQL Server 2000.

Database Имя базы данных.

HostName Имя компьютера, на котором работает сервер MS SQL Server 2000.

MSSQL Translsolation Уровень изоляции транзакции.

OS Autenification Использование учетной записи текущего пользователя операционной системы (домена или Active Directory) при доступе к ресурсам сервера.

MySQL.

Database Имя базы данных.

HostName Имя компьютера, на котором работает сервер MySQL.

Oracle.

AutoCommit Флаг завершения транзакции. Устанавливается только сервером.

BlockingMode Задает режим завершения запроса. При значении True соединение дожидается окончания запроса (синхронный режим), иначе — начинает выполнение следующего (асинхронный режим).

Database Запись базы данных в файле TNSNames.ora.

Multiple Transaction Поддержка управлением несколькими транзакциями в одной сессии.

Oracle Translsolation Уровень изоляции транзакций.

После выыбора настроенного соединения или выбора типа сервера и настройки параметров соединения компонент TSQLConnection готов к работе.

Property Connected: Boolean;

Открывает соединение с сервером при значении True. Аналогичную операцию выполняет метод.

Procedure Open;

После открытия соединения все компоненты dbExpress, инкапсулирующие наборы данных и связанные с открытым компонентом TSQLConnection, получают доступ к базе данных.

Соединение закрывается тем же свойством connected или методом.

Procedure Close;

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

Property BeforeConnect: TNotifyEvent;

Property AfterConnect: TNotifyEvent;

Property BeforeDisconnect: TNotifyEvent;

Property AfterDisconnect: TNotifyEvent;

Например, на стороне клиента можно организовать проверку пользователя приложения:

Procedure TForml.MyConnectionBeforeConnect(Sender: TObject);

Begin.

If MyConnection.Params.Values['User_Name']) <> DefaultUser then.

Begin.

MessageDlg('Wrong user name', mtError, [mbOK], 0);

Abort;

End;

Свойство.

Property LoginPrompt: Boolean;

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

О текущем состоянии соединения можно судить по значению свойства.

TConnectionState = (csStateClosed, csStateOpen, csStateConnecting, csStateExecuting, csStateFetching, csStateDisconnecting);

Property ConnectionState: TConnectionState;

Параметры соединения можно настраивать на этапе разработки в Инспекторе объектов или Редакторе соединений (см. рис. 17.1). Также это можно сделать и непосредственно перед открытием соединения, используя свойство Params или метод.

Procedure LoadParamsFromlniFile(AFileName : String = '');

Который загружает заранее подготовленные параметры из INI-файла. Проверить успешность этой операции можно при помощи свойства.

Property Params Loaded: Boolean;

Значение True которого сигнализирует об успехе загрузки.

Procedure TForml.StartBtnClickfSender: TObject);

Begin.

If MyConnection.Params.Values['DriverName'] = " then.

MyConnection.LoadParamsFromlniFile('c:\Temp\dbxalarmconnections.ini');

If MyConnection.ParamsLoaded then.

Try.

MyConnection.Open;

Except.

MessageDlgt'Database connection error', mtError, [mbOK], 0);

End;

Создание окон произвольной формы (Статья).

Вопрос создания непрямоугольных окон часто интересует начинающих программистов и время от времени обсуждается на форумах разработчиков в среде Delphi. А вообще, нужно ли это кому-нибудь? Ответ - да! Это уже было нужно таким известным фирмам, как Symantec (Norton Utilities, Norton CrashGuard), Microsoft (Приложение ".

Часы" в Windows NT4 может принимать круглую форму, Deluxe CD Player из MS Plus! 98 имеет вид прямоугольника со скругленными краями). У Borland Jbuilder 2 в окне начальной загрузки стрела крана "выскочила" за пределы прямоугольника. Программы для видеокарт TV Capture фирмы AverMedia имитируют пульт управления. Окно переводчика Magic Goody принимает вид гуся, разгуливающего по экрану.

Список можно продолжить, а вывод такой: окно "хитрой" формы – это "изюминка" оформления Вашей программы, нечто запоминающееся, дополнительный плюс в борьбе за потенциального покупателя. Главное в этом – не переборщить. Вряд ли будет удобно работать с текстовым редактором в треугольном окне. Окна произвольной формы неплохо смотрятся при начальной загрузке (Splash) и, возможно, в качестве окна "О программе … ".

Как это делается? Средствами Delphi – достаточно просто. Приведенные ниже примеры можно также перевести в C++ Builder или Visual C++.

Code: Type. TForm1 = class(TForm). // Данную процедуру будем использовать для задания. // формы окна. Procedure FormCreate(Sender: TObject); Protected. // Данную процедуру необходимо переопределить, // чтобы иметь возможность перемещать окно "мышкой". // не только за за заголовок, который в данном. // случае отсутствует. Procedure WMNCHitTest(var Message: TWMNCHitTest);message WM_NCHITTEST; Private. { Private declarations }. Public. { Public declarations }. End;

Как связать определённое расширение файлов с моим приложением?

В Win32 необходимо создать новую запись в реестре в корневом ключе HKEY_CLASSES_ROOT, которая будет указывать на расширение файла, командную строку и иконку, которая будет отображаться для этого расширения. В Win16, просто включить расширение файла и командную строку в секцию [Extensions] в Win.ini.

Пример:

Code: Uses. Registry, {For Win32}. IniFiles; {For Win16}. {Для Win32}. Procedure TForm1.Button1Click(Sender: TObject); Var. Reg: TRegistry; Begin. Reg := TRegistry.Create; Reg.RootKey := HKEY_CLASSES_ROOT; Reg.LazyWrite := false; {Add Program Support}. Reg.OpenKey('.bor\shell\open\command', true); {Имя файла будет передавать в приложение как первый параметр}. Reg.WriteString('', 'C:\Program Files\Borland\Delphi 3\Project1.exe %1'); {Добавляем отображаемую иконку}. Reg.CloseKey; Reg.OpenKey('.bor\DefaultIcon',true); {Для отображения используем первую иконку в нашем приложении}. Reg.WriteString('', 'C:\Program Files\Borland\Delphi 3\Project1.exe,0'); Reg.CloseKey; Reg.free; End; {Для Win16}. Procedure TForm1.Button2Click(Sender: TObject); Var. WinIni : TIniFile; WinIniFileName : array[0..MAX_PATH] of char; S : array[0..64] of char; Begin. GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName)); StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName); WinIni.WriteString('Extensions', 'bor', 'C:\PROGRA~1\BORLAND\DELPHI~1\PROJECT1.EXE ^.bor'); WinIni.Free; StrCopy(S, 'Extensions'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); End;

Как добавить True Type шрифт в систему?

Чтобы установить шрифт в систему, необходимо скопировать файл шрифта в 'Windows\Fonts' и добавить ключ в реестр:

'Software\Microsoft\Windows\CurrentVersion\Fonts'

Этот ключ указывает на файл шрифта. Далее запускаем API функцию 'AddFontRecource'. В заключении нужно уведомить систему широковещательным сообщением.

Code: Uses Registry; Procedure TForm1.Button1Click(Sender: TObject); Var. HReg: TRegistry; HBool : bool; Begin. CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', hBool); HReg := TRegistry.Create; HReg.RootKey := HKEY_LOCAL_MACHINE; HReg.LazyWrite := false; HReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', False); HReg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); HReg.CloseKey; HReg.free; //Добавляем ресурс шрифта. AddFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); //Убираем блокировку ресурса. RemoveFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); End;

Как уведомить все приложения, что реестр был изменён?

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

Пример:

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. SendMessage(HWND_BROADCAST,WM_WININICHANGE,0,LongInt(PChar('RegistrySection'))); End;

Просмотрщик запущенных процессов.

Автор: Василий.

Программа не видна по Ctrl+Alt+Del, и сама оттуда же может спрятать любой из процессов(правда, не все с самого начала "светятся" по Ctrl+Alt+Del) или завершить его. Простой пример для знакомства с ToolHelp32.

В исходном коде есть недоработки, например, процедура Delproc получает в качестве параметра строку, затем переводит ее в целочисленный тип(integer), хотя можно передавать сразу число. Заморочка была в проверке числа-индекса на подлинность, а так как я выдрал часть кода из более ранней своей проги, я не стал это менять, а просто подогнал до рабочей версии. Оптимизацией кода вы можете заняться сами по желанию(вы можете, если хотите, а если не хотите, то вы не обязаны, вы посто могли бы... да... :))) Программа не работала в WinNT 4.0, но в Win9x работать должна.

Code: Unit main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, tlhelp32, StdCtrls, ComCtrls, Buttons; Type. TForm1 = class(TForm). ListBox1: TListBox; Button1: TButton; Button2: TButton; Button4: TButton; Button5: TButton; StatusBar1: TStatusBar; Button6: TButton; Procedure Button4Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Procedure Button2Click(Sender: TObject); Procedure Button1Click(Sender: TObject); Procedure Button5Click(Sender: TObject); Procedure ListBox1Click(Sender: TObject); Procedure Button6Click(Sender: TObject); Private. { Private declarations }. Procedure ListProcesses; Procedure Delproc(numb:string); Public. { Public declarations }. End; Var. Form1: TForm1; ProcessID:array[1..50] of integer; Function RegisterServiceProcess(dwProcessID,dwType:integer):integer;stdcall;external 'kernel32.dll'; Implementation. {$R *.DFM}. Procedure TForm1.delproc(numb:string); Var. C1:Cardinal; Pe:TProcessEntry32; S1,s2:string; X:integer; Begin. X:=0; Try. Strtoint(numb); Except. Statusbar1.SimpleText:='Invalid number'; Exit; End; C1:=CreateToolHelp32Snapshot(TH32CS_SnapProcess,0); If c1=INVALID_HANDLE_VALUE then. Begin. Statusbar1.SimpleText:='Process listing failed'; Exit; End; Try. Pe.dwSize:=sizeof(pe); If Process32First(c1,pe) then. Repeat. Inc(x); S1:=ExtractFileName(pe.szExeFile); S2:=ExtractFileExt(s1); Delete(s1,length(s1)+1-length(s2),maxInt); If x=strtoint(numb) then. If terminateprocess(OpenProcess(PROCESS_ALL_ACCESS,false,pe.th32ProcessID),1). Then begin. Statusbar1.SimpleText:='Process '+s1+' terminated.'; End. Else Statusbar1.SimpleText:=('Couldnt terminate process'+pe.szExeFile); Until not Process32Next(c1,pe); Finally CloseHandle(c1); End; End; Procedure Tform1.ListProcesses; Var c1:Cardinal; Pe:TProcessEntry32; S1,s2:string; X:integer; Begin. X:=0; C1:=CreateToolHelp32Snapshot(TH32CS_SnapProcess,0); If c1=INVALID_HANDLE_VALUE then. Begin. Statusbar1.SimpleText:=('Информация о процессах закрыта.'); Exit; End; Try. Pe.dwSize:=sizeof(pe); If Process32First(c1,pe) then. Repeat. Inc(x); S1:=ExtractFileName(pe.szExeFile); S2:=ExtractFileExt(s1); Delete(s1,length(s1)+1-length(s2),maxInt); Listbox1.Items.Add(Inttostr(x)+' '+s1+' : '+pe.szExeFile); ProcessId[x]:=pe.th32ProcessID; //ListBox1.Items.Add(inttostr(pe.th32ProcessID)); Until not Process32Next(c1,pe); Finally CloseHandle(c1); End; End; Procedure TForm1.Button4Click(Sender: TObject); Begin. Close; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Button1.Enabled:=false; Button5.Enabled:=false; Button6.Enabled:=false; ListProcesses; If not (csDesigning in ComponentState) then. RegisterServiceProcess(GetCurrentProcessID,1); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Listbox1.Clear; ListProcesses; End; Procedure TForm1.Button1Click(Sender: TObject); Var p:integer; Begin. //hide. With Listbox1 do. P:=Listbox1.Items.IndexOf(Listbox1.items[itemindex])+1; If not (csDesigning in ComponentState) then. RegisterServiceProcess(ProcessID[p],1); With Listbox1 do. StatusBar1.SimpleText:=(Listbox1.items[itemindex]+ ' hidden'); End; Procedure TForm1.Button5Click(Sender: TObject); Var p:integer; Begin. //show. With Listbox1 do. P:=Listbox1.Items.IndexOf(Listbox1.items[itemindex])+1; If not (csDesigning in ComponentState) then. RegisterServiceProcess(ProcessID[p],0); With Listbox1 do. StatusBar1.SimpleText:=(Listbox1.items[itemindex]+ ' shown'); End; Procedure TForm1.ListBox1Click(Sender: TObject); Begin. Button1.Enabled:=true; Button5.Enabled:=true; Button6.Enabled:=true; End; Procedure TForm1.Button6Click(Sender: TObject); Var p:integer; Begin. With Listbox1 do. P:=Listbox1.Items.IndexOf(Listbox1.items[itemindex])+1; Delproc(inttostr(p)); End; End.

Посылаем нажатия клавиш другому приложению.

Автор: Gert v.d. Venis.

Компонент Sendkeys:

Code: Unit SendKeys; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; Type. TSendKeys = class(TComponent). Private. Fhandle:HWND; L:Longint; Fchild: boolean; FChildText: string; Procedure SetIsChildWindow(const Value: boolean); Procedure SetChildText(const Value: string); Procedure SetWindowHandle(const Value: HWND); Protected. Public. Published. Procedure GetWindowHandle(Text:String); Procedure SendKeys(buffer:string); Property WindowHandle:HWND read fhandle write SetWindowHandle; Property IsChildWindow:boolean read fchild write SetIsChildWindow; Property ChildWindowText:string read fChildText write SetChildText; End; Procedure Register; Implementation. Var temps:string;{й utilizado para ser acessivel pelas funcs q sao. Utilizadas como callbacks}. HTemp:Hwnd; ChildText:string; ChildWindow:boolean; Procedure Register; Begin. RegisterComponents('Standard', [TSendKeys]); End; { TSendKeys }. Function PRVGetChildHandle(H:HWND; L: Integer): LongBool; Var p:pchar; I:integer; S:string; Begin. I:=length(ChildText)+2; GetMem(p,i+1); SendMessage(H,WM_GetText,i,integer(p)); S:=strpcopy(p,s); If pos(ChildText,s)<>0 then. Begin. HTemp:=H; Result:=False. End else. Result:=True; FreeMem(p); End; Function PRVSendKeys(H: HWND; L: Integer): LongBool;stdcall; Var s:string; I:integer; Begin. I:=length(temps); If i<>0 then. Begin. SetLength(s,i+2); GetWindowText(H, pchar(s),i+2); If Pos(temps,string(s))<>0 then. Begin. Result:=false; If ChildWindow then. EnumChildWindows(H,@PRVGetChildHandle,L). Else. HTemp:=H; End. Else. Result:=True; End else. Result:=False; End; Procedure TSendKeys.GetWindowHandle(Text: String); Begin. Temps:=Text; ChildText:=fChildText; ChildWindow:=fChild; EnumWindows(@PRVSendKeys,L); FHandle:=HTemp; End; Procedure TSendKeys.SendKeys(buffer: string); Var i:integer; W:word; D:DWORD; P:^DWORD; Begin. P:=@D; SystemParametersInfo( //get flashing timeout on win98. SPI_GETFOREGROUNDLOCKTIMEOUT, 0, P, 0); SetForeGroundWindow(fHandle); For i:=1 to length(buffer) do. Begin. W:=VkKeyScan(buffer[i]); Keybd_event(w,0,0,0); Keybd_event(w,0,KEYEVENTF_KEYUP,0); End; SystemParametersInfo( //set flashing TimeOut=0. SPI_SETFOREGROUNDLOCKTIMEOUT, 0, Nil, 0); SetForegroundWindow(TWinControl(TComponent(Self).Owner).Handle); //->typecast working... SystemParametersInfo( //set flashing TimeOut=previous value. SPI_SETFOREGROUNDLOCKTIMEOUT, D, Nil, 0); End; Procedure TSendKeys.SetChildText(const Value: string); Begin. FChildText := Value; End; Procedure TSendKeys.SetIsChildWindow(const Value: boolean); Begin. Fchild := Value; End; Procedure TSendKeys.SetWindowHandle(const Value:HWND); Begin. FHandle:=WindowHandle; End; End.

Как сделать, чтобы запускалась только одна копия приложения?

Code: Var AtomText: array[0..31] of Char; Procedure LookForPreviousInstance; Var. PreviousInstanceWindow : hWnd; AppName : array[0..30] of char; FoundAtom : TAtom; Begin. // помещаем имя приложения в AtomText. StrFmt(AtomText, 'OnlyOne%s', [Copy(Application.Title,1,20)]); // Проверяем, не создано ли уже атома с таким именем приложения. FoundAtom := GlobalFindAtom(AtomText); If FoundAtom <> 0 then // эта копия приложения уже запущена. Begin. StrFmt(AppName,'%s', [Application.Title]); // изменяем текущий заголовок, чтобы FindWindow не видела его. Application.ShowMainForm := false; Application.Title := 'destroy me'; // ищем предыдущую копию приложения. PreviousInstanceWindow := FindWindow(nil,AppName); // Передаём фокус на предыдущую копию приложения. // завершаем текущую копию. Application.Terminate; If PreviousInstanceWindow <> 0 then. If IsIconic(PreviousInstanceWindow) then. ShowWindow(PreviousInstanceWindow,SW_RESTORE). Else SetForegroundWindow(PreviousInstanceWindow); End; // создаём глобальный атом, чтобы предотвратить запуск другой копии приложения. FoundAtom := GlobalAddAtom(AtomText); End; Constructor TForm.Create(AOwner: TComponent); Begin. Inherited; LookForPreviousInstance; ... End; Destructor TForm.Destroy; Var. FoundAtom : TAtom; ValueReturned : word; Begin. // не забудьте удалить глобальный атом. FoundAtom := GlobalFindAtom(AtomText); If FoundAtom <> 0 then ValueReturned := GlobalDeleteAtom(FoundAtom); Inherited Destroy; End;

Как разрешить / запретить переключение между задачами?

Только для ALT+TAB и CTRL+ESC).

Это не совсем профессиональный способ, но он работает! Мы просто эмулируем запуск и остановку скринсейвера.

Code: Procedure TaskSwitchingStatus( State : Boolean ); Var. OldSysParam : LongInt; Begin. SystemParametersInfo( SPI_SCREENSAVERRUNNING, Word( State ), @OldSysParam, 0 ); End;

Как получить / установить приоритет процесса?

Code: Const. PpIdle : Integer = -1; PpNormal : Integer = 0; PpHigh : Integer = 1; PpRealTime : Integer = 2; Function SetProcessPriority( Priority : Integer ) : Integer; Var. H : THandle; Begin. Result := ppNormal; H := GetCurrentProcess(); If ( Priority = ppIdle ) Then. SetPriorityClass( H, IDLE_PRIORITY_CLASS ). Else If ( Priority = ppNormal ) Then. SetPriorityClass( H, NORMAL_PRIORITY_CLASS ). Else If ( Priority = ppHigh ) Then. SetPriorityClass( H, HIGH_PRIORITY_CLASS ). Else If ( Priority = ppRealTime ) Then. SetPriorityClass( H, REALTIME_PRIORITY_CLASS ); Case GetPriorityClass( H ) Of. IDLE_PRIORITY_CLASS : Result := ppIdle; NORMAL_PRIORITY_CLASS : Result := ppNormal; HIGH_PRIORITY_CLASS : Result := ppHigh; REALTIME_PRIORITY_CLASS : Result := ppRealTime; End; End; Function GetProcessPriority : Integer; Var. H : THandle; Begin. Result := ppNormal; H := GetCurrentProcess(); Case GetPriorityClass( H ) Of. IDLE_PRIORITY_CLASS : Result := ppIdle; NORMAL_PRIORITY_CLASS : Result := ppNormal; HIGH_PRIORITY_CLASS : Result := ppHigh; REALTIME_PRIORITY_CLASS : Result := ppRealTime; End; End;

Как получить список процессов?

Code: Function IsRunning( sName : string ) : boolean; Var. Han : THandle; ProcStruct : PROCESSENTRY32; // from "tlhelp32" in uses clause. SID : string; Begin. Result := false; // Get a snapshot of the system. Han := CreateToolhelp32Snapshot( TH32CS_SNAPALL, 0 ); If han = 0 then. Exit; // Loop thru the processes until we find it or hit the end. ProcStruct.dwSize := sizeof( PROCESSENTRY32 ); If Process32First( han, ProcStruct ) then. Begin. Repeat. SID := ExtractFileName( ProcStruct.szExeFile ); // Check only against the portion of the name supplied, ignoring case. If uppercase( copy( sId, 1, length( sName ) ) ) = uppercase( sName ) then. Begin. // Report we found it. Result := true; Break; End; Until not Process32Next( han, ProcStruct ); End; // clean-up. CloseHandle( han ); End;

Ревизия интерфейсов (статья).

Ревизия интерфейсов.

Часть 1: Объявления, реализация и разрешение имен методов.

Я впервые написал об интерфейсах в апрельском выпуске Delphi Informant Magazine за 1998 год. Почти за два года произошло несколько важных событий. Первое - в Delphi 4 предоставлен новый и важный способ реализации интерфейса в классе. Второе, и возможно более важное - интерфейсы быстро выходят за рамки своего первоначального назначения: естественной поддержки COM (Компонентная Объектная Модель фирмы Майкрософт). В результате, видимо, пришло время для пересмотра этой важной темы.

Но только, что является интерфейсом и почему он так важен? Интерфейс - это определение методов и свойств, которые могут быть реализованы классом. Интерфейс предусматривает совместимость по назначению (часто называемую полиморфизмом) между различными объектами, которые реализуют общий интерфейс. Еще важнее, что интерфейсы обеспечивают полиморфизм без ограничений, обычно связываемых с полиморфизмом через наследование. Действительно, хотя два класса не наследуют методы от общего предка, к ним можно обращаться полиморфно в отношении метода, если этот метод определен для интерфейса обоих классов реализации. С другой стороны, интерфейсы позволяют определять свои методы и свойства абсолютно независимо от объекта реализации.

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

Почему в Delphi добавлены интерфейсы?

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

Эту концепцию трудно описать, но пример поможет ее проиллюстрировать. Рассмотрим ситуацию, когда Вы хотите создать группу компонент пользовательского интерфейса (UI), которые разделяют общие способности, такие как способность загрузки строковых данных из файла ресурсов. Кроме того, Вы можете захотеть предоставить новый метод, названный LoadStrings, в каждом из Ваших новых UI компонентов, и в реализации этого метода загрузить строки этих компонент из ресурсного файла, возможно основываясь на свойстве компонента Tag.

Пока все хорошо. Однако, другой аспект этой структуры - возможность инициирования процесса загрузки для каждого из Ваших компонент общей командой. В Delphi 1 и 2, где интерфейсы еще не были предоставлены, это было почти невозможно. Рассмотрим псевдокод на рисунке 1 (который будет компилироваться).

Code: // Псевдокод. Interface. Uses controls, stdctrls; Type. TNewButton = class(TButton). Public. Procedure LoadStrings; virtual; End; TNewLabel = class(TLabel). Public. Procedure LoadStrings; virtual; End; Implementation. Procedure TNewLabel.LoadStrings; Begin. // Код для загрузки строк NewLabel. // из файла ресурсов. End; Procedure TNewButton.LoadStrings; Begin. // Код для загрузки строк NewButton. // из файла ресурсов. End;

Как убрать мою программу из списка Alt+Ctrl+Del?

Code: Function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL'; Implementation. Procedure TForm1.Button1Click(Sender: TObject); Begin //Скрываем. If not (csDesigning in ComponentState) then. RegisterServiceProcess(GetCurrentProcessID, 1); End; Procedure TForm1.Button2Click(Sender: TObject); Begin //Опять показываем. If not (csDesigning in ComponentState) then. RegisterServiceProcess(GetCurrentProcessID, 0); End;

Как узнать имя файла текущего процесса?

Для этого существует функция GetModuleFileName, которая возвращает имя файла текущего процесса.

Code: Function GetModName: String; Var. FName: String; Nsize: cardinal; Begin. Nsize := 128; SetLength(fName,nsize); SetLength(fName, GetModuleFileName( Hinstance, Pchar(fName), Nsize)); Result := fName; End;

Как определить какие приложения уже запущены?

Code: Procedure TForm1.Button1Click(Sender: TObject); VAR. Wnd : hWnd; Buff: ARRAY [0..127] OF Char; Begin. ListBox1.Clear; Wnd := GetWindow(Handle, gw_HWndFirst); WHILE Wnd <> 0 DO. BEGIN {Не показываем:}. IF (Wnd <> Application.Handle) AND {-Собственное окно}. IsWindowVisible(Wnd) AND {-Невидимые окна}. (GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}. (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) {-Окна без заголовков}. THEN BEGIN. GetWindowText(Wnd, buff, sizeof(buff)); ListBox1.Items.Add(StrPas(buff)); END; Wnd := GetWindow(Wnd, gw_hWndNext); END; ListBox1.ItemIndex := 0; End;

Как создавать потоки без класса TThread?

Ниже приведены два примера, которые при создании потоков позволяют обойтись без класса TThread, используя API функции CreateThread, SuspendThread, ResumeThread и TerminateThread.

Пример 1:

Поместите на форму 2 окошка редактирования (edit) и 6 кнопок. Далее приведён сам код:

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Procedure incedit1;stdcall; Procedure incedit2;stdcall; Type. TForm1 = class(TForm). Button1: TButton; Edit1: TEdit; Edit2: TEdit; Button6: TButton; Button7: TButton; Button2: TButton; Button3: TButton; Button5: TButton; Button4: TButton; Procedure Button1Click(Sender: TObject); Procedure Button6Click(Sender: TObject); Procedure Button7Click(Sender: TObject); Procedure Button4Click(Sender: TObject); Procedure Button5Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Procedure Button3Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. Var. Th1,th2:cardinal; H1,h2:integer; Procedure incedit1; Var. I:integer; Begin. I:=0; While true do. Begin. Form1.edit1.text:=inttostr(i); I:=i+1; End; End; Procedure incedit2; Var. I:integer; Begin. I:=0; While true do. Begin. Form1.edit2.text:=inttostr(i); I:=i+1; End; End; {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. H1:=beginthread(nil,1024,@incedit1,nil,0,th1); H2:=beginthread(nil,1024,@incedit2,nil,0,th2); End; Procedure TForm1.Button6Click(Sender: TObject); Begin. Terminatethread(h1,0); End; Procedure TForm1.Button7Click(Sender: TObject); Begin. Terminatethread(h2,0); End; Procedure TForm1.Button4Click(Sender: TObject); Begin. Resumethread(h1); End; Procedure TForm1.Button5Click(Sender: TObject); Begin. Resumethread(h2); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Suspendthread(h1); End; Procedure TForm1.Button3Click(Sender: TObject); Begin. Suspendthread(h2); End;

Как программе удалить саму себя?

Первый способ:

Code: Uses. Windows, SysUtils; Procedure DeleteMe; Var. BatchFile: TextFile; BatchFileName: string; ProcessInfo: TProcessInformation; StartUpInfo: TStartupInfo; Begin. { создаём бат-файл в директории приложения }. BatchFileName := ExtractFilePath(ParamStr(0)) + '$$336699.bat'; { открываем и записываем в файл }. AssignFile(BatchFile, BatchFileName); Rewrite(BatchFile); Writeln(BatchFile, ':try'); Writeln(BatchFile, 'del "' + ParamStr(0) + '"'); Writeln(BatchFile, 'if exist "' + ParamStr(0) + '"' + ' goto try'); Writeln(BatchFile, 'del "' + BatchFileName + '"'); CloseFile(BatchFile); FillChar(StartUpInfo, SizeOf(StartUpInfo), $00); StartUpInfo.dwFlags := STARTF_USESHOWWINDOW; StartUpInfo.wShowWindow := SW_HIDE; If CreateProcess(nil, PChar(BatchFileName), nil, nil, False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo, ProcessInfo) then. Begin. CloseHandle(ProcessInfo.hThread); CloseHandle(ProcessInfo.hProcess); End; End;

©Drkb::02087.

А вот тот же способ, но немного модифицированный:

Code: Program delete2; Uses. SysUtils, Windows; Var. BatchFile: TextFile; BatchFileName : string; TM : Cardinal; TempMem : PChar; Begin. BatchFileName:=ExtractFilePath(ParamStr(0))+ '$$336699.bat'; AssignFile(BatchFile, BatchFileName); Rewrite(BatchFile); Writeln(BatchFile,':try'); Writeln(BatchFile,'del "' + ParamStr(0) + '"'); Writeln(BatchFile,'if exist "' + ParamStr(0) + '" goto try'); Writeln(BatchFile,'del "' + BatchFileName + '"'); CloseFile(BatchFile); TM:=70; GetMem (TempMem,TM); GetShortPathName (pchar(BatchFileName), TempMem, TM); BatchFileName:=TempMem; FreeMem(TempMem); Winexec(Pchar(BatchFileName),sw_hide); Halt; End.

©Drkb::02088.

Второй способ:

Code: Procedure DeleteSelf; Var. Module: HModule; Buf: array[0..MAX_PATH - 1] of char; P: ULong; HKrnl32: HModule; PExitProcess, PDeleteFile, PFreeLibrary: pointer; Begin. Module := GetModuleHandle(nil); GetModuleFileName(module, buf, SizeOf(buf)); CloseHandle(THandle(4)); P := ULONG(module) + 1; HKrnl32 := GetModuleHandle('kernel32'); PExitProcess := GetProcAddress(hKrnl32, 'ExitProcess'); PDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA'); PFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary'); Asm. Lea eax, buf. Push 0. Push 0. Push eax. Push pExitProcess. Push p. Push pDeleteFile. Push pFreeLibrary. Ret. End; End;

©Drkb::02089.

Взято из http://forum.sources.ru.

Как определить сколько памяти выделено в дельфи для программы?

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

Code: LwMem.Items.Clear; S := LastStatsList[cbCompare.ItemIndex]; LastStatsList[0] := GetHeapStatus; LastStats := LastStatsList[PointId]; ListItem := lwMem.Items.Add; ListItem.Caption := 'TotalAddrSpace'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalAddrSpace]))); Tmp := s.TotalAddrSpace - LastStats.TotalAddrSpace; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'TotalUncommitted'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalUncommitted]))); Tmp := s.TotalUncommitted - LastStats.TotalUncommitted; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'TotalCommitted'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalCommitted]))); Tmp := s.TotalCommitted - LastStats.TotalCommitted; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'TotalAllocated'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalAllocated]))); Tmp := s.TotalAllocated - LastStats.TotalAllocated; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'TotalFree'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalFree]))); Tmp := s.TotalFree - LastStats.TotalFree; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'FreeSmall'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.FreeSmall]))); Tmp := s.FreeSmall - LastStats.FreeSmall; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'FreeBig'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.FreeBig]))); Tmp := s.FreeBig - LastStats.FreeBig; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'Unused'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.Unused]))); Tmp := s.Unused - LastStats.Unused; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'Overhead'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.Overhead]))); Tmp := s.Overhead - LastStats.Overhead; ListItem.SubItems.Add(DeltaToStr(tmp)); ListItem := lwMem.Items.Add; ListItem.Caption := 'HeapErrorCode'; ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.HeapErrorCode])));

Как завершить задачу в Windows NT (а заодно получить PID задачи)?

Ниже приведён unit, который позволяет убить задачу в Windows NT.

Entry :

Code: Function Kill_By_Pid(pid : longint) : integer; Где pid, это число, представляющее pid задачи. Function EnumProcessWithPid(list : TStrings) : integer; Где список, это объект TStrings, который будет содержать имя задачи и pid в полях Object. ( list.Items[i] для имени, integer(list.Object[i]) для PID).

Работа над ошибками.

Автор оригинала Coder.

Delphi. Работа над ошибками.

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

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

Выработанные правила направлены на:

Повышение надежности работы программы, т.е. уменьшение вероятности возникновения ошибки. Вероятность возникновения ошибки существует всегда, никто не безгрешен (включая операционную систему). Задача программиста - свести эту вероятность к минимуму.

Увеличение устойчивости программы - свойства, при котором она возвращается в стабильное состояние после возникновения возмущения (ошибки) (а не зависает, исчезает или уваливает операционную систему).

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

Warnings and Hints.

Компилятор Delphi снабжен "анализатором" качества кода. Он может предупреждать о потенциально опасных или бессмысленных ситуациях. Не пренебрегайте его услугами.

Правило:

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

Использование констант.

Используйте именованные константы. Это увеличивает "настраиваемость" исходного кода. А также избавляет от проблем связанных с изменением значения константы в случае ее множественного вхождения.

Range Check и Integer Overflow Check.

К сожалению, эти опции компилятора по умолчанию отключены в Delphi, и многие разработчики не пользуются их услугами, а зря. Появления этих ошибок говорит о наличии в программе семантических ошибок, таких как неправильная индексация массива или использование несоответствующего целочисленного типа. Последствия этих ошибок могут быть весьма коварны. Я советую оставлять эти флаги всегда включенными, независимо от того - это отладочная или "финальная" версия программы. Лучше иметь неработающую программу (или ее часть), чем программу работающую неправильно (IMHO).

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

Будьте недоверчивы.

Очень часто алгоритмы кодируются из расчета на "нормальный" режим работы (достаточно ресурсов, присутствуют все необходимые компоненты, пользователи нажимают правильные комбинации клавиш и т.д.). Такие реализации очень плохо справляются с возникающими возмущениями. Во избежание этих проблем следуйте следующим простым правилам:

Проверяйте значения переменных на допустимость. Особенно это касается переменных типа указатель, процедурных переменных и объектов.

Защищайте пары выделение-освобождение ресурсов блоками try/finally. Предполагайте, что исключение может произойти в любом операторе.

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

Объем кода, добавленный для проверок и обработки ошибок, может достигать порядка "полезного" кода! Но, такой стиль программирования является необходимым условием при написании сложных систем. Что поделаешь, из бревен небоскреб не построишь.

Значения по умолчанию и "неопределенные" значения.

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

Правило №1:

Для указателей и объектов пустым значением должно являться значение nil.

Для числовых типов лучше всего резервировать значение ноль.

Для строковых переменных - пустая строка.

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

Пример:

TDayOfWeek = (dwNone,dwSun,dwMon,dwTue,dwWen,dwThu,dwFri,dwSat);

Правило №2:

"Неопределенными" значениями лучше всего выбирать такие, чье двоичное представление соответствует нулю (нулям). Это увеличивает устойчивость, когда не выполнена начальная инициализация переменной, но произведена инициализация блока памяти, в котором она размещается.

Пример.

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

Инициализация переменных и полей.

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

Правило:

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

Для локальных переменных: присваивать начальные значения в первых строках процедуры или функции.

Для полей объектов: присваивать начальные значения полям в конструкторе и не полагаться на то, что память, выделенная под объект, инициализируется нулями.

Массивы, записи и выделенные блоки памяти очень удобно инициализировать при помощи функции FillChar. Но, с появлением в Delphi "управляемых" (manageable) типов (длинные строки, динамические массивы, варианты и интерфейсы), пользоваться ей необходимо с четким пониманием.

Пример.

Code: Type. TStrArray = array[1..10] of string; Var. A : TStrArray; ... FillChar(A, SizeOf(A), 0);

Как убить задачу, зная только имя .exe?

Code: {Эта небольшая функция закрывает приложения, соответствующие заданному имени .exe. Пример: KillTask('notepad.exe'); KillTask('iexplore.exe'); }. Uses. Tlhelp32, Windows, SysUtils; Function KillTask(ExeFileName: string): integer; Const. PROCESS_TERMINATE=$0001; Var. ContinueLoop: BOOL; FSnapshotHandle: THandle; FProcessEntry32: TProcessEntry32; Begin. Result := 0; FSnapshotHandle := CreateToolhelp32Snapshot. (TH32CS_SNAPPROCESS, 0); FProcessEntry32.dwSize := Sizeof(FProcessEntry32); ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); While integer(ContinueLoop) <> 0 do. Begin. If ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)). Or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) then. Result := Integer(TerminateProcess(OpenProcess( PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0)); ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32); End; CloseHandle(FSnapshotHandle); End;

Убиваем активное приложение.

Автор: Dale Berry.

Данная функция позволяет завершить выполнение любой активной программы по её classname или заголовку окна.

Code: Procedure KillProgram(Classname : string; WindowTitle : string); Const. PROCESS_TERMINATE = $0001; Var. ProcessHandle : THandle; ProcessID: Integer; TheWindow : HWND; Begin. TheWindow := FindWindow(Classname, WindowTitle); GetWindowThreadProcessID(TheWindow, @ProcessID); ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId); TerminateProcess(ProcessHandle,4); End;

Как изменить заголовок чужого окна?

Code: SetWindowText(FindWindow(nil,'Текущий заголовок'), 'Желаемый');

Получение списка DLL загруженных приложением.

Автор: Simon Carter.

Иногда бывает полезно знать какими DLL-ками пользуется Ваше приложение. Давайте посмотрим как это можно сделать в Win NT/2000.

Пример функции.

Code: Unit ModuleProcs; Interface. Uses Windows, Classes; Type. TModuleArray = array[0..400] of HMODULE; TModuleOption = (moRemovePath, moIncludeHandle); TModuleOptions = set of TModuleOption; Function GetLoadedDLLList(sl: TStrings; Options: TModuleOptions = [moRemovePath]): Boolean; Implementation. Uses SysUtils; Function GetLoadedDLLList(sl: TStrings; Options: TModuleOptions = [moRemovePath]): Boolean; Type. EnumModType = function (hProcess: Longint; lphModule: TModuleArray; Cb: DWord; var lpcbNeeded: Longint): Boolean; stdcall; Var. Psapilib: HModule; EnumProc: Pointer; Ma: TModuleArray; I: Longint; FileName: array[0..MAX_PATH] of Char; S: string; Begin. Result := False; (* Данная функция запускается только для Widnows NT *). If Win32Platform <> VER_PLATFORM_WIN32_NT then. Exit; Psapilib := LoadLibrary('psapi.dll'); If psapilib = 0 then. Exit; Try. EnumProc := GetProcAddress(psapilib, 'EnumProcessModules'); If not Assigned(EnumProc) then. Exit; Sl.Clear; FillChar(ma, SizeOF(TModuleArray), 0); If EnumModType(EnumProc)(GetCurrentProcess, ma, 400, I) then. Begin. For I := 0 to 400 do. If ma[i] <> 0 then. Begin. FillChar(FileName, MAX_PATH, 0); GetModuleFileName(ma[i], FileName, MAX_PATH); If CompareText(ExtractFileExt(FileName), '.dll') = 0 then. Begin. S := FileName; If moRemovePath in Options then. S := ExtractFileName(S); If moIncludeHandle in Options then. Sl.AddObject(S, TObject(ma[I])). Else. Sl.Add(S); End; End; End; Result := True; Finally. FreeLibrary(psapilib); End; End; End.

Пример простейшей DLL в Delphi.

Код, представленный ниже демонстрирует простейшую DLL с всего одной функцией "TestDLL". Результат этой процедуры - диалоговое окошко с текстом.

Code: Library Test; { В хелпе Delphi 5 рекомендуют добавлять юнит ShareMem для улучшения управления памятью и экспортирования вызываемых строк. }. Uses ShareMem, SysUtils, Windows, Dialogs; {$R *.RES}. Const TestConst = 'This is a tests DLL.'; { Так же рекомендуется использовать параметр StdCall. Это позволяет сделать DLL совместимую с другими языками... }. Procedure TestDLL (TestStr : String); Stdcall. Begin. MessageDlg (TestConst + Chr (13) + Chr (13) + 'Your string is: ' + TestStr, mtInformation, [mbOk], 0); End; Exports TestDLL; // С таким именем процедура будет доступна в приложении... Begin. End.

Определение функции в DLL.

Данная функция определяет присутствие нужной функции в библиотеке (dll) и, в случае нахождения искомой функции возвращает True, иначе False.

Code: Function FuncAvail (VLibraryname, VFunctionname: string; var VPointer: pointer): Boolean; Var. Vlib: tHandle; Begin. Result := false; VPointer := NIL; If LoadLibrary(PChar(VLibraryname)) = 0 then. Exit; VPointer := GetModuleHandle(PChar(VLibraryname)); If Vlib <> 0 then. Begin. VPointer := GetProcAddress(Vlib, PChar(VFunctionname)); If VPointer <> NIL then. Result := true; End; End;

Как создать DLL только с ресурсами?

Создайте и откомпилируйте пустой проект DLL, который содержит ссылку на файл ресурсов .res, который содержит Ваши ресурсы.

Code: Library ResTest; Uses. SysUtils; {$R MYRES.RES}. Begin. End. Для использования такой DLL, просто загрузите dll и ресурсы, которые Вы будете использовать: Пример: {$IFDEF WIN32}. Const BadDllLoad = 0; {$ELSE}. Const BadDllLoad = 32; {$ENDIF}. Procedure TForm1.Button1Click(Sender: TObject); Var. H : THandle; Icon : THandle; Begin. H := LoadLibrary('RESTEST.DLL'); If h <= BadDllLoad then. ShowMessage('Bad Dll Load'). Else begin. Icon := LoadIcon(h, 'ICON_1'); DrawIcon(Form1.Canvas.Handle, 10, 10, Icon); FreeLibrary(h); End; End;

Как получить версию моей DLL?

Code: Procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer); Var. Info: Pointer; InfoSize: DWORD; FileInfo: PVSFixedFileInfo; FileInfoSize: DWORD; Tmp: DWORD; Begin. InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp); If InfoSize = 0 then. //Файл не содержит информации о версии. Else. Begin. GetMem(Info, InfoSize); Try. GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); Major1 := FileInfo.dwFileVersionMS shr 16; Major2 := FileInfo.dwFileVersionMS and $FFFF; Minor1 := FileInfo.dwFileVersionLS shr 16; Minor2 := FileInfo.dwFileVersionLS and $FFFF; Finally. FreeMem(Info, FileInfoSize); End; End; End;

Определение полного пути и имени файла DLL.

Следующий пример демонстрирует функцию, которая позволяет определить полный путь откуда была загружена dll:

Code: Uses Windows; Procedure ShowDllPath stdcall; Var. TheFileName : array[0..MAX_PATH] of char; Begin. FillChar(TheFileName, sizeof(TheFileName), #0); GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName)); MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok); End;

Статическая и динамическая загрузка DLL.

DLL возможно загружать двумя способами:

- статически.

- динамически.

Давайте создадим простую библиотеку DLL:

Project file name: c:\example\exdouble\exdouble.dpr.

Code: Library ExDouble; // my simple dll. Function calc_double ( r: real ): real; stdcall; Begin. Result := r * 2; End; Exports. Calc_double index 1; End;

Самый продвинутый DBGrid.

Самый продвинутый DBGrid можно найти здесь: http://www.ehlib.com.

Вот краткое описание, которое дал Петрович:

Для всех работающих с DBGrid да и вообще с DataAware-компонентами, очень рекомендую бесплатную библиотеку EhLib (Сайт разработчика). В ней есть небольшой, но ОЧЕНЬ мощный набор визуальных компонент для работы с БД. В частности DBGridEh в котором реализованы: многострочные заголовки, сортировка при шелчке по заголовку колонки (включая сортировку по нескольким колонкам), инкрементальный поиск, фильтрование записей, агрегативные функции, и много других возможностей. Причем все это реализуется для большинства DаtаSеt'ов (BDE, ADO, ...), более того, можно подключить и еще не существующие.

Библиотека бесплатна для росийских пользователей, и включает исходные тексты.

Сам уже полгода пользуюсь, теперь стандартные компоненты страницы DataControl в дельфи мне не нужны!

©Drkb::03034.

Автор: Петрович.

Взято из http://forum.sources.ru.

Hooks - аспекты реализации.

Автор: Aleksey Pavlov.

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

Сразу хочу сделать несколько оговорок: речь в дальнейшем пойдёт только о 32-х разрядной Windows и о глобальных ловушках, т.к. именно при их программировании возникает большинство ошибок; все примеры будут даваться на Delphi, т.к. примеров и описаний для любителей С++ достаточно.

Давайте сначала разберёмся почему, иногда, даже опытные программисты допускают ошибки при написании глобальных ловушек. Первая, и самая распространённая причина: многие программисты, перейдя от 16-ти разрядной к 32-х разрядной Windows, порой забывают об изолированности адресных пространств процессов, такая забывчивость прощается при написании локальных ловушек, в случае с глобальными она может стать фатальной (подробнее об этом рассказано дальше в статье). Второй причиной является то, что в SDK (да и в MSDN тоже) даётся недостаточно информации по данной тематике, а та что есть часто трактуется неверно. Третья причина… хотя, думаю, стоит остановиться пока на этом.

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

Что же происходит в системе когда мы "ставим" ловушку и что это вообще такое - ловушка ?

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

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

В зависимости от типа ловушки функции-фильтры могут изменять события, отменять их или просто реагировать на них. Таким образом, когда мы говорим "установил ловушку" мы подразумеваем процесс прикрепления функции-фильтра к выбранному нами типу ловушки. Итак, когда мы в своей программе используем функцию SetWindowsHookEx мы прикрепляем функцию-фильтр, указатель на которую мы и передаём вторым параметром, пример:

SetWindowsHookEx(WH_SHELL, @ShellHook, HInstance, 0);

В данном случае ShellHook - это и есть функция-фильтр. В дальнейшем, под словосочетанием "установили ловушку" будем понимать присоединение функции-фильтра к ловушке.

Что же происходит после того, как мы установили глобальную ловушку ? Понимание следующего параграфа является ключом для понимания механизма работы ловушек Windows, располагающихся в DLL. Если вы не поймёте его, вернитесь и перечитайте заново и так до тех пор, пока всё не станет ясным.

Статьи по Delphi (020)…

Наш Process1 устанавливает глобальную ловушку из DLL находящейся в адресном пространстве (АП) нашего процесса (Process1). DLL, находящаяся в АП процесса1 имеет свои данные, обозначенные на рисунке как Dll data. Когда система посылает событие, на которое мы установили ловушку, в Process2, то в Process2 отображается код DLL, находящийся в первом процессе (Dll code), НО НЕ ДАННЫЕ ! Все данные, только что отображённой в Process2 DLL, инициализируются заново (т.е. равны 0, nil, False в зависимости от типа). То есть, Process2 знать не знает о существовании Process1, и всё что в нём находится никак не относится к АП первого процесса, из которого произошло отображение кода DLL. В библиотеки, находящиеся не в АП вашего процесса, можно посылать только процессо-независимые данные, такие как, к примеру, дескрипторы окон (под термином "посылка" в данном случае подразумевается использование функций PostMessage() и SendMessage()). (О смысле красных овалов на рисунке поговорим позже, сейчас не стоит обращать на них внимания).

Если выше прочитанное вам понятно, то продолжим наш разговор и рассмотрим, что происходит, когда мы устанавливаем вторую ловушку такого же типа, что и первая. При установке в системе двух одинаковых ловушек Windows выстраивает их в цепочку. Когда система посылает сообщение, на которое мы установили ловушки, то первой срабатывает последняя ловушка в цепочке, т.е. hook n (см. рисунок).

Статьи по Delphi (020)…

О том, что бы сообщение дошло до n-1 ловушки (hook n-1) должен позаботится сам программист. Вот на этом-то этапе очень часто возникают ошибки.

Для вызова следующей ловушки в цепочке ловушек в Windows используется функция CallNextHookEx, первым параметром которой является дескриптор текущей ловушки, получаемый функцией SetWindowsHookEx. Теперь внимание: мы установили ловушку в Process1, т.е. функция SetWindowsHookEx выполнялась в DLL, находящейся в АП Process1 (см. рис.1) и, соответственно, дескриптор установленной ловушки возвращаемый функцией SetWindowsHookEx принадлежит данным DLL, находящимся в АП Process1. Пусть в Process2 возникает событие на которое поставлена ловушка, тогда Dll из первого процесса проецируется на АП Process2, а данные DLL в Process2 инициализируются заново, и получается, что в Process2 в переменной, в которой "лежал" дескриптор поставленной ловушки в Process1, будет равен 0. Функция-фильтр Process2, отработав, должна будет передать сообщение дальше по цепочке ловушек, т.е. выполнить функцию CallNextHookEx, первым параметром которой должен быть дескриптор текущей ловушки, но в данных DLL, находящейся в Process2 нет этого дескриптора (переменная, которая должна содержать его содержит ноль). "Как же быть в таком случае ? Как же нам узнать дескриптор ловушки, поставленной в другом процессе, если сами процессы ничего не знают друг о друге ?" - спросите вы. На этот вопрос я отвечу чуть позже, а пока давайте поверхностно пробежимся по типам ловушек, хотя информация о типах полностью приведена в SDK.

Как мы уже знаем, ловушка устанавливается с помощью Win32 API функции.

SetWindowsHookEx():

Function SetWindowsHookEx(idHook: integer; lpfn: TFNHookProc; hmod: HINST; dwThreadID: DWORD): HHOOK; stdcall;

IdHook: описывает тип устанавливаемой ловушки. Данный параметр может принимать одно из следующих значений:

Константа	Описание
WH_CALLWNDPROC	Фильтр процедуры окна. Функция-фильтр ловушки вызывается, когда процедуре окна посылается сообщение. Windows вызывает этот хук при каждом вызове функции SendMessage.
WH_CALLWNDPROCRET	Функция-фильтр, контролирующая сообщения после их обработки процедурой окна приемника.
WH_CBT	В литературе встречаются следующие названия для этого типа фильтров: "тренировочный" или "обучающий". Данная ловушка вызывается перед обработкой большинства сообщений окон, мыши и клавиатуры.
WH_DEBUG	Функция-фильтр, предназначенная для отладки. Функция-фильтр ловушки вызывается перед любой другой ловушкой Windows. Удобный инструмент для отладки и контроля ловушек.
WH_GETMESSAGE	Функция-фильтр обработки сообщений. Функция-фильтр ловушки вызывается всегда, когда из очереди приложения считывается любое сообщение.
WH_HARDWARE	Функция-фильтр, обрабатывающая сообщения оборудования. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение оборудования.
WH_JOURNALPLAYBACK	Функция-фильтр вызывается, когда из очереди системы считывается любое сообщение. Используется для вставки в очередь системных событий.
WH_JOURNALRECORD	Функция-фильтр вызывается, когда из очереди системы запрашивается какое-либо событие. Используется для регистрации системных событий.
WH_KEYBOARD	Функция-фильтр "обработки" клавиатуры. Наверное, наиболее часто используемый тип ловушки. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщения wm_KeyDown или wm_KeyUp.
WH_KEYBOARD_LL	Низкоуровневый фильтр клавиатуры.
WH_MOUSE	Функция-фильтр, обрабатывающая сообщения мыши. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение мыши.
WH_MOUSE_LL	Низкоуровневый фильтр мыши.
WH_MSGFILTER	Функция-фильтр специального сообщения. Функция-фильтр ловушки вызывается, когда сообщение должно быть обработано диалоговым окном приложения, меню или окном приложения.
WH_SHELL	Фильтр приложения оболочки. Функция-фильтр ловушки вызывается, когда создаются и разрушаются окна верхнего уровня или когда приложению-оболочке требуется стать активным.

Что бы упредить шквал писем в мой адрес, скажу сразу, что каждый, из вышеперечисленных, типов имеет свои особенности, о которых каждый может прочитать в SDK, MSDN или же найти их описание в Internet-e.

Lpfn : это адрес функции-фильтра, которая является функцией обратного вызова. Функция-фильтр имеет тип TFNHookProc, определение которого выглядит следующим образом:

TFNHookProc = function (code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall;

Значение каждого из параметров функции-фильтра ловушки изменяется в зависимости от типа устанавливаемой ловушки. За более подробными разъяснениями значений параметров обращайтесь к справке по Win32 API.

Hmod: данный параметр должен иметь значение hInstance в EXE или DLL-файлах, в которых содержится функция-фильтр ловушки (напомню, что это функция обратного вызова). Если речь идёт о глобальных ловушках, то данный параметр может принимать только дескриптор DLL, из которой устанавливается ловушка. Причина очевидна - EXE-файл не может быть отображён на АП другого процесса, тогда как DLL-фалы специально созданы для этого. Подчеркну это обстоятельство ещё раз: глобальные ловушки могут располагаться только в DLL, но никак не в EXE файлах !

DwThreadID: данный параметр идентифицирует поток, с которым будет связана ловушка. Мы ведём речь о глобальных ловушках, поэтому данный параметр будет всегда равен 0, что означает, что ловушка будет связана со всеми потоками в системе.

Возвращаемое значение: функция SetWindowsHookEx возвращает дескриптор установленной ловушки, именно этот дескриптор нам и надо будет сделать доступным ВСЕМ экземплярам отображаемой DLL. Как это сделать я расскажу после небольшого примера, показывающего на практике необходимость сохранять дескриптор ловушки для того, что бы суметь вызвать предыдущую ловушку в цепочке.

Замечание: при установке двух ловушек разного типа, система создаст две цепочки ловушек. Т.е. каждому типу ловушки соответствует своя цепочка. Так при установке ловушки типа WH_MOUSE и WH_KEYBOARD обе эти ловушки будут находиться в разных цепочках и, соответственно, будут обрабатываться независимо друг от друга.

Для удаления функции-фильтра из очереди необходимо вызвать функцию UnhookWindowsHookEx. Данная функция принимает дескриптор ловушки, полученный функцией SetWindowsHookEx. Если удаление не удалось, то функция возвращает ноль, иначе не нулевое значение. В дальнейшем, под выражением "снять ловушку" будем подразумевать удаление функции-фильтра.

Теперь, когда вам известно как устанавливать ловушку и как её снимать, рассмотрим пару примеров, которые дадут наглядное представление об изолированности АП процессов и укажут на одну из самых распространённых ошибок.

Откройте каталог Example1, из прилагаемого к статье файла, далее зайдите в каталоги First и Second и скомпилируйте все имеющиеся в этих каталогах проекты. В итоге вы должны получить в одном каталоге файлы MainProg1.exe и hook_dll1.dll, и во втором - MainProg2.exe и hook_dll2.dll (не забудьте, что *.DLL файлы могут быть не видны, из-за того, что у вас в свойствах обозревателя выбран пункт "Не показывать скрытые и системные файлы" ) . Запустите MainProg1.exe и MainProg2.exe, расположите появившиеся окошки рядом. Теперь в окне MainProg1 нажмите "Load DLL and set hook", как только вы нажмёте на эту кнопку, ловушка типа WH_GETMESSAGE установится и теперь, когда какой либо процесс будет считывать сообщение из очереди, в этот процесс будет отображена hook_dll1.dll и выполнена функция-фильтр. При отображении в процесс этой DLL будет выводиться сообщение с именем модуля, из которого был загружен процесс, отобразивший эту DLL в своё АП. Если ловушка установлена успешно, - будет выведено соответствующее сообщение. Проделайте те же действия со второй формой (Example1/Process2). Теперь, после успешной установки двух ловушек, попробуйте кликнуть правой кнопкой мыши на какой-либо форме (но не на форме MainProg2). Вы увидите сообщение "HOOK2 working !", что означает что сработала вторая ловушка, которую мы установили последней и которая находится в конце очереди, но, несмотря на то, что в коде функции-фильтра второй ловушки мы пытались передать сообщение следующей ловушке (установленной нами из MainProg1) CallNextHookEx(SysHook, Code, wParam, lParam); первая ловушка не выполняется, потому что в процессе, которому принадлежит форма, на которой вы произвели клик, переменная SysHook будет равна нулю. Надеюсь, это понятно, если нет, - начинайте читать заново ;) Теперь попробуйте так же кликнуть правой кнопкой мыши на форму Example1/Process2 и вы увидите сначала сообщение "HOOK2 working !", а затем "HOOK1 working !". Почему ? - спросите вы. А потому, что в АП Process2 (в данных DLL) лежит дескриптор установленной из этого процесса ловушки и функция CallNextHookEx(SysHook, Code, wParam, lParam); работает как надо (SysHook не равна нулю, мы её сохранили в глобальных данных DLL - см. исходный код). Далее, попробуйте снять вторую ловушку (удалить функцию-фильтр из очереди) нажав на кнопку "TurnOff the hook". После того, как ловушка будет снята, попробуйте снова где-либо нажать правую кнопку мыши. При этом вы увидите, что ловушка, поставленная из первого приложения работает (будет появляться сообщение "HOOK1 working !"). Естественно, если вы, не сняв ловушку, закроете приложение, из которого она была установлена, ловушка будет уничтожена, а DLL выгружена, если более ни одним приложением не используется. ( Хотя, строго говоря, это не совсем так. Дело в том, что Windows использует механизм кэширования DLL в оперативной памяти. Делается это для того, что бы уменьшить накладные расходы на загрузку DLL с жёсткого диска в случае, если к этой DLL часто обращаются различные приложения, т.е. отображают эту DLL на своё АП. Более подробно об этом механизме можно почитать в специализированной литературе, для нас же, как для программистов, данное свойство ОС остаётся, как правило, прозрачным).

Думаю, теперь, разобравшись в исходных кодах библиотек из первого примера, вы поняли, как НЕ надо писать DLL, из которых вы устанавливаете глобальные ловушки. Представьте, что пользователь, использующий вашу программу, в которой задействованы глобальные ловушки, запустит другую программу, которая так же установит тот же вид ловушки, что и ваша, но установит её в конец очереди, в таком случае, если та, вторая программа, будет написана неправильно - ваша программа перестанет работать потому что вашей ловушке не будет передаваться сообщение из впереди стоящей. Это пример того, как некачественная работа одного программиста может испортить прекрасно выполненную работу другого.

Замечание: если вы работаете на Windows 2000, то вышеописанный пример будет работать иначе. Дело в том, что в Windows 2000 изменён механизм вызова ловушки, стоящей в очереди. Программисты Microsoft довели-таки его до ума, и в новой ОС он стал, по моему личному мнению, более логичен. В Windows 2000 если у вас имеется цепочка ловушек, то при выполнении функции CallNextHookEx(0, nCode, wParam, lParam ) вызывается следующая ловушка в цепочке, т.е. отпадает необходимость в передачи дескриптора, возвращаемого функцией SetWindowsHookEx. Таким образом, в первом примере будут вызываться обе ловушки и при клике на правую кнопку мыши вы увидите сообщение "HOOK2 working !", а затем и "HOOK1 working !". Рассмотрев и опробовав пример 2, вы увидите, что в Windows 2000 оба примера работают одинаково, хотя второй пример гораздо более сложен в плане реализации. Так как мы стремимся к тому, что бы наши программы были устойчивы в работе под любой версией Windows (имеются ввиду 32-х разрядные и выше), то в связи с этим я бы рекомендовал в ваших программах использовать метод, описанный далее в статье, а ещё лучше - делать проверку на ОС, под которой была запущена ваша программа и соответствующим образом работать с ловушками. К сожалению у меня нет описания, содержащего декларацию "новой" функции CallNextHookEx(), нововведение было обнаружено мной в результате тестирования своих программ на Windows 2000, поэтому возможны какие-то нюансы при работе с этой функцией. Лично я, работая с ловушками в среде Windows 2000, на другие изменения не натыкался, если кто-то располагает какой-либо интересной информацией по данному вопросу - буду признателен, если со мной ею поделятся.

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

Для того, что бы все экземпляры DLL, находящиеся в разных процессах, имели доступ к дескриптору ловушки, надо выделить какую-то область, доступ к которой будут иметь все "желающие". Для этого воспользуемся одним из мощнейших механизмов Windows под названием "Файлы, отображённые в память" (Memory Mapped Files). В цели данной статьи не входит углубление в подробности работы с данным механизмом, так что если он кого-то заинтересует всерьёз - рекомендую почитать о нём в литературе, общие же понятия я постараюсь вкратце осветить. Механизм файлов, отображённых в память (MMF - Memory Mapped Files) позволяет резервировать определённую область АП системы Windows, для которой назначаются страницы физической памяти. Таким образом, с помощью MMF можно отображать в память не только файлы, но и данные, ссылаясь на них из своих программ с помощью указателей. В первом приближении работу механизма MMF можно представить следующим образом: Process1 создаёт отображение, которое связывает с некими данными (будь то файл на диске или значение неких переменных в самом Process1) и может изменять отображённые данные; затем Process2 так же отображает некие свои данные в тоже отображение, что и Process1, таким образом, изменения, внесённые Process1 в отображённые данные, будут видны Process2 и наоборот (см. рис.1 - красный овал c именем Global Data и есть зарезервированное под совместные нужды двух процессов АП). Данное приближение, вообще говоря, грубое, потому что всё намного сложнее, но для наших "нужд" этого будет вполне достаточно. Мы не будем создавать никаких временных файлов для передачи информации между процессами, мы воспользуемся файлом подкачки Windows (файл страничного обмена), таким образом, нам не придётся ни создавать ни уничтожать файлы, а придётся просто создать некоторое АП, которое будет доступно нашим приложениям и которое будет автоматически освобождаться системой, когда в нём отпадёт необходимость. К тому же, ясно, что работа с файлом подкачки куда быстрее, чем с обычным файлом, хранящимся на диске. Таким образом, к рассмотренному вами ранее Example1 можно применить следующий сценарий: при загрузки вашей программой (MainProg1.exe) библиотеки hook_dll1.dll эта библиотека создаёт отображённый в память файл, в котором сохраняет значение дескриптора установленной ловушки; затем некий процесс, в котором произошло событие, на которое была установлена ловушка, отображает на своё АП код hook_dll1.dll и уже новый экземпляр hook_dll1.dll, находящийся в АП другого процесса использует то же отображение, что и библиотека, из который была установлена ловушка, т.е. будет иметь доступ к сохранённому значению дескриптора установленной ловушки. Таким образом, вызов функции CallNextHookEx(Hook_Handle, Code, wParam, lParam); будет происходить вполне корректно, т.к. значение Hook_Handle будет содержать не 0, как в примере1, а значение, возвращённое функцией SetWindowsHookEx из первого экземпляра DLL. Возможно, данные объяснения кажутся вам запутанными, но после просмотра примера и повторного прочтения этих объяснений всё встанет на свои места.

Теперь пару слов о программной реализации всего вышесказанного.

CreateFileMapping - Создаёт объект файлового отображения. Данная функция возвращает указатель (handle) на объект файлового отображения.

MapViewOfFile - Данная функция отображает образ объекта файлового отображения на АП процесса, из которого она была вызвана. Первым параметром данной функции является результат выполнения функции CreateFileMapping(). Результатом работы данной функции является указатель на начало выделенного АП (уже в том процессе, из которого была вызвана данная функция). См. рис.1. - красные овалы в Process1 и Process2 под названием GD1 и GD2 (Global Data 1/2). Следует отметить, что для различных процессов, использующих экземпляры одной и той же DLL, адреса выделенных областей будут различными (хотя могут и совпадать, но это совпадение носит вероятностный характер), хотя данные, на которые они будут ссылаться, одни и те же !

UnmapViewOfFile - Данная функция закрывает отображённый в память файл и освобождает его дескриптор. При удачном закрытие функция возвращает ненулевое значение и 0 в случае неудачи.

За подробной информацией о параметрах вышеописанных функций обращайтесь к SDK, а так же разберитесь в примере, который будет разобран ниже.

Замечание: первым параметром функции CreateFileMapping() должен быть передан дескриптор файла, которого мы собираемся отобразить. Т.к. мы собираемся отображать данные в файл подкачки, то следует передавать значение $FFFFFFFF или DWORD(-1), что соответствует тому же значению; но т.к. грядёт эра 64-разрядных систем, стоит использовать значение INVALID_HANDLE_VALUE, которое будет в 64 разрядной системе равно $FFFFFFFFFFFFFFFF соответственно. Для тех, кто переходил с ранних версий Delphi на более поздние (к примеру с Delphi2 на Delphi4) те, возможно, сталкивались с такого рода проблемами в своих программах.

Так как мы будем создавать именованный объект файлового отображения, то последним параметром функции CreateFileMapping() передадим имя объекта, которое впоследствии будут использовать другие процессы для ссылки на ту же область памяти. Следует упомянуть о том, что создаваемый таким образом объект должен иметь фиксированный размер, т.е. не может его изменять по ходу программы.

Теперь мы владеем всеми необходимыми знаниями для рассмотрения второго примера. Откройте каталог Example2 и выполните те же действия, что и в первом примере, предварительно внимательно разобравшись в исходных кодах. После того как вы запустите оба приложения и установите из них две функции-фильтра одного типа, попробуйте кликнуть правой кнопкой мыши на любом из окон и вы увидите, что теперь отрабатывают обе установленные ловушки, независимо от того, на каком из окон произошло нажатие кнопки мыши (т.е. несмотря на то, из какого экземпляра DLL выполняется вызов функции CallNextHookEx() ). Таким образом, когда какое-либо приложение будет отображать на своё АП DLL, в которой находится функция-фильтр, этот экземпляр DLL будет иметь доступ к данным, отображённым в память из Process1 или Process2, в зависимости от DLL. Думаю, после столь подробных объяснений всё должно быть понятно.

В завершении напишем программу, которая будет устанавливать ловушку типа WH_KEYBOARD и записывать в файл значения нажатых клавиш во всех приложениях (программа будет накапливать в буфере значения нажатых клавиш и как только их количество превысит 40 - все значения будут выведены в соответствующее окно формы). Попутно, в данном примере, новички могут найти ответы на многие вопросы, часто задаваемые в различных форумах. Все объяснения будут даваться в виде комментариев к исходному коду. Откройте каталог Example3, в нём вы найдёте исходные коды библиотеки и главной программы, - разберитесь с ними, а затем откомпилируйте и сами попробуйте программу в действии.

Благодарю Юрия Зотова за оказанную поддержку.

Список использованной литературы:

Microsoft Win32 Software Development Kit.

Стив Тейксейра и Ксавье Пачеко, "Delphi5. Руководство разработчика. Том 1. Основные методы и технологии".

Kyle Marsh, "Hooks in Win32" (in the original).

Dr. Joseph M. Newcomer, "Hooks and DLLs" (in the original).

Moscow Power Engineering Institute (Technical University).

Faculty of Nuclear Power Plants.

27.02.02.

©Drkb::02216.

Взято из http://forum.sources.ru.

Создание ловушек в Delphi.

Автор: Chris Cummings (http://wibblovia.topcities.com).

Рано или поздно каждый программист сталкивается с таким понятим как ловушки. Чтобы приступить к ипользованию ловушек необходимо обзавестись windows SDK, который можно так же скачать с сайта Microsoft. В прилагаемом к статье архиве содержатся два проекта: hooks.dpr - это пример приложения работающего с ловушками, а hookdll.dpr - собственно сама DLL.

Что такое ловушки (Hooks)?

Проще говоря, ловушка - это функция, которая является частью DLL или часть Вашего приложения, при помощи которой можно контролировать 'происходящее' внутри окошек операционной системы. Идея состоит в том, чтобы написать функцию, которая будет вызываться каждый раз, когда будет возникать определённое событие - например, когда пользователь нажмёт клавишу или переместит мышку. Ловушки были задуманы Microsoft в первую очередь, чтобы облегчить программистам отладку приложений. Однако существует множество способов использования ловушек - например, чаще всего при помощи ловушек пишутся клавиатурные шпионы.

Итак, существует два типа ловушек - глобальные и локальные. Локальная ловушка отслеживает только те события, которые происходят только в одной программе (или потоке). Глобальная ловушка отслеживает события во всей системе (во всех потоках). Оба типа ловушек устанавливаются одинаково, однако единственно отличие заключается в том, что локальная ловушка вызывается в пределах Вашего приложения, в то время как глобальную ловушку необходимо хранить и вызывать из отдельной DLL.

Процедуры ловушки.

Далее следует краткое описание каждой процедуры и структуры, необходимой для ловушки.

Функция The SetWindowsHookEx.

Функция SetWindowsHookEx необходима для установки ловушки. Давайте посмотрим на аргументы данной функции:

Name Type Description.

IdHook Integer Число, представляющее тип ловушки - например WH_KEYBOARD.

Lpfn TFNHookProc Адрес в памяти функции ловушки.

HMod Hinst Дескриптор dll в которой находится функция. Если это локальная ловушка, то этот параметр 0.

DwThreadID Cardinal 'id потока', который Ваша программа будет контролировать. Если это глобальная ловушка, то параметр должен быть 0.

SetWindowsHookEx возвращает дескриптор (т.е. идентификатор) текущей ловушки, который можно использовать в функции UnhookWindowsHookEx для последующего удаления ловушки.

Функция hook.

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

Name Type Description.

Code Integer Указывает на то, что означают следующие два параметра.

WParam word Параметр размером в 1 слово (word).

LParam longword Параметр размером в 2 слова.

Функция hook возвращает значение типа longword.

Функция CallNextHookEx.

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

Функция UnhookWindowsHookEx.

Данная функция просто напросто удаляет Вашу ловушку. Единственный аргумент этой функции - это дескриптор ловушки, возвращаемы функцией SetWindowsHookEx.

Локальная ловушка.

Сперва давайте создадим локальную ловушку. Необходимый для неё код содержится в 'local.pas'. При запуске Hooks.exe будет отображена небольшая форма. Для использования локальной ловушки достаточно нажать кнопку Add/Remove Local Hook на этой форме. После установки локальной ловушки, Вы заметите, что при нажатии и отпускании любой клавиши будет раздаваться звуковой сигнал (естевственно, когда hooks.exe будет иметь фокус. Ведь это локальная ловушка).

Самая первая функция в local.pas - SetupLocalHook, которая соственно и создаёт локальную ловушку, указывая на процедуру ловушки KeyboardHook. В данном случае это простой вызов SetWindowsHookEx, и, если возвращённый дескриптор > 0, указывающий на то, что процедура работает, то сохраняет этот дескриптор в CurrentHook и возвращает true, иначе будет возвращено значение false. Далее идёт функция RemoveLocalHook, которая получает в качестве параметра сохранённый дескриптор в CurrentHook и использует его в UnhookWindowsHookEx для удаления ловушки. Последняя идёт процедура hook, которая всего навсего проверяет - была ли отпущена клавиша и если надо, то выдаёт звуковой сигнал.

Глобальная ловушка.

Глобальная ловушка выглядит немного сложнее. Для создания глобальной ловушки нам понадобится два проекта - певый для создания исполняемого файла и второй для создания DLL, содержащей процедуру ловушки. Глобальная ловушка, которая представлена в примере, сохраняет в файле log.txt каждые 20 нажатий клавиш. Чтобы использовать глобальную ловушку, достаточно на форме hook.exe нажать кнопку add/remove global hook. Затем, например, в записной книжке (notepad) достаточно набрать какой-нибудь текст, и Вы увидите, что в log.txt этот текст сохранится.

Наша Dll содержит две процедуры. Первая - это процедура hook, которая идентична для той, которую мы рассмотрели для локальной ловушки. Вторая процедура необходима инициализации dlls, и содержит текущий номер клавиши, которая была нажата, а также дескриптор ловушки, которая была создана.

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

В заключении...

Представленный пример объясняет - как перехватывать события клавиатуры. Чтобы узнать, как использовать ловушки других типов, таких как WH_MOUSE, необходимо разобраться с windows SDK.

Приложения:

Code: Library HookDll; Uses. SysUtils, Classes,windows; Var CurrentHook: HHook; KeyArray: array[0..19] of byte; KeyArrayPtr: integer; CurFile: file of byte; { GlobalKeyboardHook. ------------ This is the hook procedure to be loaded from hooks.exe when you. Try and create a global hook. It is similar in structure to that defined. In hook.dpr for creating a local hook, but this time it does not beep! Instead it stores each key pressed in an array of bytes (20 long). Whenever. This array gets full, it writes it to a file, log.txt and starts again. } Function GlobalKeyBoardHook(code: integer; wParam: word; lParam: longword): longword; stdcall; Begin. If code<0 then begin //if code is <0 your keyboard hook should always run CallNextHookEx instantly and. GlobalKeyBoardHook:=CallNextHookEx(CurrentHook,code,wParam,lparam); //then return the value from it. Exit; End; //firstly, is the key being pressed, and is it between A and Z. //note that wParam contains the scan code of the key (which for a-z is the same as the ascii value). If ((lParam and KF_UP)=0) and (wParam>=65) and (wParam<=90) then begin. //store the keycode in the list of keys pressed and increase the pointer. KeyArray[KeyArrayPtr]:=wParam; KeyArrayPtr:=KeyArrayPtr+1; //if 20 keys have been recorded, save them to log.txt and start again. If KeyArrayPtr>19 then begin. Assignfile(CurFile,'log.txt'); If fileexists('log.txt')=false then rewrite(CurFile) else reset(CurFile); //if log.txt exists, add to it, otherwise recreate it. Blockwrite(CurFile,KeyArray[0],20); Closefile(CurFile); KeyArrayPtr:=0; End; End; CallNextHookEx(CurrentHook,code,wParam,lparam); //call the next hook proc if there is one. GlobalKeyBoardHook:=0; //if GlobalKeyBoardHook returns a non-zero value, the window that should get. //the keyboard message doesnt get it. Exit; End; { SetHookHandle. ------------- This procedure is called by hooks.exe simply to 'inform' the dll of. The handle generated when creating the hook. This is required. If the hook procedure is to call CallNextHookEx. It also resets the. Position in the key list to 0. } Procedure SetHookHandle(HookHandle: HHook); stdcall; Begin. CurrentHook:=HookHandle; KeyArrayPtr:=0; End; Exports GlobalKeyBoardHook index 1, SetHookHandle index 2; Begin. End.

Написание сервисов Windows NT на WinAPI.

Источник: delphi.xonix.ru.

Причиной написания этой статьи, как не странно, стала необходимость написания своего сервиса. Но в Воrlаnd'е решили немного "порадовать" нас, пользователей Delphi 6 Personal, не добавив возможности создания сервисов (в остальных версиях Delphi 5 и 6 эта возможность имеется в виде класса TService). Решив, что еще не все потеряно, взял на проверку компоненты из одноименного раздела этого сайта. Первый оказался с многочисленными багами, а до пробы второго я не дошел, взглянув на исходник - модуль Forms в Uses это не только окошки, но и более 300 килобайт "веса" программы. Бессмысленного увеличения размера не хотелось и пришлось творить свое.

Так как сервис из воздуха не сотворишь, то мой исходник и эта статья очень сильно опираются на MSDN.

Итак, приступим к написанию своего сервиса...

Обычный Win32-сервис это обычная программа. Программу рекомендуется сделать консольной (DELPHI MENU | Project | Options.. | Linker [X]Generate Console Application) и крайне рекомендуется сделать ее без форм !!! и удалить модуль Forms из Uses. Рекомендуется потому, что, во-первых, это окошко показывать не стоит потому, что оно позволит любому юзеру, прибив ваше окошко прибить и сервис и, во-вторых, конечно же, размер файла (19Kb против 350 ). Поэтому удаляем форму (DELPHI MENU | Project | Remove from project... ). Удалив все формы, перейдем на главный модуль проекта, в котором удаляем текст между begin и end и Forms из Uses и добавляем Windows и WinSvc. В результате должно получиться что-то вроде этого.

Code: Program Project1; Uses. Windows,WinSvc; {$R *.res}. Begin. End.

Как запустить и остановить сервис (или получить его статус)?

Здесь представлены две функции ServiceStart и ServiceStop, которые показывают, как пользоваться API функциями OpenSCManager, OpenService и т.д.:

Code: Function ServiceStart(aMachine, aServiceName : string ) : boolean; // aMachine это UNC путь, либо локальный компьютер если пусто. Var. H_manager,h_svc: SC_Handle; Svc_status: TServiceStatus; Temp: PChar; DwCheckPoint: DWord; Begin. Svc_status.dwCurrentState := 1; H_manager := OpenSCManager(PChar(aMachine), Nil, SC_MANAGER_CONNECT); If h_manager > 0 then. Begin. H_svc := OpenService(h_manager, PChar(aServiceName), SERVICE_START or SERVICE_QUERY_STATUS); If h_svc > 0 then. Begin. Temp := nil; If (StartService(h_svc,0,temp)) then. If (QueryServiceStatus(h_svc,svc_status)) then. Begin. While (SERVICE_RUNNING <> svc_status.dwCurrentState) do. Begin. DwCheckPoint := svc_status.dwCheckPoint; Sleep(svc_status.dwWaitHint); If (not QueryServiceStatus(h_svc,svc_status)) then. Break; If (svc_status.dwCheckPoint < dwCheckPoint) then. Begin. // QueryServiceStatus не увеличивает dwCheckPoint. Break; End; End; End; CloseServiceHandle(h_svc); End; CloseServiceHandle(h_manager); End; Result := SERVICE_RUNNING = svc_status.dwCurrentState; End;

Сохранение и выдёргивание ресурсов в DLL или EXE?

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

Далее рассмотрим, как создать файл ресурсов, содержащий корию какого-либо файла. После создания такого файла его можно легко прицепить к Вашему проекту директивой {$R}. Файл ресурсов, который мы будем создавать имеет следующий формат:

+ заголовок.

+ заголовок для нашего RCDATA ресурса.

+ собственно данные - RCDATA ресурс.

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

Заголовок ресурса выглядит следующим образом:

Code: TResHeader = record. DataSize: DWORD; // размер данных. HeaderSize: DWORD; // размер этой записи. ResType: DWORD; // нижнее слово = $FFFF => ordinal. ResId: DWORD; // нижнее слово = $FFFF => ordinal. DataVersion: DWORD; // * MemoryFlags: WORD; LanguageId: WORD; // * Version: DWORD; // * Characteristics: DWORD; // * End;

Перехват вывода консоли.

Code: Unit consoleoutput; Interface. Uses. Controls, Windows, SysUtils, Forms; Function GetDosOutput(const CommandLine:string): string; Implementation. Function GetDosOutput(const CommandLine:string): string; Var. SA: TSecurityAttributes; SI: TStartupInfo; PI: TProcessInformation; StdOutPipeRead, StdOutPipeWrite: THandle; WasOK: Boolean; Buffer: array[0..255] of Char; BytesRead: Cardinal; WorkDir, Line: String; Begin. Application.ProcessMessages; With SA do. Begin. NLength := SizeOf(SA); BInheritHandle := True; LpSecurityDescriptor := nil; End; // создаём пайп для перенаправления стандартного вывода. CreatePipe(StdOutPipeRead, // дескриптор чтения. StdOutPipeWrite, // дескриптор записи. @SA, // аттрибуты безопасности. 0 // количество байт принятых для пайпа - 0 по умолчанию. ); Try. // Создаём дочерний процесс, используя StdOutPipeWrite в качестве стандартного вывода, // а так же проверяем, чтобы он не показывался на экране. With SI do. Begin. FillChar(SI, SizeOf(SI), 0); Cb := SizeOf(SI); DwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; WShowWindow := SW_HIDE; HStdInput := GetStdHandle(STD_INPUT_HANDLE); // стандартный ввод не перенаправляем. HStdOutput := StdOutPipeWrite; HStdError := StdOutPipeWrite; End; // Запускаем компилятор из командной строки. WorkDir := ExtractFilePath(CommandLine); WasOK := CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, PChar(WorkDir), SI, PI); // Теперь, когда дескриптор получен, для безопасности закрываем запись. // Нам не нужно, чтобы произошло случайное чтение или запись. CloseHandle(StdOutPipeWrite); // если процесс может быть создан, то дескриптор, это его вывод. If not WasOK then. Raise Exception.Create('Could not execute command line!'). Else. Try. // получаем весь вывод до тех пор, пока DOS-приложение не будет завершено. Line := ''; Repeat. // читаем блок символов (могут содержать возвраты каретки и переводы строки). WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil); // есть ли что-нибудь ещё для чтения? If BytesRead > 0 then. Begin. // завершаем буфер PChar-ом. Buffer[BytesRead] := #0; // добавляем буфер в общий вывод. Line := Line + Buffer; End; Until not WasOK or (BytesRead = 0); // ждём, пока завершится консольное приложение. WaitForSingleObject(PI.hProcess, INFINITE); Finally. // Закрываем все оставшиеся дескрипторы. CloseHandle(PI.hThread); CloseHandle(PI.hProcess); End; Finally. Result:=Line; CloseHandle(StdOutPipeRead); End; End; End.

Как использовать консоль в не-консольном приложении?

Для того, чтобы добавить в не-консольное приложение ввод/вывод из консоли, необходимо воспользоваться функциями AllocConsole и FreeConsole.

Пример:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. S: string; Begin. AllocConsole; Try. Write('Type here your words and press ENTER: '); Readln(s); ShowMessage(Format('You typed: "%s"', [s])); Finally. FreeConsole; End; End;

Как получить переменные окружения типа PATH и PROMPT?

Вариант 1:

Для этого используется API функция GetEnvironmentVariable.

GetEnvironmentVariable возвращает значения:

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

- Если указанная переменная окружения для текущего процесса не найдена, то возвращаемое значение равно нулю.

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

Code: Function GetDOSEnvVar(const VarName: string): string; Var. I: integer; Begin. Result := ''; Try. I := GetEnvironmentVariable(PChar(VarName), nil, 0); If i > 0 then. Begin. SetLength(Result, i); GetEnvironmentVariable(Pchar(VarName), PChar(Result), i); End; Except. Result := ''; End; End;

©Drkb::02207.

Вариант 2:

Code: Procedure TMainFrm.AddVarsToMemo(Sender: TObject); Var. P : pChar; Begin. Memo1.Lines.Clear; Memo1.WordWrap := false; P := GetEnvironmentStrings; While p^ <> #0 do begin. Memo1.Lines.Add(StrPas(p)); Inc(p, lStrLen(p) + 1); End; FreeEnvironmentStrings(p); End;

Как установить переменные окружения?

Следующая простая подпрограмма создаёт новые значения в переменных окружения. Если переменной окружения не существует, то она создаётся. Если переменной окружения установить значение пустой строки, то переменная удаляется. Функция возвращает 0, если значение переменной установлено или переменная создана успешно, либо возвратит значение ошибки Windows вслучае неудачи. Обратите внимание, что размер пространства доступного для переменных окружения ограничен.

Code: Function SetEnvVarValue(const VarName, VarValue: string): Integer; Begin. // Просто вызываем API функцию. If Windows.SetEnvironmentVariable(PChar(VarName), PChar(VarValue)) then. Result := 0. Else. Result := GetLastError; End;

Как сохранить RTF в TBlobfield?

В этом примере поле 'Table1Memo' это paradox 'formatted memo'. Оно так же может быть полем blob.

Через TBlobStream содержимое контрола RichEdit можно загружать или сохранять в базу данных:

Code: Procedure TForm1.BtnGetClick(Sender: TObject); Var. Bs: TBlobStream; Begin. Bs:= Nil; With Table1 Do. Try. Open; First; Bs:= TBlobStream.Create( table1memo, bmread ); Richedit1.plaintext := false; Richedit1.Lines.Loadfromstream(bs); Finally. Bs.free; Close; End; End; Procedure TForm1.BtnPutClick(Sender: TObject); Var. Bs: TBlobStream; Begin. Bs:= Nil; With Table1 Do. Try. Open; First; Edit; Bs:= TBlobStream.Create( table1memo, bmwrite ); Richedit1.plaintext := false; Richedit1.Lines.Savetostream(bs); Post; Finally. Bs.free; Close; End; End;

Моя собственная база данных.

( Перевод одноимённой статьи с сайта delphi.about.com ).

В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для управления записью, чтением и изменением собственных типов файлов.

Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не охото работать с текстовыми файлами, так как просмотр и обновление информации в них довольно муторное занятие. Преобладать будут операции записи и чтения, в то время как операции изменения и апдейта будут присутствовать в меньшей степени. Вся информация будет хранится в переопределённом типе данных Pascal Record. Итак, какой подход мне лучше всего использовать?

BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать текстовые файлы ASCII ? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью видимы". Оказывается, ответ на данный вопрос кроется в Delphi, а именно в непечатных файлах (или файлы некоторых типов/бинарные файлы).

Файлы.

В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные определённого типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы содержат читаемые символы ASCII. Файлы Untyped используются в том случае, если мы хотим работать с файлом через определённую структуру.

Файлы Typed.

В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed содержат данные, взятые из определённой структуры данных.

Например, следующее объявление создаёт запись с именем TMember и массив переменных типа TMember, который мы будем использовать для хранения нашей информации.

Code: Type. TMember = record. Name : string[50]; EMail : string[30]; Posts : LongInt; End; Var Members : array[1..50] of TMember;

Подключение к Personal Oracle с помощью BDE.

Доступ к Регsоnа1 Oracle (как и к любой другой версии СУБД Oracle) осуществляется следующим образом. Сначала нужно запустить сервер (в случае Personal Oracle для Windows 95 это отдельное приложение, в случае Oracle для Windows NT - набор сервисов, обслуживающих конкретную базу данных) и настроить клиентскую часть Oracle. Для этого следует запустить утилиту SQLNet Easy Configuration (в случае Oracle 8 - Oracle Net8 Easy Config) и с ее помощью создать описание псевдонима базы данных Oracle (для него, как и в BDE, используется термин alias, но это не то же самое, что псевдоним BDE). При создании этого описания важны три параметра.

Первый из них - сетевой протокол, с помощью которого осуществляется доступ к серверу Oracle (IPX/SPX, TCP/IP и др.). Второй параметр - местоположение сервера в сети. В случае Personal Oracle это обычно компьютер с IP-адресом 127.0.0.1 (это специальный адрес для доступа к локальному компьютеру, так называемый TCP Loopback Address, который обычно имеет URL http://localhost/). Третий параметр - имя базы данных. По умолчанию в случае Personal Oracle она называется ORCL. В общем случае имя может быть любым, но это должно быть имя уже существующей базы данных, с которой вы собираетесь работать.

В принципе все описания псевдонимов Oracle хранятся в текстовом файле TNSNAMES.ORA, который можно редактировать вручную.

Далее следует запустить утилиту SQL Plus и проверить соединение клиента с сервером. Обычно в качестве имени пользователя используется имя SYSTEM и пароль MANAGER (если вы сами администрируете сервер). Если же сервер был установлен раньше, узнайте у администратора базы данных, каким именем и паролем следует воспользоваться. Помимо имени пользователя и пароля, SQL Plus запросит так называемую строку связи, в которой должно содержаться имя сервиса, который был создан вами перед этим. При удачном соединении в SQL Plus появится соответствующее сообщение. Отметим, что утилита Oracle Net8 Easy Config позволяет протестировать соединение непосредственно в процессе создания описания сервиса.

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

Теперь можно, наконец, заняться настройкой BDE. В качестве Server Name следует указать имя псевдонима Oracle (его можно просто выбрать из выпадающего списка, так как BDE Administrator также обращается к файлу TNSNAMES.ORA). После этого нужно проверить соединение с сервером через BDE с помощью BDE Administrator или SQL Explorer.

Если соединение не устанавливается и появляется сообщение "Vendor initialization failed", стоит убедиться, что динамическая загружаемая библиотека, указанная в параметре Vendor Init драйвера Oracle, действительно присутствует на данном компьютере. На всякий случай стоит скопировать ее в папку Windows\System, так как некоторые ранние версии BDE в Windows 95 не находят эту библиотеку в подкаталоге Bin каталога, в котором установлен клиент Oracle, в силу ограничений, налагаемых этой операционной системой на длину переменной окружения PATH. Отметим также, что при использовании Oracle 8 нужно использовать версию не ниже 8.0.4; в случае использования более ранней версии следует обновить ее до 8.0.4.

Наталия Елманова.

©Drkb::02733.

Взято из http://forum.sources.ru.

Проблемы использования компонента TStoredProc.

Недавно я перешел на использование Oracle, но все мои попытки использовать компонент TStoredProc оказываются неудачными. Почему?

Причины неработоспособности компонента TStoredProc могут быть следующими.

Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают).

Во-вторых, имеется известная проблема, описание которой содержится в разделе Developers Support корпоративного сайта Inprise (http://www.inprise.com). Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.

Наталия Елманова.

©Drkb::02634.

Взято из http://forum.sources.ru.

Дает ли Delphi возможность корректно прервать выполнение SQL-запроса (BDE)?

Дает ли Delphi возможность корректно прервать выполнение SQL-запроса к серверу Oracle с помощью BDE? Например, чтобы при использовании с SQL Plus после отправки SQL-запроса на выполнение на экране появлялось окно с кнопкой Cancel, которое давало бы возможность в любой момент прервать выполнение этого запроса?

Насколько мне известно, для этой цели лучше всего использовать функции Oracle Call Interface (низкоуровневый API Oracle). В комплекте поставки Oracle есть соответствующие примеры для C, и переписать их на Pascal несложно.

Некоторые драйверы SQL Link позволяют прекратить выполнение запроса, если время его выполнения превышает заранее заданное значение (параметр MAX QUERY TIME соответствующего драйвера). Однако драйвер ORACLE, к сожалению, в их число не входит.

Наталия Елманова.

©Drkb::02549.

Взято из http://forum.sources.ru.

Как заблокировать функцию вставки записи в компоненте TDBGrid?

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

Наиболее разумным представляется создать обработчик события OnBeforeInsert компонента TTable, TQuery или TClientDataSet, данные из которых отображаются в TDBGrid. Сам компонент TDBGrid не имеет подходящего события для обработки, так как это компонент, предназначенный только для создания пользовательского интерфейса, а в данном случае следует, по существу, запретить добавление записей в таблицу.

Наталия Елманова.

©Drkb::03033.

Взято из http://forum.sources.ru.

Физическое удаление записей в локальных таблицах (BDE).

При удалении записей из таблицы dBase с помощью компонента TTable они просто приобретают признак удаления, и я никак не могу добиться их физического удаления. Как быть?

Ваша проблема решается просто - для физического удаления записей нужно использовать функцию DbiPackTable (ее описание есть в справочном файле BDE).

Наталия Елманова.

©Drkb::02595.

Взято из http://forum.sources.ru.

Примечание Vit: точно так же удаляются записи и у таблиц других локальных баз данных.

В BDE есть функция DbiPackTable.

Упаковать таблицу DBF можно открыв ее компонентом TTable и вызвав функцию BDE DbiPackTable. Для этого нужно добавить к модулю, где вызывается функция, имена DBITypes, DBIProcs, DBIErrs в оператор uses.

Затем вызвать в нужном месте функцию:

Result := DbiPackTable(Table1.DbHandle, Table1.Handle, nil, szDBase, True);

©Drkb::02596.

Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349.

Access to table disabled because of previous error. Read failure.

При добавлении новых записей с помощью метода TTable.AppendRecord в индексированную таблицу FoxPro через какое-то время (то есть при одновременном добавлении большого количества записей) возникает ошибка:

"Access to table disabled because of previous error. Read failure. File <имя_файла.cdx>".

Возможно, причина заключается в том, что операции чтения-записи в файл, содержащий таблицу FoxPro, особенно при использовании кэширования, предоставляемого операционной системой, конфликтуют с содержимым индексного файла (это часто происходит при многопользовательской работе). Дело в том, что ранние версии dBase, FoxPro, Clipper работали с неподдерживаемыми индексами, то есть индексные файлы не обновлялись одновременно с таблицей, и для их синхронизации требовалось выполнять специальные операции. Но соответствующие средства разработки, применявшиеся в то время, обычно не поддерживали никаких аналогов транзакций - записи чаще всего вставлялись по одной.

В случае применения старых версий формата FoxPro следует избегать кэширования при выполнении дисковых операций с файловым сервером, содержащим базу данных FoxPro. Кроме того, следует проверить и, если необходимо, изменить в настройках BDE параметры MINBUFSIZE, MAXBUFSIZE, LOCAL SHARE - возможно, проблема заключается в недостаточной величине буферов BDE для кэширования данных или в одновременном доступе к данным приложений, использующих и не использующих BDE.

Еще одним из способов решения этой проблемы (самым радикальным) является замена FoxPro на какую-нибудь из серверных СУБД. Например, InterBase неплохо справляется с одновременным вводом большого количества записей благодаря некоторым специфическим особенностям архитектуры этого сервера.

Наталия Елманова.

©Drkb::02572.

Взято из http://forum.sources.ru.

Как открыть базу данных Microsoft Access .MDB в Delphi?

ADO.

Если у Вас Delphi 5 Enterprise или Delphi 5 Professional с ADO Express, то Вы можете использовать компонент ADOTable и в его свойстве ConnectionString настроить (build) подключение как базе данных MS Access. Например:

Code: Provider=Microsoft.Jet.OLEDB.4.0; User ID=Admin; Password=Password; Data Source=D:\Path\dbname.mdb; Mode=ReadWrite; Extended Properties=""; Persist Security Info=False; Jet OLEDB:System database=""; Jet OLEDB:Registry Path=""; Jet OLEDB:Database Password=""; Jet OLEDB:Engine Type=5; Jet OLEDB:Database Locking Mode=1; Jet OLEDB:Global Partial Bulk Ops=2; Jet OLEDB:Global Bulk Transactions=1; Jet OLEDB:New Database Password=""; Jet OLEDB:Create System Database=False; Jet OLEDB:Encrypt Database=False; Jet OLEDB:Don't Copy Locale on Compact=False; Jet OLEDB:Compact Without Replica Repair=True; Jet OLEDB:SFP=False.

Как можно открыть отчёт (в режиме Print Preview а также print direct) в MS Access ?

Code: Var. Access: Variant; Begin. // Открываем Access. Try. Access := GetActiveOleObject('Access.Application'); Except. Access := CreateOleObject('Access.Application'); End; Access.Visible := True; // Открываем базу данных. // Второй параметр указывает - будет ли база открыта в Exclusive режиме. Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True); // открываем отч?т. {Значение второго пораметра может быть одним из следующих. AcViewDesign, acViewNormal, or acViewPreview. acViewNormal, Которые устанавливаются по умолчанию, для печати отч?та. Если Вы не используете библиотеку типов, то можете определить. Эти значения следующими: Const. AcViewNormal = $00000000; AcViewDesign = $00000001; AcViewPreview = $00000002; Третий параметр - это имя очереди для текущей базы данных. Четв?ртый параметр - это строка для SQL-евского WHERE - То есть строка SQL, минус WHERE.}. Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam, EmptyParam); < ... > // Закрываем базу данных. Access.CloseCurrentDatabase; // Закрываем Access. {const. AcQuitPrompt = $00000000; AcQuitSaveAll = $00000001; AcQuitSaveNone = $00000002;}. Access.Quit(acQuitSaveAll); End;

Методы компрессии/декомпрессии.

Библиотека "TurboPower Abbrevia" - поддерживает многочисленные методы компрессии/декомпрессии, большое количество сопутствующих компонентов для работы с архивами. Бесплатная, с исходниками. Можно скачать на http://www.torry.net/compresspacks.htm

©Drkb::04177.

Взято из http://forum.sources.ru.

Как создать таблицу в MS Access при помощи DAO?

1. Объявляем переменные:

Code: Var. Access, db, td, recordset: Variant;

Как узнать путь базы данных и её имя?

Делается это при помощи dbiGetDatabaseDesc:

Code: Uses BDE; ..... Procedure ShowDatabaseDesc(DBName: string); Const. DescStr = 'Driver Name: %s'#13#10'AliasName: %s'#13#10 + 'Text: %s'#13#10'Physical Name/Path: %s'; Var. DbDes: DBDesc; Begin. DbiGetDatabaseDesc(PChar(DBName), @dbDes); With dbDes do. ShowMessage(Format(DescStr, [szDbType, szName, szText, szPhyName])); End;

Как очистить базу данных, оставив только структуру?

ЗАМЕЧАНИЕ: Этот пример не работает в режиме редактирования, так как таблица должна быть открыта в эксклюзивном режиме.

Code: Procedure TForm1.Button2Click(Sender: TObject); Begin. {Opens the table in exclusive mode}. Try. With Table1 Do. Begin. Active:=False; Exclusive:=True; Active:=True; Try. EmptyTable; Except. ShowMessage('Cannot empty database'); End; End. Except. ShowMessage('cannot open table in exclusive mode'); End. End;

Как использовать базу данных BDE не указывая её имени?

Если база данных находится в той же директории, что и экзешник, то в качестве имени базы можно использовать .\ в поле DatabaseName в TTable.

©Drkb::02537.

Взято из http://forum.sources.ru.

Примечания Vit:

1) Если путь другой - то в поле DatabaseName можно прописать путь, например: c:\Program Files\...

2) Прописывание путивместо alias не исключает необходимости использования BDE.

Как обновить TQuery не потеряв при этом текущей записи?

Code: Procedure RefreshQuery(AQuery : TQuery; const FieldsForSearch: String); Var. AList : TList; AVarArray : Variant; I : Byte; Begin. AList := TList.Create; Try. AQuery.GetFieldList(AList, FieldsForSearch); AVarArray := VarArrayCreate([0, AList.Count - 1], varVariant); For i := 0 to Pred(AList.Count) do. AVarArray[i] := TField(AList.Items[i]).AsVariant; AQuery.Close; AQuery.Open; AQuery.Locate(FieldsForSearch, AVarArray, []); Finally. AList.Free; AVarArray.Free;p. End; End;

Быстрый доступ к нужной записи в таблице Paradox.

Автор: Valler ( http://www.valler.narod.ru ).

Code: Var NeedNumber: Integer; ... NeedNumber := Table.RecNo; {сохранение номера нужной записи}. ... {код меняющий номе записи}. ... Table.RecNo := NeedNumber; {востановление номера нужной записи}.

Как напрямую добраться до Oracle?

Автор: Philip A. Milovanov ( http://korys.chat.ru ).

Для этого можно воспользоваться компонентами от AllRoundAutomations Direct Oracle Access. Если кому надо могу поделиться. При помощи этих компонент можно не только производить простые запросы/вставки, но и выполнять DDL-скрипты, и иметь доступ к объектам Oracle 8, примет смотри ниже...

Code: Var Address: TOracleObject; Begin. Query.SQL.Text := 'select Name, Address from Persons'; Query.Execute; While not Query.Eof do. Begin. Address := Query.ObjField('Address'); If not Address.IsNull then. ShowMessage(Query.Field('Name') + ' lives in ' + Address.GetAttr('City')); Query.Next; End; End;

Как при выполнении долгой операции в Oracle показать прогресс бар?

Автор: Philip A. Milovanov ( http://korys.chat.ru ).

Ниже приведен пример, как это сделать при помощи Direct Oracle Access, надеюсь этот кусок кода несложно запустить в отдельном процессе, а в другом можно запустить перемесчатель прогресс бара. Есть готовая компонента, могу поделиться.

Code: //на создании потока вставим то, что будет выбирать необходимую информацию. Self.fods.SQL.Text:='SELECT SOFAR FROM V$SESSION_LONGOPS WHERE CONTEXT=:FK_ID'; Self.fods.DeclareVariable('FK_ID',otInteger); Self.fods.SetVariable('FK_ID',ID); //На выполнение потока вешаем открытие/закрытие TOracleDataSet. While (Terminated = false) do. Begin. Self.fods.Close; Self.fods.Open; Self.fpb.Progress := Self.fods.FieldByName('SOFAR').AsInteger; //^^^^Эта строчка как раз и устанавливает нужный прогрессбар в нужную позицию... End;

Как сохранить содержимое таблицы в текстовый файл?

Эти небольшие функции анализирую таблицу и записывают её содержимое в TStringList. А затем просто сохраняют в файл.

Code: Procedure DatasetRecordToInfFile(aDataset: TDataSet; aStrList: TStrings); Var i: integer; Begin. For i := 0 to (aDataset.FieldCount-1) do. AStrList.Add(aDataset.Fields[i].FieldName + '=' + ADataset.Fields[i].AsString); End; Procedure DatasetToInfFile(aDataset: TDataSet; aStrList: TStrings); Begin. ADataSet.First; While not aDataSet.EOF do. Begin. DatasetRecordToInfFile(aDataset,aStrList); ADataSet.Next; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. DatasetRecordToInfFile(Table1,Memo1.Lines); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. DatasetToInfFile(Table1,Memo1.Lines); End;

Библиотека реализующая практически все распространённые алгоритмы шифрования и хэширования.

DCP - http://www.cityinthesky.co.uk/cryptography.html . Библиотека реализующая практически все распространённые алгоритмы шифрования и хэширования. Бесплатная с исходными кодами.

©Drkb::03980.

Взято из http://forum.sources.ru.

Как добавить копию текущей записи?

Следующая функция добавит в конец данных точную копию текущей записи.

Code: Procedure AppendCurrent(Dataset:Tdataset); Var. AField : Variant ; I : Integer ; Begin. // Создаём массив. AField := VarArrayCreate([0,DataSet.Fieldcount-1],VarVariant); // считываем значения в массив. For i := 0 to (DataSet.Fieldcount-1) do. AField[i] := DataSet.fields[i].Value ; DataSet.Append ; // помещаем значения массива в новую запись. For i := 0 to (DataSet.Fieldcount-1) do. DataSet.fields[i].Value := aField[i] ; End;

Как по имени Базы Данных получить ссылку на компоненет TDataBase?

Автор: Max Rezanov.

Code: Var. Db : TDataBase; Begin. Db := Session.FindDatabase(FDataBaseName); Db.StartTransaction;

Из Paradox в Access при помощи ADO.

(Перевод одноимённой статьи с сайта delphi.about.com ).

В данной статье мы обратим внимание на компонент TADOCommand и использование языка SQL DDL (Data Definition Language), с целью помочь Вам с проблемой переноса данных BDE/Paradox в ADO/Access.

Язык определения данных (Data Definition Language).

Не многие программисты создают базу данных программным путём, большинство из нас для этого используют некую визуальную среду наподобие MS Access для построения файла MDB. Но иногда нам всё таки приходится создавать и удалять базу данных, а так же объекты базы данных программным путём. Для этого используется наиболее распространённая на сегодняшний день технология Structured Query Language Data Definition Language (SQL DDL). Выраджения языка определения данных (DDL) - это SQL выражения, которые поддерживают определения или объявления объектов базы данных (например, CREATE TABLE, DROP TABLE, CREATE INDEX либо подобные им).

В рамки данной статьи не входит детальное ознакомление с языком DDL. Если Вы знакомы с языком SQL DML (Data Manipulation Language - это выражения типа SELECT, UPDATE и DELETE), то DDL не будет для Вас серьёзным барьером. Обратите внимание, что работа с DDL может быть весьма ухищрённой, так как каждый производитель базы данных може включать в неё собственные расширения для SQL.

Давайте взглянем на простейший пример выражения CREATE TABLE:

Code: CREATE TABLE PhoneBook( Name TEXT(50). Tel TEXT(50). );

Курсоры в ADO.

( перевод одноимённой статьи с сайта delphi.about.com ).

В Delphi компоненты ADOExpress довольно приятны в использовании. Однако программирование компонент ADOExpress весьма отличается от традиционного Delphi программирования в компонентах TTable и TQuery, основанных на BDE. Естевственно, что если Вы привыкли к компонентам BDE dataset, то сразу же заметите различие в количестве возможностей и свойств, а так же в стиле программирования BDE и ADO.

В основе ADO лежит объект Recordset (aka Dataset). Этот объект является результатом Query команды (например, выражение SELECT компонента TADOQuery). Когда ADO-приложение получает строки из базы данных, то объект ADO Recordset формирует необходимую информацию и операции, допустимые для получаемых данных. При этом ADO использует курсоры, чтобы хранить набор строк для обработанной записи. Так же курсор содержит в себе текущую позицию в записи (recordset). Обычно, при разработке приложения, курсоры используются при создании записей, а так же при перемещении по записям (вперёд или назад).

В ADO курсоры имеют три функции. Первая, это тип курсора, определющая допустимые перемещения в пределах курсора, а так же будут ли отражаться изменения пользователей в записи. Вторая, это местоположение курсора, определяющая место хранения записи, в то время, пока курсор остаётся открытым. Третья, это тип блокировки курсора, которая определяет как ADO datastore будет блокировать строки, если Вам потребуется внести изменения.

Каждый раз когда мы будем открывать определённую запись ADO, то мы будем открывать её с определённым типом курсора.

Класс TCustomADODataSet содержит набор свойств, событий и методов, для работы с данными, доступными через ADO datastore. Все классы-потомки от TCustomADODataSet (такие как TADODataSet, TADOTable, TADOQuery, и TADOStoredProc) совместно используют некоторые общие свойства. В каждом из этих классов присутствуют три свойства, соответствующие функциям курсоров, описанным выше: CursorType, CursorLocation, и LockType. Давайте рассмотрим эти свойства по-подробнее.

CursorType.

ADO содержит четы опции для данного типа курсора: dynamic, keyset, forward-only и static. Так как каждый тип курсора ведёт себя работает по разному, то несомненно Вы извлечёте пользу из каждого из этих видов курсоров.

Свойство CursorType указывает на то, каким образом Вы будете перемещаться по записям а так же какие изменения будут видны в записях базы данных, после того как Вы получите из неё данные. В Delphi классах ADO типы курсоров задаются в TCursorType.

CtDynamic.

Позволит Вам видеть добавления, изменения и удаления, сделанные другими пользователями, а также позволит делать все типы перемещения по записи (Recordset) не полагаясь на закладки. Однако закладки можно использовать, если они поддерживаются. Для этого существует метод Supports в ADODataset, который сигнализирует о поддержке определённых типов операций. Следующее выражение позволяет определить, поддерживаются закладки или нет:

If ADOTable1.Supports(coBookmark) then ...

Если несколько пользователей одновременно вставляют (insert), апдейтят (update), или удаляют (delete) строки в базе данных, то лучше всего выбрать курсор dynamic.

CtKeyset.

Ведет себя подобно динамическому курсору, за исключением того, что Вы не сможете видеть записи, которые добавляют другие пользователи, а так же не сможете получить доступ к записям, которые удаляются другими пользователями. Изменение данных другими пользователями будет все еще видимо. Этот тип всегда поддерживает закладки и поэтому позволяет все типы перемещения по записям (Recordset).

CtStatic.

Обеспечивает статическую копию набора записей, чтобы использовать её для поиска данных и генерации отчётов. Данный тип всегда разрешает закладки и поэтому позволяет все типы движения по записям. Добавления, изменения, или удаления другими пользователями не будут видимы. Статический курсор ведет себя подобно компоненту BDE Query со свойством RequestLive установленным в False.

CtForward-only.

Ведет себя идентично динамическому курсору за исключением того, что позволяет Вам пролистывать по записям только вперед. Это увеличивает производительность в ситуациях, где Вы необходимо делать только один проход по набору записей (Recordset).

Обратите внимание: если свойство CursorLocation в компоненте ADO dataset установлено в clUseClient, то Вы сможете использовать только опцию ctStatic.

Так же обратите внимание: что если Вы запросите тип курсора неподдерживаемый базой данных, то она может вернуть другой тип курсора. То есть если Вы пробуете установить CursorLocation в clUseServer и CursorType в ctDynamic, в базе данных Access, то Delphi заменит CursorType на ctKeyset.

CursorLocation.

Свойство CursorLocation определяет, где будет создан набор записей (recordset) когда он будет открыт — у клиента или на сервере.

Данные в клиентском (client-side) курсоре не сязаны постоянно ("inherently disconnected") с базой данных. ADO получает результаты запроса (все строки) и копирует данные клиенту перед тем, как Вы начнёте использовать их (в курсоре ADO). После того, как Вы сделаете изменения в наборе записей (Recordset), ADO преобразует эти изменения в запрос и отправляет этот запрос в Вашу базу данных через OLE DB. Клиентский (client-side) курсор ведёт себя подобно локальному кэшу.

В большинстве случаев, клиентский (client-side) курсор предпочтителен, потому что перемещения и обновления быстрее и более эффективны. Но, соответственно, увеличивается сетевой трафик при возвращении данных клиенту.

Использование серверного (server-side) курсора означает получение только необходимых записей. Естевственно, что на сервер падает большая нагрузка. Серверные (Server-side) курсоры полезны при вставке, модификации, удалении записей. Данный тип курсоров иногда обеспечивает лучшую производительность чем клиентский курсор, особенно когда сеть перегружена.

При выборе типа курсора Вам необходимо продумать множество факторов, таких как: будет ли у Вас большое количество обновлений либо Вы будете производить только выборку из базы данных; будете ли Вы использовать ADO как настольное приложение или Ваше приложение будет Internet-ориентированным; размер получаемых данных и т.д. Так же есть некоторое ограничения: например, MS Access не поддерживает динамических курсоров; вместо этого он использует keyset. Некоторые средства доступа к данным автоматически мастабируют свойства CursorType и CursorLocation, в то время как другие генерируют ошибку при использовании неподдерживаемых CursorType или CursorLocation.

LockType.

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

Такой эффект наблюдается в базе данных Access, которая блокирует некоторые соседние записи. Дело в том, что Access использует так называемую стратегию фиксации страницы. Поэтому, если пользователь редактирует запись, то другой пользователь уже не сможет получить доступ к изменению данной записи и, даже не сможет модифицировать ближе стоящие записи (до или после неё).

В Delphi, для этой цели используется TADOLockType в которой указывается тип блокировки, которая будет использоваться. Вы можете управлять строкой и блокировкой страницы, устанавливая соответствующую опцию блокировки курсора. Чтобы использовать определенную схему блокировки, провайдер и тип базы данных должны поддержать эту схему.

LtOptimistic.

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

LtPessimistic.

Пессимистическая блокировка блокирует каждую запись, до тех пор пока она находится в процессе редактирования. Эта опция заставляет ADO устанавливать исключительную блокировку на строку, когда пользователь делает любое изменения в любом столбцу записи. Компоненты ADOExpress непосредственно не поддерживают пессимистическую блокировку записей, потому что сама ADO не имеет возможности произвольно блокировать данную запись и до сих пор поддерживает навигацию в другие записи.

LtReadOnly.

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

LtBatchOptimistic.

Блокировка BatchOptimistic используется в клиентских курсорах. Наборы записей с данным курсором апдейтятся локально и все изменения отправляются в базу данных пакетами.

©Drkb::02652.

Взято из http://forum.sources.ru.

Поиск в базе данных.

Перевод одноимённой статьи с delphi.about.com.

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

В данной статье будут рассмотрены различные способы поиска данных разработке ADO-приложений в Delphi.

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

Давайте рассмотрим несколько способов расположения данных, полученных из БД посредствам компонента ADODataset (для Таблицы и для Запроса).

Locate.

Этот универсальный метод поиска устанавливает текущую запись как первую строку, удовлетворяющую набору критериев поиска. Используя метод Locate мы можем искать значения одного или более полей, расположенных в массиве переменных. В приведённом ниже коде, метод Locate ищет первую запись, содержащую строку 'Zoom' в поле 'Name'. Если вызов Locate возвращает True - то запись найдена и установлена как текущая.

Code: AdoTable1.Locate('Name','Zoom',[]); {...или...}. Var ffield, fvalue: string; Opts : TLocateOptions; Ffield := 'Name'; Fvalue := 'zoom'; Opts := [loCaseInsensitive]; If not AdoTable1.Locate(ffield, fvalue, opts) then. ShowMessage(fvalue + ' not found in ' + ffield);

Как узнать, доступен ли в сети сервер MS SQL?

Здесь представлена функция, выполняющая проверку доступности MS SQL сервера.

Code: Function CheckMSSQLServer(fServerName, fUserName, fPsw : String) : Bool; Var. WDb : TDatabase; Begin // Check if MS SQL Server is reachable. // Важно! BDE Должна быть установлена. Result := False; WDb := TDatabase.Create(nil); With wDb do. Begin. DatabaseName := 'wDbDatabaseName'; // arbitrary name, must be unique. // in current Session. Params.Values['SERVER Name'] := fServerName; Params.Values['USER Name'] := fUserName; Params.Values['PASSWORD'] := fPsw; LoginPrompt := False; End; Try. WDb.DriverName := 'MSSQL'; Try. WDb.Connected := True; WDb.Connected := False; Except. ShowMessage('Server is not reachable'); End; Result := True; Finally. WDb.Free; End; End;

Генератор SQL-запросов Insert/Update.

Автор: Mike Heydon.

Вам ещё не надоело динамически генерировать SQL запросы insert и update ? Давайте посмотрим, как можно раз и навсегда упростить этот процесс.

Допустим Вы создавали запрос следующим образом (типы параметров Data1:string Data2: integer Data3:TdateTime).

Code: SqlCmd := 'insert into MyTable (Field1,Field2,Field2) values (' + QuotedStr(Data1) + ',' + IntToStr(Data2) + ',' + 'to_date(' + QuotedStr(FormatdateTime('dd/mm/yyyy',Data3)) + ',' + QuotedStr('dd/mm/yyyy') + '))';

Как создать таблицу через SQL?

Следующая функция полностью совместима с Paradox:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Q: TQuery; Begin. Q := TQuery.Create(Application). Try. Q.DatabaseName := 'SF'; With Q.SQL do. Begin. Add('Create Table Funcionarios'); Add('( ID AutoInc, '); Add(' Name Char(30), '); Add(' Salary Money, '); Add(' Depno SmallInt, '); Add(' Primary Key ( ID ) ) '); End; Q.ExecSQL; Finally. Q.Free; End; End;

Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?

Quick Report не позволяет выгружать данные в формате Microsoft Excel. Но последние его версии позволяют сохранять отчеты в формате CSV (Comma Separated Value) и HTML, и оба эти формата можно прочесть с помощью Excel.

Помимо этого, для генерации отчета можно использовать автоматизацию Excel (Automation, ранее назвалось OLE Automation. — Прим. ред.), вообще не прибегая к использованию QuickReport.

Наталия Елманова.

©Drkb::03268.

Взято из http://forum.sources.ru.

Использование компонентов Decision Support System при генерации отчетов в QuickReport.

Возможно ли использование компонентов Decision Support System при генерации отчетов в QuickReport и, если да, то каким образом? Если QuickReport не подходит для этих целей, то какие другие варианты вы можете посоветовать?

Самый простой способ - использовать компоненты TQRLabel, текст в которых динамически меняется во время печати (то есть способ, которым можно напечатать все, что угодно, написав при этом немного кода). В принципе можно записать двухмерное сечение куба во временную таблицу или в компонент TClientDataSet, написав соответствующий цикл, и сделать отчет на ее основе.

Использование DecisionQuery в качестве источника данных для отчета также вполне возможно.

Другие возможные варианты - это использование автоматизации Word или Excel либо вычисление сумм внутри отчета. Можно также использовать другие генераторы отчетов - например, с помощью Crystal Reports можно создавать отчеты, содержащие кросс-таблицы.

Наталия Елманова.

©Drkb::03270.

Взято из http://forum.sources.ru.

Мемо в DBGrid.

Code: { A common problem when working with DBGrid is, that this component can't display TMemo fields, Multiline columns, Graphics... There are a few good freeware components around to solve this problem. The best one is definitly "DBGRIDPLUS", which comes with full sources. However, this component does not allow to edit the text in memo fields. The delphi fans out there who bought a delphi version that comes with the VCL sources can. Fix this problem: Open dbgrids.pas and make the following changes: (To have memo editing in your app you must just add the modifyed version of dbgrids.pas to your uses clause). } Function TCustomDBGrid.GetEditLimit: Integer; Begin. Result := 0; If Assigned(SelectedField) and (SelectedField.DataType in [ftString, ftWideString, ftMemo]) then <-- Add. Result := SelectedField.Size; End; Function TCustomDBGrid.GetEditText(ACol, ARow: Longint): string; Begin. Result := ''; If FDatalink.Active then. With Columns[RawToDataColumn(ACol)] do. If Assigned(Field) then. Result := Field.AsString; <-- Change this. FEditText := Result; End; { Just compare theese edited functions with the original ones, and you will know what to change. To get multiline cell support (not in memo fields!) for DBGridPlus, send me an email and i can send you the changed DBGridPlus.pas file. }

Оптимизация скинов для окошек сложной формы.

Автор: Бочаров Александр.

Немного предистории: надо было мне создать скиновое окошко. Вроде несложно, исходников по этому делу везде лежит навалом, бери да делай. Проблема организовалась в том, что для сложных фигур просчет такого окна из растра занимает достаточно много времени. А когда окон несколько? Короче, я решил все это дело написать самостоятельно, причем отказавшись от таких вещей, как GetPixel() и CombineRgn(). Получилось вроде здорово и быстро.

Далее следует исходный код с комментариями:

Code: Unit RgnUnit; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, SysUtils, Classes; Function CreateBitmapRgn(DC : hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn; { Данная функция создает регион, используя для этого растр Bitmap. И исключая из него цвет TransClr. Все расчеты производятся для. Устройства DC. Данная функция состоит из двух частей: Первая часть выделяет память и копирует туда исходное изображение в формате. 24 бита на точку, без палитры, т.е. фактически в каждых трех байтах. Данного раздела памяти будет записан цвет точки исходного изображения. Данный формат был выбран из удобства его обработки. (нет необходимости создавать палитру), к тому же нет потери качества. При конвертации исходного изображения. Однако, теоретически можно использовать. Любой формат. Для выделения памяти под конвертируемое изображение используется функция. WinAPI CreateDIBSection. Данная функция выделяет память и создает. Независмый растр. Для вызова данной функции необходимо заполнить структуру. BITMAPINFO, что достаточно не сложно. Внимание! для изображений Windows Bitmap используется разрешение в формате. Dots per metr (pixels per metr), стандартному разрешению 72dpi соответствует. 2834dpm. Фактически, данную функция можно не использовать, вручную выделив память. Для последующего переноса исходного изображения. Для конвертации и переноса исходного изображения в выделнную память. Используется функция WinAPI GetDIBits. Функции передаются следуюшие параметры: Исходное изображение, количество рядов для переноса, указатель на память, Куда следует перенести изображение, структура BITMAPINFO с заполнеными первыми. Шестью членами (именно здесь задяются параметры для конвертирования. Изображения). Фактически, данная функция может перевести любой исходный растр. В любой необходимый растр. Вторая чать описываемой функции проходится по области памяти, куда было. Занесено конвертируемое изображение, отсекает ненужные области и содает регион. Для создания региона используется функция WinAPI ExtCreateRegion. Для вызова. Данной функции необходимо заполнить структуру RGNDATA, состоящую из структуры. RGNDATAHEADER и необходимого количества структур RECT. в Дельфи структура. RGNDATA описана так: _RGNDATA = record. Rdh: TRgnDataHeader; Buffer: array[0..0] of CHAR; Reserved: array[0..2] of CHAR; End; RGNDATA = _RGNDATA; Скорее всего, поле Reserved было введено программистами Дельфи только для того, Чтобы в нее умещался хотя бы один прямоугольник, т.к. в Microsoft Platfrom SDK. Этого поля нет. Однако, данная структура нам не подходит, т.к. нам необходимо. Учитывать сразу несколько прямоугольников. Для решения этой задачи приходится. Выделять память вручную, с учетом RGNDATAHEADER и количества прямоугольников, Необходимых нам, заносить туда прямоугольники (после RGNDATAHEADER), Создавать указатель на структуру RGNDATA и ставить его на выделнную память. Следовательно, придется два раза пройтись по растру: первый раз - для расчета. Количества прямоугольников, а второй - для уже фактического их занесения. В выделенную память. Есть несколько способов для избежания двойного прохода растра, но все они. Имеют свои недостатки и здесь не рассматриваются. В любом случае, даже для. Больших и сложных изображений эти два прохода достаточно быстры. По окнчании работы функции освобождается память, выделенная на конвертируемый. Растр и структуру RGNDATA. } Implementation. //создает регион из растра Bitmap для DC с удалением цвета TransClr. //внимание! TColorRef и TColor не одно и тоже. //Для перевода используется функция ColorToRGB(). Function CreateBitmapRgn(DC: hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn; Var. BmInfo: TBitmap; //структура BITMAP WinAPI. W, H: Integer; //высота и ширина растра. BmDIB: hBitmap; //дискрептор независимого растра. BmiInfo: BITMAPINFO; //структура BITMAPINFO WinAPI. LpBits, lpOldBits: PRGBTriple; //указатели на структуры RGBTRIPLE WinAPI. LpData: PRgnData; //указатель на структуру RGNDATA WinAPI. X, Y, C, F, I: Integer; //переменные циклов. Buf: Pointer; //указатель. BufSize: Integer; //размер указателя. RdhInfo: TRgnDataHeader; //структура RGNDATAHEADER WinAPI. LpRect: PRect; //указатель на TRect (RECT WinAPI). Begin. Result:=0; If Bitmap=0 then Exit; //если растр не задан, выходим. GetObject(Bitmap, SizeOf(bmInfo), @bmInfo); //узнаем размеры растра. W:=bmInfo.bmWidth; //используя структуру BITMAP. H:=bmInfo.bmHeight; I:=(W*3)-((W*3) div 4)*4; //определяем смещение в байтах. If I<>0 then I:=4-I; //Пояснение: растр Windows Bitmap читается снизу вверх, причем каждая строка. //дополняется нулевыми байтами до ее кратности 4. //для 32-х битный растров такой сдвиг делать не надо. //заполняем BITMAPINFO для передачи в CreateDIBSection. BmiInfo.bmiHeader.biWidth:=W; //ширина. BmiInfo.bmiHeader.biHeight:=H; //высота. BmiInfo.bmiHeader.biPlanes:=1; //всегда 1. BmiInfo.bmiHeader.biBitCount:=24; //три байта на пиксель. BmiInfo.bmiHeader.biCompression:=BI_RGB; //без компрессии. BmiInfo.bmiHeader.biSizeImage:=0; //размер не знаем, ставим в ноль. BmiInfo.bmiHeader.biXPelsPerMeter:=2834; //пикселей на метр, гор. BmiInfo.bmiHeader.biYPelsPerMeter:=2834; //пикселей на метр, верт. BmiInfo.bmiHeader.biClrUsed:=0; //палитры нет, все в ноль. BmiInfo.bmiHeader.biClrImportant:=0; //то же. BmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); //размер структруы. BmDIB:=CreateDIBSection(DC, bmiInfo, DIB_RGB_COLORS, Pointer(lpBits), 0, 0); //создаем независимый растр WxHx24, без палитры, в указателе lpBits получаем. //адрес первого байта этого растра. bmDIB - дискрептор растра. //заполняем первые шесть членов BITMAPINFO для передачи в GetDIBits. BmiInfo.bmiHeader.biWidth:=W; //ширина. BmiInfo.bmiHeader.biHeight:=H; //высота. BmiInfo.bmiHeader.biPlanes:=1; //всегда 1. BmiInfo.bmiHeader.biBitCount:=24; //три байта на пиксель. BmiInfo.bmiHeader.biCompression:=BI_RGB; //без компресси. BmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); //размер структуры. GetDIBits(DC, Bitmap, 0, H, lpBits, bmiInfo, DIB_RGB_COLORS); //конвертируем исходный растр в наш с его копированием по адресу lpBits. LpOldBits:=lpBits; //запоминаем адрес lpBits. //первый проход - подсчитываем число прямоугольников, необходимых для. //создания региона. C:=0; //сначала ноль. For Y:=H-1 downto 0 do begin //проход снизу вверх. X:=0; While X<W do begin //от 0 до ширины-1. //пропускаем прзрачный цвет, увеличивая координату и указатель. While (X<W) and (RGB(lpBits.rgbtRed,lpBits.rgbtGreen,lpBits.rgbtBlue)=TransClr) do begin. Inc(lpBits); X:=X+1; End; //если нашли не прозрачный цвет, то считаем, сколько точек в ряду он идет. If (X<W) and (RGB(lpBits.rgbtRed,lpBits.rgbtGreen,lpBits.rgbtBlue)<>TransClr) then begin. While (X<W) and (RGB(lpBits.rgbtRed,lpBits.rgbtGreen,lpBits.rgbtBlue)<>TransClr) do begin. Inc(lpBits); X:=X+1; End; C:=C+1; //увиличиваем счетчик прямоугольников. End; End; //ряд закончился, необходимо увеличить указатель до кратности 4. PChar(lpBits):=PChar(lpBits)+I; End; LpBits:=lpOldBits; //восстанавливаем значение lpBits. //Заполняем структуру RGNDATAHEADER. RdhInfo.iType:=RDH_RECTANGLES; //будем использовать прямоугольники. RdhInfo.nCount:=C; //их количество. RdhInfo.nRgnSize:=0; //размер выделяем памяти не знаем. RdhInfo.rcBound:=Rect(0, 0, W, H); //размер региона. RdhInfo.dwSize:=SizeOf(rdhInfo); //размер структуры. //выделяем память для струтуры RGNDATA: //сумма RGNDATAHEADER и необходимых на прямоугольников. BufSize:=SizeOf(rdhInfo)+SizeOf(TRect)*C; GetMem(Buf, BufSize); LpData:=Buf; //ставим указатель на выделенную память. LpData.rdh:=rdhInfo; //заносим в память RGNDATAHEADER. //Заполдяенм память прямоугольниками. LpRect:=@lpData.Buffer; //первый прямоугольник. For Y:=H-1 downto 0 do begin. X:=0; While X<W do begin. While (X<W) and (RGB(lpBits.rgbtRed,lpBits.rgbtGreen,lpBits.rgbtBlue)=TransClr) do begin. Inc(lpBits); X:=X+1; End; If (X<W) and (RGB(lpBits.rgbtRed,lpBits.rgbtGreen,lpBits.rgbtBlue)<>TransClr) then begin. F:=X; While (X<W) and (RGB(lpBits.rgbtRed,lpBits.rgbtGreen,lpBits.rgbtBlue)<>TransClr) do begin. Inc(lpBits); X:=X+1; End; LpRect^:=Rect(F, Y, X, Y+1); //заносим координаты. Inc(lpRect); //переходим к следующему. End; End; PChar(lpBits):=PChar(lpBits)+I; End; //после окночания заполнения структуры RGNDATA можно создавать регион. //трансформации нам не нужны, ставим в nil, указываем размер. //созданной структуры и ее саму. Result:=ExtCreateRegion(nil, BufSize, lpData^); //создаем регион. FreeMem(Buf, BufSize); //теперь структура RGNDATA больше не нужна, удаляем. DeleteObject(bmDIB); //созданный растр тоже удаляем. End; End.

Перетасовка экрана в Delphi.

Перевод одноимённой статьи с сайта delphi.about.com ).

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

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

Как это всё осуществить.

Создайте новый проект Delphi с чистой формой. Установите свойство Name в 'Shuffler'. Добавьте на форму компоненты Image (Image1) и Timer (Timer1). Image будет содержать в себе изображение десктопа (разобранное), а Timer будет вызывать процедуру рисования. Свойство Interval компонента Timer определяет, как часто будет происходить перемешивание (значение 1000 эквивалентно одной секунде, 2000 - двум секундам).

Так же для проекта потребуется несколько глобальных переменных. Поместите следующий код перед секцией implementation в модуле формы:

Code: Var. Shuffler: TShuffler; //это было добавлено самой Delphi. DesktopBitmap : TBitmap; Gx, gy : Integer; RedRect : TBitmap; RW, rH : Integer; Const. DELTA = 8; //должно быть 2^n.

Как работать с палитрой в Delphi?

Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка (*.BMP файл), как изменить у него палитру цветов ?

Палитра в TBitmap и TMetaFile доступна через property Palette. Если палитра имеется (что совсем необязательно), то Palette<>0:

Code: Procedure TMain.BitBtnClick(Sender: TObject); Var. Palette : HPalette; PaletteSize : Integer; LogSize: Integer; LogPalette: PLogPalette; Red : Byte; Begin. Palette := Image.Picture.Bitmap.ReleasePalette; // здесь можно использовать просто Image.Picture.Bitmap.Palette, но я не. // знаю, удаляются ли ненужные палитры автоматически. If Palette=0 then exit; //Палитра отсутствует. PaletteSize := 0; If GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit; // Количество элементов в палитре = paletteSize. If PaletteSize = 0 then Exit; // палитра пустая. // определение размера палитры. LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry); GetMem(LogPalette, LogSize); Try. // заполнение полей логической палитры. With LogPalette^ do begin. PalVersion := $0300; palNumEntries := PaletteSize; GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry); // делаете что нужно с палитрой, например: Red := palPalEntry[PaletteSize-1].peRed; Edit1.Text := 'Красная составляющего последнего элемента палитры ='+IntToStr(Red); PalPalEntry[PaletteSize-1].peRed := 0; //....................................... End; // завершение работы. Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^); Finally. FreeMem(LogPalette, LogSize); // я должен позаботиться сам об удалении Released Palette. DeleteObject(Palette); End; End; { Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов). И меняет его палитру при нажатии кнопки }. Unit bmpformu; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TBmpForm = class(TForm). Button1: TButton; Procedure FormDestroy(Sender: TObject); Procedure FormPaint(Sender: TObject); Procedure Button1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. Bitmap: TBitmap; Procedure ScrambleBitmap; Procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND; End; Var. BmpForm: TBmpForm; Implementation. {$R *.DFM}. Procedure TBmpForm.FormCreate(Sender: TObject); Begin. Bitmap := TBitmap.Create; Bitmap.LoadFromFile('bor6.bmp'); End; Procedure TBmpForm.FormDestroy(Sender: TObject); Begin. Bitmap.Free; End; // since we're going to be painting the whole form, handling this. // message will suppress the uneccessary repainting of the background. // which can result in flicker. Procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd); Begin. M.Result := LRESULT(False); End; Procedure TBmpForm.FormPaint(Sender: TObject); Var x, y: Integer; Begin. Y := 0; While y < Height do begin. X := 0; While x < Width do begin. Canvas.Draw(x, y, Bitmap); X := x + Bitmap.Width; End; Y := y + Bitmap.Height; End; End; Procedure TBmpForm.Button1Click(Sender: TObject); Begin. ScrambleBitmap; Invalidate; End; // scrambling the bitmap is easy when it's has 256 colors: // we just need to change each of the color in the palette. // to some other value. Procedure TBmpForm.ScrambleBitmap; Var. Pal: PLogPalette; Hpal: HPALETTE; I: Integer; Begin. Pal := nil; Try. GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255); Pal.palVersion := $300; Pal.palNumEntries := 256; For i := 0 to 255 do. Begin. Pal.palPalEntry[i].peRed := Random(255); Pal.palPalEntry[i].peGreen := Random(255); Pal.palPalEntry[i].peBlue := Random(255); End; Hpal := CreatePalette(pal^); If hpal <> 0 then. Bitmap.Palette := hpal; Finally. FreeMem(pal); End; End; End.

Как вставить растровое изображение в компонент ListBox?

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.

Пример:

Рисуются изображения размером 32*16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!

Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.

Code: { Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}. Procedure TForm1.bLoadClick(Sender: TObject); VAR S : String; Begin. ListBox1.Clear; {чистим список}. S := '*.bmp'#0; {задаем шаблон}. ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список}. End; ............ {Отобразить изображения и имена файлов в ListBox}. Procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: DrawState); VAR. Bitmap : TBitmap; Offset : Integer; BMPRect: TRect; Begin. WITH (Control AS TListBox).Canvas DO BEGIN. FillRect(Rect); Bitmap := TBitmap.Create; Bitmap.LoadFromFile(ListBox1.Items[Index]); Offset := 0; IF Bitmap <> NIL THEN BEGIN. BMPRect := Bounds(Rect.Left+2, Rect.Top+2, (Rect.Bottom-Rect.Top-2)*2, Rect.Bottom-Rect.Top-2); {StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон}. BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap.Canvas.Pixels[0, Bitmap.Height-1]); Offset := (Rect.Bottom-Rect.Top+1)*2; END; TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[Index]); Bitmap.Free; END; End;

Можно ли из Delphi рисовать в любой части экрана или в чужом окне?

Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана:

Code: Function GetDC(Wnd: HWnd): HDC;

Число цветов (цветовая палитра) у данного компьютера.

Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 - 256 цветов, 4 - 16 цветов ...

Code: Function GetDisplayColors : integer; Var tHDC : hdc; Begin. THDC:=GetDC(0); Result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14); ReleaseDC(0, tHDC); End;

Копирование экрана.

Code: Unit ScrnCap; Interface. Uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls; { Копирует прямоугольную область экрана }. Function CaptureScreenRect(ARect : TRect) : TBitmap; { Копирование всего экрана }. Function CaptureScreen : TBitmap; { Копирование клиентской области формы или элемента }. Function CaptureClientImage(Control : TControl) : TBitmap; { Копирование всей формы элемента }. Function CaptureControlImage(Control : TControl) : TBitmap; {===============================================================} Implementation. Function GetSystemPalette : HPalette; Var. PaletteSize : integer; LogSize : integer; LogPalette : PLogPalette; DC : HDC; Focus : HWND; Begin. Result:=0; Focus:=GetFocus; DC:=GetDC(Focus); Try. PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE); LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry); GetMem(LogPalette, LogSize); Try. With LogPalette^ do. Begin. PalVersion:=$0300; PalNumEntries:=PaletteSize; GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry); End; Result:=CreatePalette(LogPalette^); Finally. FreeMem(LogPalette, LogSize); End; Finally. ReleaseDC(Focus, DC); End; End; Function CaptureScreenRect(ARect : TRect) : TBitmap; Var. ScreenDC : HDC; Begin. Result:=TBitmap.Create; With result, ARect do begin. Width:=Right-Left; Height:=Bottom-Top; ScreenDC:=GetDC(0); Try. BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY ); Finally. ReleaseDC(0, ScreenDC); End; Palette:=GetSystemPalette; End; End; Function CaptureScreen : TBitmap; Begin. With Screen do. Result:=CaptureScreenRect(Rect(0,0,Width,Height)); End; Function CaptureClientImage(Control : TControl) : TBitmap; Begin. With Control, Control.ClientOrigin do. Result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight)); End; Function CaptureControlImage(Control : TControl) : TBitmap; Begin. With Control do. If Parent=Nil then. Result:=CaptureScreenRect(Bounds(Left,Top,Width,Height)). Else. With Parent.ClientToScreen(Point(Left, Top)) do. Result:=CaptureScreenRect(Bounds(X,Y,Width,Height)); End; End.

Как узнать версию таблицы.

Code: Function GetTableVersion(Table: TTable): Longint; Var. HCursor: hDBICur; DT: TBLFullDesc; Begin. Check(DbiOpenTableList(Table.DBHandle, True, False, PChar(Table.TableName), hCursor)); Check(DbiGetNextRecord(hCursor, dbiNOLOCK, @DT, nil)); Result := DT.tblExt.iRestrVersion; Check(DbiCloseCursor(hCursor)); End;

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

Code: {Draw Disabled Text ************** ***** This function draws text in "disabled" style. ***** ***** i.e. the text is grayed . ***** **********************************************************} 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;

Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?

Предполагается, что поле BLOB (например, Pict).

2) в запросе Query.SQL пишется что-то вроде.

'select Pict from sometable where somefield=somevalue'

3) запрос открывается.

4) делается "присваивание":

Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict')).

Или, если известно, что эта картинка - Bitmap, то можно.

Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict')).

А можно воспользоваться компонентом TDBImage.

Зайцев О.В.

Владимиров А.М.

©Drkb::03626.

Взято из http://forum.sources.ru.

Как рисовать за пределами формы.

Создайте обработчик сообщения для WM_NCPAINT. Следующий пример рисует красную расмку вокруг формы шириной в один пиксель.

Code: Type. TForm1 = class(TForm). Private. { Private declarations }. Procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. 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;

Как рисовать в чужом окне или по всему экрану.

Code: Procedure DrawOnScreen; Var. ScreenDC: hDC; Begin. ScreenDC := GetDC(0); {получить контекст экрана}. Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать}. ReleaseDC(0, ScreenDC); {освободить контекст}. End;

Как изменить фоновый цвет текста?

Воспользуйтесь API функциями SetBkColor и TextOut.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. OldTextColor : TColorRef; OldBkColor : TColorRef; OldBkMode : Integer; Begin. OldTextColor := SetTextColor(Form1.Canvas.Handle, RGB(0, 0, 255)); OldBkColor := SetBkColor(Form1.Canvas.Handle, RGB(255, 0, 0)); OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE); TextOut(Form1.Canvas.Handle, 100, 100, 'Синий текст на красном фоне', 27); SetBkMode(Form1.Canvas.Handle, OldBkMode); SetBkColor(Form1.Canvas.Handle, OldBkColor); SetTextColor(Form1.Canvas.Handle, OldTextColor); End;

Bitmap в StringGrid ячейке.

Автор: Olivio Moura.

В обработчике события OnDrawCell элемента StringGrid поместите следующий код:

Code: With (Sender as TStringGrid) do. With Canvas do. Begin. {...} Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic); {...} End;

Управление наборами данных.

Компонент TSQLConnection позволяет выполнять некоторые операции с подключенными наборами данных и следить за их состоянием.

Свойство.

Property DataSetCount: Integer;

Возвращает число подключенных через данное соединение наборов данных.

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

Property ActiveStatements: LongWord;

Если сервер БД установил для данного соединения максимальное число одновременно выполняющихся запросов, то оно доступно в свойстве.

Property MaxStmtsPerConn: LongWord;

Поэтому перед открытием набора данных можно выполнять следующий код, который повысит надежность приложения:

If MyQuery.SQLConnection.ActiveStatements <= MyQuery.SQLConnection.MaxStmtsPerConn then.

MyQuery.Open.

Else.

MessageDlg ('Database connection is busy', mtWarning, [mbOK] , 0) ;

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

Procedure CloseDataSets;

Без разрыва соединения.

При необходимости компонент TSQLConnection может самостоятельно выполнять запросы SQL, не прибегая к помощи компонента TSQLQuery или TSQLDataSet. Для этого предназначена функция.

Function Execute(const SQL: string; Params: TParams; ResultSet:Pointer=nil): Integer;

Если запрос должен содержать параметры, то необходимо сначала создать объект — список параметров TParams и заполнить его. При этом, т. к. объект TParams еще не связан с конкретным запросом, важен порядок следования параметров, который должен совпадать в списке TParams и в тексте SQL.

Если запрос возвращает результат, метод автоматически создает объект типа TCustomSQLDataSet и возвращает указатель на него в параметр Resultset. Функция возвращает число обработанных запросом записей. Следующий фрагмент кода иллюстрирует применение функции Execute.

Code: Procedure TForml.SendBtnClick(Sender: TObject); Var FParams: TParams; FDataSet: TSQLDataSet; Begin. FParams := TParams.Create; Try. FParams.Items[0].Aslnteger := 1234; FParams.Items[1].AsInteger := 6751; MyConnection.Execute('SELECT * FROM Orders WHERE OrderNo >= :Ord AND. EmpNo = :Emp', FParams, FDataSet); If Assigned(FDataSet) then. With FDataSet do. Begin. Open; While Not EOF do. Begin. {...} Next ; End; Close; End; Finally. FParams.Free; End; End;

Как показать удалённые записи.

Code: Procedure DeletedRecords(Table: TTable; SioNo: Boolean); Begin. Table.DisableControls; Try. Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON, Longint(SioNo))); Finally. Table.EnableControls; End; Table.Refresh; End;

Как использовать TImageList для рисования прозрачных картинок.

Следующий пример демонстрирует, динамическое создание компонента TImageList, используемого для рисования прозрачного битмапа.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Bm : TBitmap; Il : TImageList; Begin. Bm := TBitmap.Create; Bm.LoadFromFile('C:\DownLoad\TEST.BMP'); Il := TImageList.CreateSize(bm.Width, Bm.Height); Il.DrawingStyle := dsTransparent; Il.Masked := true; Il.AddMasked(bm, clRed); Il.Draw(Form1.Canvas, 0, 0, 0); Bm.Free; Il.Free; End;

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

Code: 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;

©Drkb::03878.

Взято из http://forum.sources.ru.

Как создать Bitmap из массива пикселей.

Один из способов создания битмапа из массива пикселей заключается в использовании Windows API функции CreateDiBitmap(). Это позволит использовать один из многих форматов битмапа, которые Windows использует для хранения пикселей. Следующий пример создаёт 256-цветный битмап из массива пикселей. Битмап состит из 256 оттенков серого цвета плавно переходящих от белого к чёрному. Обратите внимание, что Windows резервирует первые и последние 10 цветов для системных нужд, поэтому Вы можете получить максимум 236 оттенков серого.

Code: {$IFNDEF WIN32}. Type. {Used for pointer math under Win16}. PPtrRec = ^TPtrRec; TPtrRec = record. Lo : Word; Hi : Word; End; {$ENDIF}. {Used for huge pointer math}. Function GetBigPointer(lp : pointer; Offset : Longint) : Pointer; Begin. {$IFDEF WIN32}. GetBigPointer := @PByteArray(lp)^[Offset]; {$ELSE}. Offset := Offset + TPtrRec(lp).Lo; GetBigPointer := Ptr(TPtrRec(lp).Hi + TPtrRec(Offset).Hi * SelectorInc, TPtrRec(Offset).Lo); {$ENDIF}. End; Procedure TForm1.Button1Click(Sender: TObject); Var. HPixelBuffer : THandle; {Handle to the pixel buffer}. LpPixelBuffer : pointer; {pointer to the pixel buffer}. LpPalBuffer : PLogPalette; {The palette buffer}. LpBitmapInfo : PBitmapInfo; {The bitmap info header}. BitmapInfoSize : longint; {Size of the bitmap info header}. BitmapSize : longint; {Size of the pixel array}. PaletteSize : integer; {Size of the palette buffer}. I : longint; {loop variable}. J : longint; {loop variable}. OldPal : hPalette; {temp palette}. HPal : hPalette; {handle to our palette}. HBm : hBitmap; {handle to our bitmap}. Bm : TBitmap; {temporary TBitmap}. Dc : hdc; {used to convert the DOB to a DDB}. IsPaletteDevice : bool; Begin. Application.ProcessMessages; {If range checking is on - turn it off for now}. {we will remember if range checking was on by defining}. {a define called CKRANGE if range checking is on.}. {We do this to access array members past the arrays}. {defined index range without causing a range check}. {error at runtime. To satisfy the compiler, we must}. {also access the indexes with a variable. ie: if we}. {have an array defined as a: array[0..0] of byte,}. {and an integer i, we can now access a[3] by setting}. {i := 3; and then accessing a[i] without error}. {$IFOPT R+}. {$DEFINE CKRANGE}. {$R-}. {$ENDIF}. {Lets check to see if this is a palette device - if so, then}. {we must do palette handling for a successful operation.}. {Get the screen's dc to use since memory dc's are not reliable}. Dc := GetDc(0); IsPaletteDevice := GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE; {Give back the screen dc}. Dc := ReleaseDc(0, dc); {Размер информации о рисунке должен равняться размеру BitmapInfo}. {плюс размер таблицы цветов, минус одна таблица}. {так как она уже объявлена в TBitmapInfo}. BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255); {The bitmap size must be the width of the bitmap rounded}. {up to the nearest 32 bit boundary}. BitmapSize := (sizeof(byte) * 256) * 256; {Размер палитры должен равняться размеру TLogPalette}. {плюс количество ячеек цветовой палитры - 1, так как}. {одна палитра уже объявлена в TLogPalette}. If IsPaletteDevice then. PaletteSize := sizeof(TLogPalette) + (sizeof(TPaletteEntry) * 255); {Выделяем память под BitmapInfo, PixelBuffer, и Palette}. GetMem(lpBitmapInfo, BitmapInfoSize); HPixelBuffer := GlobalAlloc(GHND, BitmapSize); LpPixelBuffer := GlobalLock(hPixelBuffer); If IsPaletteDevice then. GetMem(lpPalBuffer, PaletteSize); {Заполняем нулями BitmapInfo, PixelBuffer, и Palette}. FillChar(lpBitmapInfo^, BitmapInfoSize, #0); FillChar(lpPixelBuffer^, BitmapSize, #0); If IsPaletteDevice then. FillChar(lpPalBuffer^,PaletteSize, #0); {Заполняем структуру BitmapInfo}. LpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader); LpBitmapInfo^.bmiHeader.biWidth := 256; LpBitmapInfo^.bmiHeader.biHeight := 256; LpBitmapInfo^.bmiHeader.biPlanes := 1; LpBitmapInfo^.bmiHeader.biBitCount := 8; LpBitmapInfo^.bmiHeader.biCompression := BI_RGB; LpBitmapInfo^.bmiHeader.biSizeImage := BitmapSize; LpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0; LpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0; LpBitmapInfo^.bmiHeader.biClrUsed := 256; LpBitmapInfo^.bmiHeader.biClrImportant := 256; {Заполняем таблицу цветов BitmapInfo оттенками серого: от чёрного до белого}. For i := 0 to 255 do begin. LpBitmapInfo^.bmiColors[i].rgbRed := i; LpBitmapInfo^.bmiColors[i].rgbGreen := i; LpBitmapInfo^.bmiColors[i].rgbBlue := i; End;

Как создать регион(HRNG) по маске.

Ниже приведена функция, которая создаёт HRGN из чёрно-белого битмапа. Все чёрные пиксели становятся регионом, а белые становятся прозрачными. Так же не составит труда сделать преобразования для поддержки всех цветов и чтобы один из них был прозрачным.

По окончании необходимо освободить регион при помощи функции DeleteObject.

Code: Function BitmapToRgn(Image: TBitmap): HRGN; Var. TmpRgn: HRGN; X, y: integer; ConsecutivePixels: integer; CurrentPixel: TColor; CreatedRgns: integer; CurrentColor: TColor; Begin. CreatedRgns := 0; Result := CreateRectRgn(0, 0, Image.Width, Image.Height); Inc(CreatedRgns); If (Image.Width = 0) or (Image.Height = 0) then exit; For y := 0 to Image.Height - 1 do. Begin. CurrentColor := Image.Canvas.Pixels[0,y]; ConsecutivePixels := 1; For x := 0 to Image.Width - 1 do. Begin. CurrentPixel := Image.Canvas.Pixels[x,y]; If CurrentColor = CurrentPixel. Then inc(ConsecutivePixels). Else begin. // Входим в новую зону. If CurrentColor = clWhite then. Begin. TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1); CombineRgn(Result, Result, TmpRgn, RGN_DIFF); Inc(CreatedRgns); DeleteObject(TmpRgn); End; CurrentColor := CurrentPixel; ConsecutivePixels := 1; End; End; If (CurrentColor = clWhite) and (ConsecutivePixels > 0) then. Begin. TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1); CombineRgn(Result, Result, TmpRgn, RGN_DIFF); Inc(CreatedRgns); DeleteObject(TmpRgn); End; End; End;

Как поместить битмап в метафайл.

Следующий пример демонстрирует рисование битмапа в метафайле.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. M : TmetaFile; Mc : TmetaFileCanvas; B : tbitmap; Begin. M := TMetaFile.Create; B := TBitmap.create; B.LoadFromFile('C:\SomePath\SomeBitmap.BMP'); M.Height := b.Height; M.Width := b.Width; Mc := TMetafileCanvas.Create(m, 0); Mc.Draw(0, 0, b); Mc.Free; B.Free; M.SaveToFile('C:\SomePath\Test.emf'); M.Free; Image1.Picture.LoadFromFile('C:\SomePath\Test.emf'); End;

Заполняем Canvas рисунком с рабочего стола, учитывая координаты.

Function PaintDesktop(HDC) : boolean;

Например: PaintDesktop(form1.Canvas.Handle);

Зайцев О.В.

Владимиров А.М.

©Drkb::03739.

Взято из http://forum.sources.ru.

Как создать временный canvas.

Создайте Bitmap, и воспользуйтесь свойством холста TBitmap-а, чтобы рисовать на нём. Следующий пример создаёт Bitmap, рисует на его canvas-е, рисует canvas на форме, а затем освобождает bitmap.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Bm : TBitmap; Begin. Bm := TBitmap.Create; Bm.Width := 100; Bm.Height := 100; Bm.Canvas.Brush.Color := clRed; Bm.Canvas.FillRect(Rect(0, 0, 100, 100)); Bm.Canvas.MoveTo(0, 0); Bm.Canvas.LineTo(100, 100); Form1.Canvas.StretchDraw(Form1.ClientRect, Bm); Bm.Free; End;

Как очистить canvas.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. PatBlt(Form1.Canvas.Handle,0,0,Form1.ClientWidth,Form1.ClientHeight,WHITENESS); End;

Как добавить пароль к таблице.

Code: Uses. Bde, SysUtils, dbtables, windows; Function StrToOem(const AnsiStr: string): string; Begin. SetLength(Result, Length(AnsiStr)); If Length(Result) 0 then. CharToOem(PChar(AnsiStr), PChar(Result)); End; Function TablePasswort(var Table: TTable; password: string): Boolean; Var. PTblDesc: pCRTblDesc; HDb: hDBIDb; Begin. Result := False; With Table do. Begin. If Active and (not Exclusive) then Close; If (not Exclusive) then Exclusive := True; If (not Active) then Open; HDB := DBHandle; Close; End; GetMem(pTblDesc, SizeOf(CRTblDesc)); FillChar(pTblDesc^, SizeOf(CRTblDesc), 0); With pTblDesc^ do. Begin. StrPCopy(szTblName, StrToOem(Table.TableName)); SzTblType := szParadox; StrPCopy(szPassword, StrToOem(Password)); BPack := True; BProtected := True; End; If DbiDoRestructure(hDb, 1, pTblDesc, nil, nil, nil, False) DBIERR_NONE then Exit; If pTblDesc nil then FreeMem(pTblDesc, SizeOf(CRTblDesc)); Result := True; End;

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

Code: Пример рисует две горизонтальные линии на экране используя 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.

Преобразование цвета RGB <-> HLS.

Code: {Максимальные значения }. Const. HLSMAX = 240; RGBMAX = 255; UNDEFINED = (HLSMAX*2) div 3; Var. H, L, S : integer; { H-оттенок, L-яркость, S-насыщенность }. R, G, B : integer; { цвета }. Procedure RGBtoHLS; Var. CMax,cMin : integer; Rdelta,Gdelta,Bdelta : single; Begin. CMax := max( max(R,G), B); CMin := min( min(R,G), B); L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) ); If (cMax = cMin) then begin. S := 0; H := UNDEFINED; End else begin. If (L <= (HLSMAX/2)) then. S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) ). Else. S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) ). / (2*RGBMAX-cMax-cMin) ); Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin); Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin); Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin); If (R = cMax) then H := round(Bdelta - Gdelta). Else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta). Else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta ); If (H < 0) then H:=H + HLSMAX; If (H > HLSMAX) then H:= H - HLSMAX; End; If S<0 then S:=0; if S>HLSMAX then S:=HLSMAX; If L<0 then L:=0; if L>HLSMAX then L:=HLSMAX; End; Procedure HLStoRGB; Var. Magic1,Magic2 : single; Function HueToRGB(n1,n2,hue : single) : single; Begin. If (hue < 0) then hue := hue+HLSMAX; If (hue > HLSMAX) then hue:=hue -HLSMAX; If (hue < (HLSMAX/6)) then. Result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) ). Else. If (hue < (HLSMAX/2)) then result:=n2 else. If (hue < ((HLSMAX*2)/3)) then. Result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6))). Else result:= ( n1 ); End; Begin. If (S = 0) then begin. B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B; End else begin. If (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX. Else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX; Magic1 := 2*L-Magic2; R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX ); G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX ); B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX ); End; If R<0 then R:=0; if R>RGBMAX then R:=RGBMAX; If G<0 then G:=0; if G>RGBMAX then G:=RGBMAX; If B<0 then B:=0; if B>RGBMAX then B:=RGBMAX; End;

Как сделать стандартные цвета в Delphi светлее или темнее.

Автор: Den Bedard.

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

Итак, немного теории:

Каждый из трёх основных цветов (Красный,Зелёный,Синий) могут иметь значение от 0 до 255, соответственно скомбинировав их мы можем получить 16,777,216 возможных цветов. Визуально это можно предствить как три оси куба, в котором направления x, y и z отвечают за цвета красный, зелёный и синий. В сочетании эти направления дают точку в кубе, представляющую один цвет из 16 миллионов. Точка куба, в которой значение равняется 0 (0,0,0) соответствует чёрному цвету, значение (255,255,255) - белому цвету, (255,0,0) - чисто красному, и т.д.

Если визуально провести линию между каким-либо цветом (r,g,b) и белым цветом (255,255,255), то получится, что на этой линии будут лежать все значения данного цвета (r,g,b). Если мы будем двигаться по линии в сторону белого цвета, то яркость будет увеличиваться до тех пор пока не получим чисто белый цвет.

То же самое можно сделать и для уменьшения яркости цвета. Достаточно провести линию из цвета (r,g,b) в чёрный (0,0,0). То есть при движении по линии к чёрному цвету мы будем уменьшать яркость до тех пор, пока не получим чёрный цвет.

Функция "Darker" возвращает новое значение цвета, которое будет на сколько-то процентов темнее. Естевственно, что при 100% мы получим чёрный цвет.

Функция "Lighter" возвращает цвет, который светлее на сколько-то процентов исходного. 100% - белый цвет.

Функции Darker и Lighter требуют 2 параметра и используются примерно так:

Panel1.Color := Darker(clBlue,20);

Получется панель цветов, которая на 20% темнее обычного синего цвета.

Теперь давайте посмотрим, как выглядят внутри наши функции:

Code: Function Darker(Color:TColor; Percent:Byte):TColor; Var. R,g,b:Byte; Begin. Color:=ColorToRGB(Color); R:=GetRValue(Color); G:=GetGValue(Color); B:=GetBValue(Color); R:=r-muldiv(r,Percent,100); //процент% уменьшения яркости. G:=g-muldiv(g,Percent,100); B:=b-muldiv(b,Percent,100); Result:=RGB(r,g,b); End; Function Lighter(Color:TColor; Percent:Byte):TColor; Var. R,g,b:Byte; Begin. Color:=ColorToRGB(Color); R:=GetRValue(Color); G:=GetGValue(Color); B:=GetBValue(Color); R:=r+muldiv(255-r,Percent,100); //процент% увеличения яркости. G:=g+muldiv(255-g,Percent,100); B:=b+muldiv(255-b,Percent,100); Result:=RGB(r,g,b); End; Так же я добавил некоторые функции, в которых уже добавлены стандартные значения процентов. Это для тех, кому некогда задумываться над процентами :). Panel1.Color := Light(clBlue); Panel1.Color := SlightlyDark(clRed); Panel1.Color := VeryLight(clMagenta); Etc. Function SlightlyDark(Color:TColor):TColor; Begin. Result := Darker(Color,25); End; Function Dark(Color:TColor):TColor; Begin. Result := Darker(Color,50); End; Function VeryDark(Color:TColor):TColor; Begin. Result := Darker(Color,75); End; Function SlightlyLight(Color:TColor):TColor; Begin. Result := Lighter(Color,25); End; Function Light(Color:TColor):TColor; Begin. Result := Lighter(Color,50); End; Function VeryLight(Color:TColor):TColor; Begin. Result := Lighter(Color,75); End;

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

Следущий пример показывает, как преобразовать RGB цвет в аналогичный оттенок серого, наподобие того, как это делает чёрно-белый телевизор:

Code: 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;

Пример.

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. Shape1.Brush.Color := RGB(255, 64, 64); Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color); End;

©Drkb::03673.

Взято из http://forum.sources.ru.

Code: // Используется функция преобразования изображения в оттенки серого. // взятая из UBPFD - http://delphibase.endimus.com/ // автор: Николай Федоровских - mailto: chook_nu@uraltc.ru. Procedure ModColors(Bitmap: TBitmap; Color: TColor); Function GetR(const Color: TColor): Byte; //извлечение красного. Begin. Result := Lo(Color); End; Function GetG(const Color: TColor): Byte; //извлечение зелёного. Begin. Result := Lo(Color shr 8); End; Function GetB(const Color: TColor): Byte; //извлечение синего. Begin. Result := Lo((Color shr 8) shr 8); End; Function BLimit(B: Integer): Byte; Begin. If B < 0 then Result := 0. Else if B > 255 then Result := 255. Else Result := B; End; Type TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var r1, g1, b1: Byte; X, y: Integer; Dest: pRGB; A: Double; Begin. Bitmap.PixelFormat := pf24Bit; R1 := Round(255 / 100 * GetR(Color)); G1 := Round(255 / 100 * GetG(Color)); B1 := Round(255 / 100 * GetB(Color)); For y := 0 to Bitmap.Height - 1 do begin. Dest := Bitmap.ScanLine[y]; For x := 0 to Bitmap.Width - 1 do begin. With Dest^ do begin. A := (r + b + g) / 300; With Dest^ do begin. R := BLimit(Round(r1 * A)); G := BLimit(Round(g1 * A)); B := BLimit(Round(b1 * A)); // Небольшая поправка к оригинальной функции. If (R=255) and (G=255) and (B=255) then begin. R:= 216; G:= 212; B:= 240; End; End; End; Inc(Dest); End; End; End;

пример использования:

Code: ModColors(BitMap, RGB(150,150,150));

Автор: Rouse_

Взято из http://forum.sources.ru.

©Drkb::03674.

Смешиваем два цвета.

Самый простой способ смешать два цвета c1 и c2, это вычислить средние значения rgb-значений. Данный пример не отличается особой быстротой, поэтому если Вам нужно быстро смешивать цвета, то прийдётся пошевелить мозгами...

Code: Function GetMixColor (c1, c2: TColor): TColor; Begin. // вычисляем средние значения Красного, Синего и Зелёного значений. // цветов c1 и c2: Result := RGB ( (GetRValue (c1) + GetRValue (c2)) div 2, (GetGValue (c1) + GetGValue (c2)) div 2, (GetBValue (c1) + GetBValue (c2)) div 2. ); End;

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

The following functions RGBTOCMYK() and CMYKTORGB().

Demonstrate how to convert between RGB and CMYK color.

Spaces. Note: There is a direct relationship between RGB.

Colors and CMY colors. In a CMY color, black tones are.

Achieved by printing equal amounts of Cyan, Magenta, and.

Yellow ink. The black component in a CMY color is achieved.

By reducing the CMY components by the minimum of (C, M,

And Y) and substituting pure black in its place producing a.

Sharper print and using less ink. Since it is possible for a user.

To boost the C,M and Y components where boosting the black.

Component would have been preferable, a ColorCorrectCMYK().

Function is provided to achieve the same color by reducing the.

C, M and Y components, and boosting the K component.

Example:

Code: 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;

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

Code: Function RGBToColor(R,G,B:Byte): TColor; Begin. Result:=B Shl 16 Or. G Shl 8 Or. R; End;

TIF ---> PDF.

Автор: Morten Ravn-Jonsen.

Совместимость: Delphi 5.x (или выше).

Как-то раз получился TIF файл на несколько страниц и возникла необходимость конвертации его в PDF формат. Для использования такой возможности необходимо иметь полную версию Adobe Acrobat. Функция тестировалась на Adobe Acrobat 4.0.

Сперва Вам необходимо импортировать элементы управления Acrobat AxtiveX.

1) Выберите Component -> Import ActiveX Control.

2) Выберите Acrobat Control for ActiveX и нажмите install.

3) Выберите пакет ActiveX control для инсталяции.

4) Добавьте PDFlib_tlb в Ваш проект. Этот файл находится в директории Borland\Delphi5\Imports.

Как использовать функцию.

Вот пример её вызова:

If not TifToPDF('c:\test.tif', 'c:\test.pdf') then Showmessage('Could not convert');

Функция TifToPdf.

Code: Function TifToPDF(TIFFilename, PDFFilename: string): boolean; Var. AcroApp : variant; AVDoc : variant; PDDoc : variant; IsSuccess : Boolean; Begin. Result := false; If not fileexists(TIFFilename) then exit; Try. AcroApp := CreateOleObject('AcroExch.App'); AVDoc := CreateOleObject('AcroExch.AVDoc'); AVDoc.Open(TIFFilename, ''); AVDoc := AcroApp.GetActiveDoc; If AVDoc.IsValid then. Begin. PDDoc := AVDoc.GetPDDoc; PDDoc.SetInfo ('Title', ''); PDDoc.SetInfo ('Author', ''); PDDoc.SetInfo ('Subject', ''); PDDoc.SetInfo ('Keywords', ''); Result := PDDoc.Save(1 or 4 or 32, PDFFilename); PDDoc.Close; End; AVDoc.Close(True); AcroApp.Exit; Finally. VarClear(PDDoc); VarClear(AVDoc); VarClear(AcroApp); End; End;

BMP ---> ICO.

Автор: Bernhard Angerer.

Вам необходимо создать два битмапа, битмап маски (назовём его "AND" bitmap) и битмап изображения (назовём его XOR bitmap). Вы можете пропустить обработчики для "AND" и "XOR" битмапов в Windows API функции CreateIconIndirect() и использовать обработчик возвращённой иконки в Вашем приложении.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap; XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon; Begin. {Получаем размер иконки}. IconSizeX := GetSystemMetrics(SM_CXICON); IconSizeY := GetSystemMetrics(SM_CYICON); {Создаём маску "And"}. AndMask := TBitmap.Create; AndMask.Monochrome := true; AndMask.Width := IconSizeX; AndMask.Height := IconSizeY; {Рисуем на маске "And"}. AndMask.Canvas.Brush.Color := clWhite; AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); AndMask.Canvas.Brush.Color := clBlack; AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Рисуем для теста}. Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); {Создаём маску "XOr"}. XOrMask := TBitmap.Create; XOrMask.Width := IconSizeX; XOrMask.Height := IconSizeY; {Рисуем на маске "XOr"}. XOrMask.Canvas.Brush.Color := ClBlack; XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); XOrMask.Canvas.Pen.Color := clRed; XOrMask.Canvas.Brush.Color := clRed; XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Рисуем в качестве теста}. Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); {Создаём иконку}. Icon := TIcon.Create; IconInfo.fIcon := true; IconInfo.xHotspot := 0; IconInfo.yHotspot := 0; IconInfo.hbmMask := AndMask.Handle; IconInfo.hbmColor := XOrMask.Handle; Icon.Handle := CreateIconIndirect(IconInfo); {Уничтожаем временные битмапы}. AndMask.Free; XOrMask.Free; {Рисуем в качестве теста}. Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); {Объявляем иконку в качестве иконки приложения}. Application.Icon := Icon; {генерируем перерисовку}. InvalidateRect(Application.Handle, nil, true); {Освобождаем иконку}. Icon.Free; End;

BMP ---> WMF.

Code: Procedure ConvertBMP2WMF. (const BMPFileName, WMFFileName: TFileName); Var. MetaFile : TMetafile; Bitmap : TBitmap; Begin. Metafile := TMetaFile.Create; Bitmap := TBitmap.Create; Try. Bitmap.LoadFromFile(BMPFileName); With MetaFile do. Begin. Height := Bitmap.Height; Width := Bitmap.Width; Canvas.Draw(0, 0, Bitmap); SaveToFile(WMFFileName); End; Finally. Bitmap.Free; MetaFile.Free; End; End;

Сохранить F1Book в Blob поле.

Code: Uses vcf1, dbtables; Procedure SaveSpreadsheet(F1Book: TF1Book); Var. BlobStream: TBlobStream; MyBlob: HGlobal; Pblob: Pointer; Begin. With Datamodule1.Query1 do. Begin. Set8087CW($133f); Try. Application.ProcessMessages; F1Book.SaveWindowInfo; MyBlob := GlobalAlloc(GMEM_MOVEABLE, 2000); Try. F1Book.WriteToBlob(MyBlob, 0); PBlob := globalLock(MyBlob); Try. Blobstream := TBlobStream.Create(TBlobField(FieldByName('QUOTE_BLOB')), BmWrite); Try. Blobstream.Write(pBlob^, GlobalSize(myBlob)); Finally. Blobstream.Free; End; Finally. GlobalUnlock(MyBlob); End; F1book.IF1Book_Modified := False; Finally. GlobalFree(myblob); End; Finally. Set8087CW(Default8087CW); Application.ProcessMessages; End; End; End; //Depending on your Delphi Version (<D4), you will need: Var. Default8087CW: Word = $1332; Procedure Set8087CW(NewCW: Word); Asm. MOV Default8087CW,AX. FLDCW Default8087CW. End;

WMF ---> BMP.

Code: Procedure ConvertWMF2BMP. (const WMFFileName, BMPFileName: TFileName); Var. MetaFile : TMetafile; Bitmap : TBitmap; Begin. Metafile := TMetaFile.Create; Bitmap := TBitmap.Create; Try. MetaFile.LoadFromFile(WMFFileName); With Bitmap do. Begin. Height := Metafile.Height; Width := Metafile.Width; Canvas.Draw(0, 0, MetaFile); SaveToFile(BMPFileName); End; Finally. Bitmap.Free; MetaFile.Free; End; End;

Обмен данными с Excel.

Автор: Fernando Silva.

В Delphi 5, для обмена данными между Вашим приложением и Excel можно использовать компонент TExcelApplication, доступный на Servers Page в Component Palette.

На форме находится TStringGrid, заполненный некоторыми данными и две кнопки, с названиями To Excel и From Excel. Так же на форме находится компонент TExcelApplication со свойством Name, содержащим XLApp и свойством ConnectKind, содержащим ckNewInstance.

Когда нам необходимо работать с Excel, то обычно мы открываем ExcelApplication, затем открываем WorkBook и в конце используем WorkSheet.

Итак, несомненный интерес представляет для нас листы (WorkSheets) в книге (WorkBook). Давайте посмотрим как всё это работает.

Посылка данных в Excel.

Это можно сделать с помощью следующей процедуры :

Code: Procedure TForm1.BitBtnToExcelOnClick(Sender: TObject); Var. WorkBk: _WorkBook; // определяем WorkBook. WorkSheet: _WorkSheet; // определяем WorkSheet. I, J, K, R, C: Integer; IIndex: OleVariant; TabGrid: Variant; Begin. If GenericStringGrid.Cells[0, 1] <> '' then. Begin. IIndex := 1; R := GenericStringGrid.RowCount; C := GenericStringGrid.ColCount; // Создаём массив-матрицу. TabGrid := VarArrayCreate([0, (R - 1), 0, (C - 1)], VarOleStr); I := 0; // Определяем цикл для заполнения массива-матрицы. Repeat. For J := 0 to (C - 1) do. TabGrid[I, J] := GenericStringGrid.Cells[J, I]; Inc(I, 1); Until. I > (R - 1); // Соединяемся с сервером TExcelApplication. XLApp.Connect; // Добавляем WorkBooks в ExcelApplication. XLApp.WorkBooks.Add(xlWBatWorkSheet, 0); // Выбираем первую WorkBook. WorkBk := XLApp.WorkBooks.Item[IIndex]; // Определяем первый WorkSheet. WorkSheet := WorkBk.WorkSheets.Get_Item(1) as _WorkSheet; // Сопоставляем Delphi массив-матрицу с матрицей в WorkSheet. Worksheet.Range['A1', Worksheet.Cells.Item[R, C]].Value := TabGrid; // Заполняем свойства WorkSheet. WorkSheet.Name := 'Customers'; Worksheet.Columns.Font.Bold := True; Worksheet.Columns.HorizontalAlignment := xlRight; WorkSheet.Columns.ColumnWidth := 14; // Заполняем всю первую колонку. WorkSheet.Range['A' + IntToStr(1), 'A' + IntToStr(R)].Font.Color := clBlue; WorkSheet.Range['A' + IntToStr(1), 'A' + IntToStr(R)].HorizontalAlignment := xlHAlignLeft; WorkSheet.Range['A' + IntToStr(1), 'A' + IntToStr(R)].ColumnWidth := 31; // Показываем Excel. XLApp.Visible[0] := True; // Разрываем связь с сервером. XLApp.Disconnect; // Unassign the Delphi Variant Matrix. TabGrid := Unassigned; End; End;

Как сохранить все картинки TWebbrowser?

Code: Uses. UrlMon; Function DownloadFile(SourceFile, DestFile: string): Boolean; Begin. Try. Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, Nil) = 0; Except. Result := False; End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. K, p: Integer; Source, dest, ext: string; Begin. For k := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do. Begin. Source := WebBrowser1.OleObject.Document.Images.Item(k).Src; P := LastDelimiter('.', Source); Ext := UpperCase(Copy(Source, p + 1, Length(Source))); If (ext = 'GIF') or (ext = 'JPG') then. Begin. P := LastDelimiter('/', Source); Dest := ExtractFilePath(ParamStr(0)) + Copy(Source, p + 1, Length(Source)); DownloadFile(Source, dest); End; End; End;

Как загрузить webpage с скрытым IP?

Code: { Add a button and memo }. Implementation. {$R *.dfm}. Uses. Urlmon; Procedure TForm1.Button1Click(Sender : TObject); Var. Ca : iinterface; Rls : Integer; Stat : iBindStatusCallBack; Rr : Cardinal; Tag : _tagBindInfo; ExGuid : tguid; NoIp : Pointer; Res : HResult; Begin. // Make a 0.0.0.0 ip giud. ExGuid.D1 := rr; ExGuid.D2 := word('0'); ExGuid.D3 := word('.'); // Set Tag options. With tag do. Begin. // set "0." ip guid. Iid := exGuid; // set needed size. CbSize := sizeOf('www.big-x.cjb.net'); // Add ip hiding ( not tested, but should work ). SecurityAttributes.lpSecurityDescriptor := noIp; SecurityAttributes.nLength := length('0.0.0.0'); SecurityAttributes.bInheritHandle := True; End;{ Extra: res := stat.GetBindInfo(rr, tag);}. //Start downloading webpage. Try. Urlmon.URLDownloadToFile(ca, 'www.big-x.cjb.net', 'filename.htm', 1, stat); Except. ShowMessage('Could not download the webpage!'); End; //Load the webpage source to a memo. Memo1.Lines.LoadFromFile('filename.htm'); End;

Перехват сообщений IE.

Code: { This component allows you to intercept Internet Explorer messages such as. "StatusTextChangeEvent", "DocumentCompleteEvent" and so on. } //---- Component Source: Install this component first. Unit IEEvents; Interface. Uses. Windows, SysUtils, Classes, Graphics, ComObj, ActiveX, SHDocVW; Type. // Event types exposed from the Internet Explorer interface. TIEStatusTextChangeEvent = procedure(Sender: TObject; const Text: WideString) of object; TIEProgressChangeEvent = procedure(Sender: TObject; Progress: Integer; ProgressMax: Integer) of object; TIECommandStateChangeEvent = procedure(Sender: TObject; Command: Integer; Enable: WordBool) of object; TIEDownloadBeginEvent = procedure(Sender: TObject) of object; TIEDownloadCompleteEvent = procedure(Sender: TObject) of object; TIETitleChangeEvent = procedure(Sender: TObject; const Text: WideString) of object; TIEPropertyChangeEvent = procedure(Sender: TObject; const szProperty: WideString) of object; TIEBeforeNavigate2Event = procedure(Sender: TObject; const pDisp: IDispatch; Var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; Var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool) of object; TIENewWindow2Event = procedure(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool) of object; TIENavigateComplete2Event = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object; TIEDocumentCompleteEvent = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object; TIEOnQuitEvent = procedure(Sender: TObject) of object; TIEOnVisibleEvent = procedure(Sender: TObject; Visible: WordBool) of object; TIEOnToolBarEvent = procedure(Sender: TObject; ToolBar: WordBool) of object; TIEOnMenuBarEvent = procedure(Sender: TObject; MenuBar: WordBool) of object; TIEOnStatusBarEvent = procedure(Sender: TObject; StatusBar: WordBool) of object; TIEOnFullScreenEvent = procedure(Sender: TObject; FullScreen: WordBool) of object; TIEOnTheaterModeEvent = procedure(Sender: TObject; TheaterMode: WordBool) of object; // Event component for Internet Explorer. TIEEvents = class(TComponent, IUnknown, IDispatch). Private. // Private declarations. FConnected: Boolean; FCookie: Integer; FCP: IConnectionPoint; FSinkIID: TGuid; FSource: IWebBrowser2; FStatusTextChange: TIEStatusTextChangeEvent; FProgressChange: TIEProgressChangeEvent; FCommandStateChange: TIECommandStateChangeEvent; FDownloadBegin: TIEDownloadBeginEvent; FDownloadComplete: TIEDownloadCompleteEvent; FTitleChange: TIETitleChangeEvent; FPropertyChange: TIEPropertyChangeEvent; FBeforeNavigate2: TIEBeforeNavigate2Event; FNewWindow2: TIENewWindow2Event; FNavigateComplete2: TIENavigateComplete2Event; FDocumentComplete: TIEDocumentCompleteEvent; FOnQuit: TIEOnQuitEvent; FOnVisible: TIEOnVisibleEvent; FOnToolBar: TIEOnToolBarEvent; FOnMenuBar: TIEOnMenuBarEvent; FOnStatusBar: TIEOnStatusBarEvent; FOnFullScreen: TIEOnFullScreenEvent; FOnTheaterMode: TIEOnTheaterModeEvent; Protected. // Protected declaratios for IUnknown. Function QueryInterface(const IID: TGUID; out Obj): HResult; override; Function _AddRef: Integer; stdcall; Function _Release: Integer; stdcall; // Protected declaratios for IDispatch. Function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall; Function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall; Function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall; Function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall; // Protected declarations. Procedure DoStatusTextChange(const Text: WideString); safecall; Procedure DoProgressChange(Progress: Integer; ProgressMax: Integer); safecall; Procedure DoCommandStateChange(Command: Integer; Enable: WordBool); safecall; Procedure DoDownloadBegin; safecall; Procedure DoDownloadComplete; safecall; Procedure DoTitleChange(const Text: WideString); safecall; Procedure DoPropertyChange(const szProperty: WideString); safecall; Procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; Var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; Var Headers: OleVariant; var Cancel: WordBool); safecall; Procedure DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool); safecall; Procedure DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant); safecall; Procedure DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant); safecall; Procedure DoOnQuit; safecall; Procedure DoOnVisible(Visible: WordBool); safecall; Procedure DoOnToolBar(ToolBar: WordBool); safecall; Procedure DoOnMenuBar(MenuBar: WordBool); safecall; Procedure DoOnStatusBar(StatusBar: WordBool); safecall; Procedure DoOnFullScreen(FullScreen: WordBool); safecall; Procedure DoOnTheaterMode(TheaterMode: WordBool); safecall; Public. // Public declarations. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; Procedure ConnectTo(Source: IWebBrowser2); Procedure Disconnect; Property SinkIID: TGuid read FSinkIID; Property Source: IWebBrowser2 read FSource; Published. // Published declarations. Property WebObj: IWebBrowser2 read FSource; Property Connected: Boolean read FConnected; Property StatusTextChange: TIEStatusTextChangeEvent read FStatusTextChange write FStatusTextChange; Property ProgressChange: TIEProgressChangeEvent read FProgressChange write FProgressChange; Property CommandStateChange: TIECommandStateChangeEvent read FCommandStateChange write FCommandStateChange; Property DownloadBegin: TIEDownloadBeginEvent read FDownloadBegin write FDownloadBegin; Property DownloadComplete: TIEDownloadCompleteEvent read FDownloadComplete write FDownloadComplete; Property TitleChange: TIETitleChangeEvent read FTitleChange write FTitleChange; Property PropertyChange: TIEPropertyChangeEvent read FPropertyChange write FPropertyChange; Property BeforeNavigate2: TIEBeforeNavigate2Event read FBeforeNavigate2 write FBeforeNavigate2; Property NewWindow2: TIENewWindow2Event read FNewWindow2 write FNewWindow2; Property NavigateComplete2: TIENavigateComplete2Event read FNavigateComplete2 write FNavigateComplete2; Property DocumentComplete: TIEDocumentCompleteEvent read FDocumentComplete write FDocumentComplete; Property OnQuit: TIEOnQuitEvent read FOnQuit write FOnQuit; Property OnVisible: TIEOnVisibleEvent read FOnVisible write FOnVisible; Property OnToolBar: TIEOnToolBarEvent read FOnToolBar write FOnToolBar; Property OnMenuBar: TIEOnMenuBarEvent read FOnMenuBar write FOnMenuBar; Property OnStatusBar: TIEOnStatusBarEvent read FOnStatusBar write FOnStatusBar; Property OnFullScreen: TIEOnFullScreenEvent read FOnFullScreen write FOnFullScreen; Property OnTheaterMode: TIEOnTheaterModeEvent read FOnTheaterMode write FOnTheaterMode; End; // Register procedure. Procedure Register; Implementation. Function TIEEvents._AddRef: Integer; Begin. // No more than 2 counts. Result := 2; End; Function TIEEvents._Release: Integer; Begin. // Always maintain 1 ref count (component holds the ref count). Result := 1; End; Function TIEEvents.QueryInterface(const IID: TGUID; out Obj): HResult; Begin. // Clear interface pointer. Pointer(Obj) := nil; // Attempt to get the requested interface. If (GetInterface(IID, Obj)) then. // Success. Result := S_OK. // Check to see if the guid requested is for the event. Else if (IsEqualIID(IID, FSinkIID)) then. Begin. // Event is dispatch based, so get dispatch interface (closest we can come). If (GetInterface(IDispatch, Obj)) then. // Success. Result := S_OK. Else. // Failure. Result := E_NOINTERFACE; End. Else. // Failure. Result := E_NOINTERFACE; End; Function TIEEvents.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; Begin. // Not implemented. Result := E_NOTIMPL; End; Function TIEEvents.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; Begin. // Clear the result interface. Pointer(TypeInfo) := nil; // No type info for our interface. Result := E_NOTIMPL; End; Function TIEEvents.GetTypeInfoCount(out Count: Integer): HResult; Begin. // Zero type info counts. Count := 0; // Return success. Result := S_OK; End; Function TIEEvents.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; Var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; Var pdpParams: PDispParams; LpDispIDs: array[0..63] of TDispID; DwCount: Integer; Begin. // Get the parameters. PdpParams := @Params; // Events can only be called with method dispatch, not property get/set. If ((Flags and DISPATCH_METHOD) > 0) then. Begin. // Clear DispID list. ZeroMemory(@lpDispIDs, SizeOf(lpDispIDs)); // Build dispatch ID list to handle named args. If (pdpParams^.cArgs > 0) then. Begin. // Reverse the order of the params because they are backwards. For dwCount := 0 to Pred(pdpParams^.cArgs) do lpDispIDs[dwCount] := Pred(pdpParams^.cArgs) - dwCount; // Handle named arguments. If (pdpParams^.cNamedArgs > 0) then. Begin. For dwCount := 0 to Pred(pdpParams^.cNamedArgs) do. LpDispIDs[pdpParams^.rgdispidNamedArgs^[dwCount]] := dwCount; End; End; // Unless the event falls into the "else" clause of the case statement the result is S_OK. Result := S_OK; // Handle the event. Case DispID of. 102: DoStatusTextChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval); 104: DoDownloadComplete; 105: DoCommandStateChange(pdpParams^.rgvarg^[lpDispIds[0]].lval, PdpParams^.rgvarg^[lpDispIds[1]].vbool); 106: DoDownloadBegin; 108: DoProgressChange(pdpParams^.rgvarg^[lpDispIds[0]].lval, PdpParams^.rgvarg^[lpDispIds[1]].lval); 112: DoPropertyChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval); 113: DoTitleChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval); 250: DoBeforeNavigate2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval), POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[2]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[3]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[4]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[5]].pvarval)^, PdpParams^.rgvarg^[lpDispIds[6]].pbool^); 251: DoNewWindow2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].pdispval^), PdpParams^.rgvarg^[lpDispIds[1]].pbool^); 252: DoNavigateComplete2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval), POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^); 253: Begin. // Special case handler. When Quit is called, IE is going away so we might. // as well unbind from the interface by calling disconnect. DoOnQuit; // Call disconnect. Disconnect; End; 254: DoOnVisible(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 255: DoOnToolBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 256: DoOnMenuBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 257: DoOnStatusBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 258: DoOnFullScreen(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 259: DoDocumentComplete(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval), POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^); 260: DoOnTheaterMode(pdpParams^.rgvarg^[lpDispIds[0]].vbool); Else. // Have to idea of what event they are calling. Result := DISP_E_MEMBERNOTFOUND; End; End. Else. // Called with wrong flags. Result := DISP_E_MEMBERNOTFOUND; End; Constructor TIEEvents.Create(AOwner: TComponent); Begin. // Perform inherited. Inherited Create(AOwner); // Set the event sink IID. FSinkIID := DWebBrowserEvents2; End; Destructor TIEEvents.Destroy; Begin. // Disconnect. Disconnect; // Perform inherited. Inherited Destroy; End; Procedure TIEEvents.ConnectTo(Source: IWebBrowser2); Var pvCPC: IConnectionPointContainer; Begin. // Disconnect from any currently connected event sink. Disconnect; // Query for the connection point container and desired connection point. // On success, sink the connection point. OleCheck(Source.QueryInterface(IConnectionPointContainer, pvCPC)); OleCheck(pvCPC.FindConnectionPoint(FSinkIID, FCP)); OleCheck(FCP.Advise(Self, FCookie)); // Update internal state variables. FSource := Source; // We are in a connected state. FConnected := True; // Release the temp interface. PvCPC := nil; End; Procedure TIEEvents.Disconnect; Begin. // Do we have the IWebBrowser2 interface? If Assigned(FSource) then. Begin. Try. // Unadvise the connection point. OleCheck(FCP.Unadvise(FCookie)); // Release the interfaces. FCP := nil; FSource := nil; Except. Pointer(FCP) := nil; Pointer(FSource) := nil; End; End; // Disconnected state. FConnected := False; End; Procedure TIEEvents.DoStatusTextChange(const Text: WideString); Begin. // Call assigned event. If Assigned(FStatusTextChange) then FStatusTextChange(Self, Text); End; Procedure TIEEvents.DoProgressChange(Progress: Integer; ProgressMax: Integer); Begin. // Call assigned event. If Assigned(FProgressChange) then FProgressChange(Self, Progress, ProgressMax); End; Procedure TIEEvents.DoCommandStateChange(Command: Integer; Enable: WordBool); Begin. // Call assigned event. If Assigned(FCommandStateChange) then FCommandStateChange(Self, Command, Enable); End; Procedure TIEEvents.DoDownloadBegin; Begin. // Call assigned event. If Assigned(FDownloadBegin) then FDownloadBegin(Self); End; Procedure TIEEvents.DoDownloadComplete; Begin. // Call assigned event. If Assigned(FDownloadComplete) then FDownloadComplete(Self); End; Procedure TIEEvents.DoTitleChange(const Text: WideString); Begin. // Call assigned event. If Assigned(FTitleChange) then FTitleChange(Self, Text); End; Procedure TIEEvents.DoPropertyChange(const szProperty: WideString); Begin. // Call assigned event. If Assigned(FPropertyChange) then FPropertyChange(Self, szProperty); End; Procedure TIEEvents.DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool); Begin. // Call assigned event. If Assigned(FBeforeNavigate2) then FBeforeNavigate2(Self, pDisp, URL, Flags, TargetFrameName, PostData, Headers, Cancel); End; Procedure TIEEvents.DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool); Var. PvDisp: IDispatch; Begin. // Call assigned event. If Assigned(FNewWindow2) then. Begin. If Assigned(ppDisp) then. PvDisp := ppDisp. Else. PvDisp := nil; FNewWindow2(Self, pvDisp, Cancel); PpDisp := pvDisp; End; End; Procedure TIEEvents.DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant); Begin. // Call assigned event. If Assigned(FNavigateComplete2) then FNavigateComplete2(Self, pDisp, URL); End; Procedure TIEEvents.DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant); Begin. // Call assigned event. If Assigned(FDocumentComplete) then FDocumentComplete(Self, pDisp, URL); End; Procedure TIEEvents.DoOnQuit; Begin. // Call assigned event. If Assigned(FOnQuit) then FOnQuit(Self); End; Procedure TIEEvents.DoOnVisible(Visible: WordBool); Begin. // Call assigned event. If Assigned(FOnVisible) then FOnVisible(Self, Visible); End; Procedure TIEEvents.DoOnToolBar(ToolBar: WordBool); Begin. // Call assigned event. If Assigned(FOnToolBar) then FOnToolBar(Self, ToolBar); End; Procedure TIEEvents.DoOnMenuBar(MenuBar: WordBool); Begin. // Call assigned event. If Assigned(FOnMenuBar) then FOnMenuBar(Self, MenuBar); End; Procedure TIEEvents.DoOnStatusBar(StatusBar: WordBool); Begin. // Call assigned event. If Assigned(FOnStatusBar) then FOnStatusBar(Self, StatusBar); End; Procedure TIEEvents.DoOnFullScreen(FullScreen: WordBool); Begin. // Call assigned event. If Assigned(FOnFullScreen) then FOnFullScreen(Self, FullScreen); End; Procedure TIEEvents.DoOnTheaterMode(TheaterMode: WordBool); Begin. // Call assigned event. If Assigned(FOnTheaterMode) then FOnTheaterMode(Self, TheaterMode); End; Procedure Register; Begin. // Register the component on the Internet tab of the IDE. RegisterComponents('Internet', [TIEEvents]); End; End.

Выделить все поля в TDBGrid?

Code: Function GridSelectAll(Grid: TDBGrid): Longint; Begin. Result := 0; Grid.SelectedRows.Clear; With Grid.DataSource.DataSet do. Begin. First; DisableControls; Try. While not EOF do. Begin. Grid.SelectedRows.CurrentRowSelected := True; Inc(Result); Next; End; Finally. EnableControls; End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. GridSelectAll(DBGrid1); End;

Получить список процессов в компьютере сети.

Code: Unit PerfInfo; Interface. Uses. Windows, SysUtils, Classes; Type. TPerfCounter = record. Counter: Integer; Value: TLargeInteger; End; TPerfCounters = Array of TPerfCounter; TPerfInstance = class. Private. FName: string; FCounters: TPerfCounters; Public. Property Name: string read FName; Property Counters: TPerfCounters read FCounters; End; TPerfObject = class. Private. FList: TList; FObjectID: DWORD; FMachine: string; Function GetCount: Integer; Function GetInstance(Index: Integer): TPerfInstance; Procedure ReadInstances; Public. Property ObjectID: DWORD read FObjectID; Property Item[Index: Integer]: TPerfInstance. Read GetInstance; default; Property Count: Integer read GetCount; Constructor Create(const AMachine: string; AObjectID: DWORD); Destructor Destroy; override; End; Procedure GetProcesses(const Machine: string; List: TStrings); Implementation. Type. PPerfDataBlock = ^TPerfDataBlock; TPerfDataBlock = record. Signature: array[0..3] of WCHAR; LittleEndian: DWORD; Version: DWORD; Revision: DWORD; TotalByteLength: DWORD; HeaderLength: DWORD; NumObjectTypes: DWORD; DefaultObject: Longint; SystemTime: TSystemTime; PerfTime: TLargeInteger; PerfFreq: TLargeInteger; PerfTime100nSec: TLargeInteger; SystemNameLength: DWORD; SystemNameOffset: DWORD; End; PPerfObjectType = ^TPerfObjectType; TPerfObjectType = record. TotalByteLength: DWORD; DefinitionLength: DWORD; HeaderLength: DWORD; ObjectNameTitleIndex: DWORD; ObjectNameTitle: LPWSTR; ObjectHelpTitleIndex: DWORD; ObjectHelpTitle: LPWSTR; DetailLevel: DWORD; NumCounters: DWORD; DefaultCounter: Longint; NumInstances: Longint; CodePage: DWORD; PerfTime: TLargeInteger; PerfFreq: TLargeInteger; End; PPerfCounterDefinition = ^TPerfCounterDefinition; TPerfCounterDefinition = record. ByteLength: DWORD; CounterNameTitleIndex: DWORD; CounterNameTitle: LPWSTR; CounterHelpTitleIndex: DWORD; CounterHelpTitle: LPWSTR; DefaultScale: Longint; DetailLevel: DWORD; CounterType: DWORD; CounterSize: DWORD; CounterOffset: DWORD; End; PPerfInstanceDefinition = ^TPerfInstanceDefinition; TPerfInstanceDefinition = record. ByteLength: DWORD; ParentObjectTitleIndex: DWORD; ParentObjectInstance: DWORD; UniqueID: Longint; NameOffset: DWORD; NameLength: DWORD; End; PPerfCounterBlock = ^TPerfCounterBlock; TPerfCounterBlock = record. ByteLength: DWORD; End; {Navigation helpers}. Function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType; Begin. Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength); End; Function NextObject(PerfObj: PPerfObjectType): PPerfObjectType; Begin. Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength); End; Function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition; Begin. Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength); End; Function NextInstance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition; Var. PerfCntrBlk: PPerfCounterBlock; Begin. PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength); Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk) + PerfCntrBlk.ByteLength); End; Function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition; Begin. Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength); End; Function NextCounter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition; Begin. Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength); End; {Registry helpers}. Function GetPerformanceKey(const Machine: string): HKey; Var. S: string; Begin. Result := 0; If Length(Machine) = 0 then. Result := HKEY_PERFORMANCE_DATA. Else. Begin. S := Machine; If Pos('\\', s) <> 1 then. S := '\\' + s; If RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) <> ERROR_SUCCESS then. Result := 0; End; End; {TPerfObject}. Constructor TPerfObject.Create(const AMachine: string; AObjectID: DWORD); Begin. Inherited Create; FList := TList.Create; FMachine := AMachine; FObjectID := AObjectID; ReadInstances; End; Destructor TPerfObject.Destroy; Var. I: Integer; Begin. For i := 0 to FList.Count - 1 do. TPerfInstance(FList[i]).Free; FList.Free; Inherited Destroy; End; Function TPerfObject.GetCount: Integer; Begin. Result := FList.Count; End; Function TPerfObject.GetInstance(Index: Integer): TPerfInstance; Begin. Result := FList[Index]; End; Procedure TPerfObject.ReadInstances; Var. PerfData: PPerfDataBlock; PerfObj: PPerfObjectType; PerfInst: PPerfInstanceDefinition; PerfCntr, CurCntr: PPerfCounterDefinition; PtrToCntr: PPerfCounterBlock; BufferSize: Integer; I, j, k: Integer; PData: PLargeInteger; Key: HKey; CurInstance: TPerfInstance; Begin. For i := 0 to FList.Count - 1 do. TPerfInstance(FList[i]).Free; FList.Clear; Key := GetPerformanceKey(FMachine); If Key = 0 then Exit; PerfData := nil; Try. {Allocate initial buffer for object information}. BufferSize := 65536; GetMem(PerfData, BufferSize); {retrieve data}. While RegQueryValueEx(Key, PChar(IntToStr(FObjectID)), {Object name}. Nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do. Begin. {buffer is too small}. Inc(BufferSize, 1024); ReallocMem(PerfData, BufferSize); End; RegCloseKey(HKEY_PERFORMANCE_DATA); {Get the first object type}. PerfObj := FirstObject(PerfData); {Process all objects}. For i := 0 to PerfData.NumObjectTypes - 1 do. Begin. {Check for requested object}. If PerfObj.ObjectNameTitleIndex = FObjectID then. Begin. {Get the first counter}. PerfCntr := FirstCounter(PerfObj); If PerfObj.NumInstances > 0 then. Begin. {Get the first instance}. PerfInst := FirstInstance(PerfObj); {Retrieve all instances}. For k := 0 to PerfObj.NumInstances - 1 do. Begin. {Create entry for instance}. CurInstance := TPerfInstance.Create; CurInstance.FName := WideCharToString(PWideChar(DWORD(PerfInst) + PerfInst.NameOffset)); FList.Add(CurInstance); CurCntr := PerfCntr; {Retrieve all counters}. SetLength(CurInstance.FCounters, PerfObj.NumCounters); For j := 0 to PerfObj.NumCounters - 1 do. Begin. PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength); PData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset); {Add counter to array}. CurInstance.FCounters[j].Counter := CurCntr.CounterNameTitleIndex; CurInstance.FCounters[j].Value := pData^; {Get the next counter}. CurCntr := NextCounter(CurCntr); End; {Get the next instance.}. PerfInst := NextInstance(PerfInst); End; End; End; {Get the next object type}. PerfObj := NextObject(PerfObj); End; Finally. {Release buffer}. FreeMem(PerfData); {Close remote registry handle}. If Key <> HKEY_PERFORMANCE_DATA then. RegCloseKey(Key); End; End; Procedure GetProcesses(const Machine: string; List: TStrings); Var. Processes: TPerfObject; I, j: Integer; ProcessID: DWORD; Begin. Processes := nil; List.Clear; Try. Processes := TPerfObject.Create(Machine, 230); {230 = Process}. For i := 0 to Processes.Count - 1 do. {Find process ID}. For j := 0 to Length(Processes[i].Counters) - 1 do. If (Processes[i].Counters[j].Counter = 784) then. Begin. ProcessID := Processes[i].Counters[j].Value; If ProcessID <> 0 then. List.AddObject(Processes[i].Name, Pointer(ProcessID)); Break; End; Finally. Processes.Free; End; End; End.

Узнать информацию о прокси сервере.

Code: Uses. WinInet; Function GetProxyInformation: string; Var. ProxyInfo: PInternetProxyInfo; Len: LongWord; Begin. Result := ''; Len := 4096; GetMem(ProxyInfo, Len); Try. If InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len) then. If ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then. Begin. Result := ProxyInfo^.lpszProxy. End; Finally. FreeMem(ProxyInfo); End; End; {************************************************************************** * NAME: GetProxyServer. * DESC: Proxy-Server Einstellungen abfragen. * PARAMS: protocol => z.B. 'http' oder 'ftp' * RESULT: [-]. * CREATED: 08-04-2004/shmia. *************************************************************************} Procedure GetProxyServer(protocol: string; var ProxyServer: string; Var ProxyPort: Integer); Var. I: Integer; Proxyinfo, ps: string; Begin. ProxyServer := ''; ProxyPort := 0; Proxyinfo := GetProxyInformation; If proxyinfo = '' then. Exit; Protocol := protocol + '='; I := Pos(protocol, proxyinfo); If i > 0 then. Begin. Delete(proxyinfo, 1, i + Length(protocol)); I := Pos(';', ProxyServer); If i > 0 then. Proxyinfo := Copy(proxyinfo, 1, i - 1); End; I := Pos(':', proxyinfo); If i > 0 then. Begin. ProxyPort := StrToIntDef(Copy(proxyinfo, i + 1, Length(proxyinfo) - i), 0); ProxyServer := Copy(proxyinfo, 1, i - 1). End. End; Procedure TForm1.Button1Click(Sender: TObject); Var. ProxyServer: string; ProxyPort: Integer; Begin. GetProxyServer('http', ProxyServer, ProxyPort); Label1.Caption := ProxyServer; Label2.Caption := IntToStr(ProxyPort); End;

Как найти и выделить текст TWebBrowser?

Code: {....} Private. Procedure SearchAndHighlightText(aText: string); {....} Uses mshtml; { .... } Procedure TForm1.SearchAndHighlightText(aText: string); Var. Tr: IHTMLTxtRange; //TextRange Object. Begin. If not WebBrowser1.Busy then. Begin. Tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange; //Get a body with IHTMLDocument2 Interface and then a TextRang obj. with IHTMLBodyElement Intf. While tr.findText(aText, 1, 0) do //while we have result. Begin. Tr.pasteHTML('<span style="background-color: Lime; font-weight: bolder;">' + Tr.htmlText + '</span>'); //Set the highlight, now background color will be Lime. Tr.scrollIntoView(True); //When IE find a match, we ask to scroll the window... you dont need this... End; End; End; // Example: Procedure TForm1.Button1Click(Sender: TObject); Begin. SearchAndHighlightText('delphi'); End;

Добавить HTML к TWebbrowser Document?

Code: Uses. MSHTML; Procedure TForm1.Button1Click(Sender: TObject); Var. Range: IHTMLTxtRange; Begin. Range := ((WebBrowser1.Document as IHTMLDocument2).body as. IHTMLBodyElement).createTextRange; Range.collapse(False); Range.pasteHTML('<br><b>Hello!</b>'); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Webbrowser1.Navigate('www.google.ch'); End;

Code: Unit Unit1; // by Sprint. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, OleCtrls, SHDocVw, MSHTML, StdCtrls; Type. TForm1 = class(TForm). WebBrowser1: TWebBrowser; Procedure FormCreate(Sender: TObject); Procedure WebBrowser1DocumentComplete(Sender: TObject; Const pDisp: IDispatch; var URL: OleVariant); Private. { Private-Deklarationen }. FirstRun: Boolean; Public. { Public-Deklarationen }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. {----------------------------------------------------------------} Procedure TForm1.FormCreate(Sender: TObject); Begin. FirstRun := True; WebBrowser1.Navigate('about:blank'); End; {----------------------------------------------------------------} Procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject; Const pDisp: IDispatch; var URL: OleVariant); Var. WebDoc: HTMLDocument; WebBody: HTMLBody; Begin. If FirstRun then. If pDisp = WebBrowser1.Application then. Begin. FirstRun := False; WebDoc := WebBrowser1.Document as HTMLDocument; WebBody := WebDoc.body as HTMLBody; WebBody.insertAdjacentHTML('BeforeEnd', '<h1>Hello World!</h1>'); End; End; {----------------------------------------------------------------} End.

Навигация в TWebbrowser по линкам.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Flags, Headers, TargetFrameName, PostData: OLEVariant; Url, Ref: string; IEApp: OLEVariant; Begin. Try. IEApp := CreateOLEObject('InternetExplorer.Application'); Except. Exit; End; IEApp.Visible := True; IEApp.Top := 0; IEApp.Left := 0; IEApp.Width := Screen.Width; IEApp.Height := Screen.Height; Flags := '1'; TargetFrameName := ''; PostData := ''; Url := 'http://www.dach.de/weiterempfehlen.php'; Ref := 'http://www.dach.de/'; // u cannot navigate to the url above without this referer. Headers := 'Referer: ' + Ref + #10 + #13; IEApp.Navigate(Url, Flags, TargetFrameName, PostData, Headers); End;

Как ускорить поиск?

Code: Type. TForm1 = class(TForm). DataSource1: TDataSource; Table1: TTable; Button1: TButton; End; Procedure TForm1.Button1Click(Sender: TObject); Var. SeekValue: string; Begin. Table1.DisableControls; Table1.FindKey([SeekValue]); Table1.EnableControls; End;

Как вызвать скрытые команды TWebBrowser?

Code: // The following codes demonstrates an innovative way to invoke hidden. // commands to show modal dialogs such as "Add To Favorite" dialog, // "Import/Export Wizard" dialog in your WebBrowser-based application. //Command IDs Handled by 'Shell DocObject View' Const ID_IE_FILE_PAGESETUP = 259; Const ID_IE_FILE_PRINT = 260; Const ID_IE_FILE_NEWWINDOW = 275; Const ID_IE_FILE_PRINTPREVIEW = 277; Const ID_IE_FILE_NEWMAIL = 279; Const ID_IE_FILE_SENDPAGE = 282; Const ID_IE_FILE_SENDLINK = 283; Const ID_IE_FILE_SENDDESKTOPSHORTCUT = 284; Const ID_IE_HELP_VERSIONINFO = 336; Const ID_IE_HELP_HELPINDEX = 337; Const ID_IE_HELP_WEBTUTORIAL = 338; Const ID_IE_HELP_FREESTUFF = 341; Const ID_IE_HELP_PRODUCTUPDATE = 342; Const ID_IE_HELP_FAQ = 343; Const ID_IE_HELP_ONLINESUPPORT = 344; Const ID_IE_HELP_FEEDBACK = 345; Const ID_IE_HELP_BESTPAGE = 346; Const ID_IE_HELP_SEARCHWEB = 347; Const ID_IE_HELP_MSHOME = 348; Const ID_IE_HELP_VISITINTERNET = 349; Const ID_IE_HELP_STARTPAGE = 350; Const ID_IE_HELP_NETSCAPEUSER = 351; Const ID_IE_FILE_IMPORTEXPORT = 374; Const ID_IE_HELP_ENHANCEDSECURITY = 375; Const ID_IE_FILE_ADDTRUST = 376; Const ID_IE_FILE_ADDLOCAL = 377; Const ID_IE_FILE_NEWPUBLISHINFO = 387; Const ID_IE_FILE_NEWPEOPLE = 390; Const ID_IE_FILE_NEWCALL =395; //Command IDs Handled by 'Internet Explorer_Server' Const ID_IE_CONTEXTMENU_NEWWINDOW = 2137; Const ID_IE_CONTEXTMENU_ADDFAV = 2261; Const ID_IE_CONTEXTMENU_REFRESH = 6042; Function GetIEHandle(WebBrowser: TWebbrowser; ClassName: string): HWND; Var. HwndChild, hwndTmp: HWND; OleCtrl: TOleControl; SzClass: array [0..255] of char; Begin. OleCtrl :=WebBrowser; HwndTmp := oleCtrl.Handle; While (true) do. Begin. HwndChild := GetWindow(hwndTmp, GW_CHILD); GetClassName(hwndChild, szClass, SizeOf(szClass)); If (string(szClass)=ClassName) then. Begin. Result :=hwndChild; Exit; End; HwndTmp := hwndChild; End; Result := 0; End; Procedure TForm1.ToolButton2Click(Sender: TObject); Begin. //Invoke "Add To Favorite" Dialog. SendMessage(GetIEHandle(web, 'Internet Explorer_Server'), WM_COMMAND, ID_IE_CONTEXTMENU_ADDFAV, 0); End; Procedure TForm1.ToolButton3Click(Sender: TObject); Begin. //Invoke "Import/Export Wizard" Dialog. SendMessage(GetIEHandle(web, 'Shell DocObject View'), WM_COMMAND, ID_IE_FILE_IMPORTEXPORT, 0); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Web.Go('http://http://www.swissdelphicenter.ch/en'); End;

Как создать консольное asp.net приложение с событиями delphi?

Code: { ****************** Below is a complete listing for an ASPX file to open and. Read an ACCESS database. Obviously the source=c:\mydb.mdb declaration should. Be changed to point to your own database. The sql commands will also need to. Be ammended to point to the correct tables and values. This souce code is a. Translation from native c#. Any problems with the code or , thanks, comments. Or general abuse over codeing standrds should be sent to andychap@hotmail.com, Please put "delphi" in the subject line so I can junk filter. Good luck..... As another issue I've also got some examples I've written for Delphi for Dot Net. Doing similar stuff. ********************************************************************************** } <%@ Page Language="Delphi" %> <%@ import Namespace="System.Data" %> <%@ import Namespace="System.Data.OleDb" %> <script runat="server"> Procedure Button1Click(Sender: System.Object; E: EventArgs); Var. MyConnection : OleDbConnection ; DbReader : OleDbDataReader; Cmd : OleDbCommand; Abc : string; Outval : string; Intval : longint; Begin. Abc := 'Provider=Microsoft.Jet.OLEDB.4.0;Password=;Data Source=c:\mydb.mdb'; MyConnection := OleDbConnection.Create(abc); MyConnection.Open; Cmd := MyConnection.CreateCommand; Cmd.CommandText := 'Select * from Table1'; DbReader := cmd.ExecuteReader; While (dbReader.Read) do. Begin. Intval := dbReader.GetInt32(0); Outval := dbReader.GetString(1); End; Label1.Text := inttostr(intval); End; Procedure Button2Click(Sender: System.Object; E: EventArgs); Var. ConnStr : string; CommTxt : string; MyConnection : OleDbConnection ; Abc : string; CmdText : string; Cmd : OleDbCommand; Begin. ConnStr := 'Provider=Microsoft.Jet.OLEDB.4.0;Password=;Data Source=c:\mydb.mdb'; CommTxt := 'select andy as [first name], chapman as [Last Name] from Table1'; Abc := 'Provider=Microsoft.Jet.OLEDB.4.0;Password=;Data Source=c:\mydb.mdb'; MyConnection := OleDbConnection.Create(abc); Cmd := OleDbCommand.Create(CommTxt,MyConnection); MyConnection.Open; DataGrid1.DataSource := cmd.ExecuteReader(CommandBehavior.CloseConnection); DataGrid1.DataBind(); End; </script> <html> <head> </head> <body style="FONT-FAMILY: arial"> <h2>Simple Data Report. </h2> <hr size="1" /> <form runat="server"> <asp:datagrid id="DataGrid1" runat="server" CellSpacing="1" GridLines="None" CellPadding="3" BackColor="White" ForeColor="Black" EnableViewState="False"> <HeaderStyle font-bold="True" forecolor="White" backcolor="#4A3C8C"></HeaderStyle> <ItemStyle backcolor="#DEDFDE"></ItemStyle> </asp:datagrid> <asp:Button id="Button1" style="Z-INDEX: 100; LEFT: 284px; POSITION: absolute; TOP: 151px" onclick="Button1Click" runat="server" Text="Bind To Data Grid"></asp:Button> <asp:Label id="Label1" style="Z-INDEX: 100; LEFT: 467px; POSITION: absolute; TOP: 156px" runat="server" Width="42px">Label</asp:Label> <asp:Button id="Button2" style="Z-INDEX: 101; LEFT: 283px; POSITION: absolute; TOP: 182px" onclick="Button2Click" runat="server" Text="Button"></asp:Button> </form> </body> </html>

Читать значения переменных из JavaScript?

Code: // Just add a Webbrowser and two Buttons to the form and insert the following code. Procedure TForm1.Button1Click(Sender: TObject); Begin. Webbrowser1.Navigate('http://www.dasbinich.info/myred/delphi/index.html'); End; Procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject; Const pDisp: IDispatch; var URL: OleVariant); Begin. If (url = 'http://www.dasbinich.info/myred/delphi/index.html') then. ShowMessage('Value lautet: ' + webBrowser1.OleObject.Document.Forms.item. ('test').Elements.item('testen').Value); //read the Javascript value testen of the form test. End; //this is an example how to use it when there are no names. Procedure TForm1.Button2Click(Sender: TObject); Begin. ShowMessage('Value lautet: ' + webBrowser1.OleObject.Document.Forms.item. (0).Elements.item(0).Value); End; //to read the javascript value from a site with a frame use the following. WebBrowser1.OleObject.Document.Frames.item('top').Document.Forms.item. ('Countdown').Elements.item('Countdown').Value; //top is the framename in this example.

Програмно меняем Delphi's Tool list?

Code: //** class to manage Delphi's Tool list. //** //** if Delphi is running restart it to see changes. //************************************************************* Unit DelphiTool; Interface. Uses. Windows, SysUtils, Registry, classes; Type. TDelphiVersion = ({dvD5,} dvD6); EDelphiTool_AlreadyRegistered = class(Exception); EDelphiTool_InvalidIndex = class(Exception); TDelphiTool = class. Private. F_Registry: TRegistry; F_ToolCount: Integer; F_ToolPath: string; Protected. Function OpenKey(key: string; CanCreate: Boolean): Boolean; Public. Constructor Create; Destructor Destroy; override; Procedure SetRootKey(root_key: HKEY); Procedure SetDelphiVersion(version: TDelphiVersion); Procedure Add(params, path, title, workingDir: string); Procedure Edit(toolIndex: Integer; params, path, title, workingDir: string); Procedure Delete(toolIndex: Integer); Function IndexOf(toolTitle: string): Integer; Function Count: Integer; Procedure ToolProperties(toolIndex: Integer; Out params, path, title, workingDir: string); End; Implementation. { TDelphiTool }. Constructor TDelphiTool.Create; Begin. Inherited; SetDelphiVersion(dvD6); F_Registry := TRegistry.Create; End; Destructor TDelphiTool.Destroy; Begin. F_Registry.CloseKey; F_Registry.Free; Inherited; End; Function TDelphiTool.IndexOf(toolTitle: string): Integer; Var. Found: boolean; Loop: integer; Count: integer; Begin. Result := -1; If OpenKey(F_ToolPath, True) then. Begin. Loop := 0; Found := False; While (loop < F_ToolCount) and not found do. Begin. Found := F_Registry.ReadString('Title' + IntToStr(loop)) = toolTitle; If not found then Inc(loop); End; End; If found then Result := loop; End; Procedure TDelphiTool.SetRootKey(root_key: HKEY); Begin. F_Registry.RootKey := root_key; End; Procedure TDelphiTool.Add(params, path, title, workingDir: string); Var. Count: integer; Suffix: string; Begin. If OpenKey(F_ToolPath, True) then. Begin. Try. If IndexOf(title) < 0 then. Begin. Count := F_ToolCount; Suffix := IntToStr(Count); Inc(Count); F_registry.WriteString('Params' + suffix, params); F_registry.WriteString('Path' + suffix, path); F_registry.WriteString('Title' + suffix, title); F_registry.WriteString('WorkingDir' + suffix, workingDir); F_registry.WriteInteger('Count', Count); F_ToolCount := Count; End. Else. Raise EDelphiTool_AlreadyRegistered.Create('[Add]: Tool is already registered.'); Finally. F_Registry.CloseKey; End; End. End; Function TDelphiTool.OpenKey(key: string; CanCreate: Boolean): Boolean; Begin. Result := F_Registry.OpenKey(key, CanCreate); If F_Registry.ValueExists('Count') then F_ToolCount := F_Registry.ReadInteger('Count'). Else. F_ToolCount := 0; End; Procedure TDelphiTool.Edit(toolIndex: Integer; params, path, title, WorkingDir: string); // if you don't want to change one property set to '' Var. Suffix: string; Begin. If (toolIndex < 0) or (toolIndex >= F_ToolCount) then. Raise EDelphiTool_InvalidIndex.Create('[Edit]: Invalid index.'). Else. Begin. If OpenKey(F_ToolPath, True) then. Begin. Try. Suffix := IntToStr(toolIndex); If (params <> '') then. F_registry.WriteString('Params' + suffix, params); If (path <> '') then. F_registry.WriteString('Path' + suffix, path); If (title <> '') then. F_registry.WriteString('Title' + suffix, title); If (workingDir <> '') then. F_registry.WriteString('WorkingDir' + suffix, workingDir); Finally. F_Registry.CloseKey; End; End. End; End; Procedure TDelphiTool.Delete(toolIndex: Integer); Var. Suffix, tmp_suffix: string; I: integer; Begin. If (toolIndex < 0) or (toolIndex >= F_ToolCount) then. Raise EDelphiTool_InvalidIndex.Create('[Delete]: Invalid index.'). Else. Begin. If OpenKey(F_ToolPath, True) then. Begin. Try. Suffix := IntToStr(toolIndex); For i := toolIndex + 1 to F_ToolCount - 1 do. Begin. Tmp_suffix := IntToStr(i); F_registry.WriteString('Params' + suffix, F_registry.ReadString('Params' + tmp_suffix)); F_registry.WriteString('Path' + suffix, F_registry.ReadString('Path' + tmp_suffix)); F_registry.WriteString('Title' + suffix, F_registry.ReadString('Title' + tmp_suffix)); F_registry.WriteString('WorkingDir' + suffix, F_registry.ReadString('WorkingDir' + tmp_suffix)); Suffix := IntToStr(i); End; F_registry.DeleteValue('Params' + suffix); F_registry.DeleteValue('Path' + suffix); F_registry.DeleteValue('Title' + suffix); F_registry.DeleteValue('WorkingDir' + suffix); F_registry.WriteInteger('Count', F_ToolCount - 1); Dec(F_ToolCount); Finally. F_Registry.CloseKey; End; End; End; End; Procedure TDelphiTool.SetDelphiVersion(version: TDelphiVersion); //************************************************************* // for versions other then D6 lookup the registry and add lines. // like below , also add dvDx entries to TDelphiVersion. Begin. Case version of. DvD6: F_ToolPath := '\Software\Borland\Delphi\6.0\Transfer'; //** don't have D5, just guessing, so check it in the registry. //** before uncommenting. // dvD5: F_ToolPath:= '\Software\Borland\Delphi\5.0\Transfer'; End; End; Function TDelphiTool.Count: Integer; Begin. Result := F_ToolCount; End; Procedure TDelphiTool.ToolProperties(toolIndex: Integer; out params, path, Title, workingDir: string); Var. Suffix: string; Begin. If (toolIndex < 0) or (toolIndex >= F_ToolCount) then. Raise EDelphiTool_InvalidIndex.Create('[ToolProperties]: Invalid index.'). Else. Begin. If OpenKey(F_ToolPath, True) then. Begin. Try. Suffix := IntToStr(toolIndex); Params := F_registry.ReadString('Params' + suffix); Path := F_registry.ReadString('Path' + suffix); Title := F_registry.ReadString('Title' + suffix); WorkingDir := F_registry.ReadString('WorkingDir' + suffix); Finally. F_Registry.CloseKey; End; End. End; End; End. //******************************************************************* //** how to use it? //******************************************************************* Unit Unit1; Interface. Uses. Windows, {...}, DelphiTool; //... //... //... Var. Form1: TForm1; Implementation. Procedure TForm1.Button1Click(Sender: TObject); Begin. With TDelphiTool.Create do. Try. // Delete(IndexOf('MyTool')); Add('', Application.ExeName, 'MyTool', ExtractFilePath(Application.ExeName)); // Edit(IndexOf('MyTool'), '', '', 'MyTool But Edited', ''); Finally. Free; End; End;

©Drkb::00041.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как сделать Thumbnails?

Code: { Here is the routine I use in my thumbnail component and I belive it is quite. Fast. A tip to gain faster loading of jpegs is to use the TJpegScale.Scale. Property. You can gain a lot by using this correct. This routine can only downscale images no upscaling is supported and you. Must correctly set the dest image size. The src.image will be scaled to fit. In dest bitmap. } Const. FThumbSize = 150; //Speed up by Renate Schaaf, Armido, Gary Williams... Procedure MakeThumbNail(src, dest: tBitmap); Type. PRGB24 = ^TRGB24; TRGB24 = packed record. B: Byte; G: Byte; R: Byte; End; Var. X, y, ix, iy: integer; X1, x2, x3: integer; Xscale, yscale: single; IRed, iGrn, iBlu, iRatio: Longword; P, c1, c2, c3, c4, c5: tRGB24; Pt, pt1: pRGB24; ISrc, iDst, s1: integer; I, j, r, g, b, tmpY: integer; RowDest, RowSource, RowSourceStart: integer; W, h: integer; Dxmin, dymin: integer; Ny1, ny2, ny3: integer; Dx, dy: integer; LutX, lutY: array of integer; Begin. If src.PixelFormat <> pf24bit then src.PixelFormat := pf24bit; If dest.PixelFormat <> pf24bit then dest.PixelFormat := pf24bit; W := Dest.Width; H := Dest.Height; If (src.Width <= FThumbSize) and (src.Height <= FThumbSize) then. Begin. Dest.Assign(src); Exit; End; IDst := (w * 24 + 31) and not 31; IDst := iDst div 8; //BytesPerScanline. ISrc := (Src.Width * 24 + 31) and not 31; ISrc := iSrc div 8; Xscale := 1 / (w / src.Width); Yscale := 1 / (h / src.Height); // X lookup table. SetLength(lutX, w); X1 := 0; X2 := trunc(xscale); For x := 0 to w - 1 do. Begin. LutX[x] := x2 - x1; X1 := x2; X2 := trunc((x + 2) * xscale); End; // Y lookup table. SetLength(lutY, h); X1 := 0; X2 := trunc(yscale); For x := 0 to h - 1 do. Begin. LutY[x] := x2 - x1; X1 := x2; X2 := trunc((x + 2) * yscale); End; Dec(w); Dec(h); RowDest := integer(Dest.Scanline[0]); RowSourceStart := integer(Src.Scanline[0]); RowSource := RowSourceStart; For y := 0 to h do. Begin. Dy := lutY[y]; X1 := 0; X3 := 0; For x := 0 to w do. Begin. Dx:= lutX[x]; IRed:= 0; IGrn:= 0; IBlu:= 0; RowSource := RowSourceStart; For iy := 1 to dy do. Begin. Pt := PRGB24(RowSource + x1); For ix := 1 to dx do. Begin. IRed := iRed + pt.R; IGrn := iGrn + pt.G; IBlu := iBlu + pt.B; Inc(pt); End; RowSource := RowSource - iSrc; End; IRatio := 65535 div (dx * dy); Pt1 := PRGB24(RowDest + x3); Pt1.R := (iRed * iRatio) shr 16; Pt1.G := (iGrn * iRatio) shr 16; Pt1.B := (iBlu * iRatio) shr 16; X1 := x1 + 3 * dx; Inc(x3,3); End; RowDest := RowDest - iDst; RowSourceStart := RowSource; End; If dest.Height < 3 then exit; // Sharpening... S1 := integer(dest.ScanLine[0]); IDst := integer(dest.ScanLine[1]) - s1; Ny1 := Integer(s1); Ny2 := ny1 + iDst; Ny3 := ny2 + iDst; For y := 1 to dest.Height - 2 do. Begin. For x := 0 to dest.Width - 3 do. Begin. X1 := x * 3; X2 := x1 + 3; X3 := x1 + 6; C1 := pRGB24(ny1 + x1)^; C2 := pRGB24(ny1 + x3)^; C3 := pRGB24(ny2 + x2)^; C4 := pRGB24(ny3 + x1)^; C5 := pRGB24(ny3 + x3)^; R := (c1.R + c2.R + (c3.R * -12) + c4.R + c5.R) div -8; G := (c1.G + c2.G + (c3.G * -12) + c4.G + c5.G) div -8; B := (c1.B + c2.B + (c3.B * -12) + c4.B + c5.B) div -8; If r < 0 then r := 0 else if r > 255 then r := 255; If g < 0 then g := 0 else if g > 255 then g := 255; If b < 0 then b := 0 else if b > 255 then b := 255; Pt1 := pRGB24(ny2 + x2); Pt1.R := r; Pt1.G := g; Pt1.B := b; End; Inc(ny1, iDst); Inc(ny2, iDst); Inc(ny3, iDst); End; End;

Узнать/установить JPG resolution?

Code: Procedure GetResJpg(JPGFile: string); Const. BufferSize = 50; Var. Buffer: string; Index: integer; FileStream: TFileStream; HorzRes, VertRes: Word; DP: Byte; Measure: string; Begin. FileStream := TFileStream.Create(JPGFile, FmOpenReadWrite); Try. SetLength(Buffer, BufferSize); FileStream.Read(buffer[1], BufferSize); Index := Pos('JFIF' + #$00, buffer); If Index > 0 then. Begin. FileStream.Seek(Index + 6, soFromBeginning); FileStream.Read(DP, 1); Case DP of. 1: Measure := 'DPI'; //Dots Per Inch. 2: Measure := 'DPC'; //Dots Per Cm. End; FileStream.Read(HorzRes, 2); // x axis. HorzRes := Swap(HorzRes); FileStream.Read(VertRes, 2); // y axis. VertRes := Swap(VertRes); End. Finally. FileStream.Free; End; End; Procedure SetResJpg(name: string; dpix, dpiy: Integer); Const. BufferSize = 50; DPI = 1; //inch. DPC = 2; //cm. Var. Buffer: string; Index: INTEGER; FileStream: TFileStream; XResolution: WORD; YResolution: WORD; _type: Byte; Begin. FileStream := TFileStream.Create(name, FmOpenReadWrite); Try. SetLength(Buffer, BufferSize); FileStream.Read(buffer[1], BufferSize); Index := POS('JFIF' + #$00, buffer); If index > 0. Then begin. FileStream.Seek(index + 6, soFromBeginning); _type := DPI; FileStream.write(_type, 1); Xresolution := swap(dpix); FileStream.write(xresolution, 2); Yresolution := swap(dpiy); FileStream.write(yresolution, 2); End. Finally. FileStream.Free; End; End;

Изменение размеров JPEG Image?

Code: { Before importing an image (jpg) into a database, I would like to resize it (reduce its size) and. Generate the corresponding smaller file. How can I do this? Load the JPEG into a bitmap, create a new bitmap. Of the size that you want and pass them both into. SmoothResize then save it again ... There's a neat routine JPEGDimensions that. Gets the JPEG dimensions without actually loading the JPEG into a bitmap, Saves loads of time if you only need to test its size before resizing. } Uses. JPEG; Type. TRGBArray = array[Word] of TRGBTriple; PRGBArray = ^TRGBArray; Procedure SmoothResize(Src, Dst: TBitmap); Var. X, y: Integer; XP, yP: Integer; XP2, yP2: Integer; SrcLine1, SrcLine2: pRGBArray; T3: Integer; Z, z2, iz2: Integer; DstLine: pRGBArray; DstGap: Integer; W1, w2, w3, w4: Integer; Begin. Src.PixelFormat := pf24Bit; Dst.PixelFormat := pf24Bit; If (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then. Dst.Assign(Src). Else. Begin. DstLine := Dst.ScanLine[0]; DstGap := Integer(Dst.ScanLine[1]) - Integer(DstLine); XP2 := MulDiv(pred(Src.Width), $10000, Dst.Width); YP2 := MulDiv(pred(Src.Height), $10000, Dst.Height); YP := 0; For y := 0 to pred(Dst.Height) do. Begin. XP := 0; SrcLine1 := Src.ScanLine[yP shr 16]; If (yP shr 16 < pred(Src.Height)) then. SrcLine2 := Src.ScanLine[succ(yP shr 16)]. Else. SrcLine2 := Src.ScanLine[yP shr 16]; Z2 := succ(yP and $FFFF); Iz2 := succ((not yp) and $FFFF); For x := 0 to pred(Dst.Width) do. Begin. T3 := xP shr 16; Z := xP and $FFFF; W2 := MulDiv(z, iz2, $10000); W1 := iz2 - w2; W4 := MulDiv(z, z2, $10000); W3 := z2 - w4; DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 + SrcLine1[t3 + 1].rgbtRed * w2 + SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16; DstLine[x].rgbtGreen := (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 + SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16; DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 + SrcLine1[t3 + 1].rgbtBlue * w2 + SrcLine2[t3].rgbtBlue * w3 + SrcLine2[t3 + 1].rgbtBlue * w4) shr 16; Inc(xP, xP2); End; {for}. Inc(yP, yP2); DstLine := pRGBArray(Integer(DstLine) + DstGap); End; {for}. End; {if}. End; {SmoothResize}. Function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string): Boolean; Var. JPEGImage: TJPEGImage; Begin. If (FileName = '') then // No FileName so nothing. Result := False //to load - return False... Else. Begin. Try // Start of try except. JPEGImage := TJPEGImage.Create; // Create the JPEG image... try // now. Try // to load the file but. JPEGImage.LoadFromFile(FilePath + FileName); // might fail...with an Exception. Bitmap.Assign(JPEGImage); // Assign the image to our bitmap.Result := True; // Got it so return True. Finally. JPEGImage.Free; // ...must get rid of the JPEG image. finally. End; {try}. Except. Result := False; // Oops...never Loaded, so return False. End; {try}. End; {if}. End; {LoadJPEGPictureFile}. Function SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string; Quality: Integer): Boolean; Begin. Result := True; Try. If ForceDirectories(FilePath) then. Begin. With TJPegImage.Create do. Begin. Try. Assign(Bitmap); CompressionQuality := Quality; SaveToFile(FilePath + FileName); Finally. Free; End; {try}. End; {with}. End; {if}. Except. Raise; Result := False; End; {try}. End; {SaveJPEGPictureFile}. Procedure ResizeImage(FileName: string; MaxWidth: Integer); Var. OldBitmap: TBitmap; NewBitmap: TBitmap; AWidth: Integer; Begin. OldBitmap := TBitmap.Create; Try. If LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName), ExtractFileName(FileName)) then. Begin. AWidth := OldBitmap.Width; If (OldBitmap.Width > MaxWidth) then. Begin. AWidth := MaxWidth; NewBitmap := TBitmap.Create; Try. NewBitmap.Width := MaxWidth; NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height, OldBitmap.Width); SmoothResize(OldBitmap, NewBitmap); RenameFile(FileName, ChangeFileExt(FileName, '.$$$')); If SaveJPEGPictureFile(NewBitmap, ExtractFilePath(FileName), ExtractFileName(FileName), 75) then. DeleteFile(ChangeFileExt(FileName, '.$$$')). Else. RenameFile(ChangeFileExt(FileName, '.$$$'), FileName); Finally. NewBitmap.Free; End; {try}. End; {if}. End; {if}. Finally. OldBitmap.Free; End; {try}. End; Function JPEGDimensions(Filename : string; var X, Y : Word) : boolean; Var. SegmentPos : Integer; SOIcount : Integer; B : byte; Begin. Result := False; With TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone) do. Begin. Try. Position := 0; Read(X, 2); If (X <> $D8FF) then. Exit; SOIcount := 0; Position := 0; While (Position + 7 < Size) do. Begin. Read(b, 1); If (b = $FF) then begin. Read(b, 1); If (b = $D8) then. Inc(SOIcount); If (b = $DA) then. Break; End; {if}. End; {while}. If (b <> $DA) then. Exit; SegmentPos := -1; Position := 0; While (Position + 7 < Size) do. Begin. Read(b, 1); If (b = $FF) then. Begin. Read(b, 1); If (b in [$C0, $C1, $C2]) then. Begin. SegmentPos := Position; Dec(SOIcount); If (SOIcount = 0) then. Break; End; {if}. End; {if}. End; {while}. If (SegmentPos = -1) then. Exit; If (Position + 7 > Size) then. Exit; Position := SegmentPos + 3; Read(Y, 2); Read(X, 2); X := Swap(X); Y := Swap(Y); Result := true; Finally. Free; End; {try}. End; {with}. End; {JPEGDimensions}.

Конвертация bitmap to sepia or greyscale.

Code: //This function adds a sepia effect to a bitmap. //the 'depth' sets the colour intensity of the red-brown colour. //greater numbers set a higher intensity. //To create a greyscale effect instead, set 'depth' to 0. Function bmptosepia(const bmp: TBitmap; depth: Integer): Boolean; Var. Color,color2:longint; R,g,b,rr,gg:byte; H,w:integer; Begin. For h := 0 to bmp.height do. Begin. For w := 0 to bmp.width do. Begin. //first convert the bitmap to greyscale. Color:=colortorgb(bmp.Canvas.pixels[w,h]); R:=getrvalue(color); G:=getgvalue(color); B:=getbvalue(color); Color2:=(r+g+b) div 3; Bmp.canvas.Pixels[w,h]:=RGB(color2,color2,color2); //then convert it to sepia. Color:=colortorgb(bmp.Canvas.pixels[w,h]); R:=getrvalue(color); G:=getgvalue(color); B:=getbvalue(color); Rr:=r+(depth*2); Gg:=g+depth; If rr <= ((depth*2)-1) then. Rr:=255; If gg <= (depth-1) then. Gg:=255; Bmp.canvas.Pixels[w,h]:=RGB(rr,gg,b); End; End; End;

Как сделать ADOConnection с использованием OLE-Automation?

Code: Uses. ComObj; Function OpenConnection(ConnectionString: AnsiString): Integer; Var. ADODBConnection: OleVariant; Begin. ADODBConnection := CreateOleObject('ADODB.Connection'); ADODBConnection.CursorLocation := 3; // User client. ADODBConnection.ConnectionString := ConnectionString; Result := 0; Try. ADODBConnection.Open; Except. Result := -1; End; End; Function DataBaseConnection_Test(bMessage: Boolean): AnsiString; Var. AsTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString; IReturn: Integer; OldCursor: TCursor; Begin. OldCursor := Screen.Cursor; Screen.Cursor := crHourGlass; AsTimeout := '150'; AsUserName := 'NT_Server'; AsPassword := 'SA'; AsDataSource := 'SQL Server - My DataBase'; ConnectionString := 'Data Source = ' + asDataSource + 'User ID = ' + asUserName + 'Password = ' + asPassword + 'Mode = Read|Write;Connect Timeout = ' + asTimeout; Try. IReturn := OpenConnection(ConnectionString); If (bMessage) then. Begin. If (iReturn = 0) then. Application.MessageBox('Connection OK!', 'Information', MB_OK). Else if (iReturn = -1) then. Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK); End; If (iReturn = 0) then. Result := ConnectionString. Else if (iReturn = -1) then. Result := ''; Finally. Screen.Cursor := OldCursor; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. DataBaseConnection_Test(True); End;

Двигаем крестик для показа значений X/Y.

Code: // TPanel, TImage e TLabel components. // Insert Image into Panel... Private. BmpH, BmpV : TBitmap; OldX, OldY: Integer; End; Var. RectSaved : boolean = false; Procedure TFormMain.FormCreate(Sender: TObject); Begin. PanelImage.DoubleBuffered := true; // This prevents that the image is blinking. LabelHint.Transparent := true; LabelHint.Font.Color := clNave; End; Procedure TFormMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. Cross(X, Y); End; Procedure TFormMain.Cross(X, Y: Integer); Begin. Image.Canvas.Pen.Color := clBlack; // Restore last image to erase line. If RectSaved then. Begin. Image.Canvas.CopyRect(Rect(OldX - 5, 0, OldX + 5, BmpV.Height), BmpV.Canvas, Rect(0,0,BmpV.Width,BmpV.Height)); Image.Canvas.CopyRect(Rect(0, OldY - 5, BmpH.Width, OldY + 5), BmpH.Canvas, Rect(0,0,BmpH.Width,BmpH.Height)); BmpH.Free; BmpV.Free; End; // Now save the image at new position for each line. // horizontal line. BmpH := TBitmap.Create; BmpH.Width := Image.Width; BmpH.Height := 10; BmpH.Canvas.CopyRect(Rect(0,0,BmpH.Width,BmpH.Height), Image.Canvas,Rect(0, Y - 5, BmpH.Width, Y + 5)); // Vertical line. BmpV := TBitmap.Create; BmpV.Width := 10; BmpV.Height := Image.Height; BmpV.Canvas.CopyRect(Rect(0,0,BmpV.Width,BmpV.Height), Image.Canvas,Rect(X - 5, 0, X + 5, BmpV.Height)); // Now draw the current position. Image.Canvas.MoveTo(0, Y); Image.Canvas.LineTo(Image.Width, Y); Image.Canvas.MoveTo(X, 0); Image.Canvas.LineTo(X, Image.Height); RectSaved := true; OldX := X; OldY := Y; LabelHint.Left := X + 36; LabelHint.Top := Y - 15; LabelHint.Caption := '(X:' + IntToStr(X) + ' x Y:' + IntToStr(Y) +')'; End;

Как сделать форму всегда позади всех окон?

Code: Protected. Procedure CreateParams(var Params: TCreateParams); override; //... Procedure TForm.CreateParams(var Params: TCreateParams); Begin. Inherited CreateParams(Params); If Assigned(Application.MainForm) then. Begin. Params.WndParent := GetDesktopWindow; Params.Style := WS_CHILD; End; End;

Как прочитать ROM-BIOS?

An Example of this unit is availabe as Demo Download.

Code: //////////////////////////////////////////////////////////////////////////////// // // BIOS Helper for Delphi. // // BIOS related utilities for Win9x and WinNT(i386). // //////////////////////////////////////////////////////////////////////////////// // // The Original Code is: // BiosHelp.pas, released 2001-09-02. // // The Initial Developer of the Original Code is Nico Bendlin. // // Portions created by Nico Bendlin are. // Copyright (C) 2001-2003 Nico Bendlin. All Rights Reserved. // // Contributor(s): // Nico Bendlin<nicode@gmx.net> // // The contents of this file are subject to the Mozilla Public License Version. // 1.1 (the "License"); you may not use this file except in compliance with the. // License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ // // Software distributed under the License is distributed on an "AS IS" basis, // WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for. // the specific language governing rights and limitations under the License. // // Alternatively, the contents of this file may be used under the terms of. // either the GNU General Public License Version 2 or later (the "GPL"), or. // the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), // in which case the provisions of the GPL or the LGPL are applicable instead. // of those above. If you wish to allow use of your version of this file only. // under the terms of either the GPL or the LGPL, and not to allow others to. // use your version of this file under the terms of the MPL, indicate your. // decision by deleting the provisions above and replace them with the notice. // and other provisions required by the GPL or the LGPL. If you do not delete. // the provisions above, a recipient may use your version of this file under. // the terms of any one of the MPL, the GPL or the LGPL. // //////////////////////////////////////////////////////////////////////////////// // // Revision: // // 2003-02-15 2.00 [NicoDE]. // - generic dump method completely rewritten. // - default range is now E000:0000-F000:FFFF. // //////////////////////////////////////////////////////////////////////////////// {$IFDEF CONDITIONALEXPRESSIONS}. {$DEFINE DELPHI6UP}. {$IF NOT DEFINED(VER140)}. {$DEFINE DELPHI7UP}. {$IFEND}. {$ENDIF}. Unit BiosHelp {$IFDEF DELPHI6UP} platform {$ENDIF}; {$MINENUMSIZE 4}. {$WEAKPACKAGEUNIT}. {$IFDEF DELPHI7UP}. {$WARN UNSAFE_TYPE OFF}. {$WARN UNSAFE_CODE OFF}. {$ENDIF}. Interface. Uses. Windows; Const. RomBiosDumpBase = $000E0000; RomBiosDumpEnd = $000FFFFF; RomBiosDumpSize = RomBiosDumpEnd - RomBiosDumpBase + 1; Type. PRomBiosDump = ^TRomBiosDump; TRomBiosDump = array [RomBiosDumpBase..RomBiosDumpEnd] of Byte; Type. TRomDumpMethod = (rdmAutomatic, // Autodetect OS type and use proper method. RdmGeneric, // Use 16-bit EXE program to dump the BIOS. RdmMemory, // Dump from process's address space (Win9x). RdmPhysical // Dump from physical memory object (WinNT). ); Function DumpRomBios(out Dump: TRomBiosDump; Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean; Function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump; Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean; Procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer; Var Buffer; Size: Cardinal); Procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer; Var Buffer; Size: Cardinal); Function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer; Function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer; Implementation. //////////////////////////////////////////////////////////////////////////////// // // DumpRomBios16 (rdmGeneric). // // Creates an 16-bit EXE program in TEMP and runs it redirected to an file. // // WARNING: One day 16-bit code will not run on future Windows. // WARNING: You are dumping the BIOS inside the MS-DOS 'emulator'. // Function _RomDumpCode(RomBase: Pointer; RomSize: Cardinal; Out Code: Pointer; out Size: Cardinal): Boolean; Const. BlockSize = $1000; Type // ; RomDump (dumps mem to STDOUT). PRomDumpCode = ^TRomDumpCode; // ; BlockSize MUST be multiple of 10h. TRomDumpCode = packed record // _header: TImageDosHeader; // _notice: array[0..$4F] of AnsiChar; // @@note: db 'RomDump 2.0', ... Init: packed record // @@init: _mov_44: array[0..2] of Byte; // mov ax, 4400h. _mov_bx: array[0..2] of Byte; // mov bx, 0001h. _dos_21: array[0..1] of Byte; // int 21h. _jcf_18: array[0..1] of Byte; // jc @@code. _and_dx: array[0..3] of Byte; // and dx, 0082h. _cmp_dx: array[0..3] of Byte; // cmp dx, 0082h. _jne_0E: array[0..1] of Byte; // jne @@code. _psh_cs: Byte; // push cs. _pop_ds: Byte; // push ds. _mov_dx: array[0..2] of Byte; // mov dx, offset @@note. _mov_09: array[0..1] of Byte; // mov ah, 09h. _int_21: array[0..1] of Byte; // int 21h. _mov_4C: array[0..2] of Byte; // mov ax, 4C01h. _int_20: array[0..1] of Byte; // int 21h. End; // Code: packed record // @@code: _mov_cx: Byte; BlockCount: Word; // mov cx, <BlockCount> _mov_dx: Byte; DatSegment: Word; // mov dx, <DatSegment> _jcx_1C: array[0..1] of Byte; // jcxz @@rest. End; // Loop: packed record // @@loop: _psh_cx: Byte; // push cx. _psh_dx: Byte; // push dx. _mov_ds: array[0..1] of Byte; // mov ds, dx. _mov_dx: Byte; DatOffset: Word; // mov dx, <DatOffset> _mov_cx: array[0..2] of Byte; // mov cx, <BlockSize> _mov_bx: array[0..2] of Byte; // mov bx, 0001h. _mov_ax: array[0..2] of Byte; // mov ax, 4000h. _int_21: array[0..1] of Byte; // int 21h. _pop_dx: Byte; // pop dx. _pop_cx: Byte; // pop cx. _jcf_1C: array[0..1] of Byte; // jc @@exit. _add_dx: array[0..3] of Byte; // add dx, <BlockSize/10h> _lop_E4: array[0..1] of Byte; // loop @@loop. End; // Rest: packed record // @@rest: _mov_ds: array[0..1] of Byte; // mov ds, dx. _mov_dx: Byte; DatOffset: Word; // mov dx, <DatOffset> _mov_cx: Byte; LenghtMod: Word; // mov cx, <LenghtMod> _mov_bx: array[0..2] of Byte; // mov bx, 0001h. _mov_ax: array[0..2] of Byte; // mov ax, 4000h. _jcx_06: array[0..1] of Byte; // jcxz @@exit. _int_21: array[0..1] of Byte; // int 21h. _jcf_02: array[0..1] of Byte; // jc @@exit. _mov_al: array[0..1] of Byte; // mov al, 00h. End; // Exit: packed record // @@exit: _mov_ah: array[0..1] of Byte; // mov ah, 4Ch. _int_21: array[0..1] of Byte; // int 21h. End; // End; Const. RomDumpCodeSize = SizeOf(TRomDumpCode) - SizeOf(TImageDosHeader); RomDumpCode: TRomDumpCode = (_header: (e_magic: IMAGE_DOS_SIGNATURE; E_cblp: Word(RomDumpCodeSize) and $1FF; E_cp: Word((RomDumpCodeSize - 1) shr 9) + 1; E_crlc: $0000; E_cparhdr: SizeOf(TImageDosHeader) shr 4; E_minalloc: $0000; E_maxalloc: $FFFF; E_ss: $0000; E_sp: $1000; E_csum: $0000; E_ip: SizeOf(RomDumpCode._notice); E_cs: $0000; E_lfarlc: SizeOf(TImageDosHeader); E_ovno: $0000; E_res: ($0000, $0000, $0000, $0000); E_oemid: $0000; E_oeminfo: $0000; E_res2: ($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000); _lfanew: $00000000. ); _notice: #13#10 + 'RomDump 2.0'#13#10 + 'Copyright (c) 2003 Nico Bendlin'#13#10 + #13#10 + 'Usage: RomDump > filename'#13#10 + #13#10'$'; Init: (_mov_44: ($B8, $00, $44); _mov_bx: ($BB, $01, $00); _dos_21: ($CD, $21); _jcf_18: ($72, $18); _and_dx: ($81, $E2, $82, $00); _cmp_dx: ($81, $FA, $82, $00); _jne_0E: ($75, $0E); _psh_cs: $0E; _pop_ds: $1F; _mov_dx: ($BA, $00, $00); _mov_09: ($B4, $09); _int_21: ($CD, $21); _mov_4C: ($B8, $01, $4C); _int_20: ($CD, $21); ); Code: (_mov_cx: $B9; BlockCount: $0010; _mov_dx: $BA; DatSegment: $F000; _jcx_1C: ($E3, $1C). ); Loop: (_psh_cx: $51; _psh_dx: $52; _mov_ds: ($8E, $DA); _mov_dx: $BA; DatOffset: $0000; _mov_cx: ($B9, Lo(BlockSize), Hi(BlockSize)); _mov_bx: ($BB, $01, $00); _mov_ax: ($B8, $00, $40); _int_21: ($CD, $21); _pop_dx: $5A; _pop_cx: $59; _jcf_1C: ($72, $1C); _add_dx: ($81, $C2, Lo(BlockSize shr 4), Hi(BlockSize shr 4)); _lop_E4: ($E2, $E4). ); Rest: (_mov_ds: ($8E, $DA); _mov_dx: $BA; DatOffset: $0000; _mov_cx: $B9; LenghtMod: $0000; _mov_bx: ($BB, $01, $00); _mov_ax: ($B8, $00, $40); _jcx_06: ($E3, $06); _int_21: ($CD, $21); _jcf_02: ($72, $02); _mov_al: ($B0, $00). ); Exit: (_mov_ah: ($B4, $4C); _int_21: ($CD, $21). ) ); Begin. Result := False; If (RomSize > 0) and (RomSize <= $100000) and. (Cardinal(RomBase) < $100000) and. (Cardinal(RomBase) + RomSize <= $100000) then. Begin. Size := SizeOf(TRomDumpCode); Code := Pointer(LocalAlloc(LPTR, Size)); If Code <> nil then. Try. PRomDumpCode(Code)^ := RomDumpCode; With PRomDumpCode(Code)^ do. Begin. Code.BlockCount := Word(RomSize div BlockSize); Code.DatSegment := Word(Cardinal(RomBase) shr 4); Loop.DatOffset := Word(Cardinal(RomBase)) and $000F; Rest.DatOffset := loop.DatOffset; Rest.LenghtMod := Word(RomSize mod BlockSize); End; Result := True; Except. LocalFree(HLOCAL(Code)); Code := nil; Size := 0; End; End; End; Function _SaveRomDumpCodeToFile(RomBase: Pointer; RomSize: Cardinal; Const FileName: string): Boolean; Var. Code: Pointer; Size: Cardinal; Hand: THandle; Num: DWORD; Begin. Result := False; If _RomDumpCode(RomBase, RomSize, Code, Size) then. Try. Hand := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); If Hand <> INVALID_HANDLE_VALUE then. Try. Result := WriteFile(Hand, Code^, Size, Num, nil) and (Num = Size); If not Result then. DeleteFile(PChar(FileName)); Finally. CloseHandle(Hand); End; Finally. LocalFree(HLOCAL(Code)); End; End; Function _ExecuteRomDumpCode(const Code, Dump: string; Timeout: DWORD): Boolean; Var. ComSpec: string; StartInfo: TStartupInfo; ProcInfo: TProcessInformation; ErrorMode: Cardinal; Begin. Result := False; SetLength(ComSpec, MAX_PATH + 1); SetLength(ComSpec, GetEnvironmentVariable('ComSpec', PChar(@ComSpec[1]), MAX_PATH)); If Length(ComSpec) <= 0 then. Exit; FillChar(StartInfo, SizeOf(TStartupInfo), 0); StartInfo.cb := SizeOf(TStartupInfo); StartInfo.dwFlags := STARTF_USESHOWWINDOW; StartInfo.wShowWindow := SW_HIDE; ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOGPFAULTERRORBOX or. SEM_NOALIGNMENTFAULTEXCEPT or SEM_NOOPENFILEERRORBOX); Try. If CreateProcess(nil, PChar(ComSpec + ' /C ' + Code + ' > ' + Dump), Nil, nil, False, HIGH_PRIORITY_CLASS, nil, nil, StartInfo, ProcInfo) then. Try. Result := (WaitForSingleObject(ProcInfo.hProcess, Timeout) <> WAIT_TIMEOUT); If not Result then. TerminateProcess(ProcInfo.hProcess, STATUS_TIMEOUT); Finally. CloseHandle(ProcInfo.hThread); CloseHandle(ProcInfo.hProcess); End; Finally. SetErrorMode(ErrorMode); End; End; Function DumpRomBios16(RomBase: Pointer; RomSize: Cardinal; var Dump; Timeout: DWORD): Boolean; Var. Tmp: array [0..MAX_PATH] of Char; Dmp: array [0..MAX_PATH] of Char; Exe: array [0..MAX_PATH] of Char; Hnd: THandle; Num: DWORD; Begin. Result := False; If GetTempPath(MAX_PATH, Tmp) > 0 then. GetShortPathName(Tmp, Tmp, MAX_PATH). Else. Lstrcpy(Tmp, '.'); If GetTempFileName(Tmp, 'rom', 0, Dmp) > 0 then. Try. Lstrcpy(Exe, Dmp); Lstrcat(Exe, '.exe'); // Win9x requires .EXE extention. If _SaveRomDumpCodeToFile(RomBase, RomSize, Exe) then. Try. If _ExecuteRomDumpCode(Exe, Dmp, Timeout) then. Begin. Hnd := CreateFile(Dmp, GENERIC_READ, FILE_SHARE_READ or. FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); If Hnd <> INVALID_HANDLE_VALUE then. Try. Result := ReadFile(Hnd, Dump, RomSize, Num, nil) and (Num = RomSize); Finally. CloseHandle(Hnd); End; End; Finally. DeleteFile(Exe); End; Finally. DeleteFile(Dmp); End; End; //////////////////////////////////////////////////////////////////////////////// // // DumpRomBios9x (rdmMemory). // // Win9x maps the BIOS into every process - therefore it's directly accessed. // Function DumpRomBios9x(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean; Begin. Result := False; Try. Move(RomBase^, Dump, RomSize); Result := True; Except. // ignore exeptions. End. End; //////////////////////////////////////////////////////////////////////////////// // // DumpRomBiosNt (rdmPhysical). // // On WinNT the BIOS is accessable through section '\Device\PhysicalMemory'. // This object can only be opened by members of local 'Adminstrators' group. // ZwOpenSection and RtlNtStatusToDosError are documented in newer MSDN/DDK. // Type. NTSTATUS = Integer; PUnicodeString = ^TUnicodeString; TUnicodeString = packed record. Length: Word; MaximumLength: Word; Buffer: PWideChar; End; PObjectAttributes = ^TObjectAttributes; TObjectAttributes = record. Length: ULONG; RootDirectory: THandle; ObjectName: PUnicodeString; Attributes: ULONG; SecurityDescriptor: PSecurityDescriptor; SecurityQualityOfService: PSecurityQualityOfService; End; TFNZwOpenSection = function(out Section: THandle; Access: ACCESS_MASK; Attributes: PObjectAttributes): NTSTATUS; Stdcall; TFNRtlNtStatusToDosError = function(Status: NTSTATUS): DWORD; Stdcall; Const. PhysMemDevName = '\Device\PhysicalMemory'; PhysMemName: TUnicodeString = (Length: Length(PhysMemDevName) * SizeOf(WideChar); MaximumLength: Length(PhysMemDevName) * SizeOf(WideChar) + SizeOf(WideChar); Buffer: PhysMemDevName; ); PhysMemMask: ACCESS_MASK = SECTION_MAP_READ; PhysMemAttr: TObjectAttributes = (Length: SizeOf(TObjectAttributes); RootDirectory: 0; ObjectName: @PhysMemName; Attributes: $00000040; // OBJ_CASE_INSENSITIVE. SecurityDescriptor: nil; SecurityQualityOfService: nil; ); Var. ZwOpenSection: TFNZwOpenSection; RtlNtStatusToDosError: TFNRtlNtStatusToDosError; Function DumpRomBiosNt(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean; Var. HMod: HMODULE; Stat: NTSTATUS; Sect: THandle; View: Pointer; Begin. Result := False; HMod := GetModuleHandle('ntdll.dll'); If HMod = 0 then. SetLastError(ERROR_CALL_NOT_IMPLEMENTED). Else. Begin. If not Assigned(ZwOpenSection) then. ZwOpenSection := GetProcAddress(HMod, 'ZwOpenSection'); If not Assigned(RtlNtStatusToDosError) then. RtlNtStatusToDosError := GetProcAddress(HMod, 'RtlNtStatusToDosError'); If not Assigned(ZwOpenSection) or not Assigned(RtlNtStatusToDosError) then. SetLastError(ERROR_CALL_NOT_IMPLEMENTED). Else. Begin. Stat := ZwOpenSection(Sect, PhysMemMask, @PhysMemAttr); If Stat >= 0 then. Try. View := MapViewOfFile(Sect, PhysMemMask, 0, Cardinal(RomBase), RomSize); If View <> nil then. Try. Move(View^, Dump, RomSize); Result := True; Finally. UnmapViewOfFile(View); End; Finally. CloseHandle(Sect); End. Else. SetLastError(RtlNtStatusToDosError(Stat)); End; End; End; //////////////////////////////////////////////////////////////////////////////// // // DumpRomBios(Ex). // // Public functions to call OS-dependent implementations. // Function DumpRomBios(out Dump: TRomBiosDump; Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean; Begin. Result := DumpRomBiosEx(Pointer(RomBiosDumpBase), RomBiosDumpSize, Dump, Method, Timeout); End; Function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump; Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean; Begin. Result := False; Case Method of. RdmAutomatic: If (GetVersion() and $80000000) <> 0 then. Result := DumpRomBios9x(RomBase, RomSize, Dump). Else. Begin. Result := DumpRomBiosNt(RomBase, RomSize, Dump); If not Result then. DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout)); End; RdmGeneric: Result := DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout)); RdmMemory: Result := DumpRomBios9x(RomBase, RomSize, Dump); RdmPhysical: Result := DumpRomBiosNt(RomBase, RomSize, Dump); Else. SetLastError(ERROR_INVALID_PARAMETER); End; End; //////////////////////////////////////////////////////////////////////////////// // // ReadRomDumpBuffer(Ex) / GetRomDumpAddr(Ex). // // Utilities to simplify the access to dumps. // Procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer; Var Buffer; Size: Cardinal); Begin. Move(Dump[Cardinal(Addr)], Buffer, Size); End; Procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer; Var Buffer; Size: Cardinal); Begin. Move(Pointer(Cardinal(@Dump) + Cardinal(Addr) - Cardinal(Base))^, Buffer, Size); End; Function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer; Begin. Result := @Dump[Cardinal(Addr)]; End; Function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer; Begin. Result := Pointer(Cardinal(@Dump) + Cardinal(Addr) - Cardinal(Base)); End; End.

©Drkb::01367.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как определить установлен ли screen saver?

Code: Function ScreenSaverEnabled: Boolean; Var. Status: Bool; Begin. SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @status, 0); Result := status = True; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If ScreenSaverEnabled then. Caption := 'Screensaver is enabled.' Else. Caption := 'Screensaver is disabled.' End;

Как получить часть GUID?

Code: { You maybe have to access just a part of a GUID. }. { Const for the function Format(...) }. Const. FsGUID: string = 'D1: $%s'#13#10'D2: $%s'#13#10'D3: $%s'#13#10 + 'D4: $%s $%s $%s $%s $%s $%s $%s $%s'; FsGUIDParts: string = 'D%d:%s'; // Type for the GUID part to be shown. Type. TGUIDPART = (guidp_NoFormat, guidp_All, guidp_D1, Guidp_D2, guidp_D3, guidp_D4); { This GUIDToStringEx function give you the full GUID string. According with then format string FStr (you can change it !!!) }. Function GUIDToStringEx(Guid: TGuid; FStr: string): string; overload; Begin. Result := Format(FStr, [IntToHex(GUID.D1, 8), IntToHex(GUID.D2, 4), IntToHex(GUID.D3, 4), IntToHex(GUID.D4[0], 2), IntToHex(GUID.D4[1], 2), IntToHex(GUID.D4[2], 2), IntToHex(GUID.D4[3], 2), IntToHex(GUID.D4[4], 2), IntToHex(GUID.D4[5], 2), IntToHex(GUID.D4[6], 2), IntToHex(GUID.D4[7], 2). ]); End; { This GUIDToStringEx function give you the part of the GUID. To be shown, according to the part type GUIDPart }. Function GUIDToStringEx(Guid: TGuid; Part: TGUIDPART): string; overload; Var. I: Integer; S: string; Begin. S := ''; Case Part of. Guidp_NoFormat: S := GUIDToString(Guid); Guidp_All: S := GUIDToStringEx(Guid, fsGUID); Guidp_D1: S := Format(fsGUIDParts, [1, ' $' + IntToHex(GUID.D1, 8)]); Guidp_D2: S := Format(fsGUIDParts, [2, ' $' + IntToHex(GUID.D2, 4)]); Guidp_D3: S := Format(fsGUIDParts, [3, ' $' + IntToHex(GUID.D3, 4)]); Guidp_D4: Begin. For i := 0 to 7 do S := S + ' $' + IntToHex(GUID.D4[i], 2); S := Format(fsGUIDParts, [4, S]); End; Else. S := '?'; End; Result := S; End; { How to use the different GUIDToStringEx functions }. Procedure TForm1.Button1Click(Sender: TObject); Var. NewGUID: TGUID; Begin. { Create a new GUID }. NewGUID := StringToGUID(CreateClassID); { Standard formated GUID string }. Label1.Caption := GUIDToStringEx(NewGUID, guidp_NoFormat) + #13#10 + { Full formated GUID string acc. with fsGUID}. GUIDToStringEx(NewGUID, fsGUID) + #13#10 + { Full formated GUID string with default formating}. GUIDToStringEx(NewGUID, guidp_All) + #13#10 + { Part D3 of the GUID only }. GUIDToStringEx(NewGUID, guidp_D3); End;

©Drkb::00080.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Vit - обычно достаточно использовать API функцию CoCreateGuid.

Как узнать заряженность батарей?

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. SysPowerStatus: TSystemPowerStatus; Begin. GetSystemPowerStatus(SysPowerStatus); If Boolean(SysPowerStatus.ACLineStatus) then. Begin. ShowMessage('System running on AC.'); End. Else. Begin. ShowMessage('System running on battery.'); ShowMessage(Format('Battery power left: %d percent.', [SysPowerStatus.BatteryLifePercent])); End; End;

©Drkb::01676.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как изменить пароль для указанной сети или домена?

Code: Function NetUserChangePassword(Domain: PWideChar; UserName: PWideChar; OldPassword: PWideChar; NewPassword: PWideChar): Longint; stdcall; external 'netapi32.dll' Name 'NetUserChangePassword'; // Changes a user's password for a specified network server or domain. // Requirements: Windows NT/2000/XP. // Windows 95/98/Me: You can use the PwdChangePassword function to change a user's. // Windows logon password on these platforms. Procedure TForm1.Button1Click(Sender: TObject); Begin. NetUserChangePassword(PWideChar(WideString('\\COMPUTER')), PWideChar(WideString('username')), PWideChar(WideString('oldpass')), PWideChar(WideString('newpass'))); End;

Как предотвратить Shut Down?

Code: { The WM_QUERYENDSESSION message is sent to all applications. When the user chooses to end the session or when an application calls the. ExitWindows function. If any application returns zero, the session is not ended. The system stops sending WM_QUERYENDSESSION messages as soon as one application. Returns zero. After processing this message, the system sends the WM_ENDSESSION message with the. WParam parameter set to the results of the WM_QUERYENDSESSION message. Windows NT/2000/XP: When an application returns TRUE for this message, It receives the WM_ENDSESSION message and it is terminated, Regardless of how the other applications respond to the WM_QUERYENDSESSION message. Windows 95/98/Me: After all applications return TRUE for this message, They receive the WM_ENDSESSION and they are terminated. } Private. Procedure WMQueryEndSession (var Msg : TWMQueryEndSession); message WM_QueryEndSession; End; Implementation. Procedure TForm1.WMQueryEndSession (var Msg : TWMQueryEndSession); Begin. If MessageDlg('Close Windows now/ Windows beenden?', MtConfirmation, [mbYes,mbNo], 0) = mrNo then. Msg.Result := 0. Else. Msg.Result := 1; End;

©Drkb::01675.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как получить список загруженных драйверов?

Code: { This code takes advantage of the undocumented NtQuerySystemInformation. API to obtain a list of loaded drivers under Windows NT. } Const. DRIVER_INFORMATION = 11; Type. TPDWord = ^DWORD; TDriverInfo = packed record. Address: Pointer; Unknown1: DWORD; Unknown2: DWORD; EntryIndex: DWORD; Unknown4: DWORD; Name: array [0..MAX_PATH + 3] of Char; End; Var. NtQuerySystemInformation: function (infoClass: DWORD; Buffer: Pointer; BufSize: DWORD; ReturnSize: TPDword): DWORD; stdcall = nil; Function GetDriverInfo: string; Var. Temp, Index, numBytes, numEntries: DWORD; Buf: TPDword; DriverInfo: ^TDriverInfo; Begin. If @NtQuerySystemInformation = nil then. NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'), 'NtQuerySystemInformation'); // Obtain required buffer size. NtQuerySystemInformation(DRIVER_INFORMATION, @temp, 0, @numBytes); // Allocate buffer. Buf := AllocMem(numBytes * 2); NtQuerySystemInformation(DRIVER_INFORMATION, buf, numBytes * 2, @numBytes); NumEntries := buf^; DriverInfo := Pointer(DWORD(buf) + 12); Result := ''; For Index := 1 to numEntries do. Begin. Result := Result + #$D#$A + 'Address: $' + IntToHex(DWORD(driverInfo^.Address), 8) + 'Name: "' + (driverInfo^.Name) + '"'; Inc(driverInfo); End; Delete(Result, 1, 2); FreeMem(buf); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ListBox1.Items.Add(GetDriverInfo). End; // Thanks to Madshi for helping me translate from C++ Code. // Original Code (C++) : // NtDriverList v1.0. // Copyright 1998, 1999 Yariv Kaplan. // WWW.INTERNALS.COM.

Загрузить все записи в Stringlist одним махом?

Loading millions of records into a stringlist can be very slow }.

Code: Procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList); Begin. StringList.Clear; With SourceTable do. Begin. Open; DisableControls; Try. While not EOF do. Begin. StringList.Add(FieldByName('OriginalData').AsString); Next; End; Finally. EnableControls; Close; End; End; End; { This is much, much faster }. Procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList); Begin. With CacheTable do. Begin. Open; Try. StringList.Text := FieldByName('Data').AsString; Finally. Close; End; End; End; { How can this be done? In Microsoft SQL Server 7, you can write a stored procedure that updates every night. A cache table that holds all the data you want in a single column and row. In this example, you get the data from a SourceTable and put it all in a Cachetable. The CacheTable has one blob column and must have only one row. Here it is the SQL code: }.

Как узнать количество памяти используемое процессом?

Code: // Works only on Windows NT systems (WinNT, Win2000, WinXP). Uses psAPI; Procedure TForm1.Button1Click(Sender: TObject); Var. Pmc: PPROCESS_MEMORY_COUNTERS; Cb: Integer; Begin. Cb := SizeOf(_PROCESS_MEMORY_COUNTERS); GetMem(pmc, cb); Pmc^.cb := cb; If GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then. Label1.Caption := IntToStr(pmc^.WorkingSetSize) + ' Bytes' Else. Label1.Caption := 'Unable to retrieve memory usage structure'; FreeMem(pmc); End;

Как узнать о переключении сессии в XP?

Code: { Typically, an application does not need to be notified when a session switch. Occurs. However, if the application needs to be aware when its desktop is. Current, it can register for session switch notifications. Applications that. Access the serial port or another shared resource on the computer should. Check for this. To register for a notification, use the following function: } Function WTSRegisterSessionNotification( HWnd: HWND , // Window handle. DwFlags: DWORD // Flags. ): Bool; // Return value. { The registered HWND receives the message WM_WTSSESSION_CHANGE. Through its WindowProc function. In dwFlags you can specify: A) NOTIFY_FOR_THIS_SESSION. A window is notified only about the session. Change events that affect the session to which window belongs. B) NOTIFY_FOR_ALL_SESSIONS. A window is notified for all session change. Events. The action happening on the session can be found in wParam code, which may. Contain one of the following flags. WTS_CONSOLE_CONNECT: A session was connected to the console session. WTS_CONSOLE_DISCONNECT: A session was disconnected from the console session. WTS_REMOTE_CONNECT: A session was connected to the remote session. WTS_REMOTE_DISCONNECT: A session was disconnected from the remote session. WTS_SESSION_LOGON: A user has logged on to the session. WTS_SESSION_LOGOFF: A user has logged off the session. WTS_SESSION_LOCK: A session has been locked. WTS_SESSION_UNLOCK: A session has been unlocked. WTS_SESSION_REMOTE_CONTROL: A session has changed its remote controlled status. LParam contains the sessionId for the session affected. When your process no longer requires these notifications or is terminating, It should call the following to unregister its notification. } Function WTSUnRegisterSesssionNotification( HWnd: HWND // window handle. ): Boolean; // Result. { The HWND values passed to WTSRegisterSessionNotification are reference. Counted, so you must call WTSUnRegisterSessionNotification exactly the same. Number of times that you call WTSRegisterSessionNotification. Applications can use the WTS_CONSOLE_CONNECT, WTS_CONSOLE_DISCONNECT, WTS_REMOTE_CONNECT, WTS_REMOTE_DISCONNECT messages to track their state, as. Well as to release and acquire console specific resources. }

Code: Unit Wtsapi; Interface. { (c) By Thomas Stutz 10. April 02 }. Uses. Windows; Const. // The WM_WTSSESSION_CHANGE message notifies applications of changes in session state. WM_WTSSESSION_CHANGE = $2B1; // wParam values: WTS_CONSOLE_CONNECT = 1; WTS_CONSOLE_DISCONNECT = 2; WTS_REMOTE_CONNECT = 3; WTS_REMOTE_DISCONNECT = 4; WTS_SESSION_LOGON = 5; WTS_SESSION_LOGOFF = 6; WTS_SESSION_LOCK = 7; WTS_SESSION_UNLOCK = 8; WTS_SESSION_REMOTE_CONTROL = 9; // Only session notifications involving the session attached to by the window. // identified by the hWnd parameter value are to be received. NOTIFY_FOR_THIS_SESSION = 0; // All session notifications are to be received. NOTIFY_FOR_ALL_SESSIONS = 1; Function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean; Function UnRegisterSessionNotification(Wnd: HWND): Boolean; Function GetCurrentSessionID: Integer; Implementation. Function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean; // The RegisterSessionNotification function registers the specified window. // to receive session change notifications. // Parameters: // hWnd: Handle of the window to receive session change notifications. // dwFlags: Specifies which session notifications are to be received: // (NOTIFY_FOR_THIS_SESSION, NOTIFY_FOR_ALL_SESSIONS). Type. TWTSRegisterSessionNotification = function(Wnd: HWND; dwFlags: DWORD): BOOL; stdcall; Var. HWTSapi32dll: THandle; WTSRegisterSessionNotification: TWTSRegisterSessionNotification; Begin. Result := False; HWTSAPI32DLL := LoadLibrary('Wtsapi32.dll'); If (hWTSAPI32DLL > 0) then. Begin. Try @WTSRegisterSessionNotification := GetProcAddress(hWTSAPI32DLL, 'WTSRegisterSessionNotification'); If Assigned(WTSRegisterSessionNotification) then. Begin. Result:= WTSRegisterSessionNotification(Wnd, dwFlags); End; Finally. If hWTSAPI32DLL > 0 then. FreeLibrary(hWTSAPI32DLL); End; End; End; Function UnRegisterSessionNotification(Wnd: HWND): Boolean; // The RegisterSessionNotification function unregisters the specified window. // Parameters: // hWnd: Handle to the window. Type. TWTSUnRegisterSessionNotification = function(Wnd: HWND): BOOL; stdcall; Var. HWTSapi32dll: THandle; WTSUnRegisterSessionNotification: TWTSUnRegisterSessionNotification; Begin. Result := False; HWTSAPI32DLL := LoadLibrary('Wtsapi32.dll'); If (hWTSAPI32DLL > 0) then. Begin. Try @WTSUnRegisterSessionNotification := GetProcAddress(hWTSAPI32DLL, 'WTSUnRegisterSessionNotification'); If Assigned(WTSUnRegisterSessionNotification) then. Begin. Result:= WTSUnRegisterSessionNotification(Wnd); End; Finally. If hWTSAPI32DLL > 0 then. FreeLibrary(hWTSAPI32DLL); End; End; End; Function GetCurrentSessionID: Integer; // Getting the session id from the current process. Type. TProcessIdToSessionId = function(dwProcessId: DWORD; pSessionId: DWORD): BOOL; stdcall; Var. ProcessIdToSessionId: TProcessIdToSessionId; HWTSapi32dll: THandle; Lib : THandle; PSessionId : DWord; Begin. Result := 0; Lib := GetModuleHandle('kernel32'); If Lib <> 0 then. Begin. ProcessIdToSessionId := GetProcAddress(Lib, '1ProcessIdToSessionId'); If Assigned(ProcessIdToSessionId) then. Begin. ProcessIdToSessionId(GetCurrentProcessId(), DWORD(@pSessionId)); Result:= pSessionId; End; End; End; End.

Example:

Code: Unit Unit1; Interface. Uses. Windows, Messages, {...}, Wtsapi; Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. { Private declarations }. FRegisteredSessionNotification : Boolean; Procedure AppMessage(var Msg: TMSG; var HAndled: Boolean); End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean); Var. StrReason: string; Begin. Handled := False; // Check for WM_WTSSESSION_CHANGE message. If Msg.Message = WM_WTSSESSION_CHANGE then. Begin. Case Msg.wParam of. WTS_CONSOLE_CONNECT: StrReason := 'WTS_CONSOLE_CONNECT'; WTS_CONSOLE_DISCONNECT: StrReason := 'WTS_CONSOLE_DISCONNECT'; WTS_REMOTE_CONNECT: StrReason := 'WTS_REMOTE_CONNECT'; WTS_REMOTE_DISCONNECT: StrReason := 'WTS_REMOTE_DISCONNECT'; WTS_SESSION_LOGON: StrReason := 'WTS_SESSION_LOGON'; WTS_SESSION_LOGOFF: StrReason := 'WTS_SESSION_LOGOFF'; WTS_SESSION_LOCK: StrReason := 'WTS_SESSION_LOCK'; WTS_SESSION_UNLOCK: StrReason := 'WTS_SESSION_UNLOCK'; WTS_SESSION_REMOTE_CONTROL: Begin. StrReason := 'WTS_SESSION_REMOTE_CONTROL'; // GetSystemMetrics(SM_REMOTECONTROL); End; Else. StrReason := 'WTS_Unknown'; End; // Write strReason to a Memo. Memo1.Lines.Add(strReason + ' ' + IntToStr(msg.Lparam)); End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. // register the window to receive session change notifications. FRegisteredSessionNotification := RegisterSessionNotification(Handle, NOTIFY_FOR_THIS_SESSION); Application.OnMessage := AppMessage; End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. // unregister session change notifications. If FRegisteredSessionNotification then. UnRegisterSessionNotification(Handle); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. // retrieve current session ID. ShowMessage(Inttostr(GetCurrentSessionID)); End;

©Drkb::01707.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как использовать IP Address Control у себя?

Code: { Microsoft® Internet Explorer Version 4.0 introduces the IP address control, A new control similar to an edit control that allows the user to enter a. Numeric address in Internet protocol (IP) format. This format consists of four three-digit fields. Each field is treated individually; the field numbers are zero-based and. Proceed from left to right as shown in this figure. Further informations. Http://msdn.microsoft.com/library/en-us/shellcc/platform/commctls/ipaddress/ipaddress.asp. } Unit Unit1; Interface. Uses. Windows, Messages, Classes, Forms, Controls, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). IPAddress: TBevel; SetIP: TButton; ClearIP: TButton; Procedure FormCreate(Sender: TObject); Procedure SetIPClick(Sender: TObject); Procedure ClearIPClick(Sender: TObject); Private. FIPAddress: Longint; HIPAddress: HWND; PrevWndProc: TWndMethod; Procedure NewWindowProc(var Message: TMessage); Public. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Uses. CommCtrl; Const. IP_ADDRESS_ID: Longword = $0100; Procedure TForm1.FormCreate(Sender: TObject); Var. LpInitCtrls: TInitCommonControlsEx; Begin. LpInitCtrls.dwSize := SizeOf(TInitCommonControlsEx); LpInitCtrls.dwICC := ICC_INTERNET_CLASSES; If InitCommonControlsEx(lpInitCtrls) then. Begin. PrevWndProc := WindowProc; WindowProc := NewWindowProc; HIPAddress := CreateWindowEx(WS_EX_LEFT, WC_IPADDRESS, nil, WS_CHILD + WS_VISIBLE + WS_BORDER + WS_TABSTOP, IPAddress.Left, IPAddress.Top, IPAddress.Width, IPAddress.Height, Handle, IP_ADDRESS_ID, HInstance, nil); SendMessage(HIPAddress, IPM_SETFOCUS, 0, 0); End; End; Procedure TForm1.NewWindowProc(var Message: TMessage); Var. NField: longint; Begin. Case Message.Msg of. WM_NOTIFY: Begin. If PNMHDR(Ptr(Message.lParam)).idFrom = IP_ADDRESS_ID then. Begin. Case PNMIPAddress(ptr(Message.lParam)).hdr.code of. IPN_FIELDCHANGED: Begin. If SendMessage(HIPAddress, IPM_ISBLANK, 0, 0) = 0 then. SendMessage(HIPAddress, IPM_GETADDRESS, 0, lParam(LPDWORD(@FIPAddress))); End; End; End; End; WM_COMMAND: Begin. If Message.WParamLo = IP_ADDRESS_ID then. Case Message.WParamHi of. EN_SETFOCUS: Begin. NField := SendMessage(HIPAddress, IPM_GETADDRESS, 0, LParam(LPDWORD(@FIPAddress))); If nField = 4 then nField := 0; SendMessage(HIPAddress, IPM_SETFOCUS, wParam(nField), 0); End; EN_KILLFOCUS: Begin. If SendMessage(HIPAddress, IPM_ISBLANK, 0, 0) = 0 then. SendMessage(HIPAddress, IPM_GETADDRESS, 0, lParam(LPDWORD(@FIPAddress))); End; EN_CHANGE: Begin. End; End; End; End; If Assigned(PrevWndProc) then PrevWndproc(Message); End; Procedure TForm1.SetIPClick(Sender: TObject); Begin. FIPAddress := MAKEIPADDRESS(127, 0, 0, 1); SendMessage(HIPAddress, IPM_SETADDRESS, 0, lParam(DWORD(FIPAddress))); End; Procedure TForm1.ClearIPClick(Sender: TObject); Begin. SendMessage(HIPAddress, IPM_CLEARADDRESS, 0, 0); End; End.

©Drkb::01324.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Изменение привилегий.

Code: { For some functions you need to get the right privileges. On a Windows NT machine. (e.g: To shut down or restart windows with ExitWindowsEx or. To change the system time). The following code provides a procedure to adjust the privileges. The AdjustTokenPrivileges() function enables or disables privileges. In the specified access token. } // NT Defined Privileges from winnt.h. Const. SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege'; SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege'; SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege'; SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege'; SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege'; SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege'; SE_TCB_NAME = 'SeTcbPrivilege'; SE_SECURITY_NAME = 'SeSecurityPrivilege'; SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege'; SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege'; SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege'; SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege'; SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege'; SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege'; SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege'; SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege'; SE_BACKUP_NAME = 'SeBackupPrivilege'; SE_RESTORE_NAME = 'SeRestorePrivilege'; SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; SE_DEBUG_NAME = 'SeDebugPrivilege'; SE_AUDIT_NAME = 'SeAuditPrivilege'; SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege'; SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege'; SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege'; SE_UNDOCK_NAME = 'SeUndockPrivilege'; SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege'; SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege'; SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege'; // Enables or disables privileges debending on the bEnabled. // Aktiviert oder deaktiviert Privilegien, abhangig von bEnabled. Function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean; Var. HToken: THandle; TokenPriv: TOKEN_PRIVILEGES; PrevTokenPriv: TOKEN_PRIVILEGES; ReturnLength: Cardinal; Begin. Result := True; // Only for Windows NT/2000/XP and later. If not (Win32Platform = VER_PLATFORM_WIN32_NT) then Exit; Result := False; // obtain the processes token. If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then. Begin. Try. // Get the locally unique identifier (LUID) . If LookupPrivilegeValue(nil, PChar(sPrivilege), TokenPriv.Privileges[0].Luid) then. Begin. TokenPriv.PrivilegeCount := 1; // one privilege to set. Case bEnabled of. True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; False: TokenPriv.Privileges[0].Attributes := 0; End; ReturnLength := 0; // replaces a var parameter. PrevTokenPriv := TokenPriv; // enable or disable the privilege. AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv), PrevTokenPriv, ReturnLength); End; Finally. CloseHandle(hToken); End; End; // test the return value of AdjustTokenPrivileges. Result := GetLastError = ERROR_SUCCESS; If not Result then. Raise Exception.Create(SysErrorMessage(GetLastError)); End;

Показать Run диалог.

Code: Uses. ComObj; Procedure TForm1.FormCreate(Sender: TObject); Var. ShellApplication: Variant; Begin. ShellApplication := CreateOleObject('Shell.Application'); ShellApplication.FileRun; End; {*****************************} {2.}. { This code uses the undocumented RunFileDlg function to show the "run" dialog }. // For Win NT. Procedure RunFileDlgW(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PWideChar; LpstrTitle: PWideChar; lpstrDescription: PWideChar; Flags: Longint); stdcall; External 'Shell32.dll' Index 61; // For Win 9x (Win NT to show standard captions ). Procedure RunFileDlg(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PChar; LpstrTitle: PChar; lpstrDescription: PChar; Flags: Longint); stdcall; External 'Shell32.dll' Index 61; Const. RFF_NOBROWSE = 1; //Removes the browse button. RFF_NODEFAULT = 2; // No default item selected. RFF_CALCDIRECTORY = 4; // Calculates the working directory from the file name. RFF_NOLABEL = 8; // Removes the edit box label. RFF_NOSEPARATEMEM = 14; // Removes the Separate Memory Space check box (Windows NT only). Function ShowRunFileDialg(OwnerWnd: HWND; InitialDir, Title, Description: PChar; Flags: Integer; StandardCaptions: Boolean): Boolean; Var. HideBrowseButton: Boolean; TitleWideChar, InitialDirWideChar, DescriptionWideChar: PWideChar; Size: Integer; Begin. If (Win32Platform = VER_PLATFORM_WIN32_NT) and not StandardCaptions then. Begin. Size := SizeOf(WideChar) * MAX_PATH; InitialDirWideChar := nil; TitleWideChar := nil; DescriptionWideChar := nil; GetMem(InitialDirWideChar, Size); GetMem(TitleWideChar, Size); GetMem(DescriptionWideChar, Size); StringToWideChar(InitialDir, InitialDirWideChar, MAX_PATH); StringToWideChar(Title, TitleWideChar, MAX_PATH); StringToWideChar(Description, DescriptionWideChar, MAX_PATH); Try. RunFileDlgW(OwnerWnd, 0, InitialDirWideChar, TitleWideChar, DescriptionWideChar, Flags); Finally. FreeMem(InitialDirWideChar); FreeMem(TitleWideChar); FreeMem(DescriptionWideChar); End; End else. RunFileDlg(OwnerWnd, 0, PChar(InitialDir), PChar(Title), PChar(Description), Flags); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowRunFileDialg(FindWindow('Shell_TrayWnd', nil), nil, nil, nil, RFF_NOBROWSE, True); End;

Поддерживается ли MMX.

Code: Function SupportsMMX: Boolean; Begin. Result := False; Try. Asm. Push eax. Push ebx. Push ecx. Push edx. Pushfd. Pop eax. Mov ebx,eax. Xor eax,$00200000. Push eax. Popfd. Pushfd. Pop eax. Xor eax,ebx. Je @NoMMX. Mov eax,$01. Test edx,$800000. Jz @NoMMX. Mov byte ptr[Result],1. @NoMMX: Pop edx. Pop ecx. Pop ebx. Pop eax. End; Except; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If SupportsMMX then ShowMessage('Computer supports MMX'); End;

©Drkb::01436.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как выгрузить Dll из памяти?

Code: Function KillDll(aDllName: string): Boolean; Var. HDLL: THandle; AName: array[0..10] of char; FoundDLL: Boolean; Begin. StrPCopy(aName, aDllName); FoundDLL := False; Repeat. HDLL := GetModuleHandle(aName); If hDLL = 0 then. Break; FoundDLL := True; FreeLibrary(hDLL); Until False; If FoundDLL then. MessageDlg('Success!', mtInformation, [mbOK], 0). Else. MessageDlg('DLL not found!', mtInformation, [mbOK], 0); End;

Как вывести список привилегий?

Code: Procedure TForm1.Button1Click(Sender: TObject); Const. TokenSize = 800; // (SizeOf(Pointer)=4 *200). Var. HToken: THandle; PTokenInfo: PTOKENPRIVILEGES; ReturnLen: Cardinal; I: Integer; PrivName: PChar; DisplayName: PChar; NameSize: Cardinal; DisplSize: Cardinal; LangId: Cardinal; Begin. GetMem(pTokenInfo, TokenSize); If not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, HToken) then ShowMessage('OpenProcessToken error'); If not GetTokenInformation(hToken, TokenPrivileges, pTokenInfo, TokenSize, ReturnLen) then. ShowMessage('GetTokenInformation error'); GetMem(PrivName, 255); GetMem(DisplayName, 255); For i := 0 to pTokenInfo.PrivilegeCount - 1 do. Begin. DisplSize := 255; NameSize := 255; LookupPrivilegeName(nil, pTokenInfo.Privileges[i].Luid, PrivName, Namesize); LookupPrivilegeDisplayName(nil, PrivName, DisplayName, DisplSize, LangId); ListBox1.Items.Add(PrivName +^I + DisplayName); End; FreeMem(PrivName); FreeMem(DisplayName); FreeMem(pTokenInfo); End;

Показать Choose Domain диалог?

Code: { If you are developing network software for Windows NT, You usually need to ask the user to select a computer or domain. He wants to connect/login. } Const. FOCUSDLG_DOMAINS_ONLY = 1; FOCUSDLG_SERVERS_ONLY = 2; FOCUSDLG_SERVERS_DOMAINS = 3; FOCUSDLG_BROWSE_LOGON_DOMAIN = $00010000; FOCUSDLG_BROWSE_WKSTA_DOMAIN = $00020000; FOCUSDLG_BROWSE_OTHER_DOMAINS = $00040000; FOCUSDLG_BROWSE_TRUSTING_DOMAINS = $00080000; FOCUSDLG_BROWSE_WORKGROUP_DOMAINS = $00100000; FOCUSDLG_BROWSE_ALL_DOMAINS = FOCUSDLG_BROWSE_LOGON_DOMAIN or. FOCUSDLG_BROWSE_WKSTA_DOMAIN or FOCUSDLG_BROWSE_OTHER_DOMAINS or. FOCUSDLG_BROWSE_TRUSTING_DOMAINS or FOCUSDLG_BROWSE_WORKGROUP_DOMAINS; Function SystemFocusDialog(hwndOwner: HWND; dwSelectionFlag: UINT; WszName: PWideChar; dwBufSize: DWORD; var bOKPressed: Boolean; WszHelpFile: PWideChar; dwContextHelpId: DWORD): DWORD; stdcall; External 'ntlanman.dll' Name 'I_SystemFocusDialog'; Function ComputerBrowser(hWndParent: HWND; wCompName: PWideChar; DwBufLen: DWORD): Boolean; Var. DwError: DWORD; Begin. Result := False; DwError := SystemFocusDialog(hWndParent, FOCUSDLG_SERVERS_DOMAINS or. FOCUSDLG_BROWSE_ALL_DOMAINS, WCompName, dwBufLen, Result, nil, 0); If dwError <> NO_ERROR then Exit; End; Procedure TForm1.Button1Click(Sender: TObject); Var. WCompName: array [0..MAX_COMPUTERNAME_LENGTH + 1] of WideChar; Begin. If ComputerBrowser(0, wCompName, MAX_COMPUTERNAME_LENGTH + 1) then. ShowMessage(wCompName). Else. ShowMessage('no computer selected'); End; {***************************} // Show the ServerBrowseDialogA0 Dialog. Type. TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; CchBufSize: DWORD): bool; Stdcall; Function ShowServerDialog(AHandle: THandle): string; Var. ServerBrowseDialogA0: TServerBrowseDialogA0; LANMAN_DLL: DWORD; Buffer: array[0..1024] of char; BLoadLib: Boolean; Begin. LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL'); If LANMAN_DLL = 0 then. Begin. LANMAN_DLL := LoadLibrary('NTLANMAN.DLL'); BLoadLib := True; End; If LANMAN_DLL <> 0 then. Begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0'); DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil); ServerBrowseDialogA0(AHandle, @buffer, 1024); If buffer[0] = '\' then. Begin. Result := buffer; End; If bLoadLib then. FreeLibrary(LANMAN_DLL); End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Label1.Caption := ShowServerDialog(Form1.Handle); End;

Как передвинуть колонку в TDBGrid?

Code: Type. THackAccess = class(TCustomGrid); { THackAccess Is needed because TCustomGrid.MoveColumn is. Protected and you can't access it directly. } // In the implementation-Section: Procedure MoveDBGridColumns(DBGrid: TDBGrid; FromColumn, ToColumn: Integer); Begin. THackAccess(DBGrid).MoveColumn(FromColumn, ToColumn); End; {Example}. Procedure TForm1.Button1Click(Sender: TObject); Begin. MoveDBGridColumns(DBGrid1, 1, 2). End;

Как узнать является ли окно Unicode?

Code: { The IsWindowUnicode function. Determines whether the specified window is a native Unicode window. The character set of a window is determined by the use of the RegisterClass function. If the window class was registered with the ANSI version of RegisterClass (RegisterClassA), The character set of the window is ANSI. If the window class was registered with the Unicode. Version of RegisterClass (RegisterClassW), the character set of the window is Unicode. The system does automatic two-way translation (Unicode to ANSI) for window messages. For example, if an ANSI window message is sent to a window that uses the Unicode character set, The system translates that message into a Unicode message before calling the window procedure. The system calls IsWindowUnicode to determine whether to translate the message. } Procedure TForm1.Button1Click(Sender: TObject); Begin. {determine if the window is a Unicode window}. If (IsWindowUnicode(Form1.Handle)) then. Button1.Caption := 'This window is a Unicode window' Else. Button1.Caption := 'This window is not a Unicode window' End;

Как получить информацию о системе?

Code: { The SYSTEM_INFO structure contains information about the current computer. System. This includes the architecture and type of the processor, the number of. Processors in the system, the page size, and other such information. } Procedure TForm1.Button1Click(Sender: TObject); Var. SysInfo: TSystemInfo; Begin. GetSystemInfo(SysInfo); With ListBox1.Items, SysInfo do. Begin. Add('ProcessorArchitecture:' + IntToStr(wProcessorArchitecture)); Add(FloatToStr(dwPageSize) + ' Kb page size'); Add(Format('Lowest memory address accessible to applications and DLL - %p', [lpMinimumApplicationAddress])); Add(Format('Highest memory address accessible to applications and DLL - %p', [lpMaximumApplicationAddress])); Add('OEMID:' + IntToStr(dwOemId)); Add('ActiveProcessorMask:' + IntToStr(dwActiveProcessorMask)); Add(IntToStr(dwNumberOfProcessors) + ' - number of processors'); Add('ProcessorType:' + IntToStr(dwProcessorType)); Case wProcessorLevel of. 3: Add('Intel 80386 processor level'); 4: Add('Intel 80486 processor level'); 5: Add('Intel Pentium processor level'); End; Add(FloatToStr(dwAllocationGranularity / 1024) + ' Kb - granularity with which virtual memory is allocated'); Add('ProcessorRevision:' + IntToStr(wProcessorRevision)); End; End;

©Drkb::01331.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Проверить приложение на зависание?

Code: // 1. The Documented way. { An application can check if a window is responding to messages by. Sending the WM_NULL message with the SendMessageTimeout function. } Function AppIsResponding(ClassName: string): Boolean; Const. { Specifies the duration, in milliseconds, of the time-out period }. TIMEOUT = 50; Var. Res: DWORD; H: HWND; Begin. H := FindWindow(PChar(ClassName), nil); If h <> 0 then. Result := SendMessageTimeOut(H, WM_NULL, 0, 0, SMTO_NORMAL or SMTO_ABORTIFHUNG, TIMEOUT, Res) <> 0. Else. ShowMessage(Format('%s not found!', [ClassName])); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If AppIsResponding('OpusApp') then. { OpusApp is the Class Name of WINWORD }. ShowMessage('App. responding'); End;

Кто владелец taskbar buttons (NT)?

Code: { In this article, I wish to describe the useful undocumented function. GetTaskmanWindow. The GetTaskmanWindow function returns a handle to. The window that ownes the taskbar buttons. Here is the quoting about taskbar from Microsoft MSDN: "The Microsoft® Windows® interface includes a special application desktop. Toolbar called the taskbar. The taskbar can be used for such tasks as switching between open. Windows and starting new applications...". And "The taskbar includes the Start menu, taskbar buttons, A shortcut menu, and a status area...". Unfortunately, Win32 API doesn't contain documented. Function that can be used for accessing to the. Taskbar so we should again use an undocumented way. Here is the prototype for GetTaskmanWindow: Function GetTaskmanWindow (): HWND; As always, Microsoft doesn't provide us with the exports symbols. In the User32.lib for this function, so we should load them dynamically using the. GetProcAddress and GetModuleHandle functions: } // getaskmanwnd.cpp (Windows NT/2000). // // This example will show you how you can obtain a handle to the. // Windows Taskbar window. // Translated from C to Delphi by Thomas Stutz. // Original Code: // (c)1999 Ashot Oganesyan K, SmartLine, Inc. // mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com. Function TaskmanWindow: HWND; Type. TGetTaskmanWindow = function(): HWND; stdcall; Var. HUser32: THandle; GetTaskmanWindow: TGetTaskmanWindow; Begin. Result := 0; HUser32 := GetModuleHandle('user32.dll'); If (hUser32 > 0) then. Begin. @GetTaskmanWindow := GetProcAddress(hUser32, 'GetTaskmanWindow'); If Assigned(GetTaskmanWindow) then. Begin. Result := GetTaskmanWindow; End; End; End; Procedure ShowTaskmanWindow(bValue: Boolean); Var. HTaskmanWindow: Hwnd; Begin. HTaskmanWindow := TaskmanWindow; If hTaskmanWindow <> 0 then. Begin. ShowWindow(GetParent(hTaskmanWindow), Ord(bValue)); End; End; // Example to Hide the Taskman Window. Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowTaskmanWindow(False); End;

Как проверить папку на shared?

Code: {Following code needs to use ShlObj, ComObj, ActiveX Units}. Function TForm1.IfFolderShared(FullFolderPath: string): Boolean; //Convert TStrRet to string. Function StrRetToString(PIDL: PItemIDList; StrRet: TStrRet; Flag: string = ''): string; Var. P: PChar; Begin. Case StrRet.uType of. STRRET_CSTR: SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr)); STRRET_OFFSET: Begin. P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)]; SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset); End; STRRET_WSTR: If Assigned(StrRet.pOleStr) then. Result := StrRet.pOleStr. Else. Result := ''; End; { This is a hack bug fix to get around Windows Shell Controls returning. Spurious "?"s in date/time detail fields }. If (Length(Result) > 1) and (Result[1] = '?') and (Result[2] in ['0'..'9']) then. Result := StringReplace(Result, '?', '', [rfReplaceAll]); End; //Get Desktop's IShellFolder interface. Function DesktopShellFolder: IShellFolder; Begin. OleCheck(SHGetDesktopFolder(Result)); End; //delete the first ID from IDList. Function NextPIDL(IDList: PItemIDList): PItemIDList; Begin. Result := IDList; Inc(PChar(Result), IDList^.mkid.cb); End; //get the length of IDList. Function GetPIDLSize(IDList: PItemIDList): Integer; Begin. Result := 0; If Assigned(IDList) then. Begin. Result := SizeOf(IDList^.mkid.cb); While IDList^.mkid.cb <> 0 do. Begin. Result := Result + IDList^.mkid.cb; IDList := NextPIDL(IDList); End; End; End; //get ID count from IDList. Function GetItemCount(IDList: PItemIDList): Integer; Begin. Result := 0; While IDList^.mkid.cb <> 0 do. Begin. Inc(Result); IDList := NextPIDL(IDList); End; End; //create an ItemIDList object. Function CreatePIDL(Size: Integer): PItemIDList; Var. Malloc: IMalloc; Begin. OleCheck(SHGetMalloc(Malloc)); Result := Malloc.Alloc(Size); If Assigned(Result) then. FillChar(Result^, Size, 0); End; Function CopyPIDL(IDList: PItemIDList): PItemIDList; Var. Size: Integer; Begin. Size := GetPIDLSize(IDList); Result := CreatePIDL(Size); If Assigned(Result) then. CopyMemory(Result, IDList, Size); End; //get the last ItemID from AbsoluteID. Function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList; Begin. Result := AbsoluteID; While GetItemCount(Result) > 1 do. Result := NextPIDL(Result); Result := CopyPIDL(Result); End; //remove the last ID from IDList. Procedure StripLastID(IDList: PItemIDList); Var. MarkerID: PItemIDList; Begin. MarkerID := IDList; If Assigned(IDList) then. Begin. While IDList.mkid.cb <> 0 do. Begin. MarkerID := IDList; IDList := NextPIDL(IDList); End; MarkerID.mkid.cb := 0; End; End; //if Flag include Element. Function IsElement(Element, Flag: Integer): Boolean; Begin. Result := Element and Flag <> 0; End; Var. P: Pointer; NumChars, Flags: LongWord; ID, NewPIDL, ParentPIDL: PItemIDList; ParentShellFolder: IShellFolder; Begin. Result := False; NumChars := Length(FullFolderPath); P := StringToOleStr(FullFolderPath); //get the folder's full ItemIDList. OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, P, NumChars, NewPIDL, Flags)); If NewPIDL <> nil then. Begin. ParentPIDL := CopyPIDL(NewPIDL); StripLastID(ParentPIDL); //get the folder's parent object's ItemIDList. ID := RelativeFromAbsolute(NewPIDL); //get the folder's relative ItemIDList. //get the folder's parent object's IShellFolder interface. OleCheck(DesktopShellFolder.BindToObject(ParentPIDL, nil, IID_IShellFolder, Pointer(ParentShellFolder))); If ParentShellFolder <> nil then. Begin. Flags := SFGAO_SHARE; //get the folder's attributes. OleCheck(ParentShellFolder.GetAttributesOf(1, ID, Flags)); If IsElement(SFGAO_SHARE, Flags) then Result := True; End; End; End; {How to use the function? The parameter in is the full path of a folder}. Procedure TForm1.Button1Click(Sender: TObject); Begin. If IfFolderShared('C:\My Documents\WinPopup') then ShowMessage('shared'). Else. ShowMessage('not shared'); End;

Проверить запущена ли программа от System account?

Code: Function OnSystemAccount(): Boolean; Const. CnMaxNameLen = 254; Var. SName: string; DwNameLen: DWORD; Begin. DwNameLen := cnMaxNameLen - 1; SetLength(sName, cnMaxNameLen); GetUserName(PChar(sName), dwNameLen); SetLength(sName, dwNameLen); If UpperCase(Trim(sName)) = 'SYSTEM' then Result := True. Else. Result := False; End;

Как проверить запущен ли сервис?

Code: Uses. WinSvc; Function ServiceGetStatus(sMachine, sService: PChar): DWORD; {******************************************} {*** Parameters: ***}. {*** sService: specifies the name of the service to open. {*** sMachine: specifies the name of the target computer. {*** ***} {*** Return Values: ***}. {*** -1 = Error opening service ***}. {*** 1 = SERVICE_STOPPED ***}. {*** 2 = SERVICE_START_PENDING ***}. {*** 3 = SERVICE_STOP_PENDING ***}. {*** 4 = SERVICE_RUNNING ***}. {*** 5 = SERVICE_CONTINUE_PENDING ***}. {*** 6 = SERVICE_PAUSE_PENDING ***}. {*** 7 = SERVICE_PAUSED ***}. {******************************************} Var. SCManHandle, SvcHandle: SC_Handle; SS: TServiceStatus; DwStat: DWORD; Begin. DwStat := 0; // Open service manager handle. SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT); If (SCManHandle > 0) then. Begin. SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS); // if Service installed. If (SvcHandle > 0) then. Begin. // SS structure holds the service status (TServiceStatus); If (QueryServiceStatus(SvcHandle, SS)) then. DwStat := ss.dwCurrentState; CloseServiceHandle(SvcHandle); End; CloseServiceHandle(SCManHandle); End; Result := dwStat; End; Function ServiceRunning(sMachine, sService: PChar): Boolean; Begin. Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService); End; // Check if Eventlog Service is running. Procedure TForm1.Button1Click(Sender: TObject); Begin. If ServiceRunning(nil, 'Eventlog') then. ShowMessage('Eventlog Service Running'). Else. ShowMessage('Eventlog Service not Running'). End; { Windows 2000 and earlier: All processes are granted the SC_MANAGER_CONNECT, SC_MANAGER_ENUMERATE_SERVICE, and SC_MANAGER_QUERY_LOCK_STATUS access rights. Windows XP: Only authenticated users are granted the SC_MANAGER_CONNECT, SC_MANAGER_ENUMERATE_SERVICE, And SC_MANAGER_QUERY_LOCK_STATUS access rights. } { Do not use the service display name (as displayed in the services. Control panel applet.) You must use the real service name, as. Referenced in the registry under. HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services. }

Как получить имена установленных почтовых клиентов?

Code: { Get names of installed Mail-Clients. } Uses. Registry; Function GetInstalledMailClients(AList: TStrings): Boolean; Const. RegClientsRoot = '\SOFTWARE\Clients'; RegClientsMail = '\Mail'; RegClientsOpenCmd = '\shell\open\command'; Var. Reg: TRegistry; Begin. Result := True; Try. AList.Clear; Reg := nil; Reg := TRegistry.Create; Try. With reg do. Begin. CloseKey; RootKey := HKEY_LOCAL_MACHINE; If OpenKeyReadOnly(RegClientsroot + RegClientsMail) then. If HasSubKeys then. GetKeyNames(AList); End; Finally. If Assigned(reg) then reg.Free; End; Except. Result := False; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. GetInstalledMailClients(ListBox1.Items); End;

Управление NT-сервисами.

Code: { The following class TServiceManager can be used to manage your NT-Services. You can do things like start, stop, pause or querying a services status. } // Thanks for this one to Frederik Schaller as well - it's a co-work }. Unit ServiceManager; Interface. Uses. SysUtils, Windows, WinSvc; Type. TServiceManager = class. Private. { Private declarations }. ServiceControlManager: SC_Handle; ServiceHandle: SC_Handle; Protected. Function DoStartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean; Public. { Public declarations }. Function Connect(MachineName: PChar = nil; DatabaseName: PChar = nil; Access: DWORD = SC_MANAGER_ALL_ACCESS): Boolean; // Access may be SC_MANAGER_ALL_ACCESS. Function OpenServiceConnection(ServiceName: PChar): Boolean; Function StartService: Boolean; overload; // Simple start. Function StartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean; Overload; // More complex start. Function StopService: Boolean; Procedure PauseService; Procedure ContinueService; Procedure ShutdownService; Procedure DisableService; Function GetStatus: DWORD; Function ServiceRunning: Boolean; Function ServiceStopped: Boolean; End; Implementation. { TServiceManager }. Function TServiceManager.Connect(MachineName, DatabaseName: PChar; Access: DWORD): Boolean; Begin. Result := False; { open a connection to the windows service manager }. ServiceControlManager := OpenSCManager(MachineName, DatabaseName, Access); Result := (ServiceControlManager <> 0); End; Function TServiceManager.OpenServiceConnection(ServiceName: PChar): Boolean; Begin. Result := False; { open a connetcion to a specific service }. ServiceHandle := OpenService(ServiceControlManager, ServiceName, SERVICE_ALL_ACCESS); Result := (ServiceHandle <> 0); End; Procedure TServiceManager.PauseService; Var. ServiceStatus: TServiceStatus; Begin. { Pause the service: attention not supported by all services }. ControlService(ServiceHandle, SERVICE_CONTROL_PAUSE, ServiceStatus); End; Function TServiceManager.StopService: Boolean; Var. ServiceStatus: TServiceStatus; Begin. { Stop the service }. Result := ControlService(ServiceHandle, SERVICE_CONTROL_STOP, ServiceStatus); End; Procedure TServiceManager.ContinueService; Var. ServiceStatus: TServiceStatus; Begin. { Continue the service after a pause: attention not supported by all services }. ControlService(ServiceHandle, SERVICE_CONTROL_CONTINUE, ServiceStatus); End; Procedure TServiceManager.ShutdownService; Var. ServiceStatus: TServiceStatus; Begin. { Shut service down: attention not supported by all services }. ControlService(ServiceHandle, SERVICE_CONTROL_SHUTDOWN, ServiceStatus); End; Function TServiceManager.StartService: Boolean; Begin. Result := DoStartService(0, ''); End; Function TServiceManager.StartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean; Begin. Result := DoStartService(NumberOfArgument, ServiceArgVectors); End; Function TServiceManager.GetStatus: DWORD; Var. ServiceStatus: TServiceStatus; Begin. { Returns the status of the service. Maybe you want to check this. More than once, so just call this function again. Results may be: SERVICE_STOPPED. SERVICE_START_PENDING. SERVICE_STOP_PENDING. SERVICE_RUNNING. SERVICE_CONTINUE_PENDING. SERVICE_PAUSE_PENDING. SERVICE_PAUSED }. Result := 0; QueryServiceStatus(ServiceHandle, ServiceStatus); Result := ServiceStatus.dwCurrentState; End; Procedure TServiceManager.DisableService; Begin. { Implementation is following... }. End; Function TServiceManager.ServiceRunning: Boolean; Begin. Result := (GetStatus = SERVICE_RUNNING); End; Function TServiceManager.ServiceStopped: Boolean; Begin. Result := (GetStatus = SERVICE_STOPPED); End; Function TServiceManager.DoStartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean; Var. Err: integer; Begin. Result := WinSvc.StartService(ServiceHandle, NumberOfArgument, ServiceArgVectors); End; End.

Как перевести компьютер в Stend-by или Hibernate?

Code: { The SetSuspendState function suspends the system by shutting power down. Depending on the Hibernate parameter, The system either enters a suspend (sleep) state or hibernation. Syntax: } Function SetSuspendState( Hibernate: Boolean, ForceCritical: Boolean, DisableWakeEvent: Boolean); { Parameters: Hibernate: If this parameter is TRUE, the system hibernates. If the parameter is FALSE, the system is suspended. ForceCritical: If this parameter is TRUE, the system suspends operation immediately; If it is FALSE, the system broadcasts a PBT_APMQUERYSUSPEND event to. Each application to request permission to suspend operation. DisableWakeEvent: If this parameter is TRUE, the system disables all wake events. If the parameter is FALSE, any system wake events remain enabled. Windows NT/2000/XP: Included in Windows 2000 and later. Windows 95/98/Me: Included in Windows 98 and later. } Var. _SetSuspendState: function (Hibernate, ForceCritical, DisableWakeEvent: BOOL): BOOL. Stdcall = nil; Function LinkAPI(const module, functionname: string): Pointer; forward; Function SetSuspendState(Hibernate, ForceCritical, DisableWakeEvent: Boolean): Boolean; Begin. If not Assigned(_SetSuspendState) then. @_SetSuspendState := LinkAPI('POWRPROF.dll', 'SetSuspendState'); If Assigned(_SetSuspendState) then. Result := _SetSuspendState(Hibernate, ForceCritical, DisableWakeEvent). Else. Result := False; End; Function LinkAPI(const module, functionname: string): Pointer; Var. HLib: HMODULE; Begin. HLib := GetModulehandle(PChar(module)); If hLib = 0 then. HLib := LoadLibrary(PChar(module)); If hLib <> 0 then. Result := getProcAddress(hLib, PChar(functionname)). Else. Result := nil; End; // Example Call: // Beispielaufruf: Procedure TForm1.Button1Click(Sender: TObject); Begin. SetSuspendState(True, False, False); End;

©Drkb::01700.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. SendMessage(Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 1); End.

©Drkb::01701.

Взято с сайта: http://www.swissdelphicenter.ch.

Как забыть о необходимости разрушать объекты?

Code: Type. ISelfDestroy = interface; //forget about GUID, if you are not using COM. TSelfDestroy = class(TInterfacedObject, ISelfDestroy). Private. FObject: TObject; Public. Constructor Create(AObject: TObject); Destructor Destroy; override; End; Implementation. Constructor TSelfDestroy.Create(AObject: TObject); Begin. FObject := AObject; End; Destructor TSelfDestroy.Destroy; Begin. FreeAndNil(FObject); Inherited; End; // So when you use, just do like this... Procedure TForm1.Button1Click(Sender: TObject); Var. MyObject: TMyObject; SelfDestroy: TSelfDestroy; Begin. MyObject := TMyObject.Create; SelfDestroy := TSelfDestroy.Create(MyObject); // The MyObject will free automatically as soon as TSelfDestroy. // goes out of scope. // Carry on your code here... End;

Как сделать Multi Screen Emulator?

Code: {** Building a multi screen emulator *** I want to present a simple multi-screen emulator written in Delphi. It consists in a little Form placing in the bottom-right corner of the screen, Right above the traybar, which consists of 5 buttons. At the beginning the first button is down; then, when I press another button, A new fresh desktop is opened. In this new desktop I can open other programs. And so on with the other buttons. When I go back to one of the buttons, I will see only the applications opened in that contest without the others. The trick is to make the following steps just before pressing another button: 1)Get the handles of all the visible windows (except for Desktop, Taskbar and the application itself). 2)Hiding all the windows detecting at step 1). After pressing the button we must: 1)Show all the windows whose handles we got when we left. The button itself by pressing another. Of course if a button is pressed for the first time we have no. Handles so we will have a new fresh desktop. I want to retrieve the handles of all the visible windows: The key is a call to the "EnumWindows" procedure. Passing as a parameter a callback function called for example "EnumWindowsProc". This callback function must be of the following type: } Function EnumWindowsProc(hWnd: HWND; lParam: LPARAM): Bool; // The EnumWindows function is of type: BOOL EnumWindows( WNDENUMPROC lpEnumFunc, // pointer to callback function. LPARAM lParam // application-defined value. ); { I will call EnumWindows(@EnumWindowsProc, 0); The "EnumWindows" function loop over all windows (visible or invisible): For each window there is a call to the callback function. "EnumWindowsProc" wich must be implemented. The first param "hWnd" is the handle of the current window. A possible implementation of the "EnumWindowsProc" function may be the inserting. Of every handle in a list. According to our target we must insert in a list the handle of. The following windows: 1)Visible windows //(IsWindowVisible(hwnd) = True). 2)Not my application window. //var processed: DWORD; //GetWindowThreadProcessID( hwnd, @processID ); //processID <> GetCurrentProcessID. 3)Not the taskbar window //hWnd <> FindWindow('Shell_TrayWnd', Nil). 4)Not the desktop window //hWnd <> FindWindow('Progman', Nil). } // This is the code: Unit ProcessView; Interface. Uses. Windows, Dialogs, SysUtils, Classes, ShellAPI, TLHelp32, Forms; Var. HandleList: TStringList; Function EnumWindowsProc(hWnd: HWND; lParam: lParam): Bool; stdcall; Procedure GetProcessList; Implementation. Procedure GetProcessList; Var. I: integer; Begin. HandleList.Clear; EnumWindows(@EnumWindowsProc, 0); End; Function EnumWindowsProc(hWnd: HWND; lParam: lParam): Bool; Var. ProcessID: DWORD; Begin. GetWindowThreadProcessID(hwnd, @processID); If processID <> GetCurrentProcessID then. If (hWnd <> FindWindow('Shell_TrayWnd', nil)) and. (hWnd <> FindWindow('Progman', nil)) then. If IsWindowVisible(hwnd) then. Begin. HandleList.Add(IntToStr(HWnd)); Result := True; End; End; Initialization. HandleList := TStringList.Create; Finalization. HandleList.Free; End.

Как читать REG_MULTI_SZ значение?

Code: Uses. Registry; Procedure ReadREG_MULTI_SZ(const CurrentKey: HKey; const Subkey, ValueName: string; Strings: TStrings); Var. ValueType: DWORD; ValueLen: DWORD; P, buffer: PChar; Key: HKEY; Begin. // Clear TStrings. Strings.Clear; // open the specified key. If RegOpenKeyEx(CurrentKey, PChar(Subkey), 0, KEY_READ, key) = ERROR_SUCCESS then. Begin. // retrieve the type and data for a specified value name. SetLastError(RegQueryValueEx(key, PChar(ValueName), Nil, @valueType, Nil, @valueLen)); If GetLastError = ERROR_SUCCESS then. If valueType = REG_MULTI_SZ then. Begin. GetMem(buffer, valueLen); Try. // receive the value's data (in an array). RegQueryValueEx(key, PChar(ValueName), Nil, Nil, PBYTE(buffer), @valueLen); // Add values to stringlist. P := buffer; While p^ <> #0 do. Begin. Strings.Add(p); Inc(p, lstrlen(p) + 1). End. Finally. FreeMem(buffer). End. End. Else. Raise ERegistryException.Create('Stringlist expected/ String Liste erwartet...'). Else. Raise ERegistryException.Create('Cannot Read MULTI_SZ Value/'+ 'Kann den MULTI_SZ Wert nicht lesen...'); End; End; // Test it: Procedure TForm1.Button1Click(Sender: TObject); Begin. ReadREG_MULTI_SZ(HKEY_CURRENT_USER, 'Software\XYZ', 'Test44', Memo1.Lines); End;

©Drkb::02274.

Code: {******************************************} {2. by Ralph Friedman }. { Question: I want to read out the binary-value "problems" of the path. HKEY_DYN_DATA\Config Manager\Enum\[add the key of a hardware component] to. Detect if a hardware component is troubled and not working right. But I cannot handle the ReadBinaryData-Method of TRegistry correct. Everytime I use it, it always returns "4" as content of the buffer. How do I detect if the content of the binary-key "problems" is. Not "00 00 00 00" but something else like "16 00 00 00" or such? } {Answer: Here's an example of ReadBinaryData }. Procedure TFrmReadBinary.Button1Click(Sender: TObject); Const. CKeyName: string = 'System\Setup'; CValName: string = 'NetcardDlls'; Var. KeyGood: boolean; P: integer; RegKey: TRegistry; TmpStr: string; VSize: integer; Begin. RegKey := TRegistry.Create; Try. RegKey.RootKey := HKEY_LOCAL_MACHINE; KeyGood := regKey.OpenKey(CKeyName, False); If (keyGood) then. Begin. VSize := regKey.GetDataSize(CValName); If (vSize > 0) then. Begin. SetLength(tmpStr, vSize); RegKey.ReadBinaryData(CValName, tmpstr[1], vSize); Repeat. P := Pos(#0, tmpStr); If p <> 0 then. Begin. Delete(tmpStr, p, 1); Insert(#13#10, tmpStr, p); End; Until p = 0; (*StringReplace(tmpStr, #0, #13#10, [rfReplaceAll]); *). ListBox1.Items.Text := tmpStr; End; End; Finally. RegKey.Free; End; End;

©Drkb::02275.

Code: {******************************************} {3. by Michael Winter }. Procedure RaiseWin32Error(Code: Cardinal); Var. Error: EWin32Error; Begin. Error := EWin32Error.CreateResFmt(@SWin32Error, [Code, SysErrorMessage(Code)]); Error.ErrorCode := Code; Raise Error; End; // Write REG_MULTI_SZ. Procedure TForm1.Button1Click(Sender: TObject); Const. Str = 'multiple'#0'strings'#0'in one'#0'registry'#0'value'#0; Var. Reg: TRegistry; Res: Integer; Begin. Reg := TRegistry.Create; Try. Reg.RootKey := HKEY_CURRENT_USER; If not Reg.OpenKey('\Software\Test\RegMultiSzTest', true) then. Raise Exception.Create('Can''t open key'); Res := RegSetValueEx( Reg.CurrentKey, // handle of key to set value for. 'TestValue', // address of value to set. 0, // reserved. REG_MULTI_SZ, // flag for value type. PChar(Str), // address of value data. Length(Str) + 1); // size of value data. If Res <> ERROR_SUCCESS then. RaiseWin32Error(Res); Finally. Reg.Free; End; End; // Read REG_MULTI_SZ. Procedure TForm1.Button2Click(Sender: TObject); Var. Reg: TRegistry; DataType: Cardinal; DataSize: Cardinal; Res: Integer; Str: String; I: Integer; Begin. Reg := TRegistry.Create; Try. Reg.RootKey := HKEY_CURRENT_USER; If not Reg.OpenKeyReadOnly('\Software\Test\RegMultiSzTest') then. Raise Exception.Create('Can''t open key'); DataSize := 0; Res := RegQueryValueEx( Reg.CurrentKey, // handle of key to query. 'TestValue', // address of name of value to query. Nil, // reserved. @DataType, // address of buffer for value type. Nil, // address of data buffer. @DataSize); // address of data buffer size. If Res <> ERROR_SUCCESS then. RaiseWin32Error(Res); If DataType <> REG_MULTI_SZ then. Raise Exception.Create('Wrong data type'); SetLength(Str, DataSize - 1); If DataSize > 1 then begin. Res := RegQueryValueEx( Reg.CurrentKey, // handle of key to query. 'TestValue', // address of name of value to query. Nil, // reserved. @DataType, // address of buffer for value type. PByte(Str), // address of data buffer. @DataSize); // address of data buffer size. If Res <> ERROR_SUCCESS then. RaiseWin32Error(Res); End; For i := Length(Str) downto 1 do. If Str[i] = #0 then. Str[i] := #13; ShowMessage(Str); Finally. Reg.Free; End; End;

©Drkb::02276.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Code: Type. {©Drkb v.3(2007): www.drkb.ru}. TExRegistry = class(TRegistry). Public. Function ReadStrings(const ValueName: String): String; End; Function TExRegistry.ReadStrings(const ValueName: String): String; Var. ValueType : DWORD; ValueLen : DWORD; P, Buffer : PChar; Begin. Result := ''; SetLastError(RegQueryValueEx(CurrentKey, PChar (ValueName), nil, @ValueType, nil, @ValueLen)); If GetLastError = ERROR_SUCCESS then. Begin. If ValueType = REG_MULTI_SZ then. Begin. GetMem(Buffer, ValueLen); Try. RegQueryValueEx(CurrentKey, PChar(ValueName), nil, nil, PBYTE(Buffer), @ValueLen); P := Buffer; While P^ <> #0 do. Begin. If Result <> '' then. Result := Result + sLineBreak; Result := Result + P; Inc(P, lstrlen(P) + 1); End; Finally. FreeMem (Buffer); End; End. Else. Raise ERegistryException.Create ('String list expected'); End. Else. Raise Exception.Create ('Unable read MULTI_SZ value'); End;

Автор: Александр (Rouse_) Багель

Взято из http://forum.sources.ru.

©Drkb::02277.

Содержание.

Обзор компонентов InternetExpress.
Что такое протокол межсетевого взаимодействия IP?
Описание протокола SSH (Secure Shell).
Работа с последовательными портами.
Работа с портами микропроцессора.
Текущий модуль и проект.
Кириллица в параметрах CGI-запроса.
Сессия.
Как синхронизировать время на 2х компьютерах?
Доступ к страницам Tabbednotebook.
Потоки и DLL.
Теория и практика использования RTTI.
Как реализовать обработку информации одновременно несколькими потоками.
Основы 3D математики - Векторные и матричные преобразования.
Алгоритмы сортировки.
Использование указателей на целое.
Как гарантированно сделать backup?
Почему MDI Child форма при закрывании просто минимизируется?
Меню дочерних MDI-форм.
Позиция дочерних MDI-окон.
Настройка монитора.
ODBC соединения.
Установка ODBC.
Конфигурирование ODBC.
Конфигурирование ODBC и псевдонима.
Использование открытых интерфейсов.
Kylix Tutorial. Работа с DBExpress (статья).
Имя класса компонента и модуля.
Язык программирования Дельфи.
Транзакции.
Как получить определённую часть текста из RichEdit?
Наборы рядов.
Команды.
Реализация ADO в Delphi.
Дельфи 2005 - отчёт, как я был на конференции Борланда.
Наборы данных ADO.
Критерии выбора базы данных (статья).
TColor --> String.
String --> TColor.
Команды ADO.
Масштабирование окон приложений, в зависимости от разрешения экрана.
Как скрыть программу от Alt - Tab.
EOleSysError - как бороться?
Unresolved external malloc referenced, Ошибка линкера Kylix 3.
Запуск программы на Kylix.
3d engines для Дельфи.
3D Engines List Delphi.
This list contains 9 rendering engines written in/for Delphi .
Texture-mapping Engines.
Gouraud-shading Engines.
Doom/Wolfenstein Engines.
Разбудить компьютер по сети, Использование Bios Wake-on-Lan.
Набор dialup соединения по умолчанию.
Где взять примеры использования Indy?
Защита данных.
Нужна база данных, работающая без каких-либо драйверов, Без ODBC/BDE/ADO/DAO etc.
Help по синтаксису SQL для MS Access (DAO/ADO/ODBC).
BDE: Несколько SQL-запросов одним махом.
Получить информацию о ВIОSе.
Прочитать boot сектор.
Как стать невидимым в Windows NT (статья)?
Как правильно работать с прозрачными окнами?
Как указать максимальный размер текста для RichEdit Control?
Как рисовать картинки в пунктах меню?
Объект ошибок ADO.
Пишем свой текст в Меню.
Как сделать пункты меню с картинками?
Как поместить маленькие битмапы в TPopUpMenu?
Более быстрый способ добавлять пункты меню.
Как программно заставить выпасть меню?
Как узнать о нажатии non-menu клавиши в момент когда меню показано?
Как поместить TMenuItem справа у формы?
Как читать/писать в I/O порты?
Как прочитать байт из параллельного порта?
Как узнать адрес LPT-порта?
Как программно установить конфигурацию COM-порта в Windows 95?
Как узнать имена установленных в системе COM-портов?
Как узнать, есть ли в приёмном буфере RS232 данные?
Компонент для последовательного устройства (TRS232).
Количество активных потоков и загруженность процессора.
Поддерживает ли процессор технологию 3DNow.
Как узнать состояние модема в Win32?
Как прочитать из модема?
Как определить, нажата ли в данный момент клавиша Shift, Ctrl или Alt?
Соглашения о вызовах.
Как конвертировать виртуальную клавишу в ASCII код?
Симфония на клавиатуре(статья).
Программно нажимаем Print Screen.
Как програмно переключить раскладку клавиатуры?
Как запретить Ctrl-Alt-Del?
Как отловить правый Enter (NumPad)?
Как заставить дополнительную клавиатуру всегда работать в режиме цифр?
Использование модуля ShareMem.
Как отловить изменение раскладки клавиатуры?
Многомерное представление данных (статья).
Как работать с реестром Windows?
Соединение с сервером баз данных.
Как программе удалить саму себя?
Самый продвинутый DBGrid.
Hooks - аспекты реализации.
Подключение к Personal Oracle с помощью BDE.
Проблемы использования компонента TStoredProc.
Дает ли Delphi возможность корректно прервать выполнение SQL-запроса (BDE)?
Как заблокировать функцию вставки записи в компоненте TDBGrid?
Физическое удаление записей в локальных таблицах (BDE).
Access to table disabled because of previous error. Read failure.
Методы компрессии/декомпрессии.
Как использовать базу данных BDE не указывая её имени?
Библиотека реализующая практически все распространённые алгоритмы шифрования и хэширования.
Курсоры в ADO.
Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?
Использование компонентов Decision Support System при генерации отчетов в QuickReport.
Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?
Как нарисовать Bitmap с прозрачностью.
Заполняем Canvas рисунком с рабочего стола, учитывая координаты.
Как преобразовать цвет в оттенки серого.
Програмно меняем Delphi's Tool list?
Как прочитать ROM-BIOS?
Как получить часть GUID?
Как узнать заряженность батарей?
Как предотвратить Shut Down?
Как узнать о переключении сессии в XP?
Как использовать IP Address Control у себя?
Как получить информацию о системе?
Как перевести компьютер в Stend-by или Hibernate?
Как читать REG_MULTI_SZ значение?