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

Write/read a string to/from the serial port.

Code: Function OpenCOMPort: Boolean; Var. DeviceName: array[0..80] of Char; ComFile: THandle; Begin. { First step is to open the communications device for read/write. This is achieved using the Win32 'CreateFile' function. If it fails, the function returns false. } StrPCopy(DeviceName, 'COM1:'); ComFile := CreateFile(DeviceName, GENERIC_READ or GENERIC_WRITE, 0, Nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); If ComFile = INVALID_HANDLE_VALUE then. Result := False. Else. Result := True; End; Function SetupCOMPort: Boolean; Const. RxBufferSize = 256; TxBufferSize = 256; Var. DCB: TDCB; Config: string; CommTimeouts: TCommTimeouts; Begin. { We assume that the setup to configure the setup works fine. Otherwise the function returns false. } Result := True; If not SetupComm(ComFile, RxBufferSize, TxBufferSize) then. Result := False; If not GetCommState(ComFile, DCB) then. Result := False; Config := 'baud=9600 parity=n data=8 stop=1'; If not BuildCommDCB(@Config[1], DCB) then. Result := False; If not SetCommState(ComFile, DCB) then. Result := False; With CommTimeouts do. Begin. ReadIntervalTimeout := 0; ReadTotalTimeoutMultiplier := 0; ReadTotalTimeoutConstant := 1000; WriteTotalTimeoutMultiplier := 0; WriteTotalTimeoutConstant := 1000; End; If not SetCommTimeouts(ComFile, CommTimeouts) then. Result := False; End; { The following is an example of using the 'WriteFile' function. To write data to the serial port. } Procedure SendText(s: string); Var. BytesWritten: DWORD; Begin. { Add a word-wrap (#13 + #10) to the string. } S := s + #13 + #10; WriteFile(ComFile, s[1], Length(s), BytesWritten, nil); End; { The following is an example of using the 'ReadFile' function to read. Data from the serial port. } Procedure ReadText: string; Var. D: array[1..80] of Char; S: string; BytesRead, i: Integer; Begin. Result := ''; If not ReadFile(ComFile, d, SizeOf(d), BytesRead, nil) then. Begin. { Raise an exception }. End; S := ''; For i := 1 to BytesRead do s := s + d[I]; Result := s; End; Procedure CloseCOMPort; Begin. // finally close the COM Port! CloseHandle(ComFile); End;

©Drkb::01353.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Передача параметров.

Методы GET и POST.

Существует по крайней мере два метода передачи параметров CGI-программе.

Чтобы определить, каким именно методом CGI-программе переданы параметры, достаточно в вашей программе проверить переменную среды REQUEST_METHOD.

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

Code: Function getvar(varname:string):string; {$IFDEF LINUX}. Begin. Result:=getenv(PChar(varname)); End; {$ELSE}. Var. Buffer:array[0..1024] of char; Size:integer; Begin. Size:=GetEnvironmentVariable(PChar(varname),buffer,sizeof(buffer)); If size=0 then getvar:='' else getvar:=String(buffer); End; {$ENDIF}.

Переадресация.

Заголовок HTTP-ответа.

Мы уже знаем, что CGI-программа отсылает серверу заголовок, не отображаемый браузером:

WriteLn('Content-Type: text/html');

WriteLn('');

Вид заголовка для переадресации.

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

Для переадресации достаточно вывести заголовок в следующем виде:

WriteLn('Location: redirection.htm');

WriteLn('');

Кроме того, ваш сервер автоматически добавляет в этот заголовок еще и свои собственные сообщения.

Допустим, вы запрашиваете в браузере URL http://yahoo.com. В этом случае вы получите от сервера следующий ответ:

HTTP/1.0 302 Found.

Location: http://www.yahoo.com.

Получив такой заголовок, браузер перезапрашивает у сервера новый URL http://www.yahoo.com, и в ответ получает следующее:

HTTP/1.0 200 OK.

Content-Length: 9332.

Expires: Wed, 18 Mar 1998 08:00:03 GMT.

Content-Type: text/html.

<html><head><title>Yahoo!</title>

<img width=460 height=59 border=0 usemap="#top3" ismap.

Src="http://us.yimg.com/i/main32.gif" alt="Yahoo!"></a>

<br>

<tr>

...

Таким образом происходит просто переадресация на другую страницу!

И последнее замечание: вам не нужно заботиться самим о выводе строк типа "HTTP/1.0...", и "Content-Length: ...", поскольку это делает автоматически сам сервер.

Введение.

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

Абстракция от оборудования и низкоуровневых протоколов вводится в ядра операционных систем в виде библиотек API (Application Program Interface). Однако современные тенденции приводят к необходимости абстрагирования и от самих операционных систем, что позволяет переносить программы с одной операционной системы на другую путем простой перекомпиляции (транслируемые программы, в основном, вообще не требуют никаких действий по переносу).

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

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

В Delphi используется очень мощная и сложная библиотека VCL (Visual Components Library), которая помимо непосредственных абстракций вводит также и множество своих функциональных классов. В этой библиотеке находятся компоненты для визуального отображения информации, работы с базами данных, с системными объектами, компоненты для работы с Internet-протоколами, классы для написания своих COM-объектов и многое другое. Модули библиотеки подключаются к компиляции по мере необходимости, однако базовый размер простейшего диалогового проекта с одной формой превышает 300кБ (со статически скомпонованной библиотекой). И такой размер во многих случаях может оказаться слишком большим, особенно если программа не требует большой функциональности в интерфейсе.

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

Данная статья посвящена проблеме создания и использования компактной объектно-ориентированной библиотеки, которая бы облегчила построение небольших и эффективных программ на основе Win32 API.

Существующие решения.

Автору известны две объектно-ориентированные библиотеки, которые можно рассматривать как альтернативу библиотеке VCL при написании компактных программ. Это библиотеки классов XCL и ACL. Обе библиотеки бесплатны и поставляются в исходных кодах.

Библиотека ACL (API control library).

Автор: Александр Боковиков, Екатеринбург, Россия.

Страничка: http://a-press.parad.ru/pc/bokovikov/delphi/acl/acl.zip.

E-Mail: abb@adx.ru.

Классы: TFont, TFonts, TControl, TWinControl, TStdControl, TLabel, TEdit, TListBox, TButton, TCheckBox, TComboBox, TGroupBox, TProgressBar, TKeyboard.

Библиотека XCL (Extreme class library).

Автор: Vladimir Kladov (Mr.Bonanzas).

Страничка: http://xcl.cjb.net.

E-Mail: bonanzas@xcl.cjb.net.

Классы: XForm, XApplet, XCanvas, XPen, XBrush, XFont, ZDDB, ZHiBmp, ZDIBitmap, ZBitmap, ZIcon, ZGifDecoder, ZGif, ZJpeg, XLabel, XButton, XBevel, XPanel, XSplitPanel, XStatus, XGrep, XGroup, XCheckBox, XRadioBox, XPaint, XScroller, XScrollBox, XScrollBoxEx, XEdit, XNumEdit, XCombo, XGrid, XListView, XMultiList, XNotebook, XTabs, XTabbedNotebook, XCalendar, XGauge, XGaugePercents, XHysto, XHystoEx, XImageList, XImgButton, XTooltip, XCustomForm, XDsgnForm, XDsgnNonvisual, CLabel, CPaint, CButton, CEdit, CMemo, CCheckBox, CRadioBox, CListBox, CComboBox, ZList, ZMenu, ZPopup, ZMainMenu, ZPopupMenu, ZTimer, ZStrings, ZStringList, ZIniFile, ZThread, ZQueue, ZFileChange, ZDirChange, ZOpenSaveDialog, ZOpenDirDialog, ZTree, ZDirList, ZDirListEx, ZRegistry, ZStream, ZFileStream, ZMemoryStream, XStrUtils.pas, XDateUtils.pas, XFileUtils.pas, XWindowUtils, XPrintUtils, XShellLinks.pas, XJustOne.pas, XJustOneNotify.pas, XPascalUnit.pas, XSysIcons.pas, XCanvasObjectsManager, XRotateFonts, XFocusPainter, XFormsStdMouseEvents, XFormsStdKeyEvents, XFormAutoSizer, XAligner, XControlAutoPlacer, XMfcAntiFlicker, XSplitSizer, XResizeAntiFlicker, XCaretShower, XEditMouseSelect, XEditClipboard, XEditUndo, XListMouseSel, XListKeySel, XListEdit, ZNamedTags, XBtnRepeats, XBufLabels, XBackgrounds, XWndDynHandlers.

Как видно из списка приведенных для каждой библиотеки классов, эти библиотеки предендуют скорее не на помощь при написании программ с использованием Win32 API, а пытаются создать более высокий уровень абстракции чем API, по крайней мере в графической части (особенно это относится к XCL). Более того, иерархия и перечень объектов совпадают с соответствующими структурами в библиотеке VCL, что скорее всего связано с желанием авторов обеспечить логическую совместимость с VCL при построении программ на основе этих библиотек.

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

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

· Несмотря на сравнительно малый размер получаемых программ, размер программ написанных с использованием только Win32 API был бы меньше.

· Помимо изучения Win32 необходимо изучение структуры классов, предлагаемых в этих библиотеках.

· Библиотека XCL не поддерживает механизм message-процедур.

· Архитектура этих библиотек, по мнению автора, является весьма громоздкой. Структуры и классы данных библиотек аналогичны структурам VCL, что приводит к неэффективности программ (ведь мы стараемся написать компактную программу, не так ли ?).

· Использование библиотеки ACL невозможно совместно с библиотекой VCL.

· Запутанность и большой размер классов наряду с "самодокументированным" кодом (то есть отсутствием файлов помощи) затрудняют изучение библиотек.

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

Принципы построения API-библиотеки.

Стандартным видом API-программирования является структурное программирование. Примеры такого программирования на Win32 API есть практически в любой книжке по Borland Pascal, Borland C++, Microsoft Visual C++ и другим системам разработки. Множество примеров API-программирования на С содержится в поставке Microsoft Visual C++.

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

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

Программирование может быть еще более облегчено, есть возпользоваться механизмом message-процедур языка Object Pascal. Вызов этих процедур полностью лежит на компиляторе и корневом объекте TObject и включает в себя методы Dispatch, DefaultHandler, а также все методы, объявленные с директивой message. Такое решениее позволит полностью отказаться от громоздкого оператора case в оконной функции.

Учитывая все вышеперечисленное автором была создана компактная библиотека оконных классов WinLite. Эта библиотека является минимальной, она не вводит более высоких уровней абстракции чем существуют в Win32 API - она только облегчает работу, переводом программирования в объектно-ориентированное русло. Размер библиотеки очень небольшой и вся она помещается в один модуль. Библиотека реализует базовый класс TLiteFrame и построенные на основе него оконные классы:

· TLiteWindow - класс окна, с возможностью subсlаss'инга;

· TLiteDialog - класс немодального диалога;

· TLiteDialogBox - класс модального диалога.

Библиотека может быть использована совместно с VCL. На первый взгляд, это возможность является абсурдной и ненужной, так как об экономии размера в этом случае не может быть и речи. Однако, иногда бывают моменты, когда реализация специфических оконных элементов на основе объектов TWinControl или TCustomControl может быть затруднена или неэффективна из-за их сложности и неочевидного поведения. В этом случае, можно реализовать такой элемент на базе класса TLiteWindow - он будет вести себя стандартным образом, как и полагается вести себя стандартному оконному элементу Win32.

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

Практический совет: при API-программировании программист должен сам следить за корректным освобождением многочисленных ресурсов, которые занимает программа во время выполнения. Поэтому, для облегчения этой задачи используйте какую-либо контролирующую утилиту, например MemProof или Numega BoundsChecker. Корректное освобождение занятых ресурсов крайне необходимо !

К тому же, прежде чем вы решите работать над своим проектом в русле Win32 API, подумайте, а зачем вам это нужно? В подавляющем числе случаев размер программы не имеет никакого значения. Я не хочу сказать, что API-программирование сложнее чем VCL-программирование. Во многих случаях легче изучить и написать 10 вызовов API с кучей аргументов и понимать, что происходит, чем написать 1 вызов простой, на первый взгляд, VCL-инструкции и потом долго исследовать дебри VCL в поисках ответа. Просто API-программирование - это другая культура, к которой вы, возможно, не привыкли. И первоначальная работа может вызвать у вас сильное разочарование. API-программирование требует дотошности, кропотливости и внимательного изучения документации.

Те же, кто отважился программировать на API, наряду с библиотекой WinLite могут совместно использовать невизуальные классы как из состава VCL (модули SysUtils, Classes), так и многие сторонние - естественно, что размер вашей программы при этом увеличится.

· Невизуальные классы библиотеки ACL - http://a-press.parad.ru/pc/bokovikov/delphi/acl/acl.zip

· Невизуальные классы библиотеки XCL - http://xcl.cjb.net

· JEDI Code Library - http://www.delphi-jedi.com

· Системные компоненты на Torry - www.torry.ru

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

Библиотека WinLight.

Code: // WinLite, библиотека классов и функций для работы с Win32 API. // (c) Николай Мазуркин, 1999-2000. // _____________________________________________________________________________ // Оконные классы. //////////////////////////////////////////////////////////////////////////////// Unit WinLite; Interface. Uses Windows, Messages; Инициализационные структуры. Объявление структур, которые используются для формирования параметров вновь создаваемых окон и диалогов соответственно. //////////////////////////////////////////////////////////////////////////////// // Параметры для создания окна. //////////////////////////////////////////////////////////////////////////////// Type. TWindowParams = record. Caption : PChar; Style : DWord; ExStyle : DWord; X : Integer; Y : Integer; Width : Integer; Height : Integer; WndParent : THandle; WndMenu : THandle; Param : Pointer; WindowClass : TWndClass; End; //////////////////////////////////////////////////////////////////////////////// // Параметры для создания диалога. //////////////////////////////////////////////////////////////////////////////// Type. TDialogParams = record. Template : PChar; WndParent : THandle; End; Декларация базового класса TLiteFrame. Базовый класс для окон и диалогов. Инкапсулирует в себе дескриптор окна и объявляет общую оконную процедуру. Реализует механизм message-процедур. //////////////////////////////////////////////////////////////////////////////// // TLiteFrame. // _____________________________________________________________________________ // Базовый класс для объектов TLiteWindow, TLiteDialog, TLiteDialogBox. //////////////////////////////////////////////////////////////////////////////// Type. TLiteFrame = class(TObject). Private. FWndCallback: Pointer; FWndHandle : THandle; FWndParent : THandle; Function WindowCallback(hWnd: HWnd; Msg, WParam, LParam:Longint):Longint; stdcall; Protected. Procedure WindowProcedure(var Msg: TMessage); virtual; Public. Property WndHandle: THandle read FWndHandle; Property WndCallback: Pointer read FWndCallback; Public. Constructor Create(AWndParent: THandle); virtual; Destructor Destroy; override; End; Декларация оконного класса TLiteWindow. Создание уникального класса окна и создание окна. Возможность субклассинга стороннего окна. //////////////////////////////////////////////////////////////////////////////// // TLiteWindow. // _____________________________________________________________________________ // Оконный класс. //////////////////////////////////////////////////////////////////////////////// Type. TLiteWindow = class(TLiteFrame). Private. FWndParams : TWindowParams; FWndSubclass: Pointer; Protected. Procedure CreateWindowParams(var WindowParams: TWindowParams); virtual; Public. Procedure DefaultHandler(var Msg); override; Constructor Create(AWndParent: THandle); override; Constructor CreateSubclassed(AWnd: THandle); virtual; Destructor Destroy; override; End; Декларация диалогового класса TLiteDialog. Загрузка шаблона диалога и создание диалога. //////////////////////////////////////////////////////////////////////////////// // TLiteDialog. // _____________________________________________________________________________ // Диалоговый класс. //////////////////////////////////////////////////////////////////////////////// Type. TLiteDialog = class(TLiteFrame). Private. FDlgParams : TDialogParams; Protected. Procedure CreateDialogParams(var DialogParams: TDialogParams); virtual; Public. Procedure DefaultHandler(var Msg); override; Constructor Create(AWndParent: THandle); override; Destructor Destroy; override; End; Декларация модального диалогового класса TLiteDialogBox. Загрузка шаблона диалога и создание диалога. Модальный показ диалога. //////////////////////////////////////////////////////////////////////////////// // TLiteDialogBox. // _____________________________________________________________________________ // Модальный диалоговый класс. //////////////////////////////////////////////////////////////////////////////// Type. TLiteDialogBox = class(TLiteFrame). Private. FDlgParams : TDialogParams; Protected. Procedure CreateDialogParams(var DialogParams: TDialogParams); virtual; Public. Procedure DefaultHandler(var Msg); override; Public. Function ShowModal: Integer; End; Реализация базового класса TLiteFrame. Implementation. //////////////////////////////////////////////////////////////////////////////// // TLiteFrame. // _____________________________________________________________________________ // Инициализация / финализация. //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // Конструктор. //////////////////////////////////////////////////////////////////////////////// Constructor TLiteFrame.Create(AWndParent: THandle); Begin. Inherited Create; // Запоминаем дескриптор родительского окна. FWndParent := AWndParent; // Создаем место под блок обратного вызова. FWndCallback := VirtualAlloc(nil,12,MEM_RESERVE or MEM_COMMIT,PAGE_EXECUTE_READWRITE); // Формируем блок обратного вызова. Asm. Mov EAX, Self. Mov ECX, [EAX].TLiteFrame.FWndCallback. Mov word ptr [ECX+0], $6858 // pop EAX. Mov dword ptr [ECX+2], EAX // push _Self_ Mov word ptr [ECX+6], $E950 // push EAX. Mov EAX, OFFSET(TLiteFrame.WindowCallback). Sub EAX, ECX. Sub EAX, 12. Mov dword ptr [ECX+8], EAX // jmp TLiteFrame.WindowCallback. End; End; //////////////////////////////////////////////////////////////////////////////// // Деструктор. //////////////////////////////////////////////////////////////////////////////// Destructor TLiteFrame.Destroy; Begin. // Уничтожаем структуру блока обратного вызова. VirtualFree(FWndCallback, 0, MEM_RELEASE); // Уничтожение по умолчанию. Inherited; End; //////////////////////////////////////////////////////////////////////////////// // TLiteFrame. // _____________________________________________________________________________ // Функции обработки сообщений. //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // Функция обратного вызова для получения оконных сообщений. //////////////////////////////////////////////////////////////////////////////// Function TLiteFrame.WindowCallback(hWnd: HWnd; Msg, WParam, LParam: Integer): Longint; Var. WindowMsg : TMessage; Begin. // Запоминаем дескриптор окна, если это первый вызов оконной процедуры. If FWndHandle = 0 then FWndHandle := hWnd; // Формируем сообщение. WindowMsg.Msg := Msg; WindowMsg.WParam := WParam; WindowMsg.LParam := LParam; // Обрабатываем его. WindowProcedure(WindowMsg); // Возвращаем результат обратно системе. Result := WindowMsg.Result; End; //////////////////////////////////////////////////////////////////////////////// // Виртуальная функция для обработки оконных сообщений. //////////////////////////////////////////////////////////////////////////////// Procedure TLiteFrame.WindowProcedure(var Msg: TMessage); Begin. // Распределяем сообщения по обработчикам. Dispatch(Msg); End; Реализация оконного класса TLiteWindow. //////////////////////////////////////////////////////////////////////////////// // TLiteWindow. // _____________________________________________________________________________ // Инициализация / финализация. //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // Конструктор. //////////////////////////////////////////////////////////////////////////////// Constructor TLiteWindow.Create(AWndParent: THandle); Begin. Inherited; // Формируем параметры окна. CreateWindowParams(FWndParams); // Регистрируем класс окна. RegisterClass(FWndParams.WindowClass); // Создаем окно. With FWndParams do. CreateWindowEx(ExStyle, WindowClass.lpszClassName, Caption, Style, X, Y, Width, Height, WndParent, WndMenu, hInstance, Param. ); End; //////////////////////////////////////////////////////////////////////////////// // Конструктор элемента с субклассингом. //////////////////////////////////////////////////////////////////////////////// Constructor TLiteWindow.CreateSubclassed(AWnd: THandle); Begin. Inherited Create(GetParent(AWnd)); // Сохраняем оконную функцию. FWndSubclass := Pointer(GetWindowLong(AWnd, GWL_WNDPROC)); // Сохраняем дескриптор окна. FWndHandle := AWnd; // Устанавливаем свою оконную функцию. SetWindowLong(FWndHandle, GWL_WNDPROC, DWord(WndCallback)); End; //////////////////////////////////////////////////////////////////////////////// // Деструктор. //////////////////////////////////////////////////////////////////////////////// Destructor TLiteWindow.Destroy; Begin. // Наш объект - объект субклассиннга ? If FWndSubclass = nil then. Begin. // Уничтожаем класс окна. UnregisterClass(FWndParams.WindowClass.lpszClassName, hInstance); // Уничтожаем окно. If IsWindow(FWndHandle) then DestroyWindow(FWndHandle); End. Else. // Восстанавливаем старую оконную функцию. SetWindowLong(FWndHandle, GWL_WNDPROC, DWord(FWndSubclass)); // Уничтожение по умолчанию. Inherited; End; //////////////////////////////////////////////////////////////////////////////// // Формирование параметров окна по умолчанию. //////////////////////////////////////////////////////////////////////////////// Procedure TLiteWindow.CreateWindowParams(var WindowParams: TWindowParams); Var. WndClassName : string; Begin. // Формируем имя класса. Str(DWord(Self), WndClassName); WndClassName := ClassName+':'+WndClassName; // Заполняем информацию о классе окна. With FWndParams.WindowClass do. Begin. Style := CS_DBLCLKS; LpfnWndProc := WndCallback; CbClsExtra := 0; CbWndExtra := 0; LpszClassName := PChar(WndClassName); HInstance := hInstance; HIcon := LoadIcon(0, IDI_APPLICATION); HCursor := LoadCursor(0, IDC_ARROW); HbrBackground := COLOR_BTNFACE + 1; LpszMenuName := ''; End; // Заполняем информацию об окне. With FWndParams do. Begin. WndParent := FWndParent; Caption := 'Lite Window'; Style := WS_OVERLAPPEDWINDOW or WS_VISIBLE; ExStyle := 0; X := Integer(CW_USEDEFAULT); Y := Integer(CW_USEDEFAULT); Width := Integer(CW_USEDEFAULT); Height := Integer(CW_USEDEFAULT); WndMenu := 0; Param := nil; End; End; //////////////////////////////////////////////////////////////////////////////// // TLiteWindow. // _____________________________________________________________________________ // Функции обработки сообщений. //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // Обработчик сообщений по умолчанию. //////////////////////////////////////////////////////////////////////////////// Procedure TLiteWindow.DefaultHandler(var Msg); Begin. // Наш объект - объект субклассиннга ? If FWndSubclass = nil then. // Вызываем системную функцию обработки сообщений. With TMessage(Msg) do. Result := DefWindowProc(FWndHandle, Msg, WParam, LParam). Else. // Вызываем старую оконную функцию обработки сообщений. With TMessage(Msg) do. Result := CallWindowProc(FWndSubclass, FWndHandle, Msg, WParam, LParam); End; Реализация диалогового класса TLiteDialog. //////////////////////////////////////////////////////////////////////////////// // TLiteDialog. // _____________________________________________________________________________ // Инициализация / финализация. //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // Конструктор. //////////////////////////////////////////////////////////////////////////////// Constructor TLiteDialog.Create(AWndParent: THandle); Begin. Inherited; // Формируем параметры диалога. CreateDialogParams(FDlgParams); // Создаем диалог. With FDlgParams do. CreateDialogParam(hInstance, Template, WndParent, WndCallback, 0); End; //////////////////////////////////////////////////////////////////////////////// // Деструктор. //////////////////////////////////////////////////////////////////////////////// Destructor TLiteDialog.Destroy; Begin. // Уничтожаем диалог. If IsWindow(FWndHandle) then DestroyWindow(FWndHandle); // Уничтожение по умолчанию. Inherited; End; //////////////////////////////////////////////////////////////////////////////// // Формирование параметров диалога по умолчанию. //////////////////////////////////////////////////////////////////////////////// Procedure TLiteDialog.CreateDialogParams(var DialogParams: TDialogParams); Begin. DialogParams.WndParent := FWndParent; DialogParams.Template := ''; End; //////////////////////////////////////////////////////////////////////////////// // Обработка сообщений по умолчанию. //////////////////////////////////////////////////////////////////////////////// Procedure TLiteDialog.DefaultHandler(var Msg); Begin. // Возвращаемые значения по умолчанию. With TMessage(Msg) do. If Msg = WM_INITDIALOG then Result := 1. Else Result := 0; End; Реализация модального диалогового класса TLiteDialogBox. //////////////////////////////////////////////////////////////////////////////// // TLiteDialogBox. // _____________________________________________________________________________ // Инициализация / финализация. //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // Формирование параметров диалога по умолчанию. //////////////////////////////////////////////////////////////////////////////// Procedure TLiteDialogBox.CreateDialogParams(var DialogParams: TDialogParams); Begin. DialogParams.WndParent := FWndParent; DialogParams.Template := ''; End; //////////////////////////////////////////////////////////////////////////////// // Активизация модального диалога. //////////////////////////////////////////////////////////////////////////////// Function TLiteDialogBox.ShowModal: Integer; Begin. // Формируем параметры диалога. CreateDialogParams(FDlgParams); // Показываем диалог. With FDlgParams do. Result := DialogBoxParam(hInstance, Template, WndParent, WndCallback, 0); End; //////////////////////////////////////////////////////////////////////////////// // Обработка сообщений по умолчанию. //////////////////////////////////////////////////////////////////////////////// Procedure TLiteDialogBox.DefaultHandler(var Msg); Begin. // Возвращаемые значения по умолчанию. With TMessage(Msg) do. If Msg = WM_INITDIALOG then Result := 1. Else Result := 0; End; End.

Вывод изображений.

Заголовок HTTP-ответа для HTML-страниц.

Мы уже знаем, что для сообщения браузеру, что передаваемый документ является HTML-документом, CGI-программа выводит специальный заголовок, не отображаемый браузером:

WriteLn('Content-Type: text/html');

WriteLn('');

HTTP-заголовок для изображений.

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

WriteLn('Content-Type: image/gif');

WriteLn('');

Таким образом мы сообщаем браузеру, что далее будет следовать именно изображение...

Передача двоичных данных.

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

Я написал две процедуры: первая выводит поток TSTREAM в STDOUTPUT, а вторая выводит двоичный файл в выходной поток:

Code: // Процедура вывода потока в STDOUTPUT. // Попробуйте самостоятельно переделать ее для Kylix... Procedure WriteStream(stream:TStream); Var. OutStream:THandleStream; Begin. Flush(output); // для передачи заголовка мы используем обычный WRITELN... // здесь используется код из программы. // DCOUNTER for Delphi 3 by Dave Wedwick (dwedwick@bigfoot.com). OutputStream:=THandleStream.Create(GetStdHandle(STD_OUTPUT_HANDLE)); Stream.SaveToStream(OutputStream); OutputStream.Free; End; // Процедура для передачи двоичного файла. Procedure WriteFile(FileName:string); Var. S:TFileStream; Begin. S:=TFileStream.Create(FileName,fmOpenRead); WriteStream(s); End;

Защита паролем.

Статус в HTTP-заголовке.

В дополнение к строкам заголовка, которые формирует CGI-программа, сервер выводит дополнительную строку, в которой сообщает о статусе обработки полученного запроса. Например, если запрос обработан успешно, сервер выдает следующую строку в заголовке:

HTTP/1.0 200 OK.

Запрос на авторизацию.

Если вы попробуете запустить без изменений мой "web browser" (см. страницу delphi), то вы увидите, что полученный HTTP заголовок несколько отличается от обычного:

HTTP/1.0 401 Unauthorized.

Content-type: text/html.

WWW-Authenticate: Basic realm="/MyRealm".

<html><head><title>401 Unauthorized</title></head><body>

<h1>Для доступа к этой странице требуется пароль!</h1>

</body></html>

Здесь сервер отсылает предупреждение 401 Unauthorized для того, чтобы ваш браузер знал, что он обратился к защищенной странице. Тем самым, сервер предлагает вам ввести пароль и логин в строке уточнения (realm= "/MyRealm"). Если вы предоставите серверу действительный логин и пароль, то сервер откроет доступ к данной странице. В противном случае браузер будет получать вместо нужной страницы предупреждение с кодом 401.

Формируем запрос на авторизацию.

Теперь мы знаем все, что нужно, чтобы наша CGI-программа могла запросить от пользователя пароль для доступа:

Code: Program CheckPWD; {$apptype console}. Begin. WriteLn('HTTP/1.0 401 Unauthorized'); WriteLn('Content-type: text/html'); WriteLn('WWW-Authenticate: Basic realm="/Check"'); WriteLn; WriteLn('Для доступа к этой странице требуется пароль!'); End;

Куки (Cookies).

Введение.

Давайте вспомним, каким образом мы можем передавать CGI-программе параметры.

При использовании метода GET параметры передаются в строке URL.

При использовании метода POST параметры передаются отдельно и не видны пользователю.

(отметим также, что в Internet Explorer 3 есть ошибка, из-за которой он ТЕРЯЕТ параметры при нажатии кнопки "Обновить").

Таким образом, нам не хватает возможности хранить информацию о передаваемых параметрах.

Что такое Cookie ?

"Cookie" - это небольшая порция информации, которая сохраняется на компьютере пользователя и привязана к конкретному URL. Когда браузер обращается к данному URL, он передает на удаленный сервер этот блок информации. В результате на сервере будет сформирована строка окружения HTTP_COOKIE, в которой содержится список всех cookies, которые относятся к данному URL.

Перменная окружения HTTP_COOKIE будет содержать пары имен/значений параметров, разделенных символом ";" в следующем виде:

Имя1=значение1;имя2=значение;...

Таким образом мы можем задавать сразу несколько параметров в одном cookie для данного URL.

Как создать Cookies ?

Давайте разберемся, как это делается! Для создания куков достаточно использовать HTTP-заголовок. Вспомним, каким образом задается тип передаваемого документа в заголовке:

Content-type: text/html.

Точно таким же образом в заголовке задаются и cookie! Просто добавляем еще одну строку:

Content-type: text/html.

Set-Cookie: Name=Value.

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

Пример использования Cookies.

По просьбам читателей я сделал программу Cook, демонстрирующую, как использовать cookies для авторизации пользователя.

В архиве COOK.ZIP находится самая последняя версия моего модуля CGI и модуль Base64.

Работа с Базами Данных.

Как это делается ?

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

Поскольку CGI-программа запускается и выполняется на сервере, то она ДОЛЖНА обязательно завершать свою работу (и чем быстрее - тем лучше) для того, чтобы сервер и браузер пользователя считали, что запрос завершен... При каждом новом обращении к CGI происходит новый произвольный запрос к базе данных.

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

В качестве рабочего примера обработки базы данных из CGI я предлагаю программу ABook. Эта программа использует ODBC-драйвер для работы с базой данных MS Access. При каждом обращении программа открывает базу, обрабатывает запрос, и закрывает базу...

Хотя я и не тестировал эту программу на больших базах данных, но хочу заметить, что в любом случае открытие базы данных MS Access с помощью ODBC производится несравненно быстрее, чем при использовании BDE!

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

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

Частые Вопросы и Ответы.

1) Настройка CGI для IIS.

Запустите программу.

Пуск/Программы/Мiсrоsоft Internet Sеrvеr/Служба Управления.

Кликните два раза на службе WWW, и выберите закладку "Каталоги":

Каталог Алиас Адрес Ошибка.

C:\InetPub\wwwroot <базовый каталог>

C:\InetPub\scripts /Scripts.

C:\WINNT\System32\inetsrv\iisadmin /iisadmin.

Кликните на Добавить, укажите каталог, в котором будут содержаться CGI-программы (например C:\DELPHI).

Алиас виртуального каталога, обычно называемый "/cgi bin", заменяет права доступа для чтения на права доступа для "Выполнения".

Каталог Алиас Адрес Ошибка.

C:\InetPub\wwwroot <базовый каталог>

C:\delphi /cgi-bin.

C:\InetPub\scripts /Scripts.

C:\WINNT\System32\inetsrv\iisadmin /iisadmin.

Теперь нам достаточно поместить наши CGI-программы в каталог C:\DELPHI и обращаться к ним примерно так: http://ваш_сервер/сgi-bin/program.exe.

Если ваша NT выдает ошибку прав доступа на конкретном документе, кликните на этом документе, и проверьте, разрешен ли доступ...

2) Как избавиться от запроса СОХРАНИТЬ/ВЫПОЛНИТЬ при клике на ссылку вида <a href="/cgi-bin/programm.exe"> ?

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

Если вы установили web-сервер на локальный компьютер (localhost), то обращаться к нему нужно следующим образом:

Http://127.0.0.1/cgi-bin/programm.exe.

XLS ---> TStringGrid.

Code: Function Xls_To_StringGrid(AGrid: TStringGrid; AXLSFile: string): Boolean; Const. XlCellTypeLastCell = $0000000B; Var. XLApp, Sheet: OLEVariant; RangeMatrix: Variant; X, y, k, r: Integer; Begin. Screen.Cursor:=crAppStart; Result := False; XLApp := CreateOleObject('Excel.Application'); Try. XLApp.Visible := False; XLApp.Workbooks.Open(AXLSFile); Sheet := XLApp.Workbooks[ExtractFileName(AXLSFile)].WorkSheets[1]; Sheet.Cells.SpecialCells(xlCellTypeLastCell, EmptyParam).Activate; X := XLApp.ActiveCell.Row; Y := XLApp.ActiveCell.Column; AGrid.RowCount := x; AGrid.ColCount := y; RangeMatrix := XLApp.Range['A1', XLApp.Cells.Item[X, Y]].Value; K := 1; Repeat. For r := 1 to y do. AGrid.Cells[(r - 1), (k - 1)] := RangeMatrix[K, R]; Inc(k, 1); AGrid.RowCount := k + 1; Until k > x; RangeMatrix := Unassigned; Finally. If not VarIsEmpty(XLApp) then. Begin. XLApp.Quit; XLAPP := Unassigned; Sheet := Unassigned; Result := True; End; End; Screen.Cursor:=crDefault; End;

Взято из http://forum.sources.ru.

Автор: Kostas.

©Drkb::00617.

XML: будущее гипертекста?

Дмитрий Шипилов, www.submarine.ru.

Спросите у любого среднестатистического пользователя компьютера, на чем базируется Internet, с помощью чего создаются Web-странички и размещаются на них данные. Скорее всего, вам скажут о языке разметки гипертекста HTML. На сегодняшний день это, пожалуй, верно. Однако все большую популярность на глазах приобретает сравнительно новая спецификация - XML. Судя по всему, будущее именно за этим языком. А значит, неплохо было бы познакомиться с ним поближе. Нет проблем!

Как известно, прародителем HTML был язык SGML (Standard Generalized Markup Language - стандартизованный обобщенный язык разметки), созданный в 60-х годах группой разработчиков компании IBM. Целью проекта был перенос документов между различными платформами и системами. Первым результатом деятельности группы, основными разработчиками в которой были Чарльз Голдфарб, Эд Мошер и Рэй Лори, стал язык GML (Generalized Markup Language - обобщенный язык разметки), предназначенный для документов на платформе IBM. Несколько лет спустя GML распространился на другие, помимо IBM, платформы. В 1986 г. язык GML попал под патронаж Международной организации стандартизации ISO и под именем SGML стал официальным стандартом (ISO 8879).

В последнее время сотрудники Internet-консорциума W3C осознали, что язык HTML уже не может разрешить все проблемы и задачи, возлагаемые на него постоянно развивающимся миром Internet. Возникла необходимость в расширяемой (в отличие от статической в HTML) системе разметки, которая позволила бы создавать максимально приближенную к содержанию и тематике документа разметку. Применять SGML в подобном случае непрактично, что и послужило причиной создания XML (eXtensible Markup Language). Язык XML позволяет объединить достоинства SGML и HTML, однако его возможности простираются за пределы Internet и разметки.

Сайт Wall Street Journal Interactive edition создан с помощью XML, затем преобразован в HTML при помощи технологии XSL.

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

Разметка

Прежде всего необходимо понять, что же такое разметка. Рассмотрим небольшой фрагмент текста:

Глава 1. "WWW".

Рождение WWW произошло в Европейской лаборатории физики частиц (CERN - European Laboratory for Particle Physics), находящейся в Швейцарии.

Применяя какой-нибудь язык разметки, мы могли бы описать данный фрагмент следующим образом:

<BOOK> <CHAPTER NUMBER=1> <TITLE>WWW</TITLE> <PARAGRAPH> Рождение WWW произошло в Европейской лаборатории физики частиц (CERN — European Laboratory for Particle Physics), находящейся в Швейцарии. </PARAGRAPH> </CHAPTER> </BOOK>

Парными тегами <BOOK> и </BOOK> мы сообщаем, что описываем книгу (или отрывок из нее). Теги <CHAPTER> и </CHAPTER> заключают внутри себя одну главу книги. Параметр NUMBER сообщает о номере главы. Теги <TITLE> и </TITLE> определяют название главы, и наконец внутри пары тегов <PARAGRAPH> и </PARAGRAPH> мы можем поместить текст абзаца.

Document Type Definition (DTD) и сам XML-документ

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

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

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

Первым и основным компонентом является элемент. Элементы - ключевые структуры XML. Они указываются в разметке с помощью тегов, логически определяющих структуру документа - <P>…</P>, <BR>, <H1>…</H1> и т. д. Все другие компоненты лишь дополняют и уточняют информацию об элементах.

Атрибуты дают более конкретную информацию. В HTML, атрибуты чаще всего указывали, каким образом следует отобразить данный элемент. В XML же практически не используются атрибуты, описывающие форматирование документа - для этого применяются таблицы стилей, определяющие, как необходимо отобразить тот или иной элемент документа. Примерами могут служить атрибуты FACE, COLOR или SIZE тега <FONT>.

Еще одним компонентом разметки XML являются объекты. Объекты могут быть набором каких-нибудь двоичных данных, графическим или звуковым файлом или специальным символом, не входящим в набор ASCII. Все используемые в XML-документе объекты (т. е., к примеру, все изображения и другие внешние объекты) должны быть описаны в DTD. С их помощью можно также объединять несколько XML-файлов в один и многое другое.

Пока XML еще не стал стандартом в Сети, приходится выполнять преобразование из XML в HTML, сайт JavaLobby.

Следующим составляющим DTD являются модели содержания. Они определяют способ и правила вложенности тегов. Обратимся к HTML за примером - упорядоченный список помещается между тегами <OL> и </OL>, элементы списка задаются внутри конструкции <LI> и </LI>. Использовать какие-либо другие кроме <LI> теги сразу же после <OL> запрещено. Модели содержания в DTD указывают способ вложения тегов друг в друга, порядок вложения, количество экземпляров каждого тега, которое можно применять внутри какой-нибудь конструкции и т. д. Таким образом, поддерживается четкая структуризация документа. Вообще XML-интерпретаторы (в отличие от HTML-броузеров) очень строго следят за соблюдением правил, перечисленных в DTD. Если возникает какая-либо ошибка, интерпретация XML-документа прекращается и выводится соответствующее сообщение. Никаких поблажек и вольностей анализаторы XML не допускают.

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

XML-документы представляют собой текст, написанный с помощью языка разметки, который в свою очередь определен в соответствующем DTD-словаре. Единственным отличием в стиле написания от HTML являются непарные теги. Если в HTML тег принудительного возврата каретки, к примеру, записывался как <BR>, то в XML подобный тег выглядел бы как <BR />. Также в XML изначально закладывались правила точной записи разметки. Иными словами, крайне важно соблюдать все правила, заданные в DTD. XML-интерпретаторы "не прощают" ошибок, и некорректно написанный документ просто не будет отображаться. К самым частым ошибкам бывших HTML-кодеров относятся потери закрывающих тегов и нарушение последовательности тегов.

Свой язык собственными руками

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

· TAPE - определяет запись о кассете;

· RUSSIANTITLE - название фильма в русскоязычном прокате;

· ORIGINALTITLE - оригинальное название фильма;

· COUNTRY - страна - производитель фильма;

· YEAR - год выпуска;

· TIME - длительность фильма;

· DIRECTOR - режиссер;

· STARRINGLIST - список актеров;

· ACTOR - имя актера, из списка актеров;

· CATEGORY - жанр;

· RATING - оценка;

· COMMENTS - комментарий к фильму.

Примером описания одного фильма на XML при использовании нашего словаря будет:

<TAPE> <RUSSIANTITLE>Чужой </RUSSIANTITLE> <ORIGINALTITLE>Alien </ORIGINALTITLE> <COUNTRY>Великобритания — США</COUNTRY> <YEAR VALUE="1979" /> <TIME VALUE="117" /> <DIRECTOR>Ридли Скотт</DIRECTOR> <STARRINGLIST> <ACTOR>Сигурни Уивер</ACTOR> <ACTOR>Том Скеррит</ACTOR> <ACTOR>Яфет Котто</ACTOR> <ACTOR>Джон Хёрт</ACTOR> </STARRINGLIST> <CATEGORY CLASS="SCIFI" /> <RATING NUMBER="5" /> </TAPE>

Для использования подобного языка разметки необходимо определить DTD-словарь. Поместим его в файл video.dtd. Ниже подробно рассматриваются все шаги по созданию DTD-словаря.

Описание элементов языка

Для начала необходимо описать все использующиеся элементы языка. Делается это с помощью директивы <!ELEMENT>, которая имеет следующий формат:

<!ELEMENT имя_элемента (модель_содержания)>

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

Значения знаков препинания:

· запятая (,) - разделяет типы элементов в списке или последовательности;

· вертикальная черта (|) - разделяет элементы в списке;

· плюс (+) - указывает, что элемент будет использоваться один или более раз;

· вопросительный знак (?) - указывает, что элемент не будет использоваться или будет использоваться один раз;

· звездочка (*) - указывает, что элемент не будет использоваться или будет использоваться несколько раз.

Примером может служить конструкция списка <OL> в HMTL, описание которой выглядело бы следующим образом:

<!ELEMENT OL (LI+)>

Эта запись говорит о том, что элемент <LI> может встречаться внутри тега элемента <OL> один или несколько раз. Другой пример - конструкция <DL> (список определений), которая выглядела бы в DTD следующим образом:

<!ELEMENT DL (DT, DD+)+>

Данная запись говорит о том, что элемент <DL> содержит один или несколько экземпляров элемента <DT>, сопровождаемых одним или несколькими экземплярами элемента <DD>. Поскольку знак плюс находится за скобками, он сообщает, что описанная в скобках конструкция может повторяться один или более одного раза. Использование запятой строго задает последовательность элементов, т. е. следующая запись для элемента <HTML> говорит, что сначала должен идти элемент <HEAD>, а затем элемент <BODY>:

<!ELEMENT HTML (HEAD, BODY)>

Внутри элемента можно использовать не только другие элементы, но и какой-нибудь текст. Для этого предназначено специальное ключевое слово #PCDATA. Если элемент будет содержать только текст (например, элемент <SUP> из HTML), то его описание выглядит следующим образом:

<!ELEMENT имя_элемента (#PCDATA)>

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

<!ELEMENT имя_элемента (#PCDATA | элемент | элемент | элемент)*>

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

Еще одним вариантом описания модели содержания служит ключевое слово ANY, которое сообщает XML-интерпретатору, что элемент имеет произвольное содержание.

После преобразования с помощью таблиц стилей XSL броузер получает XML-документ в формате HTML — сайт разработчиков программ Media Design in-Progress.

В директиве <!ELEMENT> можно указывать на то, что описываемый элемент является пустым или одиночным и он не требует закрывающих тегов. Примером из HTML служат теги <BR> или <HR>:

<!ELEMENT HR EMPTY>

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

<!ELEMENT TAPE (RUSSIANTITLE, ORIGINALTITLE, COUNTRY?, YEAR, TIME?, DIRECTOR, STARRINGLIST, CATEGORY, RATING, COMMENTS)> <!ELEMENT RUSSIANTITLE (#PCDATA)> <!ELEMENT ORIGINALTITLE (#PCDATA)> <!ELEMENT COUNTRY (#PCDATA)> <!ELEMENT YEAR EMPTY> <!ELEMENT TIME EMPTY> <!ELEMENT DIRECTOR (#PCDATA)> <!ELEMENT STARRINGLIST (ACTOR+)> <!ELEMENT ACTOR (#PCDATA)> <!ELEMENT CATEGORY EMPTY> <!ELEMENT RATING EMPTY> <!ELEMENT COMMENTS (#PCDATA)>

Обратите внимание на то, что элемент ACTOR не перечисляется в списке используемых элементов для TAPE. Он может применяться только внутри элемента STARRINGLIST, который уже в свою очередь может помещаться внутри основного тега TAPE. Вопросительные знаки после элементов COUNTRY, TIME и COMMENTS внутри описания TAPE говорят о том, что данные элементы являются необязательными.

Описание атрибутов элемента

Атрибуты элемента конкретизируют его содержание. Для описания атрибутов элементов применяется директива <!ATTLIST>. Атрибуты в XML подразделяются на три вида: обязательные, фиксированные и неявные.

Для обязательных атрибутов, о чем и говорит название, необходимо явно указывать их значение при каждом использовании элемента. Примером обязательного атрибута в HTML служит SRC для элемента <IMG>.

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

Если атрибут не является ни обязательным, ни фиксированным, то он называется неявным. Его применение необязательно, и он не имеет значения по умолчанию. Примером такого атрибута служит параметр BACKGROUND тега <BODY>.

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

Один из примеров использования XML — язык описания фильмов FlixML.

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

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

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

Синтаксис определения атрибутов в DTD имеет следующий вид:

<!ATTLIST имя_элемента имя_атрибута тип_значения тип_атрибута "значение_по_умолчанию">

Секция описания атрибута может повторяться для того, чтобы описать все атрибуты указанного элемента. Каждая секция должна содержать, как минимум, имя атрибута и тип его значения. Тип значения указывается следующим образом:

· простой текст - CDATA;

· уникальный идентификатор - ID;

· предопределенные значения - (значение|значение|…);

· нетекстовый объект - ENTITY.

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

· обязательный - #REQUIRED;

· фиксированный - #FIXED;

· неявный - #IMPLIED.

Например, сокращенный вариант описания атрибутов элемента HTML <IMG> выглядел бы следующим образом:

<!ATTLIST IMG SRC ENTITY #IMPLIED ALT CDATA #IMPLIED ALIGN (LEFT|RIGHT|CENTER| ABSCENTER) #REQUIRED VALIGN CDATA #FIXED "MIDDLE">

Вернемся к нашему языку… Мы имеем четыре элемента, для которых необходимы атрибуты - YEAR, TIME, CATEGORY и RATING. В первом и втором случае мы имеем атрибуты с текстовыми значениями (т. к. невозможно предугадать их значения). В последних двух случаях необходимо использовать предопределенные значения. В результате имеем следующую запись в нашем DTD-словаре:

Использование объектов

Объектами в XML могут выступать самые различные данные - от текста до двоичных файлов. Объекты в HTML использовались при описании специальных символов и в редких случаях служили для описания внешних источников данных (с помощью тега <OBJECT>). В XML объекты применяются гораздо шире. Существует четыре типа объектов:

· Текстовые объекты. Они содержат часто используемые фразы или целые блоки текста. Текстовые объекты могут содержать как обыкновенный текст, так и элементы разметки. Пример - обычная строка копирайта. Вместо того чтобы везде в тексте писать целую строку "Copyright by ABCD Inc., 2000" можно применять объекты. Когда интерпретатор встретит в документе ссылку на объект, он подставит вместо нее текст, ассоциируемый с этим объектом. Использование текстовых объектов облегчает написание документа, а также упрощает изменение каких-либо значений в тексте. Если строку копирайта необходимо изменить на "Copyright by EFGH Inc., 2001", то вам достаточно только изменить значение объекта. В противном случае вам бы пришлось искать необходимый для изменения текст во всех документах и только тогда исправлять его на новое значение.

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

· Параметрические объекты. Это специальный тип объекта, который применяется только внутри DTD. Параметрические объекты облегчают написание самих DTD, они содержат часто используемые блоки текста из описания DTD. К примеру, если некоторое число элементов имеет одни и те же атрибуты, то можно задать список описания атрибутов в качестве значения параметрического объекта и позже, при описании необходимых элементов, просто воспользоваться ссылкой на объект.

· Символьные объекты. Этот тип объектов наиболее часто употребляется в HTML. Они даны для описания нетекстовых или зарезервированных символов (например, символ открывающейся угловой скобки '<' = <), а также всех символов Unicode.

Для объявления объекта в DTD предназначена директива <!ENTITY>, которая имеет следующий синтаксис:

<!ENTITY имя_объекта "содержание">

В зависимости от типа объекта могут добавляться дополнительные параметры. Объекты также бывают внутренними и внешними. Содержимое внутренних объектов задается при их описании, а для внешних объектов приводится ссылка на внешний файл. Параметрические объекты всегда внутренние, а двоичные, как правило, внешние. Текстовые и символьные объекты могут быть обоих типов. При применении объектов важно соблюдать правило о том, чтобы объект был определен строго до его использования.

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

<!ENTITY copyright "Copyright (c)">

Для использования этого объекта необходимо будет применять ссылку на объект:

&copyright;

Объект copyright является внутренним, поскольку его содержание описано при его объявлении. Текстовые объекты также могут быть внешними. Тогда при его определении необходимо указать адрес файла, который содержит текст объекта. Вдобавок необходимо будет задать идентификатор внешнего объекта, сообщающий о физическом расположении файла объекта. Если будет использовано ключевое слово SYSTEM, то XML-интерпретатор считает, что файл хранится в локальной файловой системе. Идентификатор PUBLIC сообщает о том, что файл широко доступен и он не обязательно находится в локальной системе. Например:

<!ENTITY mypara "/texts/mypara.xml" SYSTEM>

Для описания двоичного объекта необходимо использовать ключевое слово NDATA и идентификатор типа двоичного объекта. Например:

<!ENTITY myphoto "/jpegs/myphoto.jpg" SYSTEM NDATA JPEG>

Важно, чтобы тип двоичного объекта был известен системе и интерпретатору. Для этого необходимо воспользоваться директивой <!NOTIFY>:

<!NOTIFY BMP SYSTEM "pbrush.exe">

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

Параметрические объекты объявляются следующим образом: <!ENTITY % имя_объекта "содержание"> Использование параметрического объекта также отличается от обычного применения объектов: %name; По умолчанию, XML-интерпретатор предоставляет доступ к символьным объектам из набора символов ISO-Latin-1. Для того чтобы получить доступ ко всему множеству символов Unicode, необходимо определить внешний параметрический объект, содержащий таблицу символов, и затем применить его. Например, следующие строки предоставляют доступ ко всем символам Latin 1: <!ENTITY % HTMLlat1 PUBLIC "-//W3C//ENTITIES Full Latin 1//EN//HTML"> %HTMLlat1; Использование двоичных объектов отличается от остальных, которые примяются в любом месте документа. Двоичные же объекты можно использовать только в качестве значения атрибута, с нетекстовыми данными, т. е., если мы определим двоичный объект, как: <!ENTITY myphoto "/jpegs/myphoto.jpg" SYSTEM NDATA JPEG> Использование &myphoto; приведет к генерации некорректного документа. Необходим элемент, принимающий двоичные данные, например: <BODY BACKGROUND="1267/tr> Необходимо заметить, что в качестве значения передается имя объекта, а не имя файла. Конструкция вида <BODY BACKGROUND="1267/tr> будет неверна, даже при вышеуказанном описании объекта. В этом состоит одна из ошибок при переходе от HTML к XML.

XML-документ

Теперь рассмотрим, как, собственно, формировать сам XML-документ. Внутри себя, помимо разметки и текста документа, каждый XML-документ содержит команды обработки (processing instructions). Они сообщают некоторую дополнительную информацию XML-интерпретатору, помогающую правильно обработать документ. Первой строкой каждого XML-документа должна стоять инструкция, идентифицирующая документ как данные на языке XML. Она имеет следующий вид:

<?xml version="1.0" encoding="кодировка" ?>

Параметр VERSION сообщает версию XML, на данный момент существует только версия 1.0. Необязательный параметр ENCODING указывает кодировку, в которой написан документ. После объявления XML-документа необходимо описать или сделать ссылку на DTD-словарь, который будет использоваться в документе, например:

<!DOCTYPE VIDEO SYSTEM "video.dtd">

VIDEO - имя всеобъемлющего элемента класса "документ" (наподобие элемента <HTML>), SYSTEM - сообщает о том, что файл со словарем необходимо искать в локальной системе (можно также использовать ключевое слово PUBLIC); video.dtd - имя файла с DTD. Допускается описание словаря и внутри XML-документа, для этого необходимо использовать директиву <!DOCTYPE> следующим образом:

<!DOCTYPE VIDEO [ <!ELEMENT TAPE (RUSSIANTITLE, ORIGINALTITLE, COUNTRY?, YEAR, TIME?, DIRECTOR, STARRINGLIST, CATEGORY, RATING, COMMENTS?)> … <!ATTLIST RATING NUMBER (1| 2|3|4|5) #REQUIRED> ]> …

XML в процессе создания…

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

Параллельно с разработкой спецификаций ведутся описания по созданию XML-броузеров интерпретаторов. Сейчас практически каждая компания, представленная на рынке информационных технологий, интегрирует свои достижения с XML. Уже существует множество DTD-словарей, применяющихся в самых разных областях. Примером могут служить каналы Microsoft, CDF, написанные на XML, или язык математической разметки MathML. Прогресс идет, и XML - это несомненное будущее разметки и гипертекста.

©Drkb::03112.

XML сериализация объекта Delphi.

Язык XML предоставляет нам чрезвычайно удобный и почти универсальный подход к хранению и передаче информации. Не хватает только средств, которые позволили бы удобно и просто организовать работу с XML. Предлагаемая разработка реализует очень эффективную возможность - XML сериализацию объектов любых классов Delphi и из загрузку из XML кода. Рассматриваемый подход дает возможность наиболее удобно интегрировать обработку XML объектов в среду разработки Delphi и C++Builder. Возможность доступа к свойствам объектов определяется RTTI. Его возможности в Delphi очень велики, т.к. среда разработки сама хранит ресурсы объектов в текстовом формате. Для начала определим ряд простых функций для формирования XML кода. Они позволят нам добавлять открывающие, закрывающие теги и значения в результирующий текст.

Code: { Добавляет открывающий тег с заданным именем }. Procedure addOpenTag(const Value: string); Begin. Result := Result + '<' + Value + '>'; Inc(Level); End; { Добавляет закрывающий тег с заданным именем }. Procedure addCloseTag(const Value: string; addBreak: boolean = false); Begin. Dec(Level); Result := Result + '</' + Value + '>'; End; { Добавляет значение в результирующую строку }. Procedure addValue(const Value: string); Begin. Result := Result + Value; End;

Следующее, что предстоит реализовать - это перебор всех свойств объекта и формирование тегов. Сведения о свойствах получаются через интерфейс компонента. Это информация о типе. Для каждого свойства, за исключением классовых получается их имя и текстовое значение, после чего формируется XML-тег. Значение загружается через ф-ию TypInfo.GetPropValue();

Двоичный поиск для TListView.

Code: {+------------------------------------------------------------ | Function ListviewBinarySearch. | | Parameters : | listview: listview to search, assumed to be sorted, must. | be <> nil. | Item : item caption to search for, cannot be empty. | index : returns the index of the found item, or the. | index where the item should be inserted if it is not. | already in the list. | Returns : True if there is an item with the passed caption. | in the list, false otherwise. | Description: | Uses a binary search and assumes that the listview is sorted. | ascending on the caption of the listitems. The search is. | case-sensitive, like the default alpha-sort routine used by. | the TListview class. | Note: | We use the lstrcmp function for string comparison since it. | is the function used by the default alpha sort routine. If. | the listview is sorted by another means (e.g. OnCompare event). | this needs to be changed, the comparison method used must. | always be the same one used to sort the listview, or the. | search will not work! | Error Conditions: none. | Created: 31.10.99 by P. Below. +------------------------------------------------------------} Function ListviewBinarySearch(listview: TListview; const Item: string; Var Index: Integer): Boolean; Var. First, last, pivot, res: Integer; Begin. Assert(Assigned(listview)); Assert(Length(item) > 0); Result := False; Index := 0; If listview.Items.Count = 0 then Exit; First := 0; Last := listview.Items.Count - 1; Repeat. Pivot := (First + last) div 2; Res := lstrcmp(PChar(item), PChar(listview.Items[pivot].Caption)); If res = 0 then. Begin. { Found the item, return its index and exit. }. Index := pivot; Result := True; Break; End { If }. Else if res > 0 then. Begin. { Item is larger than item at pivot }. First := pivot + 1; End { If }. Else. Begin. { Item is smaller than item at pivot }. Last := pivot - 1; End; Until last < First; Index := First; End; { ListviewBinarySearch }.

©Drkb::01130.

Взято с сайта: http://www.swissdelphicenter.ch.

Эволюция средств разработки Web приложений в Delphi.

Введение

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

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

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

В данной статье мы попытаемся рассмотреть спектр технологий, предлагаемый Borland, расположив их в хронологическом порядке появления их в Delphi. -Web broker -Web Snap -Web Services Технология Web broker была первой попыткой Borland представить инструментарий для разработки приложений, работающих через Internet. Она позволяет создавать приложения, расширяющие функциональность web серверов, однако не дает больших преимуществ по сравнению с другими языками программирования, такими как Perl или PHP. Осознавая это, Borland в новой версии Delphi представила на суд разработчиков две новые технологии Web Snap и Web Services. Технология Web Snap - это попытка предложить разработчикам удобный набор компонентов для решения типовых задач, возникающих при создании Web приложений, работающих под управлением Web сервера. Она призвана заменить технологию Web broker. Web services - это набор компонентов для создания приложений, использующих возможности интернета для обмена информацией между приложениями. При обмене используется протокол SOAP, который не привязан к какой-либо платформе или языку. Данный подход реализует объектную идеологию в разработке информационных систем, и является перспективным направлением, по которому, скорее всего, пойдет дальнейшее совершенствование технологий в данной области.

В первой части статьи мы рассмотрим технологии, которые были доступны еще в Delphi 5. Во второй части будут рассмотрены новые технологии, появившиеся в Delphi 6. Помимо Delphi для демонстрации работы примеров автор использовал Internet Explorer и Web сервер Apache на платформе Windows.

Форматы приложений для WEB.

Формат приложения Описание Microsoft Server DLL (ISAPI), Netscape Server DLL (NSAPI). Web приложение представляет собой dll, которая загружается Web сервером в память. Запросы клиентов обрабатываются в отдельных потоках. ISAPI работает на Web сервере IIS (от Microsoft), NSAPI - на сервере Netscape. Apache Server DLL. Динамический модуль Web сервера Apache. На платформе Windows - dll. Приложение взаимодействует с ядром Apache через специальный API. Запросы клиентов обрабатываются в отдельных потоках. Приложения данного типа с помощью перекомпиляции в Kylix могут быть перенесены на платформу Linux. Stand alone CGI. Консольные приложение, получающее запросы клиента через стандартный поток ввода и выдающий результат в стандартный поток вывода. Запросы клиента выполняются отдельным экземпляром приложения. Поддерживается практически всеми Web серверами. Приложения данного типа с помощью перекомпиляции в Kylix могут быть перенесены на платформу Linux. Windows CGI application. Приложение Windows, получающее запросы через ini файл, создаваемый Web сервером и записывающее результаты работы в файл, который Web сервер передает обратно клиенту. Web debugger application. Web debugger - это специальная программа в составе Delphi 6, которая эмулирует работу Web сервера. Позволяет проводить мониторинг работы приложения. Используется для отладки приложений. После отладки приложение должно быть конвертировано в один из вышеописанных форматов.

Web Broker.

Данная технология появилась еще в 4-ой версии Delphi. Назначение технологии - разработка приложений, расширяющих возможности существующих Web серверов. Разработка приложений в данной технологии сводится к определению возможных запросов пользователя и написании обработчиков этих запросов. К достоинствам технологии можно отнести переносимость на Kylix и простоту. Недостатки - фактически невизуальный процесс разработки приложения. Компоненты, относящиеся к данной технологии, расположены на закладке Internet IDE Delphi.

Первые шаги

Итак, попробуем разработать наше первое Web приложение. В IDE Delphi выберем пункт меню File/New/Other. В появившемся диалоге на закладке New выберем пункт Web Server Application. Нам будет предложено выбрать формат создаваемого приложения.

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

Выберем пункт Web App Debuger executable и в поле ввода CoClassName введем HelloWebApp. Delphi сгенерирует нам заготовку проекта. В состав проекта будет входить: " Unit1.pas - в нем описывается форма From1. Форма не несет никакой функциональной нагрузки в приложении. Ее наличие вызвано особенностями реализации Web App Debuger. " Unit2.pas - модуль, содержащий описание Web Module - центрального элемента нашего приложения. Тут самое время рассказать о структуре приложения Web Broker.

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

Web приложение, получив запрос от сервера создает объект типа TwebRequest, содержащий параметры клиентского запроса и объект типа TWebResponse, который будет содержать запрошенную информацию. Затем эти объекты передаются диспетчеру (Web модулю или компоненту TWebDispatcher, если отсутствует Web модуль). Диспетчер анализирует параметры поступившего запроса и вызывает обработчик, определенный программистом для данного запроса (Action Item). Обработчик отвечает за заполнение ответа данными. В обработчике для получения запрошенных клиентом данных могут использоваться компоненты, генерирующие динамическую информацию на основе заданного шаблона и поступивших в запросе данных (Content producer). По окончании работы обработчика диспетчер передает данные (Web Response) веб серверу, а тот в свою очередь клиенту.

Теперь, вооруженные теорией, вернемся к практике. Очевидно, что нам необходимо определить в Web модуле хотя бы один обработчик события. Для этого правой кнопкой мыши щелкнем на нашем модуле и в контекстном меню выберем пункт Action Editor. Перед нами появится окно редактора обработчиков. Кнопкой "Add New" добавим новый обработчик WebActionItem1.

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

В Инспекторе объектов установим следующие свойства обработчика: Default - использовать обработчик по умолчанию - true. В этом случае обработчик вызывается если нет явного обработчика запроса с данными параметрами. Можно назначить один обработчик по умолчанию для Web модуля. PachInfo - путь обработчика, часть URL адреса после имени программы, за разбор которого осуществляет данный обработчик. Так ,например, для обработки URL http://localhost/cgi-bin/Project1.exe/mypath, св-во PathInfo обработчика должно быть /mypath. Для нашего случая установим данное св-во в значение "/". Далее необходимо написать код обработчика, для этого в обработчике события OnAction WebActionItem1 введем следующий код: Response.Content:='Hello,world !'; Запустим на выполнение созданное приложение (F9). На экране появится форма Form1. В IDE Delphi выберем пункт меню Tools/Web App Debuger, при этом на экране появится главная форма отладчика.

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

После нажатия кнопки "Start" надпись http://localhost:1024/… подсветится синим. Левой кнопкой мыши выберем эту надпись при этом будет запущен Web броузер и в его окне выведен список приложений, доступных для отладки. В списке выберем пункт Project1.HelloWebApp (наше приложение) и нажмем кнопку Go. В окне броузера мы увидим результат работы нашего приложения - "Hello, world!". Присмотревшись к коду обработчика события OnAction WebActionItem1, мы видим, что содержание ответа формируется "вручную". При этом очень часто приходится анализировать поля переменных классов TWebResponse и TWebRequest. Ниже приведено описание и назначение наиболее часто используемых полей данных классов.

Поле Тип Описание TWebRequest. Host. String. Имя сервера, на котором выполняется скрипт ScriptName. String. URL путь к скрипту Request.Method. String. Метод вызова скрипта RemoteAddr. String. Имя компьютера, вызвавшего скрипт UserAgent. String. Пользовательский браузер ContentFields, QueryFields. TStrings. Параметры и их значения, переданные запросу TWebResponse. Server. String. Вид веб сервера ContentType. Sting. Тип содержимого страницы Content. String. Ответ, сформированный скриптом ContentStream. TStream. Ответ, сформированный скриптом. Используется в случае передачи двоичных данных

В качестве иллюстрации использования описанных полей приведу следующий код обработчика OnAction WebActionItem1:

Code: Response.Content:='<HTML><BODY> Host:'+Request.Host+'<br>'+ 'Скрипт: '+Request.ScriptName + '<br>'+ 'Метод: '+Request.Method+'<br>'+ 'Remote address: '+Request.RemoteAddr+'<br>'+ 'Броузер: '+Request.UserAgent+'<br>'; If Request.ContentFields.Count > 0 then. Begin. Response.Content:=Response.Content+'Параметры:<br>Кол-во:'+ IntToStr(Request.ContentFields.Count)+'<br>'; For Cnt:=0 to Request.ContentFields.Count-1 do. Begin. Response.Content:=Response.Content+Request.ContentFields[Cnt]+'<br>'; End; End else. Begin. Response.Content:=Response.Content+'Параметры:<br>Кол-во:'+ IntToStr(Request.QueryFields.Count)+'<br>'; For Cnt:=0 to Request.QueryFields.Count-1 do. Begin. Response.Content:=Response.Content+Request.QueryFields[Cnt]+'<br>'; End; End; Response.Server:='Our soft'; Response.Content:=Response.Content+'Веб сервер: '+Response.Server+'<br>'; Response.Content:=Response.Content+'Тип содержимого: '+Response.ContentType+'<br>'; Response.Content:=Response.Content+'<BODY/></HTML>';

Экранный вирус

Никогда не видели экранного вируса? Представьте, что Ваш экран заболел и покрылся красными пятнами :) А если эта болезнь нападёт на какое-нибудь окно ? Всё, что нам надо, это получить контекст устройства при помощи API функции GetWindowDC и рисовать, что душе угодно.

Эксперты в DELPHI, или Программист, упростите себе жизнь

Имеющее множество достоинств и довольно популярное средство разработки Delphi позволяет расширять функциональные возможности среды разработчика. Речь идет не о косметических изменениях в интерфейсе и не о добавлении компонентов или их наборов, а о придании рабочему окружению программиста новых полезных возможностей, не предусмотренных его создателями. Для решения подобной задачи в Delphi можно воспользоваться так называемыми экспертами. Вспомните, как удобно, ответив на несколько вопросов, создать готовую форму для вывода содержимого таблиц. Или, щелкнув мышью на нужном элементе в списке New Items, получить “костяк” вашего будущего проекта (рис. 1).

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

Рис. 1. Многие возможности Delphi реализуются с помощью экспертов

Что это — стандартные возможности рабочей среды? Да, но применить их можно лишь с помощью эксперта. О том, как это сделать, и пойдет речь далее.

Эксперты в Delphi — что это такое?

Если не хватает возможностей среды или какие-то операции кажутс слишком громоздкими, то эксперты — именно то, что нужно. С помощью экспертов вы словно проникаете внутрь среды Delphi и без труда дополняете ее. Естественно, такое проникновение должно быть осторожным и аккуратным, потому как неправильное обращение с объектами и интерфейсами может вызвать сбои в работе среды или даже ее разрушение. Эксперты могут существовать в виде библиотек DLL либо компилированных модулей DCU. Выбор “формы жизни” будущего эксперта остается за вами, но имейте в виду, что расширение файла эксперта определяет способ его регистрации. О способах регистрации чуть далее — сперва давайте рассмотрим стили экспертов Delphi. Их всего четыре, и все они приведены в таблице.

Стили экспертов

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

Главное отличие между стилями заключается в способе вызова эксперта пользователем в среде Delphi. Как видите, можно определить самый удобный из них. Реализация экспертов предполагает использование интерфейса Open Tools API — набора классов, позволяющего обращатьс ко множеству функций среды Delphi. В экспертах Open Tools API может использоватьс для:

· получения информации о проекте;

· получения информации о модуле или форме;

· управления модулями проекта (дл открытия, закрытия, добавления, создания);

· управления ресурсами проекта;

· модификации меню Delphi;

· регистрации изменений в проекте;

· регистрации изменений в модуле.

Следует заметить, что интерфейс Open Tools API доступен только из программ, запущенных как часть интегрированной среды Delphi. В следующем разделе мы рассмотрим несколько полезных экспертов.

Реализация класса TIExpert.

Для создания нового эксперта необходимо наследовать новый класс от класса TIExpert, переопределив при этом часть его методов (таблица 2).

Возможность переопределени методов экспертов тех или иных стилей Статьи по Delphi (036)…

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

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

Определение класса TIExpert приведено далее.

Code: TIExpert = class(TInterface). Public. { Методы пользовательского. Интерфейса с экспертом }. Function GetName: string; Virtual; stdcall; abstract; Function GetAuthor: string; Virtual; stdcall; abstract; Function GetComment: string; Virtual; stdcall; abstract; Function GetPage: string; Virtual; stdcall; abstract; Function GetGlyph: HICON; Virtual; stdcall; abstract; Function GetStyle: TExpertStyle; virtual; stdcall; Abstract; Function GetState: TExpertState; virtual; stdcall; Abstract; Function GetIDString: string; Virtual; stdcall; abstract; Function GetMenuText: string; Virtual; stdcall; abstract; { Запуск эксперта }. Procedure Execute; virtual; Stdcall; abstract; End;

Экспоненциальное распределение

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Экспоненциальное распределение. Возвращает случайное число, распределенное по экспоненциальному закону распределения. Зависимости: System. Автор: Алексей Перов, aperov@rambler.ru, ICQ:102661702, Караганда. Copyright: Лабораторные работы по курсу "Моделирование информационных систем", КарГТУ. Дата: 25 апреля 2002 г. ********************************************** } Function RandomExponent(ex: Extended): Extended; { экспоненциальное распределение }. Begin. Result := - ex * Ln(Random). End;

Экспортировать ветвь реестра

Code: Unit RegExpo; Interface. Uses. Windows, rRegistry, Classes, SysUtils; {$I-}. {$LONGSTRINGS ON}. { Regexpo. Author : Arthur Hoornweg (arthur.hoornweg@email.de). Version : 1.00, May 1998. O/S : Windows 95, 98, ME, NT, 2000, XP. Delphi 2+ Function : This unit allows you to backup a branch of the registry into a *.REG file, That is compatible with "regedit". Double-clicking such a file in the explorer will import it. Example: ExportRegistryBranch(HKEY_LOCAL_MACHINE,'SOFTWARE\Borland\Delphi','A:\DELPHI.REG'). (c) 1998 A.M. Hoornweg. All rights reserved. You may use this software for all purposes, both commercial and. Noncommercial, as long as proper credit is given. The sourcecode may be distributed. Freely, as long as this copyright is included and no more than a marginal fee is. Asked. Disclaimer: I accept no responsibility whatsoever for any damages caused by these. Routines. Use them at your own risk. If you find any bugs, please let me know. } Procedure ExportRegistryBranch(Rootsection: Integer; regroot: string; FileName: string); Implementation. Function dblBackSlash(t: string): string; Var. K: longint; Begin. Result := t; {Strings are not allowed to have}. For k := Length(t) downto 1 do {single backslashes}. If Result[k] = '\' then Insert('\', Result, k); End; Procedure ExportRegistryBranch(rootsection: Integer; Regroot: string; FileName: string); Var. Reg: TRegistry; F: Textfile; P: PChar; Procedure ProcessBranch(root: string); {recursive sub-procedure}. Var. Values, keys: TStringList; I, j, k: longint; S, t: string; {longstrings are on the heap, not on the stack!}. Begin. Writeln(f); {write blank line}. Case rootsection of. HKEY_CLASSES_ROOT: s := 'HKEY_CLASSES_ROOT'; HKEY_CURRENT_USER: s := 'HKEY_CURRENT_USER'; HKEY_LOCAL_MACHINE: s := 'HKEY_LOCAL_MACHINE'; HKEY_USERS: s := 'HKEY_USERS'; HKEY_PERFORMANCE_DATA: s := 'HKEY_PERFORMANCE_DATA'; HKEY_CURRENT_CONFIG: s := 'HKEY_CURRENT_CONFIG'; HKEY_DYN_DATA: s := 'HKEY_DYN_DATA'; End; Writeln(f, '[' + s + '\' + root + ']'); {write section name in brackets}. Reg.OpenKey(root, False); Try. Values := TStringList.Create; Try. Keys := TStringList.Create; Try. Reg.GetValuenames(values); {get all value names}. Reg.GetKeynames(keys); {get all sub-branches}. For i := 0 to values.Count - 1 do {write all the values first}. Begin. S := values[i]; T := s; {s=value name}. If s = '' then s := '@' {empty means "default value", write as @}. Else. S := '"' + s + '"'; {else put in quotes}. Write(f, dblbackslash(s) + '='); {write the name of the key to the file}. Case reg.Getdatatype(t) of {What type of data is it?}. RdString, rdExpandString: {String-type}. Writeln(f, '"' + dblbackslash(reg.ReadString(t) + '"')); RdInteger: {32-bit unsigned long integer}. Writeln(f, 'dword:' + IntToHex(reg.readinteger(t), 8)); {write an array of hex bytes if data is "binary." Perform a line feed. After approx. 25 numbers so the line length stays within limits}. RdBinary: Begin. Write(f, 'hex:'); J := reg.GetDataSize(t); {determine size}. GetMem(p, j); {Allocate memory}. Reg.ReadBinaryData(t, p^, J); {read in the data, treat as pchar}. For k := 0 to j - 1 do. Begin. Write(f, IntToHex(Byte(p[k]), 2)); {Write byte as hex}. If k <> j - 1 then {not yet last byte?}. Begin. Write(f, ','); {then write Comma}. If (k > 0) and ((k mod 25) = 0) {line too long?} then. Writeln(f, '\'); {then write Backslash +lf}. End; {if}. End; {for}. FreeMem(p, j); {free the memory}. Writeln(f); {Linefeed}. End; Else. Writeln(f, '""'); {write an empty string if datatype illegal/unknown}. End;{case}. End; {for}. Finally. Reg.CloseKey; End; Finally. {value names all done, no longer needed}. Values.Free; End; {Now al values are written, we process all subkeys}. {Perform this process RECURSIVELY...}. For i := 0 to keys.Count - 1 do. ProcessBranch(root + '\' + keys[i]); Finally. Keys.Free; {this branch is ready}. End; End; { ProcessBranch}. Begin. If RegRoot[Length(Regroot)] = '\' then {No trailing backslash}. SetLength(regroot, Length(Regroot) - 1); Assignfile(f, FileName); {create a text file}. Rewrite(f); If ioResult <> 0 then Exit; Writeln(f, 'REGEDIT4'); {"magic key" for regedit}. Reg := TRegistry.Create; Try. Reg.Rootkey := Rootsection; {Call the function that writes the branch and all subbranches}. ProcessBranch(Regroot); Finally. Reg.Free; {ready}. Close(f); End; End; End.

Экспортировать таблицу или результат запроса в файл

@DataSource - хранит имя таблицы или sql запрос который надо сохранить.

@UserName - имя пользователя для подсоединения к серверу.

@Password - пароль пользователя для подсоединения к серверу.

Code: --©Drkb v.3(2007): www.drkb.ru. Declare @sql varchar(8000), @out varchar(20). If PatIndex('%Select %', @DataSource)>0 Set @out='" queryout "' else Set @out='" out "' Set @sql='bcp "'+@DataSource+@out+' c:\MyFile.txt " -S'+@@servername+' -U'+@UserName+' -P'+@Password+' -c -t"," -r\n -k' Exec master..xp_cmdshell @sql.

Примечание: Путь локален для серверного компьютера, не для клиента!

Экспорт TStringGrid в Excel.

Code: { With OLE Automation }. Uses. ComObj; Function RefToCell(ARow, ACol: Integer): string; Begin. Result := Chr(Ord('A') + ACol - 1) + IntToStr(ARow); End; Function SaveAsExcelFile(AGrid: TStringGrid; ASheetName, AFileName: string): Boolean; Const. XlWBATWorksheet = -4167; Var. Row, Col: Integer; GridPrevFile: string; XLApp, Sheet, Data: OLEVariant; I, j: Integer; Begin. // Prepare Data. Data := VarArrayCreate([1, AGrid.RowCount, 1, AGrid.ColCount], varVariant); For i := 0 to AGrid.ColCount - 1 do. For j := 0 to AGrid.RowCount - 1 do. Data[j + 1, i + 1] := AGrid.Cells[i, j]; // Create Excel-OLE Object. Result := False; XLApp := CreateOleObject('Excel.Application'); Try. // Hide Excel. XLApp.Visible := False; // Add new Workbook. XLApp.Workbooks.Add(xlWBatWorkSheet); Sheet := XLApp.Workbooks[1].WorkSheets[1]; Sheet.Name := ASheetName; // Fill up the sheet. Sheet.Range[RefToCell(1, 1), RefToCell(AGrid.RowCount, AGrid.ColCount)].Value := Data; // Save Excel Worksheet. Try. XLApp.Workbooks[1].SaveAs(AFileName); Result := True; Except. // Error ? End; Finally. // Quit Excel. If not VarIsEmpty(XLApp) then. Begin. XLApp.DisplayAlerts := False; XLApp.Quit; XLAPP := Unassigned; Sheet := Unassigned; End; End; End; // Example: Procedure TForm1.Button1Click(Sender: TObject); Begin. If SaveAsExcelFile(stringGrid1, 'My Stringgrid Data', 'c:\MyExcelFile.xls') then. ShowMessage('StringGrid saved!'); End;

Экспорт документов Excel.

Экспорт документов в Excel.

Автор: JB http://asportal.h16.ru.

Эта статья первая из цикла статей посвященных экспорту документов в MS Excel. В ней мы рассмотрим подключение к Excel, заполнению ячеек и простейшее оформление документа.

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

Подключение.

Для подключения к Excel и работы с ним нам понадобится переменная типа Variant:

Excel:Variant;

Далее создаем OLE объект:

Excel:=CreateOleObject('Excel.Application');

Добавляем новую книгу:

Excel.Workbooks.Add;

Показываем Excel:

Excel.Visible:=true;

Так же нам понадобятся константы:

Const.

XlContinuous=1;

XlThin=2;

XlTop = -4160;

XlCenter = -4108;

Текст ячеек.

Теперь до любой ячейки мы можем добраться следующим образом:

Excel.ActiveWorkBook.WorkSheets[1].Cells[1, 2]:='Текст ячейки (1,2)';

Объект Range, выделение диапазона, объединение ячеек, выравнивание.

Представьте такую ситуацию: необходимо объединить несколько ячеек и выровнять текст в них по центру.

Выделяем:

Excel.ActiveWorkBook.WorkSheets[1].Range['A1:G1'].Select;

Объединяем:

Excel.ActiveWorkBook.WorkSheets[1].Range['A1:G1'].Merge;

И выравниваем:

Excel.Selection.HorizontalAlignment:=xlCenter;

Границы и перенос по словам.

Для начала выделяем нужный диапазон а затем...

Показываем границы:

Excel.Selection.Borders.LineStyle:=xlContinuous;

Excel.Selection.Borders.Weight:=xlThin;

И включаем перенос по словам:

Excel.Selection.WrapText:=true;

Пример.

Пример можно скачать здесь

Параметры страницы.

Начнем с полей страницы. Во первых для того чтобы добраться до параметров страницы у листа Excel имеется свойство объект PageSetup его мы и будем использовать. Для установки размеров полей необходимо изменить соответствующие свойства PageSetup, вот эти свойства:

· LeftMargin - Левое поле

· RightMargin - Правое поле

· TopMargin - Верхнее поле

· BottomMargin - Нижнее поле

Значение размеров полей необходимо указывать в пикселях, к чему мы не очень привыкли, поэтому воспользуемся функцией InchesToPoints объекта Application, которая переводит значение в дюймах в значение в пикселях. Теперь напишем процедуру которая подключит Excel и установит поля равные 0.44 дюйма (приблизительно 1 см):

Code: Procedure Connect; Var. Excel:Variant; Begin. Excel:=CreateOleObject('Excel.Application'); Excel.Workbooks.Add; Excel.ActiveSheet.PageSetup.LeftMargin:= Excel.Application.InchesToPoints(0.44); Excel.ActiveSheet.PageSetup.RightMargin:= Excel.Application.InchesToPoints(0.44); Excel.ActiveSheet.PageSetup.TopMargin:= Excel.Application.InchesToPoints(0.44); Excel.ActiveSheet.PageSetup.BottomMargin:= Excel.Application.InchesToPoints(0.44); End;

Экспорт и импорт из реестра

Reg-файлы это, как и ожидалось, формат, понимаемый и поддерживаемый сугубо программой regedit.

Экспорт StringGrid в исполняемый файл *.EXE.

Экспорт StringGrid в исполняемый файл *.EXE Как-то раз мне понадобилось из моей программы извлекать все содержимое StringGrid'a в exe-файл. В данном случае можно конечно писать свой собственный компилятор, но, согласитесь, это лишнее. Гораздо проще заранее написать exe-файл и поместить его в ресурсы нашей программы. А потом извлекать его оттуда, и записывать в его ресурсы содержимое StringGrid'a. Заманчиво звучит, правда? Тогда перейдем к реализации. 1. Создание exe-файла, в который поместим в конце содержимое StringGrid'a. Так как данная статья посвящена языку Делфи, то и писать этот exe-файл я рекомендую на Делфи. Запускаем Делфи, создаем новый проект, и на форму кидаем StringGrid. Это обязательный набор, но вы можете добавить все что угодно, все, что вы хотели бы видеть, после того как сделаете экспорт из StringGrid'a в исполняемый файл. Ниже представлен код процедуры загрузки содержимого из ресурсов в StringGrid:

Code: Procedure LoadStringGrid(StrGrid: TStringGrid;FName: TStream); Var. LoadList: TStringList; I, j, ListCurentLine: integer; Begin. LoadList := TStringList.Create; Try. LoadList.LoadFromStream(FName); If TryStrToInt(LoadList.Strings[0]) then. StrGrid.RowCount := StrToInt(LoadList.Strings[0]); If TryStrToInt(LoadList.Strings[1]) then. StrGrid.ColCount := StrToInt(LoadList.Strings[1]); If TryStrToInt(LoadList.Strings[2]) then. StrGrid.FixedRows := StrToInt(LoadList.Strings[2]); If TryStrToInt(LoadList.Strings[3]) then. StrGrid.FixedCols := StrToInt(LoadList.Strings[3]); ListCurentLine := 4; For j := 0 to StrGrid.RowCount-1 do. For i := 0 to StrGrid.ColCount-1 do. Begin. StrGrid.Cells[i, j] := LoadList.Strings[ListCurentLine]; Inc(ListCurentLine); End; Finally. LoadList.Free; End; End;

Экспорт TListView в TStringGrid.

Code: Procedure ListView2StringGrid(Listview: TListView; StringGrid: TStringGrid); Const. MAX_SUBITEMS = 5; Var. I, j: Integer; Begin. With ListView do. For i := 0 to Items.Count - 1 do. Begin. {Get Item of First Column}. StringGrid.Cells[1, i + 1] := Items[i].Caption; {loop through SubItems}. For j := 0 to MAX_SUBITEMS do. Begin. If Items[i].SubItems.Count > j then. StringGrid.Cells[j + 2, i + 1] := Items[i].SubItems.Strings[j]. Else. Break; End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. I: Integer; Begin. // Clear the StringGrid if necessary. // Falls notig, zuerst das StringGrid loschen. I := 0; While i < StringGrid1.RowCount do. Begin. StringGrid1.Rows[i].Clear; Inc(i); End; // Copy ListView1 to StringGrid1. ListView2StringGrid(ListView1, StringGrid1); End;

Эмулирование мыши/клавиатуры, Через SendInput().

Code: Procedure TForm1.Button1Click(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Var. TI:TInput; MI: TMouseInput; P:TPoint; Begin. GetCursorPos(P); MI.dx := P.X; MI.dy := P.Y; MI.mouseData := 0; MI.dwFlags := MOUSEEVENTF_RIGHTDOWN ; MI.time := 10; TI.mi := MI; TI.Itype := INPUT_MOUSE; SendInput(1, TI, SizeOf(TInput)); MI.dwFlags:=MOUSEEVENTF_RIGHTUP; TI.mi := MI; SendInput(1, TI, SizeOf(TInput)); End;

Code: Procedure TForm1.Button1Click(Sender: TObject); Const. SomeText = 'SendInput test.'; Var. TI: TInput; KI: TKeybdInput; I: Integer; Begin. Edit1.SetFocus; TI.Itype := INPUT_KEYBOARD; For I := 1 to Length(SomeText) do. Begin. KI.wVk := Ord(UpCase(SomeText[I])); KI.dwFlags := 0; TI.ki := KI; SendInput(1, TI, SizeOf(TI)); KI.dwFlags := KEYEVENTF_KEYUP; TI.ki := KI; SendInput(1, TI, SizeOf(TI)); End; End;

Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::01613.

Эмуляция многоэкранного режима

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. { In the main program I used a variable named Monitors of type. “array of TstringList” whose dimension is given by the number of buttons. (different monitors available) to keep in memory all the hanldes. Associated with every button. Another variable named CurrentMonitor. Keeps in memory the index of the actual monitor (the caption of the button). This is the code: } Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ProcessView, StdCtrls, Buttons, abfComponents, Menus, ImgList, AppEvnts, TrayIcon; Type. TForm1 = class(TForm). //these are the buttons (1..5) to switch from a monitor to another /// SpeedButton1: TSpeedButton; SpeedButton2: TSpeedButton; SpeedButton3: TSpeedButton; SpeedButton4: TSpeedButton; SpeedButton5: TSpeedButton; /////////////////////////////////////////////////////////////////////// ImageList1: TImageList; //ImageList connected to the Popup menu. PopupMenu1: TPopupMenu; //popup menu displayed by the trayicon. //PopupMenu Items/////// ShowApplication: TMenuItem; //Show the form. HideApplication: TMenuItem; //Hide the form. N1: TMenuItem; // - CloseApplication: TMenuItem; //Close the application. //////////////////////////////// TrayIcon1: TTrayIcon; //my TrayIcon component; you can use yours. Procedure SpeedButton1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); Procedure FormShow(Sender: TObject); Procedure ShowApplicationClick(Sender: TObject); //click on ShowApplication (TMenuItem). Procedure HideApplicationClick(Sender: TObject); //click on HideApplication (TMenuItem). Procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); Procedure CloseApplicationClick(Sender: TObject); //click on CloseApplication (TMenuItem). Private. { Private declarations }. Monitors: array[1..5] of TStringList; CurrentMonitor: Integer; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.SpeedButton1Click(Sender: TObject); Var. I: integer; Rect: TRect; Begin. // GetProcessList; Monitors[CurrentMonitor].Assign(HandleList); For i := 0 to HandleList.Count - 1 do. Begin. ShowWindow(StrToInt(HandleList.Strings[i]), SW_HIDE); End; CurrentMonitor := StrToInt((Sender as TSpeedButton).Caption); For i := 0 to Monitors[CurrentMonitor].Count - 1 do. Begin. ShowWindow(StrToInt(Monitors[CurrentMonitor].Strings[i]), SW_SHOW); End; End; Procedure TForm1.FormCreate(Sender: TObject); Var. I: integer; Begin. // ShowWindow(Application.Handle, SW_HIDE); SetWindowLong(Application.Handle, GWL_EXSTYLE, GetWindowLong(Application.Handle, GWL_EXSTYLE) and. Not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW); ShowWindow(Application.Handle, SW_SHOW); CurrentMonitor := 1; For i := Low(Monitors) to High(Monitors) do. Monitors[i] := TStringList.Create; End; Procedure TForm1.FormDestroy(Sender: TObject); Var. I: integer; Begin. // For i := Low(Monitors) to High(Monitors) do. Monitors[i].Free; End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Var. I, j: integer; Begin. For i := Low(Monitors) to High(Monitors) do. Begin. For j := 0 to Monitors[i].Count - 1 do. Begin. ShowWindow(StrToInt(Monitors[i].Strings[j]), SW_SHOW); End; End; End; Procedure TForm1.FormShow(Sender: TObject); Begin. // Height := 61; Width := 173; Top := Screen.Height - Height - 30; Left := Screen.Width - Width; End; Procedure TForm1.ShowApplicationClick(Sender: TObject); Begin. // Application.MainForm.Show; End; Procedure TForm1.HideApplicationClick(Sender: TObject); Begin. // Application.MainForm.Hide; End; Procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); Begin. // If MessageDlg('Do you want to close Monitors?', mtConfirmation, [mbOK, mbCancel], 0) = mrCancel then. CanClose := False; End; Procedure TForm1.CloseApplicationClick(Sender: TObject); Begin. Close; End; End. { In order to prevent multiple instances of the application I inserted. Some lines of code inside the project source; This is the modified source: } Program Project1; Uses. Forms, Windows, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES}. Var. Atom: integer; Begin. If GlobalFindAtom('Monitors_Procedure_Atom') = 0 then. Atom := GlobalAddAtom('Monitors_Procedure_Atom'). Else. Exit; Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; GlobalDeleteAtom(atom); End. { The GlobalAddAtom function adds a character string to the global atom table. And returns a unique value (an atom) identifying the string. The GlobalFindAtom function searches the global atom table for the. Specified character string and retrieves the global atom associated with that string. If I have already run the programm then the GlobalFindAtom function returns a value. <> 0 because the atom is already present: in this case I abort the execution of the program. Instead, if the GlobalFindAtom function returns 0 then this is the first time I run the. Program, so I create the atom. At the end I delete the atom. In order to remove the button on the taskbar I inserted the following code. Inside the OnCreate event of the form: } {...} ShowWindow( Application.handle, SW_HIDE ); SetWindowLong( Application.handle, GWL_EXSTYLE, GetWindowLong( application.handle, GWL_EXSTYLE ) and. Not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW); ShowWindow( Application.handle, SW_SHOW ); {...} { In order to have a tray icon in the traybar (wich display a menu containing showing, Hiding and closing of the form), I used a component (TTrayIcon), I built a year ago; this is the source: } Unit TrayIcon; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI, extctrls, Menus; Const. WM_SYSTEM_TRAY_NOTIFY = WM_USER + 1; Type TTrayIconMessage =(imClick, imDoubleClick, imMouseDown, ImMouseUp, imLeftClickUp, imLeftDoubleClick, ImRightClickUp, imRightDoubleClick, imNone); Type. TTrayIcon = class(TComponent). Private. { Private declarations }. FData: TNotifyIconData; FIsClicked: Boolean; FIcon: TIcon; FIconList: TImageList; FPopupMenu: TPopupMenu; FTimer: TTimer; FHint: string; FIconIndex: integer; FVisible: Boolean; FHide: Boolean; FAnimate: Boolean; FAppRestore: TTrayIconMessage; FPopupMenuShow: TTrayIconMessage; FApplicationHook: TWindowHook; FOnMinimize: TNotifyEvent; FOnRestore: TNotifyEvent; FOnMouseMove: TMouseMoveEvent; FOnMouseExit: TMouseMoveEvent; FOnMouseEnter: TMouseMoveEvent; FOnClick: TNotifyEvent; FOnDblClick: TNotifyEvent; FOnMouseDown: TMouseEvent; FOnMouseUp: TMouseEvent; FOnAnimate: TNotifyEvent; FOnCreate: TNotifyEvent; FOnDestroy: TNotifyEvent; FOnActivate: TNotifyEvent; FOnDeactivate: TNotifyEvent; Procedure SetHint(Hint: string); Procedure SetHide(Value: Boolean); Function GetAnimateInterval: integer; Procedure SetAnimateInterval(Value: integer); Function GetAnimate: Boolean; Procedure SetAnimate(Value: Boolean); Procedure EndSession; Function ShiftState: TShiftState; Protected. { Protected declarations }. Procedure SetVisible(Value: Boolean); virtual; Procedure DoMessage(var Message: TMessage);virtual; Procedure DoClick; virtual; Procedure DoDblClick; virtual; Procedure DoMouseMove(Shift: TShiftState; X: integer; Y: integer); virtual; Procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual; Procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual; Procedure DoOnAnimate(Sender: TObject); virtual; Procedure Notification(AComponent: TComponent; Operation: TOperation); override; Function ApplicationHookProc(var Message: TMessage): Boolean; Procedure Loaded(); override; Property Data: TNotifyIconData read FData; Public. { Public declarations }. Constructor Create(Owner: TComponent); override; Destructor Destroy; override; Procedure Minimize(); virtual; Procedure Restore(); virtual; Procedure Update(); virtual; Procedure ShowMenu(); virtual; Procedure SetIconIndex(Value: integer); virtual; Procedure SetDefaultIcon(); virtual; Function GetHandle():HWND; Published. { Published declarations }. Property Visible: Boolean read FVisible write SetVisible default false; Property Hint: string read FHint write SetHint; Property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu; Property Hide: Boolean read FHide write SetHide; Property RestoreOn: TTrayIconMessage read FAppRestore write FAppRestore; Property PopupMenuOn: TTrayIconMessage read FPopupMenuShow write FPopupMenuShow; Property Icons: TImageList read FIconList write FIconList; Property IconIndex: integer read FIconIndex write SetIconIndex default 0; Property AnimateInterval: integer read GetAnimateInterval write SetAnimateInterval default 1000; Property Animate: Boolean read GetAnimate write SetAnimate default false; Property Handle: HWND read GetHandle; // Events. Property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize; Property OnRestore: TNotifyEvent read FOnRestore write FOnRestore; Property OnClick: TNotifyEvent read FOnClick write FOnClick; Property OnMouseEnter: TMouseMoveEvent read FOnMouseEnter write FOnMouseEnter; Property OnMouseExit: TMouseMoveEvent read FOnMouseExit write FOnMouseExit; Property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; Property OnMouseUp:TMouseEvent read FOnMouseUp write FOnMouseUp; Property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; Property OnAnimate: TNotifyEvent read FOnAnimate write FOnAnimate; Property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; Property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; Property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; Property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Carlo Pasolini', [TTrayIcon]); End; Constructor TTrayIcon.Create(Owner: TComponent); Begin. Inherited; FIcon := TIcon.Create(); FTimer := TTimer.Create(nil); FIconIndex := 0; FIcon.Assign(Application.Icon); FAppRestore := imDoubleClick; FOnAnimate := DoOnAnimate; FPopupMenuShow := imNone; FVisible := false; FHide := true; FTimer.Enabled := false; FTimer.OnTimer := OnAnimate; FTimer.Interval := 1000; If not (csDesigning in ComponentState) then. Begin. FillChar(FData, sizeof(TNotifyIconData), #0); // memset(&FData, 0, sizeof(TNotifyIconData)); FData.cbSize := sizeof(TNotifyIconData); FData.Wnd := AllocateHWnd(DoMessage); FData.uID := UINT(Self); FData.hIcon := FIcon.Handle; FData.uFlags := NIF_ICON or NIF_MESSAGE; FData.uCallbackMessage := WM_SYSTEM_TRAY_NOTIFY; FApplicationHook := ApplicationHookProc; Update; End; End; //--------------------------------------------------------------------------- Destructor TTrayIcon.Destroy(); Begin. If not (csDesigning in ComponentState) then. Begin. Shell_NotifyIcon(NIM_DELETE, @FData); //booh forse @FData. DeallocateHWnd(FData.Wnd); End; If (Assigned(FIcon)) then. FIcon.Free; If (Assigned(FTimer)) then. FTimer.Free; Inherited; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.Notification(AComponent: TComponent; Operation: TOperation); Begin. Inherited Notification(AComponent, Operation); If Operation = opRemove then. Begin. If (AComponent = FIconList) then. FIconList := nil. Else. If (AComponent = FPopupMenu) then. FPopupMenu := nil; End; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.Loaded(); Begin. Inherited Loaded(); If (not Assigned(FIconList)) then. Begin. FAnimate := false; FIcon.Assign(Application.Icon); End. Else. Begin. FTimer.Enabled := FAnimate; FIconList.GetIcon(FIconIndex, FIcon); End; Update(); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.SetVisible(Value: Boolean); Begin. FVisible := Value; If not (csDesigning in ComponentState) then. Begin. If FVisible then. Begin. If (not Shell_NotifyIcon(NIM_ADD, @FData)) then. Raise EOutOfResources.Create('Cannot Create System Shell Notification Icon'); Hide := true; Application.HookMainWindow(FApplicationHook); End. Else. Begin. If (not Shell_NotifyIcon(NIM_DELETE, @FData)) then. Raise EOutOfResources.Create('Cannot Remove System Shell Notification Icon'); Hide := false; Application.UnhookMainWindow(FApplicationHook); End; End; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.SetHint(Hint: string); Begin. // The new hint must be different than the previous hint and less than. // 64 characters to be modified. 64 is an operating system limit. If ((FHint <> Hint) and (Length(Hint) < 64)) then. Begin. FHint := Hint; StrPLCopy(FData.szTip, Hint, sizeof(FData.szTip) - 1); // If there is no hint then there is no tool tip. If (Length(Hint) <> 0) then. FData.uFlags := FData.uFlags or NIF_TIP. Else. FData.uFlags := FData.uFlags and (not NIF_TIP); Update(); End; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.SetHide(Value: Boolean); Begin. FHide := Value; End; //--------------------------------------------------------------------------- Function TTrayIcon.GetAnimateInterval(): integer; Begin. Result := FTimer.Interval; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.SetAnimateInterval(Value: integer); Begin. FTimer.Interval := Value; End; //--------------------------------------------------------------------------- Function TTrayIcon.GetAnimate(): Boolean; Begin. Result := FAnimate; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.SetAnimate(Value: Boolean); Begin. If (Assigned(FIconList) or (csLoading in ComponentState)) then. FAnimate := Value; If (Assigned(FIconList) and (not (csDesigning in ComponentState))) then. FTimer.Enabled := Value; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.EndSession(); Begin. Shell_NotifyIcon(NIM_DELETE, @FData); End; //--------------------------------------------------------------------------- Function TTrayIcon.ShiftState(): TShiftState; Var. Res: TShiftState; Begin. Res := []; If (GetKeyState(VK_SHIFT) < 0) then. Res := Res + [ssShift]; If (GetKeyState(VK_CONTROL) < 0) then. Res := Res + [ssCtrl]; If (GetKeyState(VK_MENU) < 0) then. Res := Res + [ssAlt]; Result := Res; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.DoMessage(var Message: TMessage); Var. Point: TPoint; Shift: TShiftState; Begin. Case (Message.Msg) of. //begin. WM_QUERYENDSESSION: Message.Result := 1; //break; WM_ENDSESSION: EndSession(); //break; WM_SYSTEM_TRAY_NOTIFY: Case (Message.LParam) of. //begin. WM_MOUSEMOVE: If (Assigned(FOnClick)) then. Begin. Shift := ShiftState(); GetCursorPos(point); DoMouseMove(shift, point.x, point.y); End; //break; WM_LBUTTONDOWN: Begin. Shift := ShiftState(); Shift := shift + [ssLeft]; GetCursorPos(point); DoMouseDown(mbLeft, shift, point.x, point.y); FIsClicked := true; //break; End; WM_LBUTTONUP: Begin. Shift := ShiftState(); Shift := shift + [ssLeft]; GetCursorPos(point); If (Assigned(FOnClick)) then. DoClick(); DoMouseUp(mbLeft, shift, point.x, point.y); If (FAppRestore = imLeftClickUp) then. Restore(); If (FPopupMenuShow = imLeftClickUp) then. ShowMenu(); //break; End; WM_LBUTTONDBLCLK: Begin. DoDblClick(); If (FAppRestore = imLeftDoubleClick) then. Restore(); If (FPopupMenuShow = imLeftDoubleClick) then. ShowMenu(); //break; End; WM_RBUTTONDOWN: Begin. Shift := ShiftState(); Shift := shift + [ssRight]; GetCursorPos(point); DoMouseDown(mbRight, shift, point.x, point.y); //break; End; WM_RBUTTONUP: Begin. Shift := ShiftState(); Shift := shift + [ssRight]; GetCursorPos(point); DoMouseUp(mbRight, shift, point.x, point.y); If (FAppRestore = imRightClickUp) then. Restore(); If (FPopupMenuShow = imRightClickUp) then. ShowMenu(); //break; End; WM_RBUTTONDBLCLK: Begin. DoDblClick(); If (FAppRestore = imRightDoubleClick) then. Restore(); If (FPopupMenuShow = imRightDoubleClick) then. ShowMenu(); //break; End; WM_MBUTTONDOWN: Begin. Shift := ShiftState(); Shift := shift + [ssMiddle]; GetCursorPos(point); DoMouseDown(mbMiddle, shift, point.x, point.y); //break; End; WM_MBUTTONUP: Begin. Shift := ShiftState(); Shift := shift + [ssMiddle]; GetCursorPos(point); DoMouseUp(mbMiddle, shift, point.x, point.y); //break; End; WM_MBUTTONDBLCLK: DoDblClick(); //break; End; End; Inherited Dispatch(Message); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.ShowMenu(); Var. Point: TPoint; Begin. GetCursorPos(point); If (Screen.ActiveForm.Handle <> 0) then. SetForegroundWindow(Screen.ActiveForm.Handle); FPopupMenu.Popup(point.x, point.y); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.DoClick(); Begin. If (FAppRestore = imClick) then. Restore(); If (FPopupMenuShow = imClick) then. ShowMenu(); If (Assigned(FOnClick)) then. FOnClick(Self); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.DoDblClick(); Begin. If (FAppRestore = imDoubleClick) then. Restore(); If (FPopupMenuShow = imDoubleClick) then. ShowMenu(); If (Assigned(FOnDblClick)) then. FOnDblClick(Self); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.DoMouseMove(Shift: TShiftState; X:integer; Y: integer); Begin. If (Assigned(FOnMouseMove)) then. FOnMouseMove(Self, Shift, X, Y); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); Begin. If (FAppRestore = imMouseDown) then. Restore(); If (FPopupMenuShow = imMouseDown) then. ShowMenu(); If (Assigned(FOnMouseDown)) then. FOnMouseDown(Self, Button, Shift, X, Y); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.DoMouseUp(Button: TMouseButton; Shift: TShiftState; X: integer; Y:integer); Begin. If (FAppRestore = imMouseDown) then. Restore(); If (FPopupMenuShow = imMouseDown) then. ShowMenu(); If (Assigned(FOnMouseUp)) then. FOnMouseUp(Self, Button, Shift, X, Y); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.DoOnAnimate(Sender: TObject); Begin. If (IconIndex < FIconList.Count) then. Inc(FIconIndex). Else. FIconIndex := 0; SetIconIndex(FIconIndex); Update(); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.Minimize(); Begin. Application.Minimize(); ShowWindow(Application.Handle, SW_HIDE); If (Assigned(FOnMinimize)) then. FOnMinimize(Self); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.Restore(); Begin. Application.Restore(); ShowWindow(Application.Handle, SW_RESTORE); SetForegroundWindow(Application.Handle); If (Assigned(FOnRestore)) then. FOnRestore(Self); End; //--------------------------------------------------------------------------- Procedure TTrayIcon.Update(); Begin. If not (csDesigning in ComponentState) then. Begin. FData.hIcon := FIcon.Handle; If (Visible = true) then. Shell_NotifyIcon(NIM_MODIFY, @FData); End; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.SetIconIndex(Value: integer); Begin. FIconIndex := Value; If (Assigned(FIconList)) then. FIconList.GetIcon(FIconIndex, FIcon); Update(); End; //--------------------------------------------------------------------------- Function TTrayIcon.ApplicationHookProc(var Message: TMessage): Boolean; Begin. If (Message.Msg = WM_SYSCOMMAND) then. Begin. If (Message.WParam = SC_MINIMIZE) then. Minimize(); If (Message.WParam = SC_RESTORE) then. Restore(); End; Result:= false; End; //--------------------------------------------------------------------------- Procedure TTrayIcon.SetDefaultIcon(); Begin. FIcon.Assign(Application.Icon); Update(); End; //--------------------------------------------------------------------------- Function TTrayIcon.GetHandle(): HWND; Begin. Result := FData.Wnd; End; //--------------------------------------------------------------------------- End.

©Drkb::01865.

Взято с сайта: http://www.swissdelphicenter.ch.

Эффект Блоки

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Эффект 'Блоки' Зависимости: Windows, Classes, Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Собственное написание (Николай федоровских). Дата: 1 июня 2002 г. ***************************************************** } Procedure Blocks(Bitmap: TBitmap; Hor, Ver, MaxOffset: Integer; BackColor: TColor); {вырезаем прямоугольники со сторонами Hor Ver. И копируем их в радиусе MaxOffset}. Function RandomInRadius(Num, Radius: Integer): Integer; Begin. If Random(2) = 0 then. Result := Num + Random(Radius). Else. Result := Num - Random(Radius); End; Var. X, y, xd, yd: Integer; Bmp: TBitmap; Begin. Bmp := TBitmap.Create; Try. Bmp.Assign(Bitmap); Bitmap.Canvas.Brush.Color := BackColor; Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height)); Xd := (Bitmap.Width - 1) div Hor; Yd := (Bitmap.Height - 1) div Ver; Randomize; For x := 0 to xd do. For y := 0 to yd do. BitBlt(Bitmap.Canvas.Handle, RandomInRadius(Hor * x, MaxOffset), RandomInRadius(Ver * y, MaxOffset), Hor, Ver, Bmp.Canvas.Handle, Hor * x, Ver * y, SRCCOPY); Finally. Bmp.Free; End; End; Пример использования: Blocks(FBitmap, FBitmap.Width div 10, FBitmap.Height div 10, 4, clWhite);

Эффект Волны (синусоидальные, вид сбоку).

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Эффект 'Волны' (синусоидальные, вид сбоку). Зависимости: Classes, Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Собственное написание (Николай федоровских). Дата: 1 июня 2002 г. ***************************************************** } Procedure WaveSin(Bitmap: TBitmap; Frequency, Length: Integer; Hor: Boolean; BackColor: TColor); Function Min(A, B: Integer): Integer; Begin. If A < B then. Result := A. Else. Result := B; End; Function Max(A, B: Integer): Integer; Begin. If A > B then. Result := A. Else. Result := B; End; Const. Rad = Pi / 180; Type. TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var. X, y, f: Integer; Dest, Src: pRGB; Bmp: TBitmap; Begin. Bitmap.PixelFormat := pf24Bit; Bmp := TBitmap.create; Try. Bmp.Assign(Bitmap); Bitmap.Canvas.Brush.Color := BackColor; Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height)); For y := 0 to Bmp.Height - 1 do. Begin. Src := Bmp.ScanLine[y]; For x := 0 to Bmp.Width - 1 do. Begin. If Hor then. Begin. F := Min(Max(Round(Sin(x * Rad * Length) * Frequency) + y, 0), Bitmap.Height - 1); Dest := Bitmap.ScanLine[f]; Inc(Dest, x); End. Else. Begin. F := Min(Max(Round(Sin(y * Rad * Length) * Frequency) + x, 0), Bitmap.Width - 1); Dest := Bitmap.ScanLine[y]; Inc(Dest, f); End; Dest^ := Src^; Inc(Src); End; End; Finally. Bmp.free; End; End; Пример использования: WaveSin(FBitmap, FBitmap.Width div 50, FBitmap.Width div 40, True, clWhite);

Эффект Иней (разброс).

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Эффект 'Иней' (разброс). Зависимости: Classes, Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Собственное написание (Николай федоровских). Дата: 1 июня 2002 г. ***************************************************** } Procedure Disorder(Bitmap: TBitmap; Hor, Ver: Integer; BackColor: TColor); Function RandomInRadius(Num, Radius: Integer): Integer; Begin. If Random(2) = 0 then. Result := Num + Random(Radius). Else. Result := Num - Random(Radius); End; Type. TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var. X, y, WW, HH, xr, yr: Integer; Dest1, Dest2, Src1, Src2: PRGB; Bmp: TBitmap; Begin. Randomize; Bitmap.PixelFormat := pf24Bit; Bmp := TBitmap.Create; Try. Bmp.Assign(Bitmap); WW := Bitmap.Width - 1; HH := Bitmap.Height - 1; Bitmap.Canvas.Brush.Color := BackColor; Bitmap.Canvas.FillRect(Rect(0, 0, WW + 1, HH + 1)); For y := 0 to HH do. Begin. For x := 0 to WW do. Begin. Xr := RandomInRadius(x, Hor); Yr := RandomInRadius(y, Ver); If (xr >= 0) and (xr < WW) and (yr >= 0) and (yr < HH) then. Begin. Src1 := Bmp.ScanLine[y]; Src2 := Bmp.ScanLine[yr]; Dest1 := Bitmap.ScanLine[y]; Dest2 := Bitmap.ScanLine[yr]; Inc(Src1, x); Inc(Src2, xr); Inc(Dest1, x); Inc(Dest2, xr); Dest1^ := Src2^; Dest2^ := Src1^; End; End; End; Finally. Bmp.Free; End; End; Пример использования: Disorder(FBitmap, 5, 5, clWhite);

Эффект мозаики

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Эффект 'Мозаика' (пикселизация). Зависимости: Windows, Classes, Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Собственное написание (Николай федоровских). Дата: 1 июня 2002 г. ***************************************************** } Procedure PixelsEffect(Bitmap: TBitmap; Hor, Ver: Word); {функция разбивает изображение на прямоугольники (ширина - Hor; высота - Ver). И закрашивает эти прямоугольники средним цветом, Используя среднеарифметическое составляющих}. Function Min(A, B: Integer): Integer; Begin. If A < B then. Result := A. Else. Result := B; End; Type. TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var. I, j, x, y, xd, yd, Rr, gg, bb, h, hx, hy: Integer; Dest: pRGB; Begin. Bitmap.PixelFormat := pf24Bit; If (Hor = 1) and (Ver = 1) then. Exit; Xd := (Bitmap.Width - 1) div Hor; Yd := (Bitmap.Height - 1) div Ver; For i := 0 to xd do. For j := 0 to yd do. Begin. H := 0; Rr := 0; Gg := 0; Bb := 0; Hx := Min(Hor * (i + 1), Bitmap.Width - 1); Hy := Min(Ver * (j + 1), Bitmap.Height - 1); For y := j * Ver to hy do. Begin. Dest := Bitmap.ScanLine[y]; Inc(Dest, i * Hor); For x := i * Hor to hx do. Begin. Inc(rr, Dest^.R); Inc(gg, Dest^.G); Inc(bb, Dest^.B); Inc(h); Inc(Dest); End; End; Bitmap.Canvas.Brush.Color := RGB(rr div h, gg div h, bb div h); Bitmap.Canvas.FillRect(Rect(i * Hor, j * Ver, hx + 1, hy + 1)); End; End; Пример использования: PixelsEffect(FBitmap, 8, 8);

Эффект потухания текста

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

Как узнать, подключён ли компьютер к сети?

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. If GetSystemMetrics(SM_NETWORK) and $01 = $01 then. ShowMessage('Computer is attached to a network!'). Else. ShowMessage('Computer is not attached to a network!'); End;

Как запустить консольное приложение и перехватить вывод?

Code: Procedure ExecCmdine(const CmdLine: string; CmdResult: TStrings); Var. Output: PIOFile; Buffer: PChar; TempString: string; Line: string; BytesRead: Integer; Const. BufferSize: Integer = 1000; Begin. Output := popen(PChar(CmdLine), 'r'); GetMem(Buffer, BufferSize); If Assigned(Output) then. Try. While feof(Output) = 0 do. Begin. BytesRead := Libc.fread(Buffer, 1, BufferSize, Output); SetLength(TempString, Length(TempString)+BytesRead); Memcpy(@TempString[length(TempString)-(BytesRead-1)], Buffer, BytesRead); While Pos(#10, TempString) > 0 do. Begin. Line := Copy(TempString, 1, Pos(#10, TempString)-1); If CmdResult<>nil then CmdResult.Add(Line); TempString := copy(TempString, Pos(#10, TempString)+1, Length(TempString)); End; End; Finally. Libc.pclose(output); Wait(nil); FreeMem(Buffer,BufferSize); End; End;

Как узнать загрузку CPU определённым процессом?

В коде используется функция ExecCmdine из статьи: Как запустить консольное приложение и перехватить вывод?

Code: Procedure ReadProcLoad(Pid:string; var CPU, Mem:string); Var t:TStringList; S:string; Function GetLine:string; Var i:integer; Begin. For i:=0 to t.Count-1 do. If (pos(Pid, t[i])<10) and (pos(Pid, t[i])>0) then Result:=t[i]; End; Begin. T:=TStringList.Create; Try. ExecCmdine('top -n1 p '+PID, t); Try. S:=GetLine; S:=GetBefore(':',s); S:=trim(copy(s,1,lastDelimiter(' ',s))); Mem:=trim(copy(s,lastDelimiter(' ',s), length(s))); S:=trim(copy(s,1,lastDelimiter(' ',s))); CPU:=trim(copy(s,lastDelimiter(' ',s), length(s))); Except. CPU:='-1'; Mem:='-1'; End. Finally. T.Free; End; End;

Как узнать расход памяти процессом?

Расход памяти можно прочитать из виртуального файла.

/proc/Pid/status.

Где Pid - номер процесса.

Code: Function ReadProcData(Pid:string; var VmSize, VmLck, VmRSS, VmData, VmStk, VmExe, VmLib, ProcName:string):boolean; Var f:TextFile; S, stat:string; I:integer; Function getbefore(substr, str:string):string; Begin. If pos(substr,str)>0 then result:=copy(str,1,pos(substr,str)-1). Else result:=''; End; Function getafter(substr, str:string):string; Begin. If pos(substr,str)>0 then result:=copy(str,pos(substr,str)+length(substr),length(str)). Else result:=''; End; Begin. Result:=False; FileMode:=0; VmSize:='-1'; VmLck:='-1'; VmRSS:='-1'; VmData:='-1'; VmStk:='-1'; VmExe:='-1'; VmLib:='-1'; ProcName:=''; Try. Try. Try. AssignFile(f,'/proc/'+Pid+'/status'); Reset(f); While not eof(f) do. Begin. Readln(f, s); If pos('VmSize', s)>0 then VmSize:=GetBefore(' ',trim(GetAfter(':',s))); If pos('VmLck', s)>0 then VmLck:=GetBefore(' ',trim(GetAfter(':',s))); If pos('VmRSS', s)>0 then VmRSS:=GetBefore(' ',trim(GetAfter(':',s))); If pos('VmData', s)>0 then VmData:=GetBefore(' ',trim(GetAfter(':',s))); If pos('VmStk', s)>0 then VmStk:=GetBefore(' ',trim(GetAfter(':',s))); If pos('VmExe', s)>0 then VmExe:=GetBefore(' ',trim(GetAfter(':',s))); If pos('VmLib', s)>0 then VmLib:=GetBefore(' ',trim(GetAfter(':',s))); If pos('Name', s)>0 then ProcName:=trim(GetAfter(':',s)); End; Finally. Closefile(f); End; Finally. FileMode:=2; End; Result:=True; Except. End; End;

Как узнать имя компьютера?

Code: Uses Libc; Function GetPCName:string; Var Name:PChar; Len:Cardinal; Begin. Len:=255; GetMem(Name, Len); Gethostname(Name, Len); Result:=String(Name); FreeMem(Name); End;

Как узнать свободное место на диске?

В коде используется функция ExecCmdine из статьи: Как запустить консольное приложение и перехватить вывод?

Code: Function GetFreeSpace(Share:string):integer; {in Kb}. Var t:TstringList; I:integer; Temp:string; Mesure:char; Multi:integer; F:real; Function getbefore(substr, str:string):string; Begin. If pos(substr,str)>0 then result:=copy(str,1,pos(substr,str)-1). Else result:=''; End; Function getafter(substr, str:string):string; Begin. If pos(substr,str)>0 then result:=copy(str,pos(substr,str)+length(substr),length(str)). Else result:=''; End; Begin. Result:=-1; T:=TstringList.Create; ExecCmdine('df -h', t); For i:=0 to t.Count-1 do. If pos(Share, t[i])=1 then. Begin. Temp:=trim(GetAfter(Share, t[i])); Temp:=trim(GetAfter(' ', temp)); Temp:=trim(GetAfter(' ', temp)); Temp:=trim(GetBefore(' ', temp)); If temp='' then exit; Mesure:=temp[length(temp)]; Case mesure of. 'G','g':multi:=1024*1024; 'M','m':multi:=1024; 'K','k':multi:=1; Else multi:=0; End; Try. F:=strtofloat(copy(temp,1,length(temp)-1)); Except. F:=0; End; Result:=Round(f*multi); End; End;

Как сделать Ping?

В коде используется функция ExecCmdine из статьи: Как запустить консольное приложение и перехватить вывод?

Code: Function Ping(host:string):boolean; Var params, CommandLine:string; T:TStringList; I:integer; Begin. Params := Format('-s%d ', [32]); Params := Params+Format('-c%d ', [1]); CommandLine := Format('ping %s%s', [Params, host]); T:=TStringList.Create; ExecCmdine(CommandLine, t); Result:=pos('1 received, 0% packet loss', t.text)>0; T.free; End;

Модуль CRT для Linux.

Code: { LinCRT Kylix unit v 1.0. Author: Andrei Borovsky, aborovsky@mtu-net.ru. Copyright (c) 2002 Andrei Borovsky. Permission is hereby granted, free of charge, to any person obtaining a. Copy of this software and associated documentation files (the. "Software"), to deal in the Software without restriction, including. Without limitation the rights to use, copy, modify, merge, publish, Distribute, distribute with modifications, sublicense, and/or sell. Copies of the Software, and to permit persons to whom the Software is. Furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included. In all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESSED. OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF. MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR. OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR. THE USE OR OTHER DEALINGS IN THE SOFTWARE. Except as contained in this notice, the name(s) of the above copyright. Holders shall not be used in advertising or otherwise to promote the. Sale, use or other dealings in this Software without prior written. Authorization. } Unit LinCRT; Interface. Uses. Libc, NCurses; Const. // Pseudocharacter values returned by GetKey. BS = 127; // Backspace. LF = 10; TAB = 9; ESC = 27; KLArrow = 260; KRArrow = 261; KDArrow = 258; KUArrow = 259; KHome = 262; KBkSp = 263; // Another Backspace code. Curses.h. // says this value is unreliable (true ;-)). KEnd = 264; KF1 = 265; KF2 = 266; KF3 = 267; KF4 = 268; KF5 = 269; KF6 = 270; KF7 = 271; KF8 = 272; KF9 = 273; KF10 = 274; KF11 = 275; KF12 = 276; KDel = 330; KIns = 331; KPgDn = 338; KPgUp = 339; MLButtonDown = 501; MLButtonUp = 502; MLButtonClk = 503; MLButtonDblClk = 504; MMButtonDown = 505; MMButtonUp = 506; MMButtonClk = 507; MMButtonDblClk = 508; MRButtonDown = 509; MRButtonUp = 510; MRButtonClk = 511; MRButtonDblClk = 512; MMouseMoved = 561; // not supported yet. // Color constants. Black = 0; Red = 1; Green = 2; Brown = 3; Blue = 4; Magenta = 5; Cyan = 6; Gray = 7; LightGray = 7; DarkGray = 7; LightRed = 9; LightGreen = 10; Yellow = 11; LightBlue = 12; LightMagenta = 13; LightCyan = 14; White = 15; Blink = 128; // Additional attributes constants. // (as returned by GetAddAttrXY). AUnderline = 2; AInverse = 4; Type. TOnTermResizeProc = procedure(DoingInput : Boolean); Var. StdScr, CurWnd : PWINDOW; OnTermResize : TOnTermResizeProc; ScrCols, ScrLines : Integer; WindMin, WindMax : Integer; TextAttr : Byte; Inverse, Underline : Boolean; ScrollWnd : Boolean; BreakOnResize, Broken : Boolean; // Clears up to the end of the current line. Procedure ClrEol; // Clears current window. Procedure ClrScr; // Deletes current character. Procedure DelChar; // Deletes current line. Procedure DelLine; // Finishes with LinCRT. Procedure DoneLinCRT; // Returns additional attributes. Function GetAddAttrXY(X, Y : Byte) : Byte; // Returns character at the specified position. Function GetCharXY(X, Y : Byte) : Char; // Returns character color at the specified position. Function GetColorXY(X, Y : Byte) : Byte; // Reads the key from the mouse or keyboard. Function GetKey : Word; // Sets the cursor position within the current window. Procedure GotoXY(X, Y : Byte); // Initializes the library. Procedure InitLinCRT; // Initializes mouse handling. Procedure InitMouse; // Inserts character in the current position. Procedure InsChar(Ch : Char); // Inserts new line in the current position. Procedure InsLine; // Determines if the key has been pressed. Function KeyPressed : Boolean; // Finishes mouse handling. Procedure KillMouse; // Checks if the mouse event occured within the current winodw. Function MouseTrapped : Boolean; // Puts character in the current position. Procedure PutChar(Ch : Char); // Puts character in the position X, Y. Procedure PutCharXY(Ch : Char; X, Y : Byte); // Reads the key from the keyboard. Function ReadKey : Char; // Sets or disables window scrollng. Procedure SetScrollWnd(b : Boolean); // Sets text and background colors. Procedure SetColors(Fg, Bg : Byte); // Starts the copy of the shell. Procedure ShellOut(Cmd : PChar); // Sets background color. Procedure TextBackground(Color : Byte); // Sets text color. Procedure TextColor(Color : Byte); // Returns the mouse position at the last mouse event. Function WhereMouseXY : Word; // Returns the curent X position. Function WhereX : Byte; // Returns the curent Y position. Function WhereY : Byte; // Opens the new window. Procedure Window(X1, Y1, X2, Y2 : Byte); Implementation. Const. BUF_SIZE = 1024; STACK_SIZE = 64; // This value is the number of color pairs. // supported by ncurses. Type. TXtAttr = record. Fg, Bg, PairNum : Byte; End; Var. IOBuf : array[0..BUF_SIZE] of Byte; PairStack : array[0..STACK_SIZE-1] of TXtAttr; StackHead : Integer; MouseEvent : MEVENT; SpKey : Byte; DoingInput, Intr : Boolean; // Internal routines. Procedure winch_handler( SigNum : Integer); stdcall; Begin. If BreakOnResize then Intr := True; Endwin; Wrefresh(StdScr); ScrCols := StdScr._maxx; ScrLines := StdScr._maxy; If CurWnd <> StdScr then delwin(CurWnd); Endwin; Wrefresh(StdScr); CurWnd :=StdScr; If Assigned(OnTermResize) then OnTermResize(DoingInput); End; Function GetPair(Fg, Bg : Byte) : Integer; Var. I, Pos : Integer; Begin. Pos := -1; For i := 0 to StackHead do. If (PairStack[i].Fg = Fg) and (PairStack[i].Bg = Bg) then. Begin. Pos := i; Break; End; If Pos < 0 then. Begin. Pos := StackHead; If StackHead < (STACK_SIZE - 1) then. Begin. Inc(StackHead); Init_pair(StackHead+1, Fg, Bg); PairStack[StackHead].PairNum := StackHead+1; PairStack[StackHead].Fg := Fg; PairStack[StackHead].Bg := Bg; Pos := StackHead; End; End; Result := PairStack[Pos].PairNum; End; Procedure SetAttrs; Var. Pn : Integer; Begin. Pn := GetPair(TextAttr and 7, (TextAttr and 112) shr 4); Wattrset(CurWnd, COLOR_PAIR(Pn)); CurWnd._bkgd := (Pn shl 8) + 32; If (TextAttr and 128) <> 0 then. Set_attr(CurWnd, A_BLINK); If (TextAttr and 8) <> 0 then. Set_attr(CurWnd, A_BOLD); If Underline then set_attr(CurWnd, A_UNDERLINE); If Inverse then set_attr(CurWnd, A_REVERSE); End; Function TranslateMEvent : Word; Begin. Case MouseEvent.bstate of. BUTTON1_RELEASED : Result := mLButtonUp; BUTTON1_PRESSED : Result := mLButtonDown; BUTTON1_CLICKED : Result := mLButtonClk; BUTTON1_DOUBLE_CLICKED : Result := mLButtonDblClk; BUTTON2_RELEASED : Result := mRButtonUp; BUTTON2_PRESSED : Result := mRButtonDown; BUTTON2_CLICKED : Result := mRButtonClk; BUTTON2_DOUBLE_CLICKED : Result := mRButtonDblClk; BUTTON3_RELEASED : Result := mMButtonUp; BUTTON3_PRESSED : Result := mMButtonDown; BUTTON3_CLICKED : Result := mMButtonClk; BUTTON3_DOUBLE_CLICKED : Result := mMButtonDblClk; REPORT_MOUSE_POSITION : Result := mMouseMoved; End; End; Procedure DefineKey(c1, c2, c3 : Byte; Code : Word); Var. Seq : array[0..4] of Byte; Begin. Seq[0] := 27; Seq[1] := c1; Seq[2] := c2; Seq[3] := c3; Seq[4] := 0; Define_key(@Seq[0], Code); End; (* Here we initiate some pseudocharacter values that. For some reason are not initiated by ncurses itself. (at leas on my system). You may add/remove some. Key definitions here, if your program requires this. Note, that on any terminal there is a sequence that. Will not be enterpreted correctly. *) Procedure DefineKeys; Begin. DefineKey(91, 91, 65, kF1); DefineKey(91, 91, 66, kF2); DefineKey(91, 91, 67, kF3); DefineKey(91, 91, 68, kF4); DefineKey(91, 91, 69, kF5); DefineKey(91, 70, 0, kEnd); DefineKey(91, 72, 0, kHome); DefineKey(91, 49, 126, kHome); DefineKey(91, 52, 126, kEnd); End; Function TranslateCodes(C : Word) : Byte; Begin. Case C of. KF1 : Result := 59; KF2 : Result := 60; KF3 : Result := 61; KF4 : Result := 62; KF5 : Result := 63; KF6 : Result := 64; KF7 : Result := 65; KF8 : Result := 66; KF9 : Result := 67; KF10 : Result := 68; KF11 : Result := 69; KF12 : Result := 70; KHome : Result := 71; KUArrow : Result := 72; KPgUp : Result := 73; KLArrow : Result := 75; KRArrow : Result := 77; KEnd : Result := 79; KDArrow : Result := 80; KPgDn : Result := 81; KIns : Result := 82; KDel : Result := 83; Else Result := 0; End; End; Function wread(Win : PWINDOW; Buf : PChar; n : Integer) : Integer; Var. Tx, ty : Word; Count, ch : Integer; Begin. Intr := False; Broken := False; Noecho; Cbreak; Nodelay(Win, True); Count := 0; Tx := Win._curx; Ty := Win._cury; Waddch(Win, 32); Win._cury := ty; Win._curx := tx; Wrefresh(Win); Ch := 0; While ch <> 10 do. Begin. If Intr then. Begin. Result := 0; Broken := True; Buf[Count] := #0; Exit; End; Ch := wgetch(Win); Case ch of. 32..126, 128..255 : Begin. Waddch(Win, ch); Tx := Win._curx; Ty := Win._cury; Waddch(Win, 32); Win._cury := ty; Win._curx := tx; Wrefresh(Win); Buf[Count] := Char(Lo(ch)); Inc(Count); If Count = (n - 1) then. Begin. Buf[Count] := #0; Result := 0; Exit; End; End; BS, kBkSp, kLArrow : Begin. Tx := Win._curx; Ty := Win._cury; If Count > 0 then. Begin. If tx > 0 then Dec(tx). Else if ty > 0 then. Begin. Dec(ty); Tx := Win._maxx; End; Win._curx := tx; Win._cury := ty; Waddch(Win, 32); Win._curx := tx; Win._cury := ty; Wrefresh(Win); Dec(Count); End; End; End; End; Buf[Count] := #0; Waddch(Win, 10); Result := 0; End; // Text file driver routines. Function NCInOut(var F : Text) : Integer; Begin. SetAttrs; With TTextRec(F) do. Begin. If Mode = fmOutput then. Begin. IOBuf[BufPos] := 0; Waddstr(CurWnd, @IOBuf[0]); BufPos := 0; Result := 0; End else. If Mode = fmInput then. Begin. DoingInput := True; Echo; Nocbreak; Nodelay(CurWnd, False); //wgetnstr(CurWnd, @IOBuf[0], BUF_SIZE-2); Wread(CurWnd, @IOBuf[0], BUF_SIZE-1); BufEnd := __strlen(@IOBuf[0])+1; If BufEnd < BUF_SIZE then IOBuf[BufEnd-1] := 10; BufPos := 0; Noecho; Cbreak; Nodelay(CurWnd, True); DoingInput := False; Result := 0; End; End; End; Function NCFlush(var F : Text) : Integer; Begin. With TTextRec(F) do. Begin. If Mode = fmOutput then. Begin. SetAttrs; IOBuf[BufPos] := 0; Waddstr(CurWnd, @IOBuf[0]); Wrefresh(CurWnd); BufPos := 0; End else. Begin. BufEnd := 0; FillChar(IOBuf[0], BUF_SIZE, 0); BufPos := 0; End; End; Result := 0; End; Function NCClose(var F : Text) : Integer; Begin. TTextRec(F).Mode := fmClosed; Result := 0; End; Function NCOpen(var F : Text) : Integer; Begin. With TTextRec(F) do. Begin. If Mode = fmInOut then Mode := fmOutput; InOutFunc := @NCInOut; FlushFunc := @NCFlush; CloseFunc := @NCClose; Result:=0; End; Result := 0; End; Procedure AssignLinCRT(var F : Text); Begin. With TTextRec(F) do. Begin. Mode := fmClosed; BufSize := BUF_SIZE; BufPtr := @IOBuf[0]; OpenFunc := @NCOpen; InOutFunc := nil; FlushFunc := nil; CloseFunc := nil; Name[0] := #0; End; End; // Public LinCRT routines. Procedure ClrEol; Begin. SetAttrs; Wclrtoeol(CurWnd); Wrefresh(CurWnd); End; Procedure ClrScr; Begin. SetAttrs; Wclear(CurWnd); End; Procedure DelChar; Begin. Wdelch(CurWnd); Wrefresh(CurWnd); End; Procedure DelLine; Begin. Wdeleteln(CurWnd); Wrefresh(CurWnd); End; Procedure DoneLinCRT; Begin. Endwin; End; Function GetAddAttrXY(X, Y : Byte) : Byte; Var. Tx, ty : Integer; Begin. Tx := CurWnd._curx; Ty := CurWnd._cury; CurWnd._curx := X - 1; CurWnd._cury := Y - 1; Result := Lo(winch(CurWnd) shr 16); CurWnd._curx := tx; CurWnd._cury := ty; End; Function GetCharXY(X, Y : Byte) : Char; Var. Tx, ty : Integer; Begin. Tx := CurWnd._curx; Ty := CurWnd._cury; CurWnd._curx := X - 1; CurWnd._cury := Y - 1; Result := Char(Lo(winch(CurWnd))); CurWnd._curx := tx; CurWnd._cury := ty; End; Function GetColorXY(X, Y : Byte) : Byte; Var. Tx, ty : Integer; Begin. Tx := CurWnd._curx; Ty := CurWnd._cury; CurWnd._curx := X - 1; CurWnd._cury := Y - 1; Result := Lo(winch(CurWnd) shr 8); CurWnd._curx := tx; CurWnd._cury := ty; End; Function GetKey : Word; Var. Key : Integer; Begin. // If You have some problems with GetKey, // see the note above the DefineKeys procedure. Noecho; Nodelay(CurWnd, False); Cbreak; Key := wgetch(CurWnd); If Key = KEY_MOUSE then. Begin. Getmouse(MouseEvent); Key := TranslateMEvent; End; Result := Key; End; Procedure GotoXY(X, Y : Byte); Begin. If (X > 0) and (X < (CurWnd._maxx+2)) then. CurWnd._curx := X - 1; If (Y > 0) and (Y < (CurWnd._maxy+2)) then. CurWnd._cury := Y - 1; Wrefresh(CurWnd); // wmove(CurWnd, Y-1, X-1); End; Procedure InitLinCRT; Begin. StdScr := initscr; ScrCols := StdScr._maxx; ScrLines := StdScr._maxy; CurWnd := StdScr; WindMin := Lo(CurWnd._begx) + (Lo(CurWnd._begy) shl 8); WindMax := Lo(CurWnd._maxx) + (Lo(CurWnd._maxy) shl 8); Start_color; OnTermResize := nil; Signal(SIGWINCH, @winch_handler); TextAttr := 7; Inverse := False; Underline := False; StackHead := -1; BreakOnResize := False; Broken := False; DoingInput := False; ScrollWnd := True; AssignLinCRT(Input); Reset(Input); AssignLinCRT(Output); ReWrite(Output); Keypad(StdScr, True); DefineKeys; SpKey := 0; Intr := False; End; Procedure InitMouse; Var. Mask, oldmask : Integer; Begin. Mask := BUTTON1_RELEASED or BUTTON1_PRESSED or BUTTON1_CLICKED or. BUTTON1_DOUBLE_CLICKED; Mask := mask or BUTTON2_RELEASED or BUTTON2_PRESSED or BUTTON2_CLICKED or. BUTTON2_DOUBLE_CLICKED; Mask := mask or BUTTON3_RELEASED or BUTTON3_PRESSED or BUTTON3_CLICKED or. BUTTON3_DOUBLE_CLICKED; // if TrackMove then mask := mask or REPORT_MOUSE_POSITION; Mousemask(mask, oldmask); End; Procedure InsChar(Ch : Char); Begin. SetAttrs; Winsch(CurWnd, Integer(Ch)); Wrefresh(CurWnd); End; Procedure InsLine; Begin. SetAttrs; Winsdelln(CurWnd, 1); Wrefresh(CurWnd); End; Function KeyPressed : Boolean; Var. Ch : chtype; Begin. Noecho; Nodelay(CurWnd, True); Cbreak; Result := False; Ch := wgetch(CurWnd); If ch <> ERR then. Begin. Ungetch(ch); Result := True; End; End; Procedure KillMouse; Var. Oldmask : Integer; Begin. Mousemask(0, oldmask); End; Function MouseTrapped : Boolean; Begin. Result := wenclose(CurWnd, MouseEvent.y, MouseEvent.x); End; Procedure PutChar(Ch : Char); Var. Tx, ty : Integer; Begin. Scrollok(CurWnd, False); Tx := CurWnd._curx; Ty := CurWnd._cury; SetAttrs; Waddch(CurWnd, Byte(Ch)); CurWnd._curx := tx; CurWnd._cury := ty; Wrefresh(CurWnd); Scrollok(CurWnd, ScrollWnd); End; Procedure PutCharXY(Ch : Char; X, Y : Byte); Var. Tx, ty : Integer; Begin. Scrollok(CurWnd, False); Tx := CurWnd._curx; Ty := CurWnd._cury; CurWnd._curx := X-1; CurWnd._cury := Y-1; SetAttrs; Waddch(CurWnd, Byte(Ch)); CurWnd._curx := tx; CurWnd._cury := ty; Wrefresh(CurWnd); Scrollok(CurWnd, ScrollWnd); End; Function ReadKey : Char; Var. Ch : chtype; Begin. If SpKey <> 0 then. Begin. Result := Char(SpKey); SpKey := 0; Exit; End; Noecho; Nodelay(CurWnd, False); Cbreak; Ch := wgetch(CurWnd); If ch > 255 then. Begin. SpKey := TranslateCodes(ch); Ch := 0; End; Result := Char(Lo(ch)); End; Procedure SetColors(Fg, Bg : Byte); Begin. TextAttr := TextAttr and (255 - 112); TextAttr := TextAttr or (Bg shl 4); If Fg = Blink then TextAttr := TextAttr or Blink. Else. Begin. TextAttr := TextAttr and 127; TextAttr := TextAttr and (255 - 15); TextAttr := TextAttr or Fg; End; End; Procedure SetScrollWnd(b : Boolean); Begin. ScrollWnd := b; Scrollok(CurWnd, ScrollWnd); End; Procedure ShellOut(Cmd : PChar); Begin. Def_prog_mode; Endwin; Libc.system(Cmd); Wrefresh(StdScr); Wrefresh(CurWnd); End; Procedure TextBackground(Color : Byte); Begin. TextAttr := TextAttr and (255 - 112); TextAttr := TextAttr or (Color shl 4); End; Procedure TextColor(Color : Byte); Begin. If Color = Blink then TextAttr := TextAttr or Blink. Else. Begin. TextAttr := TextAttr and 127; TextAttr := TextAttr and (255 - 15); TextAttr := TextAttr or Color; End; End; Function WhereMouseXY : Word; Var. X, Y : Integer; Begin. X := MouseEvent.x; Y := MouseEvent.y; Wmouse_trafo(StdScr, Y, X, False); Result := Lo(X) +1 + ((Lo(Y) + 1) shl 8); End; Function WhereX : Byte; Begin. Result := Lo(CurWnd._curx + 1); End; Function WhereY : Byte; Begin. Result := Lo(CurWnd._cury + 1); End; Procedure Window(X1, Y1, X2, Y2 : Byte); Var. Tmp : PWINDOW; Begin. Tmp := CurWnd; CurWnd := newwin(Y2-Y1+1, X2-X1+1, Y1-1, X1-1); If CurWnd = nil then CurWnd := Tmp. Else if Tmp <> StdScr then delwin(Tmp); WindMin := Lo(CurWnd._begx) + (Lo(CurWnd._begy) shl 8); WindMax := Lo(CurWnd._maxx) + (Lo(CurWnd._maxy) shl 8); Scrollok(CurWnd, ScrollWnd); SetAttrs; Keypad(CurWnd, True). End; Initialization. // dummy. Finalization. Endwin; End. {*********************************************} { ncurses interface unit. Parts of this file are translated from ncurses header file curses.h. Copyright (c) 1998,1999,2000 Free Software Foundation, Inc. Translator: Andrei Borovsky - aborovsky@mtu-net.ru. This traslation is by no means complete. I have included here only those ncurses functions that. Are used (or are planned to be used) in my LinCRT unit. I have also added here some routines and constants that. I've found useful with ncurses. } Unit NCurses; Interface. Const. ERR = -1; {$EXTERNALSYM ERR}. OK = 0; {$EXTERNALSYM OK}. KEY_MOUSE = $199; {$EXTERNALSYM KEY_MOUSE}. BUTTON1_RELEASED = $1; {$EXTERNALSYM BUTTON1_RELEASED}. BUTTON1_PRESSED = $2; {$EXTERNALSYM BUTTON1_PRESSED}. BUTTON1_CLICKED = $4; {$EXTERNALSYM BUTTON1_CLICKED}. BUTTON1_DOUBLE_CLICKED = $8; {$EXTERNALSYM BUTTON1_DOUBLE_CLICKED}. BUTTON2_RELEASED = $40; {$EXTERNALSYM BUTTON2_RELEASED}. BUTTON2_PRESSED = $80; {$EXTERNALSYM BUTTON2_PRESSED}. BUTTON2_CLICKED = $100; {$EXTERNALSYM BUTTON2_CLICKED}. BUTTON2_DOUBLE_CLICKED = $200; {$EXTERNALSYM BUTTON2_DOUBLE_CLICKED}. BUTTON3_RELEASED = $1000; {$EXTERNALSYM BUTTON3_RELEASED}. BUTTON3_PRESSED = $2000; {$EXTERNALSYM BUTTON3_PRESSED}. BUTTON3_CLICKED = $4000; {$EXTERNALSYM BUTTON3_CLICKED}. BUTTON3_DOUBLE_CLICKED = $8000; {$EXTERNALSYM BUTTON3_DOUBLE_CLICKED}. REPORT_MOUSE_POSITION = $8000000; {$EXTERNALSYM REPORT_MOUSE_POSITION}. COLOR_BLACK = 0; {$EXTERNALSYM COLOR_BLACK}. COLOR_RED = 1; {$EXTERNALSYM COLOR_RED}. COLOR_GREEN = 2; {$EXTERNALSYM COLOR_GREEN}. COLOR_YELLOW = 3; {$EXTERNALSYM COLOR_YELLOW}. COLOR_BLUE = 4; {$EXTERNALSYM COLOR_BLUE}. COLOR_MAGENTA = 5; {$EXTERNALSYM COLOR_MAGENTA}. COLOR_CYAN = 6; {$EXTERNALSYM COLOR_CYAN}. COLOR_WHITE = 7; {$EXTERNALSYM COLOR_WHITE}. A_STANDOUT = 1 shl 16; {$EXTERNALSYM A_STANDOUT}. A_UNDERLINE = 1 shl 17; {$EXTERNALSYM A_UNDERLINE}. A_REVERSE = 1 shl 18; {$EXTERNALSYM A_REVERSE}. A_BLINK = 1 shl 19; {$EXTERNALSYM A_BLINK}. A_DIM = 1 shl 20; {$EXTERNALSYM A_DIM}. A_BOLD = 1 shl 21; {$EXTERNALSYM A_BOLD}. A_ALTCHARSET = 1 shl 22; {$EXTERNALSYM A_ALTCHARSET}. A_INVIS = 1 shl 23; {$EXTERNALSYM A_INVIS}. Type. Chtype = Integer; {$EXTERNALSYM chtype}. PChtype = ^chtype; Attr_t = chtype; {$EXTERNALSYM attr_t}. NCURSES_COLOR_T = Word; {$EXTERNALSYM NCURSES_COLOR_T}. NCURSES_SIZE_T = Word; {$EXTERNALSYM NCURSES_SIZE_T}. Mmask_t = Integer; {$EXTERNALSYM mmask_t}. MEVENT = record. Id : Word; X, y, z : Integer; Bstate : mmask_t; End; {$EXTERNALSYM MEVENT}. Ldat = record. Text : PChtype; Firstchar : NCURSES_SIZE_T; Lastchar : NCURSES_SIZE_T; Oldindex : NCURSES_SIZE_T; End; {$EXTERNALSYM ldat}. PLdat = ^ldat; Pdat = record. _pad_y, _pad_x : NCURSES_SIZE_T; _pad_top, _pad_left : NCURSES_SIZE_T; _pad_bottom, _pad_right : NCURSES_SIZE_T; End; {$EXTERNALSYM pdat}. PWINDOW = ^_win_st; _win_st = record. _cury, _curx : NCURSES_SIZE_T; _maxy, _maxx : NCURSES_SIZE_T; _begy, _begx : NCURSES_SIZE_T; _flags : Word; _attrs : attr_t; _bkgd : chtype; _notimeout : Boolean; _clear : Boolean; _leaveok : Boolean; _scroll : Boolean; _idlok : Boolean; _idcok : Boolean; _immed : Boolean; _sync : Boolean; _use_keypad : Boolean; _delay : Integer; _line : PLdat; _regtop : NCURSES_SIZE_T; _regbottom : NCURSES_SIZE_T; _parx : Integer; _pary : Integer; _parent : PWINDOW; _pad : pdat; _yoffset : NCURSES_SIZE_T; End; {$EXTERNALSYM _win_st}. WINDOW = _win_st; {$EXTERNALSYM WINDOW}. Function cbreak : Integer; cdecl; {$EXTERNALSYM cbreak}. Function COLOR_PAIR(n : Integer) : Integer; Function def_prog_mode : Integer; cdecl; {$EXTERNALSYM def_prog_mode}. Function define_key(definitions : PChar; keycode : Integer) : Integer; cdecl; {$EXTERNALSYM define_key}. Function delwin(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM delwin}. Function echo : Integer; cdecl; {$EXTERNALSYM echo}. Function endwin : Integer; cdecl; {$EXTERNALSYM endwin}. Function erasechar : Integer; cdecl; {$EXTERNALSYM erasechar}. Function getmouse(var event : MEVENT) : Integer; cdecl; {$EXTERNALSYM getmouse}. Function getyx(win : PWINDOW; var y, x : Word) : Integer; {$EXTERNALSYM getyx}. Function init_pair(pair, f, b : Word) : Integer; cdecl; //i. {$EXTERNALSYM init_pair}. Function initscr : PWINDOW; cdecl; {$EXTERNALSYM initscr}. Function keypad(win : PWINDOW; b : Boolean) : Integer; cdecl; {$EXTERNALSYM keypad}. Function leaveok(win : PWINDOW; b : Boolean) : Integer; cdecl; {$EXTERNALSYM leaveok}. Function mousemask(newmask : mmask_t; var oldmask : mmask_t) : mmask_t; cdecl; {$EXTERNALSYM mousemask}. Function mvwaddch(win : PWINDOW; y, x : Integer; ch : chtype) : Integer; cdecl; {$EXTERNALSYM mvwaddch}. Function mvwin(win : PWINDOW; y, x : Integer) : Integer; cdecl; {$EXTERNALSYM mvwin}. Function NCURSES_BITS(mask, shift : Integer) : Integer; Function newwin(nlines, ncols, begin_y, begin_x : Integer) : PWINDOW; cdecl; {$EXTERNALSYM newwin}. Function nl : Integer; cdecl; {$EXTERNALSYM nl}. Function nocbreak : Integer; cdecl; {$EXTERNALSYM nocbreak}. Function nodelay(win : PWINDOW; b : Boolean) : Integer; cdecl; {$EXTERNALSYM nodelay}. Function noecho : Integer; cdecl; {$EXTERNALSYM noecho}. Function notimeout(win : PWINDOW; b : Boolean) : Integer; cdecl; {$EXTERNALSYM notimeout}. Function pechochar(win : PWINDOW; ch : chtype) : Integer; cdecl; {$EXTERNALSYM pechochar}. Function resizeterm(lines, columns : Integer) : Integer; cdecl; {$EXTERNALSYM resizeterm}. Function scroll(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM scroll}. Function scrollok(win : PWINDOW; b : Boolean) : Integer; cdecl; {$EXTERNALSYM scrollok}. Function set_attr(win : PWINDOW; attr : Integer) : Integer; Function start_color : Integer; cdecl; {$EXTERNALSYM start_color}. Function timeout(delay : Integer) : Integer; cdecl; {$EXTERNALSYM timeout}. Function ungetch(ch : Integer) : Integer; cdecl; {$EXTERNALSYM ungetch}. Function unset_attr(win : PWINDOW; attr : Integer) : Integer; Function waddch(win : PWINDOW; ch : chtype) : Integer; cdecl; {$EXTERNALSYM waddch}. Function waddstr(win : PWINDOW; str : PChar) : Integer; cdecl; {$EXTERNALSYM waddstr}. Function wattr_get(win : PWINDOW; var attrs : attr_t; var pair : Word; opts : Pointer) : Integer; cdecl; {$EXTERNALSYM wattr_get}. Function wattrset(win : PWINDOW; attrs : Integer) : Integer; {$EXTERNALSYM wattrset}. Function wclear(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM wclear}. Function wclrtoeol(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM wclrtoeol}. Function wcolor_set(win : PWINDOW; Colors : Word; opts : Pointer) : Integer; cdecl; {$EXTERNALSYM wcolor_set}. Function wdelch(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM wdelch}. Function wdeleteln(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM wdeleteln}. Function wenclose(win : PWindow; y, x : Integer) : Boolean; cdecl; {$EXTERNALSYM wenclose}. Function werase(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM werase}. Function wgetch(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM wgetch}. Function wgetnstr(win : PWINDOW; str : PChar; n : Integer) : Integer; cdecl; {$EXTERNALSYM wgetnstr}. Function winch(win : PWINDOW) : chtype; cdecl; {$EXTERNALSYM winch}. Function winsch(win : PWINDOW; ch : chtype) : Integer; cdecl; {$EXTERNALSYM winsch}. Function winsdelln(win : PWINDOW; n : Integer) : Integer; cdecl; {$EXTERNALSYM winsdelln}. Function winsstr(win : PWINDOW; str : PChar) : Integer; cdecl; {$EXTERNALSYM winsstr}. Function wmouse_trafo(win : PWINDOW; var pY, pX : Integer; to_screen : Boolean) : Boolean; cdecl; {$EXTERNALSYM wmouse_trafo}. Function wmove(win : PWINDOW; y, x : Integer) : Integer; cdecl; {$EXTERNALSYM wmove}. Function wrefresh(win : PWINDOW) : Integer; cdecl; {$EXTERNALSYM wrefresh}. Implementation. Const. Libname = 'libncurses.so'; Function cbreak : Integer; cdecl; external libname name 'cbreak'; Function def_prog_mode : Integer; cdecl; external libname name 'def_prog_mode'; Function define_key(definitions : PChar; keycode : Integer) : Integer; cdecl; external libname name 'define_key'; Function delwin(win : PWINDOW) : Integer; cdecl; external libname name 'delwin'; Function echo : Integer; cdecl; external libname name 'echo'; Function endwin : Integer; cdecl; external libname name 'endwin'; Function erasechar : Integer; cdecl; external libname name 'erasechar'; Function getmouse(var event : MEVENT) : Integer; cdecl; external libname name 'getmouse'; Function init_pair(pair, f, b : Word) : Integer; cdecl; external libname name 'init_pair'; Function initscr : PWINDOW; cdecl; external libname name 'initscr'; Function keypad(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'keypad'; Function leaveok(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'leaveok'; Function mousemask(newmask : mmask_t; var oldmask : mmask_t) : mmask_t; cdecl; external libname name 'mousemask'; Function mvwaddch(win : PWINDOW; y, x : Integer; ch : chtype) : Integer; cdecl; external libname name 'mvwaddch'; Function mvwin(win : PWINDOW; y, x : Integer) : Integer; cdecl; cdecl; external libname name 'mvwin'; Function newwin(nlines, ncols, begin_y, begin_x : Integer) : PWINDOW; cdecl; external libname name 'newwin'; Function nl : Integer; cdecl; external libname name 'nl'; Function nocbreak : Integer; cdecl; external libname name 'nocbreak'; Function nodelay(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'nodelay'; Function noecho : Integer; cdecl; external libname name 'noecho'; Function notimeout(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'notimeout'; Function pechochar(win : PWINDOW; ch : chtype) : Integer; cdecl; external libname name 'pechochar'; Function resizeterm(lines, columns : Integer) : Integer; cdecl; external libname name 'resizeterm'; Function scroll(win : PWINDOW) : Integer; cdecl; external libname name 'scroll'; Function scrollok(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'scrollok'; Function start_color : Integer; cdecl; external libname name 'start_color'; Function timeout(delay : Integer) : Integer; cdecl; external libname name 'timeout'; Function ungetch(ch : Integer) : Integer; cdecl; cdecl; external libname name 'ungetch'; Function waddch(win : PWINDOW; ch : chtype) : Integer; cdecl; external libname name 'waddch'; Function waddstr(win : PWINDOW; str : PChar) : Integer; cdecl; external libname name 'waddstr'; Function wattr_get(win : PWINDOW; var attrs : attr_t; var pair : Word; opts : Pointer) : Integer; cdecl; external libname name 'wattr_get'; // function wattrset(win : PWindow; attrs : Integer) : Integer; cdecl; external libname name 'wattrset'; Function wclear(win : PWINDOW) : Integer; cdecl; external libname name 'wclear'; Function wclrtoeol(win : PWINDOW) : Integer; cdecl; external libname name 'wclrtoeol'; Function wcolor_set(win : PWINDOW; Colors : Word; opts: Pointer) : Integer; cdecl; external libname name 'wcolor_set'; Function wdelch(win : PWINDOW) : Integer; cdecl; external libname name 'wdelch'; Function wdeleteln(win :PWINDOW) : Integer; cdecl; external libname name 'wdeleteln'; Function wenclose(win : PWINDOW; y, x : Integer) : Boolean; cdecl; external libname name 'wenclose'; Function werase(win : PWINDOW) : Integer; cdecl; external libname name 'werase'; Function wgetch(win : PWINDOW) : Integer; cdecl; external libname name 'wgetch'; Function wgetnstr(win : PWINDOW; str : PChar; n : Integer) : Integer; cdecl; external libname name 'wgetnstr'; Function winch(win : PWINDOW) : chtype; cdecl; external libname name 'winch'; Function winsch(win : PWINDOW; ch : chtype) : Integer; cdecl; external libname name 'winsch'; Function winsdelln(win : PWINDOW; n : Integer) : Integer; cdecl; external libname name 'winsdelln'; Function winsstr(win : PWINDOW; str : PChar) : Integer; cdecl; external libname name 'winsstr'; Function wmouse_trafo(win : PWINDOW; var pY, pX : Integer; to_screen : Boolean) : Boolean; cdecl; external libname name 'wmouse_trafo'; Function wmove(win : PWINDOW; y, x : Integer) : Integer; cdecl; external libname name 'wmove'; Function wrefresh(win : PWINDOW) : Integer; cdecl; external libname name 'wrefresh'; Function getyx; Begin. Y := win._cury; X := win._curx; Result := 0; End; Function set_attr; Begin. Win._attrs := win._attrs or attr; Result := 0; End; Function unset_attr; Begin. Win._attrs := win._attrs and not attr; Result := 0; End; Function NCURSES_BITS; Begin. Result := mask shl (shift+8); End; Function COLOR_PAIR; Begin. Result := NCURSES_BITS(n, 0); End; Function wattrset; Begin. Win._attrs := attrs; Result:=0; End; End.

Установка Kylix под новые версии Linux (ядро 2.6).

Взято с http://www.nux.co.za/

Follow these steps to fix/patch kylix 3 work:

Step 1.

Download the ilink and ilink.so patch provided by Andreas Hausladen here:

Ilinkpatch for more info on the patch go to unvclx.sourceforge.net.

To install just go to the download directory and run.

./ilinkPatch /home/yourname/kylix.

Step 2.

Download the latest 3.6 clx patch provided by Andreas Hausladen from unvclx.sourceforge.net or here. Copy or save this file to /tmp folder.

Install the patch by executing the following from the shell.

Tar -jxf k3patches.20040915.tar.bz2.

/tmp/k3patches/installpatch.

Step 3.

Download and install the older compatible glibc libraries for running kylix apps from here. Save or copy it to /tmp.

Install by runing from the shell.

Rpm -i /tmp/compat-glibc-6.2-2.1.3.2.i386.rpm.

Now the patching is complete.... now to run kylix do the following.

Step 4.

Export LD_ASSUME_KERNEL=2.4.21.

Step 5.

Run/Start kylix via.

/usr/local/kylix3/bin/startbcb.

Step 6.

Open your project and change your projects include directories via the project options by adding.

/usr/i386-glibc21-linux/include.

/usr/include.

As the very first include paths to that your include paths..

This will fix the error so that the correct "time.h" be included.

Step 7.

Change your lib paths by adding (preferably in the beginning).

/usr/i386-glibc21-linux/lib and.

/usr/lib.

Finally:

Open the ThrdDemo (the c++ demo included with Kylix in the examples directory) This sample demonstrates the use of threads and different sort algorithms... (remember step 6+7 for this project).

Compile and run/debug....

Congatulations!!! your have done it!!!

©Drkb::04612.

КроссКу1iх - возможность под Windows Delphi получать Linux исполняемые файлы.

Информация здесь:

Http://crosskylix.untergrund.net/

Скачать можно здесь:

Http://crosskylix.untergrund.net/crosskylix-100.zip.

Автор: Remax.

©Drkb::04632.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как использовать Tray под Linux.

Есть прекрасный компонент для этого:

Http://www.sudemon.xaker.ru/

Как скачать любой URL используя стандартные настройки сети?

Начиная с Internet Explorer 3, Microsoft поддерживает очень полезные API, Wininet. Эти функции позволяют использовать все возможности IE, такие как настройки прокси, кэширование файлов и т.д.

Ниже приведён пример использования этих функций для скачивания файла с нужного URL. Это может быть любой доступный URL, ftp://, http://, gopher://, и т.д.

Более подробную информацию об этих функция можно посмотреть в MSDN - Win32 Internet API Functions.

Code: Function DownloadFile(const Url: string): string; Var. NetHandle: HINTERNET; UrlHandle: HINTERNET; Buffer: array[0..1024] of char; BytesRead: cardinal; Begin. Result := ''; NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); If Assigned(NetHandle) then. Begin. UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0); If Assigned(UrlHandle) then. { UrlHandle правильный? Начинаем загрузку }. Begin. FillChar(Buffer, SizeOf(Buffer), 0); Repeat. Result := Result + Buffer; FillChar(Buffer, SizeOf(Buffer), 0); InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead); Until BytesRead = 0; InternetCloseHandle(UrlHandle); End. Else. Begin. { UrlHandle неправильный. Генерируем исключительную ситуацию. }. Raise Exception.CreateFmt('Cannot open URL %s', [Url]); End; InternetCloseHandle(NetHandle); End. Else. { NetHandle недопустимый. Генерируем исключительную ситуацию }. Raise Exception.Create('Unable to initialize Wininet'); End;

Как сделать PING?

Протокол Ping предназначен для тестирования компьютерных соединений в Интернете путём посылки через протокол Internet Protocol (IP) по обределённому адресу сообщения и ожидания от него ответа.

ICMP - Internet Control Message Protocol. ICMP служит для передачи сообщений об ошибках а так же управляющих сообщений . ICMP-тест может показать насколько быстро проходит информация между двумя узлами в Интернете.

1. Запускаем Delphi;

2. В Новом проекте добавляем в форму Tbutton, Tedit и Tmemo;

3. Вставляем "winsock";

4. объявляем структурку для IP-заголовка:

Code: Type. IPINFO = record. Ttl: char; Tos: char; IPFlags: char; OptSize: char; Options: ^char; End;

Получение файла из сети.

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

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

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

Delphi предоставляет нам полный доступ к WinInet API (wininet.pas), который можно использовать для соединения и получения файлов с веб-сайта, который использует либо Hypertext Transfer Protocol (HTTP) либо File Transfer Protocol (FTP). Например, мы можем использовать функции из WinInet API для: добавления FTP браузера в любое приложение, создания приложения, которое автоматически скачивает файлы с общедоступных FTP серверов или поиска Internet сайтов, ссылающихся на графику и скачивать только графику.

Функция GetInetFile.

Code: Uses Wininet; Function GetInetFile. (const fileURL, FileName: String): boolean; Const BufferSize = 1024; Var. HSession, hURL: HInternet; Buffer: array[1..BufferSize] of Byte; BufferLen: DWORD; F: File; SAppName: string; Begin. Result:=False; SAppName := ExtractFileName(Application.ExeName); HSession := InternetOpen(PChar(sAppName), INTERNET_OPEN_TYPE_PRECONFIG, Nil, nil, 0); Try. HURL := InternetOpenURL(hSession, PChar(fileURL), Nil,0,0,0); Try. AssignFile(f, FileName); Rewrite(f,1); Repeat. InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen); BlockWrite(f, Buffer, BufferLen). Until BufferLen = 0; CloseFile(f); Result:=True; Finally. InternetCloseHandle(hURL). End. Finally. InternetCloseHandle(hSession). End. End;

Формулы передачи данных для начинающих.

Автор: Jason Pierce.

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

Каково различие между KBps и Kbps? В чём заключается отличие битов, байтов и бодов? Как определить скорость передачи данных? Как выяснить, насколько долго будет загружаться файл с определённой скоростью? Как посчитать время, оставшее до окончания загрузки?

Для начала хотельсы навести порядок с некоторой неразберихой по поводу KBps и Kbps (буква b в нижнем регистре). KBps это обозначение для килобайт в секунду, в то время как Kbps обозначает килобиты в секунду. 1 килобайт (KB) = 8 килобитам (Kb).

Когда речь идёт о скорости передачи, то применяется Kbps. Таким образом модем со скорость передачи 33.6K (33600 bps) передаёт данные со скоростью 4.2 KBps (4.2 килобайта в секунду). Как мы видим, разница между KB и Kb довольно ощутима. В этом кроется причина того, что некоторые пользователи модемов по своему незнанию не могут понять, почему данные передаются так медленно. На самом деле данные объёмом 33.6K передаются не за 1 секунду, а за 8, соответственно за одну секунду будет передано 33.6 Kb / 8 = 4.2.

Так же хотелось бы дать некоторые разъяснения по поводу слова "бод" (baud). Обычно для модема "боды" расшифровываются как бит в секунду. На самом деле это не так. Бод (Baud) означает частоту звука в телефонной линии. Т. е. в зависимости от модема, который Вы используете, количество бит, которые могут быть переданы зависит от частоты звука, необходимой для обеспечения нужной скорости передачи.

Обратите внимание: Приведённый ниже пример, использует компонент NetMasters TNMHTTP. Однако, если Вы "прикипели" к какому-то другому компоненту TCP/IP, то переделать пример под этот компонент не составит большого труда.

Используемые обозначения:

Bps = байт, переданных за 1 секунду.

KBps (KB/Sec) = bps / 1024.

Kbps (Kb/Sec) = KBps x 8.

Краткий алгоритм приведённого ниже примера:

1. Сохраняем в переменной время начала загрузки: nStartTime := GetTickCount;

2. Сохраняем в переменной размер файла (KB): nFileSize := "File Size";

3. Начало передачи данных.

4. Обновляем количество переданных байт: Inc(nBytesTransferred, nNewBytes);

5. Получаем оставшееся время: nTimeElapsed := (GetTickCount - nStartTime) / 1000;

6. Вычисляем bps: nBps := BytesTransferred / nTimeElapsed;

7. Вычисляем KBps: nKBps := nBps / 1024;

Используемые данные:

Общее время скачивания (секунд) := nFileSize / nKBps;

Bps := FloatToStr(nBps);

KB/Sec (KBps) := FloatToStr(nKBps);

Осталось секунд := FloatToStr(((nFileSize - BytesTransferred) / 1024) / KBps);

Рабочий пример:

Code: Unit Main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Gauges, Psock, NMHttp; Type. TfMain = class(TForm). Label1: TLabel; EURL: TEdit; BGet: TButton; LbMessages: TListBox; GbDetails: TGroupBox; LEstimate: TLabel; LKBps: TLabel; LReceived: TLabel; LRemaining: TLabel; GProgress: TGauge; NMHTTP1: TNMHTTP; Lbps: TLabel; BCancel: TButton; Procedure NMHTTP1PacketRecvd(Sender: TObject); Procedure bGetClick(Sender: TObject); Procedure bCancelClick(Sender: TObject); Procedure NMHTTP1Connect(Sender: TObject); Procedure NMHTTP1ConnectionFailed(Sender: TObject); Procedure NMHTTP1Disconnect(Sender: TObject); Procedure NMHTTP1Failure(Cmd: CmdType); Procedure NMHTTP1HostResolved(Sender: TComponent); Procedure NMHTTP1InvalidHost(var Handled: Boolean); Procedure NMHTTP1Status(Sender: TComponent; Status: String); Procedure NMHTTP1Success(Cmd: CmdType); Private. { Private declarations }. Function ss2nn(Seconds: Integer): String; Public. { Public declarations }. End; Var. FMain: TfMain; NFileSize: Double; NStartTime: DWord; Implementation. {$R *.DFM}. {Цель этой функции состоит в том, чтобы определить, сколько минут и секунд там находятся в данном количестве секунд}. Function TfMain.ss2nn(Seconds: Integer): String; Var. NMin, nSec: Integer; Begin. {Проверяем, меньше чем 1/Min}. If Seconds < 60 then Result := '0 minutes ' + IntToStr(Seconds) + ' seconds' Else begin. {Определяем минуты}. NMin := Seconds div 60; {Определяем секунды}. NSec := Seconds - (nMin * 60); {Возвращаем результат}. Result := IntToStr(nMin) + ' minutes ' + IntToStr(nSec) + ' seconds'; End; End; Procedure TfMain.NMHTTP1PacketRecvd(Sender: TObject); Var. NBytesReceived, nTimeElapsed, nBps, nKBps: Double; Begin. {Следующий код выполняется только однажды, при приёме первого пакета}. If nFileSize <> NMHTTP1.BytesTotal then. Begin. {Получаем размер файла}. NFileSize := NMHTTP1.BytesTotal; {Вычисляем время передачи, исходя из скорости соединения 33.6 Kbps}. LEstimate.Caption := 'Estimated download time at 33.6 Kbps: ' + ss2nn(Round( (nFileSize / 1024) / 4.2)); {Получаем время начала}. NStartTime := GetTickCount; End; {Обновляем nBytesReceived}. NBytesReceived := NMHTTP1.BytesRecvd; {Вычисляем количество секунд прошедших с момента начала передачи}. NTimeElapsed := (GetTickCount - nStartTime) / 1000; {Проверяем на 0/Sec, если так, то устанавливаем 1, чтобы предотвратить деления на ноль}. If nTimeElapsed = 0 then nTimeElapsed := 1; {Вычисляем байт в секунду}. NBps := nBytesReceived / nTimeElapsed; {Вычисляем килобайт в секунду}. NKBps := nBps / 1024; {Обновляем контролы}. GProgress.Progress := Round((nBytesReceived * 100) / nFileSize); Lbps.Caption := IntToStr(Round(nBps * 8)) + ' bits per second'; LKBps.Caption := IntToStr(Round(nKBps)) + ' KB/Sec (KBps)'; LReceived.Caption := FloatToStr(nBytesReceived) + ' of ' + FloatToStr( NFileSize) + ' bytes received'; LRemaining.Caption := ss2nn(Round(((nFileSize - nBytesReceived) / 1024) / NKBps)) + ' remaining'; End; Procedure TfMain.bGetClick(Sender: TObject); Begin. {Сбрасываем переменные}. NFileSize := 0; {Обнуляем контролы}. LbMessages.Clear; GProgress.Progress := 0; LEstimate.Caption := 'Estimated download time at 33.6 Kbps: 0 minutes 0 ' + 'seconds'; Lbps.Caption := '0 bits per second'; LKBps.Caption := '0 KB/Sec (KBps)'; LReceived.Caption := '0 of 0 bytes received'; LRemaining.Caption := '0 minutes 0 seconds remaining'; {Получаем файл}. NMHTTP1.Get(eURL.Text); End; Procedure TfMain.bCancelClick(Sender: TObject); Begin. {Разрываем соединение с сервером}. NMHTTP1.Disconnect; {Обновляем lbMessages}. LbMessages.Items.Append('Get Canceled'); LbMessages.Items.Append('Disconnected'); End; Procedure TfMain.NMHTTP1Connect(Sender: TObject); Begin. {Запрещаем/Разрешаем контролы}. BGet.Enabled := False; BCancel.Enabled := True; {Работаем с lbMessages}. With lbMessages.Items do. Begin. Append('Connected'); Append('Local Address: ' + NMHTTP1.LocalIP); Append('Remote Address: ' + NMHTTP1.RemoteIP); End; End; Procedure TfMain.NMHTTP1ConnectionFailed(Sender: TObject); Begin. ShowMessage('Connection Failed.'); End; Procedure TfMain.NMHTTP1Disconnect(Sender: TObject); Begin. {Запрещаем/Разрешаем контролы}. BCancel.Enabled := False; BGet.Enabled := True; {Обновляем lbMessages}. If NMHTTP1.Connected then lbMessages.Items.Append('Disconnected'); End; Procedure TfMain.NMHTTP1Failure(Cmd: CmdType); Begin. Case Cmd of. CmdGET : lbMessages.Items.Append('Get Failed'); CmdOPTIONS: lbMessages.Items.Append('Options Failed'); CmdHEAD : lbMessages.Items.Append('Head Failed'); CmdPOST : lbMessages.Items.Append('Post Failed'); CmdPUT : lbMessages.Items.Append('Put Failed'); CmdPATCH : lbMessages.Items.Append('Patch Failed'); CmdCOPY : lbMessages.Items.Append('Copy Failed'); CmdMOVE : lbMessages.Items.Append('Move Failed'); CmdDELETE : lbMessages.Items.Append('Delete Failed'); CmdLINK : lbMessages.Items.Append('Link Failed'); CmdUNLINK : lbMessages.Items.Append('UnLink Failed'); CmdTRACE : lbMessages.Items.Append('Trace Failed'); CmdWRAPPED: lbMessages.Items.Append('Wrapped Failed'); End; End; Procedure TfMain.NMHTTP1HostResolved(Sender: TComponent); Begin. LbMessages.Items.Append('Host Resolved'); End; Procedure TfMain.NMHTTP1InvalidHost(var Handled: Boolean); Begin. ShowMessage('Invalid Host. Please specify a new URL.'); End; Procedure TfMain.NMHTTP1Status(Sender: TComponent; Status: String); Begin. If NMHTTP1.ReplyNumber = 404 then ShowMessage('Object Not Found.'); End; Procedure TfMain.NMHTTP1Success(Cmd: CmdType); Begin. Case Cmd of. {Удостоверяемся, что процедура получения не была прервана}. CmdGET: if NMHTTP1.Connected then lbMessages.Items.Append('Get Succeeded'); CmdOPTIONS: lbMessages.Items.Append('Options Succeeded'); CmdHEAD : lbMessages.Items.Append('Head Succeeded'); CmdPOST : lbMessages.Items.Append('Post Succeeded'); CmdPUT : lbMessages.Items.Append('Put Succeeded'); CmdPATCH : lbMessages.Items.Append('Patch Succeeded'); CmdCOPY : lbMessages.Items.Append('Copy Succeeded'); CmdMOVE : lbMessages.Items.Append('Move Succeeded'); CmdDELETE : lbMessages.Items.Append('Delete Succeeded'); CmdLINK : lbMessages.Items.Append('Link Succeeded'); CmdUNLINK : lbMessages.Items.Append('UnLink Succeeded'); CmdTRACE : lbMessages.Items.Append('Trace Succeeded'); CmdWRAPPED: lbMessages.Items.Append('Wrapped Succeeded'); End; End; End.

Как переделать TLabel в URL?

By Kevin Lange (klange@partslink.com).

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

Следующие 3 шага показывают как переделать TLabel в URL.

Шаг 1 Установите в свойствах шрифта подчёркивание и цвет ссылки.

Шаг 2 Установите свойства курсора. Когда мышка попадает на URL, то курсор должен превращаться в ручку.

Шаг 3 Записываем событие OnClick для ссылки. Когда пользователь нажимает на ссылку, то запускается браузер, который автоматически переходит на заданный адрес. Однако этого мало! Нужно будет добавить в приложение ещё одну строчку.

Та самая строчка:

ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL);

Внимание: функция ShellExecute содержится в ShellAPI, поэтому вам прийдётся включить его в проект.

Пример приложения.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ShellAPI; Type. TForm1 = class(TForm). URLLabel: TLabel; Button1: TButton; Procedure Button1Click(Sender: TObject); Procedure URLLabelClick(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. Close; End; Procedure TForm1.URLLabelClick(Sender: TObject); Const. URL : String = 'http://www.sources.ru'; Begin. ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL); End; End.

Получение IP-адреса и маски для всех сетевых интерфейсов.

Автор: Giannis Sampaziotis.

Существует множество методов получения IP адреса компьютера. Но данный пример представляет наиболее корректный способ получения всех адресов, сетевых масок, broadcast адресов и статусов для всех интерфейсов включая циклический 127.0.0.1 - требует WinSock 2.

Совместимость: Delphi 3.х (или выше).

Это завершённый Delphi компонент. Для его использования достаточно вызвать :

EnumInterfaces(var s string): Boolean;

Которая вернёт строку, разделённую CRLF и содержащую всё, нужную нам информацию.

Code: Unit USock; Interface. Uses Windows, Winsock; { Если Вы поместите строку результатов в wide TMEMO (в его свойство memo.lines.text). То никаких результатов не увидите. Тестировалось на Win98/ME/2K, 95 OSR 2 и NT service. Pack #3 , потому что используется WinSock 2 (WS2_32.DLL). } Function EnumInterfaces(var sInt: string): Boolean; { функция WSAIOCtl импортируется из Winsock 2.0 - Winsock 2 доступен }. { только в Win98/ME/2K и 95 OSR2, NT srv pack #3 }. Function WSAIoctl(s: TSocket; cmd: DWORD; lpInBuffer: PCHAR; dwInBufferLen: DWORD; LpOutBuffer: PCHAR; dwOutBufferLen: DWORD; LpdwOutBytesReturned: LPDWORD; LpOverLapped: POINTER; LpOverLappedRoutine: POINTER): Integer; stdcall; external 'WS2_32.DLL'; { Константы взятые из заголовка C файлов }. Const SIO_GET_INTERFACE_LIST = $4004747F; IFF_UP = $00000001; IFF_BROADCAST = $00000002; IFF_LOOPBACK = $00000004; IFF_POINTTOPOINT = $00000008; IFF_MULTICAST = $00000010; Type sockaddr_gen = packed record. AddressIn: sockaddr_in; Filler: packed array[0..7] of char; End; Type INTERFACE_INFO = packed record. IiFlags: u_long; // Флаги интерфейса. IiAddress: sockaddr_gen; // Адрес интерфейса. IiBroadcastAddress: sockaddr_gen; // Broadcast адрес. IiNetmask: sockaddr_gen; // Маска подсети. End; Implementation. {------------------------------------------------------------------- 1. Открываем WINSOCK. 2. Создаём сокет. 3. Вызываем WSAIOCtl для доступа к сетевым интерфейсам. 4. Для каждого интерфейса, получаем IP, MASK, BROADCAST, статус. 5. Разделяем строку символом CRLF. 6. Конец :). --------------------------------------------------------------------} Function EnumInterfaces(var sInt: string): Boolean; Var s: TSocket; WsaD: WSADATA; NumInterfaces: Integer; BytesReturned, SetFlags: u_long; PAddrInet: SOCKADDR_IN; PAddrString: PCHAR; PtrA: pointer; Buffer: array[0..20] of INTERFACE_INFO; I: Integer; Begin. Result := true; // Инициализируем переменную. SInt := ''; WSAStartup($0101, wsaD); // Запускаем WinSock. // Здесь можно дабавить различные обработчики ошибки :). S := Socket(AF_INET, SOCK_STREAM, 0); // Открываем сокет. If (s = INVALID_SOCKET) then exit; Try // Вызываем WSAIoCtl. PtrA := @bytesReturned; If (WSAIoCtl(s, SIO_GET_INTERFACE_LIST, nil, 0, @Buffer, 1024, PtrA, nil, Nil). <> SOCKET_ERROR). Then. Begin // Если OK, то определяем количество существующих интерфейсов. NumInterfaces := BytesReturned div SizeOf(INTERFACE_INFO); For i := 0 to NumInterfaces - 1 do // Для каждого интерфейса. Begin. PAddrInet := Buffer[i].iiAddress.addressIn; // IP адрес. PAddrString := inet_ntoa(pAddrInet.sin_addr); SInt := sInt + ' IP=' + pAddrString + ','; PAddrInet := Buffer[i].iiNetMask.addressIn; // Маска подсети. PAddrString := inet_ntoa(pAddrInet.sin_addr); SInt := sInt + ' Mask=' + pAddrString + ','; PAddrInet := Buffer[i].iiBroadCastAddress.addressIn; // Broadcast адрес. PAddrString := inet_ntoa(pAddrInet.sin_addr); SInt := sInt + ' Broadcast=' + pAddrString + ','; SetFlags := Buffer[i].iiFlags; If (SetFlags and IFF_UP) = IFF_UP then. SInt := sInt + ' Interface UP,' // Статус интерфейса up/down. Else. SInt := sInt + ' Interface DOWN,'; If (SetFlags and IFF_BROADCAST) = IFF_BROADCAST then // Broadcasts. SInt := sInt + ' Broadcasts supported,' // поддерживает или. Else // не поддерживается. SInt := sInt + ' Broadcasts NOT supported,'; If (SetFlags and IFF_LOOPBACK) = IFF_LOOPBACK then // Циклический или. SInt := sInt + ' Loopback interface' Else. SInt := sInt + ' Network interface'; // нормальный. SInt := sInt + #13#10; // CRLF между каждым интерфейсом. End; End; Except. End; // // Закрываем сокеты. // CloseSocket(s); WSACleanUp; Result := false; End; End.

Как вычислить IP-адрес по доменному имени.

Code: Uses winsock. ------- Function IPAddrToName(IPAddr : String): String; Var. SockAddrIn: TSockAddrIn; HostEnt: PHostEnt; WSAData: TWSAData; Begin. WSAStartup($101, WSAData); SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr)); HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET); If HostEnt<>nil then. Begin. Result:=StrPas(Hostent^.h_name). End. Else. Begin. Result:=''; End; End;

Преобразуем доменное имя в IP адрес.

Автор: Lutfi Baran.

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

Совместимость: Delphi 3.x (или выше).

Объявляем Winsock, для использования в функции.

Code: Function HostToIP(Name: string; var Ip: string): Boolean; Var. Wsdata : TWSAData; HostName : array [0..255] of char; HostEnt : PHostEnt; Addr : PChar; Begin. WSAStartup ($0101, wsdata); Try. Gethostname (hostName, sizeof (hostName)); StrPCopy(hostName, Name); HostEnt := gethostbyname (hostName); If Assigned (hostEnt) then. If Assigned (hostEnt^.h_addr_list) then begin. Addr := hostEnt^.h_addr_list^; If Assigned (addr) then begin. IP := Format ('%d.%d.%d.%d', [byte (addr [0]), Byte (addr [1]), byte (addr [2]), byte (addr [3])]); Result := True; End. Else. Result := False; End. Else. Result := False. Else begin. Result := False; End; Finally. WSACleanup; End. End;

Как преобразовать http://192.168.1.2 в http://3232235778 ?

Автор: Roni Havas.

Функция, представленная в этом примере может быть и не очень элегантна, зато работает. Функция получает в качестве параметра строку, содержащую IP адрес, и возвращает строку с IP адресом в виде DWord значения. Результат легко можно проверить командой "Ping".

Совместимость: Delphi (все версии).

Обратите внимание, что необходимо добавить "Math" в "Uses" для функции "IntPower";

Code: Function IP2HEX(OrgIP: string): string; Var OrgVal: string; // Сохраняем оригинальное значение IP адреса. O1, O2, O3, O4: string; // части оригинального IP. H1, H2, H3, H4: string; // шестнадцатиричные части. HexIP: string; // Здесь будут собраны все шестнадцатиричные части. XN: array[1..8] of Extended; Flt1: Extended; Xc: Integer; Begin. // Сохраняем в обратном порядке для простого случая. Xn[8] := IntPower(16, 0); Xn[7] := IntPower(16, 1); Xn[6] := IntPower(16, 2); Xn[5] := IntPower(16, 3); Xn[4] := IntPower(16, 4); Xn[3] := IntPower(16, 5); Xn[2] := IntPower(16, 6); Xn[1] := IntPower(16, 7); // Сохраняем оригинальный IP адрес. OrgVal := OrgIP; O1 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal)); O2 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal)); O3 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal)); O4 := OrgVal; H1 := IntToHex(StrToInt(O1), 2); H2 := IntToHex(StrToInt(O2), 2); H3 := IntToHex(StrToInt(O3), 2); H4 := IntToHex(StrToInt(O4), 2); // Получаем шестнадцатиричное значение IP адреса. HexIP := H1 + H2 + H3 + H4; // Преобразуем это большое шестнадцатиричное значение в переменную Float. Flt1 := 0; For Xc := 1 to 8 do. Begin. Case HexIP[Xc] of. '0'..'9': Flt1 := Flt1 + (StrToInt(HexIP[XC]) * Xn[Xc]); 'A': Flt1 := Flt1 + (10 * Xn[Xc]); 'B': Flt1 := Flt1 + (11 * Xn[Xc]); 'C': Flt1 := Flt1 + (12 * Xn[Xc]); 'D': Flt1 := Flt1 + (13 * Xn[Xc]); 'E': Flt1 := Flt1 + (14 * Xn[Xc]); 'F': Flt1 := Flt1 + (15 * Xn[Xc]); End; End; Result := FloatToStr(Flt1); End;

Как преобразовать длинный IP адрес в короткий адрес / порт ?

Некоторые старые internet протоколы ( такие как FTP ) посылают IP адреса и номера портов в шестизначном формате XXX.XXX.XXX.XXX.XX.XXX Следующий код позволяет преобразовать такой адрес к нормальному четырёхзначному IP адресу.

Code: Procedure LongIPToShort(aLongIPAddress: string; out ShortIPAddress: string; out PortNumber: Integer); Var I, DotPos, tempPort: Integer; Var tempAddy, temp: string; Var TempStr: string; Begin. TempAddy := ''; TempStr := ''; // Определяем, какой символ использует отправитель в качестве разделителя длинного IP: , или . If (POS(',', aLongIPAddress) <> 0) then. TempStr := ',' Else. TempStr := '.'; For I := 1 to 4 do. Begin. DotPOS := POS(TempStr, aLongIPAddress); TempAddy := tempAddy + (Copy(aLongIPAddress, 1, (DotPos - 1))); If I <> 4 then TempADdy := TempAddy + '.'; Delete(aLongIpAddress, 1, DotPos); End; DotPos := Pos(TempStr, aLongIpAddress); Temp := Copy(aLongIpAddress, 1, (DotPos - 1)); TempPort := (StrToInt(temp) * 256); Delete(aLongIpAddress, 1, DotPos); TempPort := tempPort + StrToInt(ALongIpAddress); ShortIPAddress := TempADdy; PortNumber := tempPort; End;

Как проверить существование URL?

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

URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher://

Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ".

Платформа: Delphi 3.x (или выше).

Code: Uses wininet; Function CheckUrl(url: string): boolean; Var. HSession, hfile, hRequest: hInternet; Dwindex, dwcodelen: dword; Dwcode: array[1..20] of char; Res: pchar; Begin. If pos('http://', lowercase(url)) = 0 then. Url := 'http://' + url; Result := false; HSession := InternetOpen('InetURL:/1.0', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); If assigned(hsession) then. Begin. Hfile := InternetOpenUrl( Hsession, Pchar(url), Nil, 0, INTERNET_FLAG_RELOAD, 0); DwIndex := 0; DwCodeLen := 10; HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex); Res := pchar(@dwcode); Result := (res = '200') or (res = '302'); If assigned(hfile) then. InternetCloseHandle(hfile); InternetCloseHandle(hsession); End; End;

Поддержка библиотеки сжатия ZLib.

В Delphi 7 официально включена поддержка библиотеки сжатия ZLib. Если у вас более старшая версия посмотрите модули ZLib в дестрибутиве среды (они должны быть на диске но подключать прийдеться самому).

Библиотеки под разные платформы, среды разработок и документация на сайте www.gzip.org/zlib.

Степень сжатия превосходит алгоритм zip. Максимальная степень сжатия по алгоритму ZLib приближается к степени сжатия упаковщиком RAR.

Модули Zlib, ZlibConst.

При использовании необходимо подключить в описании Uses модуль ZLib.

Пример использования:

Компресия одного потока в другой:

Code: ComressStream( aSource, aTarget : TStream; compressionRate : TCompressionLevel ); Var comprStream : TCompressionStream; Begin. // compression level : (clNone, clFastest, clDefault, clMax). ComprStream := TCompressionStream.Create( compressionRate, aTarget ); Try. ComprStream.CopyFrom( aSource, aSource.Size ); ComprStream.CompressionRate; Finally. ComprStream.Free; End; End;

Выделить подстроку(@result) после подстроки(@substr) в строке(@str).

Code: --©Drkb v.3(2007): www.drkb.ru. Declare @i int. Declare @result varchar(4000). Set @substr=Replace(@substr, '%', '[%]'). Set @substr=Replace(@substr, '_', '[_]'). Set @i=Patindex('%'+@substr+'%', @str). If @i>0. Set @Result=right(@str,len(@str)-@i). Else. Set @Result=@str. Return @Result.

©Drkb::02826.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

__Delphikingdom.

Http://www.delphikingdom.com.

Удаление лишних пробелов в строке

Содержание.

Write/read a string to/from the serial port.
Переадресация.
Введение.
Существующие решения.
Принципы построения API-библиотеки.
Куки (Cookies).
Работа с Базами Данных.
Частые Вопросы и Ответы.
XLS ---> TStringGrid.
XML: будущее гипертекста?
Эмулирование мыши/клавиатуры, Через SendInput().
Установка Kylix под новые версии Linux (ядро 2.6).
КроссКу1iх - возможность под Windows Delphi получать Linux исполняемые файлы.
Выделить подстроку(@result) после подстроки(@substr) в строке(@str).
__Delphikingdom.