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

RadioButtons in a TWebbrowser.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Document: IHTMLDocument2; RbTestList: IHTMLElementCollection; RbTest: IHTMLOptionButtonElement; I: Integer; Begin. // Get a reference to the document. Document := WebBrowser1.Document as IHTMLDocument2; // Get a reference to input-control (Radiobutton). RbTestList := Document.all.item('rating', EmptyParam) as IHTMLElementCollection; // Get current values. For I := 0 to rbTestList.Length - 1 do. Begin. // reference to the i. RadioButton. RbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement; // Show a message if radiobutton is checked. If rbTest.Checked then. ShowMessageFmt('Der RadioButton mit dem Wert %s' + ' ist ausgewahlt!', [rbTest.Value]); End; // Set new values. For I := 0 to rbTestList.Length - 1 do. Begin. // reference to the i. RadioButton. RbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement; // check radiobutton with value 3. If rbTest.Value = '3' then. RbTest.Checked := True; End; End;

RAS API для непродвинутых

Автор: Александр Терехов

Rave Report - Руководство разработчика.

Rave Reports.

Borland Edition 5.0.

Руководство разработчика.

Руководство и справочник.

This manual and all material accompanying it is.

Http://podgoretsky.com/

Anatoly@podgoretsky.com.

Примечание от Vit: Часть иллюстративного материала статьи и приложения были исключены с целью экономии места в DRKB - за полной версией обращайтесь к Анатолию Подгорецкому.

©Drkb::03273.

Rave Report - Руководство пользователя.

Rave Reports.

Borland Edition 5.0.

Руководство пользователя.

Руководство и справочник.

This manual and all material accompanying it is.

Http://podgoretsky.com/

Anatoly@podgoretsky.com.

©Drkb::03274.

RC4.

RC4: Симметричный алгоритм шифрования поточного вида. Переменная длина ключа. Для зашифровки/расшифровки применяют один и тот же ключ. Был рассекречен в середине 90-х анонимным лицом,в интернете.

Code: /////////////////////////////////////////////////// ///////////////////Шифр RC4//////////////////////// /////////////////////////////////////////////////// Unit RC4; Var. S: array [0..255] of Byte; I,j: Byte; //Инициализация S-Вох'а. Procedure InitRC4Cipher(key: ShortString); Var. K: array [0..255] of Byte; T: Byte; L: Cardinal; I0,j0: Byte; Begin. For i0 := 0 to 255 do s[i0] := i0; J0 := 1; l := Length(key); For i0 := 0 to 255 do. Begin. K[i0] := Ord(key[j0]); If j0 = l then j0 := 0; Inc(j0); End; For i0 := 0 to 255 do. Begin. J0 := (j0 + k[i0] + s[i0]) mod 256; T := s[i0]; S[i0] := s[j0]; S[j0] := t; End; I := 0; J := 0; End; //Шифрование конкретного символа. Function GetRC4ByteCiphered(bt: Byte): Byte; Var. T: Byte; Begin. I := (i + 1) mod 256; J := (j + s[i]) mod 256; T := s[i]; S[i] := s[j]; S[j] := t; T := (s[i] + s[j]) mod 256; Result := bt XOR s[t]; End; //Применения шифра к данным потока. Function ApplyRC4ToData(InitialData: TStream; var Buffer: TStream; key: ShortString): Boolean; stdcall; Var. I: Cardinal; D: Byte; Begin. If (key = '')OR(Buffer = InitialData)OR(Buffer = nil)OR(InitialData = nil)OR(InitialData.Size = 0)OR(Buffer.Size <> 0) then. Begin. Result := false; Exit; End; InitRC4Cipher(key); Try. InitialData.Position := 0; For i := 0 to InitialData.Size-1 do. Begin. InitialData.ReadBuffer(d,1); D := GetRC4ByteCiphered(d); Buffer.WriteBuffer(d,1); End; Except. Result := false; Exit; End; InitialData.Position := 0; Buffer.Position := 0; Result := true; End;

Автор: MakedoneZ.

©Drkb::03986.

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

RC5.

Автор: Матвеев Игорь

RC6.

Автор: Матвеев Игорь

Reading the autoincrement value of Paradox table.

The current highest value is stored beginning at byte 73 decimal.

The next value is determined by adding 1 to it.

Here is a simple Delphi function that returns the current.

Autoincrement value.

Code: Function getAutoInc(filename: string): LongInt; Var. Mystream: tfilestream; Buffer: longint; Begin. Mystream := tfilestream.create(filename, FmOpenread + fmShareDenyNone); Mystream.Seek(73, soFromBeginning); Mystream.readbuffer(buffer, 4); Mystream.Free; GetAutoInc := buffer; End;

RGB --> CMYK.

Code: Procedure RGBTOCMYK(R : byte; G : byte; B : byte; Var C : byte; Var M : byte; Var Y : byte; Var K : byte); Begin. C := 255 - R; M := 255 - G; Y := 255 - B; If C 0 then. Begin. C := c - k; M := m - k; Y := y - k; End; End;

RGB --> Gray.

Code: Function RgbToGray(RGBColor: TColor): TColor; Var. Gray: byte; Begin. Gray := Round((0.30 * GetRValue(RGBColor)) + (0.59 * GetGValue(RGBColor)) + (0.11 * GetBValue(RGBColor))); Result := RGB(Gray, Gray, Gray); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Shape1.Brush.Color := RGB(255, 64, 64); Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color); End;

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

Code: // This example doesn't use TReplaceDialog. // Ohne Benutzung von TReplaceDialog. Function Search_And_Replace(RichEdit: TRichEdit; SearchText, ReplaceText: string): Boolean; Var. Startpos, Position, endpos: integer; Begin. Startpos := 0; With RichEdit do. Begin. Endpos := Length(RichEdit.Text); Lines.BeginUpdate; While FindText(SearchText, startpos, endpos, [stMatchCase])<>-1 do. Begin. Endpos := Length(RichEdit.Text) - startpos; Position := FindText(SearchText, startpos, endpos, [stMatchCase]); Inc(startpos, Length(SearchText)); SetFocus; SelStart := Position; SelLength := Length(SearchText); Richedit.clearselection; SelText := ReplaceText; End; Lines.EndUpdate; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Search_And_Replace(Richedit1, 'OldText', 'NewText'); End;

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

Code: Function SearchForText_AndSelect(RichEdit: TRichEdit; SearchText: string): Boolean; Var. StartPos, Position, Endpos: Integer; Begin. StartPos := 0; With RichEdit do. Begin. Endpos := Length(RichEdit.Text); Lines.BeginUpdate; While FindText(SearchText, StartPos, Endpos, [stMatchCase])<>-1 do. Begin. Endpos := Length(RichEdit.Text) - startpos; Position := FindText(SearchText, StartPos, Endpos, [stMatchCase]); Inc(StartPos, Length(SearchText)); SetFocus; SelStart := Position; SelLength := Length(SearchText); End; Lines.EndUpdate; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. SearchForText_AndSelect(RichEdit1, 'Some Text'); End;

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

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

RNA API.

Вот некоторые выдержки из сайта RNA API.. //==================================================================// Здесь описаны некоторые недокументированные функции которые могут быть использованы для управления сервером удалённого доступа в системах Windows95/98. Когда я решил сделать прогу для управления dial-up сервером, я начал с того, что решил изучить, как работает родная виндовая панель управления сервером. Собственно диалог управления сервером (тот который вызывается из Dial-up networking ==> Connections ==> Dial-up server... либо щелчком по иконке в трее) находится в файле RNASERV.DLL. Как я быстро выяснил, в этом модуле по большому счёту ничего больше и нет, то есть это только контрольная панель, а собственно работа с сетью и модемами происходит где-то в другом месте. Для управления сервером RNASERV.DLL вызывает специальные функции из RASAPI32.dll, но не знакомые всем (и детально описанные в MSDN) функции RAS API (типа RasDial, имена их всех начинаются на «Ras»), а особые функции, имена которых начинаются на «Rna» и «Suprv», о которых в MSDN ничего нет. Всё, что мне там удалось отыскать, это упоминание о неком RNA API, в Windows 95 DDK. (RNA расшифровывается как «Remote Network Access») В DDK даже кратко описаны некоторые функции RNA API. Однако RNASERV.DLL всё равно использует совершенно другие RNA функции, о которых там нет ни слова. Пришлось рыть дальше. Поскольку я поставил себе достаточно конкретную задачу, написать приложение командной строки, заменяющее RNASERV.DLL, я не пытался разобраться во всём многообразье RNA API (в котором 61 функция), я изучил только самые необходимые функции, именно те, которые использует RNASERV.DLL. Далее приводится их описание. Функции RNA API: SuprvInitialize SuprvDeInitialize SuprvSetAccessInfo SuprvEnumAccessInfo SuprvGetAccessInfo RnaSMMInfoDialog SuprvRequest Структура: ACCESSINFO Структура ACCESSINFO struct ACCESSINFO { char m_szName[148]; unsigned int m_flags; // bit 0 - "allow caller access" unsigned int m_field_98; char m_szProtocol[4]; unsigned int m_field_A0[11]; char m_szComment[256]; unsigned int m_field_1CC; unsigned short m_accessNumber; // 0 - share level access unsigned short m_field_1D2; unsigned short m_field_1D4; unsigned short m_field_1D6; unsigned short m_field_1D8; }; Эта структура используется функциями SuprvSetAccessInfo и SuprvGetAccessInfo. К сожалению, смысл многих полей остался неясен. Не исключено, что часть из них просто зарезервированы, поскольку в большинстве случаев просто равны нулю. Вот что удалось выяснить: m_szName – название устройства (модема или COM/LPT порта) m_flags – самое интересное для нас поле. Если младший его бит равен 1, RNA сервер для данного устройства включён, 0 — выключен. m_szProtocol – чаще всего это поле просто забито нулями, но иногда в нём обнаруживается строчка "PPP", что наводит на мысль, что это поле означает используемый протокол соединения. Более точно, к сожалению, сказать не могу. m_szComment – комментарий. Тот самый, что можно ввести в диалоге Dial-Up Server, в поле Comment. m_accessNumber – как минимум означает тип контроля за разграничением доступа к серверу. Если равен 0 — значит используется “share level access control”. При этом проверяется только пароль. Если не равен нулю — значит производится проверка имени пользователя и пароля, то есть “user level access control”. Что конкретно при этом означает сама цифра, надо ещё разобраться, возможно число зарегистрированных пользователей. Похоже на то, что с управлением доступом связаны и другие поля структуры, но используются они только при “user level access control”. Поскольку для контроля за доступом на уровне пользователей необходимо наличие в сети NT сервера (который собственно и выполняет аутентификацию) мне не удалось поэкспериментировать с целью разобраться в смысле этих полей. Функции Все нижеперечисленные функции экспортируются из модуля RASAPI32.DLL. Их имнена не декорированы. Все они используют стандартное (или «паскалевское») соглашение о вызовах. int __stdcall SuprvInitialize( HWND* _phWnd ); Описание. Должна быть вызвана в первую очередь, перед тем, как вызывать какие-либо другие функции RNA API. Используется также для того, чтобы изменения конфигурации RNA сервера, внесённые с помощью SuprvSetAccessInfo немедленно вступили в силу. Параметры. Единственный параметр _phWnd указывает на дескриптор окошка, которое будет получать специальные сообщения о состоянии сервера. Возвращаемое значение. 0 — функция выполнена успешно. Не ноль — произошла ошибка. void __stdcall SuprvDeInitialize( void ); Описание. Вызывается последней для завершения работы с RNA API. Каждому вызову SuprvInitialize должен соответствовать SuprvDeInitialize. Параметры. Нет. Возвращаемое значение. Нет. int __stdcall SuprvSetAccessInfo( ACCESSINFO* _pAccessInfoStruct ); Описание. Самая интересная функция. Именно с помощью неё можно управлять сервером, в частности включить и выключить его. Состояние включён/выключен определяется младшим битом в поле m_flags структуры ACCESSINFO. RNASERV.DLL сразу после этой функции последовательно вызывает SuprvInitialize и SuprvDeInitialize. По-видимому, это требуется для того, чтобы внесённые изменения немедленно вступили в силу. Параметры. _pAccessInfoStruct указывает на структуру ACCESSINFO, для модема состояние которого надо изменить. Эту структуру лучше заполнить с помощью функции SuprvGetAccessInfo, а затем поменять в ней нужные параметры. Возвращаемое значение. ??? void __stdcall SuprvEnumAccessInfo( char* _pStringsBuffer, int* _pStringsBufferSize, unsigned int* _pnStrings ); Описание. Позволяет извлечь список устройств (модемов и COM/LPT портов). Параметры: _pStringsBuffer – указывает на буфер, куда должны быть помещены строки - названия устройств, разделённые нулевым символом. После последней строчки следуют два нулевых символа подряд. Этот параметр можно указать нулевым, что можно использовать для того, чтобы предварительно узнать требуемый размер буфера. _pStringsBufferSize – указывает на переменную, в которую помещается требуемый размер буффера. Если после вызова функции эта переменная оказалась <=1, значит произошла ошибка. _pnStrings – указывает на переменную, в которую будет помещено число устройств. Возвращаемое значение. Нет. int __stdcall SuprvGetAccessInfo( char* _pAccessInfoString, ACCESSINFO* _pBuffer, unsigned int* _pnBufferSize ); Описание. Извлекает всю информацию об устройстве. Заполняет структуру ACCESSINFO, которую потом можно использовать в функции SuprvSetAccessInfo. Параметры: _pAccessInfoString – указывает на имя устройства. _pBuffer – Указывает на структуру ACCESSINFO, которую надо заполнить. Перед вызовом в ней следует заполнить имя устройства. _pBuffer можно указать нулевым, что разумно использовать для того, чтобы предварительно узнать размер структуры. (По-видимому, он может быть переменным). _pnBufferSize – Указывает на переменную, в которую помещается размер структуры ACCESSINFO. Возвращаемое значение. Точно не известно, но по-видимому ноль означает успешное завершение функции. int __stdcall RnaSMMInfoDialog( HWND _hwnd, DWORD _dwUnused, ACCESSINFO* _pAccInfo, char* _pszProtocol ); Описание. Вызывает диалог "Server Type" Параметры: _hwnd – дескриптор родительского окна. _dwUnused – должно быть нулём. _pAccInfo – указатель на сруктуру ACCESSINFO. (Быть может достаточно просто указателя на имя устройства.) _pszProtocol – на название протокола. RNASERV.DLL при вызове этой функции просто помещает в этот параметр указатель на поле m_szProtocol структуры ACCESSINFO. Возвращаемое значение. А хрен его знает :-) Похоже на индикатор успешного завершения или ошибки. void __stdcall SuprvRequest( int _command, void* _arg2, DWORD _arg3 ); Описание. Весьма интересная функция. Судя по всему, многоцелевая. Однако я разобрался лишь с одной её возможностью: разорвать соединение с подключившимся компьютером. До остального прямо скажем руки не дошли. Параметры: _command – код команды. Код «разорвать соединение» — 0x38. _arg2 и _arg3 – назначение этих аргументов зависит от команды. Для команды "разорвать соединение" в качестве _arg2 следует передать указатель на структуру ACCESSINFO (быть может опять-таки достаточно только имени), а _arg3 должен быть нулём. Возвращаемое значение. Отсутствует.

©Drkb::03319.

Rotate a 2D Point.

Code: Const. PIDiv180 = 0.017453292519943295769236907684886; Procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double); Var. SinVal: Double; CosVal: Double; Begin. RotAng := RotAng * PIDiv180; SinVal := Sin(RotAng); CosVal := Cos(RotAng); Nx := x * CosVal - y * SinVal; Ny := y * CosVal + x * SinVal; End;

Rotate a 3D Point around another 3D Point.

Code: Const. PIDiv180 = 0.017453292519943295769236907684886; Procedure Rotate(Rx, Ry, Rz: Double; x, y, z, ox, oy, oz: Double; Var Nx, Ny, Nz: Double); Begin. Rotate(Rx, Ry, Rz, x - ox, y - oy, z - oz, Nx, Ny, Nz); Nx := Nx + ox; Ny := Ny + oy; Nz := Nz + oz; End; Procedure Rotate(Rx, Ry, Rz: Double; x, y, z: Double; var Nx, Ny, Nz: Double); Var. TempX: Double; TempY: Double; TempZ: Double; SinX: Double; SinY: Double; SinZ: Double; CosX: Double; CosY: Double; CosZ: Double; XRadAng: Double; YRadAng: Double; ZRadAng: Double; Begin. XRadAng := Rx * PIDiv180; YRadAng := Ry * PIDiv180; ZRadAng := Rz * PIDiv180; SinX := Sin(XRadAng); SinY := Sin(YRadAng); SinZ := Sin(ZRadAng); CosX := Cos(XRadAng); CosY := Cos(YRadAng); CosZ := Cos(ZRadAng); Tempy := y * CosY - z * SinY; Tempz := y * SinY + z * CosY; Tempx := x * CosX - Tempz * SinX; Nz := x * SinX + Tempz * CosX; Nx := Tempx * CosZ - TempY * SinZ; Ny := Tempx * SinZ + TempY * CosZ; End;

Runtime error 230 when running Kylix application outside of the IDE.

Why am I getting runtime error 230 when running my application outside of the Kylix IDE?

This error generally means your application cannot find a needed library.

Tunning the command source \kylix\bin\kylixpath in Linux should fix this. See the file deploy.txt that comes with Kylix.

©Drkb::04601.

Save all TWebbrowser Frame Sources?

Code: Uses. ActiveX; Function TForm1.GetFrame(FrameNo: Integer): IWebbrowser2; Var. OleContainer: IOleContainer; Enum: IEnumUnknown; Unk: IUnknown; Fetched: PLongint; Begin. While Webbrowser1.ReadyState <> READYSTATE_COMPLETE do. Application.ProcessMessages; If Assigned(Webbrowser1.document) then. Begin. Fetched := nil; OleContainer := Webbrowser1.Document as IOleContainer; OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum); Enum.Skip(FrameNo); Enum.Next(1, Unk, Fetched); Result := Unk as IWebbrowser2; End. Else. Result := nil; End; // Load sample page. // Testseite laden. Procedure TForm1.Button1Click(Sender: TObject); Begin. Webbrowser1.Navigate('http://www.warebizprogramming.com/tutorials/html/framesEx1.htm'); End; // Save all frames in single files. // Alle Frameseiten in einzelne Dateien speichern. Procedure TForm1.Button2Click(Sender: TObject); Var. IpStream: IPersistStreamInit; AStream: TMemoryStream; Iw: IWebbrowser2; I: Integer; Sl: TStringList; Begin. For i := 0 to Webbrowser1.OleObject.Document.frames.Length - 1 do. Begin. Iw := GetFrame(i); AStream := TMemoryStream.Create; Try. IpStream := iw.document as IPersistStreamInit; If Succeeded(IpStream.save(TStreamadapter.Create(AStream), True)) then. Begin. AStream.Seek(0, 0); Sl := TStringList.Create; Sl.LoadFromStream(AStream); Sl.SaveToFile('c:\frame' + IntToStr(i) + '.txt'); // memo1.Lines.LoadFromStream(AStream); Sl.Free; End; Except. End; AStream.Free; End; End; End.

Send e-mails via WinSock API?

Code: Unit SMTP_Connections; // ********************************************************************* // Unit Name : SMTP_Connections * // Author : Melih SARICA (Non ZERO) * // Date : 01/17/2004 * //********************************************************************** Interface. Uses. Classes, StdCtrls; Const. WinSock = 'wsock32.dll'; Internet = 2; Stream = 1; FIoNbRead = $4004667F; WinSMTP = $0001; LinuxSMTP = $0002; Type. TWSAData = packed record. WVersion: Word; WHighVersion: Word; SzDescription: array[0..256] of Char; SzSystemStatus: array[0..128] of Char; IMaxSockets: Word; IMaxUdpDg: Word; LpVendorInfo: PChar; End; PHost = ^THost; THost = packed record. Name: PChar; Aliases: ^PChar; Addrtype: Smallint; Length: Smallint; Addr: ^Pointer; End; TSockAddr = packed record. Family: Word; Port: Word; Addr: Longint; Zeros: array[0..7] of Byte; End; Function WSAStartup(Version:word; Var Data:TwsaData):integer; stdcall; far; external winsock; Function socket(Family,Kind,Protocol:integer):integer; stdcall; far; external winsock; Function shutdown(Socket,How:Integer):integer; stdcall; far; external winsock; Function closesocket(socket:Integer):integer; stdcall; far; external winsock; Function WSACleanup:integer; stdcall; far; external winsock; Function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock; Function listen(socket,flags:Integer):integer; stdcall; far; external winsock; Function connect(socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock; Function accept(socket:Integer; Var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock; Function WSAGetLastError:integer; stdcall; far; external winsock; Function recv(socket:integer; data:pchar; datalen, Flags:integer):integer; stdcall; far; external winsock; Function send(socket:integer; var data; datalen, Flags:integer):integer; stdcall; far; external winsock; Function gethostbyname(HostName:PChar):PHost; stdcall; far; external winsock; Function WSAIsBlocking:boolean; stdcall; far; external winsock; Function WSACancelBlockingCall:integer; stdcall; far; external winsock; Function ioctlsocket(socket:integer; cmd: Longint; Var arg: longint): Integer; stdcall; far; external winsock; Function gethostname(name:pchar; size:integer):integer; stdcall; far; external winsock; Procedure _authSendMail(MailServer,uname,upass,mFrom,mFromName,mToName, Subject:string;mto,mbody:TStringList); Function ConnectServer(mhost:string;mport:integer):integer; Function ConnectServerwin(mhost:string;mport:integer):integer; Function DisConnectServer:integer; Function Stat: string; Function SendCommand(Command: String): string; Function SendData(Command: String): string; Function SendCommandWin(Command: String): string; Function ReadCommand: string; Function encryptB64(s:string):string; Var. MconnHandle: Integer; MFin, mFOut: Textfile; EofSock: Boolean; Mactive: Boolean; MSMTPErrCode: Integer; MSMTPErrText: string; MMemo: TMemo; Implementation. Uses. SysUtils, Sockets, IdBaseComponent, IdCoder, IdCoder3to4, IdCoderMIME, IniFiles,Unit1; Var. MClient: TTcpClient; Procedure _authSendMail(MailServer, uname, upass, mFrom, mFromName, MToName, Subject: string; mto, mbody: TStringList); Var. Tmpstr: string; Cnt: Integer; Mstrlist: TStrings; RecipientCount: Integer; Begin. If ConnectServerWin(Mailserver, 25) = 250 then. Begin. Sendcommandwin('AUTH LOGIN '); SendcommandWin(encryptB64(uname)); SendcommandWin(encryptB64(upass)); SendcommandWin('MAIL FROM: ' + mfrom); For cnt := 0 to mto.Count - 1 do. SendcommandWin('RCPT TO: ' + mto[cnt]); Sendcommandwin('DATA'); SendData('Subject: ' + Subject); SendData('From: "' + mFromName + '" <' + mfrom + '>'); SendData('To: ' + mToName); SendData('Mime-Version: 1.0'); SendData('Content-Type: multipart/related; boundary="Esales-Order";'); SendData(' type="text/html"'); SendData(''); SendData('--Esales-Order'); SendData('Content-Type: text/html;'); SendData(' charset="iso-8859-9"'); SendData('Content-Transfer-Encoding: QUOTED-PRINTABLE'); SendData(''); For cnt := 0 to mbody.Count - 1 do. SendData(mbody[cnt]); Senddata(''); SendData('--Esales-Order--'); Senddata(' '); MSMTPErrText := SendCommand(crlf + '.' + crlf); Try. MSMTPErrCode := StrToInt(Copy(mSMTPErrText, 1, 3)); Except. End; SendData('QUIT'); DisConnectServer; End; End; Function Stat: string; Var. S: string; Begin. S := ReadCommand; Result := s; End; Function EchoCommand(Command: string): string; Begin. SendCommand(Command); Result := ReadCommand; End; Function ReadCommand: string; Var. Tmp: string; Begin. Repeat. ReadLn(mfin, tmp); If Assigned(mmemo) then. Mmemo.Lines.Add(tmp); Until (Length(tmp) < 4) or (tmp[4] <> '-'); Result := tmp. End; Function SendData(Command: string): string; Begin. Writeln(mfout, Command); End; Function SendCommand(Command: string): string; Begin. Writeln(mfout, Command); Result := stat; End; Function SendCommandWin(Command: string): string; Begin. Writeln(mfout, Command + #13); Result := stat; End; Function FillBlank(Source: string; number: Integer): string; Var. A: Integer; Begin. Result := ''; For a := Length(trim(Source)) to number do. Result := Result + ' '; End; Function IpToLong(ip: string): Longint; Var. X, i: Byte; Ipx: array[0..3] of Byte; V: Integer; Begin. Result := 0; Longint(ipx) := 0; I := 0; For x := 1 to Length(ip) do. If ip[x] = '.' then. Begin. Inc(i); If i = 4 then Exit; End. Else. Begin. If not (ip[x] in ['0'..'9']) then Exit; V := ipx[i] * 10 + Ord(ip[x]) - Ord('0'); If v > 255 then Exit; Ipx[i] := v; End; Result := Longint(ipx); End; Function HostToLong(AHost: string): Longint; Var. Host: PHost; Begin. Result := IpToLong(AHost); If Result = 0 then. Begin. Host := GetHostByName(PChar(AHost)); If Host <> nil then Result := Longint(Host^.Addr^^); End; End; Function LongToIp(Long: Longint): string; Var. Ipx: array[0..3] of Byte; I: Byte; Begin. Longint(ipx) := long; Result := ''; For i := 0 to 3 do Result := Result + IntToStr(ipx[i]) + '.'; SetLength(Result, Length(Result) - 1); End; Procedure Disconnect(Socket: Integer); Begin. ShutDown(Socket, 1); CloseSocket(Socket); End; Function CallServer(Server: string; Port: Word): Integer; Var. SockAddr: TSockAddr; Begin. Result := socket(Internet, Stream, 0); If Result = -1 then Exit; FillChar(SockAddr, SizeOf(SockAddr), 0); SockAddr.Family := Internet; SockAddr.Port := swap(Port); SockAddr.Addr := HostToLong(Server); If Connect(Result, SockAddr, SizeOf(SockAddr)) <> 0 then. Begin. Disconnect(Result); Result := -1; End; End; Function OutputSock(var F: TTextRec): Integer; far; Begin. If F.BufPos <> 0 then. Begin. Send(F.Handle, F.BufPtr^, F.BufPos, 0); F.BufPos := 0; End; Result := 0; End; Function InputSock(var F: TTextRec): Integer; far; Var. Size: Longint; Begin. F.BufEnd := 0; F.BufPos := 0; Result := 0; Repeat. If (IoctlSocket(F.Handle, fIoNbRead, Size) < 0) then. Begin. EofSock := True; Exit; End; Until (Size >= 0); F.BufEnd := Recv(F.Handle, F.BufPtr, F.BufSize, 0); EofSock := (F.Bufend = 0); End; Function CloseSock(var F: TTextRec): Integer; far; Begin. Disconnect(F.Handle); F.Handle := -1; Result := 0; End; Function OpenSock(var F: TTextRec): Integer; far; Begin. If F.Mode = fmInput then. Begin. EofSock := False; F.BufPos := 0; F.BufEnd := 0; F.InOutFunc := @InputSock; F.FlushFunc := nil; End. Else. Begin. F.Mode := fmOutput; F.InOutFunc := @OutputSock; F.FlushFunc := @OutputSock; End; F.CloseFunc := @CloseSock; Result := 0; End; Procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile); Begin. With TTextRec(Input) do. Begin. Handle := Socket; Mode := fmClosed; BufSize := SizeOf(Buffer); BufPtr := @Buffer; OpenFunc := @OpenSock; End; With TTextRec(Output) do. Begin. Handle := Socket; Mode := fmClosed; BufSize := SizeOf(Buffer); BufPtr := @Buffer; OpenFunc := @OpenSock; End; Reset(Input); Rewrite(Output); End; Function ConnectServer(mhost: string; mport: Integer): Integer; Var. Tmp: string; Begin. MClient := TTcpClient.Create(nil); MClient.RemoteHost := mhost; MClient.RemotePort := IntToStr(mport); MClient.Connect; Mconnhandle := callserver(mhost, mport); If (mconnHandle<>-1) then. Begin. AssignCrtSock(mconnHandle, mFin, MFout); Tmp := stat; Tmp := SendCommand('HELO bellona.com.tr'); If Copy(tmp, 1, 3) = '250' then. Begin. Result := StrToInt(Copy(tmp, 1, 3)); End; End; End; Function ConnectServerWin(mhost: string; mport: Integer): Integer; Var. Tmp: string; Begin. MClient := TTcpClient.Create(nil); MClient.RemoteHost := mhost; MClient.RemotePort := IntToStr(mport); MClient.Connect; Mconnhandle := callserver(mhost, mport); If (mconnHandle<>-1) then. Begin. AssignCrtSock(mconnHandle, mFin, MFout); Tmp := stat; Tmp := SendCommandWin('HELO bellona.com.tr'); If Copy(tmp, 1, 3) = '250' then. Begin. Result := StrToInt(Copy(tmp, 1, 3)); End; End; End; Function DisConnectServer: Integer; Begin. Closesocket(mconnhandle); MClient.Disconnect; Mclient.Free; End; Function encryptB64(s: string): string; Var. Hash1: TIdEncoderMIME; P: string; Begin. If s <> '' then. Begin. Hash1 := TIdEncoderMIME.Create(nil); P := hash1.Encode(s); Hash1.Free; End; Result := p; End; End. {***************************************************} { How to use it}. {***************************************************} Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Memo1: TMemo; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Uses. SMTP_Connections; Procedure TForm1.Button1Click(Sender: TObject); Var. Mto, mbody: TStringList; MailServer, uname, upass, mFrom, mFromName, MToName, Subject: string; Begin. MMemo := Memo1; // to output server feedback. //.......................... MailServer := 'mail.xyz.net'; Uname := 'username'; Upass := 'password'; MFrom := 'user@xyz.net'; MFromName := 'forename surname'; MToName := ''; Subject := 'Your Subject'; //.......................... Mto := TStringList.Create; Mbody := TStringList.Create; Try. Mto.Add('anybody@xyz.net'); Mbody.Add('Test Mail'); //Send Mail................. _authSendMail(MailServer, uname, upass, mFrom, mFromName, MToName, Subject, mto, mbody); //.......................... Finally. Mto.Free; Mbody.Free; End; End; End.

©Drkb::03405.

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

Code: Function _RegReadString(_hkey:longint;const ValueName:string; Var Value:string;const SubKey:string):Boolean; Var Key:HKey; BufLen,Typed:DWord; Begin. Result:=False; Value:=EmptyStr; If RegOpenKeyEx(_hkey,pchar(subkey),0,KEY_READ,Key)=ERROR_SUCCESS then. Begin. Typed:=REG_SZ; BufLen:=$FFFF; SetLength(Value,BufLen); If RegQueryValueEx(Key,PChar(ValueName), Nil,@Typed,@Value[1],@BufLen)=ERROR_SUCCESS then. Begin. If BufLen>0 then SetLength(Value,BufLen-1) else Value:=EmptyStr; Result:=True; End; RegCloseKey(Key); End; End; Function _HostToIP(Name: string):string; Var. Wsdata : TWSAData; HostName : array [0..255] of char; HostEnt : PHostEnt; Addr : PChar; Begin. WSAStartup ($0101, wsdata); 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. Result := Format ('%d.%d.%d.%d', [byte (addr [0]), Byte (addr [1]), byte (addr [2]), byte (addr [3])]); End; End; WSACleanup; End; Function GetSMTPServer:string; Var s,j:string; Begin. Result := ''; _regreadstring(hkey_current_user,'Default Mail Account',s, 'Software\Microsoft\Internet Account Manager'); If s = '' then exit; _regreadstring(hkey_current_user,'SMTP Server',j, 'Software\Microsoft\Internet Account Manager\Accounts\' + s); Result := j; End; Procedure SendStr(Sock:cardinal;str: String); Var. I: Integer; Begin. For I:=1 to Length(str) do. If send(sock,str[I],1,0)=SOCKET_ERROR then exit; End; Procedure ConnectAndSend(from,_to,st:string); Var. Wsadata: TWSADATA; Sin: TSockAddrIn; Sock: TSocket; MySmtp : String; Iaddr: Integer; Buf: array[0..255] of char; Begin. MySmtp := _HostToIP(getsmtpserver); WSAStartUp(257, wsadata); Sock:=socket(AF_INET,SOCK_STREAM,IPPROTO_IP); Sin.sin_family := AF_INET; Htons(25); Sin.sin_port := htons(25); Iaddr:=inet_addr(PChar(MySmtp)); Sin.sin_addr.S_addr:=iaddr; Connect(sock,sin,sizeof(sin)); Recv(sock,buf,sizeof(buf),0); Sendstr(sock,'HELO google.com'+#13#10); Recv(sock,buf,sizeof(buf),0); Sendstr(sock,'MAIL FROM: '+from+#13#10); Recv(sock,buf,sizeof(buf),0); Sendstr(sock,'RCPT TO: '+_to+#13#10); Recv(sock,buf,sizeof(buf),0); Sendstr(sock,'DATA'+#13#10); Recv(sock,buf,sizeof(buf),0); Sendstr(sock,st); Sendstr(sock,#13#10'.'#13#10); Recv(sock,buf,sizeof(buf),0); Sendstr(sock,'QUIT'#13#10); Recv(sock,buf,sizeof(buf),0); Closesocket(sock); End;

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

Автор: TauxCanolf.

©Drkb::03406.

Sending a file via DCOM.

I would like to send a file through DCOM however I can only send standard types. How can I send bytes across to a client?

You need to use a variant array (VarArrayLock should be useful as well).

©Drkb::04330.

Sending an image to the printer.

Sending a bitmap based on the screen to the printer is an.

Invalid operation that will usually fail, unless the print.

Driver has been designed to detect this error condition and.

Compensate for the error. This means you should use the VCL.

Canvas methods Draw, StretchDraw,CopyRect, BrushCopy, and.

The like to transfer a bitmap to the printer, since the.

Underlying bitmap is based on the screen, and is device.

Dependent. The only way to reliably print an image is to.

Use DIBs (Device Independent Bitmaps). Getting a valid DIB can.

Be difficult, as there are many Windows API functions that must.

Be used correctly. Further, many video drivers incorrectly fill.

In the DIB structure in regards to the color table in the DIB.

The following example demonstrates an attempt to overcome.

Some of these problems and limitations. The example should.

Compile successfully under all versions of Delphi/C++ Builder.

The core function in the example, BltTBitmapAsDib(), accepts.

A handle to a device to image to, the x and y coordinates you.

Wish the bitmap to be imaged at, the width and height you wish.

The image to be (stretching and shrinking is acceptable), and.

The TBitmap you wish to image.

Code: Uses Printers; Type. PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}. TPalEntriesArray = array[0..0] of TPaletteEntry; Procedure BltTBitmapAsDib(DestDc : hdc; {Handle of where to blt}. X : word; {Bit at x}. Y : word; {Blt at y}. Width : word; {Width to stretch}. Height : word; {Height to stretch}. Bm : TBitmap); {the TBitmap to Blt}. Var. OriginalWidth :LongInt; {width of BM}. Dc : hdc; {screen dc}. IsPaletteDevice : bool; {if the device uses palettes}. IsDestPaletteDevice : bool; {if the device uses palettes}. BitmapInfoSize : integer; {sizeof the bitmapinfoheader}. LpBitmapInfo : PBitmapInfo; {the bitmap info header}. HBm : hBitmap; {handle to the bitmap}. HPal : hPalette; {handle to the palette}. OldPal : hPalette; {temp palette}. HBits : THandle; {handle to the DIB bits}. PBits : pointer; {pointer to the DIB bits}. LPPalEntriesArray : PPalEntriesArray; {palette entry array}. NumPalEntries : integer; {number of palette entries}. I : integer; {looping variable}. Begin. {If range checking is on - lets turn it off for now}. {we will remember if range checking was on by defining}. {a define called CKRANGE if range checking is on.}. {We do this to access array members past the arrays}. {defined index range without causing a range check}. {error at runtime. To satisfy the compiler, we must}. {also access the indexes with a variable. ie: if we}. {have an array defined as a: array[0..0] of byte,}. {and an integer i, we can now access a[3] by setting}. {i := 3; and then accessing a[i] without error}. {$IFOPT R+}. {$DEFINE CKRANGE}. {$R-}. {$ENDIF}. {Save the original width of the bitmap}. OriginalWidth := bm.Width; {Get the screen's dc to use since memory dc's are not reliable}. Dc := GetDc(0); {Are we a palette device?}. IsPaletteDevice := GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE; {Give back the screen dc}. Dc := ReleaseDc(0, dc); {Allocate the BitmapInfo structure}. If IsPaletteDevice then. BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255). Else. BitmapInfoSize := sizeof(TBitmapInfo); GetMem(lpBitmapInfo, BitmapInfoSize); {Zero out the BitmapInfo structure}. FillChar(lpBitmapInfo^, BitmapInfoSize, #0); {Fill in the BitmapInfo structure}. LpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader); LpBitmapInfo^.bmiHeader.biWidth := OriginalWidth; LpBitmapInfo^.bmiHeader.biHeight := bm.Height; LpBitmapInfo^.bmiHeader.biPlanes := 1; If IsPaletteDevice then. LpBitmapInfo^.bmiHeader.biBitCount := 8. Else. LpBitmapInfo^.bmiHeader.biBitCount := 24; LpBitmapInfo^.bmiHeader.biCompression := BI_RGB; LpBitmapInfo^.bmiHeader.biSizeImage := ((lpBitmapInfo^.bmiHeader.biWidth * Longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) * LpBitmapInfo^.bmiHeader.biHeight; LpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0; LpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0; If IsPaletteDevice then begin. LpBitmapInfo^.bmiHeader.biClrUsed := 256; LpBitmapInfo^.bmiHeader.biClrImportant := 256; End else begin. LpBitmapInfo^.bmiHeader.biClrUsed := 0; LpBitmapInfo^.bmiHeader.biClrImportant := 0; End; {Take ownership of the bitmap handle and palette}. HBm := bm.ReleaseHandle; HPal := bm.ReleasePalette; {Get the screen's dc to use since memory dc's are not reliable}. Dc := GetDc(0); If IsPaletteDevice then begin. {If we are using a palette, it must be}. {selected into the dc during the conversion}. OldPal := SelectPalette(dc, hPal, TRUE); {Realize the palette}. RealizePalette(dc); End; {Tell GetDiBits to fill in the rest of the bitmap info structure}. GetDiBits(dc, HBm, 0, LpBitmapInfo^.bmiHeader.biHeight, Nil, TBitmapInfo(lpBitmapInfo^), DIB_RGB_COLORS); {Allocate memory for the Bits}. HBits := GlobalAlloc(GMEM_MOVEABLE, LpBitmapInfo^.bmiHeader.biSizeImage); PBits := GlobalLock(hBits); {Get the bits}. GetDiBits(dc, HBm, 0, LpBitmapInfo^.bmiHeader.biHeight, PBits, TBitmapInfo(lpBitmapInfo^), DIB_RGB_COLORS); If IsPaletteDevice then begin. {Lets fix up the color table for buggy video drivers}. GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256); {$IFDEF VER100}. NumPalEntries := GetPaletteEntries(hPal, 0, 256, LPPalEntriesArray^); {$ELSE}. NumPalEntries := GetSystemPaletteEntries(dc, 0, 256, LPPalEntriesArray^); {$ENDIF}. For i := 0 to (NumPalEntries - 1) do begin. LpBitmapInfo^.bmiColors[i].rgbRed := LPPalEntriesArray^[i].peRed; LpBitmapInfo^.bmiColors[i].rgbGreen := LPPalEntriesArray^[i].peGreen; LpBitmapInfo^.bmiColors[i].rgbBlue := LPPalEntriesArray^[i].peBlue; End; FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256); End; If IsPaletteDevice then begin. {Select the old palette back in}. SelectPalette(dc, OldPal, TRUE); {Realize the old palette}. RealizePalette(dc); End; {Give back the screen dc}. Dc := ReleaseDc(0, dc); {Is the Dest dc a palette device?}. IsDestPaletteDevice := GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE; If IsPaletteDevice then begin. {If we are using a palette, it must be}. {selected into the dc during the conversion}. OldPal := SelectPalette(DestDc, hPal, TRUE); {Realize the palette}. RealizePalette(DestDc); End; {Do the blt}. StretchDiBits(DestDc, X, Y, Width, Height, 0, 0, OriginalWidth, LpBitmapInfo^.bmiHeader.biHeight, PBits, LpBitmapInfo^, DIB_RGB_COLORS, SrcCopy); If IsDestPaletteDevice then begin. {Select the old palette back in}. SelectPalette(DestDc, OldPal, TRUE); {Realize the old palette}. RealizePalette(DestDc); End; {De-Allocate the Dib Bits}. GlobalUnLock(hBits); GlobalFree(hBits); {De-Allocate the BitmapInfo}. FreeMem(lpBitmapInfo, BitmapInfoSize); {Set the ownership of the bimap handles back to the bitmap}. Bm.Handle := hBm; Bm.Palette := hPal; {Turn range checking back on if it was on when we started}. {$IFDEF CKRANGE}. {$UNDEF CKRANGE}. {$R+}. {$ENDIF}. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If PrintDialog1.Execute then begin. Printer.BeginDoc; BltTBitmapAsDib(Printer.Canvas.Handle, 0, 0, Image1.Picture.Bitmap.Width, Image1.Picture.Bitmap.Height, Image1.Picture.Bitmap); Printer.EndDoc; End; End;

SendMess.pas.

SetFocus в Edit на OnExit.

Я пробую выполнить editbox.SetFocus и/или editbox.Clear, но но это не дает никакого эффекта (по крайней мере видимого). Что я делаю неправильно?

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

SetFocus в TStringGrid.

Code: Grid.Row := YourRowNumber; Grid.TopRow := YourFirstVisibleRow; Grid.LeftCol := YourFirstVisibleColumn;

Sharpen a Bitmap.

Code: Procedure Sharpen(sbm, tbm: TBitmap; alpha: Single); //to sharpen, alpha must be >1. //pixelformat pf24bit. //sharpens sbm to tbm. Var. I, j, k: integer; Sr: array[0..2] of PByte; St: array[0..4] of pRGBTriple; Tr: PByte; Tt, p: pRGBTriple; Beta: Single; Inta, intb: integer; Bmh, bmw: integer; Re, gr, bl: integer; BytesPerScanline: integer; Begin. //sharpening is blending of the current pixel. //with the average of the surrounding ones, //but with a negative weight for the average. Assert((sbm.Width > 2) and (sbm.Height > 2), 'Bitmap must be at least 3x3'); Assert((alpha > 1) and (alpha < 6), 'Alpha must be >1 and <6'); Beta := (alpha - 1) / 5; //we assume alpha>1 and beta<1. Intb := round(beta * $10000); Inta := round(alpha * $10000); //integer scaled alpha and beta. Sbm.PixelFormat := pf24bit; Tbm.PixelFormat := pf24bit; Tbm.Width := sbm.Width; Tbm.Height := sbm.Height; Bmw := sbm.Width - 2; Bmh := sbm.Height - 2; BytesPerScanline := (((bmw + 2) * 24 + 31) and not 31) div 8; Tr := tbm.Scanline[0]; Tt := pRGBTriple(tr); Sr[0] := sbm.Scanline[0]; St[0] := pRGBTriple(sr[0]); For j := 0 to bmw + 1 do. Begin. Tt^ := st[0]^; Inc(tt); inc(st[0]); //first row unchanged. End; Sr[1] := PByte(integer(sr[0]) - BytesPerScanline); Sr[2] := PByte(integer(sr[1]) - BytesPerScanline); For i := 1 to bmh do. Begin. Dec(tr, BytesPerScanline); Tt := pRGBTriple(tr); St[0] := pRGBTriple(integer(sr[0]) + 3); //top. St[1] := pRGBTriple(sr[1]); //left. St[2] := pRGBTriple(integer(sr[1]) + 3); //center. St[3] := pRGBTriple(integer(sr[1]) + 6); //right. St[4] := pRGBTriple(integer(sr[2]) + 3); //bottom. Tt^ := st[1]^; //1st col unchanged. For j := 1 to bmw do. Begin. //calcutate average weighted by -beta. Re := 0; gr := 0; bl := 0; For k := 0 to 4 do. Begin. Re := re + st[k]^.rgbtRed; Gr := gr + st[k]^.rgbtGreen; Bl := bl + st[k]^.rgbtBlue; Inc(st[k]); End; Re := (intb * re + $7FFF) shr 16; Gr := (intb * gr + $7FFF) shr 16; Bl := (intb * bl + $7FFF) shr 16; //add center pixel weighted by alpha. P := pRGBTriple(st[1]); //after inc, st[1] is at center. Re := (inta * p^.rgbtRed + $7FFF) shr 16 - re; Gr := (inta * p^.rgbtGreen + $7FFF) shr 16 - gr; Bl := (inta * p^.rgbtBlue + $7FFF) shr 16 - bl; //clamp and move into target pixel. Inc(tt); If re < 0 then. Re := 0. Else. If re > 255 then. Re := 255; If gr < 0 then. Gr := 0. Else. If gr > 255 then. Gr := 255; If bl < 0 then. Bl := 0. Else. If bl > 255 then. Bl := 255; //this looks stupid, but avoids function calls. Tt^.rgbtRed := re; Tt^.rgbtGreen := gr; Tt^.rgbtBlue := bl; End; Inc(tt); Inc(st[1]); Tt^ := st[1]^; //Last col unchanged. Sr[0] := sr[1]; Sr[1] := sr[2]; Dec(sr[2], BytesPerScanline); End; // copy last row. Dec(tr, BytesPerScanline); Tt := pRGBTriple(tr); St[1] := pRGBTriple(sr[1]); For j := 0 to bmw + 1 do. Begin. Tt^ := st[1]^; Inc(tt); inc(st[1]); End; End;

©Drkb::03863.

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

Глюк при запуске приложений через ShellListView.

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

Code: {©Drkb v.3(2007): www.drkb.ru}. Procedure TCustomShellListView.DblClick; Begin. If FAutoNavigate and (Selected <> nil) then. With Folders[Selected.Index] do. If IsFolder then. SetPathFromID(AbsoluteID). Else. ShellExecute(Handle, nil, PChar(PathName), nil, PChar(ExtractFilePath(PathName)), 0); Inherited DblClick; End; На вот такую: Procedure TCustomShellListView.DblClick; Begin. If FAutoNavigate and (Selected <> nil) then. With Folders[Selected.Index] do. If IsFolder then. SetPathFromID(AbsoluteID). Else. ShellExecute(Handle, 'open', PChar(PathName), nil, PChar(ExtractFilePath(PathName)), SW_SHOW); Inherited DblClick; End;

Shell Extensions и как с ними бороться (статья).

Shell Extensions и как с ними бороться

Думаю, вы замечали, что некоторые программы добавляют собственные пункты в системное контекстное меню. Например, WinRAR добавляет "Сжать" и "Распаковать в…", ICQ - "Переслать пользователю" и пр. Механизм, с помощью которого ваш код "внедряется" в оболочку Windows, называется Shell Extensions - именно о нем пойдет речь…

Определения

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

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

Shell Extensions - набор сервисных функций Windows API, призванный обеспечить расширение базовых функций оболочки Windows Explorer за счет наших надстроек. В числе основных функций Shell Extensions:

· работа с системными контекстными меню;

· работа с папками и объектами из пространства имен оболочки Windows (Мои Документы, Принтеры, Панель управления…);

· использование механизма Drag&Drop;

· создание и использование ярлыков.

Should I install Kylix as root or a regular user?

Installing Kylix as root has the advantage of allowing all users to access the Kylix installation, provided you install it into a "shared" location. I reccomend installing Kylix as root into the directory /usr/local/kylix. However, if you are going to be the only user using Kylix, you may want to install it as that user into your home directory.

To install as root, type su from the command prompt and enter the super user password. Then, run the Kylix installer.

Примечание от Vit: обычно при установке от имени root возникает ошибка -10.

©Drkb::04606.

Show a text progressiv as typed with a typewriter (horizontal/vertical).

Code: { To make this code to work you would need 2 images, One for the horizontal- and another for the vertical text. } // VerticalTypewriter ( <Text>, <Image to write to>, <Time to delay between every chars> ). Procedure VerticalTypewriter(text: string; image: timage; delay: integer); Var. X,y,i: integer; Begin. Image.Canvas.Refresh; Application.ProcessMessages; Y := 1; For i := 1 to length(text) do begin. Application.ProcessMessages; Y := y+image.Canvas.TextHeight(text[i]); X := image.width div 2 - (image.Canvas.TextWidth(text[i]) div 2); Image.Canvas.TextOut(x,y,text[i]); Sleep(delay); End; End; // Horizontal Typewriter ( <Text>, <Image to write to>, <Time to delay between every chars>, <Space between chars>). Procedure HorizontalTypewriter(text: string; image: timage; delay, space: integer); Var. X,y,i: integer; Begin. Image.Canvas.Refresh; Application.ProcessMessages; X := 1; For i := 1 to length(text) do begin. Application.ProcessMessages; Y := image.Picture.Height div 2 - (image.Canvas.TextHeight(text[i]) div 2); X := x+image.Canvas.TextWidth(text[i])+space; Image.Canvas.TextOut(x,y,text[i]); Sleep(delay); End; End; // Sample calls: Procedure TForm1.Button1Click(Sender: TObject); Begin. // <text> <image> <delay> VerticalTypewriter('HELLO BIG-X', image1, 100 ); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. // <text> <image> <delay> <space> HorizontalTypewriter('Hello Big-X', image2, 100, 1 ); End;

Как вызвать Shutdown Windows dialog?

Code: Uses ComObj; {....} Procedure TForm1.Button1Click(Sender: TObject); Var. Shell: Variant; Begin. Shell := CreateOleObject('Shell.Application'); Shell.ShutdownWindows; End;

Приостановить компьютер (sleep).

У компьютеров ATX есть функция Sleep. Эта программа заставляет компьютер "заснуть".

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. SetSystemPowerState(true, true); End;

©Drkb::01703.

Автор советов: Даниил Карапетян.

E-mail: delphi4all@narod.ru.

Автор справки: Алексей Денисов.

E-mail: aleksey@sch103.krasnoyarsk.su.

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Переход в Спящий режим (WinNT). Зависимости: Windows, system. Автор: DeMoN-777, DeMoN-777@yandex.ru, ICQ:169281983, Санкт-Петербург. Copyright: @ Дата: 21 сентября 2002 г. ***************************************************** } Procedure NTSleep; Var. HToken: THandle; Tkp: TTokenPrivileges; ReturnLength: Cardinal; Begin. If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or. TOKEN_QUERY, hToken) then. Begin. LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid); Tkp.PrivilegeCount := 1; // one privelege to set. Tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; If AdjustTokenPrivileges(hToken, False, tkp, 0, nil, ReturnLength) then. SetSystemPowerState(true, true); End; End;

Smtpsock.pas.

Code: Unit SmtpSock; { CrtSocket for Delphi 32. Copyright (C) 1999-2001 Paul Toth <tothpaul@free.fr> Http://tothpaul.free.fr. This program is free software; you can redistribute it and/or. Modify it under the terms of the GNU General Public License. As published by the Free Software Foundation; either version 2. Of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, But WITHOUT ANY WARRANTY; without even the implied warranty of. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the. GNU General Public License for more details. You should have received a copy of the GNU General Public License. Along with this program; if not, write to the Free Software. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. } Interface. Uses. CrtSock,Classes; Function SmtpOpen(Server:string):integer; Function SmtpError:string; Procedure SmtpClose; Function SmtpFrom(Email:string):boolean; Function SmtpTo(Email:string):boolean; Function SmtpHead(From,Rcpt,Subject:string):boolean; Function SmtpSend(From,Rcpt,Subject:string; Msg:TStrings):boolean; Procedure SmtpJoin(Name:string; Stream:TStream; Count:integer); Function SmtpDone:boolean; Implementation. Var. Sin,sout:TextFile; Last:string; Function ReadString:string; Begin. Repeat. Readln(sin,Result); // writeln(result); Until (Length(Result)<4)or(Result[4]<>'-'); Last:=Result; End; Procedure WriteString(s:string); Begin. // writeln('>>>',s); WriteLn(sout,s); End; Function Status:char; Var. S:string; Begin. S:=ReadString; If s='' then Status:='?' else Status:=s[1]; End; Function Exec(cmd:string):char; Begin. Writestring(cmd); Result:=Status; End; Function SmtpOpen(Server:string):integer; Begin. Last:='Server not found'; Result:=CallServer(Server,25); If Result>0 then begin. AssignCrtSock(Result,sin,sout); If Status='2' then begin. If Exec('HELO MySoft.Delphi')='2' then exit; Disconnect(Result); Result:=-3; End else begin. Disconnect(Result); Result:=-2; End; End; End; Function SmtpError:string; Begin. Result:=Last; End; Procedure SmtpClose; Begin. CloseFile(sout); End; Function SmtpFrom(Email:string):boolean; Begin. Result:=(Exec('MAIL '+'From: '+EMail)='2'); End; Function SmtpTo(EMail:string):boolean; Begin. Result:=(Exec('RCPT To:'+Email)='2'); End; Function SmtpHead(From,Rcpt,Subject:string):boolean; Begin. Result:=False; If Exec('DATA')<>'3' then exit; WriteString('From: '+From); WriteString('To: '+Rcpt); WriteString('Subject: '+Subject); WriteString('Content-Type: text/plain; charset=ISO-8859-1'); WriteString('Content-Transfer-Encoding: 8bit'#13#10); WriteString(''); Result:=True; End; Function SmtpSend(From,Rcpt,Subject:string; Msg:TStrings):boolean; Begin. Result:=False; If not SmtpHead(From,Rcpt,Subject) then exit; WriteString(Msg.Text); Result:=SmtpDone; End; Function uchr(b:byte):char; Begin. If b=0 then result:=#96 else result:=chr(b+32); End; Procedure SmtpJoin(Name:string; Stream:TStream; Count:integer); Var. S:string[76]; Size:integer; U:string; Ss:integer; C1,c2:byte; X:integer; Begin. WriteString('begin 600 '+Name); Size:=45; While Count>0 do begin. If size>Count then size:=count; Dec(count,size); Stream.Read(s[1],size); U:=uchr(size); Ss:=2; C2:=0; For x:=1 to size do begin. C1:=ord(s[x]); U:=u+uchr(c2 or (c1 shr ss)); C2:=(c1 shl (6-ss)) and 63; Ss:=(ss+2) and 7; If ss=0 then begin. Ss:=2; U:=u+uchr(c2); C2:=0; End; End; If (ss>2) then begin. U:=u+uchr(c2)+#96; If ss=4 then u:=u+#96; End; WriteString(u); End; WriteString('end'); End; Function SmtpDone:boolean; Begin. Result:=(Exec('.')='2'); CloseFile(sout); End; End.

Split/merge files?

Code: { Parameters: FileToSplit: Specify a file to split. SizeofFiles: Specify the size of the files you want to split to (in bytes). Progressbar: Specify a TProgressBar to show the splitting progress. Result: SplitFile() will create files FileName.001, FileName.002, FileName.003 and so on. That are SizeofFiles bytes in size. } Function SplitFile(FileName : TFileName; SizeofFiles : Integer; ProgressBar : TProgressBar) : Boolean; Var. I : Word; Fs, sStream: TFileStream; SplitFileName: String; Begin. ProgressBar.Position := 0; Fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); Try. For i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do. Begin. SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i)); SStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive); Try. If fs.Size - fs.Position < SizeofFiles then. SizeofFiles := fs.Size - fs.Position; SStream.CopyFrom(fs, SizeofFiles); ProgressBar.Position := Round((fs.Position / fs.Size) * 100); Finally. SStream.Free; End; End; Finally. Fs.Free; End; End; // Combine files / Dateien zusammenfuhren. { Parameters: FileName: Specify the first piece of the splitted files. CombinedFileName: Specify the combined file name. (the output file). Result: CombineFiles() will create one large file from the pieces. } Function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean; Var. I: integer; Fs, sStream: TFileStream; FilenameOrg: String; Begin. I := 1; Fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive); Try. While FileExists(FileName) do. Begin. SStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); Try. Fs.CopyFrom(sStream, 0); Finally. SStream.Free; End; Inc(i); FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i)); End; Finally. Fs.Free; End; End;

Spray effect.

Code: Procedure Spray(Canvas: TCanvas; x, y, r: Integer; Color: TColor); Var. Rad, a: Single; I: Integer; Begin. For i := 0 to 100 do. Begin. A := Random * 2 * pi; Rad := Random * r; Canvas.Pixels[x + Round(rad * Cos(a)), y + Round(rad * Sin(a))] := Color; End; End; Procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If ssLeft in Shift then Spray(Image1.Canvas, x, y, 40, clRed); End; Procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If ssLeft in Shift then Spray(Image1.Canvas, x, y, 40, clRed); End;

Основы языка SQL (статья).

Обзор

SQL (обычно произносимый как "СИКВЭЛ" или "ЭСКЮЭЛЬ") символизирует собой Структурированный Язык Запросов. Это - язык, который дает Вам возможность создавать и работать в реляционных базах данных, являющихся наборами связанной информации, сохраняемой в таблицах.

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

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

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

Стандарт SQL определяется ANSI (Американским Национальным Институтом Стандартов) и в данное время также принимается ISO (Международной Организацией по Стандартизации). Однако, большинство коммерческих программ баз данных расширяют SQL без уведомления ANSI, добавляя различные особенности в этот язык, которые, как они считают, будут весьма полезны. Иногда они несколько нарушают стандарт языка, хотя хорошие идеи имеют тенденцию развиваться и вскоре становиться стандартами "рынка" сами по себе в силу полезности своих качеств.

На данном уроке мы будем, в основном, следовать стандарту ANSI, но одновременно иногда будет показывать и некоторые наиболее общие отклонения от его стандарта.

Точное описание особенностей языка приводится в документации на СУБД, которую Вы используете. SQL системы InterBase 4.0 соответствует стандарту ANSI-92 и частично стандарту ANSI-III.

Состав языка SQL.

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

Поэтому, в язык SQL в качестве составных частей входят:

• язык манипулирования данными (Data Manipulation Language, DML)

• язык определения данных (Data Definition Language, DDL)

• язык управления данными (Data Control Language, DCL).

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

Язык манипулирования данными используется, как это следует из его названия, для манипулирования данными в таблицах баз данных. Он состоит из 4 основных команд:

SELECT (выбрать).

INSERT (вставить).

UPDATE (обновить).

DELETE (удалить).

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

CREATE DATABASE (создать базу данных).

CREATE TABLE (создать таблицу).

CREATE VIEW (создать виртуальную таблицу).

CREATE INDEX (создать индекс).

CREATE TRIGGER (создать триггер).

CREATE PROCEDURE (создать сохраненную процедуру).

ALTER DATABASE (модифицировать базу данных).

ALTER TABLE (модифицировать таблицу).

ALTER VIEW (модифицировать виртуальную таблицу).

ALTER INDEX (модифицировать индекс).

ALTER TRIGGER (модифицировать триггер).

ALTER PROCEDURE (модифицировать сохраненную процедуру).

DROP DATABASE (удалить базу данных).

DROP TABLE (удалить таблицу).

DROP VIEW (удалить виртуальную таблицу).

DROP INDEX (удалить индекс).

DROP TRIGGER (удалить триггер).

DROP PROCEDURE (удалить сохраненную процедуру).

Язык управления данными используется для управления правами доступа к данным и выполнением процедур в многопользовательской среде. Более точно его можно назвать "язык управления доступом". Он состоит из двух основных команд:

GRANT (дать права).

REVOKE (забрать права).

С точки зрения прикладного интерфейса существуют две разновидности команд SQL:

• интерактивный SQL.

• встроенный SQL.

Интерактивный SQL используется в специальных утилитах (типа WISQL или DBD), позволяющих в интерактивном режиме вводить запросы с использованием команд SQL, посылать их для выполнения на сервер и получать результаты в предназначенном для этого окне. Встроенный SQL используется в прикладных программах, позволяя им посылать запросы к серверу и обрабатывать полученные результаты, в том числе комбинируя set-ориентированный и record-ориентированный подходы.

Мы не будем приводить точный синтаксис команд SQL, вместо этого мы рассмотрим их на многочисленных примерах, что намного более важно для понимания SQL, чем точный синтаксис, который можно посмотреть в документации на Вашу СУБД.

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

Реляционные операции. Команды языка манипулирования данными.

Наиболее важной командой языка манипулирования данными является команда SELECT. За кажущейся простотой ее синтаксиса скрывается огромное богатство возможностей. Нам важно научиться использовать это богатство!

На данном уроке предполагается, если не оговорено противное, что все команды языка SQL вводятся интерактивным способом. В качестве информационной основы для примеров мы будем использовать базу данных "Служащие предприятия" (employee.gdb), входящую в поставку Delphi и находящуюся (по умолчанию) в поддиректории \IBLOCAL\EXAMPLES.

Рис. 1: Структура базы данных EMPLOYEE.

На рис.1 приведена схема базы данных EMPLOYEE для Local InterBase, нарисованная с помощью CASE-средства S-Designor (см. доп. урок). На схеме показаны таблицы базы данных и взаимосвязи, а также обозначены первичные ключи и их связи с внешними ключами. Многие из примеров, особенно в конце урока, являются весьма сложными. Однако, не следует на этом основании делать вывод, что так сложен сам язык SQL. Дело, скорее, в том, что обычные (стандартные) операции настолько просты в SQL, что примеры таких операций оказываются довольно неинтересными и не иллюстрируют полной мощности этого языка. Но в целях системности мы пройдем по всем возможностям SQL: от самых простых - до чрезвычайно сложных.

Начнем с базовых операций реляционных баз данных. Таковыми являются:

• выборка (Restriction).

• проекция (Projection).

• соединение (Join).

• объединение (Union).

Операция выборки позволяет получить все строки (записи) либо часть строк одной таблицы.

SELECT * FROM country Получить все строки.

Таблицы Country.

COUNTRY CURRENCY.

=============== ==========

USA Dollar.

England Pound.

Canada CdnDlr.

Switzerland SFranc.

Japan Yen.

Italy Lira.

France FFranc.

Germany D-Mark.

Australia ADollar.

Hong Kong HKDollar.

Netherlands Guilder.

Belgium BFranc.

Austria Schilling.

Fiji FDollar.

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

Code: SELECT * FROM country. WHERE currency = "Dollar".

Язык SQL (на примере диалекта Informix).

Язык SQL.

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

5.1. Типы данных, доступные в SQL.

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

- какие значения может принимать тот или иной атрибут;

- какие операции будут выполняться с данным атрибутом;

- сколько физического места займет одно значение для атрибута.

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

В варианте SQL, реализованным фирмой Informix, имеются следующие типы данных:

INTEGER и SMALLINT - целое и короткое целое. Для их представления используется, соответственно, 4 и 2 байта.

Следовательно, диапазон допустимых значений для INTEGER будет от -2 147 483 647 до 2 147 483 647, а для SMALLINT - от -32 767 до 32 767. Данный тип используется для представления счетчиков, кодов чего-либо и т.д. К недостаткам данного типа данных следует отнести ограниченный набор значений. Впрочем, это не проблема, если Вы уверены, что для Вашего поля допустимый диапазон значений данного типа подходит.

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

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

Объем памяти (число байтов), выделяемых для хранения значений данного типа зависит от компьютера, но обычно составляет 8 байт для типа FLOAT и 4 байта для SMALLFLOAT. При таком представлении точность типа FLOAT составляет 16 десятичных цифр, а SMALLFLOAT - 8 цифр.

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

DECIMAL(p) - этот тип аналогичен FLOAT, но предназначен для хранения данных с фиксированным числом значащих цифр. Например, если Вы знаете, что некоторое значение всегда измеряется с точностью до пяти знаков, то это как раз тот тип данных, который Вам нужен. Чмсло значащих цифр (параметр 'p') может быть в пределах от 1 до 32. Диапазон допустимых значений для данного типа находится в пределах от 10^-128 до 10^126.

Для представления данных типа DECIMAL(p) используется двоично-десятичное представление. Следовательно, число байтов, необходимое для представления одного значения типа DECIMAL(p) будет равно 1+p/2.

По сравнению с типом FLOAT тип DECIMAL(p) имеет следующие преимущества:

- можно регулировать точность представления;

- размер требуемой памяти зависит от точности;

Но есть у типа DECIMAL(p) и недостатки по сравнению с типом FLOAT:

- операции сортировки и арифметические операции требуют большего, чем для типа FLOAT, времени;

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

DECIMAL (p,n) - этот тип предназначен для хранения данных не только с фиксированным числом значащих цифр, но и с фиксированным числом значащих цифр после запятой. Параметр 'p' задает общее число десятичных цифр в числе, а 'n' - сколько десятичных цифр будет после запятой. Таким образом, данный тип данный позволяет хранить числа, в десятичном представлении которых не более 32 цифр. Размер памяти для хранения одного значения данного типа составляет 1+p/2 байт.

По сравнению с типами INTEGER и FLOAT тип DECIMAL(p,n) имеет те же достоинства и недостатки, что и тип DECIMAL(p).

MONEY (p,n) - этот тип предназначен для хранения денежных величин. Он полностью аналогичен типу DECIMAL(p,n), но отличается от него тем, что в некоторых языках (например, INFORMIX 4GL) существуют специальные способы форматирования для этого типа на основе некоторых внешних по отношению к программе переменных окружения. Это позволяет писать программы, не зависящие от способа написания денжных величин в каждой конкретной стране (например, величина 3000000 будет печататься или как $3,000,000.00 или как 3.000.000,00Рбл).

DATE - этот тип предназначен для хранения дат. По сути, значение этого типа представляет собой число дней, прошедших с 31 декабря 1899 года. Так как это значение может быть отрицательным, то можно хранить и даты до 1899 года. Под значения этого типа выделяется 4 байта, поэтому диапазон допустимых значений очень широк - около 58 000 столетий вперед и назад. Так же как и для типа MONEY, форматирование ввода и вывода для переменных данного типа может быть указано с помощью внешних переменных.

DATETIME - этот тип предназначен для хранения точных моментов времени. Тип DATETIME содержит информацию о годе (YEAR), месяце (MONTH), дне (DAY), часе (HOUR), минуте (MINUTE), секунде (SECOND) и долях секунды (FRACTION). Вы может выбирать нужный диапазон этих значений. Например, если Вам нужен момент времени с точностью до секунды в течении дня, то следует указать тип DATETIME HOUR TO SECOND. Если же Вам нужна информация о событиии с точностью до минуты, но в произвольном году, то требуемый тип должен записываться как DATETIME YEAR TO MINUTE. При указании долей секунды, надо указывать точность представления - от десятых до тысячных. Соответственно, FRACTION(1) указывает время с точностью до десятых, FRACTION(2) - до сотых, а FRACTION(3) - до тысячных.

По сравнению с типом DATE тип DATETIME может хранить данные более точно, однако он требует больше места для хранения и обрабатывается более медленно.

INTERVAL - тип данных для хранения временных интервалов. Значение типа INTERVAL получается, когда, например, из одной даты вычитают другую. Так же как и DATETIME, следует уточнить диапазон возможных значений.

CHAR и CHAR(n) - тип для хранения символьных строк фиксированной длины. Для типа CHAR(n) параметр 'n' задает длину строки. Тип CHAR без параметра является одиночным символом и идентичен типу CHAR(1). Максимальная длина данного типа (значение параметра 'n') равно 32 511. Для хранения данных данного типа всегда отводитя n байт вне зависимости от реальной длины строки.

VARCHAR(m) - короткая (до 255 символов) символьная строка переменной длины. Параметр 'm' задает максимальную длину строки, но не более 255. Для хранения строк переменной длины произвольного размера испльзуеся тип TEXT. При хранении значений типа VARCHAR используется столько байтов, сколько реально занимает строка.

По сравнению с типом CHAR(n), тип VARCHAR имеет то преимущество, что экономится место при хранении строк разной длины. Но такой способ хранения замедляет операции модификации данных.

TEXT - этот тип предназначен для хранения символьных строк произвольной переменной длины. По сравнению с типом VARCHAR тип TEXT имеет повышенные накладные расходы, но не имеет практического ограничения по длине, Например, для сервера Informix DS максимальная длина значения типа TEXT составяет 2 Гигабайта.

BYTE - тип для хранения двоичных объектов произвольного объема. Этот тип данных можно (и нужно) использовать для хранения исполняемых файлов, оцифрованных картинок, звука и т.д. Максимальная длина значения данного типа (для сервера Informix DS ) ограничена 2 Гигабайтами.

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

5.2. SQL-операторы создания схемы базы данных.

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

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

CREATE DATABASE <имя базы>

В качестве имени базы данных Вы можете использовать любое имя, состоящее из латинских букв, цифр и символа подчеркивания. Имя должно начинаться с буквы или символа подчеркивания. Если используемые SQL-сервер и операционная система обеспечивают NLS (National Language Support - поддержка национальных языков)), или SQL-сервер поддерживает GLS (Global Language Support – глобальная поддержка языков), то Вы можете использовать для именования и национальные символы. Кстати, большие и маленькие буквы не различаются. Максимальная длина имени составляет 14 символов. Вы не можете создать на одном SQL-сервере две базы данных с одинаковым именем.

Пример:

CREATE DATABASE my_base.

В SQL существует понятие "текущая база данных". После того, как Вы создали базу данных оператором CREATE DATABASE, она становится текущей. Все указываемые таблицы, все индексы берутся из текущей базы данных. В каждый момент времени для каждой задачи существует единственная текущая база данных (или таковой не существует вовсе). Это не означает, что Вы не можете обратиться к таблице из другой базы данных, просто при обращении к такой таблице надо кроме имени таблицы, еще указывать и имя базы данны, а если база данных расположена на другом сервере, то и имя сервера базы данных.

Сразу опишем и обратный оператор - оператор удаления базы данных.

DROP DATABASE <имя базы>

Пример:

DROP DATABASE my_base.

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

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

DATABASE <имя базы>

Пример:

DATABASE my_base.

Закрытие текущей базы данных производится оператором.

CLOSE DATABASE.

Итак, предположим, что база данных создана. Для того, чтобы создавать таблицы используется оператор CREATE TABLE. Его синтаксис.

CREATE TABLE <имя таблицы> ( <имя колонки> <тип колонки> [ NOT NULL], <имя колонки> <тип колонки> [ NOT NULL] [, ...] )

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

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

CREATE TABLE companies ( company_id SERIAL, name CHAR(40) NOT NULL, address CHAR(60) )

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

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

CREATE TABLE items ( item_id SERIAL, company INTEGER NOT NULL, name CHAR(40) NOT NULL, price MONEY(20,2) )

Таблицы 'companies' и 'items' связаны. Логическая связь обеспечивается полем 'company' в таблице 'items' и полем 'company_id' в таблице 'companies'. Поле 'company' данной таблицы содержит идентификатор поставщика. То есть если мы хотим найти поставщика некоторого товара, то надо из этой таблицы для нужной записи выбрать значение поля 'company', а затем, просмотрев таблицу 'companies' найти запись, поле 'company_id' равно найденному значению.

Оператор удаления таблицы очень похож на оператор удаления базы данных:

DROP TABLE <имя таблицы>

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

Добавление новых полей в твблицу производится следующим образом:

ALTER TABLE <имя таблицы> ADD ( <имя колонки> <тип колонки> [ NOT NULL] [, ...] )

Например, если для поставщика товаров (таблица 'companies') надо добавить и контактный телефон, то следует выполнить следующий оператор:

ALTER TABLE companies ADD (phone CHAR(35)).

Для удаления ненужных полей надо выполнить другой вариант оператора ALTER TABLE:

ALTER TABLE <имя таблицы> DROP ( <имя колонки> [, ...] ).

Существует вариант этого оператора и для модификации поля:

ALTER TABLE <имя таблицы> MODIFY ( <имя колонки> <тип колонки> [ NOT NULL] [, ...] )

При изменении типа поля производится автоматическая преобразование значений к новому типу. В частности, если тип меняется с целого на символьное, то число 2385 будет преобразовано в строку '2385'.

5.3. Основные SQL-операторы для доступа и модификации данных.

Итак, структура базы данных создана. Надо как-то начинать работать с базой данных - заносить новые данные, извлекать существующие и т.д. Существует четыре основных оператора манипулирования данными - SELECT, INSERT, UPDATE и DELETE. Примеры, которые быдут сопровождать рассказ об этих операторах будут основываться на предположении, что в нашей текущей базе данных есть таблицы companies и items (см. параграф 5). В таблице companies хранится информация о производителях товаров, а в таблице items - о самих товарах.

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

Оператор INSERT вставляет в таблицу новую запись:

INSERT INTO <имя таблицы>(<поле1>, <поле2>, ...) VALUES (<значение1>, <значние2>, ...).

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

Полю типа SERIAL, если его нет в списке или его значением указано 0, присваивается новое уникальное значение. Если для поля типа SERIAL указано отличное от нуля значение, то СУБД использует указанное значение.

Например, последовательность операторов.

INSERT INTO companies (name) VALUES ("АО Рога и Копыта").

INSERT INTO companies (name, address) VALUES ("ТОО Добро пожаловать", "Энск, 5-е авеню").

INSERT INTO companies (company_id, name) VALUES (157, "АОЗТ Сделай Сам").

Наполнит таблицу companies следующим содержанием.

------------------T----------------------T-----------------¬ ¦ company_id ¦ name ¦ address ¦ +-----------------+----------------------+-----------------+ ¦ 1 ¦ АО Рога и Копыта ¦ NULL ¦ ¦ 2 ¦ ТОО Добро пожаловать ¦ Энск, 5-е авеню ¦ ¦ 157 ¦ АОЗТ Сделай Сам ¦ NULL ¦ L-----------------+----------------------+-----------------+

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

USER - имя пользователя, который выполняет этот SQL-оператор;

TODAY - дату выполнения этого оператора;

CURRENT - момент времени, когда выполняется этот оператор.

Например, если некоторая таблица под названием 'protocol' содержит описание некоторых действий и, в частности, поля when и who, указывающие когда и кто выполнил это действие, занесение новой записи в эту таблицу будет выглядеть так:

INSERT INTO protocol (who, when, ...) VALUES (USER, CURRENT YEAR TO MINUTE, ...).

Для модификации записей, которые уже есть в таблице, используется оператор UPDATE:

UPDATE <имя таблицы> SET <имя поля>=<значение> [,....] [WHERE <условие>].

Или.

UPDATE <имя таблицы> SET (<имя поля1>, <имя поля2>, ...) = (<значение1>, <значение2>, ...) [WHERE <условие>].

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

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

В качестве условия могут использоваться логические выражения над константами и полями. В логических выражениях допускается испльзовать операции сравнения >, <, >=, <=, =, <>, !=. Для проверки поля на значение NULL используются логические операции IS NULL или IS NOT NULL. Отдельные логические операции могут быть соединены связками AND, OR, NOT и сгруппированы с помощью скобок. Примеры правильных условий:

Name IS NULL.

Price > 200 OR name = "кеды".

(name IS NULL AND address IS NULL) OR (name = "АО Рога и Копыта").

Использование в SQL логических связок и операций сравнения аналогично логическим выражениям в обычных языках программирования. Представляет интерес использование в операциях сравнения и в логических связках значения NULL (неопределено). Если NULL появляется в операциях сравнения (<, >, <= и т.д.), то результатом этой операции тоже будет NULL. Если применить к NULL операцию отрицания (NOT), то снова получим NULL. Логическое умножение (AND) значений NULL и "ложь" дает "ложь", а NULL и "истина" - NULL. Логическое сложение (OR) значений NULL и "ложь" дает в результате NULL, а NULL и "истина" - "истину".

Например, если на момент вставки записи с информацией о фирме "АО Рога и Копыта" мы не знали ее адреса, то записать ее адрес после можно оператором:

UPDATE companies SET address = "Одесса, п/я 13" WHERE name = "АО Рога и Копыта".

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

UPDATE items SET price = 1000 WHERE price < 1000.

Теперь, немного забегая вперед (мы еще не рассматривали оператор SELECT), напишем оператор UPDATE, который увеличивает в два раза цену на все товары, поставляемые фирмой "АОЗТ Сделай Сам":

UPDATE items SET price = price*2 WHERE company = (SELECT company_id FROM companies WHERE name = "АОЗТ Сделай Сам").

Это пример двойного запроса, то есть запроса в запросе. Вначале ищется идентификатор фирмы по ее имени (оператор SELECT), а затем обновляется поле 'price' для всех товаров, поставляемых данной фирмой.

Для того, что бы удалить ненужные записи в таблице, существует оператор DELETE:

DELETE FROM <имя таблицы> [WHERE <условие>].

Использование ключевого слово WHERE, задающего условие на записи, подлежащие удалению, аналогично его использованию в операторе UPDATE. Точно так же, если условие не задано, то удалены будут все записи из таблицы.

Предположим, фирма "АОЗТ Сделай Сам" разорилась, больше не поставляет нам ни одного товара, и мы хотим удалить ее из списка поставщиков. Это может быть сделано оператором:

DELETE FROM companies WHERE name = "АОЗТ Сделай Сам".

Теперь рассмотрим оператор выборки SELECT. На его долю приходится, наверное, более 2/3 всех SQL-операторов используемых в программах. Оператор SELECT выбирает из одной или нескольких таблиц множество значений, которое и является результатом его работы. К сложным, многотабличным вариантам этого оператора мы вернемся позже.

Синтаксис оператора SELECT (сильно упрощенный вариант):

SELECT <имя поля> [,...] FROM <имя таблицы> [WHERE <условие>].

В операторе SELECT указываются нужные Вам поля, имя таблицы (FROM), из которой производится выборка, и условие (WHERE), которому должны удовлетворять отобранные значения. Оператор SELECT просматривает все записи в таблице и отбирает те, которые удовлетворяют условию. Из отобранных записей берутся только те поля, которые указаны. Таким образом, результатом работы оператора SELECT будет набор значений, фактически таблица, содержащая часть полей и часть записей от исходной. В предельных случаях это может быть пустое множество (ни одна запись не удовлетворила условию) или одно единственное значение, если выбиралось одно поле и только одна запись удовлетворила условию.

Примеры:

SELECT company_id, name, address FROM companies.

- результатом этого запроса будет вся таблица 'companies'.

SELECT company_id FROM companies WHERE name = "АО Рога и Копыта".

- этот запрос возвращает одно единственное значение (1), а именно уникальный идентификатор фирмы "АО Рога и Копыта".

SELECT name FROM companies.

- возвращает имена всех фирм-поставщиков, имеющихся в нашей базе данных и занесенных в таблицу 'companies'.

SELECT name, price FROM items WHERE company = (SELECT company_id FROM companies WHERE name = "АО Рога и Копыта").

- возвращает все названия товаров и их цены, поставляемые фирмой "АО Рога и Копыта".

SELECT name FROM companies WHERE address IS NULL.

- возвращает названия тех фирм, у которых неизвестен адрес.

5.4. Управление транзакциями.

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

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

· BEGIN WORK - начать транзакцию;

· COMMIT WORK - успешно завершить транзакцию;

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

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

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

Операторы управления транзакциями выполняет программа-клиент. Если она обнаруживает какую-то ошибку, то она может выполнить откат транзакции. В самом SQL нет управляющих структур (циклов, условных операторов, операторов перехода), поэтому приведем примеры на языке Informix 4GL, который содержит SQL как подмножество:

IF error { проверка какого-то события } THEN ROLLBACK WORK { откат транзакции в случае ошибки } ELSE COMMIT WORK { успешное завершене транзакции } END IF.

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

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

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

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

CREATE DATABASE <имя базы> WITH LOG.

- создание базы данных с транзакциями, и.

CREATE DATABASE <имя базы> WITH LOG MODE ANSI.

- создание базы данных с транзакциями в режиме ANSI.

Если база данных была создана с параметром WITH LOG, то сервер начинает для данной базы данных отслеживать транзакции. Выполнение оператора COMMIT WORK, говорит серверу о начале транзакции, которая закончится по оператору COMMIT WORK или откатится по оператору ROLLBACK WORK в состояние на момент выполнения BEGIN WORK.

BEGIN WORK; { Явно задаем начало транзакции } DELETE .......; { некоторые изменения } INSERT .......; { данных } COMMIT WORK; { Оператор успешного завершения транзакции }.

Если база данных была создана в режиме ANSI, то есть в операторе CREATE DATABASE было указано WITH LOG MODE ANSI, то оператор BEGIN WORK не нужен. Транзакция открывается автоматически сразу после удачного или неудачного завершения предыдущей. Открытие базы данных автоматически открывает транзакцию.

{ транзакция для ANSI-базы данных } COMMIT WORK; { завершение предыдущей транзакции } { Здесь автоматически начинается следующая транзакция} UPDATE .......; { некоторые изменения } INSERT .......; { данных } COMMIT WORK; { успешное программное завершение транзакции } { Здесь автоматически начинается следующая транзакция}.

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

5.5. Продвинутые варианты оператора поиска.

5.5.1. Поиск по нескольким таблицам.

Оператор SELECT может осуществлять поиск сразу по нескольким таблицам. В этом случае после слова FROM в операторе SELECT надо указать таблицы,по которым производится поиск. Если в нескольких полях имеются одноименные поля (например, поле name присутсвует и в таблице companies, и в таблице items), то для устранения неясностей надо перед именем поля указать имя таблицы и символ точка.

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

SELECT name, address, lname, fname FROM companies, persons WHERE company_id = company.

В данном примере не возникает коллизий и запрос будет правильно отработан. Но если мы захотим выдать список товаров и названий фирм, их производящих, то, так как поле name присутствует и в таблице items, и в таблице companies, нам потребуется для поля name указывать таблицу:

SELECT items.name, companies.name FROM persons, companies WHERE company = company_id.

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

Стоит обратить внимание, что при выборке из двух таблиц мы получаем все возможные комбинации значений, при этом из всех таблиц выбираются только те записи, которые удовлетворяют заданному условию. Например, в приведенном выше примере на получение информации о фирмах и людях, в них работающих, мы получим список только тех компаний, для которых в таблице persons есть хотя бы один человек. А если мы хотим в этом запросе получить информацию и о фирмах, для которых мы не знаем ни одного сотрудника? Для этого в разделе FROM оператора SELECT перед таблицей persons надо поставить слово OUTER:

SELECT name, address, lname, fname FROM companies, OUTER persons WHERE company_id = company.

Тогда такой оператор будет работать следующим образом. Он последовательно будет перебирать все записи из таблицы companies. Для каждой записи из companies будет просмотрена таблица persons. Как только будет найдена запись из persons, удосвлетворяющая условию WHERE, в результат добавится новый ряд, сформированный из полей name и address записи из companies и полей lname и fname записи из persons. Если же в persons не будет найдено ни одной записи, то при простом операторе SELECT информация о текущей записи из companies в результат не попадет, а в случае SELECT с OUTER - попадет, а поля lname и fname получат значение NULL:

Таблица companies: -------------T----------------------T------------------¬ ¦ company_id ¦ name ¦ address ¦ +------------+----------------------+------------------+ ¦ 101 ¦ АО Рога и Копыта ¦ Одесса, п/я 13 ¦ ¦ 105 ¦ ТОО Добро пожаловать ¦ Энск, 5-е авеню ¦ ¦ 107 ¦ АОЗТ Сделай сам ¦ Городская свалка ¦ L------------+----------------------+-------------------

Таблица persons: ----------T----------T---------¬ ¦ company ¦ lname ¦ fname ¦ +---------+----------+---------+ ¦ 101 ¦ Антонов ¦ Сергей ¦ ¦ 105 ¦ Шапокляк ¦ Алексей ¦ ¦ 102 ¦ Антонов ¦ Антон ¦ ¦ 101 ¦ Бендер ¦ Остап ¦ L---------+----------+----------

Результат простого оператора SELECT.

SELECT name, address, lname, fname FROM companies, persons WHERE company_id = company.

-----------------------T-----------------T----------T---------¬ ¦ name ¦ address ¦ lname ¦ fname ¦ +----------------------+-----------------+----------+---------+ ¦ АО Рога и Копыта ¦ Одесса, п/я 13 ¦ Антонов ¦ Сергей ¦ ¦ АО Рога и Копыта ¦ Одесса, п/я 13 ¦ Бендер ¦ Остап ¦ ¦ ТОО Добро пожаловать ¦ Энск, 5-е авеню ¦ Шапокляк ¦ Алексей ¦ L----------------------+-----------------+----------+----------

Результат оператора SELECT с указателем OUTER.

SELECT name, address, lname, fname FROM companies, OUTER persons WHERE company_id = company.

-----------------------T-----------------T----------T---------¬ ¦ name ¦ address ¦ lname ¦ fname ¦ +----------------------+-----------------+----------+---------+ ¦ АО Рога и Копыта ¦ Одесса, п/я 13 ¦ Антонов ¦ Сергей ¦ ¦ АО Рога и Копыта ¦ Одесса, п/я 13 ¦ Бендер ¦ Остап ¦ ¦ ТОО Добро пожаловать ¦ Энск, 5-е авеню ¦ Шапокляк ¦ Алексей ¦ ¦ АОЗТ Сделай сам ¦ Городская свалка¦ NULL ¦ NULL ¦ L----------------------+-----------------+----------+----------

Стоит или не стоит использовать OUTER - зависит от того, что Вы хотите получить в результате оператора SELECT. Относительно приведенного Выше примера, то если бы нас интересовали именно люди, то следовало бы выбрать оператор SELECT в первом варианте, без OUTER. Если же нам было интересно получить информацию о фирмах, а заодно и узнать кто там работает, то следует выбрать второй вариант - c OUTER.

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

5.5.2. Устранение повторения данных в операторе SELECT.

Отношение или таблица- это множество. Следовательно, в них могут содержаться повторяющиеся элементы (одинаковые записи). И если в реальных таблицах это практически никогда не встречается (ведь надо же как-то различать описания разных сущностей!), то в отношении, которое является результатом работы оператора SELECT такие повторения могут возникать достаточно часто. Если в формируемой с помощью оператора SELECT отношении Вам надо избавиться от повторений, то перед списком полей следует поставить ключевое слово DISTINCT или UNIQUE (это синонимы). В этом случае, если в выборке, удовлетворяющей условию WHERE, имеется несколько записей с одинаковыми значениями, то оператор SELECT исключит повторения. Например, если Вам требуется распечатать только номенклатуру поставляемых товаров, без учета того, что один и тот же вид продукта может пставляться разными поставщиками, Вам следует выполнить запрос:

SELECT UNIQUE name FROM items.

Если в запросе выбирается два или более поля, то две записи считаются равными, если равны все их составляющие поля.

5.5.3. Вычисления внутри оператора SELECT.

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

Выражения над полями.

Оператор SELECT может производить сразу вычисления. Над отдельными полями можно производить символьные иарифметические операции, а также функции. В вражениях можно использовать как значения полей, так и константы.

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

SELECT lname[4,9] FROM companies.

"Рога и Ко" " Добро по" "Т Сделай ".

SELECT lname || " " || fname FROM persons.

"Антонов Сергей" "Шапокляк Алексей" "Антонов Антон" "Бендер Остап".

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

SELECT lname, fname FROM persons.

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

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

К арифметическим операциям относятся операции сложения ('+'), вычитания ('-'), умножения ('*') и деления ('/'). Пример:

SELECT price*1.2 FROM items.

SELECT tax*quantity/1.2 FROM orders.

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

Функция определения длины: LENGTH(<имя поля>) - вычисляет длину строки, которая LENGTH(<текстовая строка>) содержится в указанном поле записи или указанной текстовой констант;

Временные функции: DATE (<выражение не типа DATE>) - преобразует выражение типа CHAR, INTEGER или DАТЕТIМЕв значение типа DATE; DAY(<выражение типа DATE или DATETIME>) - по заданному в качестве аргумента значению вычисляет номер дня в месяце; MDY(<месяц>, <день>, <год>) - по заданным трем целым значением, определяющим номер месяца, дня, года строится значение типа DATE; MONTH (<выражение типа DATE или DATETIME>) - по заданному в качестве аргумента значению вычисляет номер месяца в годе; WEEKDAY (<выражение типа DATE или DATETIME>) - по заданному в качестве аргумента значению вычисляет номер дня недели, причем восвкресенью соответсвует значение 0, понедельнику - 1 и т.д.; YEAR (<<выражение типа DATE или DATETIME>) - по заданному в качестве аргумента значению вычисляет номер года, состоящий из 4-х цифр;

Функции преобразования HEX (<целое выражение>) - преобразует целое, заданное в качестве аргумента, в строку, представляющую шестнадцатеричную запись данного целого; ROUND (<числовое выражение, точность>) - округляет с указанной точностью числовое выражение, заданное в качестве аргумента; точность определяет степень одной десятой, до которой надо округлять. TRUNC (<числовое выражение, точность>) - обрезает незначащие цифры у заданного в качестве аргумента выражения, причем точность определяет смещение влево от запятой последней значащей цифры;

Математические функции: ACOS(<числовое выражение>) - арккосинус от заданного значения; ASIN(<числовое выражение>) - арксинус от заданного значения; ATAN (<числовое выражение>) - арктангенс от заданного значения; COS(<числовое выражение>) - косинус от заданного числа радиан; SIN(<числовое выражение>) - синус от заданного числа радиан; TAN (<числовое выражение>) - тангенс от заданного числа радиан; ABS (<числовое выражение>) - абсолютное значение; EXP (<степень>) - вычисление заданной экспоненты; LOGN (<выражение>) - вычисление натурального логарифма; LOG10 (<выражение>) - вычисление десятичного логарифма; MOD (<делимое>, <делитель>) - остаток от деления; POW (<значение>, <степень>) - возведение в степень; ROOT (<значение>, <степень>) - вычисление корня заданной степени; SQRT (<числовое выражение>) - квадратный корень;

Функции – псевдополя CURRENT <диапазон> - возвращает точный момент времени (тип DATETIME), когда происходит обработка данного запроса; параметр <диапазон> задает (как и при описании типа DATETIME) требуемое точность - от года до тысячных секунды (например, CURRENT DAY TO SECOND); TODAY - возвращает дату (тип DATE) выполнения даного запроса; USER - возвращает имя пользователя (как он зарегестрировался в операционной системе), который выполняет данный запрос.

Следует напомнить про специальное значение NULL - "не определено". Если это значение встретится в выражении, то и все выражение будет иметь значение NULL. Даже умножив нуль на NULL, Вы все равно получите NULL. Конкатенация любой строки с неопределенной строкой (то есть строкой, имеющей значение NULL) тоже в результате даст NULL.

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

Агрегатные функции.

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

SELECT MAX(price) FROM items.

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

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

SELECT COUNT(*) FROM items WHERE name="джинсы".

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

SELECT MIN(price), MAX(price) FROM items WHERE name="кеды".

Некоторые агрегатные функции перечислены в таблице:

AVG(<имя поля>) - среднее по всем значениям данного поля; COUNT(*) - количество записей; MAX(<имя поля>) - максимум из всех значений данного поля; MIN(<имя поля>) - минимум по всем значениям данного поля; SUM(<имя поля>) - сумма всех значений данного поля.

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

SELECT name, COUNT(*), MAX(price) FROM items GROUP BY name.

Полученные результаты могли бы быть, например, такими:

Кеды 2 3000.00 джинсы 4 46000.00 рога 1 999999.85.

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

Можно наложить дополнительное условие на группирование данных с помощью ключевого слова HAVING, указываемого после раздела GROUP BY. В разделе HAVING указываются условие на группу, то есть группы, не удовлетворяющие условию, будут отсутствовать в результирующей выборке. Например, мы хотим выполнить предыдущий запрос, но нам не нужна информация о товарах, поставляемых только одним поставщиком. Для этого построим следующий запрос:

SELECT name, COUNT(*), MAX(price) FROM items GROUP BY name HAVING COUNT(*) > 1.

И получим следующие результаты:

Кеды 2 3000.00 джинсы 4 46000.00.

5.5.4. Логические выражения в условии SQL-операторов.

Когда выше обсуждались SQL-операторы и, в частности, раздел WHERE (условие), то были перечислены лишь некоторые возможные способы задания условия на выбираемые записи. В частности, были упомянуты операции сравнения (больше, меньше и т.д.) и логические связки (и, или, не). В условии поиска (в разделе WHERE) операторов SELECT, UPDATE и DELETE можно использовать и более интересные логические выражения.

Сопоставление текстовых полей с образцом.

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

<имя поля> MATCHES <образец>

Образец для оператора MATCHES является текстовой строкой и строится по следующим правилам:

· специальный символ '*' соответсвует произвольной последовательности из 0 или более символов;

· специальный символ '?' соответсвует одному произвольному символу;

· символы внутри квадратных скобок ([...]) позволяют задавать удовлетворяющие образцу символы (например, [абв] или [аеиуюыя]) диапазон символов через дефис (например, [А-Я] или [0-9]), или с помощью символа '^' указывать те символы, которые не удовлетворяют образцу (например, [^абв]);

· специальный символ '\' отменяет значение специального символа, указанного за '\', например '\*' означает именно символ '*', а не произвольную последовательность символов;

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

Например, по следующему запросу.

SELECT person_id FROM persons WHERE lname MATCHES "[Бб]ендер".

Будут выбраны номера записей (значения поля person_id) для лиц с фамилиями "Бендер" и "бендер".

Если нам требуется отобрать все записи о товарах из таблицы items, в названии которых присутствует слово "грибы" (например, "Соленые грибы", "Грибы по-французски", "Грибы-мухоморы маринованные"), то такую задачу решает следующий запрос:

SELECT item_id FROM items WHERE name MATCHES "*[Гг]рибы*".

Операцию MATCHES, как и любую другую, можно использовать вместе с другими логическими операциями путем использования логических связок OR/NOT/AND и скобок:

SELECT item_id FROM items WHERE (name MATCHES "теннис") AND price > 20.00.

Проверка на вхождение в множество.

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

<выражение> IN (<значение 1>, <значение 2>, ....).

<выражение> IN (<оператор SELECT>).

Например, если мы хотим получить адреса фирм "АО Рога и Копыта" и "ТОО Добро пожаловать", то должны выполнить следующий запрос.

SELECT name, address FROM companies WHERE name IN ("АО Рога и Копыта", "ТОО Добро пожаловать").

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

Если же множество значений формируется динамически, в процессе выполнения запроса, то использование операции IN становится единственно возможным способом. Например, нам надо выполнить запрос "найти названия и адреса всех фирм, поставляющих джинсы". Этот запрос выполняется одним SQL-оператором:

SELECT name, address FROM companies WHERE company_id IN (SELECT company FROM items WHERE name = "джинсы").

В запросах подобного рода во внутренний оператор SELECT можно добавить слово UNIQUE - это позволит повысить скорость обработки запроса:

SELECT name, address FROM companies WHERE company_id IN (SELECT UNIQUE company FROM items WHERE name = "джинсы").

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

SELECT name, address FROM companies WHERE company_id NOT IN (SELECT company FROM items WHERE name = "кеды").

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

DELETE FROM companies WHERE company_id NOT IN (SELECT company FROM items).

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

BEGIN WORK DELETE FROM companies WHERE company_id NOT IN (SELECT company FROM items) DELETE FROM persons WHERE company NOT IN (SELECT company_id FROM companies) COMMIT WORK.

Если известно, что оператор SELECT возвращает одну запись, то можно вместо слова IN использовать проверку на равенство. Например, если мы хотим получить список самых дорогих товаров, а именно их названия и цену (цена будет для всех одна - максимальная), то надо выплнить запрос:

SELECT name, price FROM items WHERE price = (SELECT MAX(price) FROM items).

Проверка на существование выборки.

С помощью логической операции EXISTS можно проверить, возвращает ли тот или иной SELECT-оператор какие-то значения. Соответственно, можно в условии определять только те записи, для которых существует (или не существует) какая-то информация. Формат логической операции EXISTS:

EXISTS (<оператор SELECT>).

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

SELECT name, address FROM companies WHERE NOT EXISTS (SELECT company FROM items WHERE items.company=companies.company_id).

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

Сравнивая операцию EXISTS с операцией IN, можно заметить. что одни и те же запросы можно выразить с помощью разных средств (а именно, EXISTS или IN). Какое из средств выбрать, должно определяться логикой задачи и эффективностью исполнения. Последнее, в свою очередь, зависит от реализации и может принципиально различаться для SQL-серверов разных фирм.

Условия "Существует" и "Для всех".

Всем, кто когда-то более или менее серьезно, занимался математикой, известны кванторы "Существует" и "Для всех". Аналогичные операции введены и в SQL. Эти операции должны использоваться после операции сравнения (больше, меньше, равно и т.д.), а в качестве правого операнда должен задаваться оператор SELECT:

<выражение> <операция сравнения> ALL (<оператор SELECT>) <выражение> <операция сравнения> ANY (<оператор SELECT>).

Соответсвенно, операция ALL возвращает значение "истина", если операция сравнения истинна для каждого значения, возвращаемого оператором SELECT, а операция ANY - хотя бы для одного. Если оператор SELECT не вернул ни одного знчения, то операция ALL возвращает истину, а ANY - ложь. Вместо ключевого слова ANY можно использовать слоово SOME.

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

SELECT company_id, name FROM companies WHERE EXISTS (SELECT company FROM items WHERE companies.company_id = items.company AND items.name = "кеды" AND items.price <= ALL (SELECT price FROM items WHERE name = "кеды") )

Тот же самый запрос мог быть сформулирован и с помощью агрегатной функции MIN:

SELECT company_id, name FROM companies WHERE EXISTS (SELECT company FROM items WHERE companies.company_id = items.company AND items.name = "кеды" AND items.price = (SELECT MIN(price) FROM items WHERE name = "кеды") )

5.5.5. Слияние двух выборок.

Результаты работы двух или более операторов SELECT могут быть объединены в одну выборку с помощью операторов UNION или UNION ALL. Оператор UNION, помещенный между двумя операторами SELECT делает из двух выборок одну, причем повторяющиеся записи отсутствуют в результирующей выборке. Оператор UNION ALL не убирает повторяющиеся записи. Синтаксис:

<оператор SELECT> UNION [ALL] <оператор SELECT> UNION [ALL] <оператор SELECT> ................

Например, если бы мы имели вместо одной таблицы companies две фирмы-поставщики (suppliers) и фирмы-производители (manufacters), и хотели бы получить выборку с названиями всех фирм, с которыми мы работаем, то требуемый запрос формулируется так:

SELECT name FROM suppliers UNION SELECT name FROM manufactures.

С помощью операторов UNION и UNION ALL вы можете объединять выборки, возвращающие самые разные поля из разных таблиц. Но при этом все операторы SELECT должны возвращать записи с одинаковым количеством полей и соответсвующие поля во всех операторах SELECT должны иметь приводимые типы данных.

5.5.6. Сортировка выборки.

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

Для упорядочивания выборки в оператор SELECT добавляется раздел ORDER BY. Этот раздел указывается псле условия (раздела WHERE). После слов ORDER BY перечисляются имена полей, по которым надо производить сортировку. Поля, по которым надо сортировать, обязательно должны быть в списке выбираемых полей (присутствовать в разделе SELECT).

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

SELECT name FROM companies ORDER BY name.

Для упорядочивания в обратном порядке, например, если мы хотим получить список названий и цен на товары в порядке уменьшения цен, то после имени поля в разделе GROUP BY надо поставить ключевое слово DESC:

SELECT name, price FROM items ORDER BY price DESC.

Если в разделе ORDER BY указано несколько полей, то вначале производится сортировка по первому полю, затем записи, у которых первые поля совпадают, сортируются по второму полю и т.д.

Если мы желаем отсортировать по некоторому значению, которое не является полем, а, например, вычисляется по значению поля, то для этого в разделе ORDER BY надо указывать не имена полей и не выражения, а номер выражения (начиная с 1) в разделе SELECT. Например, у нас есть таблица result с результатами некоторого физического эксперимента. Пусть в этой таблице есть поле angle со значением некоторого угла, и height - высота чего-то там для заданного угла. Если мы хотим получить выборку, содержащую значения полей angle, height и sin(angle), при этом отсортировать эту выборку в соответствии с синусом угла, то надо выполнить запрос.

SELECT angle, height, SIN(angle) FROM results ORDER BY 3.

Номер выражения в ORDER BY ничем принципиально не отличается от имени поля. Точно так же можно упорядочивать в порядке убывания с помощью слова DESC и можно перечислять несколько номеров выражений. Кстати, номер выражения можно использовать и для группирования по нему (см. пункт Агрегатные функции.).

5.5.7. Вставка в таблицу нескольких строк одновременно.

В случае, когда надо добавить в какую-то таблицу сразу несколько записей, то существует вариант оператора INSERT, который добавляет в таблицу сразу целую выборку. Эта выборка строится оператором SELECT, который вложен в оператор INSERT. Синтаксис такого оператора INSERT выглядит так:

INSERT INTO <имя таблицы> (имя поля1, имя поля2, ...) <оператор SELECT>

Например, мы хотим построить таблицы, в которой перечисленв все фирмы, ничего не поставляющие. Пусть такая таблица называется strange_companies и имеет структуру, идентичную таблице companies. Тогда соответствующий оператор INSERT будет выглядеть так:

INSERT INTO strange_companies(name, address) SELECT name, address FROM companies WHERE company_id NOT IN (SELECT UNIQUE company FROM items).

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

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

SELECT name, address FROM companies WHERE company_id NOT IN (SELECT UNIQUE company FROM items) INTO TEMP strange_companies.

Оператор SELECT ... INTO TEMP автоматически создает таблицу, причем эта таблица имеет столько полей, сколько выражений указано в разделе SELECT. Если в разделе SELECT выражение есть просто значение поля (указно имя поля), то формируемая временная таблица будет иметь поле такого же типа с таким же именем. Если в разделе SELECT стоит составное выражение, то имя поля формируется автоматически по некоторым правилам (здесь они не рассматриваются). В нашем примере, временная таблица strange_companies будет иметь два поля - name и address. Типы этих полей будут идентичны типам полей name и address таблицы companies, то есть CHAR(40) и CHAR(60) соответственно.

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

Кроме оператора SELECT ... INTO TEMP временные таблицы могут быть созданы с помощью оператора создания таблицы - в этом случае он записывается как CREATE TEMP TABLE. Например:

CREATE TEMP TABLE strange_companies ( name CHAR(40), address CHAR(60) )

5.6. Использование SQL в языках программирования.

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

SQL обычно встраивается в другие языки. Например, существуют продукты Informix ESQL/C, /COBOL, /Ada, /FORTRAN, которые представляют собой препроцессор и библиотеки соответственно для С/С++, COBOL, Ada и FORTRAN. На ESQL/C, например, SQL-оператор, встраиваемый в программу, должен начинаться с символа '$' или со слов 'exec sql’. Пример фрагмента программы на ESQL/C:

$database test; for (i=0; i++; i<10) { $insert into my_table values ($i); $select name into $buf from my_2nd_table where key = i; printf ("key = %d, name = %s\n", i, buf); }

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

Другой вариант построения программы, работающий с SQL-сервером - это непосредственное встраивание SQL в язык программирования. Именно по такой схеме построены Informix 4GL и NewEra SQL-операторы являются одними из возможных операторов этого языка. Если приведенную выше программу переписать на Informix-4GL, то она будет выглядеть так:

DATABASE test FOR I=0 TO 9 INSERT INTO my_table VALUES (i) SELECT name INTO buf FROM my_2nd_table WHERE key = i DISPLAY "KEY = ", i, " NAME = ", buf END IF.

Когда конечный пользователь работает с какой-то конкретной прикладной программой, он, безусловно, может и не знать ничего про SQL. Но подобные средства со "скрытым" SQL существуют и для разработчиков, а не только для конечных пользователей. Например, построитель форм и отчетов Informix ViewPoint предоставляет чисто визуальные средства разработки, когда.

Программист (или конечный пользователь) "рисует" форму или отчет. О связи с SQL-сервером позаботится оболочка, которая будет заполнять форму или отчет данными, автоматически посылая SQL-запросы на сервер.

Курсоры.

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

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

Всегда можно сказать, какой номер от начала выборки какая запись имеет. Например, нам надо выдать на экран имена и фамилии из таблицы persons в алфавитном порядке. Воспользуемся для этого курсором, а уж потом дадим точный синтаксис описания курсора и правила работы с ним (используем Informix 4GL для описания перемнных и оператора вывода):

{ определяем переменные для считывания данных из курсора } DEFINE ln LIKE persons.lname DEFINE fn LIKE persons.fname { определяем курсор } DECLARE my_cursor CURSOR FOR SELECT lname, fname FROM persons ORDER BY lname, fname {последовательно перебираем все значения из курсора и печатаем их} FOREACH my_cursor INTO ln, fn DISPLAY ln, fn END FOREACH.

Результат работы данного программного фрагмента мог бы быть примерно следующим:

Антонов Антон Антонов Сергей Бендер Остап Шапокляк Алексей.

В приведенном простом примере три оператора работают с курсором - DECLARE, FOREACH и END FOREACH. С помощью оператора DECLARE мы объявили курсор, то есть связали его с некоторой выборкой из базы. Затем, с помощью цикла FOREACH ... END FOREACH ) мы перебрали все записи из выборки, соответсвующей курсору и сделали с ними то, что хотели - вывели на экран. С таким же успехом можно было бы вывести эту информацию в отчет или провести статистическую обработку. Причем, в данной выборке мы уже имеем упорядоченность - вначале по фамилии, а для одинаковых фамилий - по имени. Упорядоченность была указана в SELECT-запросе, связанном с данным курсором (раздел ORDER BY).

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

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

DECLARE <имя курсора> CURSOR FOR <SELECT-оператор>

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

Например:

{курсор для перебора названий и адресов фирм} DECLARE cursor1 CURSOR FOR SELECT name, address FROM companies ORDER BY name.

{курсор для перебора названий товаров и фирм, их производящих} DECLARE dialog_c CURSOR FOR SELECT items.name, company.name FROM companies,items WHERE companies.company_id = items.company ORDER BY items.name.

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

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

DECLARE <имя курсора> SCROLL CURSOR FOR <SELECT-оператор>

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

Если курсор является скроллируемым, то к нему, как и к последовательному, можно применять цикл FOREACH ... END FOREACH. Но для того, чтобы организовать произвольный доступ к записям из выборки, связанной со скроллируемым курсором, служат другие операторы.

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

OPEN <имя курсора>

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

FETCH NEXT <имя курсора> FETCH PREVIOUS <имя курсора> FETCH FIRST <имя курсора> FETCH LAST <имя курсора> FETCH CURRENT <имя курсора> FETCH RELATIVE <смещение> <имя курсора> FETCH ABSOLUTE <номер записи> <имя курсора>

Смысл ключевых слов NEXT, PREVIOUS и т.д. и, соответственно, выполняемых ими действий, понятен из их перевода с английского:

· NEXT - перейти на следующую запись в выборке;

· PREVIOUS - перейти на предыдущую запись в выборке;

· FIRST - перейти на первую запись выборки;

· LAST - перейти на последнюю запись выборки;

· CURRENT - никуда не перемещаясь, перечитать текущую запись;

· RELATIVE <смещение> - сместиться от текущей записи на <смещение> записей, причем если смещение больше нуля, то сместиться "вниз" - к последней записи, а если меньше - то вверх, к первой записи;

· ABSOLUTE <номер записи> - перейти на запись, имеющую в данной выборке указанный порядковый номер, причем записи нумеруются с единицы.

После оператора OPEN, кстати, текущей записи нет (текущей записью является несуществующая запись с номером ноль). То есть, сразу после открытия курсора оператор FETCH CURRENT выполнять нельзя.

Слово NEXT в операторе FETCH можно опускать - оно принимается по умолчанию. Вместо ключевого слова PREVIOUS можно использовать синоним PRIOR.

В конкретных языках программирования для задания переменных можно (как и для оператора SELECT) использовать расширение INTO со списком переменных:

... INTO <переменная>, <переменна> ...

Например, если в программе на INFORMIX-4GL нам надо прочитать очередную запись в переменные, то соотвествующий оператор будет выглядеть так:

FETCH NEXT my_cursor INTO my_var1, my_var2.

Или для программы на INFORMIX ESQL/C:

$fetch next $my_cursor into $my_var1, $my_var2.

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

CLOSE <имя курсора>

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

FREE <имя курсора>

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

----------------T-------------¬ ¦ lname ¦ fname ¦ +---------------+-------------+ ¦ Антонов ¦ Сергей ¦ ¦ Шапокляк ¦ Алексей ¦ ¦ Антонов ¦ Антон ¦ ¦ Бендер ¦ Остап ¦ L---------------+--------------

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

DECLARE my_scroll_cursor SCROLL CURSOR FOR SELECT lname, fname FROM persons ORDER BY lname, fname OPEN my_scroll_cr.

После этих операторов сформирован набор записей в следующем порядке (порядок уже определен разделом ORDER BY оператора SELECT):

---------T-----------T----------¬ ¦ No п/п ¦ lname ¦ fname ¦ +--------+-----------+----------+ ¦ 1 ¦ Антонов ¦ Антон ¦ ¦ 2 ¦ Антонов ¦ Сергей ¦ ¦ 3 ¦ Бендер ¦ Остап ¦ ¦ 4 ¦ Шапокляк ¦ Алексей ¦ L--------+-----------+-----------

Теперь рассмотрим последовательность операторов FETCH и запись, ими выбираемая (порядок выполнения операторов FETCH, очевидно, существенен):

---------------------T------------------------------------¬ ¦ Оператор FETCH | Выбранная запись No (lname, fname) ¦ +--------------------+------------------------------------+ ¦ FETCH NEXT ¦ 1 (Антонов Антон ) ¦ ¦ FETCH NEXT ¦ 2 (Антонов Сергей ) ¦ ¦ FETCH CURRENT ¦ 2 (Антонов Сергей ) ¦ ¦ FETCH NEXT ¦ 3 (Бендер Остап ) ¦ ¦ FETCH RELATIVE -2 ¦ 1 (Антонов Антон ) ¦ ¦ FETCH LAST ¦ 4 (Шапокляк Алексей ) ¦ ¦ FETCH ABSOLUTE 3 ¦ 3 (Бендер Остап ) ¦ ¦ FETCH PREVIOUS ¦ 2 (Антонов Сергей ) ¦ ¦ FETCH FIRST ¦ 1 (Антонов Антон ) ¦ ¦ FETCH RELATIVE 2 ¦ 3 (Бендер Остап ) ¦ L--------------------+-------------------------------------

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

Область взаимодействия SQLCA.

Сервер базы данных для каждого пользователя (точнее, для каждого процесса) заводит так называемую область взаимодействия SQLCA (SQL Communication Area). Эта область фактически является глобальной структурой данных, состощей из нескольких именованных полей (переменных). Каждая переменная этой структуры содержит ту или иную характеристику последнего выполненного оператора или состояние сервера в целом. Поля структуры SQLCA перечислены в таблице:

-----------T--------- ¦ SQLCODE ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ SQLERRM ¦ ¦ ¦ SQLERRD ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ---T----------------------------------------¬ ¦ название ¦ тип ¦ описание ¦ +----------+------------+----------------------------------------+ ¦ целое ¦ Содержит признак завершения оператора. ¦ ¦ ¦ Может принимать следующие значения: ¦ ¦ ¦ 0 - признак успешного завершения; ¦ ¦ ¦ 100 - признак того, что запрос завер- ¦ ¦ ¦ шен нормально, но не было найдено ¦ ¦ ¦ ни одной записи; ¦ ¦ ¦ отрицательное значение - признак неу- ¦ ¦ ¦ дачного завершения; содержит код ¦ ¦ ¦ ошибки. ¦ +----------+------------+----------------------------------------+ ¦ строка из ¦ Содержит текстовую строку с описанием ¦ ¦ 71 символа ¦ ошибки в случае, если поле SQLCODE ¦ ¦ ¦ меньше нуля. ¦ +----------+------------+----------------------------------------+ ¦ массив из ¦ Описывает результат выполнения послед- ¦ ¦ 6 целых ¦ него оператора SQL: ¦ ¦ ¦ 1-й элемент - внутренняя информация; ¦ ¦ ¦ 2-й элемент - содержит сгенерированное ¦ ¦ ¦ сервером значение поля типа SERIAL ¦ ¦ ¦ для оператора INSERT, либо допол- ¦ ¦ ¦ нительный код ошибки; ¦ ¦ ¦ 3-й элемент - равен количеству обрабо- ¦ ¦ ¦ танных записей; ¦ ¦ ¦ 4-й элемент - примерная "стоимость" ¦ ¦ ¦ выполнения данного оператора; ¦ ¦ ¦ 5-й элемент - смещение ошибки в текс- ¦ ¦ ¦ товой записи оператор SQL ¦ ¦ ¦ 6-й элемент - внутренняя информация; ¦ L----------+------------+-----------------------------------------

Таблица: Поля области взаимодействия (SQLCA) ).

Предположим, мы хотим снизить на 20% цену на все товары, описанные в таблице items. А заодно, сообщить пользователю, что цены снижены на столько-то товаров. С ипользованием Informix ESQL/C и области взаимодействия SQLCA фрагмент программы будет выглядеть так:

$update items set price = 0.8*price; printf ("Цены снижены на %d наименований.\n", sqlca.sqlerrd[2]);

В данном примере (на ESQL/C) количество обработанных записей содержится в sqlca.sqlerrd[2], так как в языке C элементы массива нумеруются с 0 и 3-й элемент массива sqlca.sqlerrd как раз и будет иметь индекс 2.

Теперь рассмотрим пример вставки связанных значений в две таблицы. Например, мы подписали договор с новым поставщиком на поставку некоторого товара. Нам надо вставить информацию о поставщике в таблицу companies, а о товаре в таблицу items. Причем, в таблице items есть поле company, которое указывает на запись в таблице companies. Эта запись определяет фирму-поставщика данного товара (см. описание структуры базы данных в предыдущем номере). Можно, конечно, вставить информацию о фирме, по ее имени найти ее ключ, и это значение использовать для ссылки. Но это плохо - выполняется лишняя операция поиска и нигде не сказано, что имя компании уникально. С помощью области взаимодействия SQLCA данная задача решается достаточно просто (пример на Informix 4GL или NewEra):

DEFINE new_serial INTEGER ............ BEGIN WORK INSERT INTO companies(name) VALUES ("Наш новый партнер") LET new_serial = SQLCA.SQLERRD[2] -- ключ (company_id) для новой фирмы INSERT INTO items (name, company) VALUES ("Новый товар", new_serial) COMMIT WORK.

В данном примере, кстати, объединять два оператора в одну транзакцию (BEGIN WORK ... COMMIT WORK) очень желательно. Если этого не сделать и произойдет какой-то сбой между двумя операторами INSERT, то в базе окажется информация о компании, но не будет информации о товаре. В случае использования транзакции этого можно не опасаться.

Другое очень важное использование области взаимодействия SQL это проверка на то, что в результате оператора выборки (FETCH или SELECT) была найдена хотя бы одна запись. Для этого служит поле SQLCODE области взаимодействия. Данное поле также устанавливается оператором открытия курсора OPEN. Например, если мы хотим после открытия курсора выдать либо первую запись, либо сообщить о том, что записей не найдено, то соответствующий фрагмент программы будет выглядеть примерно так (пример на Informix ESQL/C):

#define NOTFOUND 100 ........ $declare x scroll cursor for select name, address from companies; $open x; /* теперь проверим на наличие хотя бы одной записи в выборке */ if (sqlca.sqlerrd == NOTFOUND) { /* нет ни одной записи - сообщить об этом */ printf("Записей не найдено.\n"); } else { /* показать первую запись и перейти к диалогу */ $fetch x into $name, $address; printf("Фирма %s расположена по адресу %s.\n", name, address); ....... /* диалог с пользователем */ } $close x; /* закрыте курсора по завершению работы */

Примером проверки ситуации, когда пользователь, выбрав последнюю запись, захотел выбрать еще и следующую (несуществующую), может служить следующий фрагмент программы на языке Informix 4GL:

FETCH x INTO name, address { не вышли ли мы за границы выборки? } IF (SQLCA.SQLERRD = NOTFOUND) THEN { больше записей нет - сообщить об этом } ERROR "Записей больше нет." END IF.

И, естественно, область взаимодействия SQL активно используется для контроля за ошибками и состоянием базы данных. Для этого надо проверять сотояние сервера SQL после выполнения какого-либо оператора. Надо отметить, что можно управлять реакцией прикладной программы на возникновение ошибок. Например, программа может автоматически завершаться при возникновении ошибки, а может и продолжать работу, сама обрабатывая ошибочную ситуацию (см. следующий параграф). Предположим, что программа работает в режиме, когда обработкой ошибок занимется сама программа и при возникновении ошибки выполнение программы продолжается. Приведем фрагмент программы, проверяющий наличие базы данных, и, если таковая отсутствует, создающий ее (Informix ESQL/C):

$database my_base; if (sqlca.sqlerrd < 0) { /* база данных отсутствует, пытаемся ее создать */ $create database my_base; if (sqlca.sqlerrd < 0) { /* ошибка при создании базы */ printf("Базы данных нет и она не может быть создана!\n"); exit(0); } }

Управление ошибками.

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

Указание программе прекращать выполнение при возникновении ошибке задается так:

WHENEVER SQLERROR STOP.

Для перехватывания ошибок и обработки их внутри программы служит следующий вариант оператора WHENEVER:

WHENEVER SQLERROR CONTINUE.

Или.

WHENEVER SQLERROR CALL <имя функции>

В случае CONTINUE при возникновении ошибки управление будет передано на следующий оператор, а в случае CALL - вначале будет вызвана указанная функция. Отслеживание возникновения ошибки в этом случае производится тестированием поля SQLCODE области взаимодействия SQL.

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

WHENEVER NOT FOUND { CONTINUE или STOP или <имя функции> }.

WHENEVER SQLWARNING { CONTINUE или STOP или <имя функции> }.

Для примера приведем простую программу на Informix-4GL с тремя операторами WHENEVER. Первый оператор задает режим продолжения работы (CONTINUE) при вознкновении ошибок, второй - задает реакцию на ненахождение выборки, а третий - говорит о необходимости завершить программу при возникновении ошибки. Любая ошибка между первым и третьим опреатором WHENEVER будет проигнорирована, а ошибка после третьего оператора WHENEVER приведет к аварийному завершнию программы.

MAIN DEFINE char_num INTEGER DATABASE test WHENEVER SQLERROR CONTINUE -- первый оператор WHENEVER DISPLAY "Пытаемся выполнить первый оператор INSERT" INSERT INTO test_table(color) VALUES ("красный") IF SQLCA.SQLCODE < 0 THEN DISPLAY "Ошибка при выполнении оператора вставки:", SQLCA.SQLERRM END IF WHENEVER NOT FOUND CONTINUE -- второй оператор WHWNEVER WHENEVER SQLERROR STOP -- третий оператор WHENEVER DISPLAY "Пытаемся выполнить второй оператор INSERT" INSERT INTO test_table(color) VALUES ("зеленый") CLOSE DATABASE DISPLAY "Программа выполнена" END MAIN.

После первого оператора INSERT мы можем проверить, был ли он реально выполнен путем сравнения SQLCA.SQLCODE с нулем. После второго оператора INSERT данная проверка бессмыслена, так как был выполнен оператор WHENEVER ERROR STOP и любая ошибка приведет к завершению программы.

5.7. Программирование сервера базы данных.

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

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

5.7.1. Динамический SQL.

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

Комбинации этих сортировок - по доходу и числу прогулов, по фамилии и стажу в обратном порядке и т.д. Простейший подсчет показывает - вариантов раздела ORDER BY оператора SELECT будет 81 (всего 4 поля, каждое поле допускает три разных способа использования при сотрировке - сортировать в порядке возрастания, убывания, вообще не сортировать - три в четвертой степени и есть 81). Согласитесь, что весьма утомительно указывать все 81 варианта оператора SELECT внутри программы.

В системах разработки приложений (ESQL/C, NewEra, 4GL и т.д.) имеется возможность формировать и исполнять SQL-запроса в процессе работы прикладной программы, в динамике ее исполнения. Отсюда и название - "динамический SQL" (впрочем, автор не считает это название очень удачным). Фактически, это тот же самый язык - SQL, но SQL-оператор не подвергаетсясинтаксическому разбору на этапе компиляции прикладной программы, а в текстовом виде передается непосредственно серверу базу данных.

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

PREPARE <имя оператора> FROM <текстовая строка>

EXECUTE <имя оператора>

FREE <имя оператора>

Оператор PREPARE "подготавливает" SQL-оператор для исполнения. Сам SQL-оператор указывается либо явно в виде текстовой строки, либо через значение текстовой переменной. Оператор PREPARE "связывает" с SQL-оператором имя. Это имя - самое обычное имя в среде разработки. Примеры (Informix-4GL):

PREPARE sel1 FROM "select name from items where price < 1.50".

PREPARE empty_comp FROM "INSERT INTO companies(name) VALUES ('undef')".

Оператор PREPARE посылает переданный ему текст SQL-серверу. Сервер анализирует переданные ему SQL-операторы и, если нет ошибок, переводит их во внутреннее представление.

После того, как оператор подготовлен, он может быть исполнен оператором EXECUTE. Здесь-то и надо указывать имя, данное подготовленному оператору:

EXECUTE sel1 EXECUTE empty_comp.

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

FREE sel1.

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

Если на момент подготовки SQL-оператора не все конкретные значения известны, то имеется возможность подставлять эти значения в момент исполнения. Для этого SQL-оператор, подготовленный с помощью PREPARE, должен быть снабжен параметрами. Параметры, значения которых будут определяться в момент исполнения, задаются символом "?":

PREPARE select2 FROM "SELECT price FROM items WHERE name = ?" PREPARE new_comp FROM "INSERT INTO companies(name, address) VALUES (?,?)".

Для задания фактических параметров в оператор EXECUTE надо добавить раздел USING:

EXECUTE new_comp USING "Кооператив 'Эх, ухнем'", "Москва, Арбат, 21" EXECUTE new_comp USING "ИЧП 'Бумеранг'", "Магадан, п/я 777".

Параметры в операторах PREPARE/EXECUTE являются позиционными. То есть при исполнении на место первого вопросительного знака подставляется первое значение в разделе USING, на место второго вопросительного знака - второе значение из раздела USING и т.д.

Подготовленный оператор может использоваться при описании курсора. Например, если в зависимости от желания пользователя нам надо выполнить сортировку товара либо по названию, либо по цене, то это на Informix-4GL реализуется следующим образом:

DEFINE string1 CHAR(60) .......... IF flag THEN { сортируем по названию } LET string1 = "SELECT name, price FROM items ORDER BY name" ELSE { сортируем по цене } LET string1 = "SELECT name, price FROM items ORDER BY price" END IF PREPARE select_st FROM string1 DECLARE my_cursor CURSOR FOR select_st ..........

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

Помимо возможности формировать запросы не на этапе написания программы, а на этапе ее иполнения, операторы PREPARE/EXECUTE/FREE могут быть полезны еще, как минимум, в двух случаях: для повышения эффективности программы и для исполнения SQL-операторов, которые понятны серверу, но которых нет в системе разработки.

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

(напомним, что все серьезные реляционные СУБД выполнены по схеме клиент-сервер). SQL-сервер исполняет запрос в четыре этапа: (1) анализирует пришедший запрос, (2) выбирает оптимальный способ его исполнения, (3) исполняет и (4) отсылает результаты приложению. Если выполнять несколько одинаковых запросов, то для каждого запроса будет делаться все четыре этапа. Если же мы подготавливаем запрос с помощью оператора PREPARE, а затем несколько раз исполняем его оператором EXECUTE, то анализ запроса и поиск оптимального способа исполнения будет делаться только один раз - в момент выполнения оператора PREPARE. А на каждое исполнение запроса оператором EXECUTE требуется только два последних этапа - непосредственное исполнение и отсылка результатов.

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

Например, Вы имеете среду разработки Informix-4GL старой версии (предположим, 4-й). Она вас вполне устраивает. Но в качестве SQL-сервера используется 7-я версия Informix DS Dynamic Scalable Architecture. Этот сервер "понимает" уже значительно более широкий набор SQL-операторов по сравнению с 4-й версией Informix-4GL. В частности, оператор создания триггеров CREATE TRIGGER (о том, что это такое, будет сказано ниже) может быть исполнен сервером, но отсутствует в продукте Informix-4GL версии 4.10. Используя операторы PREPARE/EXECUTE триггер можно создать:

PREPARE cr_trig FROM "CREATE TRIGGER trig1 ..." EXECUTE cr_trig FREE cr_trig.

Подготовленные с помощью оператора PREPARE SQL-запросы доступны (видимы) только в данном приложении, а именно между операторами DATABASE ... CLOSE DATABASE. То есть, если вы завершили работу (а точнее, закрыли базу данных оператором CLOSE DATABASE), то подготовленные запросы пропадают. Или, если вы подготовили SQL-запрос, то другой пользователь за другим компьютером не может выполнить подготовленный вами запрос (этот другой пользователь, конечно, может выполнить ту же самую последовательность PREPARE/EXECUTE/FREE, но это будет уже другой SQL-запрос). Однако, существует возможность подготовить для исполнения SQL-запросы так, что эти запросы будут доступны многим пользователям. Но для этого используется уже другой механизм - хранимые процедуры.

5.7.3. Хранимые процедуры.

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

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

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

· - никто кроме администратора не знает о том, как устроена схема базы данных и меньше шансов, что кто-то использует эти знания в корыстных целях;

· - независимо от типа рабочего места одно и тоже действие выполняется гарантированно одними и теми же операторами - выше надежность разработанной системы;

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

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

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

Языки написания хранимых процедур в настоящий момент сильно различается у разных производителей. Для серверов Informix язык для создания хранимых процедур носит название SPL - Stored Procedure Languages. Именно его (точнее, его подмножество), мы и рассмотрим.

Хранимая процедура создается оператором.

CREATE PROCEDURE <имя процедуры> (<формальные параметры>) <тело хранимой процедуры> END PROCEDURE.

Если хранимая процедура будет возвращать какие-то значения, то добавляется раздел RETURNING, в котором перечислены типы возвращаемых значений:

CREATE PROCEDURE <имя процедуры> (<формальные параметры>) RETURNING <тип 1>, <тип 2> ... <тело хранимой процедуры> END PROCEDURE.

Хранимая процедура может получать и возвращать произвольное число значений разных типов. Типы входных параметров и выходных значений могут быть любыми, доступными в SQL, за исключением SERIAL, BYTE и TEXT. Вместо типа SERIAL надо указывать тип INTEGER.

Примеры описаний хранимых процедур:

CREATE PROCEDURE incr_account (account_no INTEGER, quantity MONEY(20,2)) ..... END PROCEDURE.

CREATE PROCEDURE add_new_user (name CHAR(20) default NULL) RETURNING INTEGER {серийный номер нового пользователя} ..... END PROCEDURE.

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

Хранимая процедура, хоторая больше не нужна, может быть удалена. Для этого используется оператор:

DROP PROCEDURE <имя хранимой процедуры>

Например:

DROP PROCEDURE add_new_user.

Для исполнения хранимой процедуры используется оператор.

EXECUTE PROCEDURE <имя процедуры> (<фактические параметры>).

Например:

EXECUTE PROCEDURE incr_account (213917008, 23000000.00).

Если хранимая процедура возвращает какие-то значения (то есть в ее описании есть раздел RETURNING), то при исполнении этой процедуры в оператор EXECUTE PROCEDURE надо добавить раздел INTO с перечислением имен переменных (иногда вместо INTO используется слово RETURNING):

EXECUTE PROCEDURE <имя процедуры> (<фактические параметры>) INTO <имя переменной>, ...

Например:

EXECUTE PROCEDURE add_new_user ("Прутков") INTO user_id.

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

EXECUTE PROCEDURE incr_account (123456789, 1500000.00) EXECUTE PROCEDURE incr_account (account_no=123456789, quantity=1500000.00) EXECUTE PROCEDURE incr_account (quantity=1500000.00, account_no=123456789).

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

Язык хранимых процедур.

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

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

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

В разделе исполняемых операторов могут использоваться любые операторы из таблицы 1, а также любой из SQL-операторов, за исключеием тех, которые создают, удаляют, открывают или закрывают базу данных. При обращении к хранимой процедуре управление передается первому оператору в ее теле. Исполнение оператора RETURN завершает хранимую процедуру и возвращает исполнение в то место, откуда хранимая процедура была вызвана. Хранимая процедура завершаетя также и при достижении оператора END PROCEDURE. При этом никаких значений в вызывающую программу не возвращается.

В качестве примера рассмотрим реализацию хранимых процедур, приведенных при рассмотрении оператора CREATE PROCEDURE:

CREATE PROCEDURE incr_account (account_no INTEGER, quantity MONEY(20,2)) UPDATE accounts SET value = value + quantity WHERE account_id = account_no END PROCEDURE.

Хранимая процедура может содержать не только SQL операторы, но и операторы, обычные для универсальных языков программирования. Например:

CREATE PROCEDURE add_new_user (name CHAR(20) default NULL) RETURNING INTEGER {серийный номер нового пользователя} DEFINE user_id INTEGER; INSERT INTO users(lname) VALUES (name); LET user_id = SQLCA.SQLERR[2]; RETURN user_id END PROCEDURE.

Рассмотрим основные операторы, имеющиеся в языке хранимых процедур Informix SPL (SPL - это аббревиатура отStогеd Procedure Language):

CALL - то же самое, что и EXECUTE PROCEDURE.

CONTINUE - продолжить выполнение цикла. После этого слова надо указать какой именно цикл надо продолжить выполнять -FOR/WHILE/FOREACH. Примеры:

CONTINUE FOR .... CONTINUE FOREACH.

DEFINE - определить внутреннюю переменную. Для каждой переменной надо задать ее имя и ее тип:

DEFINE <имя переменной> <тип>

Примеры:

DEFINE user_id INTEGER DEFINE comp_name CHAR(40).

EXIT - прекратить выполнение цикла. После этого слова надо указать какой именно цикл надо прекратитьвыполнять - FOR/WHILE/FOREACH. Примеры:

EXIT WHILE .... EXIT FOR.

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

FOR <переменная> = <целое> TO <целое> STEP <целое> <операторы> END FOR.

Если шаг (STEP) не указан, то он принимается равным 1 если начальное значение меньше конечного, и -1, если нет. Пример:

FOR i = 1 TO 14 .... END FOR.

IF - условный оператор. Проверяет условие и, если оно верно, выполняет операторы после слова THEN. Если не верно, и присутствует раздел ELSE - то выполняются операторы после слова ELSE:

IF <условие> THEN <операторы> END IF IF <условие> THEN <операторы> ELSE <операторы> END IF.

Если после слова ELSE по логике должен следовать другой оператор IF, то такое сочетание ELSE IF ... END IF END IF можно записывать более компактно: ELIF ... END IF. Пример:

IF j > 20 THEN RETURN j ELIF j > 10 THEN RETURN 10 ELSE RETURN 0 END IF.

LET - оператор присваивания. Вычисляет выражение и присваивает его значение указанной переменно:

LET <имя переменной> = <выражение>

Выражение, которое может быть здесь использовано, очень похоже на выражение, которое может использоваться в операторе SELECT. Примеры:

LET i = 0 LET str1 = "абвгдежз".

RAISE EXCEPTION - возбудить ошибку. Если на данную ошибку не стоит реакция (нет соответствующего оператора ON EXCEPTION), то исполнение хранимой процедуры завершается и в вызвавшую программу "передается" данная ошибка:

RAISE EXCEPTION <номер ошибки>

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

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

RETURN <выражение 1>, ....

SYSTEM - позволяет выполнить внешнюю команду. Имя этой внешней команды передается операционной системе, то есть это может быть или встроенная команда ОС, или исполнимый файл:

SYSTEM <символьная строка> SYSTEM <имя символьной переменной>

Например, можно выполнить командный файл my_cmd:

SYSTEM "/usr/local/bin/my_cmd".

WHILE - цикл с завершением по условию. Аналогичен циклу WHILE в других языках программирования:

WHILE <условие> <операторы> END WHILE.

Пример:

LET i = 1 WHILE i = 1 EXECUTE PROCEDURE my_proc RETURNING I END WHILE.

BEGIN ... END - блок операторов. В блоке операторов можно определять и использовать локальные переменные. Допустимые любые другие операторы SPL. Пример:

BEGIN DEFINE i CHAR(20) LET i = "Ну, погоди!" IF ... THEN BEGIN DEFINE i INTEGER LET i = 0 .... END END IF END.

5.7.4. Триггеры.

Идея триггеров.

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

Для подобных задач в SQL введено понятие триггера, Триггер - это механизм, который автоматически выполняет некоторый набор SQL-операторов когда происходит некоторое событие. То есть триггер задается парой "событие-действие". Событиями, на которые можно установить триггер, являются модификации данных, то есть операторы DELETE, INSERT, UPDATE. Причем, триггер связан с конкретной таблицей. То есть событием, вызывающим триггер (триггерным событием) является выполнение операторов удаления, вставки или модификации конкретной таблицы.

Триггер хранится как объект в базе данных, то есть принадлежит схеме базы данных. ).

Создание и удаление триггера.

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

CREATE TRIGGER <имя> <событие> <действие> DROP TRIGGER <имя>

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

Соответственно, синтаксис на раздел "событие" при создании триггера будет следующим:

INSERT ON <имя таблицы> DELETE ON <имя таблицы> UPDATE ON <имя таблицы> UPDATE OF <поле>, <поле>, ... ON <имя таблицы>

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

{ триггер на вставку нового документа } CREATE TRIGGER trig1 INSERT ON documents ....

{ триггер на удаление информации о фирме } CREATE TRIGGER del_trig DELETE ON companies ....

{ триггер на обновление цены товара } CREATE TRIGGER upd_price UPDATE OF price ON items ....

{ триггер на изменение имени или фамилии человека } CREATE TRIGGER upd_name UPDATE OF lname, fname ON persons ....

Теперь рассмотрим, как описываются действия триггера. Каждое действие состоит из описания того, что выполняется единожды перед началом исполнения оператора, вызвавшего событие для триггера (раздел BEFORE), для каждого ряда (раздел FOR EACH ROW) и после исполнения оператора (раздел AFTER).

CREATE TRIGGER .... ON ... BEFORE <операторы> FOR EACH ROW <операторы> AFTER <операторы>

Можно использовать произвольное сочетание из разделов BEFORE, FOR EACH ROW и AFTER, главное, что бы был хотя бы один раздел. В качестве операторов для триггеров могут быть использованы всего четыре типа SQL-операторов - оператор вставки (INSERT), удаления (DELETE), обновления (UPDATE) и выполнения хранимой процедуры (EXECUTE PROCEDURE). Очевидно, что наличие в этом списке оператора вызова хранимой процедуры позводяет сделать триггер сколь угодно сложным. Эти SQL-операторы должны разделяться запятой и находиться в круглых скобках.

Примеры:

CREATE TRIGGER trig1 DELETE ON persons AFTER ( UPDATE tab2 SET x=x+1, UPDATE tab3 SET y=y-1 ).

CREATE TRIGGER upd_trig UPDATE OF name ON companies FOR EACH ROW ( EXECUTE PROCEDURE proc1 ) AFTER ( EXECUTE PROCEDURE proc2 ).

Рассмотрим поведение последнего триггера (upd_trig) более подробно. Пусть таблица companies имеет следующую структуру и состоит из следующих записей:

CREATE TABLE companies ( company_id SERIAL { уникальный идентификатор фирмы } name CHAR(40) { название фирмы } address CHAR(60) { адрес фирмы } )

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

UPDATE companies SET name = "ИЧП Мастер Безенчук" WHERE company_id = 101.

Приведет к исполнению триггера upd_trig. Причем, так как модифицироваться будет одна запись, то и процедура proc1, и proc2 будут исполнены по одному разу, причем вначале proc1, а затем proc2. Раздел AFTER и, соответсвенно, процедура proc2, будут исполнены уже после внесения изменений в базу данных. Но если оператор UPDATE модифицирует несколько записей, то процедура proc1 будет исполнена несколько раз (по одному разу для каждой модифицируемой записи), а процедура proc2 - только один раз - после внесения всех изменений. Так, оператор.

UPDATE companies SET name = "ТОО Льдинка" WHERE company_id > 103.

Изменит название у двух компаний, то есть в одном запросе будут модифицированы поля name у двух записей. В результате, процедура proc1 будет исполнена дважды, а затем один раз будет вызвана процедура proc2. Если в операторе UPDATE предполагается изменение поля name, но ни одна запись не была модифицирована (не удовлетворила условию в разделе WHERE, например), то раздел FOR EACH ROW триггера не будет выполнен ни разу, тогда как разделы BEFORE и AFTER все равно сработают. Так, следующий оператор исполнит процедуру proc2 и ни разу не выполнит proc1:

UPDATE companies SET name = NULL WHERE company_id < 57.

А следующий оператор вообще не приведет к выполнению триггера upd_trig, так как поле name данной таблицы не изменяется и его вообще нет в списке обновляемых полей:

UPDATE companies SET address = "Москва, Бутырка" WHERE company_id = 101.

Имена для старого и нового значений записи.

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

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

REFERENCING OLD AS <связанное имя для старого значения> REFERENCING NEW AS <связанное имя для нового значения>

Указывать связанные имена можно в любом порядке. Если какое-то из имен не нужно (например, нам не требуется имя для старого значения), то его можно не указывать. Слово AS можно опускать. ).

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

CREATE TRIGGER del_trig DELETE ON items REFERENCING OLD del_rec FOR EACH ROW ( UPDATE tab2 SET total=total-del_rec.price ).

CREATE TRIGGER upd_trig UPDATE OF name ON companies REFERENCING NEW newval REFERENCING OLD oldval FOR EACH ROW (EXECUTE PROCEDURE proc4(oldval.name, newval.name) ) AFTER ( EXECUTE PROCEDURE proc2 ).

Итак, все-таки, напишем триггер, который будет срабатывать на удаление информации о фирме (таблица companies) и действие которого будет состоять в удалении из таблицы persons информацию о всех сотрудниках этой фирмы:

CREATE TABLE companies ( company_id SERIAL, { первичный ключ фирмы } ....)

CREATE TABLE persons (..., company INTEGER, { ссылка на фирму, где работает } ....)

CREATE TRIGGER del_comp DELETE ON companies REFERENCING OLD AS rec FOR EACH ROW (DELETE FROM persons WHERE persons.company = rec.company_id ).

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

CREATE TABLE protocol ( company INTEGER, { идентификатор измененной записи } login CHAR(8), { ситемное имя пользователя } oldname CHAR(40), { старое имя фирмы } newname CHAR(40), { новое имя фирмы } when DATETIME YEAR TO SECOND { когда } )

Тогда, требуемый нам триггер будет выглядеть так:

CREATE TRIGGER upd_compname UPDATE OF name ON companies REFERENNCING NEW AS newcomp REFERENNCING OLD AS oldcomp FOR EACH ROW (INSERT INTO protocol (company, login, oldname, newname, when) VALUES (oldcomp.company_id, USER, oldcomp.name, newcomp.name, CURRENT).

Условия внутри триггера.

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

........ WHEN ( <условие> ) ( <оператор>, <оператор>, ...), WHEN ( <условие> ) ( <оператор>, <оператор>, ...), ........

Для каждого из разделов BEFORE/FOR EACH ROW/AFTER можно указывать произвольное количество таких пар условие-операторы. Пример триггера с дополнительными условиями:

CREATE TRIGGER upd_price UPDATE OF price ON items REFERENCING OLD AS pre REFERENCING NEW AS post FOR EACH ROW WHEN (post.price < 0) (EXECUTE PROCEDURE proc1(post.price)) WHEN (post.price > pre.price * 2) (EXECUTE PROCEDURE proc2(ppost.price, pre.price)).

5.8. Ограничители (задание целостности на уровне схемы).

Целостность и ограничители.

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

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

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

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

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

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

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

Значения по умолчанию для полей.

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

Значения по умолчанию для того или иного пля задаются при создании таблицы (оператор CREATE TABLE), либо при модификации структуры таблицы (оператор ALTER TABLE). При описании поля после типа данных надо указать ключевое слово DEFAULT и значение по умолчанию. В качестве значения по умолчанию может стоять константа (в том числе NULL) или функция-псевдополе (CURRENT, TODAY, USER). Пример:

{ таблица с заказами } CREATE TABLE orders ( order_id SERIAL, { уникальный ключ для заказа } item INTEGER NOT NULL, { ссылка на товар } when DATE DEFAULT TODAY, { дата заказа } quantity INTEGER DEFAULT 0, { количество } tot_price MONEY(20,2) DEFAULT "0.0" { общая стоимость } )

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

Когда создается таблица, то для каждого поля задается тип его значения. Это может быть INTEGER, CHAR и т.д. Тип определяет допустимое множество значений для данного поля. Но в некоторых случаях это множество значений много шире реально используемого множества. Например, для обозначения количества единиц товара в заказе (см. структуру таблицы orders в предыдущем пункте) используется тип INTEGER. Но это количество не может быть отрицательным - это диктуется логикой задачи, а тип INTEGER допускает отрицательные значения.

В SQL есть средства более тонкого описания множества допустимых значений поля (кстати, это множество в теории называют доменом). Более точно задать домен для того или иного поля можно с помощью ограничителя на значение (check constraint). Этот ограничитель указывается при создании таблицы (оператор CREATE TABLE). После типа поля или значения по умолчанию надо указать ключевое слово CHECK и логическое выражение в скобках:

CREATE TABLE <имя таблицы> ( ..... <имя поля> <тип поля> [NOT NULL] [<значение по умолчанию>] CHECK (<логическое выражение>) .....)

Это логическое выражение и будет опредеять допустимость значения. Условие проверяется перед изменением данных в поле операторами UPDATE или INSERT. Если значение логического выражение ложь или NULL, то сервер базы данных возвращает ошибку. Если вычисленное логическое выражение имеет значение истина, то новое значение считается допустимым и операция модификации завершается успешно. Например, можно описание таблицы orders расширить следующим образом:

CREATE TABLE orders ( ..... item INTEGER NOT NULL CHECK (EXISTS (SELECT items.item_id FROM items WHERE items.item_id = item) ), ..... quantity INTEGER DEFAULT 0 CHECK (quantity > 0), tot_price MONEY(20,2) DEFAULT "0.0" CHECK (quantity > 0) )

В ограничителе на значение поля можно использовать сколь угодно сложное логическое выражение. Требования к этому выражению такие же, как и к условию в разделе WHERE оператора SELECT. То есть можно использовать логические операции IN, MATCHES, NOT, OR, AND, EXISTS и т.д. Не допускается, однако, использование вложенных подзапросов, агрегатных функций, псевдофункций-полей (CURRENT, TODAY, USER) и вызовов хранимых процедур. Нельзя, также, использовать логическое выражение, которое зависит от других полей в этой таблице. Например, если мы напишем.

CREATE TABLE .... price MONEY, quantity INTEGER, tot_price MONEY CHECK (tot_price = price*quantity) .....

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

Уникальные поля.

Для задания уникального ключа в таблице обычно используется тип SERIAL. Этот тип по множеству значений и способу внутреннего представления идентичен типу INTEGER. Но гарантировать уникальность значений поля типа SERIAL можно только в том случае, когда сервер сам генерирует новое значение для типа SERIAL, то есть оператор INSERT с явным указанием нового значения SERIAL не выполняется. Но иногда задача требует, что бы гарантированно поля любого типа, в том числе и SERIAL, использовались в качестве первичного ключа. Или, что тоже часто встречается, предметная область накладывает требование, что бы набор некоторых полей был уникальным, то есть был бы тоже первичным ключом (ключ, состоящий из нескольких полей, называется составным). Для проверки поля или группы полей на то, что они являются первичным ключом используется ограничитель на уникальность. Ограничитель на уникальность группы полей будет рассмотрен в параграфе 4.5. Здесь мы рассмотрим ограничитель на уникальность для отдельного поля.

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

CREATE TABLE <имя таблицы> ( ..... <имя поля> <тип поля> [NOT NULL] [<значение по умолчанию>] UNIQUE .....)

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

CREATE TABLE trademarks ( name CHAR(64) UNIQUE, { название торговой марки } company INTEGER, { какой компании принадлежит } .... )

Отличие типа SERIAL от поля, объявленного уникальным, заключается в том, что сервер при вставке новой записи с полем типа SERIAL сам генерирует новое уникальное значение для типа SERIAL и не делает этого для поля с ограничителем на уникальность. Приложение должно само заботиться о присвоении полям с ограничителем на уникальность новых значений. Иначе, при вставке нового ряда при неуказанном значении уникального поля ему будет присвоено или значение NULL, или значение по умолчанию. Ни то, ни другое значение, скорее всего, не будет уникальным.

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

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

CREATE TABLE trademarks ( trademark_id SERIAL UNIQUE, { первичный ключ } name CHAR(64) UNIQUE, { название торговой марки } company INTEGER, { какой компании принадлежит } .... )

Ограничитель на уникальность не может использоваться совместо с ограничителем на значение.

Ссылочная целостность.

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

Для реализации таких отношений между таблицами используются ссылки. То есть в одной из двух связанных таблиц заводится поле (или поля), которое представляет собой значение первичного ключа в другой таблице. Именно таким образом связаны таблицы companies, persons, items, и orders. Здесь главной таблицей является таблица с информацией о фирмах (companies). Все остальные таблицы - люди (persons) и товары (items) в некотором смысле являются подчиненными таблице companies. То есть ни человек, ни товар не могут быть определены, если нет информации о соответсвующей фирме. Таблица orders, хотя и связана с таблицей items соотношением один-к-одному, тем не менее должна рассматриваться как пдчиненная последней, так как поставляемые товары могут существовать без конкретных заказов (мы этот товар еще ни разу не покупали), а наоборот - нет. В соответствии с этим, в подчиненной таблице хранится ссылка на главную, а не наоборот.

Итак, в главной таблице есть некоторый первичный ключ, а в подчиненной таблице есть ссылка, представляющая собой поле (или поля), хранящие значение первичного ключа главной таблицы:

+-------------+ +-------------+ +----------+ | companies | ++------------+| ++---------+| +-------------+ ++------------+|| ++---------+|| +->| company_id |<--+ | persons ||| | items ||| | | name | | +-------------+|| +----------+|| | | address | | | person_id ||| | item_id ||| | | phone | +--+- company ||| | company -+----+ +-------------+ | lname ||| | name |++ | fname |++ | price ++ | sname ++ +----------+ +-------------+

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

CREATE TABLE <имя таблицы> ( ..... <имя поля> <тип поля> [NOT NULL] [<значение по умолчанию>] PRIMARY KEY, ....., <имя поля> <тип поля> [NOT NULL] [<значение по умолчанию>] REFERENCES <имя таблицы> (<имя поля>) .....)

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

CREATE TABLE companies ( company_id SERIAL PRIMARY KEY, ....)

CREATE TABLE items ( item_id SERIAL PRIMARY KEY, company INTEGER REFERENCES companies(company_id), ....)

CREATE TABLE persons ( person_id SERIAL PRIMARY KEY, company INTEGER REFERENCES companies(company_id), ....)

CREATE TABLE orders ( ..... item INTEGER REFERENCES items(item_id), ....)

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

Ограничители на уровне таблицы.

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

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

CREATE TABLE .... price MONEY, quantity INTEGER, tot_price MONEY, ...., CHECK (tot_price = price*quantity) ).

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

.... UNIQUE (<имя поля>, <имя поля>, ...).

Ссылочный ограничитель для таблицы, так же как и для одного поля, состоит из описания первичного ключа и ссылки на первичный ключ. Первичный ключ задается с помощью ключевых слов PRIMARY KEY, после которых в скобках через запятую идут составляющие его поля. Ссылка на первичный ключ начинается со слов FOREIGN KEY, после которых, также в скобках через запятую, перечислены составляющие ссылку поля. Затем после слова REFERENCES надо указать имя таблицы и в скобках поля первичного ключа для главной таблицы:

.... PRIMARY KEY (<имя поля>, <имя поля>, ...) .... FOREIGN KEY (<имя поля>, <имя поля> REFERENCES (<имя поля>, <имя поля>, ...).

Очевидно, должно быть соответствие между порядком и количеством полей после слов FOREIGN KEY и слова REFERENCES. Пример:

CREATE TABLE accounts ( acc_num INTEGER, acc_type INTEGER, ..., PRIMARY KEY (acc_num, acc_type)).

CREATE TABLE sub_accounts ( ..., ref_num INTEGER NOT NULL, ref_type INTEGER NOT NULL, ..., FOREIGN KEY (ref_num, ref_type) REFERENCES accounts (acc_num, acc_type) ).

5.9. Разграничение в SQL прав пользователей.

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

5.9.1. Права доступа.

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

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

INSERT INTO protocol(user_id, action, date) VALUES (USER, "удалил запись", CURRENT YEAR TO SECOND).

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

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

5.9.2. Права на уровне базы данных.

Имеется три категории прав на уровне базы данных. Это право на адимнистрирование (DBA), право на управление ресурсами (RESOURCE), право на доступ (CONNECT). Некоторые пользователи могут вообще не иметь каких-либо прав, связанных с конкретной базой данных.

Пользователь, имеющий права на доступ (CONNECT) имеет возможность получать и модифицировать данные в базе. Он может модифицировать те объекты, которыми владеет. Любой пользователь, имеющий право доступа может делать следующее:

· выполнять операторы SELECT, INSERT, DELETE, UPDATE, если это ему позволено на уровне объекта (таблицы);

· создавать новую псевдотаблицу (VIEW) по таблицам (см. ниже), если он имеет права на выборку по требуемым таблицам;

· создавать синонимы (см. ниже);

· создавать временные таблицы и индексы по временным таблицам;

· изменять или удалять те объекты, которыми владеет;

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

Пользователь, имеющий права на управление ресурсами (RESOURCE), в дополнение к тем правам, которые имеют пользователии с правом на доступ, может также создавать новые объекты. Например, такой пользователь может создать таблицу, триггер, индекс и т.д. Как только он создает какой-то объект, он становится его владельцем.

Право на администрирование базы данных (DBA) подразумевает следующие возможности:

· удалить базу данных (выполнить оператор DROP DATABASE);

· удалять любые объекты вне зависимости от того, кто ими владеет;

· раздавать и менять права доступа других пользователей к базе данных в целом и к отдельным объектам.

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

GRANT <тип права на базу данных> TO <имя пользователя>

При управлении правами на уровне базы данных имя базы не указывается. Подразумевается текущая база данных. Примеры оператора GRANT:

GRANT DBA TO andy.

GRANT RESOURCE TO micky.

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

GRANT CONNECT TO PUBLIC.

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

REVOKE <тип права на базу данных> FROM <имя пользователя>

Например:

REVOKE CONNECT FROM roma.

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

REVOKE DBA FROM andy.

REVOKE CONNECT FROM andy.

Аналогично и с правом на управление ресурсами - выполнение оператора.

REVOKE CONNECT FROM micky.

Ни к чему не приведет, так как пользователь "micky" имеет права RESOURCE, а выполнение оператора.

REVOKE RESOURCE FROM micky.

Оставит пользователю "micky" право на доступ.

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

5.9.3. Права на таблицы.

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

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

Права на уровне таблиц бывают следующего типа:

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

· DELETE - право на удаление записей из таблицы.

· INDEX - право на создание индексов для данной таблицы (индексы будут рассмотрены позднее). Для использования этого права надо иметь право на управление ресурсами на уровне всей базы.

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

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

· ALL - все перечисленные выше права на таблицу.

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

GRANT <тип права на таблицу> ON <имя таблицы> TO <имя пользователя>

Вместо имени пользователя можно использовать слово PUBLIC, означающее всех пользоователей. Например:

GRANT ALL ON persons TO micky GRANT SELECT ON persons TO roma GRANT INSERT ON items TO PUBLIC.

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

GRANT <тип права на таблицу> (<имя поля>, <имя поля>, ....) ON <имя таблицы> TO <имя пользователя>

Например:

GRANT SELECT(person_id, lname, fname) ON persons TO PUBLIC.

Если какой-либо пользователь не имеет права на выборку того или иного поля, то он не может его использовать не только в разделе SELECT, но и в разделе WHERE. Например, если пользователь nick не имеет права на выборку поля address из таблицы persons, то он не имеет права выполнить следующие два запроса:

SELECT lname, fname, address FROM persons WHERE person_id = 101 SELECT lname, fname FROM persons WHERE address MATCHES "*Одесса*".

Пользователь, получивший то или иное право с помощью оператора GRANT ... ON ... TO ... не может передать это право другому пользователю. Для возможности передачи права другим, пользователь должен получить право на его передачу. Это право указывается в операторе GRANT с помощью ключевых слов WITH GRANT OPTION:

GRANT <тип права на таблицу> (<имя поля>, ....) ON <имя таблицы> TO <имя пользователя> WITH GRANT OPTION.

Например, владелец таблицы tabl может передать право на выборку для пользователей "sales" и "tech", но пользователю "tech" это право передается с правом передачи:

GRANT SELECT ON tabl TO sales GRANT SELECT ON tabl TO tech WITH GRANT OPTION.

После этого пользователь "tech" может выполнить следующие два оператора, а пользователь "sales" не может:

GRANT SELECT ON tabl TO jason WITH GRANT OPTION GRANT SELECT ON tabl TO micky.

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

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

REVOKE <тип права на таблицу> ON <имя таблицы> FROM <имя пользователя>

Например:

REVOKE UPDATE ON persons FROM george REVOKE ALL ON passwords FROM PUBLIC.

Если какое-либо право отбирается у пользователя, которому оно было дано с правом на передачу (WITH GRANT OPTION), то это право теряют и те пользователи, кому этот пользователь его передал. Предположим, Вы владелец таблицы tab1. Вы передаете право на вставку пользователям user1, user2:

GRANT INSERT ON tab1 TO user1 WITH GRANT OPTION GRANT INSERT ON tab1 TO user2 WITH GRANT OPTION.

Затем, пользователь "user1" передал это право пользователю "user3":

GRANT INSERT ON tab1 TO user3.

Теперь, если Вы отберете право на выборку у пользователя "user1", то его автоматически потеряет и пользователь "user3".

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

GRANT SELECT, UPDATE(fname, lname, address) ON persons TO micky, roma.

Эквивалентен следующим четырем операторам:

GRANT UPDATE(fname, lname, address) ON persons TO micky GRANT SELECT ON persons TO micky GRANT UPDATE(fname, lname, address) ON persons TO roma GRANT SELECT ON persons TO roma.

5.9.4. Права на хранимые процедуры.

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

GRANT EXECUTE ON <имя процелуры> TO <имя пользователя>

GRANT EXECUTE ON <имя процелуры> TO <имя пользователя> WITH GRANT OPTION REVOKE EXECUTE ON <имя процелуры> FROM <имя пользователя>

5.9.5. Кто и как следит за соблюдением прав.

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

Как хранится информация о привилегиях - это внутреннее дело SQL-сервера. Например, Informix DS использует для этого системные таблицы (каталоги), где и зафиксирована кто и что может делать с данными.

5.9.6. Механизм ролей.

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

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

CREATE ROLE <имя>

Например, если мы хотим создать три группы - admin (администратор), sales (продавцы) и tech (технический персонал), то надо выполнить следующие операторы:

CREATE ROLE admin CREATE ROLE sales CREATE ROLE tech.

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

Для указания пользователей, входящих в ту или иную роль, используется оператор.

GRANT <имя роли> TO <имя пользователя1>, <имя пользователя2> ….

Один пользователь может принадлежать нескольким ролям, также как и не принадлежать ни одной роли (или, что тоже самое, принадлежать только роли по имени NULL). Например:

GRANT admin TO andy GRANT tech TO andy, micky GRANT sales TO nick, kate.

В этом примере пользователь andy входит сразу в две роли - admin и tech, пользователи micky, nick, kate - входят только в одну роль.

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

REVOKE <имя роли> FROM <имя пользователя>

Например:

REVOKE sales FROM nick.

Для удаления роли используется оператор.

DROP ROLE <имя>

Для приписывания роли или отбирания у роли тех или иных прав и привилегий используются варианты операторов GRANT и REVOKE, рассмотренные в пунктах 5.9.2 и 5.9.3, только вместо имени пользователя необходимо указывать имя роли:

GRANT UPDATE(fname, lname, address) ON persons TO admin GRANT SELECT ON persons TO tech REVOKE UPDATE(fname, lname, address) ON persons FROM sales.

Определять новые роли может только пользователь, являющийся администратором данной базы данных, то есть имеющий привилегию DBA на текущую базу данных. Удалить роль, модифицировать список пользователей, входящих в ту или иную роль, а также приписать или отобрать у роли некоторые привилегии, может только адинистратор базы данных, или пользователь, которому данная роль была передана с опцией WITH GRANT OPTION.

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

SET ROLE <имя роли>

Например:

SET ROLE admin.

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

SET ROLE NULL.

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

5.9.7. Псевдотаблицы (VIEW).

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

В SQL данная проблема может быть решена с помощью псевдотаблиц (VIEW). Псевдотаблица строится на основе уже существующих таблиц или пседотаблиц. В основе псевдотаблицы лежит оператор выборки. Собственно говоря, псевдотаблица и задается оператором выборки:

CREATE VIEW <имя псевдотаблицы> AS <оператор выборки>

Например:

CREATE VIEW cheap_items AS SELECT item_id, company, name, price FROM items WHERE price < 100.00.

В этом примере была создана псевдотаблица, содержащая информацию только о дешевых (дешевле 100 единиц) товаров.

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

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

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

CREATE TABLE employers ( login_name CHAR(8), { системное имя } depat_num INTEGER, { номер отдела } .............. )

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

SELECT login_name, depat_num, ... FROM employers WHERE depat_num = (SELECT depat_num FROM employers WHERE login_name = USER).

Если, например, таблица employers имеет следующие записи.

-------------T-----------T-----¬ ¦ login_name ¦ depat_num ¦.....¦ +------------+-----------+-----+ ¦ nick ¦ 0 ¦ ¦ ¦ andy ¦ 4 ¦ ¦ ¦ kate ¦ 2 ¦ ¦ ¦ george ¦ 2 ¦ ¦ ¦ micky ¦ 4 ¦ ¦ ¦ roma ¦ 4 ¦ ¦ L------------+-----------+------

То пользователь "george" при исполнении этого запроса увидит информацию только о себе и о пользователе "kate", пользователь "andy" увидит информацию о себе и пользователях "roma" и "micky", а пользователь "nick" получит данные только о себе.

Теперь осталось только на основе данного оператора SELECT создать псевдотаблицу my_collegues:

CRETATE VIEW my_collegues AS SELECT login_name, depat_num, ... FROM employers WHERE depat_num = (SELECT depat_num FROM employers WHERE login_name = USER).

Теперь запросы вида.

SELECT login_name FROM my_collegues.

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

GRANT SELECT ON my_collegues TO PUBLIC.

REVOKE ALL ON employers FROM PUBLIC.

В псевдотаблицу можно вставлять значения, обновлять данные и удалять записи, но только в том случае, если псевдотаблица образована из одной таблицы. Так, операторы UPDATE, INSERT, DELETE применимы для описанных выше псевдотаблиц my_collegues и cheap_items. Но если для определенния псевдотаблицы использовались поля из двух или более таблиц, то такая псевдотаблица может быть использована только в операторе SELECT. Пример определения псевдотаблицы, построенной из нескольких таблиц:

CREATE VIEW pers_comp AS SELECT persons.lname, persons.fname, persons.sname, companies.name, companies.addresss FROM persons, companies WHERE persons.company = companies.company_id.

При создании VIEW можно дополнительно указать, что эта псевдотаблица будет с проверкой. Это означает, что при вставке, удалении или модификации записи будет проверяться условие WHERE в операторе SELECT, который образует данную псевдотаблицу. Для описания псевдотаблицы с проверкой надо указать ключевые слова WITH CHECK OPTION в операторе CREATE VIEW:

CREATE VIEW <имя псевдотаблицы> AS <оператор выборки> WITH CHECK OPTION.

Например, в определенную выше псевдотаблицу cheap_items можно вставить запись с ценой, равной 500 единиц:

INSERT INTO cheap_items (company, name, price) VALUES (101, "смокинг", 500).

Так как эта псевдотаблица создана без проверки. Правда, сразу после этого оператора вставки в данной псевдотаблице запись о смокинге ценой в 500 единиц будет все равно отсутствовать (при выборке эта запись будет отсечена по условию price<100). А если бы мы создали эту псевдотаблицу с проверкой, то SQL-сервер выдал бы сообщение об ошибке:

CREATE VIEW cheap_items AS SELECT item_id, company, name, price FROM items WHERE price < 100.00 WITH CHECK OPTION.

Использование псевдотаблиц бывает полезным не только в случаях разграничения доступа, но и в случаях изменения структуры базы данных. Если при проектировании базы данных была допущена ошибка, или изменились условия задачи, то очень часто приходится переделывать структуру базы данных - менять структуру таблиц, вводить новые таблицы и т.д. Обычно это требует переписывать прикладную программу. Но если с помощью псевдотаблиц можно можно симитировать старую структуру, то ничего переписывать не надо. Кроме того, использования псевлотаблиц с проыеркой (WITH CHECK OPTION) является еще одним способом поддержания целостности базы данных.

Удаляется псевдотаблицы оператором.

DROP VIEW <имя псевдотаблицы>

Например:

DROP VIEW cheap_items DROP VIEW employers.

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

5.9.7. Синонимы.

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

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

CREATE PUBLIC SYNONYM <имя синонима> FOR <имя таблицы>

Личный синоним создается аналогично, только вместо ключевого слова PUBLIC используется слово PRIVATE:

CREATE PRIVATE SYNONYM <имя синонима> FOR <имя таблицы>

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

Примеры создания синонимов:

CREATE PUBLIC SYNONYM goods FOR items.

CREATE PRIVATE SYNONYM tovary FOR items.

Для баз данных в режиме ANSI синонимы бывают только личными и при создании синонима слово PRIVATE указывать не надо. Имена синонимов могут использоваться в операторах GRANT и REVOKE при передаче или лишения права на доступ к таблице..

Удаляется синоним оператором.

DROP SYNONYM <имя синонима>

5.10. Управление одновременным доступом к данным.

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

5.10.1. Что бывает, когда несколько человек одновременно пытаются обновить одни и теже данные.

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

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

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

Итак, рассмотрим те механизмы, которые есть в SQL, и которые используются для предотвращения описанных выше ситуаций.

5.10.2. Открытие базы данных только для себя.

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

DATABASE <имя базы> EXCLUSIVE.

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

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

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

CLOSE DATABASE.

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

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

5.10.3. Блокирование таблицы.

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

Разделяемая блокировка на таблицу ставится оператором.

LOCK TABLE <имя таблицы> IN SHARE MODE.

Эксклюзивная блокировка на таблицу ставится оператором.

LOCK TABLE <имя таблицы> IN EXCLUSIVE MODE.

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

Снятие блокировки производится оператором.

UNLOCK TABLE <имя таблицы>

Блокировка с таблиц также снимается автоматически при закрытии базы данных (оператор CLOSE DATABASE) или при завершении (например, аварийном) пользовательской программы.

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

5.10.4. Механизм блокирования записей и уровни изоляции.

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

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

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

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

Существуют следующие основные уровни изоляции: грязное чтение (DIRTY READ), достоверное чтение (COMMITTED READ), стабильный курсор (CURSOR STABILITY), многократное чтение (REPEATABLE READ).

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

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

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

Уровень изоляции COMMITTED READ (достоверное чтение) обеспечивает чтение данных, когда они не модифицируются другим процессом. Использование этого уровня изоляции обеспечивает Вам невозможность прочесть так называемые "фантомные" записи, которые появляется в процессе выполнения транзакции другим процессом. То есть если Ваша программа прочитала запись, то эта запись гарантирована существует. Однако, никаких блокировок на прочитанные записи при этом не делается, то есть другой процесс может прочитать эту же запись и удалить или изменить ее. Данный уровень изоляции является уровнем, принимаемым по умолчанию для баз данных с транзакциями.

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

Уровень изоляции «Достоверное чтение», как и все более высокие уровни, описываемые ниже, возможен только для баз данных с транзакциями.

Уровень изоляции CURSOR STABILITY (стабильный курсор) обеспечивает невозможность другим пользователям изменить прочитанную Вами запись до тех пор, пока Вы не прочтете другую запись. То есть, прочитанный ряд блокируется. Обычно последовательный просмотр записей реализуется с помощью механизма, называющегося "курсор", отсюда и название данного уровня изоляции.

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

Самый высший уровень изоляции - это REPETABLE READ (повторяемое чтение). Если программа использует данный уровень изоляции, то SQL-сервер заблокирует все записи, прочитанные данной программой в пределах транзакции. То есть уровень изоляции REPEATABLE READ означает запрещение изменения другими процессами всех записей, задействованных Вами в течении транзакции. Это означает, что Вы можете в течение одной транзакции многократно читать одни и те же записи и они гарантированно не могут быть изменены другими пользователями. Этот уровень изоляции является самым сильным и принимается по умолчанию для баз данных с транзакциями в режиме ANSI.

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

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

SET ISOLATION TO <уровень изоляции>

Например:

SET ISOLATION TO REPEATABLE READ SET ISOLATION TO DIRTY READ.

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

SET ISOLATION TO DIRTY READ SELECT ... INTO ... .......................... SET ISOLATION TO CURSOR STABILITY FOREACH my_cursor INTO var, var .......................... END FOREACH.

5.10.5. Управление ожиданием снятия блокировок.

В реальных программах надо как-то уметь обрабатывать ситуации, когда пользовательская программа пытается обратитьться к заблокированным ресурсам (таблице, записи). Помимо стандартного управления ошибками (оператор WHENEVER, мы его рассмотрели в одной из предыдущих статей), существует специальный оператор установки режима ожидания SET LOCK MODE. Его синтакис:

SET LOCK MODE TO WAIT <число секунд>

SET LOCK MODE TO NOT WAIT.

Если Вы установили режим ожидание в "NOT WAIT" ("не ждать"), то если Ваша программа пытается обратиться к заблокированным ресурсам, то тут же получает сообщение об ошибке. Этот режим устанавливается по умолчанию.

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

SET LOCK MODE TO WAIT 5.

5.10.6. Тупиковые ситуации.

Теоретически, особенно при использовании режима ожидания до бесконечности, возможно возникновение тупиковой ситуации, клинча (английский термин deadlock - смертельные объятия). Это означает, что две или более программ заблокировали некоторые данные, но для продолжения работы им нужны данные, которые заблокированы другими программами. То есть программы ждут друг друга. Рассмотрим пример: пользователи А и В исполняют некоторые программы (соответсвенно программы А и В), работающие с одной и той же базой данных. Обе программы находятся в режиме бесконечного ожидания снятия блокировок (был выполнен оператор SET LOCK MODE TO WAIT). Программа А выполнила оператор.

LOCK TABLE table_a IN EXCLUSIVE MODE.

Заблокировав, таким образом, таблицу table_a. Затем программа В выполняет оператор.

LOCK TABLE table_b IN EXCLUSIVE MODE.

И блокирует таблицу. Для дальнейшей работы программе А надо заблокировать таблицу table_b и она выполняет оператор.

LOCK TABLE table_b IN EXCLUSIVE MODE.

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

LOCK TABLE table_a IN EXCLUSIVE MODE.

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

5.11. Повышение скорости обработки запросов.

Язык SQL - не процедурный язык. Когда мы обсуждали, ЧТО делает тот или иной оператор, то никогда не обсуждалось, КАК это выполняется. Но SQL используется для написания реальных программ, с которыми работают реальные люди. Поэтому во многих случаях требуется обеспечить быстрое исполнение SQL-операторов. В данном параграфе будут рассмотрены способы управления скоростью исполнения тех или иных SQL-запросов.

5.11.1. Индексы.

Предположим, в нашей базе данных есть таблица persons, содержащая сведения о людях (ФИО и где работают:).

CREATE TABLE persons ( person_id SERIAL UNIQUE, company INTEGER, lname CHAR(40), fname CHAR(30), sname CHAR(30), );

Если мы попытаемся определить, какие люди работают в фирме с уникальным номером 105 (то есть у какх записей в таблице persons поле company равно 105), нам надо будет выполнить запрос.

SELECT lname, fname, sname FROM persons WHERE company = 105.

При исполнении этого запроса сервер базы данных должен будет просмотрть всю таблицу persons и для каждой записи из этой таблицы проверить условие "company = 105". Если в таблице persons несколько миллионов записей, то такой запрос может потребовать для своей обработки длительное время. Совсем не обязательно иметь таблицу в несколько миллионов записей, чтобы нагрузить сервер работой на несколько минут. Предположим, в таблице companies одна тысяча записей, а в таблице persons всего десять тысяч записей (в каждой фирме, в среднем, работает десять человек). Таблица compenies имеет следующую структуру:

CREATE TABLE companies ( company_id SERIAL UNIQUE, name CHAR(40), address CHAR(40) );

Если мы будем искать всех людей и их рабочие адреса для фирм под названием "АО Рога и Копыта" и "АОЗТ Сделай Сам", то при исполнении запроса.

SELECT persons.lname, persons.fname, persons.sname, companies.address FROM persons, companies WHERE company.name IN ("АО Рога и Копыта", "АОЗТ Сделай Сам") AND persons.company = company.company_id.

Сервер, в строгом соответствии с правилами обработки запросов, должен будет для каждой записи из таблицы persons просмотреть всю таблицу companies. Итого, для исполнения этого запроса, надо будет просмотреть десять миллионов возможных комбинаций (десять тысяч умножить на одну тысячу).

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

Однако в SQL нельзя предугадать, какие будут запросы к данной таблице, Если мы упорядочим таблицу persons по номерам компаний, скорость поиска по фамилии все равно останется низкой, а упорядочить одну и ту же таблицу по двум полям одновременно невозможно. Но в SQL есть способ повысить скорость исполнения определенных запросов. И этот способ основан на индексах. Например, если бы мы хотели повысить скорость поиска записей в таблице persons по полю company, то следовало бы создать индекс по данному поля в данной таблице:

CREATE INDEX pers_comp_index ON persons(company).

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

CREATE INDEX <имя индекса> ON <имя таблицы> (<имя поля>,<имя поля> ...).

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

CREATE index1 ON persons(lname).

CREATE comp_indx ON items(company, name).

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

Пусть у нас есть таблица persons с полями:

------------T---------T----------T---------¬ ¦ person_id ¦ company ¦ lname ¦ fname ¦ +-----------+---------+----------+---------+ ¦ 1 ¦ 101 ¦ Антонов ¦ Сергей ¦ ¦ 2 ¦ 105 ¦ Шапокляк ¦ Алексей ¦ ¦ 3 ¦ 102 ¦ Антонов ¦ Антон ¦ ¦ 4 ¦ 101 ¦ Бендер ¦ Остап ¦ L-----------+---------+----------+----------

Каждая запись в этой таблице реально где-то размещена. С местом ее размещения может быть однозначно связано какое-то значение. Если для хранения используется файл, как в сервере Informix-SE, то в качестве этого уникального значения может выступать смещение записи от начала файла. Если для хранения используется своя собственная файловая ситема, как, например, в Informix DS, то в качестве внутреннего идентификатора записи может выступать составной ключ (номер диска, номер сектора, смещение от начала сектора). Как выглядит это уникальное для каждой записи значение - абсолютно не важно, это внутреннее дело сервера. Очевидно, что такое значение всегда можно построить. Предположим, что это значение всегда присутствует для любой таблицы и выглядит как псевдополе с именем "rowid" (идентификатор записи). С учетом этого поля записи в данной таблице выглядят следующим образом:

- - - - T-----------T---------T----------T---------¬ ¦ rowid ¦ person_id ¦ company ¦ lname ¦ fname ¦ + - - - +-----------+---------+----------+---------+ ¦ 1003 ¦ 1 ¦ 101 ¦ Антонов ¦ Сергей ¦ ¦ 1023 ¦ 2 ¦ 105 ¦ Шапокляк ¦ Алексей ¦ ¦ 1063 ¦ 3 ¦ 102 ¦ Антонов ¦ Антон ¦ ¦ 1053 ¦ 4 ¦ 101 ¦ Бендер ¦ Остап ¦ L - - - +-----------+---------+----------+----------

При исполнении оператора создания индекса сервер создает набор записей, собственно и составляющих индекс. Каждая запись из индекса состоит из значений той таблицы, по которой построен этот индекс (естественно, хранятся только те поля, которые указаны в данном индексе - эти поля называют проиндексированными) и ссылки на физическое расположение записи в таблице (rowid этой записи). Записи из индекса упорядочены по индексируемым значениям. Например, для индекса pers_comp_indx, построенного по полю company таблицы persons набор составляющих его записей будет выглядеть следующим образом:

-----------T---------¬ ¦ значение ¦ rowid ¦ +----------+---------+ ¦ 101 ¦ 1003 ¦ ¦ 101 ¦ 1053 ¦ ¦ 102 ¦ 1063 ¦ ¦ 105 ¦ 1023 ¦ L----------+----------

Тогда при исполнении запроса.

SELECT .... FROM persons WHERE company = 105.

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

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

SELECT company FROM persons WHERE lname = "Бендер".

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

CRATE INDEX second_index ON persons(lname).

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

CREATE INDEX pers_names ON persons(lname, fname).

Заметим, что порядок, в котором указаны поля для составного индекса, существенен. Так, определенный нами индекс по комбинации фамилия-имя будет отличаться от индекса по комбинации имя-фамилия:

CREATE INDEX pers_names2 ON persons(fname, sname).

Кстати, если создан составной индекс по полям (lname, sname), то отпадает необходимость в индексе по полю lname (но не в индексе по полю sname). То есть, если создан индекс по некоторой последовательности полей (a1, a2, ... aN), то он функционально покрывает индекс по последовательности полей (a1, a2, ... aK), если K < N.

У оператора создания индекса помимо базового варианта есть модификации. Более полный синтаксис оператора создания индекса выглядит так:

CREATE [UNIQUE] [CLUSTER] INDEX <имя индекса> ON <имя таблицы> (<имя поля>, <имя поля> ...).

Ключевое слово UNIQUE (вместо него можно использовать слово DISTINCT) означает, что в таблице не допускаются одинаковые наборы значений по совокупности полей, указанным в индексе. Другими словами, это способ следить за уникальностью указанного набора полей. Поэтому такой индекс называется уникальным. Использование уникального индекса функционально идентично заданию уникального ключа в таблице за тем исключением, что для добавления уникального индекса надо иметь привилегии RESOURCE, а для указания уникального ключа в структуре таблицы - быть владельцем таблицы, иметь права администратора или иметь привилегию на модификацию таблицы. Пример:

CREATE UNIQUE INDEX my_index ON persons (person_id, company).

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

CREATE CLUSTER INDEX my_2nd_index ON persons (lname, fname).

Использование индекса значительно повышает скорость поиска записей при выполнения операторов с логическим условием (то есть для операторов SELECT, DELETE или UPDATE с условием WHERE). При этом, естественно, нужно, чтобы сервер базы данных мог использовать существующие индексы для поиска записей, удовлетворяющих условию в разделе WHERE. С другой стороны, индексы, за исключением кластерных, требуют дополнительных затрат памяти. Кроме того, при выполнении операций, изменяющих содержимое базы данных (INSERT, UPDATE, DELETE), если изменения затрагивают проиндексированные поля, требуется дополнительное время на перестройку индекса. Но так как во многих задачах бОльшая часть обращений к базе данных связана с поиском информации, индексы позволяют значительно увеличить общую производительность информационной системы.

Использование индексов в SQL принципиально отличается от того, как они применяются в индексно-последовательных СУБД типа dBase, Clipper или FoxPro. В случае SQL-сервера, поддержание целостности индекса и его использование - это внутренняя задача самого сервера. У пользователя или программиста, работающего с SQL-сервером, есть только возможность создать (оператор CREATE INDEX) и удалить (оператор DROP INDEX) индекс, а также изменить его структуру (с помощью оператора ALTER INDEX, который здесь не рассматривается). Оператор удаления индекса имеет следующий синтаксис:

DROP INDEX <имя индекса>

Естественно, для удаления индекса надо быть или его владельцем, или иметь права администратора.

5.11.2. Буферизация журнала транзакций.

Обычно, при завершении транзакции (оператор COMMIT WORK) происходит принудительный сброс обновленной базы данных на внешний носитель (жесткий диск). Причем информация о проведенной транзакции дополнительно записывается в специальный файл - журнал транзакций. Если этот журнал и обновленное содержимое базы данных не сбрасывать на диск по окончании транзакции, а буферизировать в памяти, то в случае падения напряжения питания или сбоя аппаратуры информация о нескольких последних завершенных транзакциях может быть потеряна. Целостность базы данных при этом гарантированно сохранится, однако ее содержимое будет соответсвовать или последней завершенной транзакции, или предпоследней, или пред…предпоследней. Для банковских задач буферизация журнала транзакций, наверное, неприемлима, но для целого ряда других задакч, например регистрации каких-либо параметров, подлежащих статистической обработке. - вполне допустима.

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

CREATE DATABASE <имя базы данных> WITH BUFFERED LOG.

Буферизация журнала транзакций позволяет в несколько раз повысить скорость исполнения операторов INSERT, UPDATE и DELETE, но при этом практически не влияет на скорость работы оператора SELECT.

5.11.3. Блокировка на уровне записей и страниц.

При рассмотрении уровней изоляции предполагалось, что блокировки ставятся на уровне записей (то есть блокируется отдельная запись). На самом деле, сервера Informix Dynamic Server позволяют выбирать уровень блокировки между блокировкой на уровне записи и блокировкой на уровне страницы. Практически во всех SQLсерверах (в том числе, и Informix Dynamic Server) память под таблицы выделяется порциями фиксированного объема - страницами или группами страниц. Обычно размер страницы составляет 2 или 4 килобайта. В целях повышения производительности можно блокировать записи не по одной, а целыми страницами.

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

CREATE TABLE … LOCK MODE {PAGE | ROW}.

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

CREATE TABLE companies ( company_id SERIAL UNIQUE, name CHAR(40), address CHAR(40) ) LOCK MODE ROW.

CREATE TABLE persons ( person_id SERIAL UNIQUE, company INTEGER, lname CHAR(40), fname CHAR(30), sname CHAR(20), position CHAR(20) ) LOCK MODE PAGE.

5.11.4. Эффективное построение запросов.

Производительность сервера базы данных при выполнении доступа к информации зависит не только от наличия или отсутствия индексов, буферизации журнала транзакций и т.д., но и от того, какие запросы исполняются. Не секрет, что одно и тоже действие (например, построение списка сотрудников какой-либо фирмы) можно запрограммировать поразному. Суммарная скорость исполнения данного действия зависит от того, какими операторами на SQL оно представлено. Рассмотрим пример. Допустим, у нас есть таблицы persons и companies (их структура привевдена выше, в пункте 5.11.3). Требуется построить поименный список сотрудников, работающих в фирме “АО Рога и Копыта”. Первый вариант реализации данного действия выглядит так:

SELECT lname, fname FROM persons, companies WHERE persons.company = companies.company_id AND companies.name = “АО Рога и Копыта”.

При исполнении данного запроса при отсутствии индексов сервер базы данных должен будет перебрать все возможные комбинации записей из таблиц persons и companies, и для каждой комбинации проверить, выполняется ли условие из раздела WHERE. Если в таблице persons находится M записей, а в таблице companies - N записей, то всего будет проверено M*N комбинаций.

Другой запрос, функцмионально реализующий тоже самое действие, а именно, формирование списка сотрудников АО Рога и Копыта выглядит следующим образом:

SELECT lname, fname FROM persons WHERE persons.company IN (SELECT company_id FROM companies WHERE name = “АО Рога и Копыта”).

При исполнении этого запроса, сервер вначале просмотрит таблицу companies и найдет одно требуемое значение, затем он просмотрит таблицу persons и сравнит поле company с найденным значением. В итоге, он просмотрит M+N записей. Если значения M и N достаточно велики (порядка сотен или более), то второй запрос будет исполняться много быстрее первого. Естественно, это очень грубая оценка без учета наличия индексов, возможностей сервера по оптимальному исполнению запросов и т.д., но выигрыш в полмиллиона раз раз для таблиц с миллионом записей каждая уже впечатляет.

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

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

SELECT persons.lname, persons.fname, persons.sname, companies.address FROM persons, companies WHERE companies.address MATCHES "*Тверь*" AND companies.companies_id = persons.company AND persons.position = “директор”.

Привести данный запрос к виду.

SELECT . . . FROM persons WHERE . . .

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

CREATE TEMP TABLE local_companies ( company_id INTEGER, name CHAR(40), address CHAR(40) )

{наполнение временной таблицы списком фирм, распорложенных в Твери} INSERT INTO local_companies(company_id, name, address) SELECT company_id, name, address FROM companies WHERE address MATCHES "*Тверь*".

{получение требуемых данных} SELECT persons.lname, persons.fname, persons.sname, local_companies.address, local_companies.name FROM persons, local_companies WHERE local_companies.companies_id = persons.company AND persons.position = “директор”.

DROP TABLE local_companies.

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

5.11.5. Сортировка и поиск по коротким полям. Классификаторы.

Сортировка (т.е. использование раздела ORDER BY в операторе SELECT) требует очень больших времЕнных затрат. Особенно это касается больших таблиц. Сортировка, выполняемая по проиндексированным полям, происходит существенно быстрее, чем по непроиндексированным. Если же сортировка все же проводится по полям, для которых нет индекса, то лучше для сортировки использовать короткие поля (типа INTEGER, SMALLINT), нежели длинные (например, символьные). В условии WHERE операторов также предпочтительнее использовать короткие поля. Например, оператор.

SELECT address FROM companies WHERE name=”АО Рога и Копыта”.

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

SELECT address FROM companies WHERE company_id=105.

Это правило можно распространить и на использование классификаторов. Классификатор - это специально введенная таблица, в которой хранится набор возможных значений какого-либо атрибута. Предположим, для каждой фирмы требуется хранить ее тип (госпредприятие, ООО, АОЗТ и т.д.). Набор типов предприятия ограничен. В принципе, в таблице companies нетрудно предусмотреть на этот случай специальное символьное поле:

CREATE TABLE companies( . . . . . type CHAR(20) ).

Сортировка и поиск по полю CHAR(20) nбудет происходить значительно медленне, чем по полю INTEGER. К тому же, если записей в таблице companies много, то использование поля INTEGER как ссылки на классификатор с типами предприятий вместо непосредственного задания этого значения в таблице даст экономию памяти. Поэтому более грамотным решением, на наш взгляд, является создание специального классификатора (таблицы types):

CREATE TABLE types ( type_id SERIAL UNIQUE, name CHAR(40) ).

И введение в таблицу companies ссылки (внешнего ключа) на этот классификатор:

CREATE TABLE companies( . . . . . type INTEGER ).

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

SELECT name, address FROM companies WHERE type = (SELECT type_id FROM types WHERE name = “ООО”).

5.12. Объектное расширение SQL в Informix DS/Universal Data Option.

5.12.1. Зачем нужна поддержка объектов в серверах БД?

Выше была рассмотрена классическая, традиционная реляционная модель данных и ее конкретная реализация - язык SQL. Однако не все задачи могут быть одинаково хорошо и изящно решены с помощью реляционных баз данных вообще и языка SQL в частности. Рассмотрим те ограничения и неудобства, которые заложены в реляционных СУБД и как использование объектно-ориентированной технологии может помочь в преодолении возникающих трудностей.

Неравноправие атрибутов.

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

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

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

CREATE TABLE persons ( tabel_num INTEGER, {табельный номер} last_name CHAR(40), {фамилия} first_name CHAR(40), {имя} second_name CHAR(40), {отчество} department INTEGER, {отдел} dolgnost CHAR(20), {должность} emp_from DATE, {работает с…} . . . . . . )

При такой структуре данной таблицы все атрибуты “свалены” в кучу. Более правильно было бы сгруппировать фамилию, имя и отчество в новый составной тип под названием “ФИО”, а отдел и должность - в тип “позиция”:

CREATE ROW TYPE fio_t ( last_name CHAR(40), {фамилия} first_name CHAR(40), {имя} second_name CHAR(40) {отчество} )

CREATE ROW TYPE position_t ( department INTEGER, {отдел} dolgnost CHAR(20) {должность} )

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

CREATE TABLE persons ( tabel_num INTEGER, {табельный номер} fio fio_t, {ФИО} position position_t, {позиция} emp_from DATE, {работает с…} . . . . . . )

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

Ограниченный набор базовых типов.

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

Нельзя сказать, что современные реляционные СУБД такой возможности не предоставляют совсем. Например, такие типы данных в Informix Dynamic Server, как BYTE и TEXT предназначены для хранения больших (до 2 ГБт) двоичных и текстовых объектов соответственно. Сервер обеспечивает только хранение таких объектов, он не может сам обрабатывать данные этих типов. Вся обработка должна проводиться на программеклиенте. То есть для того, чтобы, например, просмотреть все имеющиеся в базе данных отпечатки пальцев и отобрать те, которые похожи на заданный образец, программаклиент должна последовательно просмотреть все имеющиеся отпечатки. Проведение такого просмотра самим сервером, а, тем более, наличие индекса по отпечаткам, значительно бы ускорило обработку такого запроса.

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

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

Рассмотрим простейший пример. Предположим, нам надо хранить информацию об адресах и делать выборку по улице. В Российских городах для названия улиц может использоваться дополнительная нумерация (1-я Парковая, 9-я Парковая) или прилагательное “Большой” или “Малый” (Малая Бронная). Соответственно, существует несколько способов записи таких названий. Следующие три названия обозначают одну и туже улицу:

М.Бронная Бронная, М. Малая Бронная.

Очевидно, что если мы будем использовать для хранения названия улиц обычные строковые типы, то придется следить за тем, чтобы в базе данных названия улиц хранились в едином, унифицированном формате. А при запросе на поиск по названию улицы потребуется преобразовывать введенное пользователем название к этому единому формату. Было бы удобнее, если бы можно было определить новый тип данных “Название улицы”, который бы делал это автоматически и, следовательно, минимизировал возможные ошибки. Для данного типа нужно было бы переопределить операцию сравнения, чтобы при сравнении двух значений учитывалось разное написание улиц. Кроме того, для данного типа потребуется переопределить операции сравнения, чтобы сортировка значений данного типа проводилась с учетом разных написаний:

SELECT streets FROM table1 ORDER by streets.

. . . . Бауманская Б.Бронная М.Бронная Буденного . . . .

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

Сложные типы данных.

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

Таблица “Дети”.

ID. Фамилия. Имя. Отчество. Родитель. 7. Иванов. Игорь. Иванович. 106. 8. Иванова. Анна. Ивановна. 106. 14. Петров. Сергей. Петрович. 107. . . . . . . . . . . . . . . . ..

Таблица “Сотрудники”:

ID. Фамилия. Имя. Отчество. . . . 106. Иванов. Иван. Иванович. . . . . 107. Петров. Петр. Петрович. . . . . 108. Сидоров. Сидор. Сидорович. . . . . . . . . . . . . . . . . . . . ..

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

Во-первых, требуется предпринять определенные меры по поддержанию целостности базы данных, А именно, при удалении информации о родителе необходимо удалить и информацию о детях, нужно следить за тем, чтобы не было “висящих” ссылок и т.д.

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

Если бы в таблице можно было описать поле типа множество, а каждый элемент множества представлял бы запись об одном ребенке, то все перечисленные выше проблемы решались бы автоматически:

CREATE TABLE persons ( tabel_num INTEGER, {табельный номер} last_name CHAR(40), {фамилия} first_name CHAR(40), {имя} second_name CHAR(40), {отчество} children SET OF ( {дети - множество записей вида} last_name CHAR(40), {фамилия ребенка} first_name CHAR(40), {имя ребенка} second_name CHAR(40), {отчество} was_born DATE {дата рождения} ) . . . . . )

Мы рассмотрели один конкретный пример, и убедились, что структура данных “множество” в некоторых задачах может быть очень полезна. Можно привести примеры, когда было бы полезно, если бы в качестве атрибутов в таблице можно было использовать сложные, составные типы данных со структурами “массив”, “список” и т.д. Реляционные СУБД в своей классической теории не позволяют этого сделать.

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

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

Существующие реляционные СУБД весьма эффективно реализуют способы представлениея, хранения, доступа и поиска традиционных реляционных данных - чисел, текстовых строк, дат и т.д. Для ускорения поиска обычно используются методы индексирования на основе B-деревьев или B+-деревьев. Когда же мы пытаемся выполнить запрос на поиск текстовой строки, содержащей внутри себя некоторую заданную подстроку, например:

SELECT name, address FROM companies WHERE name MATCHES “*Рога*”.

Или пытаемся выбрать информацию по продажам в феврале в течении нескольких лет:

SELECT price FROM contracts WHERE MONTH(was_signed)=2.

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

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

Иерархия данных.

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

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

Если мы попытаемся объединить требования отдела кадров и бухгалтерии в единой базе данных, то в стандартных реляционных СУБД мы будем стоять перед выбором: или иметь единую таблицу со всеми возможными атрибутами, или иметь три разных таблицы с разным набором атрибутов.

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

Фамилия. Имя. Отчество. Должность. Оклад. Премия (%) Комиссия (%) Сумма сделок. Иванов. Иван. Иванович. Продавец. 1000. 0.5. 500000. Петров. Петр. Петрович. Продавец. 1000. 0.6. 400000. Сидоров. Сидор. Сидорович. Инженер. 1500. 20. Матвеев. Матвей. Матвеевич. Инженер. 1600. 20. Степанов. Степан. Степанович. Админист. 1700. Кузьмин. Кузьма. Кузьмич. Админист. 1800.

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

Другой подход предполагает наличие трех разных таблиц - своя таблица для каждой категории сотрудников:

Таблица “Продавцы”.

Фамилия. Имя. Отчество. Должность. Оклад. Комиссия (%) Сумма сделок. Иванов. Иван. Иванович. Продавец. 1000. 0.5. 500000. Петров. Петр. Петрович. Продавец. 1000. 0.6. 400000.

Таблица “Инженеры”.

Фамилия. Имя. Отчество. Должность. Оклад. Премия (%) Сидоров. Сидор. Сидорович. Инженер. 1500. 20. Матвеев. Матвей. Матвеевич. Инженер. 1600. 20.

Таблица “Администраторы”.

Фамилия. Имя. Отчество. Должность. Оклад. Степанов. Степан. Степанович. Админист. 1700. Кузьмин. Кузьма. Кузьмич. Админист. 1800.

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

5.12.3. Внедрение объектно-ориентированной технологии.

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

Концепция объектно-ориентированного подхода.

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

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

Следующим шагом была разработка Б.Страуструпом языка С++, который предназначался для поддержки технологии объектно-ориентированного программирования. Для осуществления такой поддержки в С++ был реализован механизм абстрактных типов данных (с такими свойствами, как полиморфизм и инкапсуляция) и механизм наследования типов. Такой симбиоз получился настолько удачным, что сейчас многие просто отождествляют объектно-ориентированное программирование с поддержкой инкапсуляции, полиморфизма, наследования.

Объектно-ориентированные СУБД.

Как утверждается в [Манифест 95], СУБД только тогда может считаться объектно-ориентированной, когда она поддерживает следующие “восемь свойств: сложные объекты, идентифицируемость объектов, инкапсуляцию, типы или классы, наследование, перекрытие методов совместно с поздним связыванием, расширяемость и вычислительную полноту”.

Но кроме того, что бы поддерживать в той или иной степени объектно-ориентированную технологию, такая система должна оставаться собственно базой данной и решать связанные с этим вопросы. А именно, обеспечивать операции доступа и преобразования данных, одновременный доступ к данным нескольких пользователей, разграничение доступа и защиту данных от сбоев. В частности, ООСУБД должна предоставлять язык описания данных (ЯОД) и язык манипулирования данными (ЯМД). Язык манипулирования данными должен или быть встраиваемым в какой-либо язык программирования, или быть реализован в виде API.

В модели ODMG93 [Калиниченко96] были описаны и ЯОД, и ЯМД. К сожалению, пока ни одна из фирм не реализовала полностью этот стандарт. Именно отсутствие реально работающего стандарта является сдерживающим фактором в распространении объектно-ориентированных СУБД.

Объектно-реляционные СУБД.

Реляционные СУБД, в отличии от “чистых” объектно-ориентированных СУБД, имеют реально работающие стандарты - стандарты на язык запросов SQL. Кроме того, существует огромная база заказчиков, которые пока не готовы отходить от реляционной технологии. И фирмы-производители реляционных СУБД пошли по пути внедрения объектной технологии в отработанную и популярную технологию реляционных СУБД. В частности, сейчас готовится к выходу стандарт SQL-3, в котором уже заложена поддержка объектно-ориентированной концепции.

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

Технология абстрактных типов данных предполагает:

· инкапсуляцию (сокрытие деталей реализации внутри типа);

· полиморфизм (применимость одной операции к разным типам и разный способ вычисления в зависимости от типа);

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

· расширяемость (возможность определить новый тип);

· наследуемость типов (возможность определить новый тип на основе существующего);

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

Итак, объектно-реляционный подход представляет собой расширение классический реляционных СУБД, базирующихся на языке SQL. Язык SQL и, соответственно, реляционная модель, расширяются возможностью вводить абстрактные типы данных и организовывать иерархию типов и данных. Следовательно, обеспечиваются все требования, ассоциируемые с объектно-ориентированной технологией (см. Объектно-ориентированные СУБД), но при этом обеспечивается совместимость со старыми приложениями, инструментами и технологиями.

5.12.4. Реализация объектного подхода в Informix.

Informix DS/Universal Data Option - объектно-реляционная СУБД.

Informix DS/Universal Data Option представляет собой реализацию объектно-ориентированной технологии на основе встраивания механизма абстрактных типов данных и механизма наследования в популярный и надежный сервер реляционных баз данных Informix Dynamic Server.

Встраиваемая объектно-ориентированная технология была известна на практике по объектно-реляционной СУБД Illustra (позднее, приобретеннной фирмой Informix и называвшейся Informix Illustra) [Stonebraker 96].

Определение новых базовых типов.

Informix Universal Data Option позволяет вводить новые базовые типы данных. При этом можно использовать как встроенные в Informix Dynamic Server методы доступа и хранения, так и определять новые. Рассмотрим способ создания новых базовых типов с использованием встроенных механизмов хранения. Создание базовых типов вместе с алгоритмами хранения и доступа будет рассмотрено ниже.

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

Если бы речь шла только про размеры, то алгоритм перевода размеров в единую систему измерений четко известен и в базе данных можно было бы хранить только размеры в метрах и сантиметрах. С ценами сложнее - курс обмена зависит от даты конвертации. И если мы будем искать деталь с минимальной ценой, то надо учитывать текущий курс. ОРСУБД Informix DS/Universal Data Option позволяет построить новый базовый тип данных, основанный на существующем, но обеспечивающий автоматическое преобразование к нужному значению. Сами типы вводятся следующими операторами:

CREATE DISTINCT TYPE usd AS MONEY; CREATE DISTINCT TYPE dm AS MONEY;

Далее надо ввести функции преобразования значений из долларов в марки и наоборот, а также описать возможность такого преобразования:

CREATE FUNCTION usd_to_dm(v usd) RETURNS dm; . . . CREATE FUNCTION dm_to_usd(v dm) RETURNS usd; . . .

CREATE IMPLICIT CAST (usd AS dm WITH usd_to_dm); CREATE IMPLICIT CAST (dm AS usd WITH dm_to_usd);

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

Другой причиной, по которой может возникнуть необходимость во введении нового базового типа данных - это принципиальное отсутствие такого типа. Например, для экспериментальных данных, которые будут храниться в нашей базе данных, недостаточна точность, обеспечиваемая стандартным типом FLOAT. Informix DS/Universal Data Option позволяет ввести новый тип данных FLOAT16, будет использовать для хранения своих значений 16 байт и будет соответствовать нашим требованиям по числу значащих цифр в мантиссе и диапазону порядка:

CREATE OPAQUE TYPE float16 (INTERNALLENGTH=16, ALIGHNMENT=4);

Одного такого оператора недостаточно. Необходимо также задать функции преобразования значений данного вида в текстовый вид (тип данных LVARCHAR) и обратно (это нужно для ввода/вывода значений, экспорта/импорта базы и т.д.). Кроме того, нужно задать дополнительные функции преобразования и сравнения, которые будут использоваться при построении стандартных индексов и при сравнении со значениями других типов:

{обязательные функции преобразования в строку и обратно} CREATE FUNCTION float16_out(float16) RETURNING LVARCHAR . . . .; CREATE FUNCTION float16_in(lvarchar) RETURNING float16 . . . .;

{реализация стандартных операторов ’+’,’-’,’*’,’/’,’>’,’<’ и т.д.} CREATE FUNCTION Plus(float16, float16) RETURNING float16 . . . .; CREATE FUNCTION Plus(float16, float) RETURNING float16 . . . .; . . . . . . .

После того, как все нужные функции определены, можно использовать тип float16 наравне с другими базовыми типами (FLOAT, SMALLFLOAT, INTEGER и т.д.). При этом для хранения, поиска и индексирования используются стандартные механизмы Informix Dynamic Server.

Составные типы данных.

Informix DS/Universal Data Option позволяет определять новые составные типы данных. К доступным структурам, которые можно использовать для построения составных типов, относятся:

· запись

· множество

· список

Запись представляет собой возможность ввести именованные поля. Структура запись структуре record в языке Паскаль и struct в языке C/C++. Тип данных со структурой запись вводится оператором:

CREATE ROW TYPE <имя типа> ( <имя поля> <тип поля>, . . . )

Например:

CREATE ROW TYPE fio_t ( last_name CHAR(40), {фамилия} first_name CHAR(40), {имя} second_name CHAR(40) {отчество} )

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

CREATE TABLE persons ( tabel_num INTEGER, {табельный номер} fio fio_t, {ФИО} . . . . . . )

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

SELECT tabel_num, fio.last_name, fio.first_name FROM persons WHERE tabel_num = 157.

Множество представляет собой неупорядоченное множество значений. В Informix Universal Data Option используется два варианта реализации структуры множества - set и multiset. Первая структура (будем называть ее просто множеством) не допускает повторений элементов внутри себя. Вторая структура (будем называть ее мультимножеством) допускает повторение элементов. Приведем пример, как можно ввести в таблицу persons в качестве атрибута тип данных “дети” со структурой SET:

CREATE TYPE children_t SET ( fio fio_t, wasborn DATE )

CREATE TABLE persons ( tabel_num INTEGER, {табельный номер} fio fio_t, {ФИО} children children_t, {дети} . . . . . )

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

CREATE TYPE lab_byog_t LIST ( name CHAR(20), work_from DATETIME YEAR TO DAY, position CHAR(10) )

CREATE TABLE persons ( tabel_num INTEGER, {табельный номер} fio fio_t, {ФИО} children children_t, {дети} lab_byog lab_byog_t, {трудовая биография} . . . . . )

Наследование типов и данных.

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

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

CREATE ROW TYPE employee_t ( tabel_num INTEGER, {табельный номер} last_name CHAR(40), {фамилия} first_name CHAR(40), {имя} second_name CHAR(40), {отчество} dolgnost CHAR(20) {должность} base_salary MONEY {оклад} )

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

CREATE ROW TYPE engineer_t ( bonus DECIMAL (5,2) {премия в процентах} ) UNDER TYPE employee_t.

CREATE ROW TYPE sale_t ( comission DECIMAL (5,2), {размер комиссионных в %} revenue MONEY {сумма заключенных котрактов} ) UNDER TYPE employee_t.

Таким образом, имеется 3 типа данных, два из которых (sales_t и engineer_t) являются наследниками одного (employee_t). Если мы используем эти типы для создания таблиц, мы можем создать иерархию данных:

CREATE TABLE employees OF TYPE employee_t; CREATE TABLE engineers OF TYPE engineer_t UNDER TABLE employees; CREATE TABLE sales OF TYPE sale_t UNDER TABLE employees;

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

Таблица employees.

Фамилия. Имя. Отчество. Должность. Оклад. Степанов. Степан. Степанович. Админист. 1700. Кузьмин. Кузьма. Кузьмич. Админист. 1800. Таблица Sales. Комиссия (%) Сумма сделок. Иванов. Иван. Иванович. Продавец. 1000. 0.5. 500000. Петров. Петр. Петрович. Продавец. 1000. 0.6. 400000. Премия (%) Таблица engineers. Сидоров. Сидор. Сидорович. Инженер. 1500. 20. Матвеев. Матвей. Матвеевич. Инженер. 1600. 20.

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

Выборка данных по таблице employees даст возможность увидеть всех сотрудников:

SELECT * FROM employees.

Фамилия. Имя. Отчество. Должность. Оклад. Степанов. Степан. Степанович. Админист. 1700. Кузьмин. Кузьма. Кузьмич. Админист. 1800. Иванов. Иван. Иванович. Продавец. 1000. Петров. Петр. Петрович. Продавец. 1000. Сидоров. Сидор. Сидорович. Инженер. 1500. Матвеев. Матвей. Матвеевич. Инженер. 1600.

Выборка данных по таблице engineers даст возможность увидеть всех инженеров, но только их, причем будут доступны и те поля, которые принадлежат типу engineer_t, но не принадлежат типу-родителю employee_t:

SELECT * FROM engineers.

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

SELECT * FROM ONLY(employees).

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

CREATE FUNCTION zarplata(p employee_t) RETURNING MONEY; RETURN (p.base_salary);

CREATE FUNCTION zarplata(p engineer_t) RETURNING MONEY; RETURN (p.base_salary + p.base_salary*p.bonus/100);

CREATE FUNCTION zarplata(p sale_t) RETURNING MONEY; RETURN (p.base_salary + p.comission*p.revenue/100);

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

SELECT zarplata(e) FROM employees e;

Специальные методы хранения, поиска и индексации.

Informix DS/Universal Data Option позволяет вводить новые базовые типы данных одновременно с введением специальных алгоритмов хранения, доступа и индексирования, отличных от стандартных, реализованных в сервере.

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

{описание нового типа} CREATE OPAQUE TYPE picture ( INTERNALLENGTH=VARIABLE, . . . . . )

{реализация алгоритма записи на диск} CREATE FUNCTION assign(pic picture) RETURNS POINTER EXTERNAL NAME ‘/usr/bin/my_assign()’ LANGUAGE C NOT VARIANT;

Если мы хотим для нового типа ввести специальные алгоритмы индексации и поиска, то надо описать следующие функции:

· my_am_scancost_index - оценка стоимости использования индекса

· my_am_open_index - открыть внешний файл с индексом

· my_am_bedinscan_index - начать просмотр по индексу

· my_am_getnext_index - взять следующий элемент индекса

· my_am_endscan_index - закончить просмотр индекса

· my_am_close_index - закрыть внешний файл с индексом

Далее, надо указать, что вводится новый способ индексирования (pic_tree) и разработанные функции будут использоваться для индексирования созданного типа данных:

CREATE ACCESS_METHOD pic_tree( am_scancost_index = my_am_scancost_index, am_open_index = my_am_open_index , . . . . . )

Далее, использовать новый индекс можно в команде:

CREATE TABLE photos( photo picture, . . . . . ) CREATE INDEX pic1 ON photos(photo) USING pic_tree;

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

5.12.5. Итак…

Informix DS/Universal Data Option обеспечивает объектно-ориентированную технологию технологию за счет реализации механизмов инкапсуляции, полиморфизма и наследования в среду традиционной реляционной СУБД. Можно спорить о достоинствах или недостатках такого подхода, но реальностью является то, что такая технология нужна, и она реально существует.

Грачев А.Ю. Введение в СУБД Informix.

SSL – безопасные сокеты.

SSL – безопасные сокеты

18. SSL – безопасные сокеты.

SSL – это сокращение от Secure Socket Layer и является проверенным методом шифрования данных передаваемых через Интернет. SSL обычно используется для HTTP (Web) трафика и называется защищенный (secured) HTTPS. Конечно, SSL не ограничен HTTP и может быть использован с любым TCP/IP протоколом.

Для использования SSL в Indy, вы во-первых должны установить поддержку SSL. Indy реализует поддержку SSL в открытом для расширения стиле, но единственная поддерживаемая сейчас реализация библиотеки SSL - это OpenSSL. Библиотека OpenSSL доступна, как набор DLL и доступна для загрузки отдельно от дистрибутива Indy.

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

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

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

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

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

18.1. Безопасные протоколы HTTP и HTTPS.

Реализация протокола HTTPS в Indy очень проста. Просто укажите безопасный URL вместо стандартного URL и Indy клиент HTTP (TIdHTTP) все остальное сделает автоматически. Чтобы сделать URL безопасным, просто измените http:// на https://.

Примечание: чтобы HTTPS сессия была установлена, web сервер, который отвечает должен поддерживать SSL и иметь установленный сертификат шифрования. Также HTTP клиенты Indy не проверяют сертификат сервера – это ваша обязанность.

18.2. Другие клиенты.

SSL может легко реализована в любом TCP клиенте Indy с помощью использования SSL IOHandler. Обычно шифрование должно быть реализовано с помощью Intercept вместо IOHandler. SSL реализация в Indy использует IOHandler вместо Intercept, поскольку SSL библиотека выполняют весь обмен самостоятельно. Данные возвращаются в расшифрованной форме напрямую из SSL библиотеки.

Чтобы сделать Indy TCP клиента с использованием SSL просто добавьте TIdSSLIOHandlerSocket на вашу форму с закладки Indy Misc. затем установите свойство IOHandler вашего TCP клиента в TIdSSLIOHandlerSocket. Это все, что требуется для базовой поддержки SSL. Класс TIdSSLIOHandlerSocket имеет дополнительные свойства для указания сертификатов клиентской стороны и другие расширенные SSL параметры.

18.3. Сервер SSL.

Реализация SSL сервера немного более сложная, чем реализация SSL клиента. С клиентами, все что требуется это сделать хук TIdTCPClient или его наследникам к экземпляру TIdSSLIOHandlerSocket. Это происходит потому что, поскольку сервер выполняет больше работы для поддержки SSL.

Для реализации SSL сервера используется TIdServerIOHandlerSSL. TIdTCPServer's имеет свойства для установки хука на TIdServerIOHandlerSSL. Но в отличие от TIdSSLIOHandlerSocket (Client), класс TIdServerIOHandlerSSL требует несколько дополнительных шагов. Более конкретно - должен быть установлены сертификаты. Данные сертификаты должны быть представлены как файлы на диске и указаны в CertFile, KeyFile и RootCertFile, в соответствующих свойствах SSLOptions.

Сертификаты обычно получают из уполномоченных источников. Вы можете иметь свой собственный сертификат и своего собственно источника, но ни один из браузеров не будет доверять вашим сертификатам и браузер будет выдавать диалог с предупреждением при соединении с вашим сервером. Если вы желаете распространять через Интернет, то вы должны получить сертификат из корневого хранилища, которому стандартный браузер будет доверять. Единственный сертификат, которому доверяют все браузеры – это сертификат от Verisign. Можно также использовать сертификат от Thawte, но не все браузеры доверяют ему по умолчанию. Примечание от переводчика: самое смешное, что Thawte принадлежит Verisign.

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

Примечание: это относится только к HTTP серверам, но SSL не ограничен использованием только в HTTP. Вы можете реализовать SSL и получить полный контроль над правилами получения и принятия сертификатов.

18.4. Преобразование сертификатов в формат PEM.

Существует шанс, что вы получите ваши сертификаты формате отличном от .pem. Если это так, то вы должны преобразовать их с помощью Indy.

Данная процедура предполагает, что вы уже получили ключ и сертификатную пару от поставщика (Certificate Authority), например от Verisign или Thawte и уже установили их в персональное хранилище сертификатов (Personal Certificates Store) Microsoft Internet Explorer.

18.4.1. Экспортирование сертификата.

Выберите сертификат и экспортируйте его в .pfx файл (Personal Exchange Format). Дополнительно вы можете его защитить с помощью пароля.

18.4.2. Преобразование файла .pfx в .pem.

Как часть загрузки дистрибутива SSL, в него включена программа openssl.exe. данная программ преобразует ваш .pfx файл.

Для использование openssl.exe, используйте следующий синтаксис:

Openssl.exe pkcs12 –in <your file>.pfx –out <your file>.pem.

Openssl.exe запросит пароль. Введите его если он был задан или оставьте его пустым в противном случае. Также будет запрошен новый пароль для .pem файла. Это не обязательное условие, но если вы его защитите паролем, то вы должны будете создать обработчик события OnGetPassword в SSL перехватчике.

18.4.3. Разделение файла .pem.

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

18.4.4. Файл Key.pem.

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

-----BEGIN RSA PRIVATE KEY-----

-----END RSA PRIVATE KEY-----

18.4.5. Файл Cert.pem.

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

-----BEGIN CERTIFICATE-----

-----END CERTIFICATE-----

18.4.6. Файл Root.pem.

Последний файл, который требуется для Indy – это Certificate Authority certificate файл. Вы можете получить его из Internet Explorer в диалоге Trusted Root Certificate Authority. Выберите поставщика (Authority), чей сертификат вы желаете экспортировать и экспортируйте его в Base64 (cer) формате. Данный формат, аналогичен PEM и после экспорта просто переименуйте его в root.pem.

Stack Overflow, Runtime error 202.

Simply put, stack overflows are caused by putting too much on the stack. Usually, they are caused by recursive procedures that never end. A good example would be creating an event handler for the TMemo's onChange event, and making a change to the Memo during the processing of the event. Every time the OnChange event gets fired, another change is made, so the OnChange event gets fired again in an almost endless loop. The loop finally ends when the stack overflows, and the application crashes.

Start Access.

If you've got the D5 patch, you can use the TAccessApplication component to start Access. Drop one one a form, and if its AutoConnect property is true, Access will start automatically when your program starts; if it's false, just call.

AccessApplication1.Connect;

When you want to start. To use a running instance of Access, if there is one, set the ConnectKind property of TAccessApplication to ckRunningOrNew, or to ckRunningInstance if you don't want to start a new instance if Access isn't running.

Once Access has started, you can connect other components, such as TAccessReport, using their ConnectTo methods:

Code: AccessApplication1.Connect; AccessApplication1.Visible := True; AccessApplication1.OpenCurrentDatabase('C:\Office\Samples\Northwind.mdb', True); AccessApplication1.DoCmd.OpenReport('Sales by Year', acViewDesign, EmptyParam, EmptyParam); AccessReport1.ConnectTo(AccessApplication1.Reports['Sales by Year']); AccessReport1.Caption := 'Annual sales - from bad to worse';

Storing/Playing an .AVI file in a database.

How can I store an AVI file in a database and then play AVI.

Files?

AVI files can be stored in BLOB (binary large object) fields.

The easiest way to play an AVI file stored in a BLOB is to write.

The BLOB data to a temporary file, then let the mulimedia player.

Play the file. The following example demonstrates how to store.

An AVI file to a BLOB field, and also play the AVI file from the.

BLOB field.

Code: Var. FileName : string; {This function gets a temporary file name form the system}. Function GetTemporaryFileName : string; {$IFNDEF WIN32}. Const MAX_PATH = 144; {$ENDIF}. Var. {$IFDEF WIN32}. LpPathBuffer : PChar; {$ENDIF}. Lpbuffer : PChar; Begin. {Get the file name buffer}. GetMem(lpBuffer, MAX_PATH); {$IFDEF WIN32}. {Get the temp path buffer}. GetMem(lpPathBuffer, MAX_PATH); {Get the temp path}. GetTempPath(MAX_PATH, lpPathBuffer); {Get the temp file name}. GetTempFileName(lpPathBuffer, 'tmp', 0, LpBuffer); {Free the temp path buffer}. FreeMem(lpPathBuffer, MAX_PATH); {$ELSE}. {Get the temp file name}. GetTempFileName(GetTempDrive('C'), 'tmp', 0, LpBuffer); {$ENDIF}. {Create a pascal string containg}. {the temp file name and return it}. Result := StrPas(lpBuffer); {Free the file name buffer}. FreeMem(lpBuffer, MAX_PATH); End; {Read a AVI file into a blob field}. Procedure TForm1.Button1Click(Sender: TObject); Var. FileStream: TFileStream; {to load the avi file}. BlobStream: TBlobStream; {to save to the blob}. Begin. {Allow the button to repaint}. Application.ProcessMessages; {Turn off the buttons}. Button1.Enabled := false; Button2.Enabled := false; {Assign the avi file name to read}. FileStream := TFileStream.Create( 'C:\PROGRA~1\BORLAND\DELPHI~1\DEMOS\COOLSTUF\COOL.AVI', FmOpenRead); Table1.Edit; {Create a BlobStream for the TField Table1AVI}. BlobStream := TBlobStream.Create(Table1AVI, bmReadWrite); {Seek to the Beginning of the stream}. BlobStream.Seek(0, soFromBeginning); {Delete any data that may be there}. BlobStream.Truncate; {Copy from the FileStream to the BlobStream}. BlobStream.CopyFrom(FileStream, FileStream.Size); {Free the streams}. FileStream.Free; BlobStream.Free; {Post the record}. Table1.Post; {Enable the buttons}. Button1.Enabled := true; Button2.Enabled := true; End; {Read an avi stored in a blob, and play it}. Procedure TForm1.Button2Click(Sender: TObject); Var. FileStream: TFileStream; {a temp file}. BlobStream: TBlobStream; {the AVI Blob}. Begin. {Create a blob stream for the AVI blob}. BlobStream := TBlobStream.Create(Table1AVI, bmRead); If BlobStream.Size = 0 then begin. BlobStream.Free; Exit; End; {Close the media player}. MediaPlayer1.Close; {Reset the file name}. MediaPlayer1.FileName := ''; {Refresh the play window}. MediaPlayer1.Display := Panel1; Panel1.Refresh; {if we have a temp file then erase it}. If FileName '' then. DeleteFile(FileName); {Get a temp file name}. FileName := GetTemporaryFileName; {Create a temp file stream}. FileStream := TFileStream.Create(FileName, FmCreate or fmOpenWrite); {Copy the blob to the temp file}. FileStream.CopyFrom(BlobStream, BlobStream.Size); {Free the streams}. FileStream.Free; BlobStream.Free; {Setup the Media player to play the AVI file}. MediaPlayer1.FileName := filename; MediaPlayer1.DeviceType := dtAviVideo; MediaPlayer1.Open; MediaPlayer1.Play; End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. {Unassign the temp file from the media player}. MediaPlayer1.Close; MediaPlayer1.FileName := ''; {Erase the temp file}. If FileName '' then. DeleteFile(FileName); End;

StrAlloc и GetMem.

StrAlloc непосредственно использует GetMem, поэтому обе функции живут за счет Кучи. StrAlloc имеет преимущество: он распределяет на два байта больше, чем вы просите и там хранит размер размещенного блока. Поэтому StrDispose знает сколько памяти освободить и вы можете этого не помнить (в отличие от GetMem/FreeMem). Не смешивайте при работе эти две функциональные пары, иначе вы будете потрясены количеством возникающих ошибок!

©Drkb::00814.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Stream Read Error.

В моем автономном приложении при чтении/записи из моей базы данных с помощью BDE проблем не возникает. Когда я выгружаю .EXE на наш сетевой том NetWare 3.11, я получаю случайные сообщения об ошибке "Stream Read Error" (ошибка чтения потока). В сети у меня имеется BDE, но пользователи имеют на своих жестких дисках собственные файлы IDAPI.CFG. Может мне кто-нибудь прояснит ситуацию?

В программе конфигурирования Database Engine Configuration, на закладке 'system', попробуйте изменить значение по умолчанию для MAXFILEHANDLES с 48 на 12. Не знаю почему, но это решило мои проблемы, у меня исчезли ошибки 'Stream read error' и различные GPF-ы.

©Drkb::02587.

Roger Huffman.

Вопреки логики, как мне УМЕНЬШИТЬ количество дескрипторов файлов? Повышать мне их не удалось.

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

Roy Woll.

©Drkb::02586.

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

String --> BCD.

Code: Function NumStringToBCD(const inStr: string): string; Function Pack(ch1, ch2: Char): Char; Begin. Assert((ch1 >= '0') and (ch1 <= '9')); Assert((ch2 >= '0') and (ch2 <= '9')); {Ord('0') is $30, so we can just use the low nybble of the character. As value.}. Result := Chr((Ord(ch1) and $F) or ((Ord(ch2) and $F) shl 4)). End; Var. I: Integer; Begin. If Odd(Length(inStr)) then. Result := NumStringToBCD('0' + instr). Else begin. SetLength(Result, Length(inStr) div 2); For i := 1 to Length(Result) do. Result[i] := Pack(inStr[2 * i - 1], inStr[2 * i]); End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. S1, S2: string; Begin. S1 := '15151515151515151515'; S2 := NumStringToBCD(S1); Memo1.lines.add('S1: ' + S1); Memo1.lines.add('Length(S2): ' + IntToStr(Length(S2))); Memo1.lines.add('S2 unpacked again: ' + BCDToNumString(S2)); End;

StringGrid без выделенной ячейки

Автор: Jeff Fisher.

StringGrid, выделить фиксированные строки.

StringGrid, выделить фиксированные строки

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Grids; Type. TForm1 = class(TForm). StringGrid1: TStringGrid; Procedure FormCreate(Sender: TObject); Procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.FormCreate(Sender: TObject); Var. C, R: Integer; Begin. For C := 0 to StringGrid1.ColCount - 1 do. Begin. For R := 0 to StringGrid1.RowCount - 1 do. Begin. If (C < StringGrid1.FixedCols) or. (R < StringGrid1.FixedRows) then. StringGrid1.Cells[C, R] := Format('Fixed Cell (%dx%xd)', [C, R]). Else. StringGrid1.Cells[C, R] := Format('Cell (%dx%d)', [C, R]); End; End; End; Procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); Var. I: Integer; Begin. With StringGrid1 do. If gdFixed in State then. Begin. Canvas.FillRect(Rect); InflateRect(Rect, -2, 0); If (ACol = Col) or (ARow = Row) then. Canvas.Font.Style := [fsBold]. Else. Canvas.Font.Style := []; DrawText(Canvas.Handle, PChar(Cells[ACol, ARow]), -1, Rect, DT_SINGLELINE or DT_VCENTER); End else begin. Rect := CellRect(ACol, 0); For I := 1 to FixedRows - 1 do. With CellRect(ACol, I) do. Inc(Rect.Bottom, Bottom - Top); InvalidateRect(Handle, @Rect, True); Rect := CellRect(0, ARow); For I := 1 to FixedCols - 1 do. With CellRect(I, ARow) do. Inc(Rect.Right, Right - Left); InvalidateRect(Handle, @Rect, True); End; End; End.

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

Автор: Smike.

©Drkb::00615.

StringGrid как DBGrid.

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

StringGrid, Печать в ячейку.

StringGrid, Печать в ячейку

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Grids; Type. TForm1 = class(TForm). StringGrid: TStringGrid; Procedure FormCreate(Sender: TObject); Procedure StringGridDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.FormCreate(Sender: TObject); Var. C, R: Integer; Begin. For C := 0 to StringGrid.ColCount - 1 do. For R := 0 to StringGrid.RowCount - 1 do. StringGrid.Cells[C, R] := 'A very very very long string'; End; Procedure TForm1.StringGridDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); Begin. If not (Sender is TStringGrid) then Exit; With TStringGrid(Sender) do. Begin. Canvas.FillRect(Rect); DrawText(Canvas.Handle, PChar(Cells[ACol, ARow]), -1, Rect, DT_WORDBREAK); End; End; End.

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

Автор: Smike.

©Drkb::00616.

String --> HKEY.

Code: Const. HKEYNames: array[0..6] of string = ('HKEY_CLASSES_ROOT', 'HKEY_CURRENT_USER', 'HKEY_LOCAL_MACHINE', 'HKEY_USERS', 'HKEY_PERFORMANCE_DATA', 'HKEY_CURRENT_CONFIG', 'HKEY_DYN_DATA'); Function StrToHKEY(const KEY: string): HKEY; Var. I: Byte; Begin. Result := $0; For i := Low(HKEYNames) to High(HKEYNames) do. Begin. If SameText(HKEYNames[i], KEY) then. Result := HKEY_CLASSES_ROOT + i; End; End;

String --> WideString.

Code: {:Converts Ansi string to Unicode string using specified code page. @param s Ansi string. @param codePage Code page to be used in conversion. @returns Converted wide string. } Function StringToWideString(const s: AnsiString; codePage: Word): WideString; Var. L: integer; Begin. If s = '' then. Result := '' Else. Begin. L := MultiByteToWideChar(codePage, MB_PRECOMPOSED, PChar(@s[1]), - 1, nil, 0); SetLength(Result, l - 1); If l > 1 then. MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PChar(@s[1]), - 1, PWideChar(@Result[1]), l - 1); End; End; { StringToWideString }.

String --> PWideChar.

String --> StringList.

SUser.pas.

SVR API для непродвинутых

Автор: Александр Терехов

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

Tab как Enter в StringGrid.

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

TADOConnection.

Компонент TADOConnection предназначен для управления соединением с объектами хранилища данных ADO. Он обеспечивает доступ к хранилищу данных компонентам ADO, инкапсулирующим набор данных (см. ниже).

Применение этого компонента дает разработчику ряд преимуществ:

Все компоненты доступа к данным ADO обращаются к хранилищу данных через одно соединение;

Возможность напрямую задать объект провайдера соединения;

Доступ к объекту соединения ADO;

Возможность выполнять команды ADO;

Выполнение транзакций;

Расширенное управление соединением при помощи методов-обработчиков событий.

Настройка соединения.

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

Property ConnectionString: WideString;

Которое подробно рассматривалось в разд. "Компонент TADOConnection". Добавим лишь, что набор параметров изменяется в зависимости от типа провайдера и может настраиваться как вручную, так и при помощи специального редактора параметров соединения, который вызывается двойным щелчком на компоненте TADOConnection, перенесенным на форму, или щелчком на кнопке в поле редактирования свойства ConnectionString в Инспекторе объектов. Здесь можно настроить соединение через свойство ConnectionString (радиокнопка Use Connection String) или загрузить параметры соединения из файла с расширением udl (радиокнопка Use Data Link File).

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

[oledb].

Everything after this line is an OLE DB initstring.

Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Program Files\Common Files\Borland Shared\Data\DBDEMOS.mdb.

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

Первая страница Provider позволяет выбрать провайдер OLE DB для конкретного типа источника данных из числа провайдеров, установленных в системе. Здесь вы видите провайдеры не только для серверов БД, но и служб, установленных в операционной системе. Состав элементов управления следующих страниц зависит от типа источника данных, но различается не так уж сильно. Далее практически везде необходимо задать источник данных (имя сервера, базу данных, файл и т. д.), режим аутентификации пользователя, а также определить имя и пароль пользователя.

Следующая страница Connection настраивает источник данных.

На первом этапе требуется выбрать имя сервера из доступных для данного компьютера.

Второй этап определяет режим аутентификации пользователя. Это либо система безопасности Windows, либо собственная система аутентификации сервера. Здесь же надо определить имя и пароль пользователя.

Третий этап предназначен для выбора базы данных сервера.

По окончании настройки источника данных вы можете проверить соединение, нажав кнопку Test Connection.

Страница Advanced задает дополнительные параметры соединения. В зависимости от типа хранилища данных некоторые элементы этой страницы могут быть недоступны.

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

Anonymous — роль клиента недоступна серверу;

Identify — роль клиента опознается сервером, но доступ к системным объектам заблокирован;

Impersonate — процесс сервера может быть представлен защищенным контекстом клиента;

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

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

None — подтверждение не требуется;

Connect — подтверждение необходимо только при подключении;

Call — подтверждение источника данных при каждом запросе;

Pkt — подтверждение получения от клиента всех данных;

Pkt Integrity — подтверждение получения от клиента всех данных с соблюдением целостности;

Pkt Privacy — подтверждение получения от клиента всех данных с соблюдением целостности и защита шифрованием.

В поле Connect timeout можно задать время ожидания соединения в секундах. По истечении этого времени процесс прерывается.

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

Read — только чтение;

ReadWrite — чтение и запись;

Share Deny None — полный доступ всем на чтение и запись;

Share Deny Read — чтение запрещено всем;

Share Deny Write — запись запрещена всем;

Share Exclusive — чтение и запись запрещена всем;

Write — только запись.

Последняя страница All позволяет просмотреть и при необходимости изменить все сделанные настройки (для этого предназначена кнопка Edit Value...) для выбранного провайдера.

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

Управление соединением.

Соединение с хранилищем данных ADO открывается и закрывается при помощи свойства.

Property Connected: Boolean;

Или методов.

Procedure Open; overload;

Procedure Openfconst UserlD: WideString; const Password: WideString); overload;

И.

Procedure Close;

Метод open является перегружаемым при необходимости использования удаленного или локального соединения. Для удаленного соединения применяется вариант с параметрами UserID и Password.

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

Property BeforeConnect: TNotifyEvent;

Property BeforeDisconnect: TNotifyEvent;

Property AfterConnect: TNotifyEvent;

Property AfterDisconnect: TNotifyEvent;

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

TWillConnectEvent = procedure(Connection: TADOConnection; var Connectionstring, UserlD, Password: WideString; var ConnectOptions: TConnectOption;

Var EventStatus: TEventStatus) of object;

Property OnWillConnect: TWillConnectEvent;

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

Параметры Connectionstring, userID и Password определяют строку параметров, имя и пароль пользователя.

Соединение может быть синхронным или асинхронным, что и определяется параметром ConnectOptions типа TConnectOption:

Type TConnectOption = (coConnectUnspecified, coAsyncConnect);

CoConnectunspecified — синхронное соединение всегда ожидает результат последнего запроса;

CoAsyncConnect — асинхронное соединение может выполнять новые запросы, не дожидаясь ответа от предыдущих запросов.

Наконец, параметр Eventstatus позволяет определить успешность выполнения посланного запроса на соединение:

Type TEventStatus = (esOK, esErrorsOccured, esCantDeny, esCancel, esUnwantedEvent);

EsOK — запрос на соединение выполнен успешно;

EsErrorsOccured — в процессе выполнения запроса возникла ошибка;

EsCantDeny — соединение не может быть прервано;

EsCancel — соединение было прервано до открытия;

EsUnwantedEvent — внутренний флаг ADO.

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

Procedure TForml.ADOConnectionWillConnect(Connection: TADOConnection;

Var ConnectionString, UserlD, Password: WideString;

Var ConnectOptions: TConnectOption;

Var Eventstatus: TEventStatus);

Begin.

If Eventstatus = esOK then ConnectOptions := coConnectunspecified;

End;

Кстати, параметр синхронности/асинхронности можно также задать при помощи свойства.

ConnectOptions property ConnectOptions: TConnectOption;

После открытия соединения для выполнения собственного кода можно использовать метод-обработчик.

TConnectErrorEvent = procedure(Connection: TADOConnection; Error: Error;

Var Eventstatus: TEventStatus) of object;

Property OnConnectComplete: TConnectErrorEvent;

Здесь, если в процессе открытия соединения возникла ошибка, параметр Eventstatus будет равен esErrorsOccured, а параметр Error содержит объект ошибки ADO.

Теперь перейдем к вспомогательным свойствам и методам компонента TADOConnection, обеспечивающим соединение.

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

Property ConnectionTimeout: Integer;

Задающее время ожидания открытия соединения в секундах. По умолчанию оно равно 15 сек.

Также можно определить реакцию компонента на неиспользуемое соединение. Если через соединение не подключен ни один активный компонент, свойство.

Property KeepConnection: Boolean;

В значении True сохраняет соединение открытым. Иначе, после закрытия последнего связанного компонента ADO, соединение закрывается.

При необходимости провайдер соединения ADO определяется напрямую свойством.

Property Provider: WideString;

Имя источника данных по умолчанию задается свойством.

Property DefaultDatabase: WideString;

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

При необходимости прямой доступ к объекту соединения OLE DB обеспечивает свойство.

Property ConnectionObject: _Connection;

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

Property LoginPrompt: Boolean;

Без этого диалога для задания данных параметров можно использовать свойство Connectionstring, метод open (см. выше) или метод-обработчик.

Type TLoginEvent = procedure(Sender:TObject; Username, Password: string) of object;

Property OnLogin: TLoginEvent;

Свойство.

Type TConnectMode = (cmUnknown, cmRead, cmWrite, cinReadWrite, cmShareDenyRead, cmShareDenyWrite, cmShareExclusive, cmShareDenyNone);

Property Mode: TConnectMode;

Задает доступные для соединения операции:

CmUnknown — разрешение неизвестно или не может быть установлено;

CmRead — разрешение на чтение;

Cmwrite — разрешение на запись;

CmReadWrite — разрешение на чтение и запись;

CmshareDenyRead — разрешение на чтение для других соединений запрещено;

Cmshareoenywrite — разрешение на запись для других соединений запрещено;

CmShareExciusive — разрешение на открытие для других соединений запрещено;

CmshareDenyNone — открытие других соединений с разрешениями запрещено.

Доступ к связанным наборам данных и командам ADO.

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

Property DataSets[Index: Integer]: TCustomADODataSet;

Каждый элемент этого списка содержит дескриптор компонента доступа к данным ADO (тип TCustomADODataSet). Общее число связанных компонентов с наборами данных возвращается свойством.

Property DataSetCount: Integer;

Для этих компонентов можно централизованно установить тип используемого курсора при помощи свойства.

Type TCursorLocation = (clUseServer, clUseClient); property CursorLocation: TCursorLocation;

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

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

Например:

For i := 0 to ADOConnection.DataSetCount — 1 do.

Begin.

If ADOConnection.DataSets[i].Active = True then ADOConnection.DataSets[i].Close;

ADOConnection.DataSets[i].CursorLocation := clUseClient;

End;

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

Property Commands[Index: Integer]: TADOCommand.

Каждый элемент этого списка представляет собой экземпляр класса TADOCommand.

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

Property CommandCount: Integer.

Например, сразу после открытия соединения можно выполнить все связанные команды ADO, реализовав таким образом нечто вроде скрипта:

Procedure TForml.ADOConnectionConnectComplete(Connection: TADOConnection;

Const Error: Error; var EventStatus: TEventStatus);

Var i, ErrorCnt: Integer;

Begin.

If EventStatus = esOK then.

For i := 0 to ADOConnection.CommandCount — 1 do.

Try.

If ADOConnection.Commands[i].CommandText <> then ADOConnection.Commands[i].Execute;

Except.

On E: Exception do Inc(ErrorCnt);

End;

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

Function Execute(const CommandText: WideString; ExecuteOptions: TExecuteOptions = []): _RecordSet; overload;

Procedure Execute(const CommandText: WideString; var RecordsAffected:

Integer; ExecuteOptions: TExecuteOptions = [eoExecuteNoRecords]);overload;

Выполнение команды осуществляется процедурой Execute (если команда не возвращает набор записей) или одноименной функцией Execute (если команда возвращает набор записей).

Параметр commandText должен содержать текст команды. Параметр RecordsAffected возвращает число обработанных командой записей (если они есть). Параметр.

Type.

TExecuteOption = (eoAsyncExecute, eoAsyncFetch, eoAsyncFetchNonBlocking, eoExecuteNoRecords);

TExecuteOptions = set of TExecuteOption;

Задает условия выполнения команды:

EoAsyncExecute — команда выполняется асинхронно (соединение не будет ожидать окончания выполнения команды, а продолжит работу, обработав сигнал о завершении команды, когда он поступит);

EoAsyncFetch — команда получает необходимые записи также асинхронно;

EoAsyncFetchNonBlocking — команда получает необходимые записи также асинхронно, но при этом созданная нить не блокируется;

EoExecuteNoRecords — команда не должна возвращать записи.

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

TWillExecuteEvent = procedure(Connection: TADOConnection;

Var CommandText: WideString; var CursorType: TCursorType; var LockType:

TADOLockType; var ExecuteOptions: TExecuteOptions; var EventStatus:

TEventStatus; const Command: _Command;

Const Recordset: _Recordset) of object;

Property OnWillExecute: TWillExecuteEvent;

После выполнения команды вызывается метод-обработчик.

TExecuteCompleteEvent = procedure(Connection: TADOConnection; RecordsAffected: Integer; const Error: Error; var EventStatus: TEventStatus;

Const Command: _Command; const Recordset: _Recordset) of object;

Property OnExecuteComplete: TExecuteCompleteEvent;

Объект ошибок ADO.

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

Property Errors: Errors;

Транзакции.

Компонент TADOconnection позволяет выполнять транзакции. Методы.

Function BeginTrans: Integer;

Procedure CommitTrans;

Procedure RollbackTrans;

Обеспечивают начало, фиксацию и откат транзакции соответственно. Методы-обработчики.

TBeginTransCompleteEvent = procedure(Connection: TADOConnection;

TransactionLevel: Integer;

Const Error: Error; var EventStatus: TEventStatus) of object;

Property OnBeginTransComplete: TBeginTransCompleteEvent; TConnectErrorEvent = procedure(Connection: TADOConnection; Error: Error; var EventStatus: TEventStatus) of object;

Property OnCornmitTransComplete: TConnectErrorEvent;

Вызываются после начала и фиксации транзакции. Свойство.

Type TIsolationLevel = (ilUnspecified, ilChaos, ilReadUncommitted, ilBrowse, ilCursorStability, ilReadCorranitted, ilRepeatableRead, ilSerializable, illsolated);

Property IsolationLevel: TIsolationLevel;

Позволяет задать уровень изоляции транзакции:

IlUnspecifed — уровень изоляции не задается;

Ilichaos — изменения более защищенных транзакций не перезаписываются данной транзакцией;

IlReadUncommitted — незафиксированные изменения других транзакций видимы;

IlBrowse — незафиксированные изменения других транзакций видимы;

IlCursorStability — изменения других транзакций видимы только после фиксации;

IlReadCommitted — изменения других транзакций видимы только после фиксации;

IlRepeatableRead — изменения других транзакций не видимы, но доступны при обновлении данных;

ISerializable — транзакция выполняется изолированно от других транзакций;

Ilisolated — транзакция выполняется изолированно от других транзакций.

Свойство.

TXactAttribute = (xaCommitRetaining, xaAbortRetaining); property Attributes: TXactAttributes;

Задает способ управления транзакциями при их фиксации и откате:

XaCommitRetaining — после фиксации очередной транзакции автоматически начинается выполнение новой;

XaAbortRetaining — после отката очередной транзакции автоматически начинается выполнение новой.

TADODataSet.

Компонент TADODataSet.

Компонент TADODataSet предназначен для представления набора данных из хранилища данных ADO. Он прост в использовании, имея только несколько собственных свойств и методов, и применяет функции своего предка —класса TCustomADODataSet.

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

Property CommandText: WideString;

И.

Property CommandType: TCommandType;

В результате компонент представляет собой гибкий инструмент, который позволяет (в зависимости от типа команды и ее текста) получать данные из таблиц, запросов SQL, хранимых процедур, файлов и т. д. Например, вы выбираете нужное значение свойства CommandType = cmdText и заносите в свойство CommandText текст запроса SQL из редактора:

ADODataSet,CommandType = cmdText;

ADODataSet. CommandText := Memol.Lines.Text;

И запрос SQL готов к выполнению.

Примечание.

Для запросов SQL можно применять только язык Data Manipulation Language (использовать только SELECT).

Соединение с базой данных задается свойством Connectionstring или Connection (см. выше).

Набор данных открывается и закрывается свойством Active или методами Open и Close.

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

TADOQuery.

Компонент TADOQuery обеспечивает применение запросов SQL при работе с данными через ADO. По своей функциональности он подобен стандартному компоненту запроса (см. гл. 11).

Текст запроса задается свойством.

Property SQL: TStrings;

Параметры запроса определяются свойством.

Property Parameters: TParameters;

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

Property Active: Boolean;

Или метод.

Procedure Open;

В противном случае достаточно использовать метод.

Function ExecSQL: Integer;

Число обработанных запросом записей возвращает свойство.

Property RowsAffected: Integer;

TADOStoredProc.

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

Имя хранимой процедуры определяется свойством.

Property ProcedureName: WideString;

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

Property Parameters: TParameters;

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

Property Prepared: Boolean;

Присваивается значение True.

TADOTable.

Компонент ТАDОТаь1е обеспечивает использование в приложениях Delphi таблиц БД, подключенных через провайдеры OLE DB. По своим функциональным возможностям и применению он подобен стандартному табличному компоненту (см. гл. 11).

Как вы уже знаете, в основе компонента лежит использование команды ADO, но ее свойства настроены заранее и изменению не подлежат.

Имя таблицы БД задается свойством.

Property TableName: WideString;

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

Так как не все провайдеры ADO обеспечивают прямое использование таблиц БД, то для доступа к ним может понадобиться запрос SQL. Если свойство.

Property TableDirect: Boolean;

Имеет значение True, осуществляется прямой доступ к таблице. В противном случае компонент генерирует соответствующий запрос.

Свойство.

Property Readonly: Boolean;

Позволяет включить или отключить для таблицы режим "только для чтения".

TColor ---> HTML Color.

Функция для преобразования цвета TColor в формат цветов HTML.

Code: Function TColorToHTML(const Value: TColor): string; Var. RGBColor: Longint; Begin. RGBColor := ColorToRGB(Value); Result := Format('#%.2x%.2x%.2x', [GetRValue(RGBColor), GetGValue(RGBColor), GetBValue(RGBColor)]); End;

Не нужно забывать о

Code: Uses SysUtils, Graphics;

для функций Format и ColorToRGB!

Автор: Smike.

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

©Drkb::03677.

TComponent.

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

Property Name: TComponentName;

Оно содержит имя экземпляра компонента, которое используется для идентификации компонента в приложении.

Примечание.

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

Type TComponentName = type string;

Свойство.

Property Tag: Longint;

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

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

Таблица 2.1. Свойства и методы для управления списком компонентов.

Свойство (метод).

Описание.

Property Components [Index: Integer]: TComponent ;

Содержит индексированный список указателей всех компонентов, для которых данный компонент является владельцем (owner).

Property ComponentCount : Integer;

Число подчиненных компонентов.

Property Owner: TComponent;

Указывается, какой компонент является владельцем данного.

Property Componentlndex: Integer;

Индекс данного компонента в списке владельца.

Procedure InsertComponent (AComponent : TComponent) ;

Вставляет компонент AComponent в список.

Procedure RemoveComponent (AComponent : TComponent};

Удаляет компонент AComponent из списка.

Procedure FindComponent (AName: string): TComponent;

Осуществляет поиск компонента по имени AName.

Procedure DestroyComponents;

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

Очень важное свойство.

Type TComponentState = set of (csLoading, csReading, csWriting, csDestroying, csDesigning, csAncestor, csllpdating, csFixups, csFreeNotification, cslnline, csDesignlnstance); property ComponentState: TComponentState;

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

Таблица 2.2. Возможные состояния компонента.

CsLoading.

Устанавливается при загрузке компонента из потока.

CsReading.

Устанавливается при чтении значений свойств из потока.

CsWriting.

Устанавливается при записи значений свойств в поток.

CsDestroying.

Устанавливается при уничтожении компонента.

CsDesigning.

Состояние разработки. Устанавливается при работе с формой во время разработки.

CsAncestor.

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

CsUpdating.

Устанавливается при изменении значений свойств и отображения результата на форме-владельце. Для перехода в это состояние должно быть уже установлено состояние csAncestor.

CsFixups.

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

CsFreeNotification.

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

Cslnline.

Определяет компонент верхнего уровня в иерархии. Используется для обозначения корневого объекта в разворачивающихся свойствах.

CsDesignlnstance.

Определяет корневой компонент на этапе разработки.

Для обеспечения работы механизма действий (см. гл. 8) предназначен.

Метод.

Function ExecuteAction(Action: TBasicAction): Boolean; dynamic;

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

На уровне класса TComponent обеспечена поддержка СОМ-интерфейсов IUnknown и IDispatch.

Через свойство.

Property ComObject: IUnknown;

Вы можете обеспечить применение методов этих интерфейсов.

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

©Drkb::00323.

TControl.

Класс TControi является базовым для всех визуальных компонентов и инкапсулирует механизмы отображения компонента на экране. В нем используется множество новых свойств и методов. Недаром в Delphi в Инспекторе объектов появилась категоризация методов и свойств (рис. 2.2). Большинство из них вводятся как раз в классах TControl и TWinControl.

©Drkb::00324.

TCustomADODataSet.

Класс TCustomADODataSet инкапсулирует механизм доступа к хранилищу данных через ADO. Этот класс наполняет абстрактные методы общего предка TDataSet функциями конкретного механизма доступа к данным.

Поэтому здесь мы рассмотрим только уникальные свойства и методы класса TCustomADODataSet, обеспечивающие работу с ADO.

Соединение набора данных с хранилищем данных ADO осуществляется через компонент TADOConnection (свойство connection) или путем задания параметров соединения через свойство connectionstring.

Набор данных.

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

Type TADOLockType = (ItUnspecified, ItReadOnly, ItPessimistic, ItOptimistic, ItBatchOptimistic); property LockType: TADOLockType;

ItUnspecified — блокировка задается источником данных, а не компонентом;

ItReadOnly — набор данных откроется в режиме только для чтения;

ItPessimistic — редактируемая запись блокируется на все время редактирования до момента сохранения в хранилище данных;

ItOptimistic — запись блокируется только на время сохранения изменений в хранилище данных;

ItBatchOptimistic — запись блокируется на время сохранения в хранилище данных при вызове метода updateBatch.

Примечание.

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

Набор данных открывается методом Open и закрывается методом close. Также можно использовать свойство.

Property Active: Boolean;

Текущее состояние набора данных можно определить свойством.

Type.

TObjectState = (stClosed, stOpen, stConnecting, stExecuting, stretching);

TObjectStates = set of TObjectState;

Property RecordsetState: TObjectStates;

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

Property Recordset: _Recordset;

Но поскольку все основные методы интерфейсов объекта набора записей ADO перекрыты методами класса, в обычных случаях прямой доступ к объекту вам не понадобится. После обновления набора данных вызывается метод-обработчик.

TRecordsetEvent = procedure(DataSet: TCustomADODataSet; const Error: Error;

Var EventStatus: TEventStatus) of object; property OnFetchComplete: TRecordsetEvent;

Где Error — ссылка на объект ошибки ADO, если она возникла.

Если же набор данных работает в асинхронном режиме, при обновлении вызывается метод-обработчик.

TFetchProgressEvent = procedure(DataSet: TCustomADODataSet; Progress, MaxProgress: Integer; var EventStatus: TEventStatus) of object;

Property OnFetchProgress: TFetchProgressEvent;

Где параметр Progress показывает долю выполнения операции.

Курсор набора данных.

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

Type TCursorLocation = (clUseServer, clUseClient); property CursorLocation: TCursorLocation;

Курсор может находиться на сервере (CIUseServer) или на клиенте (CIUseClient).

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

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

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

TMarshalOption = (moMarshalAll, moMarshalModifiedOnly);

Property MarshalOptions: TmarshalOption.

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

Тип курсора определяется свойством.

TCursorType = (ctUnspecified, CtOpenForwardOnly, ctKeyset, ctDynamic, ctStatic);

Property CursorType: TCursorType;

Ctunspecified — курсор не задан, тип курсора определяется возможностями источника данных;

CtOpenForwardOnly — однонаправленный курсор, допускающий перемещение только вперед; используется при необходимости быстрого одиночного прохода по всем записям набора данных;

CtKeyset — двунаправленный локальный курсор, не обеспечивающий просмотр добавленных и удаленных другими пользователями записей;

CtDynamic — двунаправленный курсор, отображает все изменения, требует наибольших затрат ресурсов;

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

Примечание.

Если курсор расположен на клиенте (CursorType = ciusedient), то для него доступен только один тип — ctStatic.

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

TRecordsetReasonEvent = procedure(DataSet: TCustomADODataSet;

Const Reason: TEventReason;

Var EventStatus: TEventStatus) of object;

Property OnWillMove: TRecordsetReasonEvent;

И.

TPRecordsetErrorEvent = procedure(DataSet: TCustomADODataSet; const --eason: TEventReason; const Error: Error; var EventStatus: TEventStatus) if object;

Property OnMoveComplete: TRecordsetErrorEvent;

Где параметр Reason позволяет узнать, какой метод вызвал это перемещение.

Локальный буфер.

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

Property CacheSize: Integer;

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

CacheSizelnMem := ADODataSet.CacheSize * ADODataSet.RecordSize;

Где RecordSize — свойство.

Property RecordSize: Word;

Возвращающее размер одной записи в байтах.

Как видите, компоненты ADO не избежали общей проблемы клиентских данных — при плохом качестве соединения работа приложения замедляется. Однако кое-что все-таки сделать можно. Если при навигации по записям вам не требуется отображать данные в визуальных компонентах пользовательского интерфейса, свойство property BlockReadSize: Integer;

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

Property MaxRecords: Integer.

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

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

Property RecordCount: Integer;

При достижении последней записи набора данных вызывается метод-обработчик.

TEndOfRecordsetEvent = procedure (DataSet: TCustomADODataSet; var MoreData: WordBool; var EventStatus: TEventStatus) of object;

Property OnEndOfRecordset: TEndOfRecordsetEvent;

При этом параметр MoreData показывает, действительно ли достигнут конец набора данных. Если MoreData = True, то это означает, что в хранилище данных еще имеются записи, не переданные клиенту.

Состояние записи.

Класс TCustomADODataSet обладает дополнительными возможностями, которые позволяют отслеживать состояние каждой записи.

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

TRecordStatus = (rsOK, rsNew, rsModified, rsDeleted, rsUnmodified, rslnvalid, rsMultipleChanges, rsPendingChanges, rsCanceled, rsCantRelease, rsConcurrencyViolation, rsIntegrityViolation, rsMaxChangesExceeded, rsObjectOpen, rsOutOfMemory, rsPermissionDenied, rsSchemaViolation, rsDBDeleted);

Property RecordStatus: TRecordStatusSet;

Где.

RsOK — запись успешно сохранена;

RsNew — запись добавлена;

RsModified — запись была изменена;

RsDeleted — запись удалена;

RsUnmodified — запись без изменений;

Rslnvalid — запись не может быть сохранена из-за неверной закладки;

RsMultipleChanges — запись не может быть сохранена из-за множественных изменений;

RsPendingChanges — запись не может быть сохранена из-за ссылки на несохраненные изменения;

RsCanceled — операция с записью была отменена;

RsCantRelease — запись заблокирована;

RsConcurrencyViolation — запись не может быть сохранена из-за типа блокировки;

Rsintegrityvioiation — нарушена ссылочная целостность;

RsMaxChangesExceeded — слишком много изменений;

RsObjectOpen — конфликт с объектом базы данных;

RsoutofMemory — недостаток памяти,

RsPermissionDenied — нет доступа;

RsSchemaViolation — нарушение структуры данных;

RsDBDeleted — запись удалена в БД.

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

Кроме этого, метод.

Type.

TUpdateStatus = (usUnmodified, usModifled, uslnserted, usDeleted);

Function UpdateStatus: TUpdateStatus; override;

Возвращает информацию о состоянии текущей записи.

Соответственно до и после изменения записи вызываются методы-обработчики.

TWillChangeRecordEvent = procedure(DataSet: TCustomADODataSet; const Reason: TEventReason; const RecordCount: Integer; var EventStatus: TEventStatus) of object;

Property OnWillChangeRecord: TWillChangeRecordEvent;

И.

TRecordChangeCompleteEvent = procedure(DataSet: TCustomADODataSet; const Reason: TEventReason; const RecordCount: Integer; const Error: Error;

Var EventStatus: TEventStatus) of object;

Property OnRecordChangeComplete: TrecordChangeCompleteEvent;

Где параметр Reason позволяет узнать, какой метод изменил записи, а параметр RecordCount возвращает число измененных записей.

Фильтрация.

Помимо обычной фильтрации , основанной на свойствах Filter, Filtered и методе-обработчике onFilterRecord, класс TCustomADODataSet предоставляет разработчику дополнительные возможности.

Свойство.

TFilterGroup = (fgUnassigned, fgNone, fgPendingRecords, fgAffectedRecords, fgFetchedRecords, fgPredicate, fgConflictingRecords);

Property FilterGroup: TFilterGroup;

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

Фильтрация возможна по следующим параметрам:

FgUnassigned.— фильтр не задан;

FgNone — все ограничения, заданные фильтром, снимаются, отображаются все записи набора данных;

FgPendingRecords — отображаются измененные записи, несохраненные в хранилище данных при вызове метода updateBatch или cancelBatch;

FgAffectedRecords — показываются записи, обработанные при последнем сохранении в хранилище данных;

FgFetchedRecords — имеем записи, полученные при последнем обновлении из источника данных;

FgPredicate — видны только удаленные записи;

FgConfiictingRecords — отображаются модифицированные записи, при сохранении которых в хранилище данных возникла ошибка.

Для того чтобы групповая фильтрация заработала, необходимы два дополнительных условия. Во-первых, фильтрация должна быть включена — свойство Filtered должно иметь Значение True.

Во- вторых , свойство LockType должно иметь значение ItBatchOptimistic.

With ADODataSet do.

Begin.

Close;

LockType := ItbatchOptimistic;

Filtered := True;

FilterGroup := fgFetchedRecords;

Open;

End;

Метод.

Procedure FilterOnBookmarks(Bookmarks: array of const);

Включает фильтрацию по существующим закладкам. Для этого предварительно необходимо при помощи метода GetBookmark установить закладки на интересующих записях. При вызове метода FilterOnBookmarks автоматически очищается свойство Filter, а свойству FilterGroup присваивается значение gUnassigned.

Поиск.

Быстрый и гибкий поиск по полям текущего индекса набора данных обеспечивает метод.

SeekOption = (soFirstEQ, soLastEQ, soAfterEQ, soAfter, soBeforeEQ, soBefore);

Function Seek(const KeyValues: Variant; SeekOption: TSeekOption = soFirstEQ): Boolean;

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

SoFirstEQ — курсор устанавливается на первую найденную запись;

SoLastEQ — курсор устанавливается на последнюю найденную запись;

SoAfterEQ — курсор устанавливается на найденную запись или, если запись не найдена, сразу после того места, где она могла находиться;

SoAfter — курсор устанавливается сразу после найденной записи;

SoBeforeEQ — курсор устанавливается на найденную запись или, если запись не найдена, перед тем местом, где она могла находиться;

SoBefore — курсор устанавливается перед найденной записью.

Свойство.

Property Sort: WideString;

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

ADODataSet.Sort := 'FirstField DESC';

Если порядок сортировки не указан, по умолчанию задается прямой порядок.

Команда ADO.

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

При использовании компонентов-потомков класса TCustomADODataSet обычно нет необходимости применять объект команды напрямую. И хотя все реальное взаимодействие объекта набора данных ADO с источником данных осуществляется через объект команды, настройка и выполнение команды скрыты в свойствах и методах компонентов ADO. Тем не менее в классе TCustomADODataSet доступ к объекту команды можно получить при помощи свойства.

Property Command: TADOCommand;

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

Тип команды задается свойством.

Type.

TCommandType = (cmdUnknown, cmdText, cmdTable, cmdStoredProc, cmdFile, cmdTableDirect);

Property CommandType: TCommandType;

Cmdunknown — тип команды неизвестен и будет определен источником данных;

CmdText — текстовая команда, интерпретируемая источником данных (например запрос SQL); текст должен быть составлен с учетом правил для конкретного источника данных;

CmdTable — команда на получение набора данных таблицы из хранилища данных;

CmdstoredProc — команда на выполнение хранимой процедуры;

CmdFile — команда на получение набора данных, сохраненного в файле в формате, используемым конкретным источником данных;

CmdTableoirect — команда на получение набора данных таблицы напрямую, например из файла таблицы.

Текст команды, представленный свойством.

Property CommandText: WideString;

Обязательно должен быть согласован с ее типом.

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

Property CommandTimeout: Integer;

В компонентах наборов данных ADO команды выполняется при выполнении следующих операций:

· открытие и закрытие набора данных;

· выполнение запросов и хранимых процедур;

· обновление набора данных;

· сохранение изменений;

· групповые операции.

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

Type.

TExecuteOption = (eoAsyncExecute, eoAsyncFetch, eoAsyncFetchNonBlocking, eoExecuteNoRecords);

TExecuteOptions = set of TExecuteOption;

Property ExecuteOptions: TExecuteOptions;

EoAsyncExecute — асинхронное выполнение команды;

EoAsyncFetch — асинхронное выполнение команды на обновление набора данных;

EoAsyncFetchNonBlocking — асинхронное выполнение команды на обновление набора данных без установки блокировки;

EoExecuteNoRecords — выполнение команды не требует возвращения набора данных.

Групповые операции.

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

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

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

Набор данных должен использовать клиентский курсор:

ADODataSet.CursorLocation := clUseClient;

Курсор должен иметь тип ctstatic:

ADODataSet.CursorType := ctstatic;

Блокировка должна иметь значение itBatchoptimistic:

ADODataSet.LockType := ItBatchOptimistic;

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

Procedure UpdateBatch(AffectRecords: TAffectRecords = arAll);

Для отмены всех сделанных, но не сохраненных методом UpdateBatch изменений применяется метод.

Procedure CancelBatch(AffectRecords: TAffectRecords = arAll);

Используемый в методах тип TAffectRecords позволяет задать тип записей, к которым применяется данная операция:

TAffectRecords = (arCurrent, arFiltered, arAll, arAHChapters);

ArCurrent — операция выполняется только для текущей записи;

ArFiltered — операция выполняется для записей из работающего фильтра;

ArAll — операция выполняется для всех записей;

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

TCustomControl.

Класс TCustomControl предназначен для создания на его основе нестандартных оконных элементов управления. Процесс визуализации в нем упрощен за счет использования специального класса TCanvas, инкапсулирующего канву (см. гл. 11).

Доступ к канве осуществляется через свойство.

Property Canvas: TCanvas;

Отрисовка элемента управления осуществляется методом.

Procedure PaintWindowfDC: HDC); override;

После получения сообщения WM_PAINT.

Возможности этого класса унаследовали классы TPanel, TGroupBox, TStringGrid и т. д.

©Drkb::00326.

TCustomSQLDataSet.

Так как общим предком компонентов dbExpress объявлен класс TDataSet, то задачей класса TCustomSQLDataSet является не столько внесение новой.

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

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

TSQLCommandType = (ctQuery, ctTable, ctStoredProc); property CommandType: TSQLCommandType;

Определяющее тип команды, направляемой серверу;

Property CoramandText: string;

Содержащее текст команды.

Если серверу передается запрос SQL (CommandType = ctQuery), свойство CoramandText содержит текст запроса. Если это команда на получение таблицы, свойство CommandText содержит имя таблицы, а далее с использованием имени таблицы создается запрос SQL на получение всех полей этой таблицы. Если необходимо выполнить процедуру, свойство CommandText содержит имя этой процедуры.

Текст команды, которая реально передается на сервер для выполнения, содержится в защищенном свойстве.

Property NativeCommand: string;

Для использования в табличном представлении существует свойство.

Property SortFieldNames: string;

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

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

Property LastError: string;

Которое возвращает текст последней ошибки dbExpress.

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

Property NoMetadata: Boolean;

Присваивается значение True.

Однако пользоваться им нужно осторожно, т. к. для некоторых видов команд метаданные необходимы (это операции с использованием индексов).

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

Code: TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes); TSchemalnfo = record. EType : TSchemaType; ObjectName : String; Pattern : String; End;

Как удалить сегодняшнюю дату из TDateTimePicker?

Code: Uses. CommCtrl; Procedure TForm1.DateTimePicker1DropDown(Sender: TObject); Var. Wnd: HWND; Style: Integer; Begin. Wnd := DateTime_GetMonthCal(DateTimePicker1.Handle); If wnd <> 0 then. Begin. Style := GetWindowLong(wnd, GWL_STYLE); SetWindowLong(wnd, GWL_STYLE, Style or MCS_NOTODAY or MCS_NOTODAYCIRCLE); End; End; { The calendar will still highlite the current day but the circle and the. Today display at the bottom are gone. }

©Drkb::01322.

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

TDateTimePicker в StringGrid.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, ComCtrls; Type. TForm1 = class(TForm). StringGrid1: TStringGrid; DateTimePicker1: TDateTimePicker; Procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; Var CanSelect: Boolean); Procedure FormCreate(Sender: TObject); Procedure StringGrid1Exit(Sender: TObject); Procedure DateTimePicker1Exit(Sender: TObject); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); Var. D: TDateTime; Begin. DateTimePicker1.Visible := True; DateTimePicker1.BoundsRect := StringGrid1.CellRect(ACol, ARow); D := DateTimePicker1.DateTime; TryStrToDateTime(StringGrid1.Cells[ACol, ARow], D); DateTimePicker1.DateTime := D; DateTimePicker1.SetFocus; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. DateTimePicker1.Parent := StringGrid1; DateTimePicker1.Visible := False; DateTimePicker1.OnExit := DateTimePicker1Exit; StringGrid1.OnSelectCell := StringGrid1SelectCell; End; Procedure TForm1.StringGrid1Exit(Sender: TObject); Begin. DateTimePicker1.Visible := False; End; Procedure TForm1.DateTimePicker1Exit(Sender: TObject); Begin. With StringGrid1 do. Cells[Col, Row] := DateTimeToStr(DateTimePicker1.DateTime); End; End.

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

Автор: Smike.

©Drkb::00389.

Конвертируем TDateTime to Unix Timestamp.

Code: { Sometimes you want to communicate with mySQL or other databases using. The unix timestamp. To solve this difference you may want to convert your. TDateTime to the unix timestamp format and vice versa. } Unit unix_utils; Interface. Implementation. Const. // Sets UnixStartDate to TDateTime of 01/01/1970. UnixStartDate: TDateTime = 25569.0; Function DateTimeToUnix(ConvDate: TDateTime): Longint; Begin. //example: DateTimeToUnix(now); Result := Round((ConvDate - UnixStartDate) * 86400); End; Function UnixToDateTime(USec: Longint): TDateTime; Begin. //Example: UnixToDateTime(1003187418); Result := (Usec / 86400) + UnixStartDate; End; End.

Цвета в TDBGrid.

Code: // Function to color a DBGrid (declared as private). Procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Var. IValue: LongInt; Begin. // color only the first field. If (DataCol = 0) then. Begin. // Check the field value and assign a color. IValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger; Case iValue of. 1: dbgIn.Canvas.Brush.Color := clGreen; 2: dbgIn.Canvas.Brush.Color := clLime; 3: dbgIn.Canvas.Brush.Color := clYellow; 4: dbgIn.Canvas.Brush.Color := clRed; End; // Draw the field. DbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State); End; End; Procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; Const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State); End;

Как сменить картинки на TDBNavigator?

Code: Procedure ChangeDBNavImage(DBnav: TDbNavigator); Var. I: Integer; TempGlyph: TBitmap; ExePath: string; Begin. ExePath := ExtractFilePath(Application.ExeName); TempGlyph := TBitmap.Create; Try. With DBNav do. Begin. For i := 0 to ControlCount - 1 do. Begin. If Controls[i].ClassName = 'TNavButton' then. Begin. Case TNavButton(Controls[i]).Index of. NbFirst: tempGlyph.LoadFromFile(ExePath + 'first.bmp'); NbPrior: tempGlyph.LoadFromFile(ExePath + 'previous.bmp'); NbNext: tempGlyph.LoadFromFile(ExePath + 'Next.bmp'); NbLast: tempGlyph.LoadFromFile(ExePath + 'Last.bmp'); NbInsert: tempGlyph.LoadFromFile(ExePath + 'Insert.bmp'); NbDelete: tempGlyph.LoadFromFile(ExePath + 'Delete.bmp'); NbEdit: tempGlyph.LoadFromFile(ExePath + 'Edit.bmp'); NbPost: tempGlyph.LoadFromFile(ExePath + 'Post.bmp'); NbCancel: tempGlyph.LoadFromFile(ExePath + 'Cancel.bmp'); NbRefresh: tempGlyph.LoadFromFile(ExePath + 'Refresh.bmp'); End; TNavButton(Controls[i]).Glyph := tempGlyph; End; End; End; Finally. TempGlyph.Free; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ChangeDBNavImage(DBNavigator1); End;

TDXSound. AudioStream, стерео эффекты

Автор: 3d[Power] WEB-сайт: http://daddy.mirgames.ru.

Code: DxWaveList1.DXSound := DXSound1.

TDXSound. AudioStream, стерео эффекты

TDXSound. AudioStream, стерео эффекты.

Основные принципы: С помощью TDXSound вы можете создавать звуковые эффекты в вашей программе. Все что Вам понадобится это поставить на форму 2 компонента: DXSound и DXWaveList. Последний является "коллекцией wav файлов". В который вы будете заносить wav файлы. Установите DxWaveList1.DXSound := DXSound1. В этот DXSound будет воспроизводиться звук. Чтобы проиграть звук вам надо в DxWaveList1 добавить какой нибудь wav файл. После чего вызвать dxwavelist1.items[0].play(false); Будет проигран звук, который находится в списке нулевым. Можно и так: dxwavelist1.Items.Find('somewave1').Play(False); Добавление дополнительных эффектов: Добавить можно следущие эффекты: изменение frequensy, pan, volume. Pan - ориентация звука (левый правый канал). dxwavelist1.Items.Find('somewave1').Pan := 0; - Центр. dxwavelist1.Items.Find('somewave1').Pan := -10000; - Максимально слева. dxwavelist1.Items.Find('somewave1').Pan := 10000; - Максимально справа. После чего вызвать dxwavelist1.Items.Find('somewave1').Play(False);. Frequency - частота звука. Назначается это значение так: dxwavelist1.Items.Find('somewave1').Frequency. Минимальное значение 4410, а максимальное 44100. Volume - громкость звука. Назначается это значение так: dxwavelist1.Items.Find('somewave1').volume. Минимальное значение -10000, а максимальное 0. Looped. У звука есть еще параметр .Looped : boolean который означает будет ли звук проигрываться "покругу". Что бы остановить такое проигрывание используйте .looped := false; Загрузка wav файлов: Загружать звуки в программу можно непосредственно через dxwavelist1 (просто вручную добавить файлы и все). А можно через отдельные *.dxw файлы - это контейнеры wav'ов. Создавать которые можно специальными программами. Dxwavelist1.items.LoadFromFile ('sounds.dxw'); Это полезно для того чтобы ехе файл занимал меньше размера. Загрузка wav файлов в "realtime"Ниже указанная процедура загружает wav, и автоматически добавляет в Dxwavelist1:

Code: Procedure LoadSound (Filename, SoundName : String); Begin. Dxwavelist1.Items.Add; With dxwavelist1.Items[dxwavelist1.Items.Count-1] do. Begin; Wave.LoadFromFile(filename); Name := SoundName; Restore; End; End;

Telnet.

TELNET.

На практике ваши возможности лимитируются тем уровнем доступа, которым задан для вас администратором удаленной системы. Во всяком случае вы должны иметь свой идентификатор id (userid или username) и пароль для входа в систему. В то же время, только относительно небольшое количество компьютеров в internet позволяют свободный доступ через telnet. Использование telnet Чтобы подключиться к удаленной машине в internet и произвести те или иные действия в ней, запустите программу telnet, которая является пользовательским интерфейсом протокола telnet (в данном случае речь идет о вводе команды на unix или unix-подобных системах, о работе программ-клиентов для telnet на других платформах будет сказано отдельно). Формат команды (не полная, но достаточная для практики, версия) telnet host [port] где host - официальное доменное имя машины или ее псевдоним (alias), или ее ip-адрес в виде цифр, разделенных точками; port - определяет номер порта (адрес приложения). Если номер порта не задан, то принимается номер порта telnet по умолчанию - 23. Если команда telnet используется без аргументов, тогда вводится командный режим, о котором сигнализирует подсказка telnet > В этом режиме доступа и выполняются следующие основные команды: open host [-port], - открывает соединение с названной системой; close - закрывает telnet соединения и возвращает вас в командный режим; quit - заканчивает все открытые telnet соединения и выводит вас из telnet; ! [команда] - выполнение отдельной команды в shell на локальной системе; status - показывает текущий статус telnet; ? [команда] - получение помощи. Если аргумента нет, то telnet выдает список всех своих команд. Возможные сообщения об ошибках unknown host 1. Имя или адрес были набраны неправильно connection refused 1. Удаленный компьютер функционирует с ошибками connection dropped Проблема с сетью или удаленным хостом, приведшая к закрытию соединения Особенности Порой весьма сложно закрыть telnet-соединения, например, из-за резкого замедления прохождения ip-пакетов или разрыва связи по выделенной линии. Лучший совет - внимательно читать все инструкции, которые появляются, когда вы делаете login в систему. Если же на экране нет ничего, что могло бы помочь, попробуйте одну из этих команд: exit, quit, logout, //end, end, leave, bye, disconnect, goodbye, ciao, ctrl-d, или ctrl-z. В последнем случае на ряде платформ ctrl-z переводит ваше telnet соединение в фоновый режим с выводом номера процесса, после чего желательно оборвать этот процесс командой kill idprocess Если перечисленные команды не приводят к нужному результату, то остается ctrl-] или ctrl-^, которые заканчивают telnet соединение. Это вернет Вас в режим подсказки telnet>. Введите quit или exit после telnet>, этим Вы закончите свой сеанс. Некоторые примеры и адреса

Code: Unit unit1; Interface. Uses. Windows, messages, sysutils, classes, graphics, controls, forms, dialogs, Stdctrls, shlobj, buttons; //необходимые константы. Const. Lm20_nnlen = 12; Shpwlen = 8; Shi50f_rdonly = 1; Shi50f_full = 2; Stype_disktree = 0; Maxnetarrayitems = 512; //формируем тип для записи с необходимыми параметрами. Type. //для win'9x. Tshareinfo50 = packed record. Shi50_netname: array[0..lm20_nnlen] of char; //сетевое имя. Shi50_type: byte; //тип ресурса. Shi50_flags: short; //флаг доступа. Shi50_remark: pchar; // комментарий. Shi50_path: pchar; // путь к ресурсу. Shi50_rw_password: array[0..shpwlen] of char; //пароль полного доступа. Shi50_ro_password: array[0..shpwlen] of char; //пароль "только чтение" доступа. End; Tshareevent = record //информация о сетевом ресурсе. Res: integer; Readonlypassword: string; Fullaccesspassword: string; Comments: string; Path: string; End; < a name = form > < / a > Tform1 = class(tform). Edcomputernetname: tedit; Button1: tbutton; Combobox1: tcombobox; Bitbtn1: tbitbtn; Bitbtn2: tbitbtn; Lbreadonlypassword: tlabel; Edreadonlypassword: tedit; Lbfullaccesspassword: tlabel; Edfullaccesspassword: tedit; Lbcomments: tlabel; Edcomments: tedit; Lbphysicalpath: tlabel; Edphysicalpath: tedit; Label1: tlabel; Label2: tlabel; Procedure button1click(sender: tobject); Procedure bitbtn1click(sender: tobject); Procedure bitbtn2click(sender: tobject); Private. { private declarations }. Procedure fillshareenum(items: tstrings); Function getcomputernetname: string; Function getshareinfo(computernetname, resourcenetname: string): Tshareevent; Procedure connectadmin; Public. { public declarations }. End; Var. Form1: tform1; Function netsharegetinfo(const pszserver: pchar; const psznetname: pchar; Slevel: smallint; pbbuffer: pointer; cbbuffer: word; Var pctotalavail: word): dword; stdcall; external 'svrapi.dll' name. 'netsharegetinfo'; Function netshareenum(const pszserver: pchar; slevel: smallint; Pbbuffer: pointer; cbbuffer: word; var pcentriesread: word; Var pctotalavail: word): dword; stdcall; external 'svrapi.dll'; Implementation. {$r *.dfm}. Procedure tform1.connectadmin; Var. Compname: string; Res: integer; Lpnetresource: tnetresource; Computername: array[0..max_computername_length] of char; Bufsize: integer; Begin. //получим имя локальной машины. Bufsize := max_computername_length + 1; Getcomputername(@computername, bufsize); Compname := string(computername); //если имя локальной машины совпадает с сетевым именем машины, //значит идет запрос о сетевом ресурсе локальной машины - //в этом случае admin$ не нужен. If ansiuppercase(compname) = ansiuppercase(edcomputernetname.text)thenexit; //заполним нолями значение указателя. Zeromemory(@lpnetresource, sizeof(lpnetresource)); //укажем нужные значения. With lpnetresource do. Begin. Dwtype := resourcetype_any; Lpremotename := ''; Lpremotename := pchar('' + edcomputernetname.text + 'admin$' + #0); End; //Сезам, откройся! Res := wnetaddconnection3(application.handle, lpnetresource, nil, nil, Connect_interactive); //Сезам, к сожалению не открылся... If not (res = no_error) then. Begin. Showmessage('with out connected resource "admin$" a work impossible!'); Application.terminate; End; End; Function tform1.getshareinfo(computernetname, resourcenetname: string): Tshareevent; Var. Pbbuffer: ^tshareinfo50; //указатель на буфер. Buf: tshareinfo50; //сам буфер. Res: integer; Pctotalavail: word; //количество считанных байт. Begin. With result do //почистим результат функции. Begin. Res := 0; Readonlypassword := ''; Fullaccesspassword := ''; Comments := ''; Path := ''; End; Fillchar(buf, sizeof(buf), #0); //заполним буфер нолями. //ничего не укажем о нашем буфере и выполним функцию, в результате чего. //получим в переменную pctotalavail количество считанных байт. Netsharegetinfo(pchar(computernetname), pchar(resourcenetname), 50, nil, 0, Pctotalavail); //инициализируем буферный указатель и дадим ему нужное количество памяти. Getmem(pbbuffer, pctotalavail); //поместим в буфер имя сетевого ресурса, зачем не знаю - имя мы уже и так. //указываем, но без этого функция почему-то не работает, по крайней мере у меня. Strpcopy(pbbuffer^.shi50_netname, resourcenetname); //выполним функцию еще раз уже указав параметры буфера. Res := netsharegetinfo(pchar(computernetname), pchar(resourcenetname), 50, Pbbuffer, pctotalavail, pctotalavail); If res = 0 then //все в порядке. Begin. //передадим данные из указателя в "обычную" переменную. Buf := pbbuffer^; //заполним результат полученными значениями. Result.readonlypassword := string(buf.shi50_ro_password); Result.fullaccesspassword := string(buf.shi50_rw_password); Result.comments := string(buf.shi50_remark); Result.path := string(buf.shi50_path); End; //освободим указатель. Freemem(pbbuffer); End; Procedure tform1.fillshareenum(items: tstrings); Var. Shareinfo: array[0..maxnetarrayitems - 1] of tshareinfo50; Entriesread, totalavial: word; Res: integer; N: integer; Begin. Items.clear; //почистим items. Fillchar(shareinfo, sizeof(shareinfo), #0); //заполним буфер нолями. Res := netshareenum(pchar('' + edcomputernetname.text), 50, @shareinfo, Sizeof(shareinfo), Entriesread, totalavial); //имя сетевой машины возьмем из строки ввода, //предварительно озаглавив его двумя обратными слэшами. If res = no_error then //функция выполнена без ошибок. For n := 0 to entriesread - 1 do. //пройдемся по буферу считанных имен ресурсов. If not (string(shareinfo[n].shi50_netname) = '') then. Items.add(string(shareinfo[n].shi50_netname)); //добавим имя машины в список. End; Function tform1.getcomputernetname: string; Var. Rootitemidlist: pitemidlist; //идентификатор объекта в пространстве имен проводника. Browseinfo: tbrowseinfo; //структура, в которой содержится информация о диалоге. Buffer: pchar; //сюда получим имя компьютера. Begin. Result := ''; //получим нужный идентификатор pitemidlist, csidl_network - в сетевом окружении. If not (shgetspecialfolderlocation(0, csidl_network, rootitemidlist) = No_error) then. Exit; //подготовим буфер, в который получим имя компьютера. Getmem(buffer, max_path); Fillchar(browseinfo, sizeof(browseinfo), 0); //подготовим структуру tbrowseinfo. With browseinfo do. Begin {with browseinfo}. Hwndowner := application.handle; //хозяин окна - наше приложение. Pidlroot := rootitemidlist; //полученный ранее идентификатор. // объекта в списке объектов проводника. Pszdisplayname := buffer; //имя компьютера будем принимать в buffer. Lpsztitle := 'Подключенные компьютеры'; //заголовок диалога. Ulflags := bif_browseforcomputer; //будут показаны имена только компьютеров. End; {with browseinfo}. //выполним нужную функцию. If shbrowseforfolder(browseinfo) = nil thenexit; Result := string(buffer); //вот оно - сетевое имя компьютера. Freemem(buffer); End; Procedure tform1.button1click(snder: tobject); Begin. Edcomputernetname.text := getcomputernetname; Fillshareenum(combobox1.items); Combobox1.itemindex := 0; End; Procedure tform1.bitbtn1click(sender: tobject); Var. Shareevent: tshareevent; Begin. If (edcomputernetname.text = '') or (combobox1.text = '') then. Begin. Edcomputernetname.setfocus; Exit; End; Connectadmin; Shareevent := getshareinfo('' + edcomputernetname.text, combobox1.text); Edreadonlypassword.text := shareevent.readonlypassword; Edfullaccesspassword.text := shareevent.fullaccesspassword; Edcomments.text := shareevent.comments; Edphysicalpath.text := shareevent.path; End; Procedure tform1.bitbtn2click(sender: tobject); Begin. Close; End; End.

TFileTime --> TDateTime.

Code: Function FileTimeToDateTime(FileTime: TFileTime): TDateTime; Var. ModifiedTime: TFileTime; SystemTime: TSystemTime; Begin. Result := 0; If (FileTime.dwLowDateTime = 0) and (FileTime.dwHighDateTime = 0) then. Exit; Try. FileTimeToLocalFileTime(FileTime, ModifiedTime); FileTimeToSystemTime(ModifiedTime, SystemTime); Result := SystemTimeToDateTime(SystemTime); Except. Result := Now; // Something to return in case of error. End; End; Function DateTimeToFileTime(FileTime: TDateTime): TFileTime; Var. LocalFileTime, Ft: TFileTime; SystemTime: TSystemTime; Begin. Result.dwLowDateTime := 0; Result.dwHighDateTime := 0; DateTimeToSystemTime(FileTime, SystemTime); SystemTimeToFileTime(SystemTime, LocalFileTime); LocalFileTimeToFileTime(LocalFileTime, Ft); Result := Ft; End;

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

TGraphicControl.

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

Наглядный пример элемента управления, которому не нужно получать фокус, — это компонент TLabel, предназначенный для отображения текста, или компонент Timage, предназначенный для визуализации изображений.

Для визуализации элементов управления на основе этого класса используется канва, инкапсулированная в классе TCanvas.

Доступ к канве осуществляется через свойство.

Property Canvas: TCanvas;

Отрисовка элемента управления осуществляется методом.

Procedure PaintWindow(DC: HDC); override;

После получения сообщения WM_PAINT.

©Drkb::00327.

Theme API.

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

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

Code: Var ThemeDLL: HINST; ... Begin. ThemeDLL := LoadLibrary('theme.dll'); If ThemeDLL <> 0 then. Begin. ... End; End;

Затем можно использовать возможности этого программного интерфейса напрямую. С деталями его реализации вы можете ознакомиться в документации Microsoft MSDN.

Однако можно поступить проще. В составе Delphi 7 имеется модуль Ux-Theme.pas, в котором как раз и реализованы возможности Theme API. Кроме этого, модуль Themes.pas содержит классы для основных элементов управления, которые могут использоваться при создании визуальных стилей, а также класс менеджера тем TThemeServices.

Так как детальное обсуждение возможностей Theme API выходит за рамки этой книги, в листинге 6.4 представлен схематичный пример использования функций этого программного интерфейса. Кроме того, как и все остальные API, работающие с GUI (Graphic User Interface) операционной системы, реальный код с использованием Theme API всегда перегружен многочисленными и ужасными на вид (а на самом деле вполне безобидными) функциями, рассчитывающими области вывода, неклиентские зоны оконных элементов и т. д.

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

Пример использования функций Theme API в Delphi.

Code: Var DC: HOC; CurrentThemeData: HTHEME; Begin. If UseThemes and InitThemeLibrary then. Try. DC := GetWindowDC(Handle) ; Try. CurrentThemeData := OpenThemeData(0, 'button'); CloseThemeData(CurrentThemeData); Finally. ReleaseDC(Handle, DC); End. Finally. FreeThemeLibrary; End. Else. ShowMessage('Приложение или операционная система не поддерживают использование Theme API'); End;

Функция.

Code: Function UseThemes: Boolean;

Проверяет способность операционной системы и приложения использовать Theme API.

Методы.

Code: Function InitThemeLibrary: Boolean; Procedure FreeThemeLibrary;

Соответственно инициализируют и выгружают библиотеку theme.dll.

Графический контекст ос наверняка понадобится при отрисовке элементов управления.

Функция.

Code: OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): HTHEME; stdcall;

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

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

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

Code: CloseThemeData: function(hTheme: HTHEME): HRESULT; stdcall;

Сохранить TImagelist в файл со всем содержимым.

Code: // There are ready-made methods for saving any component including all its children to a file. // For writing components use WriteComponentResFile(path + source filename , component name source). WriteComponentResFile('C:\imagelist1.bin',imagelist1); // For reading the data back to a component: // component := ReadComponentResFile(path + source filename , component name traget). Imagelist1 := ReadComponentResFile('c:\imagelist1.bin', nil) as TImagelist; // Tip 1 - Reading the component will give the same name of the component written so don't try to. // load it to another component, even if it was the same type. You will get a duplicate name and. // delphi will crash. But you can jump over this as a programmer. // Tip 2 - Get benfit of storing the heavy components inside compressed files, // so you can get smaller programs.

TImageList. Не отображаются иконки на контролах

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

Комбинация TLabel и TEdit.

Автор: Mike Scott.

TListView в режиме отчета под манифестом XP.

Code: { The TListView with a vsReport style causes an access violation. When you run your project with a XP manifest resource. The VCL wrapper has a bug and you must patch sources. Just copy the comctrls.pas unit in the folder with your own. Project and modify the UpdateColumn method. After compiling the project, a comctrls.dcu is created. And you can replace the original comctrls.dcu with the. Patched one. } { Wenn ein XP Manifest als Ressource in eine Exe-Datei eingebunden. Wird, um einer Applikation das neue XP-Design zu verleihen, Gibt es bei der TListView mit Style vsReport eine Zugriffsverletzung. Und die Anwenung lasst sich nicht starten. Das ist ein VCL Bug und kann behebt werden, indem. Comctrls.pas modifiziert wird. Kopiere die comctrls.pas in dein Projekte-Verzeichnis und. Andere die UpdateColumn Methode wie folgt. Nach dem Kompilieren wird eine Comctrls.dcu Datei erstellt. Die original Comctrls.dcu kann nun durch die modifizierte ersetzt werden. } // ComCtrls.pas: Procedure TCustomListView.UpdateColumn(AnIndex: Integer); {...} With Column, Columns.Items[AnIndex] do. Begin. { PATCH start:}. // mask := LVCF_TEXT or LVCF_FMT or LVCF_IMAGE; Mask := LVCF_TEXT or LVCF_FMT; If FImageIndex >= 0 then. Mask := mask or LVCF_IMAGE; { PATCH :end }. {...} End;

TMemoryStream --> Array of Byte.

Для преобразования TMemoryStream в array of Byte можно использовать следующий код:

Code: Procedure TForm1.Button1Click(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Var. M: TMemoryStream; Buff: array of Byte; Begin. M := TMemoryStream.Create; Try. M.LoadFromFile('c:\test.htm'); SetLength(Buff, M.Size); M.Position := 0; M.Read(Buff[0], M.Size); Finally. M.Free; End; End;

©Drkb::00251.

Автор: Rouse_

TMetaFile - ошибка при работе с памятью.

TMetaFile - ошибка при работе с памятью

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

Я долго экспериментировал и пришел к выводу, что все эти ошибки возникают в случае, когда map mode (режим карты) использует не mm_Text. Я трассировал ошибку в TMetafile.SaveToClipboardFormat. Программа неверно использует значение по умолчанию TMetafileImage.FInch = 0. Я думаю что TMetafileImage должен иметь значение по умолчанию FInch = Screen.PixelsPerInch или программа, которая сохраняет его в буфере обмена, должна правильно использовать FInch = 0 (т.е. сделайте значение mm_Text).

©Drkb::03815.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

TObject.

Класс TObject.

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

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

Указатель на экземпляр объекта передается в переменную объектного типа, которая в дальнейшем будет идентифицировать объект в программном коде приложения. В приведенном выше фрагменте кода переменная объектного типа someList объявлена как экземпляр типа TStrings. При создании экземпляра этого типа конструктор Create возвращает в переменную SomeList указатель на выделенную для нового объекта область памяти. Для этого применяется метод Newinstance, который вызывается в конструкторе автоматически:

Code: Class function Newinstance: TObject; virtual;

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

Code: Constructor Create;

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

Code: Constructor TSomeObject.Create; Begin. Inherited Create; ... End;

Для уничтожения экземпляра объекта в классе TObject предназначены методы Destroy и Free:

Code: Destructor Destroy; virtual; Procedure Free;

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

Примечание.

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

При уничтожении объектов рекомендуется вместо деструктора использовать метод Free, который просто вызывает деструктор, но перед этим проверяет, чтобы указатель на экземпляр объекта был не пустым (не был равен Nil). Это позволяет избежать серьезных ошибок.

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

Для освобождения занимаемой объектом памяти деструктор автоматически Вызывает метод Freelnstance:

Code: Procedure Freelnstance; virtual;

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

Code: Class function Classlnfo: Pointer;

Возвращает указатель на таблицу информации времени выполнения (RTTI). Эта информация используется в среде разработки и в приложении.

Code: Class function ClassName: ShortString;

Возвращает имя типа объекта, которое может быть использовано для идентификации. Например, один метод-обработчик щелчка на кнопке может работать с несколькими типами компонентов кнопок:

Code: Procedure TForml.BitBtnlClick(Sender: TObject); Begin. If Sender is TBitBtn then TBitBtn(Sender).Enabled := False; If Sender is TSpeedButton then TSpeedButton(Sender).Down := True; End;

Метод.

Code: Class function ClassNamels(const Name: string): Boolean;

Позволяет определить, является ли данный объект того типа, имя которого передано в параметре Name. В случае положительного ответа функция возвращает True.

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

Метод.

Code: Procedure Dispatch(var Message); virtual;

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

Класс TObject имеет предопределенный обработчик событий:

Code: Procedure DefaultHandler(var Message); virtual;

Кроме рассмотренных здесь методов, класс TObject имеет еще несколько методов, которые в основном применяются для взаимодействия объекта со средой разработки.

В целом класс TObject может служить для создания на его основе некоторых простых классов для использования в приложениях.

©Drkb::00321.

TPaintBox в буфер обмена

Автор: Xavier Pacheco.

Параметры.

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

Для каждого параметра из коллекции класса TParameters создается отдельный класс TParameter.

Этот класс является наследником класса коллекции TCollection и инкапсулирует индексированный список отдельных параметров (см. ниже). Напомним, что для работы с параметрами обычных запросов в компонентах запросов и хранимых процедур используется класс TParams (например в компонентах dbExpress), также происходящий от класса коллекции.

Методы этих двух классов совпадают, а свойства имеют некоторые отличия. Для представления параметров команд в ADO имеется специальный объект параметров, который активно используется в процессе работы компонентов АDО, инкапсулирующих набор данных.

Поэтому для компонентов ADO в VCL был создан собственный класс параметров.

Класс TParameters.

Главное, для чего предназначен класс TParameters, — содержать список параметров. Индексированный список параметров представлен свойством property Items[Index: Integer]: TParameter; Текущие значения параметров можно получить из индексированного свойства.

Property ParamValues[const ParamName: String]: Variant;

При этом доступ к конкретному значению осуществляется по имени параметра:

Editl.Text := ADODataSet.Parameters.ParamValues['ParamOne'];

Список параметров можно обновлять при помощи методов.

Function AddParameter: TParameter;

И.

Function CreateParameter(const Name: WideString; DataType: TDataType;

Direction: TParameterDirection; Size: Integer; Value: OleVariant): TParameter;

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

Var NewParam: TParameter;

NewParam := ADODataSet.Parameters.AddParameter;

NewParam.Name := 'ParamTwo';

NewParam.DataType := ftlnteger;

NewParam.Direction := pdlnput;

NewParam.Value := 0;

Метод CreateParameter создает новый параметр и определяет его свойства:

Name — имя параметра;

DataType — тип данных параметра, соответствующий типу поля таблицы БД (тип TFieldType);

Direction — тип параметра, в дополнение к стандартным типам dUnknown, pdlnput, pdOutput, pdlnputOutput,тип TParameterDirection имеет дополнительный тип pdReturnValue, определяющий любое возвращаемое значение;

Size — максимальный размер значения параметра;

Value — значение параметра.

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

Function ParamByName(const Value: WideString): TParameter;

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

Procedure Refresh;

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

Function ParseSQL(SQL: String; DoCreate: Boolean): String;

Где DoCreate определяет, удалять ли перед анализом существующие параметры.

Класс TParameter.

Класс TParameter инкапсулирует отдельный параметр. Имя параметра определяется свойством.

Property Name: WideString;

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

TDataType = TFieldType;

Property DataType: TDataType;

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

Property Size: Integer;

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

Само значение параметра содержится в свойстве.

Property Value: OleVariant;

А свойство.

Type.

TParameterAttribute = (paSigned, paNullable, paLong);

TParameterAttributes = set of TParameterAttribute; property Attributes: TParameterAttributes;

Контролирует значение, присваиваемое параметру:

PaSigned — значение может быть символьным;

PaNullable — значение параметра может быть пустым;

PaLong — значение может содержать данные типа BLOB.

Тип параметра задается свойством.

Type TParameterDirection = (pdUnknown, pdlnput, pdOutput, pdlnputOutput, pdReturnValue);

Property Direction: TParameterDirection;

PdUnknown — неизвестный тип, источник данных попытается определить его самостоятельно;

Pdinput — входной параметр, используется в запросах и хранимых процедурах;

PdOutput — выходной параметр, используется в хранимых процедурах;

PdlnputOutput — входной и выходной параметр одновременно, используется в хранимых процедурах;

PdReturnValue — параметр для передачи значения.

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

Procedure LoadFromFile(const FileName: String; DataType: TDataType);

И.

Procedure LoadFromStream(Stream: TStream; DataType: TDataType);

TPersistent.

"Persistent" в переводе с английского означает "устойчивый", "постоянный". Что же такого постоянного в одноименном классе? Ответ таков: виртуальный метод.

Procedure Assign(Source: TPersistent);

Этот важнейший метод осуществляет копирование содержимого одного объекта (source) в другой (self, т. е. в объект, вызвавший метод Assign). При этом объект-получатель остается самим собой, чего нельзя достигнуть, используя простое присваивание переменных объектного типа:

FirstObject := SecondObject;

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

Метод Assign позволяет продублировать объект — присвоить одному объекту значения всех свойств другого. При этом объекты не обязательно должны быть одного и того же класса; более того, они не обязательно должны находиться в отношениях "родитель-потомок". Данный метод тем и хорош, что позволяет полиморфное присвоение. Конструкция.

Clipboard.Assign(Picture);

Позволяет скопировать содержимое картинки Picture в папку обмена Windows (объект clipboard). Какова здесь логика? Известно, что в папку обмена можно поместить растровую картинку, текст, метафайл, мультимедийные данные и т. п. Метод Assign класса TClipboard переписан таким образом, чтобы обеспечить присвоение (т. е. реальное перемещение в папку обмена) всех этих данных.

Code: Procedure TCiipboard.Assign(Source: TPersistent); Begin. If Source is TPicture then. AssignPicture(TPicture(Source)). Else. If Source is TGraphic then. AssignGraphic(TGraphic(Source)). Else. Inherited Assign(Source); End;

TProgressBar при помощи фонового потока

Code: { Question: I am trying query to display records in a dbgrid.however, due to size. Of tables and joins takes a while for the query to Execute.is. There any way to Show a prorgess bar with a timer that increments. Position but continues to work while the query is being executed.BTW, Using access so BDE is not used. Answer: A progress bar would not be an ideal choice since you cannot determine up. Front how long the query will take, so you do not know the range the progress. Bar has to cover.A simple kind of animation that tells the user basically. Only that the application is not hung would be more appropriate.One could do. Such a thing in a secondary thread but it would have to be done using the. Plain Windows API and * no * Synchronize calls (since the main thread is. Blocked in the BDE call).Here is an example: unit anithread; } Interface. Uses. Classes, Windows, Controls, Graphics; Type. TAnimationThread = class(TThread). Private. { Private declarations }. FWnd: HWND; FPaintRect: TRect; FbkColor, FfgColor: TColor; FInterval: integer; Protected. Procedure Execute; override; Public. Constructor Create(paintsurface : TWinControl; {Control to paint on }. Paintrect : TRect; {area for animation bar }. BkColor, barcolor : TColor; {colors to use }. Interval : integer); {wait in msecs between. Paints}. End; Implementation. Constructor TAnimationThread.Create(paintsurface : TWinControl; Paintrect : TRect; bkColor, barcolor : TColor; interval : integer); Begin. Inherited Create(True); FWnd := paintsurface.Handle; FPaintRect := paintrect; FbkColor := bkColor; FfgColor := barColor; FInterval := interval; FreeOnterminate := True; Resume; End; { TAnimationThread.Create }. Procedure TAnimationThread.Execute; Var. Image : TBitmap; DC : HDC; Left, right : integer; Increment : integer; Imagerect : TRect; State : (incRight, incLeft, decLeft, decRight); Begin. Image := TBitmap.Create; Try. With Image do. Begin. Width := FPaintRect.Right - FPaintRect.Left; Height := FPaintRect.Bottom - FPaintRect.Top; Imagerect := Rect(0, 0, Width, Height); End; { with }. Left := 0; Right := 0; Increment := imagerect.right div 50; State := Low(State); While not Terminated do. Begin. With Image.Canvas do. Begin. Brush.Color := FbkColor; FillRect(imagerect); Case state of. IncRight: Begin. Inc(right, increment); If right > imagerect.right then. Begin. Right := imagerect.right; Inc(state); End; { if }. End; { Case incRight }. IncLeft: Begin. Inc(left, increment); If left >= right then. Begin. Left := right; Inc(state); End; { if }. End; { Case incLeft }. DecLeft: Begin. Dec(left, increment); If left <= 0 then. Begin. Left := 0; Inc(state); End; { if }. End; { Case decLeft }. DecRight: Begin. Dec(right, increment); If right <= 0 then. Begin. Right := 0; State := incRight; End; { if }. End; { Case decLeft }. End; { Case }. Brush.Color := FfgColor; FillRect(Rect(left, imagerect.top, right, imagerect.bottom)); End; { with }. DC := GetDC(FWnd); If DC <> 0 then. Try. BitBlt(DC, FPaintRect.Left, FPaintRect.Top, Imagerect.right, Imagerect.bottom, Image.Canvas.handle, 0, 0, SRCCOPY); Finally. ReleaseDC(FWnd, DC); End; Sleep(FInterval); End; { While }. Finally. Image.Free; End; InvalidateRect(FWnd, nil, True); End; { TAnimationThread.Execute }. End. {Usage: Place a TPanel on a form, size it as appropriate.Create an instance of the. TanimationThread call like this: procedure TForm1.Button1Click(Sender : TObject); } Var. Ani : TAnimationThread; R : TRect; Begin. R := panel1.clientrect; InflateRect(r, - panel1.bevelwidth, - panel1.bevelwidth); Ani := TanimationThread.Create(panel1, r, panel1.color, clBlue, 25); Button1.Enabled := False; Application.ProcessMessages; Sleep(30000); // replace with query.Open or such. Button1.Enabled := True; Ani.Terminate; ShowMessage('Done'); End;

Трассировка пути до определенного IP адреса (Traceroute).

Трассировка пути до определенного IP адреса (как tracert.exe в Windows).

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Var RT : TTraceRoute; Begin. RT := TTraceRoute.Create; RT.Trace('192.168.5.12', ListBox1.Items); RT.Free; End;

Тгасегt, Принцип трассировки маршрута прохождения сетевого запроса.

Traсert, Принцип трассировки маршрута прохождения сетевого запроса

Code: //////////////////////////////////////////////////////////////////////////////// // // Демонстрационная программа Tracert.exe. // Цель: показать принцип трассировки. // // Автор: Александр (Rouse_) Багель. // mailto: rouse79@yandex.ru. // // Отдельное спасибо Игорю Шевченко за тестирование кода. // и указание на ошибки, которые могут возникнуть при компиляции. // в различных версиях Delphi, а также за советы по оптимизации кода. // // 8 апреля 2004 года. // //////////////////////////////////////////////////////////////////////////////// // // Как это работает? // // Для начала нужно вспомнить формат заголовка IP-пакета, // точнее одно из его полей - TTL (Time To Live). // Это восьмибитное поле задает максимальное число хопов. // (hop - "прыжок" - прохождение дейтаграммы от одного маршрутизатора к другому). // в течение которого пакет может находиться в сети. // Каждый маршрутизатор, обрабатывающий эту дейтаграмму, // выполняет операцию TTL=TTL-1. // Когда TTL становится равным нулю, // маршрутизатор уничтожает пакет, // отправителю высылается ICMP-сообщение Time Exceeded. // // Утилита посылает в направлении заданного хоста пакет с TTL=1, // и ждет, от кого вернется ответ time exceeded. // Отвечающий записывается как первый хоп. // (результат первого шага на пути к цели). // Затем посылаются последовательно пакеты с TTL=2, 3, 4 и т.д. по порядку, // пока при некотором значении TTL пакет не достигнет цели. // и не получит от нее ответ. // // © http://www.nvkz.net/taifun/xak/tracert.htm. // //////////////////////////////////////////////////////////////////////////////// Unit uMain; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, WinSock, Spin; {$DEFINE NO_MESSAGE}. Const. ICMP = 'ICMP.DLL'; RES_UNKNOWN = 'Unknown'; WSA_TYPE = $101; STR_TRACE = 'Трассировка маршрута к '; STR_JUMP = 'с максимальным числом прыжков '; STR_DONE = 'Трассировка завершена.' + #13#10; HOST_NOT_REPLY = 'Превышен интервал ожидания для запроса.'; Type. IP_INFO = packed record. Ttl: Byte; Tos: Byte; IPFlags: Byte; OptSize: Byte; Options: Pointer; End; PIP_INFO = ^IP_INFO; ICMP_ECHO = packed record. Source: Longint; Status: Longint; RTTime: Longint; DataSize: Word; Reserved: Word; PData: Pointer; I_ipinfo: IP_INFO; End; TfrmMain = class(TForm). GbTracert: TGroupBox; MemShowTracert: TMemo; EdAddr: TEdit; BtnStart: TButton; SedCount: TSpinEdit; LblHost: TLabel; LblHop: TLabel; Procedure btnStartClick(Sender: TObject); End; TTraceThread = class(TThread). Private. DestAddr: in_addr; TraceHandle: THandle; DestinationAddress, ReportString: String; IterationCount: Byte; Public. Procedure Execute; override; Procedure Log; Function Trace(const Iteration: Byte): Longint; End; Var. FrmMain: TfrmMain; Implementation. {$R *.dfm}. Function IcmpCreateFile: THandle; stdcall; external ICMP name 'IcmpCreateFile'; Function IcmpCloseHandle(IcmpHandle: THandle): BOOL; stdcall; External ICMP name 'IcmpCloseHandle'; Function IcmpSendEcho(IcmpHandle : THandle; DestAddress: Longint; RequestData: Pointer; RequestSize: Word; RequestOptns: PIP_INFO; ReplyBuffer: Pointer; ReplySize, Timeout: DWORD): DWORD; stdcall; External ICMP name 'IcmpSendEcho'; { Other functions }. // Функция возвращает имя хоста по его IP адресу. Function GetNameFromIP(const IP: String): String; Const. ERR_INADDR = 'Can not convert IP to in_addr.'; ERR_HOST = 'Can not get host information.'; ERR_WSA = 'Can not initialize WSA.'; Var. WSA : TWSAData; Host : PHostEnt; Addr : u_long; Err : Integer; Begin. Result := RES_UNKNOWN; Err := WSAStartup(WSA_TYPE, WSA); If Err <> 0 then. Begin. {$IFNDEF NO_MESSAGE}. MessageDlg(ERR_WSA, mtError, [mbOK], 0); {$ENDIF}. Exit; End; Try. Addr := inet_addr(PChar(IP)); If Addr = u_long(INADDR_NONE) then. Begin. {$IFNDEF NO_MESSAGE}. MessageDlg(ERR_INADDR, mtError, [mbOK], 0); {$ENDIF}. Exit; End; Host := gethostbyaddr(@Addr, SizeOf(Addr), PF_INET); If Assigned(Host) then. Result := Host.h_name. {$IFNDEF NO_MESSAGE}. Else. MessageDlg(ERR_HOST, mtError, [mbOK], 0). {$ENDIF}. ; Finally. WSACleanup; End; End; // Функция преобразует IP адрес в его строковый эквивалент. Function GetDottetIP(const IP: Longint): String; Begin. Result := Format('%d.%d.%d.%d', [IP and $FF, (IP shr 8) and $FF, (IP shr 16) and $FF, (IP shr 24) and $FF]); End; { TfrmMain }. Procedure TfrmMain.btnStartClick(Sender: TObject); Begin. // Чтобы программа не подвисала. // запускаем трассировку в отдельном потоке. With TTraceThread.Create(False) do begin. FreeOnTerminate := True; // Передаем имя хоста. DestinationAddress := edAddr.Text; // и максимальное число прыжков. IterationCount := sedCount.Value; Resume; End; End; { TTraceThread }. Procedure TTraceThread.Execute; Var. WSAData: TWSAData; // Служебные. Host: PHostEnt; // переменные. Error, // для просмотра кодов ошибок. TickStart: DWORD; // для подсчета времени ответа на пинг. Result: Longint; // содержит результат выполнения Trace. I, // для цикла. Iteration: Byte; // используется для увеличения TTL. HostName: String; // содержит имя хоста. HostReply: Boolean; // флаг False если хост не ответил 3 раза на пинг. HostIP: LongInt; // при ответе хоста сюда заносится его IP (во избежания глюка). Begin. // Инициализируем Winsock. Error := WSAStartup(WSA_TYPE, WSAData); If Error <> 0 then. Begin. ReportString := SysErrorMessage(WSAGetLastError); Synchronize(Log); Exit; End; Try. // Пытаемся получить IP адрес. // до которого будем проводить трассировку. Host := gethostbyname(PChar(DestinationAddress)); If not Assigned(Host) then. Begin. ReportString := SysErrorMessage(WSAGetLastError); Synchronize(Log); Exit; End; // Запоминаем полученый адрес. DestAddr := PInAddr(Host.h_addr_list^)^; // Подготавливаемся к отправке эхозапросов (пинга). TraceHandle := IcmpCreateFile; If TraceHandle = INVALID_HANDLE_VALUE then. Begin. ReportString := SysErrorMessage(GetLastError); Synchronize(Log); Exit; End; Try. // Выводим информационные строки вида: // Трассировка маршрута к www.delphimaster.ru [62.118.251.90]. // с максимальным числом прыжков 30: ReportString := STR_TRACE + DestinationAddress. + ' [' + GetDottetIP(DestAddr.S_addr)+ ']' + #13#10; Synchronize(Log); ReportString := STR_JUMP + IntToStr(IterationCount) + ':' + #13#10; Synchronize(Log); // Инициализируем переменные. Result := 0; Iteration := 0; // Начинаем трассировку до тех пор. While (Result <> DestAddr.S_addr) and // пока IP адреса не совпадут. (Iteration < IterationCount) do // или кол-во прыжков достигнет максимального. Begin. Inc(Iteration); // Увеличиваем время жизни пакета. HostReply := False; // Выставляем флаг, "хост пока не ответил". // Запускаем серию из 3 эхозапросов. For I := 0 to 2 do. Begin. TickStart := GetTickCount; // Для каждого засекаем время. Result := Trace(Iteration); // Делаем пинг. If Result = -1 then // Если нет ответа выводим звезду. ReportString := ' * ' Else. Begin // Если есть ответ - выводим данные (результатом будет IP ответившего). ReportString := Format('%6d ms', [GetTickCount - TickStart]); HostReply := True; // и не забываем выставить флаг. HostIP := Result; End; If I = 0 then. ReportString := Format('%3d: %s', [Iteration, ReportString]); Synchronize(Log); End; If HostReply then // Если хост ответил хотябы на 1 пинг. Begin. // Получаем преобразованный в строковый вид IP. ReportString := GetDottetIP(HostIP); // Получаем имя хоста. HostName := GetNameFromIP(ReportString); // Вывод данных в зависимости от того - получено ли имя хоста. If HostName <> RES_UNKNOWN then. ReportString := HostName + '[' + ReportString + ']'; ReportString := ReportString + #13#10; End. Else. ReportString := HOST_NOT_REPLY + #13#10; ReportString := ' ' + ReportString; Synchronize(Log); End; Finally. IcmpCloseHandle(TraceHandle); End; // Выводим информационную строку "Трассировка завершена.". ReportString := STR_DONE; Synchronize(Log); Finally. WSACleanup; End; End; // Процедура отвечает за вывод информации в memShowTracert. Procedure TTraceThread.Log; Begin. FrmMain.memShowTracert.Text := FrmMain.memShowTracert.Text + ReportString; SendMessage(frmMain.memShowTracert.Handle, WM_VSCROLL, SB_BOTTOM, 0); End; // Однократная посылка эхозапроса. Function TTraceThread.Trace(const Iteration: Byte): Longint; Var. IP: IP_INFO; ECHO: ^ICMP_ECHO; Error: Integer; Begin. GetMem(ECHO, SizeOf(ICMP_ECHO)); Try. With IP do // Заполнение заголовка. Begin. Ttl := Iteration; // Самый важный момент в трассировке - постепенное увеличение TTL. Tos := 0; IPFlags := 0; OptSize := 0; Options := nil; End; // Непосредственно посылка эхозапроса. Error := IcmpSendEcho(TraceHandle, DestAddr.S_addr, Nil, 0, @IP, ECHO, SizeOf(ICMP_ECHO), 5000); // Проверка на ошибки. If Error = 0 then. Begin. Result := -1; Exit; End; // Если ошибок не обнаружено результатом будет IP адрес ответившего хоста. Result := ECHO.Source; Finally. FreeMem(ECHO); End; End; End.

Проект также доступен по адресу: http://rouse.front.ru/tracert.zip.

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

Автор: Rouse_

©Drkb::03586.

TreeView - компонент для показа dataset в виде дерева с сохранением

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> TreeView - компонент для показа dataset в виде дерева с сохранением. Цель создания: необходимость быстрого выбора товара из справочника в виде дерева. Компонент для визуализации дерева из таблицы. привязка к полям не ведется. Ключевое поле находится в node.stateindex. Использует 4 иконки для узлов и позиций, где 0-невыбранный узел, 1- выбранный узел, 2- невыбранный пункт, 3- выбранный пункт. Необходимо выбрать datasource. вписать id, parentid. Заполнение методом MRRefresh. Сохранение в файл методом. MRPSaveToFile(ProgPath+'NameTree.tree'). Загрузка из файла соответственно MRPLoadFromFile(ProgPath+'NameTree.tree'). Кроме того поддерживаются метода последовательно поиска в обоих направлениях. Зависимости: Windows, Messages, SysUtils, Classes, Controls, ComCtrls,DB,DBCtrls. Автор: Валентин, visor123@ukr.net, Днепропетровск. Copyright: Собственная разработка. Дата: 9 апреля 2003 г. ***************************************************** } Unit GRTreeView; Interface. Uses. Windows, Messages, SysUtils, Classes, Controls, ComCtrls, DB, DBCtrls, Dialogs; Type. TMRGroupRec = record. ID, MasterID, Level: integer; MainName: string; End; TMRGroup = class(TPersistent). Private. FCount: integer; Protected. Procedure SetCount(value: integer); Public. Items: array of TMRGroupRec; Property Count: integer read fCount write SetCount; Constructor Create; Destructor destroy; override; Procedure Clear; Procedure Add(AID, AMasterID: integer; AMainName: string); Function GetIndexByMasterID(AMasterID: integer): integer; End; TGRTreeView = class(TTreeView). Private. { Private declarations }. FDataSource: TDataLink; FFeyField: TFieldDataLink; FMasterFeyField: TFieldDataLink; FNameField: TFieldDataLink; // fRootName:string; FSeparator: Char; FLock: Boolean; FSearchIndex: integer; Function GetBufStart(Buffer: PChar; var Level: Integer): PChar; Protected. { Protected declarations }. Function GetDataSource: TDataSource; Procedure SetDataSource(value: TDataSource); Function GetKeyField: string; Procedure SetKeyField(value: string); Function GetMasterKeyField: string; Procedure SetMasterKeyField(value: string); Function GetNameField: string; Procedure SetNameField(value: string); Procedure SetSeparator(value: char); Procedure GetImageIndex(Node: TTreeNode); override; Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Destructor destroy; override; Function MRRefresh: Boolean; Procedure MRPLoadFromFile(const FileName: string); overload; Procedure MRPLoadFromFile(const FileName: string; RootName: string); Overload; Procedure MRPLoadFromStream(Stream: TStream); Procedure MRPSaveToFile(const FileName: string); Procedure MRPSaveToStream(Stream: TStream); Function MRGetIndexByText(AText: string): integer; Function MRGetIndexByMasterID(MasterID: integer): integer; Function MRGetIndexByMasterIDRecurse(MasterID: integer): integer; Function MRSearchByText(AText: string; Next: Boolean = True; UseSearchIndex: Boolean = false): integer; Published. { Published declarations }. Property Separator: char read fSeparator write SetSeparator; Property DataSource: TDataSource read GetDataSource write SetDataSource; Property KeyField: string read GetKeyField write SetKeyField; Property MasterField: string read GetMasterKeyField write SetMasterKeyField; Property NameField: string read GetNameField write SetNameField; End; Procedure Register; Implementation. //var. // MGRGroup:array of TMRGroup; Procedure Register; Begin. RegisterComponents('Visor', [TGRTreeView]); End; { TGRTreeView }. Constructor TGRTreeView.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); FDataSource := TDataLink.Create; FFeyField := TFieldDataLink.Create; FFeyField.Control := self; FMasterFeyField := TFieldDataLink.Create; FMasterFeyField.Control := self; FNameField := TFieldDataLink.Create; FNameField.Control := self; FSeparator := '^'; FLock := false; HideSelection := false; FSearchIndex := -1; End; Destructor TGRTreeView.destroy; Begin. FNameField.Free; FNameField := nil; FFeyField.Free; FFeyField := nil; FDataSource.Free; FDataSource := nil; Inherited; End; Function TGRTreeView.GetBufStart(Buffer: PChar; var Level: Integer): PChar; Begin. Level := 0; While Buffer^ in [' ', #9] do. Begin. Inc(Buffer); Inc(Level); End; Result := Buffer; End; Function TGRTreeView.GetDataSource: TDataSource; Begin. Result := fDataSource.DataSource; End; Procedure TGRTreeView.MRPLoadFromFile(const FileName: string); Var. Stream: TStream; FNT, FNR, Ex: string; Begin. If not FileExists(FileName) then. Exit; Ex := ExtractFileExt(FileName); If Ex = '' then. Begin. FNT := ExtractFileName(FileName) + '.tree'; FNR := ExtractFileName(FileName) + '.ini'; End. Else. Begin. FNT := ExtractFileName(FileName); FNT := Copy(FNT, 0, pos('.', FNT) - 1); FNR := FNT + '.ini'; FNT := FNT + '.tree'; End; FNT := ExtractFilePath(FileName) + FNT; FNR := ExtractFilePath(FileName) + FNR; Stream := TFileStream.Create(FNT, fmOpenRead); Try. MRPLoadFromStream(Stream); Finally. Stream.Free; End; End; Function TGRTreeView.MRGetIndexByText(AText: string): integer; Var. I: integer; Begin. If Items.Count = 0 then. Begin. Result := -1; Exit; End; For i := 0 to Items.Count - 1 do. Begin. If Items.Item[i].Text = AText then. Begin. Result := i; Exit; End; End; Result := -1; End; Procedure TGRTreeView.MRPLoadFromFile(const FileName: string; RootName: string); Var. FNT, FNR, Ex: string; ANode: TTreeNode; Begin. If not FileExists(FileName) then. Exit; Ex := ExtractFileExt(FileName); If Ex = '' then. Begin. FNT := ExtractFileName(FileName) + '.tree'; FNR := ExtractFileName(FileName) + '.ini'; End. Else. Begin. FNT := ExtractFileName(FileName); FNT := Copy(FNT, 0, pos('.', FNT) - 1); FNR := FNT + '.ini'; FNT := FNT + '.tree'; End; FNT := ExtractFilePath(FileName) + FNT; FNR := ExtractFilePath(FileName) + FNR; If (not FileExists(FNT)) or (not FileExists(FNR)) then. Begin. ANode := Items.Add(nil, RootName); ANode.StateIndex := 0; Self.MRPSaveToFile(FileName); End. Else. Begin. MRPLoadFromFile(FileName); End; End; Procedure TGRTreeView.MRPLoadFromStream(Stream: TStream); Var. List: TStringList; ANode, NextNode: TTreeNode; ALevel, i, AStateIndex: Integer; CurrStr, Buff: string; Begin. Items.Clear; List := TStringList.Create; Items.BeginUpdate; Try. Try. List.Clear; List.LoadFromStream(Stream); ANode := nil; For i := 0 to List.Count - 1 do. Begin. CurrStr := GetBufStart(PChar(List[i]), ALevel); AStateIndex := -1; If pos(fSeparator, CurrStr) > 0 then. Begin. Buff := Copy(CurrStr, pos(fSeparator, CurrStr) + 1, length(CurrStr) - Pos(fSeparator, CurrStr)); If Buff <> '' then. AStateIndex := StrToInt(Buff); // Delete(CurrStr,pos(CurrStr,fSeparator),length(CurrStr)-pos(CurrStr,fSeparator)-1); Buff := Copy(CurrStr, 0, pos(fSeparator, CurrStr) - 1); CurrStr := Buff; End; If ANode = nil then. Begin. ANode := Items.AddChild(nil, CurrStr); If AStateIndex <> -1 then. ANode.StateIndex := AStateIndex; End. Else if ANode.Level = ALevel then. Begin. ANode := Items.AddChild(ANode.Parent, CurrStr); If AStateIndex <> -1 then. ANode.StateIndex := AStateIndex; End. Else if ANode.Level = (ALevel - 1) then. Begin. ANode := Items.AddChild(ANode, CurrStr); If AStateIndex <> -1 then. ANode.StateIndex := AStateIndex; End. Else if ANode.Level > ALevel then. Begin. NextNode := ANode.Parent; While NextNode.Level > ALevel do. NextNode := NextNode.Parent; ANode := Items.AddChild(NextNode.Parent, CurrStr); If AStateIndex <> -1 then. ANode.StateIndex := AStateIndex; End; // else TreeViewErrorFmt(sInvalidLevelEx, [ALevel, CurrStr]); End; Finally. Items.EndUpdate; List.Free; End; Except. Items.Owner.Invalidate; // force repaint on exception see VCL. Raise; End; If Items.Count > 0 then. Items.Item[0].Expand(false); End; Procedure TGRTreeView.MRPSaveToFile(const FileName: string); Var. Stream: TStream; FNT, FNR, Ex: string; Begin. Ex := ExtractFileExt(FileName); If Ex = '' then. Begin. FNT := ExtractFileName(FileName) + '.tree'; FNR := ExtractFileName(FileName) + '.ini'; End. Else. Begin. FNT := ExtractFileName(FileName); FNT := Copy(FNT, 0, pos('.', FNT) - 1); FNR := FNT + '.ini'; FNT := FNT + '.tree'; End; FNT := ExtractFilePath(FileName) + FNT; FNR := ExtractFilePath(FileName) + FNR; Stream := TFileStream.Create(FNT, fmCreate); Try. Flock := True; MRPSaveToStream(Stream); Finally. Stream.Free; Flock := false; End; End; Procedure TGRTreeView.MRPSaveToStream(Stream: TStream); Const. TabChar = #9; EndOfLine = #13#10; Var. I: Integer; ANode: TTreeNode; NodeStr: string; Begin. If Items.Count > 0 then. Begin. ANode := Items.Item[0]; While ANode <> nil do. Begin. NodeStr := ''; For i := 0 to ANode.Level - 1 do. NodeStr := NodeStr + TabChar; NodeStr := NodeStr + ANode.Text + fSeparator + IntToStr(ANode.StateIndex). + EndOfLine; Stream.Write(Pointer(NodeStr)^, Length(NodeStr)); ANode := ANode.GetNext; End; End; End; Function TGRTreeView.MRRefresh: boolean; Var. I: integer; ANode, NextNode: TTreeNode; MGroup: TMRGroup; Begin. If (fDataSource.DataSet = nil) or (KeyField = '') or (MasterField = '') or. (NameField = '') then. Begin. Result := false; Exit; End; If not fDataSource.DataSet.Active then. FDataSource.DataSet.Open. Else. Begin. FDataSource.DataSet.Close; FDataSource.DataSet.Open; End; FDataSource.DataSet.DisableControls; MGroup := TMRGroup.Create; MGroup.Clear; Try. While not fDataSource.DataSet.Eof do. Begin. MGroup.Add(DataSource.DataSet.FieldByName(KeyField).AsInteger, DataSource.DataSet.FieldByName(MasterField).AsInteger, DataSource.DataSet.FieldByName(NameField).AsString); FDataSource.DataSet.Next; End; Items.Clear; Items.BeginUpdate; FLock := True; ANode := nil; For i := 0 to MGroup.Count - 1 do. Begin. If ANode = nil then. Begin. ANode := Items.AddChild(nil, MGroup.Items[i].MainName); ANode.StateIndex := MGroup.items[i].ID; End. Else if ANode.Level = (MGroup.items[i].Level) then. Begin. ANode := items.AddChild(ANode.Parent, MGroup.items[i].MainName); ANode.StateIndex := MGroup.items[i].ID; End. Else if ANode.Level = (MGroup.items[i].Level - 1) then. Begin. ANode := Items.AddChild(ANode, MGroup.items[i].MainName); ANode.StateIndex := MGroup.items[i].ID; End. Else if ANode.Level > MGroup.items[i].Level then. Begin. NextNode := ANode.Parent; While NextNode.Level > MGroup.items[i].Level do. NextNode := NextNode.Parent; ANode := Items.AddChild(NextNode.Parent, MGroup.items[i].MainName); ANode.StateIndex := MGroup.items[i].ID; End; { else if ANode.Level > MGroup.items[i].Level then. Begin. NextNode := ANode.Parent; While NextNode.Level > MGroup.items[i].Level do. NextNode := NextNode.Parent; ANode := Items.AddChild(NextNode.Parent, MGroup.items[i].MainName); ANode.StateIndex:=MGroup.items[i].ID; End;}. End; Finally. FDataSource.DataSet.First; FDataSource.DataSet.EnableControls; //ShowMessage('Tree count='+IntToStr(Items.Count)+' MGroup count='+IntToStr(MGroup.Count)); MGroup.Free; FLock := false; End; Items.EndUpdate; If Items.Count > 0 then. Items.Item[0].Expand(false); Result := True; End; Procedure TGRTreeView.SetDataSource(value: TDataSource); Begin. FDataSource.DataSource := value; End; Function TGRTreeView.MRGetIndexByMasterID(MasterID: integer): integer; Var. I: integer; Begin. If Items.Count = 0 then. Begin. Result := -1; Exit; End; For i := 0 to Items.Count - 1 do. Begin. If Items.Item[i].StateIndex = MasterID then. Begin. Result := i; Exit; End; End; Result := -1; End; Function TGRTreeView.GetKeyField: string; Begin. Result := fFeyField.FieldName; End; Function TGRTreeView.GetMasterKeyField: string; Begin. Result := fMasterFeyField.FieldName; End; Function TGRTreeView.GetNameField: string; Begin. Result := fNameField.FieldName; End; Procedure TGRTreeView.SetKeyField(value: string); Begin. FFeyField.FieldName := value; End; Procedure TGRTreeView.SetMasterKeyField(value: string); Begin. FMasterFeyField.FieldName := value; End; Procedure TGRTreeView.SetNameField(value: string); Begin. FNameField.FieldName := value; End; Procedure TGRTreeView.SetSeparator(value: char); Begin. FSeparator := value; End; Procedure TGRTreeView.GetImageIndex(Node: TTreeNode); Begin. If fLock then. Exit; Inherited; If Node.getFirstChild <> nil then. Begin. Node.ImageIndex := 0; Node.SelectedIndex := 1; End. Else. Begin. Node.ImageIndex := 2; Node.SelectedIndex := 3; End; End; Function TGRTreeView.MRGetIndexByMasterIDRecurse( MasterID: integer): integer; Var. I: integer; Begin. If Items.Count = 0 then. Begin. Result := -1; Exit; End; For i := Items.Count - 1 downto 0 do. Begin. If Items.Item[i].StateIndex = MasterID then. Begin. Result := i; Exit; End; End; Result := -1; End; Function TGRTreeView.MRSearchByText(AText: string; Next: Boolean = True; UseSearchIndex: Boolean = false): integer; Var. I, iStart, iEnd: integer; Sel: TList; F: boolean; Begin. If Items.Count = 0 then. Begin. Result := -1; FSearchIndex := -1; Exit; End; If Next then. Begin. If (UseSearchIndex) and (fSearchIndex <> -1) then. IStart := fSearchIndex + 1. Else. IStart := 0; IEnd := Items.Count - 1; End. Else. Begin. If (UseSearchIndex) and (fSearchIndex <> -1) then. IStart := fSearchIndex - 1. Else. IStart := Items.Count - 1; IEnd := 0; End; I := iStart; F := true; Repeat. If pos(AnsiUpperCase(AText), AnsiUpperCase(Items.Item[i].Text)) > 0 then. Begin. Result := i; FSearchIndex := i; Sel := TList.Create; Sel.Add(Items.Item[i]); Select(Sel); Sel.Free; Exit; End; If Next then. Begin. Inc(i); If i > iEnd then. F := false; End. Else. Begin. Dec(i); If i < iEnd then. F := false; End; Until f <> true; Result := -1; FSearchIndex := -1; End; { TMRGroup }. Procedure TMRGroup.Add(AID, AMasterID: integer; AMainName: string); Var. Idx: integer; Begin. Inc(fCount); SetLength(items, fCount); Items[fCount - 1].ID := AID; Items[fCount - 1].MasterID := AMasterID; Items[fCount - 1].MainName := AMainName; Idx := GetIndexByMasterID(AMasterID); If idx = -1 then. Begin. Items[idx].Level := 0; End. Else. Begin. Items[fCount - 1].Level := items[idx].Level + 1; End; End; Procedure TMRGroup.Clear; Begin. Items := nil; FCount := 0; End; Constructor TMRGroup.Create; Begin. Inherited; FCount := 0; End; Destructor TMRGroup.destroy; Begin. Items := nil; Inherited; End; Function TMRGroup.GetIndexByMasterID(AMasterID: integer): integer; Var. I: integer; Begin. If (fCount = 0) then. Begin. Result := -1; Exit; End; For i := 0 to fCount - 1 do. Begin. If items[i].ID = AMasterID then. Begin. Result := i; Exit; End; End; Result := -1; End; Procedure TMRGroup.SetCount(value: integer); Begin. FCount := value; End; End.

Компонент TRvNDRWriter.

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

Свойства и события.

Компонент TRvNDRWriter имеет свойства и события для управления выводом. AccuracyMethod определяет, каким образом выводятся строки, для получения должного качества печати и просмотра. FileName это файл, который будет создан, если StreamMode содержит, что отличное от smUser. Используйте smFile для больших отчетов (более 10 страниц или с большим количеством рисунков) и smMemory для маленьких отчетов (менее 10 страниц). Для отсылки отчета в файл используйте метод Execute.

Компонент TRvProject.

Компонент TRvProject является ключом для доступа к визуальным отчетам, создаваемым с помощью Rave. Обычно к вас только один компонент TRvProject на все приложения, но при нужде Вы можете иметь их столько, сколько нужно. Свойство ProjectFile определяет файл проекта вашего приложения, в котором хранятся все определения отчета. Данный файл имеет расширение .RAV и даже если это единственный файл он может хранить столько определений отчета сколько необходимо. Когда вызывается метод Open объекта TRaveReport, то данный файл загружается в память для подготовки к печати или для изменений пользовательским дизайнером. Вы должны обязательно вызвать метод Close, как только вам не нужен файл проекта или при закрытии вашего приложения. Любые изменения в проекте отчета Вы можете сохранить, вызвав метод Save. TRvProject также имеет несколько свойства и методов, такие как SelectReport, GetReportList, ReportDescToMemo, ReportDesc, ReportName и ReportFullName, что делает эффективным и простым создание интерфейса для ваших пользователей. Посмотрите RAVEDEMO проект, как хороший пример создания интерфейса Rave.

Свойство Engine.

Свойство Engine TRvProject позволяет вам определять альтернативный движок для вывода. Это позволяет вам создавать свои пользовательские диалоги настройки и просмотра через компонент TRvSystem или создавать NDR потоки или файлы через компонент TRvNDRWriter.

Использование TRvProject.

Далее показана базовая последовательность шагов, которую Вы должны выполнить при использовании компоненты TrvProject в вашем приложении:

1) Вызовите RvProject.Open; для открытия проекта отчета, определенном в свойстве ProjectFile.

2) Вызовите RvProject.GetReportList(ListBox1.Items,TRUE); для загрузки списка имен отчетов в ListBox1.

3) Когда пользователь щелкнет в ListBox1 (ListBox1.OnClick),

вызовите RvProject.SelectReport(ListBox1.Items[ListBox1.ItemIndex],TRUE); и затем RvProject.ReportDescToMemo(Memo1); для выбора текущего отчета и копирования его описание в Memo1.

4) Вызовите RvProject.Execute; для печати текущего отчета.

5) Вызовите RvProject.Design; вызов дизайнера конченого пользователя для текущего отчета (доступен только через End User Designer License (EUDL)).

6) Вызовите RvProject.Close; для закрытия проекта отчета и освобождения занятой памяти.

Это просто обзор базовых действий для типичного приложения и показано как вызывать методы и свойства TRvProject. Есть также и другие свойства и методы, определенные в основном справочника, что дает вам большие возможности. Для сохранения места в вашем приложении, Rave загружает только Graphics, Standard и Reporting компоненты. Компоненты штрих кодов (Barcode) и другие пользовательские компоненты должны быть зарегистрированы и откомпилированы в приложение явно, если они используются в отчете Rave. Далее список шагов для подключения компонентов штрих кодов в ваше приложение:

1) На форме, которая содержит компонент TRvProject для приложения, добавьте модуль RvCsBars в uses.

2) Определите событие TRvProject.OnCreate и вызовите метод RaveRegister для модуля RvCsBars:

Procedure TReportForm.RvProjectCreate(Sender: TObject);

Begin.

RvCsBars.RaveRegister;

End;

Два приведенных выше шага требуются для любого пользовательского компонента, который может использоваться в Rave отчете. Если Вы не корректно выполните приведенные шаги, то Вы получите такое сообщение об ошибке "Class TRavePostNetBarcode not found", во время открытия проекта.

Компонент TRvSystem.

3. Компонент TRvSystem.

Описание.

Компонент TRvSystem очень мощный компонент, который интегрирует функциональность сразу трех компонент, TRvRenderPreview, TRvRenderPrinter и TRvNDRWriter в одну простую для использования систему. TRvSystem может посылать отчет или на принтер или на экран для просмотра и может показывать диалог настройки (setup) и окно состояния.

Свойства.

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

SystemFiler, который может быть назначен путем двойного щелчка на левой колонке в инспекторе объектов, может показывать все файловые настройки из TRvNDRWriter, TRvRenderPreview и TRvRenderPrinter. Все настройки SystemFiler работают так же, как и в других компонентах, за исключением потокового режима для smMemory, который не требует указания имени файла, а должен использовать TmemoryStream содержащий отчет.

SystemOptions управляет конфигурацией компонента TRvSystem.

SoUseFiler всегда посылает отчет в файл отчета. Это особенно полезно, если в отчете используется метод Macro.

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

SoShowStatus позволяет указать, требуется ли вывод окна состояния при подготовке или печати отчета.

SoAllowPrintFromPreview позволяет указать может ли пользователь печатать отчет из окна просмотра отчета.

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

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

SystemPreview показывает все настройки просмотра, найденные в TRvRenderPreview.

SystemPrinter показывает все настройки печати, найденные в TRvNDRWriter.

SystemSetups управляет конфигурацией стандартного диалога настроек для TRvSystem.

SsAllowSetup определяет должен ли быть показан диалог настройки.

SsAllowCopies, ssAllowCollate и ssAllowDuplex разрешают включение данных настроек в диалог настройки принтера.

SsAllowDestPreview, ssAllowDestPrinter и ssAllowDestFile определяют настройки вывода, до которых пользователь может иметь доступ.

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

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

События.

Все OnXxxx события для TRvSystem работают одинаково, как у TRvNDRWriter. Перекрытые события, OverridePreview, OverrideSetup и OverrideStatus позволяют программисту заменить эти диалоги своими собственными. Документация о том, как это сделать это отсутствует, но можно посмотреть, как это сделано в TRvSystem. Посмотрите методы OverridePreviewProc, OverrideStatusProc и OverrideSetupProc как создать перекрытый метод событие. Модули RpFormPreview, RpFormStatus и RpFormSetup расположены в \RAVE4\SOURCE, также показывают, как взаимодействовать с TRvSystem, и могут быть использованы как начальная точка для собственных версий различных форм.

TSimpleDataSet.

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

Компонент использует двунаправленный курсор и позволяет редактировать данные, правда только в режиме кэширования (см. гл. 22).

Таким образом, компонент TSimpleDataSet позволяет исправить основные недостатки технологии dbExpress.

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

Property DBConnection: TSQLConnection;

Которое позволяет связать его с соединением TSQLConnection (см. выше). или свойство.

Property ConnectionName: string;

Которое позволяет выбрать тип соединения dbExpress напрямую.

При этом у компонента отсутствует механизм создания удаленного доступа к данным, представленный у компонента TclientDataSet свойствами RemoteServer И ProviderName.

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

Тип команды определяется свойством.

TSQLCommandType = (ctQuery, ctTable, ctStoredProc);

Property CommandType: TSQLCommandType;

А содержание команды задает свойство.

Property CoinmandText: string;

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

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

Function ApplyUpdates(MaxErrors: Integer); Integer; virtual;

Где параметр MaxErrors определяет максимально возможное число ошибок при сохранении. Обычно этому параметру присваивается -1, что снимает ограничение на число ошибок. Метод.

Function Reconcile(const Results: OleVariant): Boolean;

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

Отменить локальные изменения можно методом.

Procedure CancelUpdates;

Обратите внимание, что в компоненте действуют традиционные методы набора данных Edit, Post, Cancel, Apply, Insert, Delete. Но они оказывают влияние только на записи, кэшированные локально. Вы можете сколько угодно редактировать набор данных при помощи перечисленных методов, но они будут изменять только содержимое кэша. Настоящее сохранение на сервере осуществляется методом Appiyupdates.

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

Property Data: OleVariant;

Сделанные изменения содержатся в свойстве.

Property Delta: OleVariant;

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

Property PacketRecords: Integer;

Которое задает число записей в пакете. Автоматическое назначение пакетов включается.

PacketRecords := -1.

Если значение PacketRecords равно 0, между клиентом и сервером пересылаются только метаданные.

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

Function GetNextPacket: Integer;

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

Property BeforeGetRecords: TRemoteEvent;

Property AfterGetRecords: TRemoteEvent;

В компоненте TSimpleDataSet развиты средства работы с одиночными записями. Можно просмотреть общее число записей.

Property RecordCount: Integer;

И номер текущей записи.

Property RecNo: Integer;

Размер одной записи сохраняется в свойстве.

Property RecordSize: Word;

Все изменения, сделанные в текущей записи, отменяются методом.

Procedure RevertRecord;

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

Procedure RefreshRecord;

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

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

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

TReconcileErrorEvent = procedure(DataSet: TCustomClientDataSet; E: EReconcileError; UpdateKind: TUpdateKind; var Action: TReconcileAction) of object;

Property OnReconcileError: TReconcileErrorEvent;

Который срабатывает, если с сервера пересылается сообщение об ошибке. Информация об ошибке находится в параметре E: EReconcileError.

TSQLDataSet.

Компонент TSQLDataSet является универсальным и позволяет выполнять запросы SQL (подобно TSQLQuery), просматривать таблицы целиком (подобно TSQLTable)или выполнять хранимые процедуры (подобно TSQLStoredProc).

Для определения режима работы компонента используется свойство ConimandType (см. выше).

Если ему присвоить значение ctTable, в списке свойства commandText можно выбрать имя таблицы, если конечно компонент подключен к соединению. При выборе значения ctQuery в свойстве CommandText необходимо определить текст запроса SQL. Для работы в режиме хранимой процедуры для свойства commandType используется значение ctstoredProc, а в списке свойства CommandText можно выбрать нужную процедуру.

Для открытия набора данных используются традиционные способы: свойство Active или метод Open. Если же запрос SQL или хранимая процедура не возвращают набор данных, для их выполнения используется метод.

Function ExecSQL(ExecDirect: Boolean = False): Integer; override;

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

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

В режиме запросов и хранимых процедур для задания параметров используются свойства Params И ParamCheck (см. часть III).

Информация об используемых в результирующем наборе данных индексах сохраняется в свойстве.

Property IndexDefs: TIndexDefs;

TSQLQuery.

Компонент TSQLQuery повторяет функциональность своих аналогов в BDE, ADO, InterBase Express и позволяет выполнять на сервере запросы SQL клиента. Подробнее о функциях компонентов запросов SQL см. часть III.

Текст запроса содержится в свойстве.

Property SQL: TStrings;

А его простое строковое представление в свойстве.

Property Text: string;

Если запрос возвращает набор данных, его выполнение осуществляется свойством Active или методом open. В противном случае используется метод.

Function ExecSQL(ExecDirect: Boolean = False): Integer; override;

Параметр ExecDirect = False означает, что запрос не имеет настраиваемых параметров.

TSQLStoredProc.

Компонент TSQLStoredProc инкапсулирует функциональность хранимых процедур для их выполнения в рамках технологии dbExpress. Он подобен другим своим аналогам. Подробнее о функциях компонентов хранимых процедур см. часть III. Имя хранимой процедуры определяется свойством.

Property StoredProcName: string;

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

Property Params: TParams;

Внимание.

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

Процедура выполняется методом.

Function ExecProc: Integer; virtual;

Если она не возвращает набор данных. Иначе используются свойство Active или метод open.

Если хранимая процедура возвращает несколько связанных наборов данных (подобно иерархическим запросам ADO), доступ к следующему набору данных осуществляет метод.

Function NextRecordSet: TCustomSQLDataSet;

Автоматически создавая объект типа TCustomSQLDataSet для инкапсуляции новых данных. Возврат к предыдущему набору данных возможен, если вы определили объектные переменные для каждого набора данных:

Code: Var SecondSet: TCustomSQLDataSet; MyProc.Open; While Not MyProc.Eof do. Begin. {...} Next; End; SecondSet := MyProc.NextRecordSet; SecondSet.Open; {...}. SecondSet.Close; MyProc.Close;

TSQLTable.

Компонент TSQLTable предназначен для просмотра таблиц целиком и по основным функциям подобен своим аналогам ТТаь1е, ТАDОтаь1е,ТIВТаь1е (подробнее о функциях компонентов таблиц см. часть III).

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

Метод.

Procedure PrepareStatement; override;

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

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

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

IndexFieldNames, IndexFields, IndexName.

А метод.

Procedure GetlndexNames(List: TStrings);

Возвращает в параметр List список используемых индексов.

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

Компонент TSQLTable предоставляет разработчику некоторое подобие функций редактирования. Для удаления всех записей из связанной с компонентом таблицы на сервере используется метод.

Procedure DeleteRecords;

TStream.

Класс TStream не нов для библиотек фирмы Borland; он и его потомки называются потоками. Со времен появления в библиотеке Turbo Vision он не претерпел существенных изменений, но теперь потоки стали обязательными составными частями там, где нужно прочитать или передать во внешний источник какую-либо информацию.

TStream "является абстрактной моделью совокупности данных, обладающей двумя свойствами — длиной Size и положением текущего элемента Position:

Property Position: Longint;

Property Size: Longint;

От TStream порождены дочерние объекты, позволяющие пользоваться метафорой потока при работе с файлами, блоками памяти и т. п. Так, в модуле CLASSES описаны классы TMemoryStream и TFileStream.

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

Function Read(var Buffer; Count: Longint): Longint;virtual; abstract;

Function Writetconst Buffer; Count: Longint): Longint;virtual; abstract;

Метод.

Function Seek(0ffset: Longint; Origin: Word): Longint;virtual; abstract;

Позиционирует поток. В зависимости от значения параметра Origin новая позиция выбирается так:

О — новая позиция равна Offset;

1 —текущая позиция смещается на Offset байт;

2 — новая позиция находится на Offset байт от конца потока.

Методы.

Procedure ReadBuffer(var Buffer; Count: Longint);

Procedure WriteBuffer(const Buffer; Count: Longint);

Представляют собой оболочки над Read/Write, вызывающие в случае неудачи операции исключительные ситуации EReadError/EWriteError.

Метод.

Function CopyFromfSource: TStream; Count: Longint): Longint;

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

Основным отличием реализации TStream в VCL является введение ряда методов, обеспечивающих чтение и запись компонентов в потоки. Они полезны на уровне разработчика новых компонентов и здесь подробно не рассматриваются:

Function ReadComponent(Instance: TComponent): TComponent;

Function ReadComponentRes(Instance: TComponent): TComponent;

Procedure WriteComponent(Instance: TComponent);

Procedure WriteComponentRes (const ResName: string;Instance: TComponent);

Procedure ReadResHeader;

©Drkb::00319.

TStringGrid --> HTML.

Code: Procedure SGridToHtml(SG: TStringgrid; Dest: TMemo; BorderSize: Integer); Var. I, p: integer; SStyle1, SStyle2, Text: string; Begin. Dest.Clear; Dest.Lines.Add('<html>'); Dest.Lines.Add('<body>'); Dest.Lines.Add(' <table border="' + IntToStr(BorderSize) + '" width="' + IntToStr(SG.Width) + '" height="' + IntToStr(SG.Width) + '">'); For i := 0 to SG.RowCount - 1 do. Begin. Dest.Lines.Add(' <tr>'); For p := 0 to SG.ColCount - 1 do. Begin. SStyle1 := ''; SStyle2 := ''; If fsbold in SG.Font.Style then. Begin. SStyle1 := SStyle1 + '<b>'; SStyle2 := SStyle2 + '</b>'; End; If fsitalic in SG.Font.Style then. Begin. SStyle1 := SStyle1 + '<i>'; SStyle2 := SStyle2 + '</i>'; End; If fsunderline in SG.Font.Style then. Begin. SStyle1 := SStyle1 + '<u>'; SStyle2 := SStyle2 + '</u>'; End; Text := sg.Cells[p, i]; If Text = '' then Text := ' '; Dest.Lines.Add(' <td width="' + IntToStr(sg.ColWidths[p]) + '" height="' + IntToStr(sg.RowHeights[p]) + '"><font color="#' + IntToHex(sg.Font.Color, 6) + '" face="' + SG.Font.Name + '">' + SStyle1 + Text + SStyle2 + '</font></td>'); End; Dest.Lines.Add(' </tr>'); End; Dest.Lines.Add(' </table>'); Dest.Lines.Add('</body>');; Dest.Lines.Add('</html>'); End; // Example, Beispiel. Procedure TFormCSVInport.Button6Click(Sender: TObject); Begin. SGridToHtml(StringGrid1, Memo1, 1); Memo1.Lines.SaveToFile('c:\test.html'); End;

TStringGrid и файловый поток

Какое наилучшее решение для сохранения экземпляра TStringGrid (150x10)?

TStringGrid с фокусом (OnDrawCell).

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

TStringList. Сортировка и системная locale.

Автор: Alexander Ilyin.

TTreeView. Проблемы CustomDraw.

Автор: Rustam Kafarov.

TWinControl.

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

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

Дескриптор окна содержится в свойстве.

Property Handle: HWND;

При создании оконного элемента управления вызывается метод.

Procedure CreateParams(var Params: TCreateParams); virtual;

Который заполняет структуру TCreateParams необходимыми значениями:

Code: Type. TCreateParams = record. Caption: PChar; Style: DWORD; ExStyle: DWORD; X, Y: Integer; Width, Height: Integer; WndParent: HWND; Param: Pointer. WindowClass: TWndClass; WinClassName: array[0..63] of Char; End;

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

Procedure CreateHandle; virtual;

Операционная система создает дескриптор окна только вместе с самим окном. Поэтому метод CreateHandle только создает окно, а для присваивания свойству Handle значения дескриптора окна вызывает метод createwnd.

Для передачи фокуса между элементами управления на одной форме часто используется клавиша <Таь>. Порядок перемещения фокуса между элементами определяется свойством.

Type TTabOrder = -1..32767;

Property TabOrder: TTabOrder;

В первую очередь фокус передается компоненту с минимальным значением свойства. Далее — по возрастанию значения. При переносе компонента на форму это значение задается автоматически в соответствии с числом компонентов на форме.

Компонент можно заставить не откликаться на клавишу <Таь>. Для этого свойству.

Property TabStop: Boolean;

Необходимо присвоить значение False.

Для передачи фокуса прямо элементу управления применяется метод.

Procedure SetFocus; virtual;

Чтобы узнать, имеет ли элемент управления фокус, в настоящее время используется метод.

Function Focused: Boolean; dynamic;

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

Property BevelEdges: TBevelEdges;

Задает, какие стороны входят в рамку;

Property Bevellnner: TBevelCut; property BevelOuter: TBevelCut;

Задают внешний вид рамки;

Property BevelKind: TBevelKind;

Определяет стиль рамки;

Property BevelWidth: TBevelWidth;

Задает размер рамки.

Свойство.

Property Brush: TBrush;

Определяет параметры кисти (цвет и заполнение), которой рисуется фон элемента.

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

Property Controls[Index: Integer]: TControl;

Общее число дочерних элементов управления содержится в свойстве.

Property ControlCount: Integer;

Внешний вид оконного элемента определяется свойством.

Property Ctl3D: Boolean.

При значении True элемент управления имеет трехмерный вид. Иначе элемент выглядит плоским.

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

Type THelpContext = -MaxLonglnt..MaxLonglnt;

Property HelpContext: THelpContext;

Значение свойства должно соответствовать номеру темы в файле помощи.

В классе TwinControl добавлена возможность использования редакторов способа ввода (Input Method Editor, IME). Такие редакторы позволяют приспособить стандартную раскладку клавиатуры для символьных языков для ввода нестандартных символов (иероглифов и т. д.). Редакторы IМЕ представляют собой специально устанавливаемое в операционной системе программное обеспечение (ПО). Имя такого редактора задается в свойстве ImeName. Режим работы редактора определяется свойством ImeMode.

В классе TwinControl добавлено еще несколько методов-обработчиков событий, обеспечивающих реакцию на ввод с клавиатуры, получение и потерю фокуса.

©Drkb::00325.

Компонент TXPManifest.

На странице Win32 Палитры компонентов Delphi 7 имеется компонент TXPManifest. Будучи добавленным в проект, он обеспечивает компиляцию манифеста Windows XP в исполняемый файл приложения. В качестве основы используется стандартный манифест Delphi для Windows XP, содержащийся в файле ресурсов Delphi7\Lib\WindowsXP.res:

Code: <assembly xmlns="urn:schemas-microsoft-com:asm.vl" manifestVersion="l.0"> <assemblyIdentity. Type="win32". Name="DelphiApplication". Version="3.2.0.0". ProcessorArchitecture="*"/> <dependency> <dependentAssembly> Ossemblyldentity type="win32". Name="Microsoft.Windows.Common-Controls". Version="6.0.0.0". PublicKeyToken="6595b64144ccfldf. " language="*". ProcessorArchitecture="*"/> </dependentAs sembly> </dependency> </assembly>

Types.pas.

Code: {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: Alexander Vaga. EMail: alexander_vaga@hotmail.com. Creation: May, 2002. Legal issues: Copyright (C) 2002 by Alexander Vaga. Kyiv, Ukraine. This software is provided 'as-is', without any express or. Implied warranty. In no event will the author be held liable. For any damages arising from the use of this software. Permission is granted to anyone to use this software for any. Purpose, including commercial applications, and to alter it. And redistribute it freely. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} Unit Types; Interface. Const. STATE_ONLINE =$10020000; STATE_AWAY =$10020001; STATE_DND =$10020013; STATE_INVISIBLE =$10020100; STATE_OCCUPIED =$10020011; STATE_FREEFORCHAT=$10020020; STATE_N_A =$10020005; TYPE_MSG =$01; TYPE_CHAT =$02; TYPE_FILE =$03; TYPE_URL =$04; TYPE_AUTH_REQ =$06; TYPE_AUTH_DEN =$07; TYPE_AUTH_GIV =$08; TYPE_ADDED =$0C; TYPE_WEBPAGER =$0D; TYPE_EXPRESS =$0E; TYPE_CONTACT =$13; TYPE_CONTACT_REG =$1A; Online = 0; Freeforchat = 1; Invisible = 2; Occupied = 3; Dnd = 4; Away = 5; Na = 6; Etc = 7; Offline = 8; Simply_icq = 9; Mes = 10; Empty = 11; PACKET_DATA_SIZE = 4096; Type. IParray = array[0..3] of byte; PByteArray = ^TByteArray; TByteArray = array[0..PACKET_DATA_SIZE-1] of byte; PCharArray = ^TCharArray; TCharArray = array[0..PACKET_DATA_SIZE-1] of char; PWORD = ^word; PLONG = ^longint; PBYTE = ^byte; Type PFLAP_HDR = ^FLAP_HDR; FLAP_HDR = packed record. Sign : byte; ChID : byte; SEQ : word; Len : word; End; Type PSNAC_HDR = ^SNAC_HDR; SNAC_HDR = packed record. FamilyID : word; SubTypeID : word; Flags : array[0..1] of byte; RequestID : longint; End; Type PFLAP_Item = ^FLAP_Item; FLAP_Item = packed record. FLAP : FLAP_HDR; DATA : PByteArray; Next : PFLAP_Item; End; Type. Pack = packed record. Cursor : word; Length : word; Case integer of. 0: (DATA:array[0..PACKET_DATA_SIZE-1] of byte); 1: (FLAP : FLAP_HDR; FLAP_BODY:array[0..PACKET_DATA_SIZE-1] of byte); 2: (Sign,ChID:byte; SEQ,Len : word); 3: (fix:FLAP_HDR; SNAC:SNAC_HDR; SNAC_BODY:array[0..PACKET_DATA_SIZE-1] of byte); End; PPack = ^Pack; Implementation. End.

UDP.

7. UDP.

7.1. Обзор.

UDP (User Datagram Protocol) используется для датаграмм (datagram) и без установки соединения. UDP позволяет посылать короткие пакеты на узел, без установки соединения с ним. Для UDP пакетов не гарантируется доставка и не гарантируется тот же порядок приема, в каком они были посланы. При посылке UDP пакета, он посылается в одном блоке. Поэтому вы не должны превышать максимальный размер пакета, указанный в вашем TCP/IP стеке.

Из-за этих факторов, многие люди считают UDP малопригодными. Но это не совсем так. Многие потоковые протоколы, такие как Real Audio, используют UDP.

Примечание: термин "потоковый" может быть легко перепутан с термином поток (stream) для TCP. Когда вы видите эти термины, вы должны разобраться с контекстом, в котором они применяются, для определения точного значения.

7.2. Надежность.

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

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

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

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

7.3. Широкополосносные сообщения (Broadcast).

UDP имеет уникальную возможность, что его делает очень применимым. Это возможность широкополосной посылки. Широкополосность (Broadcast) означает, что может быть послано одно сообщение, по получено многими получателями. Это не то же самое, как многоадресность (multicasting). Многоадресность – это модель подписки. Когда получатели делают подписку на получение и они добавляются в список рассылки. С помощью широкополосной рассылки, сообщение посылается по сети и все кто его слушают, могут принять его, без необходимости подписываться.

Многоадресные сообщения подобны газетной рассылки. Только те люди, которые подписались на доставку, получают его. Широкополосные сообщения аналогичны радиовещанию (От переводчика: в английском языке это одно и тоже слово broadcasting). Любой, кто имеет радиоприемник, может настроить его на любую радиостанцию и принимать ее. Радиослушатель не обязан оповещать радиостанцию, что он хочет слушать.

Конкретный IP адрес для сообщения, можно рассчитать, основываясь на IP отправителя и маски сети. Есть также особый случай, это адрес 255.255.255.255, который так далеко, насколько это возможно.

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

7.4. Размеры пакетов.

Большинство операционных систем позволяют иметь размер UDP пакета 32K или даже 64K. Но, как правило, маршрутизаторы имеют более серьезные ограничения. UDP не должны превышать допустимый размер, разрешенный маршрутизатором или другим сетевым устройством. Но нет никакой возможности узнать это ограничение.

Поэтому рекомендуется, чтобы UDP пакеты были длиной в 8192 байт или менее, при передаче за пределами локальной сети. Но в некоторых случаях и этот размер велик. Для абсолютной гарантии делайте ваши пакеты в 1024 байт или менее.

7.5. Схемы подтверждений.

7.5.1. Обзор.

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

7.5.2. Схема с подтверждениями.

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

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

7.5.3. Схема с последовательностями.

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

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

7.6. Компонент TIdUDPClient.

TIdUDPClient – это базовый компонент для посылки UDP пакетов. Наиболее часто используемый метод – это Send, в котором используются свойства Host и Port для посылки UDP пакета. Аргументом функции является строка.

Есть также метод SendBuffer, который выполняет туже задачу, но аргументами являются Buffer и Size.

TIdUDPClient также может использоваться как сервер, для приема входящих UDP пакетов.

7.7. Компонент TIdUDPServer.

Поскольку UDP работает без соединений, то TIdUDPServer немного иначе, чем TIdTCPServer. TIdUDPServer не имеет режимов подобным TIdSimpleServer, Так как UDP не использует соединений, то TIdUDPClient (видимо здесь опечатка и имеется в виду TIdUDPServer) имеет только простые слушающие методы.

При активации TIdUDPServer создает слушающий поток для входящих UDP пакетов. Для каждого принятого UDP пакета, TIdUDPServer возбуждает событие OnUDPRead в главном кодовом потоке, или в контексте слушающего потока, в зависимости от свойства ThreadedEvent.

Когда свойство ThreadedEvent сброшено, то событие OnUDPRead возбуждается в контексте главного кодового потока. Когда свойство ThreadedEvent установлено, то событие OnUDPRead возбуждается в контексте слушающего потока.

Вне зависимость от состояния ThreadedEvent true или false, блокируется обработка других сообщений. Поэтому обработка OnUDPRead по возможности должна быть короткой.

7.8. UDP пример - RBSOD.

7.8.1. Обзор.

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

Пример называется «Remote BSOD invocator» - или сокращено RBSOD. RBSOD может быть использован для создания ложных BSOD (От переводчика: Blue Screen Of Dead – это знаменитый экран смерти) на машинах коллег (или врагов). BSOD не является реальным BSOD, и не делает ни каких потерь данных у жертвы. Тем не менее, он должен напугать его startle. Сам BSOD также может быть сброшен удаленно.

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

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

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

Предоставлены следующие параметры.

7.8.1.1. IP Address.

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

Если оставить это поле пустым, то сообщение будет послано в широковещательном режиме по всей подсети (или докуда оно сможет дойти) и на всех компьютерах, на которых установлен сервер возникнет BSOD.

7.8.1.2. Поле Message.

Поле Message задает текст сообщения на машине жертвы, которое будет указано в BSOD screen. Значение по умолчанию следующее:

A fatal exception OE has occurred at 0028:C0011E36 in VXD VMM(01)00010E36. The current application will be terminated. (Произошла фатальная ошибка OE по адресу 0028:C0011E36 в VXD VMM(01)00010E36. Текущее приложение будет закрыто).

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

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

Windows crashed again. I am the Blue Screen of Death. No one hears your screams. (Виндоус снова упал. Я синий экран смерти. Никто не услышит ваших криков).

Three things are certain: Death, taxes, and lost data. Guess which has occurred. (Три вещи неотвратимы: смерть, налоги и потерянные данные. Отгадайте, какая случилась).

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

Сообщения находятся в файле messages.dat и вы можете добавить свои.

7.8.1.3. Use a Custom Message.

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

Ugly brown suit error. I cannot continue in such company. (Очень неприятная ошибка в одежде. Я больше не могу оставаться далее в такой компании).

7.8.1.4. Show Any Key.

Данный параметр, может быть использован для дополнительных выходок. BSOD выдает подсказку «нажмите любую клавишу для продолжения». Это так в нормальном BSOD. НО в данном случае, если будет отмечен, то после нажатия любой клавиши, будет выдано другое сообщение с мигающим текстом «Это не та клавиша, нажмите клавишу NY!».

Этот параметр должен отвратить вашего босса или Бейсик программиста потратить часы на поиск клавиши. Данный параметр наиболее хорошо использовать до отправки в аэропорт для длительного путешествия или когда вы хотите занять его надолго. (А себя в длительных поисках новой работы).

7.8.1.5. Show Trademark.

Если данный параметр используется, то в нижнем углу экрана будет мелкая, но читаемая надпись: * The BSOD is a trademark of the Microsoft Corporation.

7.8.1.6. Клавиша Show.

Нажатие клавиши Show приведет к генерации BSOD на удаленном компьютере.

7.8.1.7. Клавиша Clear.

Нажатие клавиши Clear используется для удаленного снятия «BSOD». Обычно вы отдаете это на откуп пользователю, но в некоторых случая вы, возможно, захотите сами его снять. Ну, например, перед походом к пользователю.

7.8.2. Сервер RBSOD.

Но сначала посмотрим на сервер.

7.8.2.1. Установка.

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

Сервер не имеет окон и не появляется в панели задач и системном трее (там, где часики). Если вы хотите его остановить, то запустите диспетчер задач и выберите тот svchost, который запущен от имени пользователя. Системный svchosts запущен от SYSTEM (это не совсем так). После выбора вашей «версии» нажмите клавишу [Снять задачу].

Для инсталляции просто скопируйте сервер на машину клиента (compile without packages for easiest deployment) и запустит его. Он останется в памяти пока пользователь не перезагрузит свой компьютере. После перезагрузки программа не будет перезапущена. Если вы желаете, что бы программа автоматически стартовала при каждой перезагрузки, то просто добавьте ее в автозагрузку или в реестр, для невидимого запуска.

7.8.2.2. Исходный код.

Сервер состоит из двух частей, Server.pas и BSOD.pas. BSOD.pas содержит форму, которая используется для показа BSOD экрана. BSOD.pas не содержит Indy кода и поэтому не рассматривается здесь.

Server.pas – это главная форма приложения и содержит один UDP сервер. Свойство port установлено в 6001 и свойство active установлено в True. Когда приложение запускается, то оно немедленно начинает слушать порт для входящих UDP пакетов.

Как ранее обсуждалось UDP подобен пейджеру. Поскольку ему не требуется соединение для приема данных. Пакеты данных просто появляются как один кусок. Для каждого принятого UDP пакета, UDP сервер возбуждает событие OnUDPRead. Больше никаких других событий не требуется для реализации UDP сервера. Когда возбуждается событие OnUDPRead, полный пакет уже принят и готов к использованию.

Событию OnUDPRead передаются три аргумента:

1. ASender: TObject – это компонент, который возбудил данное событие. Это применимо только если будет создано несколько UDPServers серверов и используют один и тот же метод для события. Это очень редко нужно.

2. AData: TStream – это основной аргумент и он содержит сам пакет. UDP пакеты могут содержать текст и/или двоичные данные. Поэтому Indy предоставляет их в виде потока. Для доступа к данным, просто используйте методы read класса TStream.

3. ABinding: TIdSocketHandle – этот аргумент пригоден для получения расширенной информации. Это востребовано, если используется связывание (bindings). Вот пример как выглядит событие OnUDPRead в RBSOD сервере:

Code: Procedure TformMain.IdUDPServer1UDPRead(Sender: TObject; AData: TStream; ABinding: TIdSocketHandle); Var. LMsg: string; Begin. If AData.Size = 0 then. Begin. FormBSOD.Hide; End. Else. Begin. // Move from stream into a string. SetLength(LMsg, AData.Size); AData.ReadBuffer(LMsg[1], Length(LMsg)); // FormBSOD.ShowBSOD(Copy(LMsg, 3, MaxInt), Copy(LMsg, 1, 1) = 'T', Copy(LMsg, 2, 1) = 'T'); End; End;

UInfo.pas.

Code: {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: Alexander Vaga. EMail: primary: icq2000cc@hobi.ru. Secondary: alexander_vaga@hotmail.com. Web: http://icq2000cc.hobi.ru. Creation: May, 2002. Legal issues: Copyright (C) 2002 by Alexander Vaga. Kyiv, Ukraine. This software is provided 'as-is', without any express or. Implied warranty. In no event will the author be held liable. For any damages arising from the use of this software. Permission is granted to anyone to use this software for any. Purpose, including commercial applications, and to alter it. And redistribute it freely. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} Unit UInfo; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, Buttons, ExtCtrls, Animate,inifiles, Typess,main,util,packet, AppEvnts; Type. TUserInfo = class(TForm). UserInfoDoneBtn: TButton; UserInfoRetrieveBtn: TButton; InfoPage: TPageControl; MainTab: TTabSheet; HomeTab: TTabSheet; MoreTab: TTabSheet; WorkTab: TTabSheet; InfoAboutTab: TTabSheet; Panel1: TPanel; UIAnime: TAnimatedImage; GroupBox1: TGroupBox; Label1: TLabel; Label2: TLabel; Label6: TLabel; Label9: TLabel; UinEd: TEdit; IpEd: TEdit; RealipEd: TEdit; VerEd: TEdit; GroupBox2: TGroupBox; Label3: TLabel; Label4: TLabel; Label7: TLabel; Label8: TLabel; FirstEd: TEdit; LastEd: TEdit; DisplayEd: TEdit; NickEd: TEdit; GroupBox3: TGroupBox; Label5: TLabel; PriEd: TEdit; Label10: TLabel; Label11: TLabel; SecEd: TEdit; OldEd: TEdit; GroupBox4: TGroupBox; CityEd: TEdit; ZipEd: TEdit; StateEd: TEdit; Label12: TLabel; Label13: TLabel; Label14: TLabel; Label15: TLabel; StreetMemo: TMemo; Label16: TLabel; GroupBox5: TGroupBox; Label17: TLabel; Label18: TLabel; Label19: TLabel; PhoneEd: TEdit; CellularEd: TEdit; FaxEd: TEdit; GroupBox6: TGroupBox; Label20: TLabel; Label21: TLabel; Label22: TLabel; TzEd: TEdit; Edit20: TEdit; Edit21: TEdit; GroupBox7: TGroupBox; Label23: TLabel; Label24: TLabel; Label25: TLabel; HomepageEd: TEdit; AgeEd: TEdit; GroupBox8: TGroupBox; Label26: TLabel; Label27: TLabel; Label28: TLabel; GroupBox9: TGroupBox; GroupBox10: TGroupBox; Label29: TLabel; Label30: TLabel; Label31: TLabel; Label32: TLabel; Label33: TLabel; WcityEd: TEdit; WzipEd: TEdit; WstateEd: TEdit; WstreetMemo: TMemo; GroupBox11: TGroupBox; Label34: TLabel; Label36: TLabel; WphoneEd: TEdit; WfaxEd: TEdit; GroupBox12: TGroupBox; Label38: TLabel; Label39: TLabel; CompanyEd: TEdit; JobEd: TEdit; DepartmentEd: TEdit; Label35: TLabel; Label37: TLabel; WhomepageEd: TEdit; Label40: TLabel; GroupBox13: TGroupBox; AboutMemo: TMemo; AuthLabel: TLabel; Label43: TLabel; GroupBox15: TGroupBox; InterMemo: TMemo; CountryCombo: TComboBox; WcountryCombo: TComboBox; GenderCombo: TComboBox; MonthCombo: TComboBox; Lang1Combo: TComboBox; Lang2Combo: TComboBox; Lang3Combo: TComboBox; OccupationCombo: TComboBox; DayCombo: TComboBox; YearCombo: TComboBox; ApplicationEvents1: TApplicationEvents; Procedure Request_Meta_Info(UIN : longint); Procedure Set_Meta_Info; Procedure UserInfoDoneBtnClick(Sender: TObject); Procedure UserInfoRetrieveBtnClick(Sender: TObject); Procedure FormShow(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); Procedure SetCountry(Combo:TComboBox; Country:word); Function GetCountry(Combo:TComboBox):word; Procedure SetGender(Combo:TComboBox; Gender:byte); Function GetGender(Combo:TComboBox):byte; Procedure SetMonth(Combo:TComboBox; Month:byte); Function GetMonth(Combo:TComboBox):byte; Procedure SetLanguage(Combo:TComboBox; Lang:byte); Function GetLanguage(Combo:TComboBox):byte; Procedure SetOccupation(Combo:TComboBox; Occupation:word); Function GetOccupation(Combo:TComboBox):word; Procedure SetCombo(Combo:TComboBox; min,max,Value:word); Function GetCombo(Combo:TComboBox; min,max:byte):word; Procedure ApplicationEvents1Message(var Msg: tagMSG; Var Handled: Boolean); Private. { Private declarations }. Public. AutoRetrieve : boolean; UIRecord : TListRecord; Cookie : word; End; Implementation. {$R *.DFM}. Procedure TUserInfo.UserInfoDoneBtnClick(Sender: TObject); Begin. Close; End; Procedure TUserInfo.Request_Meta_Info(UIN : longint); Var p,a : pPack; Begin. A := PacketNew; PacketGoto(a,2);// a[0..1] = len. PacketAppend32(a,main.UIN); PacketAppend16(a,swap($D007)); Cookie := random($FF) shl 8; PacketAppend16(a,swap(Cookie)); PacketAppend16(a,swap($B204)); PacketAppend32(a,UIN); PacketBegin(a); PacketAppend16(a,a.length-2); P:=CreatePacket(2,SEQ); SNACAppend(p,$15,$2); TLVAppend(p,1,a.length,@a.data); PacketDelete(a); Form1.PacketSend(p); M(Form1.Memo,'>Request Full Info: '+s(UIN)+' '+ 'Cookie:$'+inttohex(Cookie,4)); UIAnime.Active := true; End; Procedure TUserInfo.UserInfoRetrieveBtnClick(Sender: TObject); Begin. If (OL and isLogged)then. Request_Meta_Info(UIRecord.UIN); End; Procedure TUserInfo.FormShow(Sender: TObject); Begin. InfoPage.ActivePageIndex :=0; With UIRecord do begin. UinEd.Text := s(UIN); IpEd.Text := IPtoStr(IP); RealipEd.Text := IPtoStr(REAL_IP); VerEd.Text := s(VER); FirstEd.Text := FIRST; LastEd.Text := LAST; NickEd.Text := NICK; DisplayEd.Text := NICK; PriEd.Text := PRI_E_MAIL; SecEd.Text := SEC_E_MAIL; OldEd.Text := OLD_E_MAIL; CityEd.Text := CITY; StateEd.Text := STATE; PhoneEd.Text := PHONE; FaxEd.Text := FAX; CellularEd.Text := CELLULAR; M(streetMemo,STREET); SetCountry(countryCombo,COUNTRY); SetGender(genderCombo,GENDER); AgeEd.Text := s(AGE); HomepageEd.Text := HOMEPAGE; SetCombo(yearCombo,1,99,BYEAR); SetMonth(monthCombo,BMONTH); SetCombo(dayCombo,1,31,BDAY); Case AUTH of. 0: AuthLabel.Caption := 'Authorize'; 1: AuthLabel.Caption := 'Always'; Else AuthLabel.Caption := 'unknown'; End; SetLanguage(lang1Combo,LANG1); SetLanguage(lang2Combo,LANG2); SetLanguage(lang3Combo,LANG3); M(aboutMemo,ABOUT); M(interMemo,INTERESTS); CompanyEd.Text :=COMPANY; DepartmentEd.Text := DEPARTMENT; JobEd.Text := JOB; SetOccupation(occupationCombo,Occupation); WcityEd.Text := WCITY; WstateEd.Text := WSTATE; WphoneEd.Text := WPHONE; WfaxEd.Text := WFAX; WstreetMemo.Clear; M(wstreetMemo,WSTREET); SetCountry(wcountryCombo,WCOUNTRY); WhomepageEd.Text := WHOMEPAGE; End; If AutoRetrieve then begin. If (OL and isLogged)then. Request_Meta_Info(UIRecord.UIN); End; End; Procedure TUserInfo.FormClose(Sender: TObject; var Action: TCloseAction); Var i : integer; Begin. If not AutoRetrieve then begin. For i:=0 to CLNum-1 do with ContactList[i] do begin. If UIN = UIRecord.UIN then begin. ContactList[i] := UIRecord; If NICK = '' then begin. If FIRST <> '' then NICK := FIRST. Else if LAST <> '' then NICK := LAST. Else NICK := s(UIN); End; // if. Form1.WriteToContactList(ContactList[i]); Break; End; End; //for. For i:=0 to Form1.CL.Items.Count-1 do. If Form1.CL.Items[i].Text <> PListRecord(Form1.CL.Items[i].Data)^.NICK then. Form1.CL.Items[i].Text := PListRecord(Form1.CL.Items[i].Data)^.NICK; End; Destroy; End; Procedure TUserInfo.Set_Meta_Info; Begin. // это еще старый кусок из протокола icqv5 (UDP). // CMD_META_USER + META_CMD_SET_INFO. (* P:=main.UDPCreateStdPacket(CMD_META_USER); PacketAppend16(p,META_CMD_SET_INFO); Cookie := main.UDPSeqNum2-1; MetaUIN := main.UIN; PacketAppendString(p,nickEd.Text); PacketAppendString(p,firstEd.Text); PacketAppendString(p,lastEd.Text); PacketAppendString(p,priEd.Text); PacketAppendString(p,secEd.Text); PacketAppendString(p,oldEd.Text); PacketAppendString(p,cityEd.Text); PacketAppendString(p,stateEd.Text); PacketAppendString(p,phoneEd.Text); PacketAppendString(p,faxEd.Text); PacketAppendString(p,streetMemo.Lines[0]); PacketAppendString(p,cellularEd.Text); Try PacketAppend32(p,longint(strtoint(zipEd.Text))); Except PacketAppend32(p,-1); end; PacketAppend16(p,GetCountry(countryCombo)); PacketAppend8(p,0); // 250 = +03:00 TimeZone. PacketAppend8(p,0); // ???? Main.SendUDPCmd(p,'META_USER+SET_INFO: ['+s(main.UIN)+'] ===>'); // CMD_META_USER + META_CMD_SET_WORK. P:=main.UDPCreateStdPacket(CMD_META_USER); PacketAppend16(p,META_CMD_SET_WORK); PacketAppendString(p,wcityEd.Text); PacketAppendString(p,wstateEd.Text); PacketAppendString(p,wphoneEd.Text); PacketAppendString(p,wfaxEd.Text); PacketAppendString(p,wstreetMemo.Lines[0]); Try PacketAppend32(p,longint(strtoint(wzipEd.Text))); Except PacketAppend32(p,-1); end; PacketAppend16(p,GetCountry(wcountryCombo)); PacketAppendString(p,companyEd.Text); PacketAppendString(p,departmentEd.Text); PacketAppendString(p,jobEd.Text); PacketAppend16(p,GetOccupation(occupationCombo)); PacketAppendString(p,whomepageEd.Text); Main.SendUDPCmd(p,'META_USER+SET_WORK: ['+s(main.UIN)+'] ===>'); // CMD_META_USER + META_CMD_SET_MORE. P:=main.UDPCreateStdPacket(CMD_META_USER); PacketAppend16(p,META_CMD_SET_MORE); Try PacketAppend16(p,word(strtoint(ageEd.Text))); Except PacketAppend16(p,0); end; PacketAppend8(p,GetGender(genderCombo)); PacketAppendString(p,homepageEd.Text); PacketAppend8(p,GetCombo(yearCombo,0,99)); PacketAppend8(p,GetMonth(monthCombo)); PacketAppend8(p,GetCombo(dayCombo,1,31)); PacketAppend8(p,GetLanguage(lang1Combo)); PacketAppend8(p,GetLanguage(lang2Combo)); PacketAppend8(p,GetLanguage(lang3Combo)); Main.SendUDPCmd(p,'META_USER+SET_MORE: ['+s(main.UIN)+'] ===>'); // CMD_META_USER + META_CMD_SET_ABOUT. P:=main.UDPCreateStdPacket(CMD_META_USER); PacketAppend16(p,META_CMD_SET_ABOUT); PacketAppendString(p,aboutMemo.lines[0]); Main.SendUDPCmd(p,'META_USER+SET_ABOUT: ['+s(main.UIN)+'] ===>'); // CMD_META_USER + META_CMD_SET_SECURE. P:=main.UDPCreateStdPacket(CMD_META_USER); PacketAppend16(p,META_CMD_SET_SECURE); PacketAppend8(p,1); // 0-autor required; 1-all users. PacketAppend8(p,0); // 0-not allow web; 1-allow web aware. PacketAppend8(p,0); // 0-hide IP; 1-show IP. Main.SendUDPCmd(p,'META_USER+SET_SECURE: ['+s(main.UIN)+'] ===>'); ///// *) UIAnime.Active := true; End; Procedure TUserInfo.SetCountry(Combo:TComboBox; Country:word); Var i : integer; Begin. Combo.Clear; For i:=0 to 121 do begin. Combo.Items.Add(Countries[i].Text); If Countries[i].Code = Country then Combo.Text := Countries[i].Text; End; If Combo.Text = '' then Combo.Text := Countries[121].Text; End; Function TUserInfo.GetCountry(Combo:TComboBox):word; Var i : integer; Begin. Result := $FFFF; For i:=0 to 121 do begin. If Countries[i].Text = Combo.Text then begin. Result := Countries[i].Code; Break; End; End; End; Procedure TUserInfo.SetGender(Combo:TComboBox; Gender:byte); Begin. Combo.Clear; Combo.Items.Add('Not specified'); Combo.Items.Add('Female'); Combo.Items.Add('Male'); Case Gender of. 0: Combo.Text := 'Not specified'; 1: Combo.Text := 'Female'; 2: Combo.Text := 'Male'; Else Combo.Text := 'Not specified'; End; End; Function TUserInfo.GetGender(Combo:TComboBox):byte; Begin. Result := 0; If Combo.Text = 'Female' then Result := 1. Else if Combo.Text = 'Male' then Result := 2; End; Procedure TUserInfo.SetMonth(Combo:TComboBox; Month:byte); Var i : integer; Begin. Combo.Clear; For i:=0 to 12 do begin. Combo.Items.Add(MetaMonth[i].Text); If MetaMonth[i].Code = Month then Combo.Text := MetaMonth[i].Text; End; If Combo.Text = '' then Combo.Text := MetaMonth[12].Text; End; Function TUserInfo.GetMonth(Combo:TComboBox):byte; Var i : integer; Begin. Result := 0; For i:=0 to 12 do begin. If MetaMonth[i].Text = Combo.Text then begin. Result := MetaMonth[i].Code; Break; End; End; End; Procedure TUserInfo.SetLanguage(Combo:TComboBox; Lang:byte); Var i : integer; Begin. Combo.Clear; For i:=0 to 67 do begin. Combo.Items.Add(MetaLanguages[i].Text); If MetaLanguages[i].Code = Lang then Combo.Text := MetaLanguages[i].Text; End; If Combo.Text = '' then Combo.Text := MetaLanguages[0].Text; End; Function TUserInfo.GetLanguage(Combo:TComboBox):byte; Var i : integer; Begin. Result := 0; For i:=0 to 67 do begin. If MetaLanguages[i].Text = Combo.Text then begin. Result := MetaLanguages[i].Code; Break; End; End; End; Procedure TUserInfo.SetOccupation(Combo:TComboBox; Occupation:word); Var i : integer; Begin. Combo.Clear; For i:=0 to 28 do begin. Combo.Items.Add(MetaOccupation[i].Text); If MetaOccupation[i].Code = Occupation then Combo.Text := MetaOccupation[i].Text; End; If Combo.Text = '' then Combo.Text := MetaOccupation[28].Text; End; Function TUserInfo.GetOccupation(Combo:TComboBox):word; Var i : integer; Begin. Result := 0; // not specified. For i:=0 to 27 do begin. If MetaOccupation[i].Text = Combo.Text then begin. Result := MetaOccupation[i].Code; Break; End; End; End; Procedure TUserInfo.SetCombo(Combo:TComboBox; min,max,Value:word); Var i : integer; Begin. Combo.Clear; For i:=min to max do begin. Combo.Items.Add(s(i)); If i=Value then Combo.Text := s(i); End; Combo.Items.Add('Not specified'); If Combo.Text = '' then Combo.Text := 'Not specified'; End; Function TUserInfo.GetCombo(Combo:TComboBox; min,max:byte):word; Begin. Result := 0; If Combo.Text = 'Not specified' then exit. Else. Try Result := strtoint(Combo.Text) except Result := 0; end; If (Result >= min) and (Result<=max) then exit else Result := 0; End; Procedure TUserInfo.ApplicationEvents1Message(var Msg: tagMSG; Var Handled: Boolean); Var PBuff : PInfoRec; Begin. If Msg.message = msg_UInfo then begin. If (Msg.wParam = Cookie)then begin. Handled := false; PBuff := PInfoRec(Msg.lParam); Case PBuff^.f of. DEND: begin. M(Form1.Memo,'The END.'); UIAnime.Active := false; End; DNick: begin. UIRecord.NICK := PBuff^.s; NickEd.Text := PBuff^.s; End; DFirst: begin. UIRecord.FIRST := PBuff^.s; FirstEd.Text := PBuff^.s; End; DLast: begin. UIRecord.LAST := PBuff^.s; LastEd.Text := PBuff^.s; End; DE_Mail: begin. UIRecord.PRI_E_MAIL := PBuff^.s; PriEd.Text := PBuff^.s; End; DSec_E_Mail: begin. UIRecord.SEC_E_MAIL := PBuff^.s; SecEd.Text := PBuff^.s; End; DOld_E_Mail: begin. UIRecord.OLD_E_MAIL := PBuff^.s; OldEd.Text := PBuff^.s; End; DIP: begin. Strtoip(PBuff^.s,UIRecord.IP); IpEd.Text := PBuff^.s; End; DReal_IP: begin. Strtoip(PBuff^.s,UIRecord.REAL_IP); RealipEd.Text := PBuff^.s; End; DVer: begin. UIRecord.VER := strtoint(PBuff^.s); VerEd.Text := PBuff^.s; End; DAuth: begin. UIRecord.AUTH := strtoint(PBuff^.s); Case UIRecord.AUTH of. 0: AuthLabel.Caption := 'Authorize'; 1: AuthLabel.Caption := 'Always'; Else AuthLabel.Caption := 'unknown'; End; End; DCity: begin. UIRecord.CITY := PBuff^.s; CityEd.Text := PBuff^.s; End; DState: begin. UIRecord.STATE := PBuff^.s; StateEd.Text := PBuff^.s; End; DPhone: begin. UIRecord.Phone := PBuff^.s; PhoneEd.Text := PBuff^.s; End; DFax: begin. UIRecord.Fax := PBuff^.s; FaxEd.Text := PBuff^.s; End; DCellular: begin. UIRecord.Cellular := PBuff^.s; CellularEd.Text := PBuff^.s; End; DZip: begin. UIRecord.Zip := PBuff^.s; ZipEd.Text := PBuff^.s; End; DStreet: begin. UIRecord.Street := PBuff^.s; StreetMemo.Clear; M(streetMemo,PBuff^.s); End; DCountry: begin. UIRecord.Country := strtoint(PBuff^.s); SetCountry(countryCombo,UIRecord.COUNTRY); End; DTimeZone: begin. UIRecord.TimeZone := strtoint(PBuff^.s); TzEd.Text := PBuff^.s; End; DWebAware: begin. // UIRecord.WebAware := strtoint(PBuff^.s); // webawareEd.Text := PBuff^.s; End; DHideIP: begin. // UIRecord.HideIP := PBuff^.s; // HideIPEd.Text := PBuff^.s; End; DAge: begin. UIRecord.Age := strtoint(PBuff^.s); AgeEd.Text := PBuff^.s; End; DGender: begin. UIRecord.Gender := strtoint(PBuff^.s); SetGender(genderCombo,UIRecord.GENDER); End; DHomepage: begin. UIRecord.Homepage := PBuff^.s; HomepageEd.Text := PBuff^.s; End; DByear: begin. UIRecord.Byear := strtoint(PBuff^.s); If UIRecord.Byear<>0 then dec(UIRecord.Byear,1900); SetCombo(yearCombo,1,99,UIRecord.Byear); End; DBmonth: begin. UIRecord.BMonth := strtoint(PBuff^.s); SetMonth(monthCombo,UIRecord.BMonth); End; DBday: begin. UIRecord.Bday := strtoint(PBuff^.s); SetCombo(dayCombo,1,31,UIRecord.Bday); End; DAbout: begin. UIRecord.ABOUT := PBuff^.s; AboutMemo.Clear; M(AboutMemo,PBuff^.s); End; DLang1: begin. UIRecord.LANG1 := strtoint(PBuff^.s); SetLanguage(lang1Combo,UIRecord.LANG1); End; DLang2: begin. UIRecord.LANG2 := strtoint(PBuff^.s); SetLanguage(lang2Combo,UIRecord.LANG2); End; DLang3: begin. UIRecord.LANG3 := strtoint(PBuff^.s); SetLanguage(lang3Combo,UIRecord.LANG3); End; DInterests: begin. UIRecord.INTERESTS := PBuff^.s; InterMemo.Clear; M(interMemo,PBuff^.s); End; DFailure: begin. ///////////////////////////// ????? End; DMeta_Srv_Res: begin. UIAnime.Active := false; End; DwCity: begin. UIRecord.WCITY := PBuff^.s; WcityEd.Text := PBuff^.s; End; DwState:begin. UIRecord.WSTATE := PBuff^.s; WstateEd.Text := PBuff^.s; End; DwPhone:begin. UIRecord.WPHONE := PBuff^.s; WphoneEd.Text := PBuff^.s; End; DwFax:begin. UIRecord.WFAX := PBuff^.s; WfaxEd.Text := PBuff^.s; End; DwStreet:begin. UIRecord.WSTREET := PBuff^.s; WstreetMemo.Clear; M(wstreetMemo,PBuff^.s); End; DwZip:begin. UIRecord.WZIP := PBuff^.s; WzipEd.Text := PBuff^.s; End; DwCountry:begin. UIRecord.WCOUNTRY := strtoint(PBuff^.s); SetCountry(wcountryCombo,UIRecord.WCOUNTRY); End; DCompany:begin. UIRecord.COMPANY := PBuff^.s; CompanyEd.Text := PBuff^.s; End; DDepartment:begin. UIRecord.DEPARTMENT := PBuff^.s; DepartmentEd.Text := PBuff^.s; End; DJob:begin. UIRecord.JOB := PBuff^.s; JobEd.Text := PBuff^.s; End; DOccupation:begin. UIRecord.OCCUPATION := strtoint(PBuff^.s); SetOccupation(occupationCombo,UIRecord.Occupation); End; DWhomepage:begin. UIRecord.WHOMEPAGE := PBuff^.s; WhomepageEd.Text := PBuff^.s; End; End; // case. Dispose(PBuff); End; End; End; End.

Функции преобразования UNICODE и ANSI строк.

StringToWideChar Преобразовывает строку формата ANSI в Unicode-строку.

WideCharLenToString Преобразовывает указанное количество символов Unicode-строки в ANSI строку.

WideCharLenToStrVar Преобразовывает заданное количество символов Unicode-строки в ANSI формат и копирует результат в указанную переменную.

WideCharToString Преобразовывает длинную строку Unicode в ANSI строку.

WideCharLenToStrVar Преобразовывает строку формата Unicode в ANSI-формат и копирует результирующую строку в указанную переменную.

©Drkb::00152.

Взято с http://atrussk.ru/delphi/

Unit с полезными функциями для работы с процессами

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Unit с полезными функциями для работы с процессами. Этот Unit содержит полезные функции для работы с процессами. Взять информацию о данном процессе, обо всех процессах, убить процесс, и т.д. Полезна при создании системных приложений под Win32. Надо хорошо оттестировать этот Unit. Зависимости: windows, PSAPI, TlHelp32, SysUtils; Автор: Alex Kantchev, stoma@bitex.bg. Copyright: Моя разработка, некоторые функции базируются на примере в MSDN jan 2000 Collection. Дата: 5 июня 2002 г. ********************************************** } Unit ProcUtilz; Interface. Uses windows, PSAPI, TlHelp32, SysUtils; Type TLpModuleInfo = packed record. ModuleInfo:LPMODULEINFO; ModulePID: Cardinal; ModuleName: String; End; Type TLpModuleInfoArray = Array of TLpModuleInfo; Function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; External 'KERNEL32.DLL'; Function DisplayProcessInThreeFingerSalute(PID:Integer; Disp:Boolean):Boolean; Function TakeProcessID (WindowTitle:String):Integer; Function GetCurrAppPID:Integer; Function GetAllProcessesInfo(ExtractFullPath: Boolean = false):TLpModuleInfoArray; Function ExtractExeFromModName(ModuleName: String):String; Function TerminateTask(PID:integer):integer; Implementation. //Wziat PID na danoi process ot nego window title. Function TakeProcessID(WindowTitle:String):Integer; Var. WH:THandle; Begin. Result := 0; WH := FindWindow (nil , pchar(WindowTitle)); IF WH <> 0 then. GetWindowThreadProcessID(WH, @Result); End; //Wziat PID na tekuchii process. Function GetCurrAppPID:Integer; Begin. GetCurrAppPID := GetCurrentProcessID; End; //Pokzat process s PID v task menagera Windows 9X. //WNIMANIE: Rabotaet tolko pod Win9x !!!! Function DisplayProcessInThreeFingerSalute(PID:Integer; Disp:Boolean):Boolean; Begin. Result := false; If Win32Platform = VER_PLATFORM_WIN32_WINDOWS then. Begin. Try. IF Disp=True then. RegisterServiceProcess(PID, 0). Else. RegisterServiceProcess(PID, 1); Except. Result := false; End; End; DisplayProcessInThreeFingerSalute := result; End; //Ostanavlivaet rabotu procesa. Ne rabotaet so WinNT. //serviznae processi. Function TerminateTask(PID:integer):integer; Var. Process_handle:integer; LpExitCode:Cardinal; Begin. Process_handle:=openprocess(PROCESS_ALL_ACCESS,true,pid); GetExitCodeProcess(process_handle,lpExitCode); If (process_handle = 0) then. TerminateTask := GetLastError. Else if terminateprocess(process_handle,lpExitCode) then. Begin. TerminateTask:=0; CloseHandle(process_handle); End. Else. Begin. TerminateTask := GetLastError; CloseHandle(process_handle); End; End; //Wziat informacia ob processse po ego PID. //Testirano pod WinNT. Function GetProcessInfo(PID: WORD):LPMODULEINFO; Var. RetVal: LPMODULEINFO; HProc: DWORD; HMod: HMODULE; Cm:cardinal; Begin. HProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,false, PID); GetMem(RetVal,sizeOf(LPMODULEINFO)); If not(hProc = 0) then. Begin. EnumProcessModules(hProc, @hMod, 4, cm); GetModuleInformation(hProc,hMod,RetVal,SizeOf(RetVal)); End; GetProcessInfo := RetVal; End; //Wziat executable processa ot ego polnai put. Function ExtractExeFromModName(ModuleName: String):String; Begin. ExtractExeFromModName := Copy(ModuleName,LastDelimiter('\',ModuleName)+1,Length(ModuleName));; End; //Wziat informacia ob wse processi rabotaushtie w tekuchii. //moment. Testirano pod WinNT. Function GetAllProcessesInfo(ExtractFullPath: Boolean = false):TLpModuleInfoArray; Var. ProcList: Array [0..$FFF] of DWORD; RetVal: TLpModuleInfoArray; ProcCnt: Cardinal; I,MaxCnt: WORD; ModName:array[0..max_path] of char; Ph,mh: THandle; Cm: Cardinal; SnapShot:THandle; ProcEntry:TProcessEntry32; RetValLength,CVal: WORD; ModInfo:LPMODULEINFO; Begin. //case the platform is Win9X. If Win32Platform = VER_PLATFORM_WIN32_WINDOWS then begin. GetMem(ModInfo,SizeOf(LPMODULEINFO)); SnapShot := CreateToolhelp32Snapshot(th32cs_snapprocess, 0); RetValLength := 0; CVal := 0; If not integer(SnapShot)=-1 then. Begin. ProcEntry.dwSize:=sizeof(TProcessEntry32); If Process32First(SnapShot, ProcEntry) then. Repeat. //get the size of out array. Inc(RetValLength); Until not Process32Next(SnapShot, ProcEntry); //set the size of the output array. SetLength(RetVal,RetValLength); //iterate through processes and get their info. If Process32First(SnapShot, ProcEntry) then. Repeat. Begin. Inc(CVal); ModInfo.lpBaseOfDll := nil; ModInfo.SizeOfImage := ProcEntry.dwSize; ModInfo.EntryPoint := nil; RetVal[CVal].ModuleInfo := ModInfo; RetVal[CVal].ModulePID := ProcEntry.th32ProcessID; If (ExtractFullPath) then. RetVal[CVal].ModuleName := string(ProcEntry.szExeFile). Else. RetVal[CVal].ModuleName := ExtractExeFromModName(string(ProcEntry.szExeFile)); ModInfo := nil; End; Until not Process32Next(SnapShot, ProcEntry); End; End. //case the platform is WinNT/2K/XP. Else. Begin. EnumProcesses(@ProcList,sizeof(ProcList),ProcCnt); MaxCnt := ProcCnt div 4; SetLength(RetVal,MaxCnt); //iterate through processes and get their info. For i := Low(RetVal) to High(RetVal) do. Begin. //Check for reserved PIDs. If ProcList[i] = 0 then. Begin. RetVal[i].ModuleName := 'System Idle Process'; RetVal[i].ModulePID := 0; RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i); End. Else if ProcList[i] = 8 then. Begin. RetVal[i].ModuleName := 'System'; RetVal[i].ModulePID := 8; RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i); End. //Gather info about all processes. Else. Begin. RetVal[i].ModulePID := ProcList[i]; RetVal[i].ModuleInfo := GetProcessInfo(ProcList[i]); //get module name. Ph:=OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,false, ProcList[i]); If ph>0 then. Begin. EnumProcessModules(ph, @mh, 4, cm); GetModuleFileNameEx(ph, mh, ModName, sizeof(ModName)); If (ExtractFullPath) then. RetVal[i].ModuleName := string(ModName). Else. RetVal[i].ModuleName := ExtractExeFromModName(string(ModName)); End. Else. RetVal[i].ModuleName := 'UNKNOWN'; CloseHandle(ph); End; End; End; //return the array of LPMODULEINFO structz. GetAllProcessesInfo := RetVal; End; End.

UPDATE из SЕLЕСТ'а.

UPDATE из SELECT'а

Code: UPDATE aaa. INNER JOIN bbb ON aaa.ID = bbb.ID. SET aaa.Num = bbb.Num;

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

©Drkb::02747.

URL декодирование строки

Code: { **** UBPFD *********** by kladovka.net.ru **** >> URL декодирование строки. Функция выполняет URL декодирование строки, заменяя все. Подстроки вида '%HH', где 'HH' - шестнадцатеричные. Цифры, на соответствующие символы. Зависимости: Windows. Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург. Copyright: Dimka Maslov. Дата: 27 мая 2002 г. ********************************************** } Function UrlDecode(Str: string): string; Function HexToChar(W: word): Char; Asm. Cmp ah, 030h. Jl @@error. Cmp ah, 039h. Jg @@10. Sub ah, 30h. Jmp @@30. @@10: Cmp ah, 041h. Jl @@error. Cmp ah, 046h. Jg @@20. Sub ah, 041h. Add ah, 00Ah. Jmp @@30. @@20: Cmp ah, 061h. Jl @@error. Cmp al, 066h. Jg @@error. Sub ah, 061h. Add ah, 00Ah. @@30: Cmp al, 030h. Jl @@error. Cmp al, 039h. Jg @@40. Sub al, 030h. Jmp @@60. @@40: Cmp al, 041h. Jl @@error. Cmp al, 046h. Jg @@50. Sub al, 041h. Add al, 00Ah. Jmp @@60. @@50: Cmp al, 061h. Jl @@error. Cmp al, 066h. Jg @@error. Sub al, 061h. Add al, 00Ah. @@60: Shl al, 4. Or al, ah. Ret. @@error: Xor al, al. End; Function GetCh(P: PChar; var Ch: Char): Char; Begin. Ch:=P^; Result:=Ch; End; Var. P: PChar; Ch: Char; Begin. Result:=''; P:=@Str[1]; While GetCh(P, Ch) <> #0 do begin. Case Ch of. '+': Result:=Result+' '; '%': begin. Inc(P); Result:=Result+HexToChar(PWord(P)^); Inc(P); End; Else Result:=Result+Ch; End; Inc(P); End; End;

URL кодирование строки

Code: { **** UBPFD *********** by kladovka.net.ru **** >> URL кодирование строки. Функция производит так назваемое URL кодирование строк для. Использования в http запросах. Т.е. все алфавитно-цифровые. Символы и знак подчёикивания '_' остаются неизменными, Пробел заменяется на '+', а все остальные символы на знак. Процента '%' с двумя шестнадцатеричными цифрами. Зависимости: Windows. Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург. Copyright: Dimka Maslov. Дата: 27 мая 2002 г. ********************************************** } Function UrlEncode(Str: string): string; Function CharToHex(Ch: Char): Integer; Asm. And eax, 0FFh. Mov ah, al. Shr al, 4. And ah, 00fh. Cmp al, 00ah. Jl @@10. Sub al, 00ah. Add al, 041h. Jmp @@20. @@10: Add al, 030h. @@20: Cmp ah, 00ah. Jl @@30. Sub ah, 00ah. Add ah, 041h. Jmp @@40. @@30: Add ah, 030h. @@40: Shl eax, 8. Mov al, '%' End; Var. I, Len: Integer; Ch: Char; N: Integer; P: PChar; Begin. Result:=''; Len:=Length(Str); P:=PChar(@N); For i:=1 to Len do begin. Ch:=Str[i]; If Ch in ['0'..'9', 'A'..'Z', 'a'..'z', '_'] then Result:=Result+Ch else begin. If Ch = ' ' then Result:=Result+'+' else begin. N:=CharToHex(Ch); Result:=Result+P; End; End; End; End;

URL кодирование строки

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> URL кодирование строки. Функция производит так назваемое URL кодирование строк для использования. В http запросах. Т.е. все алфавитно-цифровые символы и знак подчёикивания. '_' остаются неизменными, пробел заменяется на '+', а все остальные символы. На знак процента '%' с двумя шестнадцатеричными цифрами. Зависимости: Windows. Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург. Copyright: Dimka Maslov. Дата: 27 мая 2002 г. ***************************************************** } Function UrlEncode(Str: string): string; Function CharToHex(Ch: Char): Integer; Asm. And eax, 0FFh. Mov ah, al. Shr al, 4. And ah, 00fh. Cmp al, 00ah. Jl @@10. Sub al, 00ah. Add al, 041h. Jmp @@20. @@10: Add al, 030h. @@20: Cmp ah, 00ah. Jl @@30. Sub ah, 00ah. Add ah, 041h. Jmp @@40. @@30: Add ah, 030h. @@40: Shl eax, 8. Mov al, '%' End; Var. I, Len: Integer; Ch: Char; N: Integer; P: PChar; Begin. Result := ''; Len := Length(Str); P := PChar(@N); For i := 1 to Len do. Begin. Ch := Str[i]; If Ch in ['0'..'9', 'A'..'Z', 'a'..'z', '_'] then. Result := Result + Ch. Else. Begin. If Ch = ' ' then. Result := Result + '+' Else. Begin. N := CharToHex(Ch); Result := Result + P; End; End; End; End; Пример использования: Procedure TForm1.Button1Click(Sender: TObject); Var. S: string; Begin. S := UrlEncode('Delphi World'); ShellExecute(Handle, 'open', PChar('http://www.yandex.ru/yandsearch?text=' + S), '', '', SW_SHOWNORMAL); End; { **** UBPFD *********** by delphibase.endimus.com **** >> URL декодирование строки. Функция выполняет URL декодирование строки, заменяя все подстроки вида. '%HH', где 'HH' - шестнадцатеричные цифры, на соответствующие символы. Зависимости: Windows. Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург. Copyright: Dimka Maslov. Дата: 27 мая 2002 г. ***************************************************** } Function UrlDecode(Str: string): string; Function HexToChar(W: word): Char; Asm. Cmp ah, 030h. Jl @@error. Cmp ah, 039h. Jg @@10. Sub ah, 30h. Jmp @@30. @@10: Cmp ah, 041h. Jl @@error. Cmp ah, 046h. Jg @@20. Sub ah, 041h. Add ah, 00Ah. Jmp @@30. @@20: Cmp ah, 061h. Jl @@error. Cmp al, 066h. Jg @@error. Sub ah, 061h. Add ah, 00Ah. @@30: Cmp al, 030h. Jl @@error. Cmp al, 039h. Jg @@40. Sub al, 030h. Jmp @@60. @@40: Cmp al, 041h. Jl @@error. Cmp al, 046h. Jg @@50. Sub al, 041h. Add al, 00Ah. Jmp @@60. @@50: Cmp al, 061h. Jl @@error. Cmp al, 066h. Jg @@error. Sub al, 061h. Add al, 00Ah. @@60: Shl al, 4. Or al, ah. Ret. @@error: Xor al, al. End; Function GetCh(P: PChar; var Ch: Char): Char; Begin. Ch := P^; Result := Ch; End; Var. P: PChar; Ch: Char; Begin. Result := ''; P := @Str[1]; While GetCh(P, Ch) <> #0 do. Begin. Case Ch of. '+': Result := Result + ' '; '%': Begin. Inc(P); Result := Result + HexToChar(PWord(P)^); Inc(P); End; Else. Result := Result + Ch; End; Inc(P); End; End;

Using a DSO on Apache 2.0.43, created with Kylix 3.

After compiling and installing Apache 2.0.39 with DSO support, deploying an .so file built with Kylix 3 doesn't work.

You need to change MODULE_MAGIC_NUMBER_MAJOR in HTTPD.pas file to the following: MODULE_MAGIC_NUMBER_MAJOR = 20020903;

©Drkb::04588.

Using Tapi.

How can I use TAPI to dial the telephone for a voice call?

The following example shows how to interface with tapi to make a voice call.

Code: {tapi Errors}. Const TAPIERR_CONNECTED = 0; Const TAPIERR_DROPPED = -1; Const TAPIERR_NOREQUESTRECIPIENT = -2; Const TAPIERR_REQUESTQUEUEFULL = -3; Const TAPIERR_INVALDESTADDRESS = -4; Const TAPIERR_INVALWINDOWHANDLE = -5; Const TAPIERR_INVALDEVICECLASS = -6; Const TAPIERR_INVALDEVICEID = -7; Const TAPIERR_DEVICECLASSUNAVAIL = -8; Const TAPIERR_DEVICEIDUNAVAIL = -9; Const TAPIERR_DEVICEINUSE = -10; Const TAPIERR_DESTBUSY = -11; Const TAPIERR_DESTNOANSWER = -12; Const TAPIERR_DESTUNAVAIL = -13; Const TAPIERR_UNKNOWNWINHANDLE = -14; Const TAPIERR_UNKNOWNREQUESTID = -15; Const TAPIERR_REQUESTFAILED = -16; Const TAPIERR_REQUESTCANCELLED = -17; Const TAPIERR_INVALPOINTER = -18; {tapi size constants}. Const TAPIMAXDESTADDRESSSIZE = 80; Const TAPIMAXAPPNAMESIZE = 40; Const TAPIMAXCALLEDPARTYSIZE = 40; Const TAPIMAXCOMMENTSIZE = 80; Const TAPIMAXDEVICECLASSSIZE = 40; Const TAPIMAXDEVICEIDSIZE = 40; Function tapiRequestMakeCallA(DestAddress : PAnsiChar; AppName : PAnsiChar; CalledParty : PAnsiChar; Comment : PAnsiChar) : LongInt; Stdcall; external 'TAPI32.DLL'; Function tapiRequestMakeCallW(DestAddress : PWideChar; AppName : PWideChar; CalledParty : PWideChar; Comment : PWideChar) : LongInt; Stdcall; external 'TAPI32.DLL'; Function tapiRequestMakeCall(DestAddress : PChar; AppName : PChar; CalledParty : PChar; Comment : PChar) : LongInt; Stdcall; external 'TAPI32.DLL'; Procedure TForm1.Button1Click(Sender: TObject); Var. DestAddress : string; CalledParty : string; Comment : string; Begin. DestAddress := '1-555-555-1212'; CalledParty := 'Frank Borland'; Comment := 'Calling Frank'; TapiRequestMakeCall(pChar(DestAddress), PChar(Application.Title), PChar(CalledParty), PChar(Comment)); End; End.

©Drkb::01466.

Using the Shell API function SHBrowseForFolder.

Code: Uses ShellAPI, ShlObj; Procedure TForm1.Button1Click(Sender: TObject); Var. TitleName : string; LpItemID : PItemIDList; BrowseInfo : TBrowseInfo; DisplayName : array[0..MAX_PATH] of char; TempPath : array[0..MAX_PATH] of char; Begin. FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); BrowseInfo.hwndOwner := Form1.Handle; BrowseInfo.pszDisplayName := @DisplayName; TitleName := 'Please specify a directory'; BrowseInfo.lpszTitle := PChar(TitleName); BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; LpItemID := SHBrowseForFolder(BrowseInfo); If lpItemId nil then begin. SHGetPathFromIDList(lpItemID, TempPath); ShowMessage(TempPath); GlobalFreePtr(lpItemID); End; End;

Using Visual Basic arrays in Delphi.

How do I pass arrays from VB to Delphi?

Arrays can be passed as variants:

VB module code:

Code: Attribute VB_Name = "Module1". Declare Function TestMin Lib "c:\windows\system\NoelSArr". (Nums As Variant) As Integer.

VB form code:

Code: Dim A As Variant. Private Sub Command1_Click(). A = Array(4, 3). MsgBox (TestMin(A)). End Sub.

Благодарности.

Хочу выразить свою благодарность администрации форумов Vingrad.ru и Sources.ru любезно разрешивших составить этот документ.

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

Как долго запущена Windows?

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

Windows started on Thursday, February 10, 2000 at 11:42:46 AM.

Its been up for 0 days, 3 hours, 22 minutes, 54 seconds.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Ndays: double; Ticks: LongInt; Btime: TDateTime; Begin. {Функция GetTickCount получает количество миллисекунд, прошедших с момента старта Windows}. Ticks := GetTickCount; {Чтобы получить дни, необходимо разделить на количество миллисекунд в дне, 24*60*60*1000=86400000}. Ndays := ticks/86400000; {теперь вычитаем из текущей даты полученное количество дней работы Windows}. BTime := now-ndays; {показываем диалоговое окошко с сообщением}. ShowMessage( FormatDateTime('"Windows started on" dddd, mmmm d, yyyy, ' + '"at" hh:nn:ss AM/PM', bTime) + #10#13 + 'Its been up for ' + IntToStr(Trunc(nDays)) + ' days,' + FormatDateTime(' h "hours," n "minutes," s "seconds"',ndays)); End;

Как завершить сеанс работы или перезагрузить Windows NT?

Для этого нам потребуются определённые привелегии:

Code: Function SetPrivilege(aPrivilegeName : string; AEnabled : boolean ): boolean; Var. TPPrev, TP : TTokenPrivileges; Token : THandle; DwRetLen : DWord; Begin. Result := False; OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES. Or TOKEN_QUERY, @Token ); TP.PrivilegeCount := 1; If( LookupPrivilegeValue(nil, PChar( aPrivilegeName ), TP.Privileges[ 0 ].LUID ) ) then. Begin. If( aEnabled )then. TP.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED; Else. TP.Privileges[0].Attributes:= 0; DwRetLen := 0; Result := AdjustTokenPrivileges(Token,False,TP, SizeOf( TPPrev ), TPPrev,dwRetLen ); End; CloseHandle( Token ); End; Function WinExit( iFlags : integer ) : boolean; // возможные флаги: // EWX_LOGOFF. // EWX_REBOOT. // EWX_SHUTDOWN. Begin. Result := True; If( SetPrivilege( 'SeShutdownPrivilege', true ) ) then. Begin. If( not ExitWindowsEx( iFlags, 0 ) )then. Begin. Result := False; End; SetPrivilege( 'SeShutdownPrivilege', False ). End. Else. Begin. Result := False; End; End;

©Drkb::01669.

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

Как получить закэшированные пароли в Win9x?

Code: Program getpass; ........ Type. ... ListBox: TListBox; Procedure getpasswords; ....... End; Const Count: Integer = 0; Function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; stdcall; Implementation. {$R *.DFM}. Function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; external mpr name 'WNetEnumCachedPasswords'; Type. PWinPassword = ^TWinPassword; TWinPassword = record. EntrySize: Word; ResourceSize: Word; PasswordSize: Word; EntryIndex: Byte; EntryType: Byte; PasswordC: Char; End; Var. WinPassword: TWinPassword; Function AddPassword(WinPassword: PWinPassword; dw: DWord): LongBool; stdcall; Var. Password: String; PC: Array[0..$FF] of Char; Begin. Inc(Count); Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize); PC[WinPassword.ResourceSize] := #0; CharToOem(PC, PC); Password := StrPas(PC); Move(WinPassword.PasswordC, PC, WinPassword.PasswordSize + WinPassword.ResourceSize); Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize); PC[WinPassword.PasswordSize] := #0; CharToOem(PC, PC); Password := Password + ': ' + StrPas(PC); Form1.ListBox.Items.Add(Password); Result := True; End; Procedure tform1.getpasswords; Var error: string; Begin. If WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then. Begin. Error := 'Can not load passwords: User is not loged on.'; End. Else if Count = 0 then. Error := 'No passwords found...' End;

Как определить, изменилось ли системное время?

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

Code: Type. TForm1 = class(TForm). Private. { Private declarations }. Procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); message WM_TIMECHANGE; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE); Begin. Form1.Caption := 'Time Changed'; End;

Выставляем горячие клавиши для Delphi приложения.

Как сделать так, чтобы при минимизации приложения в Tray его можно было вызвать определённой комбинацией клавиш, например Alt-Shift-F9 ?

Code: //В обработчике события OnCreate. //основной формы создаём горячую клавишу: If not RegisterHotkey. (Handle, 1, MOD_ALT or MOD_SHIFT, VK_F9) Then. ShowMessage('Unable to assign Alt-Shift-F9 as hotkey.'); //В событии OnClose удаляем горячую клавишу: UnRegisterHotkey( Handle, 1 ); //Добавляем обработчик в форму для сообщения. //WM_HOTKEY: Private // в секции объявлений формы. Procedure WMHotkey( Var msg: TWMHotkey ); Message WM_HOTKEY; Procedure TForm1.WMHotkey( Var msg: TWMHotkey ); Begin. If msg.hotkey = 1 Then Begin. If IsIconic( Application.Handle ) Then. Application.Restore; BringToFront; End; End;

©Drkb::01524.

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

Выполняем встроенные команды Windows.

Автор: Ruslan Abu Zant.

Компилятор: Delphi 4.x (или выше).

Впринципе эти команды можно запускать в меню "Выполнить..." (Run), кнопки Пуск. Ну а в Delphi они запускаются путём всем извесной команды winexec(Pchar('ABCD'),sw_Show);

Где 'ABCD' - одна из следующих команд ...

"rundll32 shell32,Control_RunDLL" - Запустить Панель Управления.

"rundll32 shell32,OpenAs_RunDLL" - Открыть диалог "Открыть Как ..." ('Open With...').

"rundll32 shell32,ShellAboutA Info-Box" - Открыть 'About Window Window'

"rundll32 shell32,Control_RunDLL desk.cpl" - Открыть диалог "Свойства: Экран" (Display Properties).

"rundll32 user,cascadechildwindows" - Выстроить все окна каскадно.

"rundll32 user,tilechildwindows" - Свернуть все окна.

"rundll32 user,repaintscreen" - Обновить Десктоп.

"rundll32 shell,shellexecute Explorer" - Перезапустить Проводник.

"rundll32 keyboard,disable" - Заблокировать Клавиатуру.

"rundll32 mouse,disable" - Запретить мышку.

"rundll32 user,swapmousebutton" - Поменять кнопки мыши.

"rundll32 user,setcursorpos" - Установить Курсор в позицию (0,0).

"rundll32 user,wnetconnectdialog" - Показать диалог "Подключить сетевой диск" ('Map Network Drive').

"rundll32 user,wnetdisconnectdialog" - Показать диалог "Отключить сетевой диск" ('Disconnect Network Disk').

"rundll32 user,disableoemlayer" - Отобразить окно BSOD ('''(BSOD) = Blue Screen Of Death ''').

"rundll32 diskcopy,DiskCopyRunDll" - Показать диалог копирования диска.

"rundll32 rnaui.dll,RnaWizard" - Запустить 'Internet Connection Wizard'

"rundll32 shell32,SHFormatDrive" - Запустить окно форматирования дискеты ('Format Disk (A)').

"rundll32 shell32,SHExitWindowsEx -1" - "Холодный" перезапуск Проводника.

"rundll32 shell32,SHExitWindowsEx 1" - Выключить компьютер.

"rundll32 shell32,SHExitWindowsEx 0" - Завершить сеанс текущего пользователя.

"rundll32 shell32,SHExitWindowsEx 2" Быстрый перезапуск Windows9x.

"rundll32 krnl386.exe,exitkernel" - Выход из Windows 9x без потверждения.

"rundll rnaui.dll,RnaDial "MyConnect" - Запустить диалог 'Net Connection'

"rundll32 msprint2.dll,RUNDLL_PrintTestPage" - Выбор и печать тестовой страницы текущего принтера.

"rundll32 user,setcaretblinktime" - Усатновить скорость мигания курсора.

"rundll32 user, setdoubleclicktime" - Установить скорость двойного нажатия.

"rundll32 sysdm.cpl,InstallDevice_Rundll" - Поиск устройств не PnP.

©Drkb::01735.

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

Как пользоваться командой шела - MinimizeAll?

Для этого надо импортировать Microsoft Shell Controls & Automation Type Library.

В меню Project..Import Type Library.

Выберите Microsoft Shell Controls & Automation (version 1.0).

Нажмите Install...

На панели компонентов, в закладке ActiveX появится несколько компонентов. Перетащите на форму компонент TShell. После этого, например, можно всё минимизировать:

Shell1.MinimizeAll;

Code: /********************************************************************* Так же в этом компоненте присутствует давольно много забавных примочек. *********************************************************************/ Procedure TForm1.Shell(sMethod: Integer); Begin. Case sMethod of. 0: //Минимизируем все окна на рабочем столе. Begin. Shell1.MinimizeAll; Button1.Tag := Button1.Tag + 1; End; 1: //Показываем диалоговое окошко Run. Begin. Shell1.FileRun; Button1.Tag := Button1.Tag + 1; End; 2: //Показываем окошко завершения работы Windows. Begin. Shell1.ShutdownWindows; Button1.Tag := Button1.Tag + 1; End; 3: //Показываем окно поиска файлов. Begin. Shell1.FindFiles; Button1.Tag := Button1.Tag + 1; End; 4: //Отображаем окно настройки времени и даты. Begin. Shell1.SetTime; Button1.Tag := Button1.Tag + 1; End; 5: //Показываем диалоговое окошко настройки интернета (Internet Properties). Begin. Shell1.ControlPanelItem('INETCPL.cpl'); Button1.Tag := Button1.Tag + 1; End; 6: //Предлагаем пользователю выбрать директорию из Program Files. Begin. Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files'); Button1.Tag := Button1.Tag + 1; End; 7: //Показываем диалоговое окошко настройки панели задач. Begin. Shell1.TrayProperties; Button1.Tag := Button1.Tag + 1; End; 8: //Восстанавливаем все окна на рабочем столе. Begin. Shell1.UndoMinimizeAll; Button1.Tag := 0; End; End; {case}. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Shell(Button1.Tag); End;

Как показать окно свойств экрана?

Для этого воспользуемся 'Rundll32.exe' и запустим её в 'shellexecute'. Не забудьте добавить 'shellapi' в Ваш список uses.

Code: Function GetSystemDir: TFileName; Var. SysDir: array[0..MAX_PATH - 1] of char; Begin. SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH)); If Result = '' then. Raise Exception.Create(SysErrorMessage(GetLastError)); End; Procedure TForm1.Button1Click(Sender: TObject); Var. X: Tfilename; Begin. X := getsystemdir; ShellExecute(Form11.Handle, 'open', Pchar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl,@0,3', Pchar(X), SW_normal); End; //getsystemdir это функция, которая совместима со всеми версиями windows.

Как открыть диалог Add printer?

Добавьте ShellAPI в USES.

Code: ShellExecute(handle, nil, 'rundll32.exe', 'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL);

Ссылки на сайты по Дельфи.

Http://www.forum.vingrad.ru/ программистский портал с большим разделом Дельфи.

Http://www.sources.ru программистский портал с большим разделом Дельфи.

Http://www.borland.com.ru/delphi/index.htm Borland Russia.

На сервере новости для разработчиков ПО на Delphi. Полное описание свойств Delphi 4. Полезные ссылки на ресурсы Delphi в Интернет. "Лидер на рынке RAD-инструментов" и "Delphi снова побеждает! " - это лозунги с этого сайта.

Http://www.torry.net Torry's Delphi Pages.

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

Www.delphikingdom.com - 'Королевство Дельфи' - Виртуальный клуб программистов. Сайт для программистов пишущих на Delphi, организация взаимопомощи и общение программистов на тему задач на Delphi.

Http://www.delphimaster.ru/ - Мастера Дельфи. Большое количество статей и материалов.

Как программно вазвать окно Завершение работы Windows?

Code: SendMessage (FindWindow ('Progman', 'Program Manager'), WM_CLOSE, 0, 0);

©Drkb::01668.

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

Как управлять спикером под 9х из Дельфи?

Прислал: Ненашев Илья Николаевич.

Под WinNT/2000/XP вы можете использовать Beep(Tone, Duration) (задавать тон и продолжительность звучания). А под 9.x/Me эта функция не реализована, но можно командовать железом через порты, и сделать универсальную:

Code: Unit BeepUnit; Procedure Beep(Tone, Duration: Word); // универсальная - версию виндовса проверяет. Procedure Sound(Freq : Word); Procedure NoSound; Procedure SetPort(address, Value:Word); Function GetPort(address:word):word; Implementation. Procedure SetPort(address, Value:Word); Var. BValue: byte; Begin. BValue := trunc(Value and 255); Asm. Mov dx, address. Mov al, bValue. Out dx, al. End; End; Function GetPort(address:word):word; Var. BValue: byte; Begin. Asm. Mov dx, address. In al, dx. Mov bValue, al. End; GetPort := bValue; End; Procedure Sound(Freq : Word); Var. B : Byte; Begin. If Freq > 18 then begin. Freq := Word(1193181 div LongInt(Freq)); B := Byte(GetPort($61)); If (B and 3) = 0 then begin. SetPort($61, Word(B or 3)); SetPort($43, $B6); End; SetPort($42, Freq); SetPort($42, Freq shr 8); End; End; Procedure NoSound; Var. Value: Word; Begin. Value := GetPort($61) and $FC; SetPort($61, Value); End; Procedure Beep(Tone, Duration: Word); Begin. If SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT. Then Windows.Beep(Tone, Duration). Else begin. Sound(Tone); Windows.Sleep(Duration); NoSound; End; End; End.

Как научить приложение Delphi разговаривать?

Автор: Alec Bergamini.

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

11-го августа 2001 Microsoft объявила о выпуске SAPI 5.1 SDK. Данный продукт можно использовать в любом языке, который поддерживает OLE автоматизацию.

В данной статье я постараюсь раасказать, как установить SAPI 5.1 SDK. Затем мы посмотрим, как использовать SDK в приложении Delphi для преобразования текста в синтезированную речь. Синтезированная речь будет проигрываться через спикер. Всё это тестировалось в Delphi 5 и 6.

Чтобы скачать SAPI 5.1, необходимо зайти на сайт Microsoft's Speech.net Technologies по адресу http://www.microsoft.com/speech/ и кликнуть по ссылке download. Далее будет предложено прочитать комментарии к данному продукту. Если в Вашей системе, язык по умолчанию отличается от US English, то настоятельно рекомендую прочитать эти комментарии до конца.

Если Вы используете beta версию операционной системы XP, то у Вас могут возникнуть некоторые проблемы. Проблемы связаны с тем, что большинство beta версий XP включают в себя ранние версии SAPI 5.1. Поэтому не пытайтесь инсталировать release версию SAPI 5.1 на XP, она не будет работать.

После того как Вы прочитаете комментарии, то приступайте к скачиванию Speech SDK 5.1. Всё что для этого потребуется, это нажать на ссылку Speech SDK 5.1 (68 MB). В архиве содержится сам SDK, докумантация, а так же текты на английском для примера.

Итак, после скачивания SAPI 5.1 SDK, запустите speechsdk51.exe для установки его на Ваш компьютер.

Теперь надо дать знать Delphi о новых объектах автоматизации SAPI. Для этого запустите Delphi 5 или 6 (Я не пробовал боле ранние версии) и откройте Project | Import Type Library. В диалоге Import Type Library выберите "Microsoft Speech Object Library (Version 5.1)". Если Вы не нашли его в списке, значит во время инсталяции SAPI 5.1 произошли какие-то ошибки.

Delphi предложит поместить компоненты SAPI на станицу ActiveX. Я рекомендую разместить их в новой странице под названием "SAPI 5", так как количество компонент довольно большое (19). Так же рекомендую Вам выбрать "Unit dir name" отличающуюся от той, которая предлагается по умолчанию. Убедитесь, что на "Generate Component Wrapper" стоит галочка и нажмите кнопку >Install<.

В диалоге Install выберите закладку "Into new package" и в поле "File name:" введите имя пакета наподобие "SAPI5.dpk", нажмите кнопку "Обзор..." (browse) и убедитесь, что dpk создан в той же директории, в которой были созданы компоненты. В диалоге Install в поле Description задайте какое-нибудь описание, например "SAPI 5 automation components". Нажмите OK.

В подтверждающем диалоге нажмите yes. После этого новые компоненты будут установлены.

Теперь, если Вы посмотрите в директорию, которую указали для установки компонент, то обнаружите там файл SpeechLib_TLB.pas (и dcr) который содержит весь код компоненты (интерфайс, константы, типы, а так же другую полезную информацию). Эта директория так же содержит (если Вы следовали вышеприведённым инструкциям) SAPI5.dpk который является исходинком пакета.

А теперь самая интересная часть.

Давайте создадим приложение, которое будет синтезировать речь. В Delphi создайте новое приложение и поместите на форму кнопку. На странице компонент SAPI5 найдите SpVoice и перетащите его на форму.

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. SpVoice1.Speak('Hello world!', SVSFDefault); End;

Как определить, запущено ли приложение в Windows NT?

Следующий кодкомпилируется как на 16-ти, так и на 32-битных платформах.

Code: {$IFNDEF WIN32}. Const WF_WINNT = $4000; {$ENDIF}. Function IsNT : bool; {$IFDEF WIN32}. Var. Osv : TOSVERSIONINFO; {$ENDIF}. Begin. Result := true; {$IFDEF WIN32}. GetVersionEx(osv); If osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit; {$ELSE}. If ((GetWinFlags and WF_WINNT) = WF_WINNT ) then exit; {$ENDIF}. Result := false; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If IsNt then. ShowMessage('Running on NT'). Else. ShowMessage('Not Running on NT'); End;

Программирование на основе Win32 API в Delphi (статья).

Николай Мазуркин, 1999-2000.

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

1. Введение

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

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

4. Библиотека WinLite

©Drkb::02009.

Pipeline Components.

Эта область разработки возникла в моем текущем проекте. Pipeline components - это COM-объекты, которые выполняются в pipeline, который в свою очередь вызывается на выполнение обычно через ASP. Pipeline представляет собой цепочку pipeline component, выполняющихся последовательно один за одним. На вход pipeline передается объект IDictionary, который передается всем компонентам в цепочке. Результатом работы этих компонент может быть видоизмененный IDictionary, либо еще чего-нибудь.

Описание.

Pipeline компоненты должны поддерживать интерфейс IPipelineComponent, а также несколько других. Обо всех будет рассказано поподробнее ниже.

Представим себе, что мы хотим создать компонент, который сбрасывает содержимое IDictionary в xml-файл на диск. Причем мы хотим иметь возможность задавать имя этого файла в Properties Page внутри Pipeline Editor. Для ознакомления с Pipeline Editor советую обратиться на сайт Microsoft.

В первую очередь, для создания компонента в Delphi необходимо создать ActiveX Library. Для этого выполним команду File|New -> Activex tabsheet -> ActiveX Library. Затем там добавим Automation Object. Назовем объект DumpOrderToXml. Добавим методы SetXmlFilename и GetXmlFilename. Результатом должны быть следующие объявления:

Function SetXmlFilename(XmlFileName: WideString): HResult [dispid $00000001]; stdcall;

Function GetXmlFileName(retval XmlFileName: WideString): HResult [dispid $00000002]; stdcall;

Для дальнейшей успешной работы Вы должны иметь на диске следующие файлы: COMMERCELib_TLB.pas, MSCSAspHelpLib_TLB.pas, MSCSCoreLib_TLB.pas, PIPELINELib_TLB.pas. Их можно сгенерировать с помощью tipe library editor, предоставляемого Delphi, либо скачать у меня. Также необходимо иметь на диске ComPUtil.pas и PipeConsts.pas файлы, которые есть у меня.

Delphi поможет Вам создать макет модуля с классом TDumpOrderToXml. В объявление этого класса добавьте дополнительные интерфейсы и соответсвующие методы для их реализации:

Code: Type. TDumpOrderToXml = class(TAutoObject, IDumpOrderToXml, IPipelineComponent, ISpecifyPropertyPages, IPersistStreamInit). Private. FXmlFileName: WideString; Protected. { IDumpOrderToXml methods }. Function GetXmlFileName(out XmlFileName: WideString): HResult; stdcall; Function SetXmlFilename(const XmlFileName: WideString): HResult; stdcall; { IPipelineComponent methods }. Function EnableDesign(fEnable: Integer): HResult; stdcall; Function Execute(const pdispOrder, pdispContext: IDispatch; LFlags: Integer; out plErrorLevel: Integer): HResult; stdcall; { ISpecifyPropertyPages methods }. Function GetPages(out pages: TCAGUID): HResult; stdcall; { IPersistStreamInit methods }. Function GetClassID(out classID: TCLSID): HResult; stdcall; Function IsDirty: HResult; stdcall; Function Load(const stm: IStream): HResult; stdcall; Function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall; Function GetSizeMax(out cbSize: Largeint): HResult; stdcall; Function InitNew: HResult; stdcall; End;

События, происходящие в приложениях Delphi при завершении работы Windows.

Я провел небольшое исследование, и вот что я выяснил:

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

FormCloseQuery - действие по умолчанию, устанавливает переменную CanClose в значание TRUE и продолжает закрытие формы.

FormClose.

FormDestroy.

Если приложение активно и вы пытаетесь завершить работу Windows (Shut Down), происходят следующие события (с соблюдением последовательности):

FormCloseQuery.

FormDestroy.

Мы видим, что метод FormClose в этом случае не вызывается.

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

Windows посылает сообщение WM_QUERYENDSESSION всем приложениям и ожидает ответ.

Каждое приложение получает сообщение и возвращает одну из величин: не равную нулю - приложение готово завершить свою работу, 0 - приложение не может завершить свою работу.

Если одно из приложений возвращает 0, Windows не завершает свою работу, а снова рассылает всем окнам сообщение, на этот раз WM_ENDSESSION.

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

Завершение работы Windows.

Первое решение проблемы: приложение Delphi на сообщение WM_QUERYENDSESSION должно возвратить 0, не дав при этом Windows завершить свою работу. При этом бессмысленно пытаться воспользоваться методом FormCloseQuery, поскольку нет возможности определить виновника завершения работы приложения (это может являться как результатом сообщения WM_QUERYENDSESSION, так и просто действием пользователя при попытке закрыть приложение).

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

Code: Unit Unit1; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; Type. TForm1 = class(TForm). Procedure FormClose(Sender: TObject; var Action: TCloseAction); Private. {--------------------------------------------------------} { Объявляем свой обработчик сообщения WM_QUERYENDSESSION }. {--------------------------------------------------------} Procedure WMQueryEndSession( Var Message: TWMQueryEndSession); message WM_QUERYENDSESSION; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. {--------------------------------------------------------------} { Создаем процедуру обработки сообщения WM_QUERYENDSESSION. }. { Приложение получит только это сообщение при попытке Windows }. { завершить работу }. {--------------------------------------------------------------} Procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession); Begin. Inherited; { сначала сообщание должен обработать наследуемый метод }. {--------------------------------------------------------------------} { в этой точке вы также можете сообщить Windows о неготовности }. { приложения завершить работу... }. { Message.Result:=0; }. {-------------------------------------------или----------------------}. { вызов процедуры освобождения ресурсов, предусмотренной в FormClose }. { MyCleanUpProcedure; }. {--------------------------------------------------------------------} End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. MyCleanUpProcedure; End; End.

Как запретить кнопку close в любом окне?

Следующий пример запрещает кнопку закрытия (и пункт "закрыть" (close) в системном меню) нужного нам окна (в данном случае Notepad).

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. HwndHandle : THANDLE; HMenuHandle : HMENU; Begin. HwndHandle := FindWindow(nil, 'Untitled - Notepad'); If (hwndHandle <> 0) then begin. HMenuHandle := GetSystemMenu(hwndHandle, FALSE); If (hMenuHandle <> 0) then. DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); End; End;

Как использовать встроенные в Windows иконки в своём приложении?

Сперва необходимо узнать, константы, которые соответствуют определённым иконкам. Все они определены в API unit (windows.pas) в Delphi:

IDI_HAND.

IDI_EXCLAMATION.

Or.

IDI_QUESTION.

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

Code: Var. DC: HDC; Icon: HICON; Begin. DC := GetWindowDC(Panel1.Handle); Icon := LoadIcon(0, IDI_QUESTION); DrawIcon(DC, 5, 5, Icon); ReleaseDC(Panel1.Handle, DC); End;

Как редактировать таблицы виртуальных и динамических методов?

Code: Unit EditorVMTandDMTTables; Interface. // функция служит для выяснения существования VMT у класса. // возвращает True, если класс имеет VMT и False - если нет. Function IsVMTExist(Cls: TClass): Boolean; // процедура служит для замены адреса метода в VMT класса со смещением. // Offset(должно быть кратно 4) новым адресом, хранящимся в NewMet. // примечание: перед вызовом этой процедуры проверяйте существование. // VMT у класса функцией IsVMTExist. Procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer); overload; // процедура служит для замены адреса метода, хранящегося в OldMet, // в VMT класса новым адресом, хранящимся в NewMet. // примечание: перед вызовом этой процедуры проверяйте существование. // VMT у класса функцией IsVMTExist. Procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload; // функция служит для замены адреса динамического метода класса с индексом, // хранящимся в Index, новым адресом, хранящимся в NewMet. // возвращает True, если метод с данным индексом найден и False - если нет. Function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean; overload; // функция служит для замены адреса динамического метода класса, хранящегося. // в OldMet, новым адресом, хранящимся в NewMet. // возвращает True, если метод с данным адресом найден и False - если нет. Function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean; overload; Implementation. // функция служит для получения указателя на байт, следующий за адресом. // последнего метода в VMT класса. // возвращает nil в случае, если у класса нет VMT. // функция является "внутренней" в модуле. // (используется другими подпрограммами и не объявлена в секции interface). // , поэтому используйте её только если. // Вы полностью уверены в своих действиях(она изменяет "рабочие" регистры. // ECX и EDX). Function GetVMTEnd(Cls: TClass): Pointer; Asm. // Вход: Cls --> EAX. // Выход: Result --> EAX. PUSH EBX. MOV ECX, 8. MOV EBX, -1. MOV EDX, vmtSelfPtr. @@cycle: ADD EDX, 4. CMP [EAX + EDX], EAX. JE @@vmt_not_found. JB @@continue. CMP [EAX + EDX], EBX. JAE @@continue. MOV EBX, [EAX + EDX]. @@continue: DEC ECX. JNZ @@cycle. MOV EAX, EBX. JMP @@exit. @@vmt_not_found: XOR EAX, EAX. @@exit: POP EBX. End; Function IsVMTExist(Cls: TClass): Boolean; Asm. // Вход: Cls --> EAX. // Выход: Result --> AL. CALL GetVMTEnd. TEST EAX, EAX. JZ @@vmt_not_found. MOV AL, 1. @@vmt_not_found: End; Procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer); overload; Asm. // Вход: Cls --> EAX, Offset --> EDX, NewMet --> ECX. MOV [EAX + EDX], ECX. End; Procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload; Asm. // Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX. PUSH EDI. MOV EDI, EAX. PUSH ECX. PUSH EDX. PUSH EAX. CALL GetVMTEnd. POP EDX. SUB EAX, EDX. SHR EAX, 2. POP EDX. POP ECX. PUSH ECX. MOV ECX, EAX. MOV EAX, EDX. POP EDX. REPNE SCASD. JNE @@OldMet_not_found. MOV [EDI - 4], EDX. @@OldMet_not_found: POP EDI. End; Function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean; overload; Asm. // Вход: Cls --> EAX, Index --> DX, NewMet --> ECX. // Выход: Result --> AL. PUSH EDI. PUSH ESI. MOV ESI, ECX. XOR EAX, EDX. XOR EDX, EAX. XOR EAX, EDX. JMP @@start. @@cycle: MOV EDX, [EDX]. @@start: MOV EDI, [EDX].vmtDynamicTable. TEST EDI, EDI. JZ @@get_parent_dmt. MOVZX ECX, WORD PTR [EDI]. PUSH ECX. ADD EDI, 2. REPNE SCASW. JE @@Index_found. POP ECX. @@get_parent_dmt: MOV EDX, [EDX].vmtParent. TEST EDX, EDX. JNZ @@cycle. JMP @@Index_not_found. @@Index_found: POP EAX. SHL EAX, 1. SUB EAX, ECX. MOV [EDI + EAX * 2 - 4], ESI. MOV AL, 1. JMP @@exit. @@Index_not_found: XOR AL, AL. @@exit: POP ESI. POP EDI. End; Function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean; overload; Asm. // Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX. // Выход: Result --> AL. PUSH EDI. PUSH ESI. MOV ESI, ECX. XOR EAX, EDX. XOR EDX, EAX. XOR EAX, EDX. JMP @@start. @@cycle: MOV EDX, [EDX]. @@start: MOV EDI, [EDX].vmtDynamicTable. TEST EDI, EDI. JZ @@get_parent_dmt. MOVZX ECX, WORD PTR [EDI]. LEA EDI, EDI + 2 * ECX + 2. REPNE SCASD. JE @@OldMet_found. @@get_parent_dmt: MOV EDX, [EDX].vmtParent. TEST EDX, EDX. JNZ @@cycle. JMP @@OldMet_not_found. @@OldMet_found: MOV [EDI - 4], ESI. MOV AL, 1. JMP @@exit. @@OldMet_not_found: XOR AL, AL. @@exit: POP ESI. POP EDI. End; End.

Как выключить компьютер с любой версией Windows?

Code: Function GetWinVersion: String; Var. VersionInfo : TOSVersionInfo; OSName : String; Begin. // устанавливаем размер записи. VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo ); If Windows.GetVersionEx( VersionInfo ) then. Begin. With VersionInfo do. Begin. Case dwPlatformId of. VER_PLATFORM_WIN32s : OSName := 'Win32s'; VER_PLATFORM_WIN32_WINDOWS : OSName := 'Windows 95'; VER_PLATFORM_WIN32_NT : OSName := 'Windows NT'; End; // case dwPlatformId. Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) + #13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')'; End; // with VersionInfo. End // if GetVersionEx. Else. Result := ''; End; Procedure ShutDown; Const. SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; // Borland forgot this declaration. Var. HToken : THandle; Tkp : TTokenPrivileges; Tkpo : TTokenPrivileges; Zero : DWORD; Begin. If Pos( 'Windows NT', GetWinVersion) = 1 then // we've got to do a whole buch of things. Begin. Zero := 0; If not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then. Begin. MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK ); Exit; End; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken). If not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then. Begin. MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK ); Exit; End; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken). // SE_SHUTDOWN_NAME. If not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[ 0 ].Luid ) then. Begin. MessageBox( 0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK ); Exit; End; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid ). Tkp.PrivilegeCount := 1; Tkp.Privileges[ 0 ].Attributes := SE_PRIVILEGE_ENABLED; AdjustTokenPrivileges( hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero ); If Boolean( GetLastError() ) then. Begin. MessageBox( 0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK ); Exit; End // if Boolean( GetLastError() ). Else. ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 ); End // if OSVersion = 'Windows NT' Else. Begin // just shut the machine down. ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 ); End; // else. End;

©Drkb::01682.

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

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

Есть способ намного лучше: ф-ия SHExitWindowsEx из shell32.dll.

С неё всё good. Это запуск из-под WinExec().

Программно же только с получением привелегии.

Замечу также что флаг EWX_FORCE необходим только для принудительного завершения при выдаче каких либо сообщений или модальных окон, что воспрепятствует завершению, например, "К компьютеру подключены пользователи. Данные могут быть утярены. Вы хотите завершить работу?" или сообщение, которое автор указал в вопросе.

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

©Drkb::01683.

Автор: Song.

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

Code: Function MyExitWindows(RebootParam: Longword): Boolean; Var. TTokenHd: THandle; TTokenPvg: TTokenPrivileges; CbtpPrevious: DWORD; RTTokenPvg: TTokenPrivileges; PcbtpPreviousRequired: DWORD; TpResult: Boolean; Const. SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; Begin. If Win32Platform = VER_PLATFORM_WIN32_NT then. Begin. TpResult := OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, TTokenHd); If tpResult then. Begin. TpResult := LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, TTokenPvg.Privileges[0].Luid); TTokenPvg.PrivilegeCount := 1; TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; CbtpPrevious := SizeOf(rTTokenPvg); PcbtpPreviousRequired := 0; If tpResult then. Windows.AdjustTokenPrivileges(TTokenHd, False, TTokenPvg, CbtpPrevious, RTTokenPvg, PcbtpPreviousRequired); End; End; Result := ExitWindowsEx(RebootParam, 0); End; // Example to shutdown Windows: Procedure TForm1.Button1Click(Sender: TObject); Begin. MyExitWindows(EWX_POWEROFF or EWX_FORCE); End; // Example to reboot Windows: Procedure TForm1.Button1Click(Sender: TObject); Begin. MyExitWindows(EWX_REBOOT or EWX_FORCE); End; // Parameters for MyExitWindows().

©Drkb::01684.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Code: Program Shutdown; {$APPTYPE CONSOLE}. Uses. SysUtils, Windows; // Shutdown Program. // (c) 2000 NeuralAbyss Software. // www.neuralabyss.com. Var. Logoff: Boolean = False; Reboot: Boolean = False; Warn: Boolean = False; DownQuick: Boolean = False; CancelShutdown: Boolean = False; PowerOff: Boolean = False; TimeDelay: Integer = 0; Function HasParam(Opt: Char): Boolean; Var. X: Integer; Begin. Result := False; For x := 1 to ParamCount do. If (ParamStr(x) = '-' + opt) or (ParamStr(x) = '/' + opt) then Result := True; End; Function GetErrorstring: string; Var. Lz: Cardinal; Err: array[0..512] of Char; Begin. Lz := GetLastError; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil); Result := string(err); End; Procedure DoShutdown; Var. Rl, flgs: Cardinal; HToken: Cardinal; Tkp: TOKEN_PRIVILEGES; Begin. Flgs := 0; If downQuick then flgs := flgs or EWX_FORCE; If not reboot then flgs := flgs or EWX_SHUTDOWN; If reboot then flgs := flgs or EWX_REBOOT; If poweroff and (not reboot) then flgs := flgs or EWX_POWEROFF; If logoff then flgs := (flgs and (not (EWX_REBOOT or EWX_SHUTDOWN or EWX_POWEROFF))) or. EWX_LOGOFF; If Win32Platform = VER_PLATFORM_WIN32_NT then. Begin. If not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, HToken) then. Writeln('Cannot open process token. [' + GetErrorstring + ']'). Else. Begin. If LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then. Begin. Tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; Tkp.PrivilegeCount := 1; AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl); If GetLastError <> ERROR_SUCCESS then. Writeln('Error adjusting process privileges.'); End. Else. Writeln('Cannot find privilege value. [' + GetErrorstring + ']'); End; { if CancelShutdown then. If AbortSystemShutdown(nil) = False then. Writeln(\'Cannot abort. [\' + GetErrorstring + \']\'). Else. Writeln(\'Cancelled.\'). Else. Begin. If InitiateSystemShutdown(nil, nil, timeDelay, downQuick, Reboot) = False then. Writeln(\'Cannot go down. [\' + GetErrorstring + \']\'). Else. Writeln(\'Shutting down!\'); End; } End; // else begin. ExitWindowsEx(flgs, 0); // end; End; Begin. Writeln('Shutdown v0.3 for Win32 (similar to the Linux version)'); Writeln('(c) 2000 NeuralAbyss Software. All Rights Reserved.'); If HasParam('?') or (ParamCount = 0) then. Begin. Writeln('Usage: shutdown [-akrhfnc] [-t secs]'); Writeln(' -k: dont really shutdown, only warn.'); Writeln(' -r: reboot after shutdown.'); Writeln(' -h: halt after shutdown.'); Writeln(' -p: power off after shutdown'); Writeln(' -l: log off only'); Writeln(' -n: kill apps that dont want to die.'); Writeln(' -c: cancel a running shutdown.'); End. Else. Begin. If HasParam('k') then warn := True; If HasParam('r') then reboot := True; If HasParam('h') and reboot then. Begin. Writeln('Error: Cannot specify -r and -h parameters together!'); Exit; End; If HasParam('h') then reboot := False; If HasParam('n') then downQuick := True; If HasParam('c') then cancelShutdown := True; If HasParam('p') then powerOff := True; If HasParam('l') then logoff := True; DoShutdown; End; End.

©Drkb::01685.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Как заблокировать компьютер?

Code: Procedure LockPC; Var OldValue: LongBool; Begin. SystemParametersInfo(97, Word(Bool), @OldValue, 0); WinExec(PChar('rundll32 mouse,disable'), SW_SHOW); WinExec(PChar('rundll32 keyboard,disable'), SW_SHOW); End;

©Drkb::01694.

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

Code: { The LockWorkStation function locks the workstation's display, Protecting it from unauthorized use. This function has the same result as pressing Ctrl+Alt+Del and. Clicking Lock Workstation. To unlock the workstation, the user must log in. Windows NT/2000/XP: Included in Windows 2000 and later. Windows 95/98/Me: Unsupported. } Procedure TForm1.Button1Click(Sender: TObject); Begin. LockWorkStation; End; { Loading LockWorkStation dynamically}. Function LockWS: Boolean; // by Thomas Stutz, SDC. Type. TLockWorkStation = function: Boolean; Var. HUser32: HMODULE; LockWorkStation: TLockWorkStation; Begin. // Here we import the function from USER32.DLL. HUser32 := GetModuleHandle('USER32.DLL'); If hUser32 <> 0 then. Begin. @LockWorkStation := GetProcAddress(hUser32, 'LockWorkStation'); If @LockWorkStation <> nil then. Begin. LockWorkStation; Result := True; End; End; End;

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

Code: Function GetMemoryTotalPhys : DWord; Var. MemStatus: TMemoryStatus; Begin. MemStatus.dwLength := sizeOf ( memStatus ); GlobalMemoryStatus ( memStatus ); Result := memStatus.dwTotalPhys; End;

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

Code: Var. Status : TMemoryStatus; Begin. Status.dwLength := sizeof( TMemoryStatus ); GlobalMemoryStatus( Status ); ...

Как определить видеокарту?

Code: Procedure TForm1.button1click(Sender: TObject); Var. LpDisplayDevice: TDisplayDevice; DwFlags: DWORD; Cc: DWORD; Begin. Form2.memo1.Clear; LpDisplayDevice.cb := sizeof(lpDisplayDevice); DwFlags := 0; Cc:= 0; While EnumDisplayDevices(nil, cc, lpDisplayDevice , dwFlags) do. Begin. Inc(cc); Form2.memo1.lines.add(lpDisplayDevice.DeviceString); {Так же мы увидим дополнительную информацию в lpDisplayDevice}. Form2.show; End; End;

©Drkb::01455.

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

Как перевести монитор в режим stand-by?

Автор: Kecvin S. Gallagher.

Если монитор поддерживает режим Stand by, то его можно программно перевести в этот режим. Данная возможность доступна на Windows95 и выше.

Чтобы перевести монитор в режим Stand by:

Code: SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0) ;

Чтобы вывести его из этого режима:

Code: SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1) ;

А теперь более полный пример кода:

На новую форму поместите кнопку, таймер и ListBox.

Code: Timer (use Object Inspector): Enabled := False. Interval := 15000.

Добавьте следующее событие таймеру:

Code: Procedure TForm1.Timer1Timer(Sender: TObject); Begin. ListBox1.Items.Add(FormatDateTime('h:mm:ss AM/PM',Time)) ; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1); End;

Command Button:

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. ListBox1.Items.Add('--> ' + FormatDateTime('h:mm:ss AM/PM',Time)) ; Timer1.Enabled := not Timer1.Enabled ; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0) ; End;

После запуска откомпилированного приложения и нажатия на кнопку, экран погаснет на 15 секунд.

ЗАМЕЧАНИЕ: Удостоверьтесь, что во первых компьютер поддерживает режимы энергосбережения, а вовторых, эти функции не запрещены на данном компьютере.

©Drkb::01699.

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

Как изменить громкость?

Code: Procedure SetVolume(X: Word); Var. IErr : Integer; I: integer; A: TAuxCaps; Begin. For i := 0 to auxGetNumDevs do begin. AuxGetDevCaps(i,Addr(a),SizeOf(a)); If a.wTechnology = AUXCAPS_CDAUDIO Then break; End; // Устанавливаем одинаковую громкость для левого и правого каналов. // VOLUME := LEFT*$10000 + RIGHT*1. IErr:=auxSetVolume(i,(X*$10001)); If (iErr‹›0) then ShowMessage('No audio devices are available!'); End; Function GetVolume: Word; Var. IErr : Integer; I: integer; A: TAuxCaps; Vol: word; Begin. For i := 0 to auxGetNumDevs do begin. AuxGetDevCaps(i,Addr(a),SizeOf(a)); If a.wTechnology = AUXCAPS_CDAUDIO Then break; End; IErr:=auxGetVolume(i,addr(vol)); GetVolume := vol; If (iErr‹›0) then ShowMessage('No audio devices are available!'); End;

Свои апплеты в панели управления.

Компилятор: Delphi 3.x.

Источник: www.borland.com.

Примечание Vit: Более поздние версии Дельфи имеют встроенные средства для создания апплетов - см. New Project->Other->Control Panel...

Апплеты в панели управления, это обычные DLL, имеющие расширение .cpl (Control Panel Library) и располагающиеся в системной директории Windows. В свою очередь, в каждом файле cpl может храниться несколько апплетов. Cpl имеет единственную функцию точки входа CPlApplet(), через которую поступают все сообщения от панели управления.

Давайте рассмотрим сообщения, с которыми панель управления вызывает функцию CPlApplet():

CPL_INIT - сообщение, которым CPlApplet() вызывается первый раз (инициализация). Возвращаем TRUE для продолжения процесса загрузки.

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

CPL_INQUIRE - панель управления запрашивает информацию о каждом апплете, хранящемся в файле cpl. При этом, параметр lParam1 будет содержать номер апплета, о котором панель управления хочет получить информацию, lParam2 будет указывать на структуру TCplInfo. Поле idIcon в структуре TClpInfo должно содержать идентификатор (id) ресурса иконки, которая будет отображаться в панели управления, а поля idName и idInfo должны содержать идентификаторы строковых ресурсов для имени и описания. lData может содержать данные, которые будут использоваться апплетом.

CPL_SELECT - это сообщение посылается апплету, если его иконка была выбрана пользователем. При этом lParam1 содержит номер выбранного апплета, а lParam2 содержит значение lData, определённое для данного апплета.

CPL_DBLCLK - это сообщение будет послано, если по иконке апплета сделать двойной щелчёк. lParam1 будет содержать номер апплета, а lParam2 будет содержать значение lData, определённое для данного апплета. При поступление это сообщения апплет должен как-то показать себя, в частности отобразить своё диалоговое окно.

CPL_STOP - Посылается каждому апплету, когда панель управления закрывается. lParam1 содержит номер апплета, а lParam2 содержит значение lData, определённое для данного апплета.

CPL_EXIT - Посылается перед тем, как панель управления вызовет FreeLibrary.

CPL_NEWINQUIRE - тоже, что и CPL_INQUIRE за исключением того, что lParam2 указывает на структуру NEWCPLINFO.

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

Пример .rc файла содержит таблицу строк, состоящую из двух строк, и указатель на файл с иконкой:

STRINGTABLE.

{

1, "TestApplet".

2, "My Test Applet".

}

2 ICON C:\SOMEPATH\CHIP.ICO.

Чтобы преобразовать файл .rc в .res, (который можно будет спокойно прилинковать к Вашему приложению) достаточно просто указать в командной строке полный путь до компилятора ресурсов и полный путь до файла .rc:

C:\Delphi\Bin\brcc32.exe c:\Delphi\MyRes.rc.

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

Следующий пример, это апплет панели управления, который в ответ на сообщение CPL_DBLCLK запускает блокнот. Код можно легко изменить, чтобы отображалась форма или диалоговое окошко. Этот код можно компилировать как под платформу Win32, так и под Win16.

Чтобы скомпилировать проект, необходимо из вышеприведённого файла .rc создать два: TCPL32.RES и TCPL16.RES.

Code: Library TestCpl; {$IFDEF WIN32}. Uses. SysUtils, Windows, Messages; {$ELSE}. Uses. SysUtils, WinTypes, WinProcs, Messages; {$ENDIF}. {$IFDEF WIN32}. {$R TCPL32.RES}. {$ELSE}. {$R TCPL16.RES}. {$ENDIF}. Const NUM_APPLETS = 1; {$IFDEF WIN32}. Const CPL_DYNAMIC_RES = 0; {$ENDIF}. Const CPL_INIT = 1; Const CPL_GETCOUNT = 2; Const CPL_INQUIRE = 3; Const CPL_SELECT = 4; Const CPL_DBLCLK = 5; Const CPL_STOP = 6; Const CPL_EXIT = 7; Const CPL_NEWINQUIRE = 8; {$IFDEF WIN32}. Const CPL_STARTWPARMS = 9; {$ENDIF}. Const CPL_SETUP = 200; {$IFNDEF WIN32}. Type DWORD = LongInt; {$ENDIF}. Type TCplInfo = record. IdIcon : integer; IdName : integer; IdInfo : integer; LData : LongInt; End; PCplInfo = ^TCplInfo; Type TNewCplInfoA = record. DwSize : DWORD; DwFlags : DWORD; DwHelpContext : DWORD; LData : LongInt; IconH : HIcon; SzName : array [0..31] of char; SzInfo : array [0..63] of char; SzHelpFile : array [0..127] of char; End; PNewCplInfoA = ^TNewCplInfoA; {$IFDEF WIN32}. Type TNewCplInfoW = record. DwSize : DWORD; DwFlags : DWORD; DwHelpContext : DWORD; LData : LongInt; IconH : HIcon; SzName : array [0..31] of WChar; SzInfo : array [0..63] of WChar; SzHelpFile : array [0..127] of WChar; End; PNewCplInfoW = ^TNewCplInfoW; {$ENDIF}. Type TNewCplInfo = TNewCplInfoA; Type PNewCplInfo = ^TNewCplInfoA; Function CPlApplet(hWndCPL : hWnd; IMEssage : integer; LParam1 : longint; LParam2 : longint) : LongInt. {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}. Begin. Case iMessage of. CPL_INIT : begin. Result := 1; Exit; End; CPL_GetCount : begin. Result := NUM_APPLETS; Exit; End; CPL_Inquire : begin. PCplInfo(lParam2)^.idIcon := 2; PCplInfo(lParam2)^.idName := 1; PCplInfo(lParam2)^.idInfo := 2; PCplInfo(lParam2)^.lData := 0; Result := 1; Exit; End; CPL_NewInquire : begin. PNewCplInfo(lParam2)^.dwSize := sizeof(TNewCplInfo); PNewCplInfo(lParam2)^.dwHelpContext := 0; PNewCplInfo(lParam2)^.lData := 0; PNewCplInfo(lParam2)^.IconH := LoadIcon(hInstance, MakeIntResource(2)); LStrCpy(@PNewCplInfo(lParam2)^.szName, 'TestCPL'); LStrCpy(PNewCplInfo(lParam2)^.szInfo, 'My Test CPL'); PNewCplInfo(lParam2)^.szHelpFile[0] := #0; Result := 1; Exit; End; CPL_SELECT : begin. Result := 0; Exit; End; CPL_DBLCLK : begin. WinExec('Notepad.exe', SW_SHOWNORMAL); Result := 1; Exit; End; CPL_STOP : begin. Result := 0; Exit; End; CPL_EXIT : begin. Result := 0; Exit; End else begin. Result := 0; Exit; End; End; End; Exports CPlApplet name 'CPlApplet'; Begin. End.

©Drkb::01869.

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

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

Апплеты в панели управления можно запускать при помощи функции WinExec, запуская control.exe и передав ей в качестве параметра имя апплета. Файлы апплетов (.cpl) обычно находятся в системной директории Windows.

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL', Sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE MOUSE', Sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS', Sw_ShowNormal); End;

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

Code: Uses ShellAPI; ... Function IsTaskbarAutoHideOn : boolean; Var ABData : TAppBarData; Begin. ABData.cbSize := sizeof(ABData); Result :=(SHAppBarMessage(ABM_GETSTATE, ABData) and ABS_AUTOHIDE) > 0; End;

Как узнать, была ли перемещена форма?

Code: Type. TfrmMain = class(TForm). Private. Procedure OnMove(var Msg: TWMMove); message WM_MOVE; End; (...) Procedure TfrmMain.OnMove(var Msg: TWMMove); Begin. Inherited; (...) End; (...)

Как скрыть TaskBar?

Code: //Спрятать. Procedure TForm1.Button1Click(Sender: TObject); Var. HTaskBar : THandle; Begin. HTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_HIDE); End; //Показать. Procedure TForm1.Button2Click(Sender: TObject); Var. HTaskBar : THandle; Begin. HTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_SHOWNORMAL); End;

©Drkb::01769.

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

Code: ShowWindow(FindWindow('Shell_TrayWnd', nil), sw_hide);

Как скрыть часики в панели задач?

Убираем часики:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var hn: HWnd; Begin. Hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil); If hn <> 0 then. ShowWindow(hn, SW_HIDE); //Bye,bye,Baby. End;

Снова показываем:

Code: Procedure TForm1.Button2Click(Sender: TObject); Var hn: HWnd; Begin. Hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil); If hn <> 0 then. ShowWindow(hn, SW_SHOW); //Hello, again. End;

Добавляем файлы в Recent Documents list?

Предположим Вам захотелось, чтобы Ваше программа сама умела добавлять файлы "recent documents list" (для тех, кто в танке - это такая менюшка, которая появляется при нажатии на кнопку Пуск(Start) и наведении мышкой на "Документы" (Documents). Сама функция API-шная, так что применять её можно в любом компиляторе.

Добавляем следующий код в интерфейсную часть формы:

Code: Const. SHARD_PIDL = 1; SHARD_PATH = 2; Procedure SHAddToRecentDocs(Flags: Word; pfname: Pointer); stdcall; external 'shell32.dll' name'SHAddToRecentDocs';

А так выглядит вызов этой функции:

Code: SHAddTorecentDocs(SHARD_PATH,pchar('C:\mydir\myprogram.exe'));

Как удалить все файлы из Recent Documents List?

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. SHAddToRecentDocs(SHARD_PATH, 0); End;

Не забудьте включить ShlObj в Unit.

©Drkb::01661.

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

Отображаем текст в System Tray.

Автор: Ruslan Abu Zant.

Данный код сперва конвертирует Ваш текст в DIB, а затем DIB в иконку и далее в ресурс. После этого изображение иконки отображается в System Tray.

Вызов просходит следующим образом....

StringToIcon('This Is Made By Ruslan K. Abu Zant');

N.B>> Не забудьте удалить объект HIcon, после вызова функции...

Code: Unit MainForm; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Button1: TButton; Image1: TImage; Timer1: TTimer; Procedure Button1Click(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Private. Function StringToIcon(const st: string): HIcon; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Type. ICONIMAGE = record. Width, Height, Colors: DWORD; // Ширина, Высота и кол-во цветов. LpBits: PChar; // указатель на DIB биты. DwNumBytes: DWORD; // Сколько байт? Lpbi: PBitmapInfoHeader; // указатель на заголовок. LpXOR: PChar; // указатель на XOR биты изображения. LpAND: PChar; // указатель на AND биты изображения. End; Function CopyColorTable(var lpTarget: BITMAPINFO; const lpSource: BITMAPINFO): boolean; Var. Dc: HDC; HPal: HPALETTE; Pe: array[0..255] of PALETTEENTRY; I: Integer; Begin. Result := False; Case (lpTarget.bmiHeader.biBitCount) of. 8: If lpSource.bmiHeader.biBitCount = 8 then. Begin. Move(lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof(RGBQUAD)); Result := True. End. Else. Begin. Dc := GetDC(0); If dc <> 0 then. Try. HPal := CreateHalftonePalette(dc); If hPal <> 0 then. Try. If GetPaletteEntries(hPal, 0, 256, pe) <> 0 then. Begin. For i := 0 to 255 do. Begin. LpTarget.bmiColors[i].rgbRed := pe[i].peRed; LpTarget.bmiColors[i].rgbGreen := pe[i].peGreen; LpTarget.bmiColors[i].rgbBlue := pe[i].peBlue; LpTarget.bmiColors[i].rgbReserved := pe[i].peFlags. End; Result := True. End. Finally. DeleteObject(hPal). End. Finally. ReleaseDC(0, dc). End. End; 4: If lpSource.bmiHeader.biBitCount = 4 then. Begin. Move(lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof(RGBQUAD)); Result := True. End. Else. Begin. HPal := GetStockObject(DEFAULT_PALETTE); If (hPal <> 0) and (GetPaletteEntries(hPal, 0, 16, pe) <> 0) then. Begin. For i := 0 to 15 do. Begin. LpTarget.bmiColors[i].rgbRed := pe[i].peRed; LpTarget.bmiColors[i].rgbGreen := pe[i].peGreen; LpTarget.bmiColors[i].rgbBlue := pe[i].peBlue; LpTarget.bmiColors[i].rgbReserved := pe[i].peFlags. End; Result := True. End. End; 1: Begin. I := 0; LpTarget.bmiColors[i].rgbRed := 0; LpTarget.bmiColors[i].rgbGreen := 0; LpTarget.bmiColors[i].rgbBlue := 0; LpTarget.bmiColors[i].rgbReserved := 0; I := 1; LpTarget.bmiColors[i].rgbRed := 255; LpTarget.bmiColors[i].rgbGreen := 255; LpTarget.bmiColors[i].rgbBlue := 255; LpTarget.bmiColors[i].rgbReserved := 0; Result := True. End; Else. Result := True. End. End; Function WidthBytes(bits: DWORD): DWORD; Begin. Result := ((bits + 31) shr 5) shl 2. End; Function BytesPerLine(const bmih: BITMAPINFOHEADER): DWORD; Begin. Result := WidthBytes(bmih.biWidth * bmih.biPlanes * bmih.biBitCount). End; Function DIBNumColors(const lpbi: BitmapInfoHeader): word; Var. DwClrUsed: DWORD; Begin. DwClrUsed := lpbi.biClrUsed; If dwClrUsed <> 0 then. Result := Word(dwClrUsed). Else. Case lpbi.biBitCount of. 1: result := 2; 4: result := 16; 8: result := 256. Else. Result := 0. End. End; Function PaletteSize(const lpbi: BitmapInfoHeader): word; Begin. Result := DIBNumColors(lpbi) * sizeof(RGBQUAD). End; Function FindDIBBits(const lpbi: BitmapInfo): PChar; Begin. Result := @lpbi; Result := result + lpbi.bmiHeader.biSize + PaletteSize(lpbi.bmiHeader). End; Function ConvertDIBFormat(var lpSrcDIB: BITMAPINFO; nWidth, nHeight, nbpp: DWORD; bStretch: boolean): PBitmapInfo; Var. Lpbmi: PBITMAPINFO; LpSourceBits, lpTargetBits: Pointer; DC, hSourceDC, hTargetDC: HDC; HSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap: HBITMAP; DwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize: DWORD; Begin. Result := nil; // Располагаем и заполняем структуру BITMAPINFO для нового DIB. // Обеспечиваем достаточно места для 256-цветной таблицы. DwTargetHeaderSize := sizeof(BITMAPINFO) + (256 * sizeof(RGBQUAD)); GetMem(lpbmi, dwTargetHeaderSize); Try. Lpbmi^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER); Lpbmi^.bmiHeader.biWidth := nWidth; Lpbmi^.bmiHeader.biHeight := nHeight; Lpbmi^.bmiHeader.biPlanes := 1; Lpbmi^.bmiHeader.biBitCount := nbpp; Lpbmi^.bmiHeader.biCompression := BI_RGB; Lpbmi^.bmiHeader.biSizeImage := 0; Lpbmi^.bmiHeader.biXPelsPerMeter := 0; Lpbmi^.bmiHeader.biYPelsPerMeter := 0; Lpbmi^.bmiHeader.biClrUsed := 0; Lpbmi^.bmiHeader.biClrImportant := 0; // Заполняем в таблице цветов. If CopyColorTable(lpbmi^, lpSrcDIB) then. Begin. DC := GetDC(0); HTargetBitmap := CreateDIBSection(DC, lpbmi^, DIB_RGB_COLORS, LpTargetBits, 0, 0); HSourceBitmap := CreateDIBSection(DC, lpSrcDIB, DIB_RGB_COLORS, LpSourceBits, 0, 0); Try. If (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then. Begin. HSourceDC := CreateCompatibleDC(DC); HTargetDC := CreateCompatibleDC(DC); Try. If (hSourceDC <> 0) and (hTargetDC <> 0) then. Begin. // Flip the bits on the source DIBSection to match the source DIB. DwSourceBitsSize := DWORD(lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader); DwTargetBitsSize := DWORD(lpbmi^.bmiHeader.biHeight) * BytesPerLine(lpbmi^.bmiHeader); Move(FindDIBBits(lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize); // Select DIBSections into DCs. HOldSourceBitmap := SelectObject(hSourceDC, hSourceBitmap); HOldTargetBitmap := SelectObject(hTargetDC, hTargetBitmap); Try. If (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then. Begin. // Устанавливаем таблицу цветов для DIBSections. If lpSrcDIB.bmiHeader.biBitCount <= 8 then. SetDIBColorTable(hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors); If lpbmi^.bmiHeader.biBitCount <= 8 then. SetDIBColorTable(hTargetDC, 0, 1 shl. Lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors); // If we are asking for a straight copy, do it. If (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then. BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY). Else if bStretch then. Begin. SetStretchBltMode(hTargetDC, COLORONCOLOR); StretchBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, Lpbmi^.bmiHeader.biHeight, HSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth, lpSrcDIB.bmiHeader.biHeight, SRCCOPY). End. Else. BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY); GDIFlush; GetMem(result, Integer(dwTargetHeaderSize + dwTargetBitsSize)); Move(lpbmi^, result^, dwTargetHeaderSize); Move(lpTargetBits^, FindDIBBits(result^)^, dwTargetBitsSize). End. Finally. If hOldSourceBitmap <> 0 then SelectObject(hSourceDC, hOldSourceBitmap); If hOldTargetBitmap <> 0 then SelectObject(hTargetDC, hOldTargetBitmap); End. End. Finally. If hSourceDC <> 0 then DeleteDC(hSourceDC); If hTargetDC <> 0 then. DeleteDC(hTargetDC). End. End; Finally. If hTargetBitmap <> 0 then DeleteObject(hTargetBitmap); If hSourceBitmap <> 0 then DeleteObject(hSourceBitmap); If dc <> 0 then. ReleaseDC(0, dc). End. End. Finally. FreeMem(lpbmi). End. End; Function DIBToIconImage(var lpii: ICONIMAGE; var lpDIB: BitmapInfo; BStretch: boolean): boolean; Var. LpNewDIB: PBitmapInfo; Begin. Result := False; LpNewDIB := ConvertDIBFormat(lpDIB, lpii.Width, lpii.Height, lpii.Colors, BStretch); If Assigned(lpNewDIB) then. Try. Lpii.dwNumBytes := sizeof(BITMAPINFOHEADER) // Заголовок. + PaletteSize(lpNewDIB^.bmiHeader) // Палитра. + lpii.Height * BytesPerLine(lpNewDIB^.bmiHeader) // XOR маска. + lpii.Height * WIDTHBYTES(lpii.Width); // AND маска. // Если здесь уже картинка, то освобождаем её. If lpii.lpBits <> nil then. FreeMem(lpii.lpBits); GetMem(lpii.lpBits, lpii.dwNumBytes); Move(lpNewDib^, lpii.lpBits^, sizeof(BITMAPINFOHEADER) + PaletteSize. (lpNewDIB^.bmiHeader)); // Выравниваем внутренние указатели/переменные для новой картинки. Lpii.lpbi := PBITMAPINFOHEADER(lpii.lpBits); Lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2; Lpii.lpXOR := FindDIBBits(PBitmapInfo(lpii.lpbi)^); Move(FindDIBBits(lpNewDIB^)^, lpii.lpXOR^, lpii.Height * BytesPerLine. (lpNewDIB^.bmiHeader)); Lpii.lpAND := lpii.lpXOR + lpii.Height * BytesPerLine. (lpNewDIB^.bmiHeader); Fillchar(lpii.lpAnd^, lpii.Height * WIDTHBYTES(lpii.Width), $00); Result := True. Finally. FreeMem(lpNewDIB). End. End; Function TForm1.StringToIcon(const st: string): HIcon; Var. MemDC: HDC; Bmp: HBITMAP; OldObj: HGDIOBJ; Rect: TRect; Size: TSize; InfoHeaderSize: DWORD; ImageSize: DWORD; InfoHeader: PBitmapInfo; Icon: IconImage; OldFont: HFONT; Begin. Result := 0; MemDC := CreateCompatibleDC(0); If memDC <> 0 then. Try. Bmp := CreateCompatibleBitmap(Canvas.Handle, 16, 16); If bmp <> 0 then. Try. OldObj := SelectObject(memDC, bmp); If oldObj <> 0 then. Try. Rect.Left := 0; Rect.top := 0; Rect.Right := 16; Rect.Bottom := 16; SetTextColor(memDC, RGB(255, 0, 0)); SetBkColor(memDC, RGB(128, 128, 128)); OldFont := SelectObject(memDC, font.Handle); GetTextExtentPoint32(memDC, PChar(st), Length(st), size); ExtTextOut(memDC, (rect.Right - size.cx) div 2, (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect, PChar(st), Length(st), nil); SelectObject(memDC, oldFont); GDIFlush; GetDibSizes(bmp, infoHeaderSize, imageSize); GetMem(infoHeader, infoHeaderSize + ImageSize); Try. GetDib(bmp, SystemPalette16, infoHeader^, PChar(DWORD(infoHeader) + infoHeaderSize)^); Icon.Colors := 4; Icon.Width := 32; Icon.Height := 32; Icon.lpBits := nil; If DibToIconImage(icon, infoHeader^, True) then. Try. Result := CreateIconFromResource(PByte(icon.lpBits), icon.dwNumBytes, True, $00030000); Finally. FreeMem(icon.lpBits). End. Finally. FreeMem(infoHeader). End. Finally. SelectObject(memDC, oldOBJ). End. Finally. DeleteObject(bmp). End. Finally. DeleteDC(memDC). End. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Application.Icon.Handle := StringToIcon('0'); Timer1.Enabled := True; Button1.Enabled := False; End; Procedure TForm1.Timer1Timer(Sender: TObject); {Код исправлен by Alex (http://forum.vingrad.ru)}. {$WRITEABLECONST ON}. Const. I: Integer = 0; Begin. Inc(i); If i = 100 then i := 1; Application.Icon.Handle := StringToIcon(IntToStr(i)); {$WRITEABLECONST OFF}. End; End.

Как закрыть всплывающее меню в System Tray когда оно теряет фокус?

Иногда, при потере фокуса, всплывающее меню в System Tray при потере фокуса не закрывается. Поэтому, при обработке сообщений для всплывающего меню необходимо поместить окно на передний план и послать ему сообщение WM_NULL.

Code: Procedure TForm1.WndProc(var Msg : TMessage); Var. P : TPoint; Begin. Case Msg.Msg of. WM_USER + 1: Case Msg.lParam of. WM_RBUTTONDOWN: begin. SetForegroundWindow(Handle); GetCursorPos(p); PopupMenu1.Popup(p.x, p.y); PostMessage(Handle, WM_NULL, 0, 0); End; End; End; Inherited; End;

Как показать округлённое окошко подсказки в трее в Windows2000?

В Windows 2000, формат структуры NotifyIconData, которая используется для работы с иконками в Трее (которая, кстати, называется "The Taskbar Notification Area" :) значительно отличается от предыдущий версий Windows. Однако, эти изменения НЕ отражены в юните ShellAPI.pas в Delphi 5.

Итак, нам понадобится преобразованный SHELLAPI.H, в котором присутствуют все необходимые объявления:

Code: Uses Windows; Type. NotifyIconData_50 = record // определённая в shellapi.h. CbSize: DWORD; Wnd: HWND; UID: UINT; UFlags: UINT; UCallbackMessage: UINT; HIcon: HICON; SzTip: array[0..MAXCHAR] of AnsiChar; DwState: DWORD; DwStateMask: DWORD; SzInfo: array[0..MAXBYTE] of AnsiChar; UTimeout: UINT; // union with uVersion: UINT; SzInfoTitle: array[0..63] of AnsiChar; DwInfoFlags: DWORD; End{record}; Const. NIF_INFO = $00000010; NIIF_NONE = $00000000; NIIF_INFO = $00000001; NIIF_WARNING = $00000002; NIIF_ERROR = $00000003; А это набор вспомогательных типов: Type. TBalloonTimeout = 10..30{seconds}; TBalloonIconType = (bitNone, // нет иконки. BitInfo, // информационная иконка (синяя). BitWarning, // иконка восклицания (жёлтая). BitError); // иконка ошибки (краснаа).

Как открыть меню кнопки Пуск?

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. SendMessage(Self.Handle, WM_SYSCOMMAND, SC_TASKLIST, 0); End;

Анимированная кнопка Пуск?

Автор: I MD.CIPTAYASA.

Итак, если Вам надоело привычное статическое изображение кнопки "Пуск", то предлагаю немного оживить её :) Надеюсь, что это доставит Вам удовольствие.

Code: Unit Main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,ShellAPI; Const. MAX_BUFFER = 6; Type. TForm1 = class(TForm). Button1: TButton; Timer1: TTimer; Button2: TButton; Image1: TImage; Edit1: TEdit; Label1: TLabel; Label2: TLabel; Label3: TLabel; Button3: TButton; Procedure FormCreate(Sender: TObject); Procedure Button1Click(Sender: TObject); Procedure FormDestroy(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Procedure Button2Click(Sender: TObject); Procedure Edit1KeyPress(Sender: TObject; var Key: Char); Procedure FormClose(Sender: TObject; var Action: TCloseAction); Procedure Button3Click(Sender: TObject); Private. HW : HWND; DC : HDC; R : TRect; FNumber : integer; Buffer : array[1..MAX_BUFFER] of TBitmap; TrayIcon : TNotifyIconData; Procedure CreateFrames; Procedure DestroyFrames; Procedure BuildFrames; Procedure NotifyIcon(var Msg : TMessage);message WM_USER + 100; Procedure OnMinimizeEvt(Sender : TObject); End; Var. Form1: TForm1; Implementation. Uses Math; {$R *.DFM}. // Создаём буфер для спрайтов. Procedure TForm1.CreateFrames; Var. I : integer; Begin. For i:=1 to MAX_BUFFER do. Begin. Buffer[i] := TBitmap.Create; Buffer[i].Height := R.Bottom-R.Top; Buffer[i].Width := R.Right-R.Left; Buffer[i].Canvas.Brush.Color := clBtnFace; Buffer[i].Canvas.Pen.Color := clBtnFace; Buffer[i].Canvas.Rectangle(0,0,Buffer[i].Width,Buffer[i].Height); End; End; Procedure TForm1.DestroyFrames; Var. I : integer; Begin. For i:=1 to MAX_BUFFER do. Begin. Buffer[i].Destroy; End; End; // Подготавливает сегменты/спрайты для анимации. Procedure TForm1.BuildFrames; Var. I,j,k,H,W : integer; Y : double; Begin. H := R.Bottom-R.Top; W := R.Right-R.Left; Image1.Width := W; Image1.Height:= H; For i := 1 to MAX_BUFFER-1 do //Буфер[MAX_BUFFER] используется для хранения оригинального битмапа. For j:= 1 to W do. For k:=1 to H do. Begin. Y := 2*Sin((j*360/W)*(pi/180)-20*i); Buffer[i].Canvas.Pixels[j,k-Round(Y)]:= Buffer[6].Canvas.Pixels[j,k]; End; End; Procedure TForm1.OnMinimizeEvt(Sender : TObject); Begin. ShowWindow(Application.Handle,SW_HIDE); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. HW := FindWindowEx(FindWindow('Shell_TrayWnd',nil),0,'Button',nil); GetWindowRect(HW,R); DC := GetWindowDC(HW); CreateFrames; FNumber :=1; TrayIcon.cbSize := SizeOf(TrayIcon); TrayIcon.Wnd := Form1.Handle; TrayIcon.uID := 100; TrayIcon.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP; TrayIcon.uCallbackMessage := WM_USER + 100; TrayIcon.hIcon := Application.Icon.Handle; Shell_NotifyIcon(NIM_ADD,@TrayIcon); Application.OnMinimize := OnMinimizeEvt; End; // Уведомляем обработчик. Procedure TForm1.NotifyIcon(var Msg : TMessage); Begin. Case Msg.LParam of. WM_LBUTTONDBLCLK : Begin. ShowWindow(Application.Handle,SW_SHOW); Application.Restore; End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. //Получаем изображение оригинальной кнопки, чтобы потом использовать его. //когда анимация завершится. BitBlt(Buffer[MAX_BUFFER].Canvas.Handle,0,0,R.Right-R.Left,R.Bottom-R.Top, DC,0,0,SRCCOPY); BuildFrames; Image1.Canvas.Draw(0,0,Buffer[MAX_BUFFER]); Button2.Enabled := true; If Edit1.Text <> '' then. Timer1.Interval := StrToInt(Edit1.Text). Else. Begin. Timer1.Interval := 100; Edit1.Text := '100'; End; End; // Освобождение ресурсов. Procedure TForm1.FormDestroy(Sender: TObject); Begin. Timer1.Enabled := false; BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top, Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY); ReleaseDC(HW,DC); DestroyFrames; // не забудьте сделать это !!! Shell_NotifyIcon(NIM_DELETE,@TrayIcon); End; // Анимация начинается здесь. Procedure TForm1.Timer1Timer(Sender: TObject); Begin. BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top, Buffer[FNumber].Canvas.Handle,0,0,SRCCOPY); Inc(FNumber); If (FNumber > MAX_BUFFER-1) then FNumber := 1; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Timer1.Enabled := not Timer1.Enabled; If not Timer1.Enabled then. Begin. BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top, Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY); Button2.Caption := '&Animate'; Button1.Enabled := true; End. Else. Begin. Button2.Caption := '&Stop'; Button1.Enabled := false; End; End; // Обеспечиваем ввод числовых значений. Procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); Begin. If not (Key in ['0'..'9']) and (Key <> Chr(VK_BACK)) then. Key := #0; End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. Action := caNone; Application.Minimize; End; Procedure TForm1.Button3Click(Sender: TObject); Begin. PostMessage(Form1.Handle,WM_DESTROY,0,0); Application.Terminate; End; End.

Как изменить изображение кнопки Пуск?

Автор: Misha Moellner.

Пример из серии "Что можно сделать с рабочим столом". В общем, это обычный трюк с кнопкой "Пуск" (Start).

Code: { объявляем глобальные переменные }. Var. Form1: TForm1; StartButton: hWnd; OldBitmap: THandle; NewImage: TPicture; { добавляем следующий код в событие формы OnCreate }. Procedure TForm1.FormCreate(Sender: TObject); Begin. NewImage := TPicture.create; NewImage.LoadFromFile('C:\Windows\Circles.BMP'); StartButton := FindWindowEx. (FindWindow( 'Shell_TrayWnd', nil), 0,'Button', nil); OldBitmap := SendMessage(StartButton, BM_SetImage, 0, NewImage.Bitmap.Handle); End; { Событие OnDestroy }. Procedure TForm1.FormDestroy(Sender: TObject); Begin. SendMessage(StartButton,BM_SetImage,0,OldBitmap); NewImage.Free; End;

Как найти директорию TEMP в Windows?

Code: Function c_GetTempPath: String; Var. Buffer: array[0..1023] of Char; Begin. SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer)); End;

Показываем/Скрываем System Tray.

Автор: Ruslan Abu Zant.

Вы, наверное, видели множество примеров, которые показывают как скрывать панель задач или кнопку Пуск. Но вот как скрыть только System Tray ?

Code: Procedure hideStartbutton(visi: boolean); Var. Tray, Child: hWnd; C: array[0..127] of Char; S: string; Begin. Tray := FindWindow('Shell_TrayWnd', nil); Child := GetWindow(Tray, GW_CHILD); While Child <> 0 do. Begin. If GetClassName(Child, C, SizeOf(C)) > 0 then. Begin. S := StrPAS(C); If UpperCase(S) = 'TRAYNOTIFYWND' then. Begin. If Visi then. ShowWindow(Child, 1). Else. ShowWindow(Child, 0); End; End; Child := GetWindow(Child, GW_HWNDNEXT); End; End;

Как программно создать ярлык?

Автор: Gavrilo.

Code: Uses ShlObj, ComObj, ActiveX; Procedure CreateLink(const PathObj, PathLink, Desc, Param: string); Var. IObject: IUnknown; SLink: IShellLink; PFile: IPersistFile; Begin. IObject := CreateComObject(CLSID_ShellLink); SLink := IObject as IShellLink; PFile := IObject as IPersistFile; With SLink do begin. SetArguments(PChar(Param)); SetDescription(PChar(Desc)); SetPath(PChar(PathObj)); End; PFile.Save(PWChar(WideString(PathLink)), FALSE); End;

Как проверить, включён ли ActiveDesktop?

Code: Function IsActiveDeskTopOn: Boolean; Var. H: hWnd; Begin. H := FindWindow('Progman', nil); H := FindWindowEx(h, 0, 'SHELLDLL_DefView', nil); H := FindWindowEx(h, 0, 'Internet Explorer_Server', nil); Result := h <> 0; End;

Как установить цвет фона иконок на рабочем столе, либо сделать у них прозрачный фон?

Для этого нужно найти окно "SysListView32" (которое является списком, который содержит иконки рабочего стола). Сперва будем искать главное родительское окно "Progman", которое содержит дочернее окно "SHELLDLL_DefView" , которое в свою очередь имеет дочернее окно "SysListView32". Для этого можно воспользоваться API функцией FindWindow to. Когда Мы получим дескриптор окна "SysListView32", то можно будет воспользоваться макросами ListView_SetTextBkColor и ListView_SetTextColor для установки желаемого цвета.

Ниже приведена процедура, которая делает всё вышеперечисленное. Если параметр Trans равен true, то будет установлен прозрачный фон, иначе цвет фона будет равен Background.

Code: Unit DeskIcons; Interface. Uses Graphics; // Будет использоваться TColor. Procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean); Procedure SetDefaultIconColors; Implementation. Uses Windows, CommCtrl; // будут использоваться HWND и ListView_XXXXX. Procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean); Var. Window: HWND; Begin. // Находим нужное окно в три этапа. Window := FindWindow('Progman', 'Program Manager'); // Используем FindWindowEx для нахождения дочернего окна. Window := FindWindowEx(Window, HWND(nil), 'SHELLDLL_DefView', ''); // SysListView32, это список с иконками на рабочем столе. Window := FindWindowEx(Window, HWND(nil), 'SysListView32', ''); // Используем макрос для очистки цвета фона. If Trans then. ListView_SetTextBkColor(Window, $ffffffff) // фоновый цвет. Else. ListView_SetTextBkColor(Window, Background); // фоновый цвет. ListView_SetTextColor(Window, Forground); // передний цвет. // теперь перерисовываем иконки. ListView_RedrawItems(Window, 0, ListView_GetItemCount(Window) - 1); UpdateWindow(Window); // даём команду "немедленно перерисовать". End; Procedure SetDefaultIconColors; { Эта процедура устанавливает цвета, которые заданы в. Windows по умолчанию }. Var. Kind: Integer; Color: TColor; Begin. Kind := COLOR_DESKTOP; Color := GetSysColor(COLOR_DESKTOP); SetSysColors(1, Kind, Color); End; End.

Как выровнять иконки на рабочем столе к левому краю?

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

Пример:

Code: Function GetDesktopListViewHandle: THandle; Var. S: String; Begin. Result := FindWindow('ProgMan', nil); Result := GetWindow(Result, GW_CHILD); Result := GetWindow(Result, GW_CHILD); SetLength(S, 40); GetClassName(Result, PChar(S), 39); If PChar(S) <> 'SysListView32' then Result := 0; End;

Как создать лупу для рабочего стола?

Автор: Zarko Gajic.

Code: // переменные. Var Srect,Drect,PosForme:TRect; IWidth,iHeight,DmX,DmY:Integer; ITmpX,iTmpY:Real; C:TCanvas; Kursor:TPoint; // Увеличиваем экран, если приложение не свёрнуто в иконку. If not IsIconic(Application.Handle) then begin. // Получаем координаты курсора. GetCursorPos(Kursor); // PosForm представляет прямоугольник с. // координатами Form (image control). PosForme:=Rect(Form1.Left, Form1.Top, Form1.Left+Form1.Width, Form1.Top+Form1.Height); //Показываем magnified screen. //если курсор за пределами формы. If not PtInRect(PosForme,Kursor) then begin. // Далее код можно использовать для увеличения выбранной. // части экрана. С небольшими модификациями его можно. // использовать для уменьшения. // экрана. IWidth:=Image1.Width; IHeight:=Image1.Height; Drect:=Bounds(0,0,iWidth,iHeight); ITmpX:=iWidth / (Slider.Position * 4); ITmpY:=iHeight / (Slider.Position * 4); Srect:= Rect(Kursor.x,Kursor.y,Kursor.x,Kursor.y); InflateRect(Srect,Round(iTmpX),Round(iTmpY)); //Получаем обработчик(handle) окна рабочего стола. C:=TCanvas.Create; Try. C.Handle:=GetDC(GetDesktopWindow); //Передаём часть изображения окна в TImage. Image1.Canvas.CopyRect(Drect,C,Srect); Finally. C.Free; End; End; // Обязательно обрабатываем все сообщения Windows. Application.ProcessMessages; End; // IsIconic.

Как скрыть / показать иконки на рабочем столе?

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. // скрыть иконки. ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. // показать иконки. ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW); End;

©Drkb::01826.

Code: Procedure ShowDesktop(const YesNo : boolean); Var h : THandle; Begin. H := FindWindow('ProgMan', nil); H := GetWindow(h, GW_CHILD); If YesNo = True then. ShowWindow(h, SW_SHOW). Else. ShowWindow(h, SW_HIDE); End; {Использование:}. {Скрыть иконки на рабочем столе}. ShowDesktop(False); {Показать иконки на рабочем столе}. ShowDesktop(true);

Компонент PowerControl.

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. PowerControl1.Action:=actCDEject;// Или... actLogOFF, actShutDown... PowerControl1.Execute; End;

Component Code:

Code: Unit PowerControl; Interface. Uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls, Forms, Graphics, MMSystem; Type. TAction = (actLogOFF,actShutDown,actReBoot,actForce,actPowerOFF, ActForceIfHung,actMonitorOFF,actMonitorON,actCDEject,actCDUnEject); Type. TPowerControl = class(TComponent). Private. FAction : TAction; Procedure SetAction(Value : TAction); Protected. Public. Function Execute : Boolean; Published. Property Action : TAction read FAction write SetAction; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('K2', [TPowerControl]); End; Procedure TPowerControl.SetAction(Value : TAction); Begin. FAction := Value; End; Function TPowerControl.Execute : Boolean; Begin. With (Owner as TForm) do. Case FAction of. ActLogOff: ExitWindowsEx(EWX_LOGOFF,1); ActShutDown: ExitWindowsEx(EWX_SHUTDOWN,1); ActReBoot: ExitWindowsEx(EWX_REBOOT,1); ActForce: ExitWindowsEx(EWX_FORCE,1); ActPowerOff: ExitWindowsEx(EWX_POWEROFF,1); ActForceIfHung: ExitWindowsEx(EWX_FORCEIFHUNG,1); ActMonitorOFF: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0); ActMonitorON: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1); ActCDEject: mciSendstring('SET CDAUDIO DOOR OPEN. WAIT',nil,0, Handle); ActCDUnEject: mciSendstring('SET CDAUDIO DOOR CLOSED. WAIT',nil,0, Handle); End; {Case}. Result := True; End; End.

©Drkb::01672.

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

Создание хранителя экрана средствами Delphi.

Автор: Dave Murray.

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

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

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

FormShow - скрыть курсор, установка обработки сообщений, начало отображения скринсейвера.

FormHide - окончание отображения скринсейвера, отображение курсора.

DeactivateScrSaver - обработка сообщений, деактивирование, если нажата мышка или клавиатура.

Типичный код для этих процедур показан ниже.

Вы должны быть уверены, что Ваша форма создана со стилем fsStayOnTop. Вы так же должны быть уверены, что только один экземпляр Вашей программы будет запущен в системе. И в заключении Вам необходимо включить директиву компилятора {$D "Programname Screensaver"} в Ваш проект (*.dpr).

После того, как Вы скомпилируете программу, измените расширение файла на SCR и скопируйте его в Вашу системную папку \WINDOWS\SYSTEM .

Code: Var. Crs : TPoint; {первоначально расположение курсора мышки}. Procedure TScrForm.FormShow(Sender: TObject); {starts the screensaver}. Begin. WindowState := wsMaximized; {окошко будет на полный экран}. GetCursorPos(crs); {получаем позицию курсора}. Application.OnMessage := DeactivateScrSaver; {проверяем мышку/клавиатуру}. ShowCursor(false); {скрываем курсор}. {начинаем отображение скринсейвера...}. // End; {процедура TScrForm.FormShow}. Procedure TScrForm.FormHide(Sender: TObject); {возвращаем управление пользователю}. Begin. Application.OnMessage := nil; {запрещаем сообщения}. {останавливаем скринсейвер...}. // ShowCursor(true); {возвращаем курсор назад}. End; {procedure TScrForm.FormHide}. Procedure TScrForm.DeactivateScrSaver(var Msg : TMsg; var Handled : boolean); {определение движения мышки или нажатия на клавиатуре}. Var. Done : boolean; Begin. If Msg.message = WM_MOUSEMOVE then {сдвинулась мышка}. Done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or. (Abs(HIWORD(Msg.lParam) - crs.y) > 5). Else {key / mouse нажаты?}. Done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or. (Msg.message = WM_SYSKEYDOWN) or (Msg.message = WM_SYSKEYUP) or. (Msg.message = WM_ACTIVATE) or (Msg.message = WM_NCACTIVATE) or. (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or. (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN); If done then. Close; End; {procedure TScrForm.DeactivateScrSaver}.

Создаём собственный UnRar, используя unrar.dll.

// Объявления.

Code: Function RAROpenArchive(ArchiveData : Pointer): Integer; stdcall; External 'unrar.dll' name 'RAROpenArchive'; Function RARCloseArchive(hArcData : Integer): Integer; stdcall; External 'unrar.dll' name 'RARCloseArchive'; Function RARReadHeader(hArcData : Integer; HeaderData : Pointer): Integer; stdcall; External 'unrar.dll' name 'RARReadHeader'; Function RARProcessFile(hArcData : Integer; Operation : Integer; DestPath : Pointer; DestName : Pointer): Integer; stdcall; External 'unrar.dll' name 'RARProcessFile'; Const. ERAR_END_ARCHIVE = 10; ERAR_NO_MEMORY = 11; ERAR_BAD_DATA = 12; ERAR_BAD_ARCHIVE = 13; ERAR_UNKNOWN_FORMAT = 14; ERAR_EOPEN = 15; ERAR_ECREATE = 16; ERAR_ECLOSE = 17; ERAR_EREAD = 18; ERAR_EWRITE = 19; ERAR_SMALL_BUF = 20; RAR_OM_LIST = 0; RAR_OM_EXTRACT = 1; RAR_SKIP = 0; RAR_TEST = 1; RAR_EXTRACT = 2; RAR_VOL_ASK = 0; RAR_VOL_NOTIFY = 1; Type. Char260 = Array [1..260] of Char; TRAROpenArchiveData = record. ArcName : PChar; // в C++ это будет выглядеть как: char *ArcName. OpenMode : Cardinal; OpenResult : Cardinal; CmtBuf : PChar; CmtBufSize : Cardinal; CmtSize : Cardinal; CmtState : Cardinal; End; TRARHeaderData = record. ArcName : Char260; FileName : Char260; Flags : Cardinal; PackSize : Cardinal; UnpSize : Cardinal; HostOS : Cardinal; FileCRC : Cardinal; FileTime : Cardinal; UnpVer : Cardinal; Method : Cardinal; FileAttr : Cardinal; CmtBuf : PChar; CmtBufSize : Cardinal; CmtSize : Cardinal; CmtState : Cardinal; End; Var. RARExtract : boolean; RAROpenArchiveData : TRAROpenArchiveData; RARComment : array [1..256] of Char; RARHeaderData : TRARHeaderData; ... Procedure ExtractRARArchive; Var. SDir : string; S : string; STest : string; ITest : integer; BTestDone : boolean; RARhnd : Integer; RARrc : Integer; PDestPath : Char260; Begin. RARExtract:=TRUE; LKBWritten:=0; ProgressBar2.Position := 0; ProgressBar2.Max := lTotalSize; RARStartTime:=Time; RAROpenArchiveData.OpenResult:=99; RAROpenArchiveData.OpenMode := RAR_OM_EXTRACT; // открываем для распаковки. RAROpenArchiveData.ArcName:= @RARFileName; RAROpenArchiveData.CmtBuf := @RARComment; RAROpenArchiveData.CmtBufSize := 255; // Открываем RAR архив и выделяем память. RARhnd := RAROpenArchive (@RAROpenArchiveData); If RAROpenArchiveData.OpenResult <> 0 then. Begin. Case RAROpenArchiveData.OpenResult of. ERAR_NO_MEMORY : s:='Not enough memory to initialize data structures'; ERAR_BAD_DATA : s:='Archive header broken'; ERAR_BAD_ARCHIVE : s:='File is not valid RAR archive'; ERAR_EOPEN : s:='File open error'; End; MessageDlg('Unable to open rar archive: ' + s + '!',mtError, [mbOK], 0); End; RARSetProcessDataProc(RARhnd,@Form.OnRarStatus); StrPCopy(@PDestPath, EInstallPath.Text); Repeat. RARrc := RARReadHeader (RARhnd, @RARHeaderData);// Читаем заголовок. If RARrc <> ERAR_END_ARCHIVE then. Begin. ProgressBar1.Position := 0; ProgressBar1.Max := RARHeaderData.UnpSize; S:=RARHeaderData.FileName; LblCurrentFile.Caption := s; LKBytesDone := 0; End; If RARrc = 0 then. RARrc:=RARProcessFile (RARhnd, RAR_EXTRACT, @PDestPath, nil); If (RARrc <> 0) and (RARrc <> ERAR_END_ARCHIVE) then. Begin. MessageDlg('An Error occured during extracting of ' + sTest+'!' + #13#10 + 'RARProcessFile: ' + MakeItAString(RARrc),mtError, [mbOK], 0); End; Until RARrc <> 0; // закрываем RAR архив и освобождаем память. If RARCloseArchive(RARhnd) <> 0 then. Begin. MessageDlg('Unable to close rar archive!',mtError, [mbOK], 0); End; End; // ExtractRARArchive.

Как узнать номер недели данного дня в году?

Вариант 1:

Code: Function WeekOfYear(ADate : TDateTime) : word; Var. Day : word; Month : word; Year : word; FirstOfYear : TDateTime; Begin. DecodeDate(ADate, year, month, day); FirstOfYear := EncodeDate(year, 1, 1); Result := Trunc(ADate - FirstOfYear) div 7 + 1; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage(IntToStr(WeekOfYear(Date))); End;

Как преобразовать строку в дату?

Код распознаёт и русский и английский языки. Кстати вполне корректно обрабатывает и падежи типа:

2 мая 2002.

Май месяц 1999 года, 3е число.

3е мая 1999 года.

Солнечный апрельский день в 1998м году, 20е число.

Корректно распознаёт что-нибудь типа.

July 3, 99.

Но естественно не способен распознать.

01-jan-03.

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

Code: Function StringToDate(Temp:String):TDateTime; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Type TDateItem=(diYear, diMonth, diDay, diUnknown); TCharId=(ciAlpha, ciNumber, ciSpace); //языковые настройки. Для включения нового языка добавляем раскладку сюда, дополняем тип alpha и меняем. //единственную строку где используется эта константа. Const. Eng_monthes:array[1..12] of string=('jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec'); Rus_monthes:array[1..12] of string=('янв', 'фев', 'мар', 'апр', 'ма', 'июн', 'июл', 'авг', 'сен', 'окт', 'ноя', 'дес'); Alpha:set of char=['a'..'z','а'..'я']; //временные переменные. Var month, day, year:string; Temp1:string; I, j:integer; Ci1, ci2:TCharId; Function GetWord(var temp:string):string; Begin. //возвращаем следующее слово из строки и вырезаем это слово из исходной строки. If pos(' ', temp)>0 then. Begin //берём слово до пробела. Result:=trim(copy(temp, 1, pos(' ', temp))); Temp:=copy(temp, pos(' ', temp)+1, length(temp)); End. Else //это последнее слово в строке. Begin. Result:=trim(temp); Temp:=''; End; End; Function GetDateItemType(temp:string):TDateItem; Var i, j:integer; Begin. //распознаём тип слова. I:=StrToIntDef(temp,0); //попытка преобразовать слово в цифру. Case i of. 0: Result:=diMonth; //не число, значит или месяц или мусор. 1..31:Result:=diDay;//числа от 1 до 31 считаем днём. Else Result:=diYear;//любые другие числа считаем годами. End; End; Function GetCharId(ch:char):TCharId; Begin. //узнаём тип символа, нужно для распознавания "склееных" дней или лет с месяцем. Case ch of. ' ':Result:=ciSpace; '0'..'9':Result:=ciNumber; Else Result:=ciAlpha; End; End; Begin. Temp:=trim(ansilowercase(temp)); Month:=''; Day:=''; Year:=''; //замена любого мусора на пробелы. For i:=1 to length(temp) do. If not (temp[i] in alpha+['0'..'9']) then temp[i]:=' '; //удаление лишних пробелов. While pos(' ', temp)>0 do. Temp:=StringReplace(temp, ' ',' ',[rfReplaceAll]); //вставка пробелов если месяц слеплен с днём или годом. Ci1:=GetCharId(temp[1]); I:=1; Repeat. Inc(i); Ci2:=GetCharId(temp[i]); If ((ci1=ciAlpha) and (ci2=ciNumber)) or ((ci1=ciNumber) and (ci2=ciAlpha)) then. Insert(' ', temp, i); Ci1:=ci2; Until i>=length(temp); //собственно парсинг. While temp>'' do. Begin. Temp1:=GetWord(temp); Case GetDateItemType(temp1) of. DiMonth: if month='' then //только если месяц ещё не определён, уменьшает вероятность ошибочного результата. For i:=12 downto 1 do // обязателен отсчёт в обратную сторону чтоб не путать май и март. If (pos(eng_monthes[i],temp1)=1) or (pos(rus_monthes[i],temp1)=1) then //сюда добавляем ещё язык если надо. Month:=inttostr(i); DiDay: Day:=temp1; DiYear: Year:=temp1; End; End; //проверка - все ли элементы определены. If (month='') or (Day='') or (Year='') then raise Exception.Create('Could not be converted!'); //поправка на двузначный год. If length(year)<3 then year:='19'+year; //кодирование результата. Result:=EncodeDate(Strtoint(Year), Strtoint(month), Strtoint(Day)); End;

Работа со временем или как реализовать 1.20+1.50=3.10 ?

Автор: Hans Pieters.

Как узнать имя домена Windows NT/2000?

Code: Function GetNTDomainName: string; Var hReg: TRegistry; Begin. HReg := TRegistry.Create; HReg.RootKey := HKEY_LOCAL_MACHINE; HReg.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion. \Winlogon', false ); Result := hReg.ReadString( 'DefaultDomainName' ); HReg.CloseKey; HReg.Destroy; End;

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

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

Code: Uses Windows; Function GetComputerNetName: string; Var. Buffer: array[0..255] of char; Size: dword; Begin. Size := 256; If GetComputerName(buffer, size) then. Result := buffer. Else. Result := '' End;

Как узнать имя пользователя?

Code: Function GetUserFromWindows: string; Var. UserName : string; UserNameLen : Dword; Begin. UserNameLen := 255; SetLength(userName, UserNameLen); If GetUserName(PChar(UserName), UserNameLen) Then. Result := Copy(UserName,1,UserNameLen - 1). Else. Result := 'Unknown'; End;

Как расшарить диск?

Автор: Repairman.

Это модуль для Share любого диска или папки как на локальном, так и на удаленном компьютере (если, конечно у Вас права администратора и на компе разрешено удаленное администрирование, для локальной машины это не обязательно... ;-)).

Следует отметить, что под NT некоторые процедуры находятся в других DLL...

Функция SetShareOnDisk - ставит шару, RemoveShareFromDisk - снимает ее.

Code: Unit Share; //(c)2002 <Repairman> repairman@uzel.ru. Interface. Type. TPassw = string[8]; TNetName = string[12]; Function SetShareOnDisk(HostName: string; //имя компьютера. LocalPath: string; //папка которую надо открыть для доступа. NetName: TNetName; //имя расшаренной папки в сети. Remark: string; //комментарий, видимый в сети. Access: word; //доступ. RO_Passw: TPassw; //пароль на чтение. RW_Passw: TPassw //пароль на полный доступ. ): boolean; Function RemoveShareFromDisk(HostName: string; //имя компьютера. NetName: string; //сетевое имя папки которую надо закрыть. LocalPath: string //локальный путь папки. ): boolean; Var. ShareResult: word; //------------------------------------------------------------------------------------------- Implementation. Uses SysUtils, Windows, ShlObj; Function NetShareAdd(ServerName: PChar; //указатель на имя компьютера, например '\\Server'#0, если свой, то можно nil. Level: Word; //уровень структуры Share_info, здесь 50. PShareInfo: PChar; //указатель на структуру Share_Info. ParmErr: DWord) //указатель на ??? : dword; stdcall; external 'svrapi.dll'; //svrapi для Win9X, NetApi32 для NT. Function NetShareDel(ServerName: PChar; NetName: PChar; Reserved: DWord): dword; stdcall; external 'svrapi.dll'; Type. _share_info_50 = record //структура Share уровня 50. NetName: array[1..13] of char; //Как будет называться диск в сети. SType: byte; //тип =0 (STYPE_DISKTREE) - шарить диски. Flags: word; //флаги $0191,$0192,$0193....(доступ из сети). Remark: PChar; //указатель на комментарий, видимый из сети. Path: PChar; //указатель на имя ресурса, например 'c:\'#0. RW_Password: array[1..9] of char; //пароль для полного доступа, если не нужен =#0. RO_Password: array[1..9] of char; //пароль для доступа на чтение, если не нужен =#0. End; //---------------------------- Function SetShareOnDisk(HostName, LocalPath: string; NetName: TNetName; Remark: string; Access: word; RO_Passw, RW_Passw: TPassw): boolean; Var ShareInfo: _Share_Info_50; Begin. Result := false; StrPCopy(@ShareInfo.NetName, NetName); ShareInfo.SType := 0; ShareInfo.Flags := Access; ShareInfo.Remark := PChar(Remark); ShareInfo.Path := PChar(LocalPath); StrPCopy(@ShareInfo.RO_Password, RO_Passw); StrPCopy(@ShareInfo.RW_Password, RW_Passw); ShareResult := NetShareAdd(PChar(HostName), 50, @ShareInfo, $0000002A); //вызываем Share. If ShareResult <> 0 then Exit; //расшарить неудалось. SHChangeNotify(SHCNE_NETSHARE, SHCNF_PATH, PChar(LocalPath), nil); //сказать шеллу об изменениях. Result := true; End; //---------------------------- Function RemoveShareFromDisk(HostName, NetName, LocalPath: string): boolean; Begin. Result := false; ShareResult := NetShareDel(PChar(HostName), PChar(NetName), 0); //удалить шару. If ShareResult <> 0 then Exit; SHChangeNotify(SHCNE_NETUNSHARE, SHCNF_PATH, PChar(LocalPath), nil); //сказать шеллу об изменениях. Result := true; End; //---------------------------- End.

Подключение сетевого диска.

Автор: Eber Irigoyen.

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

Code: //Пример открытия стандартного диалога. Procedure TForm1.Button1Click(Sender: TObject); Begin. WNetConnectionDialog(Handle,RESOURCETYPE_DISK). End; //Так же можно подключить и принтер. Procedure TForm1.Button1Click(Sender: TObject); Begin. WNetConnectionDialog(Handle,RESOURCETYPE_PRINT). End; //либо можно использовать следующий код. Procedure TForm1.Button2Click(Sender: TObject); Var. NetResource: TNetResource; Begin. { заполняем структуру TNetResource }. NetResource.dwType := RESOURCETYPE_DISK; NetResource.lpLocalName := 'S:'; NetResource.lpRemoteName := '\\myserver\public'; NetResource.lpProvider := ''; { подключаем сетевой ресурс, используя структуру TNetResource }. If ( WNetAddConnection2(NetResource, '', {Password (if needed) or empty}. '', {User name (if needed) or empty}. CONNECT_UPDATE_PROFILE)<>NO_ERROR) Then. Raise Excepcion.Create('unable to map drive'). //так же существуют другие константы для определения возникшей ошибки. //ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, и т.д. End; //так же можно и отключить сетевой ресурс... Procedure TForm1.Button2Click(Sender: TObject); Begin. If WNetCancelConnection2( 'S:',0,TRUE) <> NO_ERROR then. Raise Exception.create('Error disconnecting map drive'); //соответственно можно использовать другие константы для определения ошибки. //ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, и т.д. End;

Создание Аккаунта в Windows, используя ADSI (Активные директории).

Автор: Philip Jespersen.

Чтобы создавать пользовательские аккаунты в Windows на Delphi можно использовать ADSI (Active Directory Services Interface) от Microsoft. Вы думаете, что ADSI это новая примочка для Windows 2000 (судя по названию) , но оказывается ADSI доступна для всех платформ Win32. Для этого Вам потребуется всего навсего скачать ADSI для Windows (более полная информация на http://www.microsoft.com/adsi ). Ну и конечно же ADSI входит в поставку Windows 2000.

ADSI довольно большой предмет для изучения. В данном примере я затрону этот предмет поверхностно. ADSI - это своего рода основа для различных сервисов (обычно основанных на директориях) оперционной системы. Например, стандартными ADSI сервисами можно назвать (COM интерфейсы, которые можно использовать в программах) WinNT, IIS, LDAP и NDS. WinNT сервис может тем самым использоваться для создания пользовательских аккаунтов, модификации их или модификации групп.

Следующий небольшой пример показывает необходимые шаги для создания пользовательского аккаунта в NT/2000, используя ADSI:

Во первых Вам прийдётся импортировать Библиотеку Типов ADSI (Menu Project/Import Type Library). Библиотеку Типов можно найти в поддирректории system32 (Например C:\WINNT\system32\activeds.tlb). Требуемый файл называется 'activeds.tlb'. Если такого файла нет, то проверьте, правильно ли вы установили ADSI. После успешного импортирования Библиотеки Типов Вы найдёте новый файл в дирректории ипортов Delphi, файл будет называться "activeds_tlb.pas" (..\Delphi5\Imports\activeds_tlb.pas). Чтобы приступить к программированию ADSI в Delphi, необходимо включить этот файл в Ваш проект.

Далее в примере, необходимо заменить [computername] на фактическое имя компьютера, с которым Вы работаете. То же надо проделать с [accountname]. Пример тестировался на WindowsNT 4.0 и Windows 2000.

Code: ... Uses ActiveX, // используется для COM Moniker stuff... ActiveDs_TLB, // созданная библиотека типов. ComObj; // используется для OleCheck и других функций COM. Implementation. Procedure TForm1.BtnCreateUserClick(Sender: TObject); Var. Usr: IADsUser; Comp: IADsContainer; Begin. Try. Comp := GetObject('WinNT://[computername],computer') as. IADsContainer; Usr := Comp.Create('user', '[accountname]') as IADsUser; Usr.SetInfo; Except. On E: EOleException do begin. ShowMessage(E.Message); End; End; End; Procedure TForm1.BtnSetPasswordClick(Sender: TObject); Var. Usr: IADsUser; Begin. Try. Usr := GetObject('WinNT://[computername]/[accountname],user'). As IADsUser; Usr.SetPassword('thenewpassword'); Except. On E: EOleException do begin. ShowMessage(E.Message); End; End; End; // GetObject использует вызов VB GetObject. // Данный код (GetObject) был найден в Usenet. // // GetObject позволяет связаться с существующим ADSI сервисом. // используя 'ADSIPath' (например WinNT://.... или. // IIS://localhost). Function TForm1.GetObject(const Name: string): IDispatch; Var. Moniker: IMoniker; Eaten: integer; BindContext: IBindCtx; Dispatch: IDispatch; Begin. OleCheck(CreateBindCtx(0, BindContext)); OleCheck(MkParseDisplayName(BindContext, PWideChar(WideString(Name)), Eaten, Moniker)); OleCheck(Moniker.BindToObject(BindContext, NIL, IDispatch, Dispatch)); Result := Dispatch; End; End.

Использование HTTP в Delphi.

Введение.

В связи с все большим вниманием, которое привлекает к себе Интернет, все больше людей становятся заинтересованы в сетевых технологиях. Данная статья посвящена программированию на Borland Delphi с использованием одного из самых популярных Интернет-протоколов - HTTP.

А именно, здесь мы рассмотрим компонент TNMHTTP (NetMasters HTTP), который можно обнаружить на вкладке FastNet палитры компонентов Дельфи.

Начнем с теории. Если Вы уже знаете, что такое HTTP и зачем он нужен, то пропустите следующий раздел.

Зачем нужен HTTP.

Итак, где же используется HTTP? Если Вы хотя бы чуть-чуть заглядывали на Интернет-странички и встречались с термином Web, то наверняка обратили внимание на то, что адреса страничек, как правило, начинаются с http://. Протокол HTTP (HyperText Transfer Protocol) позволяет принимать и посылать не только гипертекстовые документы (типа html), но и любые другие (тексты (txt), изображения (gif, jpg), и т.д.). Ниже приведены типовые задачи, для выполнения которых необходимо использовать HTTP:

· Браузеры - программы, позволяющие просматривать Интернет-странички;

· Скачивальщики - программы, позволяющие скачивать из Интернета странички, рисунки и другие документы;

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

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

Краткое описание свойств, методов и событий.

Ниже приведена таблица, содержащая наиболее краткое описание основных свойств, методов и событий компонента TNMHTTP:

Свойства.

Body - строка, содержащая либо путь к файлу, в который будет записано тело http-документа (если св-во InputFileMode равно True), либо непосредственно само тело (если св-во InputFileMode равно False). Тип: string;

Header - строка, содержащая либо путь к файлу, в который будет записан заголовок http-документа (если св-во InputFileMode равно True), либо непосредственно сам заголовок (если св-во InputFileMode равно False). Тип: string;

HeaderInfo - структура, содержащая различную информацию о http-документе (подробней см. в help-файле). Тип: THeaderInfo;

InputFileMode - тип записи результата. Значение True - запись в файлы, указанные в свойствах Body и Header, False - запись в сами эти свойства. Тип: Boolean;

OutputFileMode - тип отсылаемых данных (методами Put, Post и Trace). Значение True - данные для отправки содержатся в файлах, указанных при вызове этих методов, а False - в самих аргументах этих методов. Тип: Boolean;

Далее некоторые свойства, унаследованные от TPowerSock:

BytesRecvd, BytesSent, BytesTotal - количество отправленных, принятых и общее количество байтов соотвественно. Тип: LongInt;

Connected - показывает, установленно ли в данный момент соединение. Тип: Boolean;

BeenCanceled - показывает, было ли прервано соединение с сервером. Тип: Boolean;

Host - строка, содержащая хост-имя удаленного компьютера. Заполнять не надо, так как это свойство устанавливается автоматически при вызове методов Get, Put, Post и т.д. Тип: string. Port - Integer, содержащий порт удаленного компьютера (заполняется тоже автоматически);

TimeOut - таймаут в миллисекундах. Тип: Integer;

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

Методы.

Get(URL: string) - посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файлы или в сами свойства Body и Header (в зависимости от значения свойства InputFileMode);

Head(URL: string) - посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файл или в само свойство Header (в зависимости от значения свойства InputFileMode). В отличие от метода Get, при вызове Head запрос отсылается только на заголовок http-документа;

Post(URL, PostData: string) - посылает запрос на изменение http-документа (с адресом URL) на данные, содержащиеся в параметре PostData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.

Put(URL, PutData: string) - посылает запрос на создание http-документа (с адресом URL), содержащего данные, переданные в параметре PutData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.

Trace(URL, TraceData: string) - посылает запрос на получение отладочных данных (для отладки соединения с HTTP-сервером). Данные для запроса нужно указать в параметре TraceData. Если OutputFileMode равен True, то в TraceData должен содержаться путь к файлу, содержащему нужные данные.

Delete(URL: string) - посылает запрос на удаление http-документа (с адресом URL).

Далее некоторые методы, унаследованные от TPowerSock:

Abort и Cancel - прерывают соединение и обмен данными;

Disconnect - отсоединение от HTTP-сервера;

События.

OnAuthenticationNeeded - возникает, когда сервер требует указания имени пользователя и пароля. В обработчике этого события (если оно возникнет) Вы должны ответить серверу, запонив нужными значениями соответствующие переменные. Примечание: Перед установлением соединения можно сразу заполнить поля UserID и Password в свойстве HeaderInfo;

OnAboutToSend - возникает, когда компонент TNMHTTP собирается отправлять данные (запрос). В обработчике этого события можно заполнить дополнительной информацией свойство SendHeader;

OnFailure - возникает, когда текущая операция завершилась неудачно, т.е. произошла ошибка;

OnRedirect - возникает, сервер переадресовал ссылку с указанной URL на другую ссылку. Установив параметр handled в значение True можно запретить переадресацию и остановиться на запрошенной URL. Значение по умолчанию - False;

OnSuccess - возникает, когда текущая операция завершилась успешно, т.е. запрос был выполнен без ошибок;

Далее некоторые методы, унаследованные от TPowerSock:

OnConnect - возникает, когда соединение с сервером успешно установлено;

OnDisconnect - возникает, когда соединение с сервером завершено;

OnConnectionFailed - возникает, когда соединение с сервером установить не удалось;

OnError - возникает, когда последняя операция была завершена с ошибкой;

OnHostResolved - возникает, когда от DNS получен IP-адрес указанного хоста;

OnInvalidHost - возникает, когда DNS вернул ошибку при попытке определить IP-адрес указанного хоста;

OnPacketRecvd - возникает, когда значения свойств BytesRecvd и BytesTotal изменены, т.е. была принята новая порция данных от сервера;

OnPacketSent - возникает, когда значения свойств BytesSent и BytesTotal изменены, т.е. была отправлена новая порция данных на сервер;

OnStatus - возникает, когда статус компонента был изменен (для обновления визуального оповещения пользователя);

Практика и примеры.

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

И самый первый пример - программа, позволяющая определить, существует ли заданный URL:

Пример 1. Проверка существования указанной URL.

Code: {... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}. {В форму нужно поместить кнопку TButton и одно поле TEdit. При нажатии на кнопку вызывается обработчик события OnClick - Button1Click. Перед этим в TEdit нужно ввести адрес URL. НЕ ЗАБУДЬТЕ ПОМЕСТИТЬ В ФОРМУ КОМПОНЕНТ TNMHTTP!}. Procedure Button1Click(Sender: TObject); Begin. {Пытаемя получить заголовок}. NMHTTP1.Head(Edit1.Text); {Если URL неверный, то здесь выскочит ошибка}. End;

Проверка правильности E-mail адреса.

Автор: Udo Nesshoever.

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

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

Code: Function IsValidEmail(const Value: string): boolean; Function CheckAllowed(const s: string): boolean; Var. I: integer; Begin. Result:= false; For i:= 1 to Length(s) do. Begin. { недопустимый символ в s - значит недопустимый адрес }. If not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then. Exit; End; Result:= true; End; Var. I: integer; NamePart, serverPart: string; Begin // начало выполнения IsValidEmail. Result:= false; I:= Pos('@', Value); If i = 0 then. Exit; NamePart:= Copy(Value, 1, i - 1); ServerPart:= Copy(Value, i + 1, Length(Value)); // @ не указано имя имя или сервер не указаны; минимально для сервера. "a.com". If (Length(namePart) = 0) or ((Length(serverPart) < 1)) then. Exit; I:= Pos('.', serverPart); // должно иметь точку и как минимум два знака от конца. If (i = 0) or (i > (Length(serverPart) - 1)) then. Exit; Result:= CheckAllowed(namePart) and CheckAllowed(serverPart); End;

Delphi и CGI.

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

Необходимо отметить, что CGI-приложения разрабатываемые в средах разработки ориентированных на Win32 системы, в том числе и в Дельфи, а вернее серверная часть такого приложения может работать только под Win32 сервером, например IIS из NT или Personal Web Server из Windows98. Что касается клиентской части, то здесь никаких проблем совместимости не должно быть в принципе, т.к. клиентская часть представляет собой сгенерированный HTML код, который поддерживается любым браузером, не важно какую платформу использует пользователь, будь то Win32, OS/2, Unix и др.

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

Что касается веб-интерфейсов, то здесь желательно знать хотя бы основы языка HTML. Здесь мы не будем уделять этому особое внимание, хотя знание HTML для программиста CGI-приложений очень желательно. Сейчас же для нас будет вполне достаточным знание таких основопологающих тэгов как <HTML>,<BODY> и конструкции <FORM>.

Ну а теперь будем разбираться непосредственно с телом CGI-приложения. Во-первых, что такое CGI-приложение разрабатываемое в Win32 среде разработки? Это приложение типа Win32 CONSOLE, т.е. консольное приложение Win32. Только вот для такого приложения в отличии от классической Win32 консоли стандартным устройством ввода является либо поля ввода HTML формы либо строка адреса браузера, а в качестве стандартного устройства вывода используется окно браузера. Активизация приложения происходит непосредственно из какой-либо HTML странички, например так <A HREF="http://myhost/myapp.exe">My Application</A> Как мы уже выяснили такое CGI-приложение будет представлять собой исполняемую Win32 программу (exe), таким веб-приложениям принято давать расширение CGI, хотя это и непринципиально.

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

Code: Program MyApp. {$APPTYPE CONSOLE} // тип приложения Win32 консоль. {$E cgi} // Расширение приложения cgi. Begin. WriteLn('Content-Type: text/html'); WriteLn; WriteLn; WriteLn('<HTML>'); WriteLn('<HEAD>'); WriteLn('<ТIТLЕ>Простейшее CGI приложение</ТIТLЕ>'); WriteLn('<META http-equiv="Content-Type" content="text/html;' + ' charset=windows-1251">'); WriteLn('</HEAD>'); WriteLn('<BODY>'); WгОтitеLn('<H1>HELLO WORLD</H1>'); WriteLn('</BODY>'); WriteLn('</HTML>'); End.

Программирование CGI в Delphi и Kylix (статья).

Автор: Paul TOTH.

Перевод с французского: Valery Votintsev.

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

Содержание:

· Введение

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

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

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

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

· Куки (Cookies)

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

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

Введение.

В настоящем руководстве объясняется, как программировать CGI на Delphi и Kylix.

Автор будет рад Вашим замечаниям и пожеланиям!

Уточнения:

Для работы с CGI вам потребуется Web-сервер (для Delphi - под Windows, а для Kylix - под Linux)...

Автор тестировал свои программы на сервере Lotus Domino под NT, и на сервере Apache под Mandrake 7.0 (linux).

Автор использовал Delphi 2.0, однако это руководство применимо и для Delphi 3,4,5, 6... и Kylix !

Примечание:

Если вы планируете использовать ISAPI/NSAPI DLL, то лучше будет программировать на Delphi 5/6; однако настоящее руководство остается весьма полезным, если Вы желаете разобраться в том, как функционирует CGI.

Основные понятия.

Ссылки на CGI-программу:

На HTML-странице (или непосредственно в строке URL браузера) вы помещаете ссылку на вашу программу. Вот несколько примеров ссылок:

Простая ссылка: <a href="/cgi-bin/program.exe">

Запрос вывода изображения: <img src="/cgi-bin/program.exe">

Форма с запросом типа GET: <form method=GET action="/cgi-bin/program.exe"> ... </form>

Форма с запросом типа POST: <form method=POST action="/cgi-bin/program.exe"> ... </form>

Прямое обращение по URL: http://www.tonserver.fr/cgi-bin/program.exe.

Что такое cgi-bin:

Cgi-bin - это псевдоним каталога на сервере, который указывает на реальный каталог, в котором размещены все CGI программы.

Например:

Под Windows: c:\internet\delphi\cgi.

Под Linux: /home/httpd/cgi-bin.

Запуск CGI-программ:

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

Ответ CGI-программы:

Самым простым вариантом CGI программы может служить консольное приложение {$apptype console}, которое похоже на DOS-программу, однако работает под Windows 95/NT, или под Linux.

Эта возможность позволяет тестировать CGI-программу локально, выводя результат работу на экран.

Пример простейшей CGI-программы:

Code: Program ExampleCGI; {$apptype console}. Begin. WriteLn('Content-type: text/html'); WriteLn; WriteLn('Всем привет !'); End.

Создание Web-приложений.

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

Время первопроходцев HTML в скором времени закончиться и вовсе, и их место займут профессионалы-программисты. Именно программисты, ибо уже в большей степени от их умения создать удобный в использование сайт зависит его успех. Кроме прочего, теперь сайты создают совсем уж как программные продукты: тем кто занят наполнением содержанием, уже может не опасаться запутаться в html, java, cgi и прочих ипостасях интернет-технологий - администрирование сайта становиться таким же привычным и удобным, как работа с текстовыми процессорами. Пока правда ощущается явный недостаток законченных продуктов, на плечи которых можно было бы возложить все функции по поддержанию сайта в актуальном состоянии, оставив себе лишь вопросы по наполнению его содержанием.

Пока же тяжкое бремя по созданию данных систем, на основе которых будет функционировать сайт, ложиться на плечи программистов, только вот-вот успевших изумится возможностями языка Perl или Java. И многие из них, сказать без преувеличения, вышли, словно из гоголевской "Шинели", из Delphi. Действительно, данная среда разработчика, предоставляющая удобный интерфейс для визуального программирования и широкие возможности Object Pascal, столь мила сердцу российских программистов.

Но, похоже, что времена меняются, и Delphi, из среды создания обычных настольных приложений, может сгодиться и в другом плане: для написания прикладных web-программ. И действительно, что может быть лучше: уже знакомая среда разработки, вдоль и поперек изученный язык, да и достаточно широкий круг специалистов по программированию в Delphi - это ли не плюсы создания web-приложений на Delphi. Есть конечно и минусы: созданные программы вряд ли смогут удовлетворить тех, кто считает, что лучший web-сервер, это сервер не от Microsoft. Но что поделаешь - версия Delphi под Unix отложена пока до лучших времен. Зато посудите сами: перенос программ в будущем светлом будущем можно будет совершить с малой кровью.

Но отложим пока теорию в сторону, и обратимся к практики. Итак, создания web-приложения в среде Delphi, что называется шаг за шагом.

Пример из учебника.

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

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

Создайте в Delphi новый проект - ту самую уже давно забытую всем Console Application. Вы получите знакомый со школьной скамьи, текст обычной паскалевской программы:

Code: Program primer; {$APPTYPE CONSOLE}. Uses SysUtils; Begin. // Insert user code here. End.

Простейшая авторизация в ISAPI/CGI приложениях.

Самый простой способ защитить директорию на web сервере - это применить авторизацию. Этот пример показывает как это сделать используя только ISAPI приложение.

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

Исходный код:

============

- Эти две строчки заставляют браузер спросить имя пользователя и пароль:

Response.StatusCode := 401; // Запрос логина и пароля.

Response.WWWAuthenticate := 'Basic realm="Delphi"'; // Заголовок.

- Браузер посылает имя пользователя и пароль и мы получаем их:

Request.Authorization.

- Но информация закодирована в Base64. Существует довольно много исходников, которые показывают как кодировать/декодировать в Base64. Следующая строчка возвращает декодированные данные в mAuthorization.

FBase64.DecodeData(Copy(Request.Authorization, 6,

Length(Request.Authorization)), mAuthorization);

©Drkb::03421.

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

Как отправить бинарные данные из CGI приложения?

Не для кого не секрет, как просто можно получать данные различного типа из CGI приложения. Однако, иногда необходимо, чтобы данные сохранялись в виде файла с определённым именем, типа "Test.ZIP". Для этого необходимо добавить в заголовок HTTP пункт "Content-Disposition".

В Delphi для этого используется свойство CustomHeaders. В это TStrings свойство можно добавлять пункты в виде "name=value" - так как HTTP синтакс name:value здесь не используется.

Пример:

Code: Procedure TWebModule1.WebModule1CHECKSTATUSAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); Var s : TFileStream; Begin. S := nil; If request.query='download' then. Try. Response.Title := 'Download Test.ZIP'; Response.CustomHeaders.Add('Content-Disposition=filename=Test.zip'); Response.ContentType := 'application/zip'; S := TFileStream.Create(fmOpenRead+fmShareDenyNone,'Test.zip'); Response.contentstream := s; Response.sendresponse; Finally. S.Free; End; End;

Создание CGI счётчика в Delphi 5.

(Перевод одноимённой статьи с сайта http://homepages.borland.com/aohlsson/Articles/CounterCGI.html).

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

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

Вызывается счётчик тэгом IMG примерно так:

CGI скрипт так же может получать определённый набор параметров:

Txt e.g. "You are visitor %d today, and %d ever.".

FontName e.g. "Courier".

FontColor e.g. "clGreen" or "$404040".

BackgroundColor e.g. "clYellow" or "$808080".

А вот так выглядит вызов скрипта с несколькими параметрами:

Http://ww5.borland.com/scripts/CounterCGI.exe?FileName=Article&BackgroundColor=$808080&FontColor=$404040&FontName=Courier.

Итак, давайте разбираться с кодом.

Начать создавать новое CGI приложение следует с выбора File | New | Web Server Application | CGI stand-alone executable. После этого Вы получите чистый Web модуль. Добавьте новый TWebActionItem в подсвеченном свойстве действий (Actions) в TWebModule, нажав на Add Item. Затем двойным щелчком на событие OnAction создайте обработчик действия.

Изображение JPEG, получается как снимок изображения с TPanel, с TMemo внитри него. Таким способом легче придать 3D вид счётчику. Для начала нам необходимо добавить следующую строку в раздел implementation:

Implementation.

Uses.

ExtCtrls, StdCtrls, Controls, Forms, Graphics, JPEG;

Теперь, мы определим некоторые основные процедуры, которые будут использоваться в коде. GetPaths будет обеспечивать нас двумя жизненно важными путями. Первый путь будет указывать где хранится сам скрипт по отношению к корневой директории web сервера (т.е. относительный путь). Скорее всего это будет "scripts" или "cgi-bin" в зависимости от того, куда Вы его положите. Второй - это локальный путь в Windows. Он может выглядеть как "C:\InetPub". Для нас важны оба пути, чтобы обеспечить переносимость CGI скрипта из директории в директорию и с одного сервера на другой.

Code: Procedure GetPaths(Request: TWebRequest; var ScriptPath, LocalPath : String); Var. ScriptFileName : String; Begin. ScriptPath := Request.ScriptName; ScriptFileName := ExtractFileName(ParamStr(0)); // Убираем EXE/DLL имя, чтобы получить путь. Delete(ScriptPath,Pos(ScriptFileName,ScriptPath)-1,Length(ScriptFileName)+1); // Убираем главную косую. Delete(ScriptPath,1,1); LocalPath := ExtractFilePath(ParamStr(0)); // Удаление ScriptPath даёт нам корневой путь. Delete(LocalPath,Pos(ScriptPath,LocalPath)-1,Length(ScriptPath)+1); End;

Понимание многопоточности в VCL для веб-серверных ISAPI-расширений.

Автор: Andrew Kachanov (www.arisesoft.com).

В среде Delphi можно создавать высокоэффективные веб-серверные ISAPI-расширения на основе технологии WebBroker. Создайте проект с помощью мастера (New -> Web Server Application - ISAPI DLL). Прилагаемая справочная документация, а так же демонстрационный пример "$(DELPHI)\Demos\Webserv" позволяют достаточно быстро освоиться в приемах написания веб-серверных ISAPI-расширений. На выходе у вас получится обычная DLL (далее по тексту - библиотека).

Сложность заключается в том, что веб-сервер (для ускорения обработки поступающих запросов) вызывает нашу библиотеку в много-поточном режиме. В результате чего на разработчика ложиться ответственность за написание поточно-безопасного кода. Не беспокойтесь, ребята из Borland постарались упростить вам жизнь настолько, насколько это возможно. Когда я понял смысл "обертки" TWebApplication и наследника TISAPIApplication, то был восхищен, и вдохновлен поделиться этими знаниями с вами!

Согласно спецификации ISAPI-расширений, созданная библиотека имеет всего три экспортируемые функции: GetExtensionVersion, HttpExtensionProc, TerminateExtension. Нас интересует только HttpExtensionProc, через которую выполняется вся работа: получение запросов с веб-сервера (Request), обработка и обратная отправка результата (Response).

Итак, рассмотрим весь путь прохождения данных. Запрос веб-сервера поступает через экспортируемую библиотекой функцию HttpExtensionProc в TISAPIApplication через инкапсулированный метод с одноименным названием (объект Application, как и в любом VCL-приложении другого вида, присутствует всегда: создается при инициализации и разрушается при завершении приложения, однако в данном случае имеет тип TISAPIApplication):

Code: Function TISAPIApplication.HttpExtensionProc(var ECB: TEXTENSION_CONTROL_BLOCK): DWORD; Var. HTTPRequest: TISAPIRequest; HTTPResponse: TISAPIResponse; { ^ локально объявленные переменные запроса и ответа }. Begin. Try. HTTPRequest := NewRequest(ECB); { ^ инициализация переменной запроса по структуре ECB, полученной от веб-сервера }. Try. HTTPResponse := NewResponse(HTTPRequest); { ^ инициализация переменной ответа }. Try. If HandleRequest(HTTPRequest, HTTPResponse) then. { ^ обработка переходит к TWebApplication.HandleRequest }. Result := HSE_STATUS_SUCCESS. Else Result := HSE_STATUS_ERROR; Finally. HTTPResponse.Free; End; Finally. HTTPRequest.Free; End; Except. HandleServerException(Exception(ExceptObject), ECB); Result := HSE_STATUS_ERROR; End; End;

Как отследить изменения дисплея?

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

Далее следует пример обработчика сообщения:

Code: Type. TForm1 = class(TForm). Button1: TButton; Private. Procedure WMDisplayChange(var Message: TMessage); message WM_DISPLAYCHANGE; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WMDisplayChange(var Message: TMessage); Begin. {Do Something here}. Inherited; End;

©Drkb::01452.

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

Эта программа отслеживает изменение характеристик экрана.

Code: ... Private. Procedure WMDISPLAYCHANGE(var Msg: TWMDISPLAYCHANGE); Message WM_DISPLAYCHANGE; ... Procedure TForm1.FormCreate(Sender: TObject); Var. Bp: integer; Begin. Bp := GetDeviceCaps(GetDC(0), BITSPIXEL); Form1.Caption := 'Бит на точку - ' + IntToStr(bp) + ' (' + FloatToStr(IntPower(2, bp)) + ' цветов). Разрешение '; Form1.Caption := Form1.Caption + IntToStr(GetDeviceCaps(GetDC(0), HORZRES)) + 'X'; Form1.Caption := Form1.Caption + IntToStr(GetDeviceCaps(GetDC(0), VERTRES)) + ' '; End; Procedure TForm1.WMDISPLAYCHANGE(var Msg: TWMDISPLAYCHANGE); Var. Bp: integer; Begin. Bp := Msg.BitsPerPixel; Form1.Caption := 'Бит на точку - ' + IntToStr(bp) + ' (' + FloatToStr(IntPower(2, bp)) + ' цветов). Разрешение '; Form1.Caption := Form1.Caption + IntToStr(Msg.Width) + 'X'; Form1.Caption := Form1.Caption + IntToStr(Msg.Height) + ' '; End;

©Drkb::01453.

Автор советов: Даниил Карапетян.

E-mail: delphi4all@narod.ru.

Автор справки: Алексей Денисов.

E-mail: aleksey@sch103.krasnoyarsk.su.

Code: Type. {...} Private. Procedure WMDisplayChange(var msg: TMessage); Message WM_DISPLAYCHANGE; Public. {...} End; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WMDisplayChange(var msg: TMessage); Begin. ShowMessage('Display settings changed!'); Inherited; End;

©Drkb::01454.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Создание Active Server Page (ASP) приложений (Статья).

Новый продукт Borland – Delphi5, который начал распространяться осенью 1999 года содержит ряд новых возможностей. В частности, к экспертам проектов была добавлена возможность создания ASP приложений. Эксперт вызывается при помощи команды File/New/ActiveX и далее выбирается икона Active Server Object. К сожалению, в текущей документации, распространяемой с Delphi 5 (Build 5.62), крайне скупо сказано о назначении, последовательности создания и тестирования ASP сервера. Примеры работающего ASP сервера также отсутствуют в дистрибутиве Delphi5. Настоящая публикация частично восполняет эти проблемы.

Клиентное приложение, работающее с ASP сервером, представляет собой HTML документ и может быть прочитано на любом WEB браузере. Соответственно, эти HTML документы размещаются на каком-либо WEB-сервере. WEB сервер, получив требование о предоставлении документа, считывает его из локального хранилища и передает клиенту, при этом часть информации вносится в документ динамически ASP сервером. Принято, чтобы расширения у документов, обращающиеся к ASP серверу, имели расширение *.asp. Примеры таких документов можно найти в директориях WINNT\SYSTEM32\INETSRV\IISADMIN и INETPUB\IISAMPLES\EXAIR если был установлен Microsoft Internet Informational Server (IIS). Типичный пример обращения к ASP серверу с HTML документа выглядит следующим образом:

Set FileSystem=Server.CreateObject("Scripting.FileSystemObject").

FileSystem.FindAllFiles.

Данная запись представляет собой Visual Basic (VB) скрипт. Несмотря на наличие VB скрипта, страница ASP может быть доступна клиентам, работающих на других операционных системах, например UNIX. На первый взгляд это может показаться странным: ведь UNIX компьютеры не имеет языка Basic, и тем более VB. Но дело в том, что скрипты в ASP документах выполняются на сервере и клиенту приходит HTML документ.

ASP сервер обязан быть установлен на Windows NT (Windows 98) операционной системе с запущенным IIS или Microsoft Personal Web Server (PWS) и этот факт снижает возможности широкого использования ASP сервера. По существу, ASP сервер представляет собой внутреннюю разработку компании Microsoft, которая не была (да и не могла быть) согласована с фактическими законодателями дальнейшего развития Internet-технологий (Sun, Netscape). В будущем не следует ожидать продвижения этой технологии на другие платформы, поскольку при реализации ASP – серверов использовалась COM-технология, записи в системный реестр – а это эксклюзивные разработки Microsoft. Более того, другие WEB-сервера, работающие на платформе Windows (Netscape, Apache), скорее всего не будут поддерживать ASP технологию, поскольку до сих пор производители этих серверов успешно игноировали все новые разработки Microsoft в этой области.

По существу, ASP сервер представляет собой сервер OLE автомации, в котором предопределено несколько интерфейсов, среди них – IRequest и IResponse. IRequest содержит методы, вызов которых позволяют установить параметры, заполненные на клиенте – об этом будет рассказано ниже. IResponse содержит методы, вызов которых приводит к формированию HTML документа и, как финал, передача данного документа клиенту. По этим признакам ASP сервер напоминает CGI приложения и ISAPI/NSAPI dll (далее – WEB сервер приложения). Идеология выполнения методов в ASP сервере и WEB серверных приложениях также аналогична: анализируется (если требуется) запрос клиента и динамически формируется отклик. Отличие заключается в том, что WEB серверные приложения формируют целиком HTML документ, в то время как отклик ASP сервера вставляется в исходную HTML страницу. Например, если документ ASP представлен в виде:

<HTML>

<BODY>

<TITLE> Testing Delphi ASP </TITLE>

<H3> You should see the results of your Delphi Active Server method below </H3>

</CENTER>

<HR>

<% Set DelphiASPObj = Server.CreateObject("ASP01.Test").

DelphiASPObj.ScriptContent.

<HR>

</BODY>

</HTML>

И результат выполнения метода ScriptContent возвращает строку 'First call to ASP server', то клиент, получивший данный документ, увидит следующее (рис. 1):

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

Рис.1 Результат выполнения запроса к простейшему ASP серверу.

То есть, отклик ASP сервера добавляется к HTML документу. В одном документе допустимо обращение к нескольким ASP серверам и результат их отклика формируется в единый документ. Этого невозможно достичь при использовании WEB приложений. Ограничение: набор ASP серверов, к которым обращаются из одного документа, обязаны быть зарегистрированы на одном IIS сервере. Нельзя обратиться по различным адресам для формирования одного HTML документа.

ASP сервер реализуется как в *.exe, так и в *.dll приложениях – это разрешается при создании сервера OLE автомации. ASP сервер, реализованный в *.exe файле, запускается один раз в ответ на запрос клиента. При использовании внутренних (in-process) ASP серверов один экземпляр DLL, загруженный в оперативную память, способен обслуживать одновременно нескольких клиентов. При этом для каждого клиента может создаваться как отдельный экземпляр COM обьекта, так и единственный экземпляр COM обьекта может обслуживать нескольких клиентов. Это зависит от выбранной модели работы в потоках (Threading Model) при заполнении диалога при выборе команды File/New/ActiveX/Active Server Object.

Рассмотрим теперь, каким образом работает ASP сервер на конкретном примере создания внутреннего (in-process) ASP сервера. Ограничимся сервером, который выполняет один запрос. Выберем команду File/New/ActiveX/ActiveX Library и нажмем кнопку OK. Будет создан новый проект, который сохраним, например, под именем ASP01. Далее, вызовем из меню команду File/New/ActiveX/Active Server Object. В появляющемся диалоге определеим имя класса, например, Test. Поскольку создается in-process сервер, параметр Instancing не играет роли, зато имеет значение параметр Threading Model. Выбор параметра Single приводит к неэффективной работе сервера – при одновременном к нему обращении нескольких клиентов, сервер выполняет запросы последовательно и если один из клиентов обращается с длительным запросом, то остальные вынуждены ожидать его окончания, даже если запросы у них короткие по времени. У них создается впечатление о зависании эксплорера и часто это приводит к попыткам прервать задачу разными методами. Выбор параметра Apartment приводит к разделению запросов клиентов по потокам, при этом для каждого клиента будет создан свой экземпляр COM обьекта – в данном примере, класса TTest. При этом при написании методов класса не требуется защиты переменных класса по потокам – клиент может свободно модифицироать их и это упрощает разработку кода приложения. Недостаток этоя модели – проект ресурсоемкий и переменные класса инициализируются на каждое обращение, что удлиняет время отклика. Этих недостатков лишена модель Free, в которых единственный экземпляр COM обьекта обслуживает нескольких клиентов. Однако, если клиенты могут изменять данные, то это требует защиты общих переменных по потокам что существенно усложняет процедуру реализации кода приложения и является потенциальным источником трудноуловимых ошибок. Как правило, эту модель используют в серверах, которые только предоставляют данные, но клиент не может их модифицировать.

Группа контролей Active Server Type позволяет выбрать назначение ASP сервера. Если сервер планируется инсталлировать на компьютере, которым управляет IIS версии 3 или 4, то следует выбрать Page Level Events Methods. С IIS5 эта опция тоже работает, но эффективнее будет работать опция Object Context. Эту же опцию необходимо выбирать, если работой ASP управляет Microsoft Transaction Server (MTS). Фактически IIS5 также управляет этим сервером при помощи MTS – оба этих продукта тесно интегрированы.

Опцию Generate a Template Test Script for this object следует оставлять всегда включенной – Delphi в этом случае создаст небольшой HTML документ, который с небольшими изменениями можно использовать для тестирования ASP сервера.

После заполнения опций диалога следует нажать кнопку OK и после этого будет создан файл реализации интерфейсов Unit1.pas, который следует запомнить под разумным именем – например: U1_01. Кроме того, будет создана библиотека типов, появится ее редактор и файл, описывающий библиотеку типов – в данном примере TEST_TLB.pas. Если была выбрана опция Page Level Events Methods (как в данном примере), то библиотека типов будет содержать два предопределенных метода – OnStartPage и OnEndPage. Также будет создан файл Test.asp, который содержит HTML документ с заготовками VB скриптов для тестирования сервера.

Если заглянуть в файл реализации (U1_01.pas) , то класс ТТеst является потомком класса TASPObject. При выборе же опции Object Context библиотека типов не содержит предопределенных методов, а сам класс TTest являлся бы потомком TASPMTSObject. Оба класса-предка TTest содержат абсолютно одинаковые методы и свойста, но класс TASPObject дополнительно содержит пару методов интерфейса IASPObject - OnStartPage и OnEndPage.

Далее, создадим метод, который будет заполнять HTML документ. Для этого в редакторе библиотеки типов (рис 2) отметим интерфейс ITest и вызовем команду New Method нажатием кнопки 1:

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

Рис. 2. Добавление нового метода к редактору библиотеки типов ASP сервера.

Назовем вновь созданный метод ScriptContent набив этот текст в названии метода с мигающей кареткой. Данный метод не должен иметь параметров. Далее вызовем команду Refresh нажатием кнопки 2. После этого в модуле реализации (U1_01.pas) появится заготовка, где следует описать реализацию. Метод реализуем следующим образом:

Code: Procedure TTest.ScriptContent; Begin. If Assigned(Response) Then Response.Write('First call to ASP server'); End;

Как добавить кнопку в панель инструментов IE?

1. ButtonText = Всплывающая подсказка к кнопке.

2. MenuText = Текст, который будет использован для пункта в меню "Сервис".

3. MenuStatusbar = *Ignore*

4. CLSID = Ваш уникальный classID. Для создания нового CLSID (для каждой кнопки) можно использовать GUIDTOSTRING.

5. Default Visible := Показать ей.

6. Exec := Путь к Вашей программе.

7. Hoticon := иконка из shell32.dll когда мышка находится над кнопкой.

8. Icon := иконка из shell32.dll.

Code: Procedure CreateExplorerButton; Const. TagID = '\{10954C80-4F0F-11d3-B17C-00C0DFE39736}\'; Var. Reg: TRegistry; ProgramPath: string; RegKeyPath: string; Begin. ProgramPath := 'c:\folder\exename.exe'; Reg := TRegistry.Create; Try. With Reg do begin. RootKey := HKEY_LOCAL_MACHINE; RegKeyPath := 'Software\Microsoft\Internet Explorer\Extensions'; OpenKey(RegKeyPath + TagID, True); WriteString('ButtonText', 'Your program Button text'); WriteString('MenuText', 'Your program Menu text'); WriteString('MenuStatusBar', 'Run Script'); WriteString('ClSid', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}'); WriteString('Default Visible', 'Yes'); WriteString('Exec', ProgramPath); WriteString('HotIcon', ',4'); WriteString('Icon', ',4'); End. Finally. Reg.CloseKey; Reg.Free; End; End;

Как очистить кэш в IE?

В примере описывается как программно в Internet Explorer нажать кнопку "Clear cache".

Вам нужно будет использовать WinINet в Вашей TfrmMain:

Code: Uses WinINet;

Как добавить Cookies?

Пример демонстрирует создание cookie посредствам стандартного компонента Delphi.

Code: Procedure TwebDispatcher.WebAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); Begin. With (Response.Cookies.Add) do begin. Name := 'TESTNAME'; Value := 'TESTVALUE'; Secure := False; Expires := Now; Response.Cookies.WebResponse.SendResponse; End; End;

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

Автор: Ruslan Abu Zant.

Приводимая здесь функция показывает, как Ваше приложение может извлечь из браузера (IE или Netscape) URL , как, например, это делает аська.

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

Не забудьте добавить DDEMan в Ваш проект!

Code: Uses windows, ddeman, ...... Function Get_URL(Servicio: string): String; Var. Cliente_DDE: TDDEClientConv; Temp:PChar; //<<-------------------------This is new. Begin. Result := ''; Cliente_DDE:= TDDEClientConv.Create( nil ); With Cliente_DDE do. Begin. SetLink( Servicio,'WWW_GetWindowInfo'); Temp := RequestData('0xFFFFFFFF'); Result := StrPas(temp); StrDispose(temp); //<<-Предотвращаем утечку памяти. CloseLink; End; Cliente_DDE.Free; End; Procedure TForm1.Button1Click(Sender); Begin. Showmessage(Get_URL('Netscape')); Или. Showmessage(Get_URL('IExplore')); End;

Связка ActiveX - Internet Explorer.

А знаете ли вы, что на Delphi можно писать ActiveX компоненты? Конечно знаете. А что с их помощью можно взаимодействовать с Internet Explorer? Это может быть интересно для профессиональных вебмастеров, скажете вы, но я не согласен. "Простой" программист тоже может найти массу применений этому. Здесь будет описано одно из них. Все мы лазим (ходим и т.д.) по интернету. И вы тоже - раз читаете эти строки :). А не случалось ли вам, случайно где-то побывав, что-то прочитав и благополучно забыв адрес сайта через некоторое время вдруг понять, что там было именно то, что вам сейчас срочно понадобилось? Можно конечно посмотреть History браузера, можно залезть в кэш "руками" и попытаться найти там что-то. А можно написать компонент, который бы искал слова в файлах кэша (в общем случае в любых HTML-файлах) и выводил бы на просмотр требуемые файлы. Связать этот компонент с Эксплорером - и вперед. Что удобно - вся работа происходит в эксплорере: и поиск, и,естественно, просмотр. При этом для Delphi-программиста не нужны особые знания языка HTML, скриптовых языков и т.п. Достаточно знать несколько основных конструкций (а уж справочных руководств в интернете навалом - хотя бы на www.citforum.ru). Написанный ActiveX-компонент вставляется в HTML-страничку. Вот пример простейшей странички.

<HTML>

<HEAD>

<ТIТLЕ>Поиск</ТIТLЕ>

</HEAD>

<BODY>

<OBJECT ID="findword1" - {при помощи этого тэга компонент вставляется в страничку}.

CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6".

CODEBASE="C:\PATH\FINDWORDS.OCX">

</OBJECT>

</P>

</BODY>

</HTML>

В этом примере ActiveX-компонент, находящийся в файле C:\PATH\FINDWORDS.OCX вставляется в HTML-страничку. Но важно отметить, что эта страничка откроется только в Microsoft Internet Explorer версии 4 и старше. Пишут, что третий эксплорер тоже поддерживает тэг <OBJECT>, но сам не пробовал, не знаю. Браузеры Netscape, Opera и какие еще там бывают, его не поддерживают.

Итак, тэг <OBJECT> вставляет в страничку ActiveX-компонент. Его атрибут CLASSID указывает идентификатор класса нашего компонента. При создании в Delphi компонента с нуля ему автоматически присваивается этот идентификатор класса. ID="findword1" - имя объекта. Здесь можно писать любое имя. По нему мы в дальнейшем будем ссылаться на наш компонент в теле странички из скриптов-процедур обработки событий. Далее, для того, чтобы наш компонент мог использоваться прикладными программами, он должен быть зарегистрирован в реестре. Зарегистрировать его можно программой regsvr32, которая по умолчанию находится в каталоге [System]. Например так: [regsvr32 C:\PATH\FINDWORDS.OCX]. Если при открытии странички Explorer не находит в реестре указанный компонент, то он ищет его в местоположении, указанном атрибутом CODEBASE. Здесь может быть полный путь к файлу, если он находится на вашем жестком диске или даже URL-адрес (со всеми сопутствующими атрибутами, как то http:// и т.д.).Т.е, если эксплорер встретил ссылку на компонент, а этого компонента нет на вашей машине, он может загрузить его из интернета с указанного адреса. Кстати, атрибут CLASSID - обязательный, именно по нему производится "идентификация" класса. А атрибут CODEBASE - необязательный. В случае, когда он опущен, если компонент уже зарегистрирован в системе, то он отобразится в вашей страничке, если не зарегистрирован - страничка будет пустой. И наконец если эксплорер сам регистрирует компонент, он переписывает файл OCX в папку [Windows\Downloaded program files].

Для того, чтобы вручную не писать скрипты подсоединения ActiveX компонентов, я советую скачать программу Microsoft ActiveX Control Pad отсюда. Эта программа предназначена для внедрения ActiveX-компонентов в HTML-странички. После ее работы определение компонента выглядит примерно так:

<OBJECT ID="findword1".

CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6".

CODEBASE="C:\PATH\FINDWORDS.OCX">

</OBJECT>

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

Теперь подходим к самому главному: как сделать сам компонент (чтобы было что вставлять в нашу страничку :). Итак, в Delphi делаем New\ActiveX\Active form. В окошке Active Form Wizard выбираем Threading model=Apartment. Другие threading models не работают с IE 4. Выглядит это так: компонент в страничке открывается, но иногда вдруг выскакивает Access violation. (обычно на событие Create). Модель же Both работает с IE 5. Флажок "Include Design-Time licence" лучше не устанавливать. Дальше открывается новая форма, где вы можете размещать свои кнопки-текстбоксы, определять реакцию на события и т.д.

Далее будут описаны некоторые хитрости. Например, нужно хранить некоторые данные во внешнем файле. Я столкнулся со следующим: мой компонент на разных машинах размещал свои файлы в разных местах: на одной в каталоге Windows, на другой - на рабочем столе. Был найден такой выход: пусть страничка по требованию компонента возвращает ему каталог, в котором она находится. Для этого на форму я поместил PageControl, сделал закладки невидимыми и на OnShow (у формы ActiveX компонента нет события OnShow) одной из страниц поставил генерацию собственного события OnWantDir. А в теле HTML-странички соответственно реакцию на него:

<!--

Sub findword1_OnWantDir().

Findword1.page_location = location.href.

End Sub.

-->

</SCRIPT>

Далее, это событие OnShow происходит сразу после создания экземпляра компонента. Так вот, если событие OnWantDir генерировать непосредственно в нем (в OnShow), то видимо что-то в недрах Windows не успевает провернуться и машина виснет. Поэтому пришлось повесить на форму таймер, на OnShow таймер запускать, и уже на OnTimer как раз и вызывать свое событие OnWantDir. Интервал у таймера я поставил в полсекунды. Конечно можно было бы хранить свои файлы например в каталоге [Windows], но почему-то функция GetWindowsDirectory при вызове из ActiveX-компонента возвращала ошибку, хотя тут же нормально отрабатывала из обыкновенного приложения (exe). То же и с GetSystemDirectory и GetTempDirectory. Кто не знает как делать собственные свойства и события - кликайте сюда.

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

<html>

<HEAD>

<titlе>Поиск</titlе>

<!--

Sub Procedure1().

Location.href = findword1.NewStroke.

{Получить от компонента имя файла и открыть его для просмотра. Эта процедура запускается при возникновении события OnDocClick. Location - объект Ехрlоrеr'а (см. документацию по VBScript)}.

End Sub.

-->

</SCRIPT>

</HEAD>

<!--

Sub findword1_OnWantDir().

Findword1.page_location = location.href.

{Получить текущий каталог, т.е. свойству page_location объекта присвоить местоположение нашей странички}.

End sub.

Sub findword1_OnDocClick().

{При возникновении события OnDocClick вызвать процедуру Procedure1 (открыть файл для просмотра)}.

Call Procedure1().

End sub.

-->

</SCRIPT>

<OBJECT ID="findword1".

CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6".

CODEBASE="findwords.ocx">

{Здесь просто имя файла без пути. Explorer зарегистрирует компонент невидимо для пользователя, взяв его из текущеего каталога (страничка и файл OCX находятся в одном каталоге)}.

</OBJECT>

</p>

</BODY>

</html>

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

©Drkb::03526.

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

Примечание Vit: Данный FAQ не поддерживает вложения, поэтому все линки данного топика не рабочие. Используйте оригинал с Web сайта для полной функциональности: http://www.sources.ru/delphi/delphi_activex_ie.shtml.

Как открыть HTML-файл в стандартном браузере?

Code: //------------------------------------------------------------- // HTMLView - пример, показывающий, как открыть HTM/HTML файл в браузере, // установленном поумолчанию. // Пример использует Win32API функцию ShellExecute с параметром 'open', // которая заставляет систему найти в реестре приложение, связанное. // с расширением HTM/HTML. //------------------------------------------------------------- Unit HTMLUnit; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ShellAPI; Type. TForm1 = class(TForm). OpenDialog1: TOpenDialog; Button1: TButton; Button2: TButton; Label1: TLabel; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1 : TForm1; HTMLFile : Array[0..79] of Char; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. If OpenDialog1.Execute then. Begin. // получаем имя выбранного файла. StrPCopy(HTMLFile, OpenDialog1.FileName); // разрешаем пользователю открывать (т.е. просматривать) его в браузере. Button2.Enabled := True; End; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. // запускаем функцию ShellExecute с параметром 'open' ShellExecute(Handle, 'open', HTMLFile, nil, nil, SW_SHOWNORMAL); End; End.

Как сохранить исходник HTML из TWebBrowser.Document на диск?

TWebBrowser.Document включает в себя IPersistStreamInit который содержит метод Save(). Всё, что нам нужно знать, это как использовать данный метод с объектом, который включён в IStream. Для этого мы просто воспользуемся TStreamAdapter.

Обратите внимание, что интерфейсы IPersistStreamInit и IStream объявлены внутри ActiveX unit.

Итак, вот так это выглядит.

Code: Procedure TForm1.SaveHTMLSourceToFile(const FileName: string; WB: TWebBrowser); Var. PersistStream: IPersistStreamInit; FileStream: TFileStream; Stream: IStream; SaveResult: HRESULT; Begin. PersistStream := WB.Document as IPersistStreamInit; FileStream := TFileStream.Create(FileName, fmCreate); Try. Stream := TStreamAdapter.Create(FileStream, soReference) as IStream; SaveResult := PersistStream.Save(Stream, True); If FAILED(SaveResult) then. MessageBox(Handle, 'Fail to save HTML source', 'Error', 0); Finally. { В ответ на уничтожение объекта TFileStream, передаём. SoReference в конструктор TStreamAdapter. }. FileStream.Free; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If SaveDialog1.Execute then. SaveHTMLSourceToFile(SaveDialog1.FileName, WebBrowser1); End;

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

©Drkb::03530.

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.

Как получить информацию о локальных настройках системы?

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

Далее приведена функция, которая возвращает значение в зависимости от параметра "flag":

Code: ........ Function TForm1.GetLocaleInformation(Flag: Integer): String; Var. PcLCA: Array[0..20] of Char; Begin. If( GetLocaleInfo(LOCALE_SYSTEM_DEFAULT,Flag,pcLCA,19) <= 0 ) then begin. PcLCA[0] := #0; End; Result := pcLCA; End; ........

Удаление HTML элементов из текста.

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

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

Code: Procedure TMainForm.LoadFileIntoList(TextFileName:String; AWebPage:TStringList; WithFilter:Boolean); Var CurrentFile : TStringList; Begin. CurrentFile := TStringList.Create; CurrentFile.LoadFromFile(TextFileName); If WithFilter then. FilterHTML(CurrentFile,AWebPage). Else. With AWebPage do AddStrings(CurrentFile); CurrentFile.Free; End; Procedure TMainForm.FilterHTML(FilterInput, AWebPage:TStringList); Var. I,j : LongInt; S : String; Begin. FilterMemo.Lines.Clear; FilterMemo.Lines := FilterInput; With AWebPage do. Begin. FilterMemo.SelectAll; J := FilterMemo.SelLength; If j > 0 then. Begin. I := 0; Repeat. If FilterMemo.Lines.GetText[i] = Char(VK_RETURN) // ищем cr. Then S := S+' ' Else if FilterMemo.Lines.GetText[i] = '<' Then repeat. Inc(i); Until FilterMemo.Lines.GetText[i] = '>' Else if FilterMemo.Lines.GetText[i] = Char(VK_TAB) // ищем tab. Then S := S+' ' Else S := S+ FilterMemo.Lines.GetText[i]; // добавляем текст. Inc(i); Until i = j+1; Add(S); // добавляем строку в WebPage. End else Add('No data entered into field.'); // no data in text file. End; End;

WEB страничка внутри Delphi приложения.

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

Многие из Вас спрашивают, как сделать, чтобы приложением могло содержать в себе различные компоненты в стиле Web, включая HTML ресурсы и картинки, которые являются частью Вашего проекта. Статья показывает, как можно легко добавить в Delphi приложение HTML и связанные с ним файлы (картинки).

Создание HTML страницы.

Для начала мы должны создать простую страницу HTML. Для этого можно использовать Ваш любимый HTML редактор, и создать одну страницу с одним изображением. К примеру, назовём этот файл aboutindex.htm. Обратите внимание, что, когда Вы добавляете тэг картинки внутрь htm страницы, то в исходнике страницы будет присутствовать следудующая строка:

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

У меня HTML код выглядит следующим образом:

<HTML><HEAD><TITLE>HTML inside a Delphi exe</TITLE></HEAD><BODY>

This is a HTML Delphi resource test:<br>

</BODY></HTML>

Создание и компиляция файла ресурсов.

Запомните, что для того, чтобы создать новый скрипт-файл ресурсов, необходимо:

1. Создать новый текстовый файл в директории Вашего проекта.

2. Переименовать его в AHTMLDelphi.rc.

3. Добавить следующие две строки текста в файл AHTMLDelphi.rc.

DELPHIINDEX HTML "c:\Delphi\projects\aboutindex.htm".

ABOUTDP GIF "c:\library\graphics\adp.gif".

Обратите внимание, что "HTML" тип ресурса RT_HTML, определён как "23". Это значение является дефолтовым для протокола RES.

Таким образом мы подготовили одну HTML страницу и одну картинку GIF, которые будут включены в исполняемый EXE модуль.

Следующий шаг - это компиляция .rc файла. Для компиляции файла AHTMLDelphi.rc в файл .res, выполните следующую команду из командной строки (в директории Вашего проекта):

BRCC32 AHTMLDelphi.RC.

Заключительный шаг - это добавление следующей директивы компилятора в unit Вашего проекта. Следующая строка заставляет компилятор включить в проект файл RES:

{$R AHTMLDelphi.RES}.

Отображение внутри Web браузера.

После того, как Вы получите экзешник приложения (назовём его, например, myhtmldelphi.exe), то HTML ресурсы, содержащиеся в нём, могут быть доступны через протокол RES: . Запустите Internet Explorer и, адресной строке напишите следующее:

Res://c:\myhtmldelphi.exe/DELPHIINDEX.

©Drkb::03532.

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

Как преобразовать шестнадцатиричный цвет HTML в TColor?

Допустим, мы имеем переменную:

Const BGCOLOR = '#003366';

И нам необходимо связать её с фоновым цветом memo либо любого другого TColor.

Мы можем это сделать простым вызовом функции и использовать возвращённое значение:

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. Memo.Color := ConvertHtmlHexToTColor(BGCOLOR); End;

Как распечатать WEB страничку при помощи HTML контрола?

Можно использовать два метода HTML контрола: AutoPrint или PrintPage.

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

--------------------------------------------------------------------------------

Как распечатать WEB страничку при помощи HTML контрола.

Можно использовать два метода HTML контрола: AutoPrint или PrintPage.

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

Code: Uses Printers; Procedure TForm1.Button1Click(Sender: TObject); Var. OldCur: TCursor; Begin. OldCur := Screen.Cursor; With Printer do begin. BeginDoc; HTML1.AutoPrint(handle); Title := HTML1.URL; EndDoc; End; Screen.Cursor := OldCur; End;

Как получить цвет строки в HTML формате?

Если Вам необходимо создать HTML-файл, то необходимо объявить тэг для цвета шрифта либо цвета фона. Однако просто вставить значение TColor не получится - необходимо преобразовать цвет в формат RGB. В своём наборе SMExport я использую следующую функцию:

Code: Function GetHTMLColor(cl: TColor; IsBackColor: Boolean): string; Var rgbColor: TColorRef; Begin. If IsBackColor then. Result := 'bg' Else. Result := ''; RgbColor := ColorToRGB(cl); Result := Result + 'color="#' + Format('%.2x%.2x%.2x', [GetRValue(rgbColor), GetGValue(rgbColor), GetBValue(rgbColor)]) + '"'; End;

Посылка Raw IP-пакетов.

Автор: Erwin Molendijk.

Используя данный исходник можно конструировать собственные пакеты содержащие внутри всё, что угодно. Можно самостоятельно указывать в пакете IP-адрес получателя и отправителя, порт назначения и т.д. Если Вы не знаете, что это такое, то лучше не эксперементировать. Единственный недостаток, то, что скорее всего данный пример будет работать только в Windows 2000. Так же исходник позволяет произвести SYN flood и IP spoofing.

Необходимо зайти в систему под Администратором.

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

Code: { Raw Packet Sender. Using: Delphi + Winsock 2. Copyright (c) 2000 by E.J.Molendijk (xes@dds.nl). ---------------------------------------------------------------------- Перед использованием измените значения SrcIP+SrcPort+ DestIP+DestPort на нужные! ---------------------------------------------------------------------- } Unit main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, OleCtrls, Registry; Const. SrcIP = '123.123.123.1'; SrcPort = 1234; DestIP = '123.123.123.2'; DestPort = 4321; Max_Message = 4068; Max_Packet = 4096; Type. TPacketBuffer = Array[0..Max_Packet-1] of byte; TForm1 = class(TForm). Button1: TButton; Memo1: TMemo; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. Procedure SendIt; End; // Заголовок IP пакета. Type. T_IP_Header = record. Ip_verlen : Byte; Ip_tos : Byte; Ip_totallength : Word; Ip_id : Word; Ip_offset : Word; Ip_ttl : Byte; Ip_protocol : Byte; Ip_checksum : Word; Ip_srcaddr : LongWord; Ip_destaddr : LongWord; End; // Заголовок UDP пакета. Type. T_UDP_Header = record. Src_portno : Word; Dst_portno : Word; Udp_length : Word; Udp_checksum : Word; End; // Некоторые объявления типов для Winsock 2. U_char = Char; U_short = Word; U_int = Integer; U_long = Longint; SunB = packed record. S_b1, s_b2, s_b3, s_b4: u_char; End; SunW = packed record. S_w1, s_w2: u_short; End; In_addr = record. Case integer of. 0: (S_un_b: SunB); 1: (S_un_w: SunW); 2: (S_addr: u_long); End; TInAddr = in_addr; Sockaddr_in = record. Case Integer of. 0: (sin_family: u_short; Sin_port: u_short; Sin_addr: TInAddr; Sin_zero: array[0..7] of Char); 1: (sa_family: u_short; Sa_data: array[0..13] of Char). End; TSockAddr = Sockaddr_in; TSocket = u_int; Const. WSADESCRIPTION_LEN = 256; WSASYS_STATUS_LEN = 128; Type. PWSAData = ^TWSAData; WSAData = record // !!! also WSDATA. WVersion: Word; WHighVersion: Word; SzDescription: array[0..WSADESCRIPTION_LEN] of Char; SzSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; IMaxSockets: Word; IMaxUdpDg: Word; LpVendorInfo: PChar; End; TWSAData = WSAData; // Определяем необходимые функции winsock 2. Function closesocket(s: TSocket): Integer; stdcall; Function socket(af, Struct, protocol: Integer): TSocket; stdcall; Function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr; Tolen: Integer): Integer; stdcall;{}. Function setsockopt(s: TSocket; level, optname: Integer; optval: PChar; Optlen: Integer): Integer; stdcall; Function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr }. Function htons(hostshort: u_short): u_short; stdcall; Function WSAGetLastError: Integer; stdcall; Function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall; Function WSACleanup: Integer; stdcall; Const. AF_INET = 2; // internetwork: UDP, TCP, etc. IP_HDRINCL = 2; // включаем заголовок IP пакета. SOCK_RAW = 3; // интерфейс raw-протокола. IPPROTO_IP = 0; // dummy for IP. IPPROTO_TCP = 6; // tcp. IPPROTO_UDP = 17; // user datagram protocol. IPPROTO_RAW = 255; // raw IP пакет. INVALID_SOCKET = TSocket(NOT(0)); SOCKET_ERROR = -1; Var. Form1: TForm1; Implementation. // Импортируем функции Winsock 2. Const WinSocket = 'WS2_32.DLL'; Function closesocket; external winsocket name 'closesocket'; Function socket; external winsocket name 'socket'; Function sendto; external winsocket name 'sendto'; Function setsockopt; external winsocket name 'setsockopt'; Function inet_addr; external winsocket name 'inet_addr'; Function htons; external winsocket name 'htons'; Function WSAGetLastError; external winsocket name 'WSAGetLastError'; Function WSAStartup; external winsocket name 'WSAStartup'; Function WSACleanup; external winsocket name 'WSACleanup'; {$R *.DFM}. // // Function: checksum. // // Description: // This function calculates the 16-bit one's complement sum. // for the supplied buffer. // Function CheckSum(Var Buffer; Size : integer) : Word; Type. TWordArray = Array[0..1] of Word; Var. ChkSum : LongWord; I : Integer; Begin. ChkSum := 0; I := 0; While Size > 1 do begin. ChkSum := ChkSum + TWordArray(Buffer)[i]; Inc(i); Size := Size - SizeOf(Word); End; If Size=1 then ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]); ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF); ChkSum := ChkSum + (Chksum shr 16); Result := Word(ChkSum); End; Procedure BuildHeaders( FromIP : String; IFromPort : Word; ToIP : String; IToPort : Word; StrMessage : String; Var Buf : TPacketBuffer; Var remote : TSockAddr; Var iTotalSize : Word. ); Var. DwFromIP : LongWord; DwToIP : LongWord; IIPVersion : Word; IIPSize : Word; IpHdr : T_IP_Header; UdpHdr : T_UDP_Header; IUdpSize : Word; IUdpChecksumSize : Word; Cksum : Word; Ptr : ^Byte; Procedure IncPtr(Value : Integer); Begin. Ptr := pointer(integer(ptr) + Value); End; Begin. // преобразуем ip адреса. DwFromIP := inet_Addr(PChar(FromIP)); DwToIP := inet_Addr(PChar(ToIP)); // Инициализируем заголовок IP пакета. // ITotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage); IIPVersion := 4; IIPSize := sizeof(ipHdr) div sizeof(LongWord); // // IP version goes in the high order 4 bits of ip_verlen. The. // IP header length (in 32-bit words) goes in the lower 4 bits. // IpHdr.ip_verlen := (iIPVersion shl 4) or iIPSize; IpHdr.ip_tos := 0; // IP type of service. IpHdr.ip_totallength := htons(iTotalSize); // Total packet len. IpHdr.ip_id := 0; // Unique identifier: set to 0. IpHdr.ip_offset := 0; // Fragment offset field. IpHdr.ip_ttl := 128; // время жизни пакета. IpHdr.ip_protocol := $11; // Protocol(UDP). IpHdr.ip_checksum := 0 ; // IP checksum. IpHdr.ip_srcaddr := dwFromIP; // Source address. IpHdr.ip_destaddr := dwToIP; // Destination address. // // Инициализируем заголовок UDP пакета. // IUdpSize := sizeof(udpHdr) + length(strMessage); UdpHdr.src_portno := htons(iFromPort) ; UdpHdr.dst_portno := htons(iToPort) ; UdpHdr.udp_length := htons(iUdpSize) ; UdpHdr.udp_checksum := 0 ; // // Build the UDP pseudo-header for calculating the UDP checksum. // The pseudo-header consists of the 32-bit source IP address, // the 32-bit destination IP address, a zero byte, the 8-bit. // IP protocol field, the 16-bit UDP length, and the UDP. // header itself along with its data (padded with a 0 if. // the data is odd length). // IUdpChecksumSize := 0; Ptr := @buf[0]; FillChar(Buf, SizeOf(Buf), 0); Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr)); IncPtr(SizeOf(ipHdr.ip_srcaddr)); IUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr); Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr)); IncPtr(SizeOf(ipHdr.ip_destaddr)); IUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr); IncPtr(1); Inc(iUdpChecksumSize); Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol)); IncPtr(sizeof(ipHdr.ip_protocol)); IUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol); Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length)); IncPtr(sizeof(udpHdr.udp_length)); IUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length); Move(udpHdr, ptr^, sizeof(udpHdr)); IncPtr(sizeof(udpHdr)); IUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr); Move(StrMessage[1], ptr^, Length(strMessage)); IncPtr(Length(StrMessage)); IUdpChecksumSize := iUdpChecksumSize + length(strMessage); Cksum := checksum(buf, iUdpChecksumSize); UdpHdr.udp_checksum := cksum; // // Now assemble the IP and UDP headers along with the data. // so we can send it. // FillChar(Buf, SizeOf(Buf), 0); Ptr := @Buf[0]; Move(ipHdr, ptr^, SizeOf(ipHdr)); IncPtr(SizeOf(ipHdr)); Move(udpHdr, ptr^, SizeOf(udpHdr)); IncPtr(SizeOf(udpHdr)); Move(StrMessage[1], ptr^, length(StrMessage)); // Apparently, this SOCKADDR_IN structure makes no difference. // Whatever we put as the destination IP addr in the IP header. // is what goes. Specifying a different destination in remote. // will be ignored. // Remote.sin_family := AF_INET; Remote.sin_port := htons(iToPort); Remote.sin_addr.s_addr := dwToIP; End; Procedure TForm1.SendIt; Var. Sh : TSocket; BOpt : Integer; Ret : Integer; Buf : TPacketBuffer; Remote : TSockAddr; Local : TSockAddr; ITotalSize : Word; Wsdata : TWSAdata; Begin. // Startup Winsock 2. Ret := WSAStartup($0002, wsdata); If ret<>0 then begin. Memo1.lines.add('WSA Startup failed.'); Exit; End; With memo1.lines do begin. Add('WSA Startup:'); Add('Desc.: '+wsData.szDescription); Add('Status: '+wsData.szSystemStatus); End; Try. // Создаём сокет. Sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP); If (sh = INVALID_SOCKET) then begin. Memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError)); Exit; End; Memo1.lines.add('Socket Handle = '+IntToStr(sh)); // Option: Header Include. BOpt := 1; Ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt)); If ret = SOCKET_ERROR then begin. Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError)); Exit; End; // строим пакет. BuildHeaders( SrcIP, SrcPort, DestIP, DestPort, 'THIS IS A TEST PACKET', Buf, Remote, iTotalSize ); // Отправляем пакет. Ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote)); If ret = SOCKET_ERROR then. Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError)). Else. Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.'); // Закрываем сокет. CloseSocket(sh); Finally. // Закрываем Winsock 2. WSACleanup; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. SendIt; End; End.

Как послать широковещательный UDP пакет?

Code: Procedure TMainForm.FormCreate(Sender: TObject); Var Init:TWSAData; SockOpt:BOOL; Sock:TSocket; Target:TSockAddrIn; Begin. WSAStartup($101,Init); Sock:=Socket(PF_INET,SOCK_DGRAM,IPPROTO_UDP); SockOpt:=TRUE; SetSockOpt(Sock,SOL_SOCKET,SO_BROADCAST,PChar(@SockOpt),SizeOf(SockOpt)) ; Target.sin_port:=htons(8167);//номер порта. Target.sin_addr.S_addr:=INADDR_BROADCAST; Target.sa_family:=AF_INET; SendTo(Sock,Data,DataBytes,0,Target,SizeOf(Target)); WSACleanup; End;

Отправка файлов при помощи TClientSocket/TServerSocket.

Автор: M K.

На вопрос "Как я могу отправлять файлы через TClientSocket & TServerSocket?" даём наш ответ :).

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ScktComp, ExtCtrls, StdCtrls; Type. TForm1 = class(TForm). Image1: TImage; Image2: TImage; ClientSocket1: TClientSocket; ServerSocket1: TServerSocket; Button1: TButton; Procedure Image1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Procedure ClientSocket1Connect(Sender: TObject; Socket: TCustomWinSocket); Procedure ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket); Procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket); Private. { Private declarations }. Reciving: boolean; DataSize: integer; Data: TMemoryStream; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Image1Click(Sender: TObject); Begin. // Это процедура для открытия сокета на ПРИЁМ (RECEIVING). // Button1.Click is this procedure as well. ClientSocket1.Active:= true; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. // Открытие ОТПРАВЛЯЮЩЕГО (SENDING) сокета. ServerSocket1.Active:= true; End; Procedure TForm1.ClientSocket1Connect(Sender: TObject; Socket: TCustomWinSocket); Begin. // Посылаем команду для начала передачи файла. Socket.SendText('send'); End; Procedure TForm1.ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket); Var. S, sl: string; Begin. S:= Socket.ReceiveText; // Если мы не в режиме приёма: If not Reciving then. Begin. // Теперь нам необходимо получить длину потока данных. SetLength(sl, StrLen(PChar(s))+1); // +1 for the null terminator. StrLCopy(@sl[1], PChar(s), Length(sl)-1); DataSize:= StrToInt(sl); Data:= TMemoryStream.Create; // Удаляем информацию о размере из данных. Delete(s, 1, Length(sl)); Reciving:= true; End; // Сохраняем данные в файл, до тех пор, пока не получим все данные. Try. Data.Write(s[1], length(s)); If Data.Size = DataSize then. Begin. Data.Position:= 0; Image2.Picture.Bitmap.LoadFromStream(Data); Data.Free; Reciving:= false; Socket.Close; End; Except. Data.Free; End; End; Procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket); Var. Ms: TMemoryStream; Begin. // Клиент получает команду на передачу файла. If Socket.ReceiveText = 'send' then. Begin. Ms:= TMemoryStream.Create; Try. // Получаем данные на передачу. Image1.Picture.Bitmap.SaveToStream(ms); Ms.Position:= 0; // Добавляем длину данных, чтобы клиент знал, сколько данных будет передано. // Добавляем #0 , чтобы можно было определить, где заканчивается информация о размере. Socket.SendText(IntToStr(ms.Size) + #0); // Посылаем его. Socket.SendStream(ms); Except. // Итак, осталось освободить поток, если что-то не так. Ms.Free; End; End; End; End.

Как отправить веб форму на сервер?

Как отправить вебформу на сервер при помощи TClientSocket (напрямую и через прокси).

Code: { Copyright (c) 1999 by E.J.Molendijk. Присоедините следующие события к Вашему ClientSocket: Procedure T...Form.ClientSocket1Write; Procedure T...Form.ClientSocket1Read; Procedure T...Form.ClientSocket1Disconnect; Procedure T...Form.ClientSocket1Error; Так же пример показывает, как направлять передачу через прокси-сервер. Для отправки на вебсервер используется следующий формат: Напрямую: 'POST ' + PostAddr + 'HTTP/1.0' + HTTP_Data + Content. Через проксю: 'POST http://' Webserver + PostAddr + 'HTTP/1.0' + HTTP_Data + Content. } Const. WebServer = 'www.somehost.com'; WebPort = 80; PostAddr = '/cgi-bin/form'; { Следующие переменные используются только для вебсервера: }. ProxyServer ='proxy.somewhere.com'; ProxyPort = 3128; // В заголовке post необходимы некоторые данные. HTTP_Data = 'Content-Type: application/x-www-form-urlencoded'#10+ 'User-Agent: Delphi/5.0 ()'#10+ { Отрекламируем Delphi 5! }. 'Host: somewhere.com'#10+ 'Connection: Keep-Alive'#10; Type. T...Form = class(TForm). ... Private. { Private declarations }. HTTP_POST : String; FContent : String; FResult : String; // Эта переменная будет содержать ответ сервера. Public. { Public declarations }. End; { Эти функции сделают некоторое url-кодирование }. { Например. 'John Smith' => 'John+Smith' }. Function HTTPTran(St : String) : String; Var i : Integer; Begin. Result:=''; For i:=1 to length(St) do. If St[i] in ['a'..'z','A'..'Z','0','1'..'9'] then. Result:=Result+St[i]. Else if St[i]=' ' then. Result:=Result+'+' Else. Result:=Result+'%'+IntToHex(Byte(St[i]),2); End; Procedure T...Form.ClientSocket1Write(Sender: TObject; Socket: TCustomWinSocket); Begin. // Постим данные. Socket.SendText(HTTP_POST+FContent); End; Procedure T...Form.ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket); Begin. // Получаем результат. FResult:=FResult+Socket.ReceiveText; End; Procedure T...Form.ClientSocket1Disconnect(Sender: TObject; Socket: TCustomWinSocket); Begin. // ЗДЕСЬ МОЖНО ОБРАБОТАТЬ FResult // End; Procedure T...Form.ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; Var ErrorCode: Integer); Begin. ErrorCode := 0; // Игнорируем ошибки. End; { А эта подпрограмма, которую можно использовать для постинга данных формы. } Procedure T...Form.PostTheForm; Begin. // Очищаем результаты. FResult:=''; // Вы можете ввести поля формы, которые необходимы. // Вот некоторые примеры: FContent:= 'Name='+ HTTPTran('John Smith') +'&'+ 'Address='+ HTTPTran('1 Waystreet') +'&'+ 'Email='+ HTTPTran('jsmith@somewhere.com') +'&'+ 'B1=Submit'+ #10; // Вычисляем длину содержимого. FContent:= 'Content-Length: '+IntToStr(Length(FContent))+#10+#10+FContent; {-- Начало прокси ---}. { если Вы используете прокси, то раскоментируйте этот код. ClientSocket1.Host := ProxyServer; ClientSocket1.Port := ProxyPort; HTTP_POST := 'POST http://'+WebServer+PostAddr+' HTTP/1.0'#10; {--- Конец прокси ---}. {--- Начало соединения напрямую --- }. { удалите этот код, еслы Вы будете использовать прокси }. ClientSocket1.Host := WebServer; ClientSocket1.Port := WebPort; HTTP_POST := 'POST '+PostAddr+' HTTP/1.0'#10; {--- Конец соединения напрямую ---}. // Соединяем заголовок. HTTP_Post := HTTP_Post + HTTP_Data; // Пытаемся открыть соединение. ClientSocket1.Open; End;

Использование компонента TServerSocket.

Автор: Brian Pedersen.

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

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

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

Давайте рассмотрим структуру работы данного компонента:

- Добавляем TServerSocket в Вашу основную форму.

- Устанавливаем свойство Servertype в stThreadBlocking.

- Создаём новый "unit" (показанный ниже) содержащий поток сервера.

Устанавливаем следующий код на OnSocketGetThread.

Code: Procedure TfrmMain.fSocketGetThread(Sender: TObject; ClientSocket: TServerClientWinSocket; Var SocketThread: TServerClientThread); Begin. // Здесь создаём объект TServerThread, который я привожу ниже. // Новый объект создаётся каждый раз, когда когда установлен канал связи. SocketThread := TServerThread.Create( FALSE, ClientSocket ); End;

Vfw.pas.

Code: {******************************************************************************* Original author unknown. Modified for Delphi 3/4 COM syntax by Tom Nuydens. (delphi3d@gamedeveloper.org). (www.gamedeveloper.org/delphi3d). *******************************************************************************} Unit VFW; Interface. Uses. Windows, MMSystem, Messages, CommDlg, ActiveX; {== General ==================================================================}. Type. PDWORD = ^DWORD; PLONG = PDWORD; UDWORD = DWORD; PVOID = Pointer; Int = Integer; {-- Returns version of VFW ---------------------------------------------------}. Function VideoForWindowsVersion: DWord; pascal; {-- Call these to start stop using VfW from your app -------------------------}. { TODO: Where are these functions? }. // function InitVFW: DWORD; stdcall; // function TermVFW: DWORD; stdcall; {-- Macros -------------------------------------------------------------------}. Function MKFOURCC(ch0, ch1, ch2, ch3: Char): FOURCC; {== COMPMAN - Installable Compression Manager ================================}. Const. ICVERSION = $0104 ; Type. HIC = THandle; // Handle to an Installable Compressor. // // this code in biCompression means the DIB must be accesed via. // 48 bit pointers! using *ONLY* the selector given. // Const. BI_1632 = $32333631; // '1632' Function mmioFOURCC(ch0, ch1, ch2, ch3: Char): FOURCC; Type. TWOCC = Word; Function aviTWOCC(ch0, ch1: Char): TWOCC; Const. ICTYPE_VIDEO = $63646976; // mmioFOURCC('v', 'i', 'd', 'c'). ICTYPE_AUDIO = $63647561; // mmioFOURCC('a', 'u', 'd', 'c'). Const. ICERR_OK = 0 ; ICERR_DONTDRAW = 1 ; ICERR_NEWPALETTE = 2 ; ICERR_GOTOKEYFRAME = 3 ; ICERR_STOPDRAWING = 4 ; ICERR_UNSUPPORTED = -1 ; ICERR_BADFORMAT = -2 ; ICERR_MEMORY = -3 ; ICERR_INTERNAL = -4 ; ICERR_BADFLAGS = -5 ; ICERR_BADPARAM = -6 ; ICERR_BADSIZE = -7 ; ICERR_BADHANDLE = -8 ; ICERR_CANTUPDATE = -9 ; ICERR_ABORT = -10 ; ICERR_ERROR = -100 ; ICERR_BADBITDEPTH = -200 ; ICERR_BADIMAGESIZE = -201 ; ICERR_CUSTOM = -400 ; // errors less than ICERR_CUSTOM... {-- Values for dwFlags of ICOpen() -------------------------------------------}. ICMODE_COMPRESS = 1 ; ICMODE_DECOMPRESS = 2 ; ICMODE_FASTDECOMPRESS = 3 ; ICMODE_QUERY = 4 ; ICMODE_FASTCOMPRESS = 5 ; ICMODE_DRAW = 8 ; {-- Flags for AVI file index -------------------------------------------------}. AVIIF_LIST = $00000001 ; AVIIF_TWOCC = $00000002 ; AVIIF_KEYFRAME = $00000010 ; {-- quality flags ------------------------------------------------------------}. ICQUALITY_LOW = 0 ; ICQUALITY_HIGH = 10000 ; ICQUALITY_DEFAULT = -1 ; {-----------------------------------------------------------------------------} ICM_USER = (DRV_USER+$0000) ; ICM_RESERVED_LOW = (DRV_USER+$1000) ; ICM_RESERVED_HIGH = (DRV_USER+$2000) ; ICM_RESERVED = ICM_RESERVED_LOW ; {-- Messages -----------------------------------------------------------------}. ICM_GETSTATE = (ICM_RESERVED+0) ; // Get compressor state. ICM_SETSTATE = (ICM_RESERVED+1) ; // Set compressor state. ICM_GETINFO = (ICM_RESERVED+2) ; // Query info about the compressor. ICM_CONFIGURE = (ICM_RESERVED+10); // show the configure dialog. ICM_ABOUT = (ICM_RESERVED+11); // show the about box. ICM_GETDEFAULTQUALITY = (ICM_RESERVED+30); // get the default value for quality. ICM_GETQUALITY = (ICM_RESERVED+31); // get the current value for quality. ICM_SETQUALITY = (ICM_RESERVED+32); // set the default value for quality. ICM_SET = (ICM_RESERVED+40); // Tell the driver something. ICM_GET = (ICM_RESERVED+41); // Ask the driver something. {-- Constants for ICM_SET: ---------------------------------------------------}. ICM_FRAMERATE = $526D7246; // mmioFOURCC('F','r','m','R'). ICM_KEYFRAMERATE = $5279654B; // mmioFOURCC('K','e','y','R'). {-- ICM specific messages ----------------------------------------------------}. ICM_COMPRESS_GET_FORMAT = (ICM_USER+4) ; // get compress format or size. ICM_COMPRESS_GET_SIZE = (ICM_USER+5) ; // get output size. ICM_COMPRESS_QUERY = (ICM_USER+6) ; // query support for compress. ICM_COMPRESS_BEGIN = (ICM_USER+7) ; // begin a series of compress calls. ICM_COMPRESS = (ICM_USER+8) ; // compress a frame. ICM_COMPRESS_END = (ICM_USER+9) ; // end of a series of compress calls. ICM_DECOMPRESS_GET_FORMAT = (ICM_USER+10) ; // get decompress format or size. ICM_DECOMPRESS_QUERY = (ICM_USER+11) ; // query support for dempress. ICM_DECOMPRESS_BEGIN = (ICM_USER+12) ; // start a series of decompress calls. ICM_DECOMPRESS = (ICM_USER+13) ; // decompress a frame. ICM_DECOMPRESS_END = (ICM_USER+14) ; // end a series of decompress calls. ICM_DECOMPRESS_SET_PALETTE = (ICM_USER+29) ; // fill in the DIB color table. ICM_DECOMPRESS_GET_PALETTE = (ICM_USER+30) ; // fill in the DIB color table. ICM_DRAW_QUERY = (ICM_USER+31) ; // query support for dempress. ICM_DRAW_BEGIN = (ICM_USER+15) ; // start a series of draw calls. ICM_DRAW_GET_PALETTE = (ICM_USER+16) ; // get the palette needed for drawing. ICM_DRAW_START = (ICM_USER+18) ; // start decompress clock. ICM_DRAW_STOP = (ICM_USER+19) ; // stop decompress clock. ICM_DRAW_END = (ICM_USER+21) ; // end a series of draw calls. ICM_DRAW_GETTIME = (ICM_USER+32) ; // get value of decompress clock. ICM_DRAW = (ICM_USER+33) ; // generalized "render" message. ICM_DRAW_WINDOW = (ICM_USER+34) ; // drawing window has moved or hidden. ICM_DRAW_SETTIME = (ICM_USER+35) ; // set correct value for decompress clock. ICM_DRAW_REALIZE = (ICM_USER+36) ; // realize palette for drawing. ICM_DRAW_FLUSH = (ICM_USER+37) ; // clear out buffered frames. ICM_DRAW_RENDERBUFFER = (ICM_USER+38) ; // draw undrawn things in queue. ICM_DRAW_START_PLAY = (ICM_USER+39) ; // start of a play. ICM_DRAW_STOP_PLAY = (ICM_USER+40) ; // end of a play. ICM_DRAW_SUGGESTFORMAT = (ICM_USER+50) ; // Like ICGetDisplayFormat. ICM_DRAW_CHANGEPALETTE = (ICM_USER+51) ; // for animating palette. ICM_GETBUFFERSWANTED = (ICM_USER+41) ; // ask about prebuffering. ICM_GETDEFAULTKEYFRAMERATE = (ICM_USER+42) ; // get the default value for key frames. ICM_DECOMPRESSEX_BEGIN = (ICM_USER+60) ; // start a series of decompress calls. ICM_DECOMPRESSEX_QUERY = (ICM_USER+61) ; // start a series of decompress calls. ICM_DECOMPRESSEX = (ICM_USER+62) ; // decompress a frame. ICM_DECOMPRESSEX_END = (ICM_USER+63) ; // end a series of decompress calls. ICM_COMPRESS_FRAMES_INFO = (ICM_USER+70) ; // tell about compress to come. ICM_SET_STATUS_PROC = (ICM_USER+72) ; // set status callback. {-----------------------------------------------------------------------------} Type. PICOPEN = ^TICOPEN; TICOPEN = record. DwSize : DWORD ; // sizeof(ICOPEN). FccType : DWORD ; // 'vidc' FccHandler : DWORD ; // DwVersion : DWORD ; // version of compman opening you. DwFlags : DWORD ; // LOWORD is type specific. DwError : DWORD ; // error return. PV1Reserved : PVOID ; // Reserved. PV2Reserved : PVOID ; // Reserved. DnDevNode : DWORD ; // Devnode for PnP devices. End; {-----------------------------------------------------------------------------} PICINFO = ^TICINFO ; TICINFO = record. DwSize : DWORD; // sizeof(ICINFO). FccType : DWORD; // compressor type 'vidc' 'audc' FccHandler : DWORD; // compressor sub-type 'rle ' 'jpeg' 'pcm ' DwFlags : DWORD; // flags LOWORD is type specific. DwVersion : DWORD; // version of the driver. DwVersionICM : DWORD; // version of the ICM used. // // under Win32, the driver always returns UNICODE strings. // SzName : array[0..15] of WideChar ; // short name. SzDescription : array[0..127] of WideChar ; // DWORD name. SzDriver : array[0..127] of WideChar ; // driver that contains compressor. End; {-- Flags for the <dwFlags> field of the <ICINFO> structure. -----------------}. Const. VIDCF_QUALITY = $0001 ; // supports quality. VIDCF_CRUNCH = $0002 ; // supports crunching to a frame size. VIDCF_TEMPORAL = $0004 ; // supports inter-frame compress. VIDCF_COMPRESSFRAMES = $0008 ; // wants the compress all frames message. VIDCF_DRAW = $0010 ; // supports drawing. VIDCF_FASTTEMPORALC = $0020 ; // does not need prev frame on compress. VIDCF_FASTTEMPORALD = $0080 ; // does not need prev frame on decompress. //VIDCF_QUALITYTIME = $0040 ; // supports temporal quality. //VIDCF_FASTTEMPORAL = (VIDCF_FASTTEMPORALC or VIDCF_FASTTEMPORALD). {-----------------------------------------------------------------------------} ICCOMPRESS_KEYFRAME = $00000001; Type. PICCOMPRESS = ^TICCOMPRESS; TICCOMPRESS = record. DwFlags : DWORD; // flags. LpbiOutput : PBITMAPINFOHEADER ; // output format. LpOutput : PVOID ; // output data. LpbiInput : PBITMAPINFOHEADER ; // format of frame to compress. LpInput : PVOID ; // frame data to compress. Lpckid : PDWORD ; // ckid for data in AVI file. LpdwFlags : PDWORD; // flags in the AVI index. LFrameNum : DWORD ; // frame number of seq. DwFrameSize : DWORD ; // reqested size in bytes. (if non zero). DwQuality : DWORD ; // quality. // these are new fields. LpbiPrev : PBITMAPINFOHEADER ; // format of previous frame. LpPrev : PVOID ; // previous frame. End; {-----------------------------------------------------------------------------} Const. ICCOMPRESSFRAMES_PADDING = $00000001 ; Type. TICCompressProc = function(lInput: LPARAM; lFrame: DWORD; lpBits: PVOID; len: DWORD): DWORD; stdcall; PICCOMPRESSFRAMES = ^TICCOMPRESSFRAMES; TICCOMPRESSFRAMES = record. DwFlags : DWORD ; // flags. LpbiOutput : PBITMAPINFOHEADER ; // output format. LOutput : LPARAM ; // output identifier. LpbiInput : PBITMAPINFOHEADER ; // format of frame to compress. LInput : LPARAM ; // input identifier. LStartFrame : DWORD ; // start frame. LFrameCount : DWORD ; // # of frames. LQuality : DWORD ; // quality. LDataRate : DWORD ; // data rate. LKeyRate : DWORD ; // key frame rate. DwRate : DWORD ; // frame rate, as always. DwScale : DWORD ; DwOverheadPerFrame : DWORD ; DwReserved2 : DWORD ; GetData : TICCompressProc; PutData : TICCompressProc; End; {-- Messages for Status callback ---------------------------------------------}. Const. ICSTATUS_START = 0 ; ICSTATUS_STATUS = 1 ; // l = % done. ICSTATUS_END = 2 ; ICSTATUS_ERROR = 3 ; // l = error string (LPSTR). ICSTATUS_YIELD = 4 ; Type. // return nonzero means abort operation in progress. TICStatusProc = function(lParam: LPARAM; message: UINT; l: DWORD): DWORD; stdcall; PICSETSTATUSPROC = ^TICSETSTATUSPROC; TICSETSTATUSPROC = record. DwFlags : DWORD ; LParam : LPARAM ; Status : TICStatusProc; End; {-----------------------------------------------------------------------------} Const. ICDECOMPRESS_HURRYUP = $80000000 ; // don't draw just buffer (hurry up!). ICDECOMPRESS_UPDATE = $40000000 ; // don't draw just update screen. ICDECOMPRESS_PREROLL = $20000000 ; // this frame is before real start. ICDECOMPRESS_NULLFRAME = $10000000 ; // repeat last frame. ICDECOMPRESS_NOTKEYFRAME = $08000000 ; // this frame is not a key frame. Type. PICDECOMPRESS = ^TICDECOMPRESS; TICDECOMPRESS = record. DwFlags : DWORD ; // flags (from AVI index...). LpbiInput : PBITMAPINFOHEADER ; // BITMAPINFO of compressed data. // biSizeImage has the chunk size. LpInput : PVOID ; // compressed data. LpbiOutput : PBITMAPINFOHEADER ; // DIB to decompress to. LpOutput : PVOID ; Ckid : DWORD ; // ckid from AVI file. End; PICDECOMPRESSEX = ^TICDECOMPRESSEX; TICDECOMPRESSEX = record. // // same as ICM_DECOMPRESS. // DwFlags : DWORD; LpbiSrc : PBITMAPINFOHEADER; // BITMAPINFO of compressed data. LpSrc : PVOID; // compressed data. LpbiDst : PBITMAPINFOHEADER; // DIB to decompress to. LpDst : PVOID; // output data. // // new for ICM_DECOMPRESSEX. // XDst : int ; // destination rectangle. YDst : int ; DxDst : int ; DyDst : int ; XSrc : int ; // source rectangle. YSrc : int ; DxSrc : int ; DySrc : int ; End; {-----------------------------------------------------------------------------} Const. ICDRAW_QUERY = $00000001 ; // test for support. ICDRAW_FULLSCREEN = $00000002 ; // draw to full screen. ICDRAW_HDC = $00000004 ; // draw to a HDC/HWND. ICDRAW_ANIMATE = $00000008 ; // expect palette animation. ICDRAW_CONTINUE = $00000010 ; // draw is a continuation of previous draw. ICDRAW_MEMORYDC = $00000020 ; // DC is offscreen, by the way. ICDRAW_UPDATING = $00000040 ; // We're updating, as opposed to playing. ICDRAW_RENDER = $00000080 ; // used to render data not draw it. ICDRAW_BUFFER = $00000100 ; // please buffer this data offscreen, we will need to update it. Type. PICDRAWBEGIN = ^TICDRAWBEGIN; TICDRAWBEGIN = record. DwFlags : DWORD ; // flags. Hpal : HPALETTE ; // palette to draw with. Hwnd : HWND ; // window to draw to. Hdc : HDC ; // HDC to draw to. XDst : int ; // destination rectangle. YDst : int ; DxDst : int ; DyDst : int ; Lpbi : PBITMAPINFOHEADER ; // format of frame to draw. XSrc : int ; // source rectangle. YSrc : int ; DxSrc : int ; DySrc : int ; DwRate : DWORD ; // frames/second = (dwRate/dwScale). DwScale : DWORD ; End; {-----------------------------------------------------------------------------} Const. ICDRAW_HURRYUP = $80000000 ; // don't draw just buffer (hurry up!). ICDRAW_UPDATE = $40000000 ; // don't draw just update screen. ICDRAW_PREROLL = $20000000 ; // this frame is before real start. ICDRAW_NULLFRAME = $10000000 ; // repeat last frame. ICDRAW_NOTKEYFRAME = $08000000 ; // this frame is not a key frame. Type. PICDRAW = ^TICDRAW; TICDRAW = record. DwFlags : DWORD ; // flags. LpFormat : PVOID ; // format of frame to decompress. LpData : PVOID ; // frame data to decompress. CbData : DWORD ; LTime : DWORD ; // time in drawbegin units (see dwRate and dwScale). End; PICDRAWSUGGEST = ^TICDRAWSUGGEST; TICDRAWSUGGEST = record. LpbiIn : PBITMAPINFOHEADER ; // format to be drawn. LpbiSuggest : PBITMAPINFOHEADER ; // location for suggested format (or NULL to get size). DxSrc : int ; // source extent or 0. DySrc : int ; DxDst : int ; // dest extent or 0. DyDst : int ; HicDecompressor : HIC ; // decompressor you can talk to. End; {-----------------------------------------------------------------------------} PICPALETTE = ^TICPALETTE; TICPALETTE = record. DwFlags : DWORD ; // flags (from AVI index...). IStart : int ; // first palette to change. ILen : int ; // count of entries to change. Lppe : PPALETTEENTRY ; // palette. End; {-- ICM function declarations ------------------------------------------------}. Function ICInfo(fccType, fccHandler: DWORD; lpicinfo: PICINFO) : BOOL ; stdcall ; Function ICInstall(fccType, fccHandler: DWORD; lParam: LPARAM; szDesc: LPSTR; wFlags: UINT) : BOOL ; stdcall ; Function ICRemove(fccType, fccHandler: DWORD; wFlags: UINT) : BOOL ; stdcall ; Function ICGetInfo(hic: HIC; picinfo: PICINFO; cb: DWORD) : DWORD ; stdcall ; Function ICOpen(fccType, fccHandler: DWORD; wMode: UINT) : HIC ; stdcall ; Function ICOpenFunction(fccType, fccHandler: DWORD; wMode: UINT; lpfnHandler: TFarProc) : HIC ; stdcall ; Function ICClose(hic: HIC) : DWORD; stdcall ; Function ICSendMessage(hic: HIC; msg: UINT; dw1, dw2: DWORD) : DWORD ; stdcall ; {-- Values for wFlags of ICInstall -------------------------------------------}. Const. ICINSTALL_UNICODE = $8000 ; ICINSTALL_FUNCTION = $0001 ; // lParam is a DriverProc (function ptr). ICINSTALL_DRIVER = $0002 ; // lParam is a driver name (string). ICINSTALL_HDRV = $0004 ; // lParam is a HDRVR (driver handle). ICINSTALL_DRIVERW = $8002 ; // lParam is a unicode driver name. {-- Query macros -------------------------------------------------------------}. ICMF_CONFIGURE_QUERY = $00000001 ; ICMF_ABOUT_QUERY = $00000001 ; Function ICQueryAbout(hic: HIC): BOOL; Function ICAbout(hic: HIC; hwnd: HWND): DWORD; Function ICQueryConfigure(hic: HIC): BOOL; Function ICConfigure(hic: HIC; hwnd: HWND): DWORD; {-- Get/Set state macros -----------------------------------------------------}. Function ICGetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD; Function ICSetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD; Function ICGetStateSize(hic: HIC): DWORD; {-- Get value macros ---------------------------------------------------------}. Function ICGetDefaultQuality(hic: HIC): DWORD; Function ICGetDefaultKeyFrameRate(hic: HIC): DWORD; {-- Draw window macro --------------------------------------------------------}. Function ICDrawWindow(hic: HIC; prc: PRECT): DWORD; {== Compression functions ====================================================}. {-- ICCompress() - compress a single frame -----------------------------------}. Function ICCompress( Hic : HIC; DwFlags : DWORD; // flags. LpbiOutput : PBITMAPINFOHEADER; // output format. LpData : PVOID; // output data. LpbiInput : PBITMAPINFOHEADER; // format of frame to compress. LpBits : PVOID; // frame data to compress. Lpckid : PDWORD; // ckid for data in AVI file. LpdwFlags : PDWORD; // flags in the AVI index. LFrameNum : DWORD; // frame number of seq. DwFrameSize : DWORD; // reqested size in bytes. (if non zero). DwQuality : DWORD; // quality within one frame. LpbiPrev : PBITMAPINFOHEADER; // format of previous frame. LpPrev : PVOID // previous frame. ) : DWORD; cdecl; {-- ICCompressBegin() - start compression from a source fmt to a dest fmt ----}. Function ICCompressBegin(hic: HIC; lpbiInput: PBITMAPINFOHEADER; lpbiOutput: PBITMAPINFOHEADER): DWORD; {-- ICCompressQuery() - determines if compression from src to dst is supp ----}. Function ICCompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; {-- ICCompressGetFormat() - get the output format (fmt of compressed) --------}. // if lpbiOutput is nil return the size in bytes needed for format. Function ICCompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Function ICCompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD; {-- ICCompressSize() - return the maximal size of a compressed frame ---------}. Function ICCompressGetSize(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Function ICCompressEnd(hic: HIC): DWORD; {== Decompression functions ==================================================}. {-- ICDecompress() - decompress a single frame -------------------------------}. Function ICDecompress( Hic : HIC; DwFlags : DWORD; // flags (from AVI index...). LpbiFormat : PBITMAPINFOHEADER; // BITMAPINFO of compressed data. // biSizeImage has the chunk size. LpData : PVOID; // data. Lpbi : PBITMAPINFOHEADER; // DIB to decompress to. LpBits : PVOID. ): DWORD; cdecl; {-- ICDecompressBegin() - start compression from src fmt to a dest fmt -------}. Function ICDecompressBegin(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; {-- ICDecompressQuery() - determines if compression is supported -------------}. Function ICDecompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; {-- ICDecompressGetFormat - get the output fmt (fmt of uncompressed data) ----}. // if lpbiOutput is NULL return the size in bytes needed for format. Function ICDecompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Function ICDecompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD; {-- ICDecompressGetPalette() - get the output palette ------------------------}. Function ICDecompressGetPalette(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Function ICDecompressSetPalette(hic: HIC; lpbiPalette: PBITMAPINFOHEADER): DWORD; Function ICDecompressEnd(hic: HIC): DWORD; {== Decompression(ex) functions ==============================================}. // // on Win16 these functions are macros that call ICMessage. ICMessage will. // not work on NT. rather than add new entrypoints we have given. // them as static inline functions. // {-- ICDecompressEx() - decompress a single frame -----------------------------}. Function ICDecompressEx( Hic : HIC; DwFlags : DWORD; LpbiSrc : PBITMAPINFOHEADER; LpSrc : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; LpbiDst : PBITMAPINFOHEADER; LpDst : PVOID; XDst : int; YDst : int; DxDst : int; DyDst : int. ): DWORD; stdcall; {-- ICDecompressExBegin() - start compression from a src fmt to a dest fmt ---}. Function ICDecompressExBegin( Hic : HIC; DwFlags : DWORD; LpbiSrc : PBITMAPINFOHEADER; LpSrc : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; LpbiDst : PBITMAPINFOHEADER; LpDst : PVOID; XDst : int; YDst : int; DxDst : int; DyDst : int. ): DWORD; stdcall; {-- ICDecompressExQuery() ----------------------------------------------------}. Function ICDecompressExQuery( Hic : HIC; DwFlags : DWORD; LpbiSrc : PBITMAPINFOHEADER; LpSrc : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; LpbiDst : PBITMAPINFOHEADER; LpDst : PVOID; XDst : int; YDst : int; DxDst : int; DyDst : int. ): DWORD; stdcall; Function ICDecompressExEnd(hic: HIC): DWORD; {== Drawing functions ========================================================}. {-- ICDrawBegin() - start decompressing data with fmt directly to screen -----}. // return zero if the decompressor supports drawing. Function ICDrawBegin( Hic : HIC; DwFlags : DWORD; // flags. Hpal : HPALETTE; // palette to draw with. Hwnd : HWND; // window to draw to. Hdc : HDC; // HDC to draw to. XDst : int; // destination rectangle. YDst : int; DxDst : int; DyDst : int; Lpbi : PBITMAPINFOHEADER; // format of frame to draw. XSrc : int; // source rectangle. YSrc : int; DxSrc : int; DySrc : int; DwRate : DWORD; // frames/second = (dwRate/dwScale). DwScale : DWORD. ): DWORD; cdecl; {-- ICDraw() - decompress data directly to the screen ------------------------}. Function ICDraw( Hic : HIC; DwFlags : DWORD; // flags. LpFormat : PVOID; // format of frame to decompress. LpData : PVOID; // frame data to decompress. CbData : DWORD; // size of data. LTime : DWORD // time to draw this frame. ): DWORD; cdecl; // ICMessage is not supported on Win32, so provide a static inline function. // to do the same job. Function ICDrawSuggestFormat( Hic : HIC; LpbiIn : PBITMAPINFOHEADER; LpbiOut : PBITMAPINFOHEADER; DxSrc : int; DySrc : int; DxDst : int; DyDst : int; HicDecomp : HIC. ): DWORD; stdcall; {-- ICDrawQuery() - determines if the compressor is willing to render fmt ----}. Function ICDrawQuery(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD; Function ICDrawChangePalette(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD; Function ICGetBuffersWanted(hic: HIC; lpdwBuffers: PDWORD): DWORD; Function ICDrawEnd(hic: HIC): DWORD; Function ICDrawStart(hic: HIC): DWORD; Function ICDrawStartPlay(hic: HIC; lFrom, lTo: DWORD): DWORD; Function ICDrawStop(hic: HIC): DWORD; Function ICDrawStopPlay(hic: HIC): DWORD; Function ICDrawGetTime(hic: HIC; lplTime: PDWORD): DWORD; Function ICDrawSetTime(hic: HIC; lTime: DWORD): DWORD; Function ICDrawRealize(hic: HIC; hdc: HDC; fBackground: BOOL): DWORD; Function ICDrawFlush(hic: HIC): DWORD; Function ICDrawRenderBuffer(hic: HIC): DWORD; {== Status callback functions ================================================}. {-- ICSetStatusProc() - Set the status callback function ---------------------}. // ICMessage is not supported on NT. Function ICSetStatusProc( Hic : HIC; DwFlags : DWORD; LParam : DWORD; FpfnStatus : TICStatusProc. ): DWORD; stdcall; {== Helper routines for DrawDib and MCIAVI... ================================}. Function ICLocate(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER; wFlags: WORD): HIC; stdcall; Function ICGetDisplayFormat(hic: HIC; lpbiIn, lpbiOut: PBITMAPINFOHEADER; BitDepth: int; dx, dy: int): HIC; stdcall; Function ICDecompressOpen(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER): HIC; Function ICDrawOpen(fccType, fccHandler: DWORD; lpbiIn: PBITMAPINFOHEADER): HIC; {== Higher level functions ===================================================}. Function ICImageCompress( Hic : HIC; // compressor to use. UiFlags : UINT; // flags (none yet). LpbiIn : PBITMAPINFO; // format to compress from. LpBits : PVOID; // data to compress. LpbiOut : PBITMAPINFO; // compress to this (NULL ==> default). LQuality : DWORD; // quality to use. PlSize : PDWORD // compress to this size (0=whatever). ): THANDLE; stdcall; Function ICImageDecompress( Hic : HIC; // compressor to use. UiFlags : UINT; // flags (none yet). LpbiIn : PBITMAPINFO; // format to decompress from. LpBits : PVOID; // data to decompress. LpbiOut : PBITMAPINFO // decompress to this (NULL ==> default). ): THANDLE; stdcall; {-- TCompVars ----------------------------------------------------------------}. // // Structure used by ICSeqCompressFrame and ICCompressorChoose routines. // Make sure this matches the autodoc in icm.c! // Type. PCOMPVARS = ^TCOMPVARS; TCOMPVARS = record. CbSize : DWORD; // set to sizeof(COMPVARS) before. // calling ICCompressorChoose. DwFlags : DWORD; // see below... Hic : HIC; // HIC of chosen compressor. FccType : DWORD; // basically ICTYPE_VIDEO. FccHandler : DWORD; // handler of chosen compressor or. // "" or "DIB ". LpbiIn : PBITMAPINFO; // input format. LpbiOut : PBITMAPINFO; // output format - will compress to this. LpBitsOut : PVOID; LpBitsPrev : PVOID; LFrame : DWORD; LKey : DWORD; // key frames how often? LDataRate : DWORD; // desired data rate KB/Sec. LQ : DWORD; // desired quality. LKeyCount : DWORD; LpState : PVOID; // state of compressor. CbState : DWORD; // size of the state. End; // FLAGS for dwFlags element of COMPVARS structure: // set this flag if you initialize COMPVARS before calling ICCompressorChoose. Const. ICMF_COMPVARS_VALID = $00000001; // COMPVARS contains valid data. {-- ICCompressorChoose() - allows user to choose compressor, quality etc... --}. Function ICCompressorChoose( Hwnd : HWND; // parent window for dialog. UiFlags : UINT; // flags. PvIn : PVOID; // input format (optional). LpData : PVOID; // input data (optional). Pc : PCOMPVARS; // data about the compressor/dlg. LpszTitle : LPSTR // dialog title (optional). ): BOOL; stdcall; // defines for uiFlags. Const. ICMF_CHOOSE_KEYFRAME = $0001; // show KeyFrame Every box. ICMF_CHOOSE_DATARATE = $0002; // show DataRate box. ICMF_CHOOSE_PREVIEW = $0004; // allow expanded preview dialog. ICMF_CHOOSE_ALLCOMPRESSORS = $0008; // don't only show those that. // can handle the input format. // or input data. Function ICSeqCompressFrameStart(pc: PCOMPVARS; lpbiIn: PBITMAPINFO): BOOL; stdcall; Procedure ICSeqCompressFrameEnd(pc: PCOMPVARS); stdcall; Function ICSeqCompressFrame( Pc : PCOMPVARS; // set by ICCompressorChoose. UiFlags : UINT; // flags. LpBits : PVOID; // input DIB bits. PfKey : PBOOL; // did it end up being a key frame? PlSize : PDWORD // size to compress to/of returned image. ): PVOID; stdcall; Procedure ICCompressorFree(pc: PCOMPVARS); stdcall; {== DRAWDIB - Routines for drawing to the display ============================}. Type. HDRAWDIB = THandle; // hdd. {== DrawDib Flags ============================================================}. Const. DDF_UPDATE = $0002; // re-draw the last DIB. DDF_SAME_HDC = $0004; // HDC same as last call (all setup). DDF_SAME_DRAW = $0008; // draw params are the same. DDF_DONTDRAW = $0010; // dont draw frame, just decompress. DDF_ANIMATE = $0020; // allow palette animation. DDF_BUFFER = $0040; // always buffer image. DDF_JUSTDRAWIT = $0080; // just draw it with GDI. DDF_FULLSCREEN = $0100; // use DisplayDib. DDF_BACKGROUNDPAL = $0200; // Realize palette in background. DDF_NOTKEYFRAME = $0400; // this is a partial frame update, hint. DDF_HURRYUP = $0800; // hurry up please! DDF_HALFTONE = $1000; // always halftone. DDF_PREROLL = DDF_DONTDRAW; // Builing up a non-keyframe. DDF_SAME_DIB = DDF_SAME_DRAW; DDF_SAME_SIZE = DDF_SAME_DRAW; {== DrawDib functions ========================================================}. {-- DrawDibOpen() ------------------------------------------------------------}. Function DrawDibOpen: HDRAWDIB; stdcall; {-- DrawDibClose() -----------------------------------------------------------}. Function DrawDibClose(hdd: HDRAWDIB): BOOL; stdcall; {-- DrawDibGetBuffer() -------------------------------------------------------}. Function DrawDibGetBuffer(hdd: HDRAWDIB; lpbi: PBITMAPINFOHEADER; dwSize: DWORD; dwFlags: DWORD): PVOID; stdcall; {-- DrawDibGetPalette() - get the palette used for drawing DIBs --------------}. Function DrawDibGetPalette(hdd: HDRAWDIB): HPALETTE; stdcall; {-- DrawDibSetPalette() - set the palette used for drawing DIBs --------------}. Function DrawDibSetPalette(hdd: HDRAWDIB; hpal: HPALETTE): BOOL; stdcall; {-- DrawDibChangePalette() ---------------------------------------------------}. Function DrawDibChangePalette(hdd: HDRAWDIB; iStart, iLen: int; lppe: PPALETTEENTRY): BOOL; stdcall; {-- DrawDibRealize() - realize the palette in a HDD --------------------------}. Function DrawDibRealize(hdd: HDRAWDIB; hdc: HDC; fBackground: BOOL): UINT; stdcall; {-- DrawDibStart() - start of streaming playback -----------------------------}. Function DrawDibStart(hdd: HDRAWDIB; rate: DWORD): BOOL; stdcall; {-- DrawDibStop() - start of streaming playback ------------------------------}. Function DrawDibStop(hdd: HDRAWDIB): BOOL; stdcall; {-- DrawDibBegin() - prepare to draw -----------------------------------------}. Function DrawDibBegin( Hdd : HDRAWDIB; Hdc : HDC; DxDst : int; DyDst : int; Lpbi : PBITMAPINFOHEADER; DxSrc : int; DySrc : int; WFlags : UINT. ): BOOL; stdcall; {-- DrawDibDraw() - actually draw a DIB to the screen ------------------------}. Function DrawDibDraw( Hdd : HDRAWDIB; Hdc : HDC; XDst : int; YDst : int; DxDst : int; DyDst : int; Lpbi : PBITMAPINFOHEADER; LpBits : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; WFlags : UINT. ): BOOL; stdcall; {-- DrawDibUpdate() - redraw last image (may only be valid with DDF_BUFFER) --}. Function DrawDibUpdate(hdd: HDRAWDIB; hdc: HDC; x, y: int): BOOL; {-- DrawDibEnd() -------------------------------------------------------------}. Function DrawDibEnd(hdd: HDRAWDIB): BOOL; stdcall; {-- DrawDibTime() - for debugging purposes only ------------------------------}. Type. PDRAWDIBTIME = ^TDRAWDIBTIME; TDRAWDIBTIME = record. TimeCount : DWORD; TimeDraw : DWORD; TimeDecompress : DWORD; TimeDither : DWORD; TimeStretch : DWORD; TimeBlt : DWORD; TimeSetDIBits : DWORD; End; Function DrawDibTime(hdd: HDRAWDIB; lpddtime: PDRAWDIBTIME): BOOL; stdcall; {-- Display profiling --------------------------------------------------------}. Const. PD_CAN_DRAW_DIB = $0001; // if you can draw at all. PD_CAN_STRETCHDIB = $0002; // basicly RC_STRETCHDIB. PD_STRETCHDIB_1_1_OK = $0004; // is it fast? PD_STRETCHDIB_1_2_OK = $0008; // ... PD_STRETCHDIB_1_N_OK = $0010; // ... Function DrawDibProfileDisplay(lpbi: PBITMAPINFOHEADER): DWORD; stdcall; {== AVIFMT - AVI file format definitions =====================================}. // // The following is a short description of the AVI file format. Please. // see the accompanying documentation for a full explanation. // // An AVI file is the following RIFF form: // // RIFF('AVI' // LIST('hdrl' // avih(<MainAVIHeader>). // LIST ('strl' // strh(<Stream header>). // strf(<Stream format>). // ... additional header data. // LIST('movi' // { LIST('rec' // SubChunk... // ). // | SubChunk } .... // ). // [ <AVIIndex> ]. // ). // // The main file header specifies how many streams are present. For. // each one, there must be a stream header chunk and a stream format. // chunk, enlosed in a 'strl' LIST chunk. The 'strf' chunk contains. // type-specific format information; for a video stream, this should. // be a BITMAPINFO structure, including palette. For an audio stream, // this should be a WAVEFORMAT (or PCMWAVEFORMAT) structure. // // The actual data is contained in subchunks within the 'movi' LIST. // chunk. The first two characters of each data chunk are the. // stream number with which that data is associated. // // Some defined chunk types: // Video Streams: // ##db: RGB DIB bits. // ##dc: RLE8 compressed DIB bits. // ##pc: Palette Change. // // Audio Streams: // ##wb: waveform audio bytes. // // The grouping into LIST 'rec' chunks implies only that the contents of. // the chunk should be read into memory at the same time. This. // grouping is used for files specifically intended to be played from. // CD-ROM. // // The index chunk at the end of the file should contain one entry for. // each data chunk in the file. // // Limitations for the current software: // Only one video stream and one audio stream are allowed. // The streams must start at the beginning of the file. // // // To register codec types please obtain a copy of the Multimedia. // Developer Registration Kit from: // // Microsoft Corporation. // Multimedia Systems Group. // Product Marketing. // One Microsoft Way. // Redmond, WA 98052-6399. // {-- form types, list types and chunk types -----------------------------------}. Const. FormtypeAVI = $20495641; // mmioFOURCC('A', 'V', 'I', ' '). ListtypeAVIHEADER = $6C726468; // mmioFOURCC('h', 'd', 'r', 'l'). CkidAVIMAINHDR = $68697661; // mmioFOURCC('a', 'v', 'i', 'h'). ListtypeSTREAMHEADER = $6C727473; // mmioFOURCC('s', 't', 'r', 'l'). CkidSTREAMHEADER = $68727473; // mmioFOURCC('s', 't', 'r', 'h'). CkidSTREAMFORMAT = $66727473; // mmioFOURCC('s', 't', 'r', 'f'). CkidSTREAMHANDLERDATA = $64727473; // mmioFOURCC('s', 't', 'r', 'd'). CkidSTREAMNAME = $6E727473; // mmioFOURCC('s', 't', 'r', 'n'). ListtypeAVIMOVIE = $69766F6D; // mmioFOURCC('m', 'o', 'v', 'i'). ListtypeAVIRECORD = $20636572; // mmioFOURCC('r', 'e', 'c', ' '). CkidAVINEWINDEX = $31786469; // mmioFOURCC('i', 'd', 'x', '1'). {-- Stream types for the <fccType> field of the stream header ----------------}. StreamtypeVIDEO = $73646976; // mmioFOURCC('v', 'i', 'd', 's'). StreamtypeAUDIO = $73647561; // mmioFOURCC('a', 'u', 'd', 's'). StreamtypeMIDI = $7364696D; // mmioFOURCC('m', 'i', 'd', 's'). StreamtypeTEXT = $73747874; // mmioFOURCC('t', 'x', 't', 's'). {-- Basic chunk types --------------------------------------------------------}. CktypeDIBbits = $6264; // aviTWOCC('d', 'b'). CktypeDIBcompressed = $6364; // aviTWOCC('d', 'c'). CktypePALchange = $6370; // aviTWOCC('p', 'c'). CktypeWAVEbytes = $6277; // aviTWOCC('w', 'b'). {-- Chunk id to use for extra chunks for padding -----------------------------}. CkidAVIPADDING = $4B4E554A; // mmioFOURCC('J', 'U', 'N', 'K'). {== Useful macros ============================================================}. {-- Macro to get stream number out of a FOURCC ckid --------------------------}. Function FromHex(n: BYTE): BYTE; Function StreamFromFOURCC(fcc: DWORD): BYTE; {-- Macro to get TWOCC chunk type out of a FOURCC ckid -----------------------}. Function TWOCCFromFOURCC(fcc: DWORD): WORD; {-- Macro to make a ckid for a chunk out of a TWOCC and a stream num (0-255) -}. Function ToHex(n: BYTE): BYTE; Function MAKEAVICKID(tcc: WORD; stream: BYTE): DWORD; {-- Main AVI file header -----------------------------------------------------}. {-- flags for use in <dwFlags> in AVIFileHdr ---------------------------------}. Const. AVIF_HASINDEX = $00000010; // Index at end of file? AVIF_MUSTUSEINDEX = $00000020; AVIF_ISINTERLEAVED = $00000100; AVIF_TRUSTCKTYPE = $00000800; // Use CKType to find key frames? AVIF_WASCAPTUREFILE = $00010000; AVIF_COPYRIGHTED = $00020000; {-- The AVI File Header LIST chunk should be padded to this size -------------}. Const. AVI_HEADERSIZE = 2048; // size of AVI header list. Type. PMainAVIHeader = ^TMainAVIHeader; TMainAVIHeader = record. DwMicroSecPerFrame : DWORD; // frame display rate (or 0L). DwMaxBytesPerSec : DWORD; // max. transfer rate. DwPaddingGranularity : DWORD; // pad to multiples of this. // size; normally 2K. DwFlags : DWORD; // the ever-present flags. DwTotalFrames : DWORD; // # frames in file. DwInitialFrames : DWORD; DwStreams : DWORD; DwSuggestedBufferSize : DWORD; DwWidth : DWORD; DwHeight : DWORD; DwReserved : array[0..3] of DWORD; End; {-- Stream header ------------------------------------------------------------}. Const. AVISF_DISABLED = $00000001; AVISF_VIDEO_PALCHANGES = $00010000; Type. PAVIStreamHeader = ^TAVIStreamHeader; TAVIStreamHeader = record. FccType : FOURCC; FccHandler : FOURCC; DwFlags : DWORD; // Contains AVITF_* flags. WPriority : WORD; WLanguage : WORD; DwInitialFrames : DWORD; DwScale : DWORD; DwRate : DWORD; // dwRate / dwScale == samples/second. DwStart : DWORD; DwLength : DWORD; // In units above... DwSuggestedBufferSize : DWORD; DwQuality : DWORD; DwSampleSize : DWORD; RcFrame : TRECT; End; {-- Flags for index ----------------------------------------------------------}. Const. AVIIF_NOTIME = $00000100; // this frame doesn't take any time. AVIIF_COMPUSE = $0FFF0000; // these bits are for compressor use. Type. PAVIINDEXENTRY = ^TAVIINDEXENTRY; TAVIINDEXENTRY = record. Ckid : DWORD; DwFlags : DWORD; DwChunkOffset : DWORD; // Position of chunk. DwChunkLength : DWORD; // Length of chunk. End; {-- Palette change chunk (used in video streams) -----------------------------}. PAVIPALCHANGE = ^TAVIPALCHANGE; TAVIPALCHANGE = record. BFirstEntry : BYTE; // first entry to change. BNumEntries : BYTE; // # entries to change (0 if 256). WFlags : WORD; // Mostly to preserve alignment... // peNew : array[0..-1] of PALETTEENTRY ; // New color specifications. End; {== AVIFile - routines for reading/writing standard AVI files ================}. // // Ansi - Unicode thunking. // // Unicode or Ansi-only apps can call the avifile APIs. // any Win32 app who wants to use. // any of the AVI COM interfaces must be UNICODE - the AVISTREAMINFO and. // AVIFILEINFO structures used in the Info methods of these interfaces are. // the unicode variants, and no thunking to or from ansi takes place. // except in the AVIFILE api entrypoints. // // For Ansi/Unicode thunking: for each entrypoint or structure that. // uses chars or strings, two versions are declared in the Win32 version, // ApiNameW and ApiNameA. The default name ApiName is #defined to one or. // other of these depending on whether UNICODE is defined (during. // compilation of the app that is including this header). The source will. // contain ApiName and ApiNameA (with ApiName being the Win16 implementation, // and also #defined to ApiNameW, and ApiNameA being the thunk entrypoint). // // For GetFrame::SetFormat - use the best format for the display. Const. AVIGETFRAMEF_BESTDISPLAYFMT = 1; // // Structures used by AVIStreamInfo & AVIFileInfo. // // These are related to, but not identical to, the header chunks. // in an AVI file. // {-- AVISTREAMINFO ------------------------------------------------------------}. // for Unicode/Ansi thunking we need to declare three versions of this! Type. PAVISTREAMINFOW = ^TAVISTREAMINFOW; TAVISTREAMINFOW = record. FccType : DWORD; FccHandler : DWORD; DwFlags : DWORD; // Contains AVITF_* flags. DwCaps : DWORD; WPriority : WORD; WLanguage : WORD; DwScale : DWORD; DwRate : DWORD; // dwRate / dwScale == samples/second. DwStart : DWORD; DwLength : DWORD; // In units above... DwInitialFrames : DWORD; DwSuggestedBufferSize : DWORD; DwQuality : DWORD; DwSampleSize : DWORD; RcFrame : TRECT ; DwEditCount : DWORD; DwFormatChangeCount : DWORD; SzName : array[0..63] of WideChar; End; PAVISTREAMINFOA = ^TAVISTREAMINFOA; TAVISTREAMINFOA = record. FccType : DWORD; FccHandler : DWORD; DwFlags : DWORD; // Contains AVITF_* flags. DwCaps : DWORD; WPriority : WORD; WLanguage : WORD; DwScale : DWORD; DwRate : DWORD; // dwRate / dwScale == samples/second. DwStart : DWORD; DwLength : DWORD; // In units above... DwInitialFrames : DWORD; DwSuggestedBufferSize : DWORD; DwQuality : DWORD; DwSampleSize : DWORD; RcFrame : TRECT ; DwEditCount : DWORD; DwFormatChangeCount : DWORD; SzName : array[0..63] of AnsiChar; End; TAVISTREAMINFO = TAVISTREAMINFOA; PAVISTREAMINFO = PAVISTREAMINFOA; Const. AVISTREAMINFO_DISABLED = $00000001; AVISTREAMINFO_FORMATCHANGES = $00010000; {-- AVIFILEINFO --------------------------------------------------------------}. Type. PAVIFILEINFOW = ^TAVIFILEINFOW; TAVIFILEINFOW = record. DwMaxBytesPerSec : DWORD; // max. transfer rate. DwFlags : DWORD; // the ever-present flags. DwCaps : DWORD; DwStreams : DWORD; DwSuggestedBufferSize : DWORD; DwWidth : DWORD; DwHeight : DWORD; DwScale : DWORD; DwRate : DWORD; // dwRate / dwScale == samples/second. DwLength : DWORD; DwEditCount : DWORD; SzFileType : array[0..63] of WideChar; // descriptive string for file type? End; PAVIFILEINFOA = ^TAVIFILEINFOA; TAVIFILEINFOA = record. DwMaxBytesPerSec : DWORD; // max. transfer rate. DwFlags : DWORD; // the ever-present flags. DwCaps : DWORD; DwStreams : DWORD; DwSuggestedBufferSize : DWORD; DwWidth : DWORD; DwHeight : DWORD; DwScale : DWORD; DwRate : DWORD; // dwRate / dwScale == samples/second. DwLength : DWORD; DwEditCount : DWORD; SzFileType : array[0..63] of AnsiChar; // descriptive string for file type? End; TAVIFILEINFO = TAVIFILEINFOA; PAVIFILEINFO = PAVIFILEINFOA; {-- Flags for dwFlags --------------------------------------------------------}. Const. AVIFILEINFO_HASINDEX = $00000010; AVIFILEINFO_MUSTUSEINDEX = $00000020; AVIFILEINFO_ISINTERLEAVED = $00000100; AVIFILEINFO_WASCAPTUREFILE = $00010000; AVIFILEINFO_COPYRIGHTED = $00020000; {-- Flags for dwCaps ---------------------------------------------------------}. AVIFILECAPS_CANREAD = $00000001; AVIFILECAPS_CANWRITE = $00000002; AVIFILECAPS_ALLKEYFRAMES = $00000010; AVIFILECAPS_NOCOMPRESSION = $00000020; Type. TAVISAVECALLBACK = function(i: int): BOOL; pascal; {-- AVICOMPRESSOPTIONS -------------------------------------------------------}. // Make sure it matches the AutoDoc in avisave.c !!! Type. PAVICOMPRESSOPTIONS = ^TAVICOMPRESSOPTIONS; TAVICOMPRESSOPTIONS = record. FccType : DWORD; // stream type, for consistency. FccHandler : DWORD; // compressor. DwKeyFrameEvery : DWORD; // keyframe rate. DwQuality : DWORD; // compress quality 0-10,000. DwBytesPerSecond : DWORD; // bytes per second. DwFlags : DWORD; // flags... see below. LpFormat : PVOID; // save format. CbFormat : DWORD; LpParms : PVOID; // compressor options. CbParms : DWORD; DwInterleaveEvery : DWORD; // for non-video streams only. End; // // Defines for the dwFlags field of the AVICOMPRESSOPTIONS struct. // Each of these flags determines if the appropriate field in the structure. // (dwInterleaveEvery, dwBytesPerSecond, and dwKeyFrameEvery) is payed. // attention to. See the autodoc in avisave.c for details. // Const. AVICOMPRESSF_INTERLEAVE = $00000001; // interleave. AVICOMPRESSF_DATARATE = $00000002; // use a data rate. AVICOMPRESSF_KEYFRAMES = $00000004; // use keyframes. AVICOMPRESSF_VALID = $00000008; // has valid data? {== AVI interfaces ===========================================================}. {-- AVIStream ----------------------------------------------------------------}. Type. PAVIStream = ^IAVIStream; IAVIStream = interface(IUnknown). Function Create(lParam1, lParam2: LPARAM): HResult; stdcall; Function Info(psi: PAVISTREAMINFOW; lSize: DWORD): HResult; stdcall; Function FindSample(lPos: DWORD; lFlags: DWORD): DWORD; stdcall; Function ReadFormat(lPos: DWORD; lpFormat: PVOID; lpcbFormat: PDWORD): HResult; stdcall; Function SetFormat(lPos: DWORD; lpFormat: PVOID; cbFormat: DWORD): HResult; stdcall; Function Read(lStart: DWORD; lSamples: DWORD; lpBuffer: PVOID; cbBuffer: DWORD; plBytes, plSamples: PDWORD): HResult; stdcall; Function Write(lStart: DWORD; lSamples: DWORD; lpBuffer: PVOID; cbBuffer: DWORD; dwFlags: DWORD; plSampWritten, plBytesWritten: PDWORD): HResult; stdcall; Function Delete(lStart: DWORD; lSamples: DWORD): HResult; stdcall; Function ReadData(fcc: DWORD; lp: PVOID; lpcb: PDWORD): HResult; stdcall; Function WriteData(fcc: DWORD; lp: PVOID; cb: DWORD): HResult; stdcall; Function SetInfo(lpInfo: PAVISTREAMINFOW; cbInfo: DWORD): HResult; stdcall; End; PAVIStreaming = ^IAVIStreaming; IAVIStreaming = interface(IUnknown). Function _Begin( LStart, // start of what we expect to play. LEnd : DWORD; // expected end, or -1. LRate : DWORD // Should this be a float? ): HResult; stdcall; Function _End: HResult; stdcall; End; PAVIEditStream = ^IAVIEditStream; IAVIEditStream = interface(IUnknown). Function Cut(plStart, plLength: PDWORD; var ppResult: PAVISTREAM): HResult; stdcall; Function Copy(plStart, plLength: PDWORD; var ppResult: PAVISTREAM): HResult; stdcall; Function Paste(plPos: PDWORD; plLength: PDWORD; pstream: PAVISTREAM; lStart, lEnd: DWORD): HResult; stdcall; Function Clone(var ppResult: PAVISTREAM): HResult; stdcall; Function SetInfo(lpInfo: PAVISTREAMINFOW; cbInfo: DWORD): HResult; stdcall; End; {-- AVIFile ------------------------------------------------------------------}. PAVIFile = ^IAVIFile; IAVIFile = interface(IUnknown). Function Info(pfi: PAVIFILEINFOW; lSize: DWORD): HResult; stdcall; Function GetStream(var ppStream: PAVISTREAM; fccType: DWORD; lParam: DWORD): HResult; stdcall; Function CreateStream(var ppStream: PAVISTREAM; psi: PAVISTREAMINFOW): HResult; stdcall; Function WriteData(ckid: DWORD; lpData: PVOID; cbData: DWORD): HResult; stdcall; Function ReadData(ckid: DWORD; lpData: PVOID; lpcbData: PDWORD): HResult; stdcall; Function EndRecord: HResult; stdcall; Function DeleteStream(fccType: DWORD; lParam: DWORD): HResult; stdcall; End; {-- GetFrame -----------------------------------------------------------------}. PGetFrame = ^IGetFrame; IGetFrame = interface(IUnknown). Function GetFrame(lPos: DWORD): PVOID; stdcall; Function _Begin(lStart, lEnd: DWORD; lRate: DWORD): HResult; stdcall; Function _End: HResult; stdcall; Function SetFormat(lpbi: PBITMAPINFOHEADER; lpBits: PVOID; x, y, dx, dy: int): HResult; stdcall; // STDMETHOD(DrawFrameStart) (THIS) PURE; // STDMETHOD(DrawFrame) (THIS_ DWORD lPos, HDC hdc, int x, int y, int dx, int dy) PURE; // STDMETHOD(DrawFrameEnd) (THIS) PURE; End; {-- GUIDs --------------------------------------------------------------------}. Const. IID_IAVIFile : TGUID = (D1: $00020020; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46)); IID_IAVIStream : TGUID = (D1: $00020021; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46)); IID_IAVIStreaming : TGUID = (D1: $00020022; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46)); IID_IGetFrame : TGUID = (D1: $00020023; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46)); IID_IAVIEditStream : TGUID = (D1: $00020024; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46)); CLSID_AVISimpleUnMarshal : TGUID = (D1: $00020009; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46)); CLSID_AVIFile : TGUID = (D1: $00020000; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46)); AVIFILEHANDLER_CANREAD = $0001; AVIFILEHANDLER_CANWRITE = $0002; AVIFILEHANDLER_CANACCEPTNONRGB = $0004; {-- Functions ----------------------------------------------------------------}. Procedure AVIFileInit; stdcall; // Call this first! Procedure AVIFileExit; stdcall; Function AVIFileAddRef(pfile: PAVIFILE): UDWORD; stdcall; Function AVIFileRelease(pfile: PAVIFILE): UDWORD; stdcall; Function AVIFileOpenA(var ppfile: PAVIFILE; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; Function AVIFileOpenW(var ppfile: PAVIFILE; szFile: LPCWSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; Function AVIFileOpen(var ppfile: PAVIFILE; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; // AVIFileOpenA. Function AVIFileInfoW(pfile: PAVIFILE; pfi: PAVIFILEINFOW; lSize: DWORD): HResult; stdcall; Function AVIFileInfoA(pfile: PAVIFILE; pfi: PAVIFILEINFOA; lSize: DWORD): HResult; stdcall; Function AVIFileInfo(pfile: PAVIFILE; pfi: PAVIFILEINFOA; lSize: DWORD): HResult; stdcall; // AVIFileInfoA. Function AVIFileGetStream(pfile: PAVIFILE; var ppavi: PAVISTREAM; fccType: DWORD; lParam: DWORD): HResult; stdcall; Function AVIFileCreateStreamW(pfile: PAVIFILE; var ppavi: PAVISTREAM; psi: PAVISTREAMINFOW): HResult; stdcall; Function AVIFileCreateStreamA(pfile: PAVIFILE; var ppavi: PAVISTREAM; psi: PAVISTREAMINFOA): HResult; stdcall; Function AVIFileCreateStream(pfile: PAVIFILE; var ppavi: PAVISTREAM; psi: PAVISTREAMINFOA): HResult; stdcall; // AVIFileCreateStreamA. Function AVIFileWriteData(pfile: PAVIFILE; ckid: DWORD; lpData: PVOID; cbData: DWORD): HResult; stdcall; Function AVIFileReadData(pfile: PAVIFILE; ckid: DWORD; lpData: PVOID; lpcbData: PDWORD): HResult; stdcall; Function AVIFileEndRecord(pfile: PAVIFILE): HResult; stdcall; Function AVIStreamAddRef(pavi: PAVISTREAM): UDWORD; stdcall; Function AVIStreamRelease(pavi: PAVISTREAM): UDWORD; stdcall; Function AVIStreamInfoW (pavi: PAVISTREAM; psi: PAVISTREAMINFOW; lSize: DWORD): HResult; stdcall; Function AVIStreamInfoA (pavi: PAVISTREAM; psi: PAVISTREAMINFOA; lSize: DWORD): HResult; stdcall; Function AVIStreamInfo(pavi: PAVISTREAM; psi: PAVISTREAMINFOA; lSize: DWORD): HResult; stdcall; // AVIStreamInfoA. Function AVIStreamFindSample(pavi: PAVISTREAM; lPos: DWORD; lFlags: DWORD): DWORD; stdcall; Function AVIStreamReadFormat(pavi: PAVISTREAM; lPos: DWORD; lpFormat: PVOID; lpcbFormat: PDWORD): HResult; stdcall; Function AVIStreamSetFormat(pavi: PAVISTREAM; lPos: DWORD; lpFormat: PVOID; cbFormat: DWORD): HResult; stdcall; Function AVIStreamReadData(pavi: PAVISTREAM; fcc: DWORD; lp: PVOID; lpcb: PDWORD): HResult; stdcall; Function AVIStreamWriteData(pavi: PAVISTREAM; fcc: DWORD; lp: PVOID; cb: DWORD): HResult; stdcall; Function AVIStreamRead( Pavi : PAVISTREAM; LStart : DWORD; LSamples : DWORD; LpBuffer : PVOID; CbBuffer : DWORD; PlBytes : PDWORD; PlSamples : PDWORD. ): HResult; stdcall; Const. AVISTREAMREAD_CONVENIENT = -1; Function AVIStreamWrite( Pavi : PAVISTREAM; LStart, LSamples : DWORD; LpBuffer : PVOID; CbBuffer : DWORD; DwFlags : DWORD; PlSampWritten : PDWORD; PlBytesWritten : PDWORD. ): HResult; stdcall; // Right now, these just use AVIStreamInfo() to get information, then. // return some of it. Can they be more efficient? Function AVIStreamStart(pavi: PAVISTREAM): DWORD; stdcall; Function AVIStreamLength(pavi: PAVISTREAM): DWORD; stdcall; Function AVIStreamTimeToSample(pavi: PAVISTREAM; lTime: DWORD): DWORD; stdcall; Function AVIStreamSampleToTime(pavi: PAVISTREAM; lSample: DWORD): DWORD; stdcall; Function AVIStreamBeginStreaming(pavi: PAVISTREAM; lStart, lEnd: DWORD; lRate: DWORD): HResult; stdcall; Function AVIStreamEndStreaming(pavi: PAVISTREAM): HResult; stdcall; {-- Helper functions for using IGetFrame -------------------------------------}. Function AVIStreamGetFrameOpen(pavi: PAVISTREAM; lpbiWanted: PBITMAPINFOHEADER): PGETFRAME; stdcall; Function AVIStreamGetFrame(pg: PGETFRAME; lPos: DWORD): PVOID; stdcall; Function AVIStreamGetFrameClose(pg: PGETFRAME): HResult; stdcall; // !!! We need some way to place an advise on a stream.... // STDAPI AVIStreamHasChanged (PAVISTREAM pavi); {-- Shortcut function --------------------------------------------------------}. Function AVIStreamOpenFromFileA(var ppavi: PAVISTREAM; szFile: LPCSTR; fccType: DWORD; LParam: DWORD; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; Function AVIStreamOpenFromFileW(var ppavi: PAVISTREAM; szFile: LPCWSTR; fccType: DWORD; LParam: DWORD; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; Function AVIStreamOpenFromFile(var ppavi: PAVISTREAM; szFile: LPCSTR; fccType: DWORD; LParam: DWORD; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; // AVIStreamOpenFromFileA. {-- Use to create disembodied streams ----------------------------------------}. Function AVIStreamCreate(var ppavi: PAVISTREAM; lParam1, lParam2: DWORD; PclsidHandler: PCLSID): HResult; stdcall; // PHANDLER AVIAPI AVIGetHandler (PAVISTREAM pavi, PAVISTREAMHANDLER psh); // PAVISTREAM AVIAPI AVIGetStream (PHANDLER p); {-- Flags for AVIStreamFindSample --------------------------------------------}. Const. FIND_DIR = $0000000F; // direction. FIND_NEXT = $00000001; // go forward. FIND_PREV = $00000004; // go backward. FIND_FROM_START = $00000008; // start at the logical beginning. FIND_TYPE = $000000F0; // type mask. FIND_KEY = $00000010; // find key frame. FIND_ANY = $00000020; // find any (non-empty) sample. FIND_FORMAT = $00000040; // find format change. FIND_RET = $0000F000; // return mask. FIND_POS = $00000000; // return logical position. FIND_LENGTH = $00001000; // return logical size. FIND_OFFSET = $00002000; // return physical position. FIND_SIZE = $00003000; // return physical size. FIND_INDEX = $00004000; // return physical index position. {-- Stuff to support backward compat. ----------------------------------------}. Function AVIStreamFindKeyFrame(pavi: PAVISTREAM; lPos: DWORD; lFlags: DWORD): DWORD; stdcall; // AVIStreamFindSample. // Non-portable: this is alias for method name. // FindKeyFrame FindSample. Function AVIStreamClose(pavi: PAVISTREAM): UDWORD; stdcall; // AVIStreamRelease. Function AVIFileClose(pfile: PAVIFILE): UDWORD; stdcall; // AVIFileRelease. Procedure AVIStreamInit; stdcall; // AVIFileInit. Procedure AVIStreamExit; stdcall; // AVIFileExit. Const. SEARCH_NEAREST = FIND_PREV; SEARCH_BACKWARD = FIND_PREV; SEARCH_FORWARD = FIND_NEXT; SEARCH_KEY = FIND_KEY; SEARCH_ANY = FIND_ANY; {-- Helper macros ------------------------------------------------------------}. Function AVIStreamSampleToSample(pavi1, pavi2: PAVISTREAM; l: DWORD): DWORD; Function AVIStreamNextSample(pavi: PAVISTREAM; l: DWORD): DWORD; Function AVIStreamPrevSample(pavi: PAVISTREAM; l: DWORD): DWORD; Function AVIStreamNearestSample(pavi: PAVISTREAM; l: DWORD): DWORD; Function AVIStreamNextKeyFrame(pavi: PAVISTREAM; l: DWORD): DWORD; Function AVIStreamPrevKeyFrame(pavi: PAVISTREAM; l: DWORD): DWORD; Function AVIStreamNearestKeyFrame(pavi: PAVISTREAM; l: DWORD): DWORD; Function AVIStreamIsKeyFrame(pavi: PAVISTREAM; l: DWORD): BOOL; Function AVIStreamPrevSampleTime(pavi: PAVISTREAM; t: DWORD): DWORD; Function AVIStreamNextSampleTime(pavi: PAVISTREAM; t: DWORD): DWORD; Function AVIStreamNearestSampleTime(pavi: PAVISTREAM; t: DWORD): DWORD; Function AVIStreamNextKeyFrameTime(pavi: PAVISTREAM; t: DWORD): DWORD; Function AVIStreamPrevKeyFrameTime(pavi: PAVISTREAM; t: DWORD): DWORD; Function AVIStreamNearestKeyFrameTime(pavi: PAVISTREAM; t: DWORD): DWORD; Function AVIStreamStartTime(pavi: PAVISTREAM): DWORD; Function AVIStreamLengthTime(pavi: PAVISTREAM): DWORD; Function AVIStreamEnd(pavi: PAVISTREAM): DWORD; Function AVIStreamEndTime(pavi: PAVISTREAM): DWORD; Function AVIStreamSampleSize(pavi: PAVISTREAM; lPos: DWORD; plSize: PDWORD): DWORD; Function AVIStreamFormatSize(pavi: PAVISTREAM; lPos: DWORD; plSize: PDWORD): HResult; Function AVIStreamDataSize(pavi: PAVISTREAM; fcc: DWORD; plSize: PDWORD): HResult; {== AVISave routines and structures ==========================================}. Const. ComptypeDIB = $20424944; // mmioFOURCC('D', 'I', 'B', ' '). Function AVIMakeCompressedStream( Var ppsCompressed : PAVISTREAM; PpsSource : PAVISTREAM; LpOptions : PAVICOMPRESSOPTIONS; PclsidHandler : PCLSID. ): HResult; stdcall; // Non-portable: uses variable number of params. // EXTERN_C HRESULT CDECL AVISaveA (LPCSTR szFile, // CLSID FAR *pclsidHandler, // AVISAVECALLBACK lpfnCallback, // int nStreams, // PAVISTREAM pfile, // LPAVICOMPRESSOPTIONS lpOptions, // ...); Function AVISaveVA( SzFile : LPCSTR; PclsidHandler : PCLSID; LpfnCallback : TAVISAVECALLBACK; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): HResult; stdcall; // Non-portable: uses variable number of params. // EXTERN_C HRESULT CDECL AVISaveW (LPCWSTR szFile, // CLSID FAR *pclsidHandler, // AVISAVECALLBACK lpfnCallback, // int nStreams, // PAVISTREAM pfile, // LPAVICOMPRESSOPTIONS lpOptions, // ...); Function AVISaveVW( SzFile : LPCWSTR; PclsidHandler : PCLSID; LpfnCallback : TAVISAVECALLBACK; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): HResult; stdcall; // #define AVISave AVISaveA. Function AVISaveV( SzFile : LPCSTR; PclsidHandler : PCLSID; LpfnCallback : TAVISAVECALLBACK; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): HResult; stdcall; // AVISaveVA. Function AVISaveOptions( Hwnd : HWND; UiFlags : UINT; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): BOOL; stdcall; Function AVISaveOptionsFree(nStreams: int; var plpOptions: PAVICOMPRESSOPTIONS): HResult; stdcall; {-- FLAGS FOR uiFlags --------------------------------------------------------}. // Same as the flags for ICCompressorChoose (see compman.h). // These determine what the compression options dialog for video streams. // will look like. Function AVIBuildFilterW(lpszFilter: LPWSTR; cbFilter: DWORD; fSaving: BOOL): HResult; stdcall; Function AVIBuildFilterA(lpszFilter: LPSTR; cbFilter: DWORD; fSaving: BOOL): HResult; stdcall; Function AVIBuildFilter(lpszFilter: LPSTR; cbFilter: DWORD; fSaving: BOOL): HResult; stdcall; // AVIBuildFilterA. Function AVIMakeFileFromStreams(var ppfile: PAVIFILE; nStreams: int; var papStreams: PAVISTREAM): HResult; stdcall; Function AVIMakeStreamFromClipboard(cfFormat: UINT; hGlobal: THANDLE; var ppstream: PAVISTREAM): HResult; stdcall; {-- Clipboard routines -------------------------------------------------------}. Function AVIPutFileOnClipboard(pf: PAVIFILE): HResult; stdcall; Function AVIGetFromClipboard(var lppf: PAVIFILE): HResult; stdcall; Function AVIClearClipboard: HResult; stdcall; {-- Editing routines ---------------------------------------------------------}. Function CreateEditableStream(var ppsEditable: PAVISTREAM; psSource: PAVISTREAM): HResult; stdcall; Function EditStreamCut(pavi: PAVISTREAM; plStart, plLength: PDWORD; var ppResult: PAVISTREAM): HResult; stdcall; Function EditStreamCopy(pavi: PAVISTREAM; plStart, plLength: PDWORD; var ppResult: PAVISTREAM): HResult; stdcall; Function EditStreamPaste(pavi: PAVISTREAM; plPos, plLength: PDWORD; pstream: PAVISTREAM; lStart, lEnd: DWORD): HResult; stdcall; Function EditStreamClone(pavi: PAVISTREAM; var ppResult: PAVISTREAM): HResult; stdcall; Function EditStreamSetNameA(pavi: PAVISTREAM; lpszName: LPCSTR): HResult; stdcall; Function EditStreamSetNameW(pavi: PAVISTREAM; lpszName: LPCWSTR): HResult; stdcall; Function EditStreamSetInfoW(pavi: PAVISTREAM; lpInfo: PAVISTREAMINFOW; cbInfo: DWORD): HResult; stdcall; Function EditStreamSetInfoA(pavi: PAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: DWORD): HResult; stdcall; Function EditStreamSetInfo(pavi: PAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: DWORD): HResult; stdcall; // EditStreamSetInfoA. Function EditStreamSetName(pavi: PAVISTREAM; lpszName: LPCSTR): HResult; stdcall; // EditStreamSetNameA. {-- Error handling -----------------------------------------------------------}. Const. AVIERR_OK = 0; // !!! Questions to be answered: // How can you get a string form of these errors? // Which of these errors should be replaced by errors in SCODE.H? Const. AVIERR_UNSUPPORTED = $80044065; // MAKE_AVIERR(101). AVIERR_BADFORMAT = $80044066; // MAKE_AVIERR(102). AVIERR_MEMORY = $80044067; // MAKE_AVIERR(103). AVIERR_INTERNAL = $80044068; // MAKE_AVIERR(104). AVIERR_BADFLAGS = $80044069; // MAKE_AVIERR(105). AVIERR_BADPARAM = $8004406A; // MAKE_AVIERR(106). AVIERR_BADSIZE = $8004406B; // MAKE_AVIERR(107). AVIERR_BADHANDLE = $8004406C; // MAKE_AVIERR(108). AVIERR_FILEREAD = $8004406D; // MAKE_AVIERR(109). AVIERR_FILEWRITE = $8004406E; // MAKE_AVIERR(110). AVIERR_FILEOPEN = $8004406F; // MAKE_AVIERR(111). AVIERR_COMPRESSOR = $80044070; // MAKE_AVIERR(112). AVIERR_NOCOMPRESSOR = $80044071; // MAKE_AVIERR(113). AVIERR_READONLY = $80044072; // MAKE_AVIERR(114). AVIERR_NODATA = $80044073; // MAKE_AVIERR(115). AVIERR_BUFFERTOOSMALL = $80044074; // MAKE_AVIERR(116). AVIERR_CANTCOMPRESS = $80044075; // MAKE_AVIERR(117). AVIERR_USERABORT = $800440C6; // MAKE_AVIERR(198). AVIERR_ERROR = $800440C7; // MAKE_AVIERR(199). {== MCIWnd - Window class for MCI objects ====================================}. // // MCIWnd. // // MCIWnd window class header file. // // the MCIWnd window class is a window class for controling MCI devices. // MCI devices include, wave files, midi files, AVI Video, cd audio, // vcr, video disc, and others.. // // to learn more about MCI and mci command sets see the. // "Microsoft Multimedia Programmers's guide" in the Win31 SDK. // // the easiest use of the MCIWnd class is like so: // // hwnd = MCIWndCreate(hwndParent, hInstance, 0, "chimes.wav"); // ... // MCIWndPlay(hwnd); // MCIWndStop(hwnd); // MCIWndPause(hwnd); // .... // MCIWndDestroy(hwnd); // // this will create a window with a play/pause, stop and a playbar. // and start the wave file playing. // // mciwnd.h defines macros for all the most common MCI commands, but. // any string command can be used if needed. // // Note: unlike the mciSendString() API, no alias or file name needs. // to be specifed, since the device to use is implied by the window handle. // // MCIWndSendString(hwnd, "setaudio stream to 2"); // // (C) Copyright Microsoft Corp. 1991-1995. All rights reserved. // // WIN32: // // MCIWnd supports both ansi and unicode interfaces. For any message that. // takes or returns a text string, two versions of the message are defined, // appended with A or W for Ansi or Wide Char. The message or api itself. // is defined to be one or other of these depending on whether you have. // UNICODE defined in your application. // Thus for the api MCIWndCreate, there are in fact two apis, // MCIWndCreateA and MCIWndCreateW. If you call MCIWndCreate, this will be. // re-routed to MCIWndCreateA unless UNICODE is defined when building your. // application. In any one application, you can mix calls to the. // Ansi and Unicode entrypoints. // // If you use SendMessage instead of the macros below such as MCIWndOpen(), // you will see that the messages have changed for WIN32, to support Ansi. // and Unicode entrypoints. In particular, MCI_OPEN has been replaced by. // MCWNDM_OPENA, or MCIWNDM_OPENW (MCIWNDM_OPEN is defined to be one or. // other of these). // // Also, note that the WIN32 implementation of MCIWnd uses UNICODE. // so all apis and messages supporting ANSI strings do so by mapping them. // UNICODE strings and then calling the corresponding UNICODE entrypoint. // Function MCIWndSM(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD; Const. MCIWND_WINDOW_CLASS = 'MCIWndClass' ; Function MCIWndCreateA(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl; Function MCIWndCreateW(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCWSTR): HWND; cdecl; Function MCIWndCreate(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl; // MCIWndCreateA. Function MCIWndRegisterClass: BOOL; cdecl; {-- Flags for the MCIWndOpen command -----------------------------------------}. Const. MCIWNDOPENF_NEW = $0001; // open a new file. {-- Window styles ------------------------------------------------------------}. MCIWNDF_NOAUTOSIZEWINDOW = $0001; // when movie size changes. MCIWNDF_NOPLAYBAR = $0002; // no toolbar. MCIWNDF_NOAUTOSIZEMOVIE = $0004; // when window size changes. MCIWNDF_NOMENU = $0008; // no popup menu from RBUTTONDOWN. MCIWNDF_SHOWNAME = $0010; // show name in caption. MCIWNDF_SHOWPOS = $0020; // show position in caption. MCIWNDF_SHOWMODE = $0040; // show mode in caption. MCIWNDF_SHOWALL = $0070; // show all. MCIWNDF_NOTIFYMODE = $0100; // tell parent of mode change. MCIWNDF_NOTIFYPOS = $0200; // tell parent of pos change. MCIWNDF_NOTIFYSIZE = $0400; // tell parent of size change. MCIWNDF_NOTIFYERROR = $1000; // tell parent of an error. MCIWNDF_NOTIFYALL = $1F00; // tell all. MCIWNDF_NOTIFYANSI = $0080; // The MEDIA notification includes a text string. // To receive notifications in ANSI instead of unicode set the. // MCIWNDF_NOTIFYANSI style bit. The macro below includes this bit. // by default unless you define UNICODE in your application. MCIWNDF_NOTIFYMEDIAA = $0880; // tell parent of media change. MCIWNDF_NOTIFYMEDIAW = $0800; // tell parent of media change. MCIWNDF_NOTIFYMEDIA = MCIWNDF_NOTIFYMEDIAA; MCIWNDF_RECORD = $2000; // Give a record button. MCIWNDF_NOERRORDLG = $4000; // Show Error Dlgs for MCI cmds? MCIWNDF_NOOPEN = $8000; // Don't allow user to open things. {-- Can macros ---------------------------------------------------------------}. Function MCIWndCanPlay(hwnd: HWND): BOOL; Function MCIWndCanRecord(hwnd: HWND): BOOL; Function MCIWndCanSave(hwnd: HWND): BOOL; Function MCIWndCanWindow(hwnd: HWND): BOOL; Function MCIWndCanEject(hwnd: HWND): BOOL; Function MCIWndCanConfig(hwnd: HWND): BOOL; Function MCIWndPaletteKick(hwnd: HWND): BOOL; Function MCIWndSave(hwnd: HWND; szFile: LPCSTR): DWORD; Function MCIWndSaveDialog(hwnd: HWND): DWORD; // If you dont give a device it will use the current device.... Function MCIWndNew(hwnd: HWND; lp: PVOID): DWORD; Function MCIWndRecord(hwnd: HWND): DWORD; Function MCIWndOpen(hwnd: HWND; sz: LPCSTR; f: BOOL): DWORD; Function MCIWndOpenDialog(hwnd: HWND): DWORD; Function MCIWndClose(hwnd: HWND): DWORD; Function MCIWndPlay(hwnd: HWND): DWORD; Function MCIWndStop(hwnd: HWND): DWORD; Function MCIWndPause(hwnd: HWND): DWORD; Function MCIWndResume(hwnd: HWND): DWORD; Function MCIWndSeek(hwnd: HWND; lPos: DWORD): DWORD; Function MCIWndEject(hwnd: HWND): DWORD; Function MCIWndHome(hwnd: HWND): DWORD; Function MCIWndEnd(hwnd: HWND): DWORD; Function MCIWndGetSource(hwnd: HWND; prc: PRECT): DWORD; Function MCIWndPutSource(hwnd: HWND; prc: PRECT): DWORD; Function MCIWndGetDest(hwnd: HWND; prc: PRECT): DWORD; Function MCIWndPutDest(hwnd: HWND; prc: PRECT): DWORD; Function MCIWndPlayReverse(hwnd: HWND): DWORD; Function MCIWndPlayFrom(hwnd: HWND; lPos: DWORD): DWORD; Function MCIWndPlayTo(hwnd: HWND; lPos: DWORD): DWORD; Function MCIWndPlayFromTo(hwnd: HWND; lStart, lEnd: DWORD): DWORD; Function MCIWndGetDeviceID(hwnd: HWND): UINT; Function MCIWndGetAlias(hwnd: HWND): UINT; Function MCIWndGetMode(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Function MCIWndGetPosition(hwnd: HWND): DWORD; Function MCIWndGetPositionString(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Function MCIWndGetStart(hwnd: HWND): DWORD; Function MCIWndGetLength(hwnd: HWND): DWORD; Function MCIWndGetEnd(hwnd: HWND): DWORD; Function MCIWndStep(hwnd: HWND; n: DWORD): DWORD; Procedure MCIWndDestroy(hwnd: HWND); Procedure MCIWndSetZoom(hwnd: HWND; iZoom: UINT); Function MCIWndGetZoom(hwnd: HWND): UINT; Function MCIWndSetVolume(hwnd: HWND; iVol: UINT): DWORD; Function MCIWndGetVolume(hwnd: HWND): DWORD; Function MCIWndSetSpeed(hwnd: HWND; iSpeed: UINT): DWORD; Function MCIWndGetSpeed(hwnd: HWND): DWORD; Function MCIWndSetTimeFormat(hwnd: HWND; lp: LPCSTR): DWORD; Function MCIWndGetTimeFormat(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Procedure MCIWndValidateMedia(hwnd: HWND); Procedure MCIWndSetRepeat(hwnd: HWND; f: BOOL); Function MCIWndGetRepeat(hwnd: HWND): BOOL; Function MCIWndUseFrames(hwnd: HWND): DWORD; Function MCIWndUseTime(hwnd: HWND): DWORD; Procedure MCIWndSetActiveTimer(hwnd: HWND; active: UINT); Procedure MCIWndSetInactiveTimer(hwnd: HWND; inactive: UINT); Procedure MCIWndSetTimers(hwnd: HWND; active, inactive: UINT); Function MCIWndGetActiveTimer(hwnd: HWND): UINT; Function MCIWndGetInactiveTimer(hwnd: HWND): UINT; Function MCIWndRealize(hwnd: HWND; fBkgnd: BOOL): DWORD; Function MCIWndSendString(hwnd: HWND; sz: LPCSTR): DWORD; Function MCIWndReturnString(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Function MCIWndGetError(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; // #define MCIWndActivate(hwnd, f) (void)MCIWndSM(hwnd, WM_ACTIVATE, (WPARAM)(BOOL)(f), 0). Function MCIWndGetPalette(hwnd: HWND): HPALETTE; Function MCIWndSetPalette(hwnd: HWND; hpal: HPALETTE): DWORD; Function MCIWndGetFileName(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Function MCIWndGetDevice(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Function MCIWndGetStyles(hwnd: HWND): UINT; Function MCIWndChangeStyles(hwnd: HWND; mask: UINT; value: DWORD): DWORD; Type. PUnknown = ^IUnknown; Function MCIWndOpenInterface(hwnd: HWND; pUnk: PUnknown): DWORD; Function MCIWndSetOwner(hwnd: HWND; hwndP: HWND): DWORD; {-- Messages an app will send to MCIWND --------------------------------------}. // all the text-related messages are defined out of order above (they need. // to be defined before the MCIWndOpen() macros. Const. MCIWNDM_GETDEVICEID = WM_USER + 100; MCIWNDM_GETSTART = WM_USER + 103; MCIWNDM_GETLENGTH = WM_USER + 104; MCIWNDM_GETEND = WM_USER + 105; MCIWNDM_EJECT = WM_USER + 107; MCIWNDM_SETZOOM = WM_USER + 108; MCIWNDM_GETZOOM = WM_USER + 109; MCIWNDM_SETVOLUME = WM_USER + 110; MCIWNDM_GETVOLUME = WM_USER + 111; MCIWNDM_SETSPEED = WM_USER + 112; MCIWNDM_GETSPEED = WM_USER + 113; MCIWNDM_SETREPEAT = WM_USER + 114; MCIWNDM_GETREPEAT = WM_USER + 115; MCIWNDM_REALIZE = WM_USER + 118; MCIWNDM_VALIDATEMEDIA = WM_USER + 121; MCIWNDM_PLAYFROM = WM_USER + 122; MCIWNDM_PLAYTO = WM_USER + 123; MCIWNDM_GETPALETTE = WM_USER + 126; MCIWNDM_SETPALETTE = WM_USER + 127; MCIWNDM_SETTIMERS = WM_USER + 129; MCIWNDM_SETACTIVETIMER = WM_USER + 130; MCIWNDM_SETINACTIVETIMER = WM_USER + 131; MCIWNDM_GETACTIVETIMER = WM_USER + 132; MCIWNDM_GETINACTIVETIMER = WM_USER + 133; MCIWNDM_CHANGESTYLES = WM_USER + 135; MCIWNDM_GETSTYLES = WM_USER + 136; MCIWNDM_GETALIAS = WM_USER + 137; MCIWNDM_PLAYREVERSE = WM_USER + 139; MCIWNDM_GET_SOURCE = WM_USER + 140; MCIWNDM_PUT_SOURCE = WM_USER + 141; MCIWNDM_GET_DEST = WM_USER + 142; MCIWNDM_PUT_DEST = WM_USER + 143; MCIWNDM_CAN_PLAY = WM_USER + 144; MCIWNDM_CAN_WINDOW = WM_USER + 145; MCIWNDM_CAN_RECORD = WM_USER + 146; MCIWNDM_CAN_SAVE = WM_USER + 147; MCIWNDM_CAN_EJECT = WM_USER + 148; MCIWNDM_CAN_CONFIG = WM_USER + 149; MCIWNDM_PALETTEKICK = WM_USER + 150; MCIWNDM_OPENINTERFACE = WM_USER + 151; MCIWNDM_SETOWNER = WM_USER + 152; {-- Define both A and W messages ---------------------------------------------}. MCIWNDM_SENDSTRINGA = WM_USER + 101; MCIWNDM_GETPOSITIONA = WM_USER + 102; MCIWNDM_GETMODEA = WM_USER + 106; MCIWNDM_SETTIMEFORMATA = WM_USER + 119; MCIWNDM_GETTIMEFORMATA = WM_USER + 120; MCIWNDM_GETFILENAMEA = WM_USER + 124; MCIWNDM_GETDEVICEA = WM_USER + 125; MCIWNDM_GETERRORA = WM_USER + 128; MCIWNDM_NEWA = WM_USER + 134; MCIWNDM_RETURNSTRINGA = WM_USER + 138; MCIWNDM_OPENA = WM_USER + 153; MCIWNDM_SENDSTRINGW = WM_USER + 201; MCIWNDM_GETPOSITIONW = WM_USER + 202; MCIWNDM_GETMODEW = WM_USER + 206; MCIWNDM_SETTIMEFORMATW = WM_USER + 219; MCIWNDM_GETTIMEFORMATW = WM_USER + 220; MCIWNDM_GETFILENAMEW = WM_USER + 224; MCIWNDM_GETDEVICEW = WM_USER + 225; MCIWNDM_GETERRORW = WM_USER + 228; MCIWNDM_NEWW = WM_USER + 234; MCIWNDM_RETURNSTRINGW = WM_USER + 238; MCIWNDM_OPENW = WM_USER + 252; {-- Map defaults to A --------------------------------------------------------}. MCIWNDM_SENDSTRING = MCIWNDM_SENDSTRINGA; MCIWNDM_GETPOSITION = MCIWNDM_GETPOSITIONA; MCIWNDM_GETMODE = MCIWNDM_GETMODEA; MCIWNDM_SETTIMEFORMAT = MCIWNDM_SETTIMEFORMATA; MCIWNDM_GETTIMEFORMAT = MCIWNDM_GETTIMEFORMATA; MCIWNDM_GETFILENAME = MCIWNDM_GETFILENAMEA; MCIWNDM_GETDEVICE = MCIWNDM_GETDEVICEA; MCIWNDM_GETERROR = MCIWNDM_GETERRORA; MCIWNDM_NEW = MCIWNDM_NEWA; MCIWNDM_RETURNSTRING = MCIWNDM_RETURNSTRINGA; MCIWNDM_OPEN = MCIWNDM_OPENA; // note that the source text for MCIWND will thus contain. // support for eg MCIWNDM_SENDSTRING (both the 16-bit entrypoint and. // in win32 mapped to MCIWNDM_SENDSTRINGW), and MCIWNDM_SENDSTRINGA (the. // win32 ansi thunk). {-- Messages MCIWND will send to an app --------------------------------------}. Const. MCIWNDM_NOTIFYMODE = WM_USER + 200; // wp = hwnd, lp = mode. MCIWNDM_NOTIFYPOS = WM_USER + 201; // wp = hwnd, lp = pos. MCIWNDM_NOTIFYSIZE = WM_USER + 202; // wp = hwnd. MCIWNDM_NOTIFYMEDIA = WM_USER + 203; // wp = hwnd, lp = fn. MCIWNDM_NOTIFYERROR = WM_USER + 205; // wp = hwnd, lp = error. {-- Special seek values for START and END ------------------------------------}. MCIWND_START = Cardinal(-1) ; MCIWND_END = Cardinal(-2) ; {== VIDEO - Video capture driver interface ===================================}. Type. HVIDEO = THandle; PHVIDEO = ^HVIDEO; {-- Error return values ------------------------------------------------------}. Const. DV_ERR_OK = 0; // No error. DV_ERR_BASE = 1; // Error Base. DV_ERR_NONSPECIFIC = DV_ERR_BASE; DV_ERR_BADFORMAT = DV_ERR_BASE + 1; // unsupported video format. DV_ERR_STILLPLAYING = DV_ERR_BASE + 2; // still something playing. DV_ERR_UNPREPARED = DV_ERR_BASE + 3; // header not prepared. DV_ERR_SYNC = DV_ERR_BASE + 4; // device is synchronous. DV_ERR_TOOMANYCHANNELS = DV_ERR_BASE + 5; // number of channels exceeded. DV_ERR_NOTDETECTED = DV_ERR_BASE + 6; // HW not detected. DV_ERR_BADINSTALL = DV_ERR_BASE + 7; // Can not get Profile. DV_ERR_CREATEPALETTE = DV_ERR_BASE + 8; DV_ERR_SIZEFIELD = DV_ERR_BASE + 9; DV_ERR_PARAM1 = DV_ERR_BASE + 10; DV_ERR_PARAM2 = DV_ERR_BASE + 11; DV_ERR_CONFIG1 = DV_ERR_BASE + 12; DV_ERR_CONFIG2 = DV_ERR_BASE + 13; DV_ERR_FLAGS = DV_ERR_BASE + 14; DV_ERR_13 = DV_ERR_BASE + 15; DV_ERR_NOTSUPPORTED = DV_ERR_BASE + 16; // function not suported. DV_ERR_NOMEM = DV_ERR_BASE + 17; // out of memory. DV_ERR_ALLOCATED = DV_ERR_BASE + 18; // device is allocated. DV_ERR_BADDEVICEID = DV_ERR_BASE + 19; DV_ERR_INVALHANDLE = DV_ERR_BASE + 20; DV_ERR_BADERRNUM = DV_ERR_BASE + 21; DV_ERR_NO_BUFFERS = DV_ERR_BASE + 22; // out of buffers. DV_ERR_MEM_CONFLICT = DV_ERR_BASE + 23; // Mem conflict detected. DV_ERR_IO_CONFLICT = DV_ERR_BASE + 24; // I/O conflict detected. DV_ERR_DMA_CONFLICT = DV_ERR_BASE + 25; // DMA conflict detected. DV_ERR_INT_CONFLICT = DV_ERR_BASE + 26; // Interrupt conflict detected. DV_ERR_PROTECT_ONLY = DV_ERR_BASE + 27; // Can not run in standard mode. DV_ERR_LASTERROR = DV_ERR_BASE + 27; DV_ERR_USER_MSG = DV_ERR_BASE + 1000; // Hardware specific errors. {-- Callback messages --------------------------------------------------------}. // Note that the values for all installable driver callback messages are. // identical, (ie. MM_DRVM_DATA has the same value for capture drivers, // installable video codecs, and the audio compression manager). Const. DV_VM_OPEN = MM_DRVM_OPEN; // Obsolete messages. DV_VM_CLOSE = MM_DRVM_CLOSE; DV_VM_DATA = MM_DRVM_DATA; DV_VM_ERROR = MM_DRVM_ERROR; {== Structures ===============================================================}. {-- Video data block header --------------------------------------------------}. Type. PVIDEOHDR = ^TVIDEOHDR; TVIDEOHDR = record. LpData : PBYTE; // pointer to locked data buffer. DwBufferLength : DWORD; // Length of data buffer. DwBytesUsed : DWORD; // Bytes actually used. DwTimeCaptured : DWORD; // Milliseconds from start of stream. DwUser : DWORD; // for client's use. DwFlags : DWORD; // assorted flags (see defines). DwReserved : array[0..3] of DWORD; // reserved for driver. End; {-- dwFlags field of VIDEOHDR ------------------------------------------------}. Const. VHDR_DONE = $00000001; // Done bit. VHDR_PREPARED = $00000002; // Set if this header has been prepared. VHDR_INQUEUE = $00000004; // Reserved for driver. VHDR_KEYFRAME = $00000008; // Key Frame. {-- Channel capabilities structure -------------------------------------------}. Type. PCHANNEL_CAPS = ^TCHANNEL_CAPS; TCHANNEL_CAPS = record. DwFlags : DWORD; // Capability flags. DwSrcRectXMod : DWORD; // Granularity of src rect in x. DwSrcRectYMod : DWORD; // Granularity of src rect in y. DwSrcRectWidthMod : DWORD; // Granularity of src rect width. DwSrcRectHeightMod : DWORD; // Granularity of src rect height. DwDstRectXMod : DWORD; // Granularity of dst rect in x. DwDstRectYMod : DWORD; // Granularity of dst rect in y. DwDstRectWidthMod : DWORD; // Granularity of dst rect width. DwDstRectHeightMod : DWORD; // Granularity of dst rect height. End; {-- dwFlags of CHANNEL_CAPS --------------------------------------------------}. Const. VCAPS_OVERLAY = $00000001; // overlay channel. VCAPS_SRC_CAN_CLIP = $00000002; // src rect can clip. VCAPS_DST_CAN_CLIP = $00000004; // dst rect can clip. VCAPS_CAN_SCALE = $00000008; // allows src != dst. {== API flags ================================================================}. {-- Types of channels to open with the videoOpen function --------------------}. Const. VIDEO_EXTERNALIN = $0001; VIDEO_EXTERNALOUT = $0002; VIDEO_IN = $0004; VIDEO_OUT = $0008; {-- Is a driver dialog available for this channel ----------------------------}. VIDEO_DLG_QUERY = $0010; {-- videoConfigure (both GET and SET) ----------------------------------------}. VIDEO_CONFIGURE_QUERY = $8000; {-- videoConfigure (SET only) ------------------------------------------------}. VIDEO_CONFIGURE_SET = $1000; {-- videoConfigure (GET only) ------------------------------------------------}. VIDEO_CONFIGURE_GET = $2000; VIDEO_CONFIGURE_QUERYSIZE = $0001; VIDEO_CONFIGURE_CURRENT = $0010; VIDEO_CONFIGURE_NOMINAL = $0020; VIDEO_CONFIGURE_MIN = $0040; VIDEO_CONFIGURE_MAX = $0080; {== Configure messages =======================================================}. DVM_USER = $4000; DVM_CONFIGURE_START = $1000; DVM_CONFIGURE_END = $1FFF; DVM_PALETTE = DVM_CONFIGURE_START + 1; DVM_FORMAT = DVM_CONFIGURE_START + 2; DVM_PALETTERGB555 = DVM_CONFIGURE_START + 3; DVM_SRC_RECT = DVM_CONFIGURE_START + 4; DVM_DST_RECT = DVM_CONFIGURE_START + 5; {== AVICAP - Window class for AVI capture ====================================}. Function AVICapSM(hwnd: HWND; m: UINT; w: WPARAM; l: LPARAM): DWORD; {-- Window messages WM_CAP... which can be sent to an AVICAP window ----------}. // UNICODE. // // The Win32 version of AVICAP on NT supports UNICODE applications: // for each API or message that takes a char or string parameter, there are. // two versions, ApiNameA and ApiNameW. The default name ApiName is #defined. // to one or other depending on whether UNICODE is defined. Apps can call. // the A and W apis directly, and mix them. // // The 32-bit AVICAP on NT uses unicode exclusively internally. // ApiNameA() will be implemented as a call to ApiNameW() together with. // translation of strings. // Defines start of the message range. Const. WM_CAP_START = WM_USER; WM_CAP_UNICODE_START = WM_USER + 100; WM_CAP_GET_CAPSTREAMPTR = WM_CAP_START + 1; WM_CAP_SET_CALLBACK_ERRORW = WM_CAP_UNICODE_START + 2; WM_CAP_SET_CALLBACK_STATUSW = WM_CAP_UNICODE_START + 3; WM_CAP_SET_CALLBACK_ERRORA = WM_CAP_START + 2; WM_CAP_SET_CALLBACK_STATUSA = WM_CAP_START + 3; WM_CAP_SET_CALLBACK_ERROR = WM_CAP_SET_CALLBACK_ERRORA; WM_CAP_SET_CALLBACK_STATUS = WM_CAP_SET_CALLBACK_STATUSA; WM_CAP_SET_CALLBACK_YIELD = WM_CAP_START + 4; WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5; WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START + 6; WM_CAP_SET_CALLBACK_WAVESTREAM = WM_CAP_START + 7; WM_CAP_GET_USER_DATA = WM_CAP_START + 8; WM_CAP_SET_USER_DATA = WM_CAP_START + 9; WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10; WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11; WM_CAP_DRIVER_GET_NAMEA = WM_CAP_START + 12; WM_CAP_DRIVER_GET_VERSIONA = WM_CAP_START + 13; WM_CAP_DRIVER_GET_NAMEW = WM_CAP_UNICODE_START + 12; WM_CAP_DRIVER_GET_VERSIONW = WM_CAP_UNICODE_START + 13; WM_CAP_DRIVER_GET_NAME = WM_CAP_DRIVER_GET_NAMEA; WM_CAP_DRIVER_GET_VERSION = WM_CAP_DRIVER_GET_VERSIONA; WM_CAP_DRIVER_GET_CAPS = WM_CAP_START + 14; WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20; WM_CAP_FILE_GET_CAPTURE_FILEA = WM_CAP_START + 21; WM_CAP_FILE_SAVEASA = WM_CAP_START + 23; WM_CAP_FILE_SAVEDIBA = WM_CAP_START + 25; WM_CAP_FILE_SET_CAPTURE_FILEW = WM_CAP_UNICODE_START + 20; WM_CAP_FILE_GET_CAPTURE_FILEW = WM_CAP_UNICODE_START + 21; WM_CAP_FILE_SAVEASW = WM_CAP_UNICODE_START + 23; WM_CAP_FILE_SAVEDIBW = WM_CAP_UNICODE_START + 25; WM_CAP_FILE_SET_CAPTURE_FILE = WM_CAP_FILE_SET_CAPTURE_FILEA; WM_CAP_FILE_GET_CAPTURE_FILE = WM_CAP_FILE_GET_CAPTURE_FILEA; WM_CAP_FILE_SAVEAS = WM_CAP_FILE_SAVEASA; WM_CAP_FILE_SAVEDIB = WM_CAP_FILE_SAVEDIBA; // out of order to save on ifdefs. WM_CAP_FILE_ALLOCATE = WM_CAP_START + 22; WM_CAP_FILE_SET_INFOCHUNK = WM_CAP_START + 24; WM_CAP_EDIT_COPY = WM_CAP_START + 30; WM_CAP_SET_AUDIOFORMAT = WM_CAP_START + 35; WM_CAP_GET_AUDIOFORMAT = WM_CAP_START + 36; WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41; WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42; WM_CAP_DLG_VIDEODISPLAY = WM_CAP_START + 43; WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44; WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45; WM_CAP_DLG_VIDEOCOMPRESSION = WM_CAP_START + 46; WM_CAP_SET_PREVIEW = WM_CAP_START + 50; WM_CAP_SET_OVERLAY = WM_CAP_START + 51; WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52; WM_CAP_SET_SCALE = WM_CAP_START + 53; WM_CAP_GET_STATUS = WM_CAP_START + 54; WM_CAP_SET_SCROLL = WM_CAP_START + 55; WM_CAP_GRAB_FRAME = WM_CAP_START + 60; WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61; WM_CAP_SEQUENCE = WM_CAP_START + 62; WM_CAP_SEQUENCE_NOFILE = WM_CAP_START + 63; WM_CAP_SET_SEQUENCE_SETUP = WM_CAP_START + 64; WM_CAP_GET_SEQUENCE_SETUP = WM_CAP_START + 65; WM_CAP_SET_MCI_DEVICEA = WM_CAP_START + 66; WM_CAP_GET_MCI_DEVICEA = WM_CAP_START + 67; WM_CAP_SET_MCI_DEVICEW = WM_CAP_UNICODE_START + 66; WM_CAP_GET_MCI_DEVICEW = WM_CAP_UNICODE_START + 67; WM_CAP_SET_MCI_DEVICE = WM_CAP_SET_MCI_DEVICEA; WM_CAP_GET_MCI_DEVICE = WM_CAP_GET_MCI_DEVICEA; WM_CAP_STOP = WM_CAP_START + 68; WM_CAP_ABORT = WM_CAP_START + 69; WM_CAP_SINGLE_FRAME_OPEN = WM_CAP_START + 70; WM_CAP_SINGLE_FRAME_CLOSE = WM_CAP_START + 71; WM_CAP_SINGLE_FRAME = WM_CAP_START + 72; WM_CAP_PAL_OPENA = WM_CAP_START + 80; WM_CAP_PAL_SAVEA = WM_CAP_START + 81; WM_CAP_PAL_OPENW = WM_CAP_UNICODE_START + 80; WM_CAP_PAL_SAVEW = WM_CAP_UNICODE_START + 81; WM_CAP_PAL_OPEN = WM_CAP_PAL_OPENA; WM_CAP_PAL_SAVE = WM_CAP_PAL_SAVEA; WM_CAP_PAL_PASTE = WM_CAP_START + 82; WM_CAP_PAL_AUTOCREATE = WM_CAP_START + 83; WM_CAP_PAL_MANUALCREATE = WM_CAP_START + 84; // Following added post VFW 1.1. WM_CAP_SET_CALLBACK_CAPCONTROL = WM_CAP_START + 85; // Defines end of the message range. WM_CAP_UNICODE_END = WM_CAP_PAL_SAVEW; WM_CAP_END = WM_CAP_UNICODE_END; {-- Callback definitions -----------------------------------------------------}. Type. TCAPYIELDCALLBACK = function(hWnd: HWND): DWORD; stdcall; TCAPSTATUSCALLBACKW = function(hWnd: HWND; nID: int; lpsz: LPCWSTR): DWORD; stdcall; TCAPERRORCALLBACKW = function(hWnd: HWND; nID: int; lpsz: LPCWSTR): DWORD; stdcall; TCAPSTATUSCALLBACKA = function(hWnd: HWND; nID: int; lpsz: LPCSTR): DWORD; stdcall; TCAPERRORCALLBACKA = function(hWnd: HWND; nID: int; lpsz: LPCSTR): DWORD; stdcall; TCAPSTATUSCALLBACK = TCAPSTATUSCALLBACKA; TCAPERRORCALLBACK = TCAPERRORCALLBACKA; TCAPVIDEOCALLBACK = function(hWnd: HWND; lpVHdr: PVIDEOHDR): DWORD; stdcall; TCAPWAVECALLBACK = function(hWnd: HWND; lpWHdr: PWAVEHDR): DWORD; stdcall; TCAPCONTROLCALLBACK = function(hWnd: HWND; nState: int): DWORD; stdcall; {-- Structures ---------------------------------------------------------------}. Type. PCAPDRIVERCAPS = ^TCAPDRIVERCAPS; TCAPDRIVERCAPS = record. WDeviceIndex : UINT; // Driver index in system.ini. FHasOverlay : BOOL; // Can device overlay? FHasDlgVideoSource : BOOL; // Has Video source dlg? FHasDlgVideoFormat : BOOL; // Has Format dlg? FHasDlgVideoDisplay : BOOL; // Has External out dlg? FCaptureInitialized : BOOL; // Driver ready to capture? FDriverSuppliesPalettes : BOOL; // Can driver make palettes? // following always NULL on Win32. HVideoIn : THANDLE; // Driver In channel. HVideoOut : THANDLE; // Driver Out channel. HVideoExtIn : THANDLE; // Driver Ext In channel. HVideoExtOut : THANDLE; // Driver Ext Out channel. End; PCAPSTATUS = ^TCAPSTATUS; TCAPSTATUS = record. UiImageWidth : UINT ; // Width of the image. UiImageHeight : UINT ; // Height of the image. FLiveWindow : BOOL ; // Now Previewing video? FOverlayWindow : BOOL ; // Now Overlaying video? FScale : BOOL ; // Scale image to client? PtScroll : TPOINT ; // Scroll position. FUsingDefaultPalette : BOOL ; // Using default driver palette? FAudioHardware : BOOL ; // Audio hardware present? FCapFileExists : BOOL ; // Does capture file exist? DwCurrentVideoFrame : DWORD ; // # of video frames cap'td. DwCurrentVideoFramesDropped : DWORD ; // # of video frames dropped. DwCurrentWaveSamples : DWORD ; // # of wave samples cap'td. DwCurrentTimeElapsedMS : DWORD ; // Elapsed capture duration. HPalCurrent : HPALETTE; // Current palette in use. FCapturingNow : BOOL ; // Capture in progress? DwReturn : DWORD ; // Error value after any operation. WNumVideoAllocated : UINT ; // Actual number of video buffers. WNumAudioAllocated : UINT ; // Actual number of audio buffers. End; // Default values in parenthesis. PCAPTUREPARMS = ^TCAPTUREPARMS; TCAPTUREPARMS = record. DwRequestMicroSecPerFrame : DWORD ; // Requested capture rate. FMakeUserHitOKToCapture : BOOL ; // Show "Hit OK to cap" dlg? WPercentDropForError : UINT ; // Give error msg if > (10%). FYield : BOOL ; // Capture via background task? DwIndexSize : DWORD ; // Max index size in frames (32K). WChunkGranularity : UINT ; // Junk chunk granularity (2K). FUsingDOSMemory : BOOL ; // Use DOS buffers? WNumVideoRequested : UINT ; // # video buffers, If 0, autocalc. FCaptureAudio : BOOL ; // Capture audio? WNumAudioRequested : UINT ; // # audio buffers, If 0, autocalc. VKeyAbort : UINT ; // Virtual key causing abort. FAbortLeftMouse : BOOL ; // Abort on left mouse? FAbortRightMouse : BOOL ; // Abort on right mouse? FLimitEnabled : BOOL ; // Use wTimeLimit? WTimeLimit : UINT ; // Seconds to capture. FMCIControl : BOOL ; // Use MCI video source? FStepMCIDevice : BOOL ; // Step MCI device? DwMCIStartTime : DWORD ; // Time to start in MS. DwMCIStopTime : DWORD ; // Time to stop in MS. FStepCaptureAt2x : BOOL ; // Perform spatial averaging 2x. WStepCaptureAverageFrames : UINT ; // Temporal average n Frames. DwAudioBufferSize : DWORD ; // Size of audio bufs (0 = default). FDisableWriteCache : BOOL ; // Attempt to disable write cache. AVStreamMaster : UINT ; // Which stream controls length? End; {-- AVStreamMaster -----------------------------------------------------------}. // Since Audio and Video streams generally use non-synchronized capture. // clocks, this flag determines whether the audio stream is to be considered. // the master or controlling clock when writing the AVI file: // // AVSTREAMMASTER_AUDIO - Audio is master, video frame duration is forced. // to match audio duration (VFW 1.0, 1.1 default). // AVSTREAMMASTER_NONE - No master, audio and video streams may be of. // different lengths. Const. AVSTREAMMASTER_AUDIO = 0; // Audio master (VFW 1.0, 1.1). AVSTREAMMASTER_NONE = 1; // No master. Type. PCAPINFOCHUNK = ^TCAPINFOCHUNK; TCAPINFOCHUNK = record. FccInfoID : FOURCC; // Chunk ID, "ICOP" for copyright. LpData : PVOID; // pointer to data. CbData : DWORD; // size of lpData. End; {-- CapControlCallback states ------------------------------------------------}. Const. CONTROLCALLBACK_PREROLL = 1; // Waiting to start capture. CONTROLCALLBACK_CAPTURING = 2; // Now capturing. {-- Message crackers for above -----------------------------------------------}. // message wrapper macros are defined for the default messages only. Apps. // that wish to mix Ansi and UNICODE message sending will have to. // reference the _A and _W messages directly. Function capSetCallbackOnError(hwnd: HWND; fpProc: TCAPERRORCALLBACK): BOOL; Function capSetCallbackOnStatus(hwnd: HWND; fpProc: TCAPSTATUSCALLBACK): BOOL; Function capSetCallbackOnYield(hwnd: HWND; fpProc: TCAPYIELDCALLBACK): BOOL; Function capSetCallbackOnFrame(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL; Function capSetCallbackOnVideoStream(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL; Function capSetCallbackOnWaveStream(hwnd: HWND; fpProc: TCAPWAVECALLBACK): BOOL; Function capSetCallbackOnCapControl(hwnd: HWND; fpProc: TCAPCONTROLCALLBACK): BOOL; Function capSetUserData(hwnd: HWND; lUser: DWORD): BOOL; Function capGetUserData(hwnd: HWND): DWORD; Function capDriverConnect(hwnd: HWND; i: INT): BOOL; Function capDriverDisconnect(hwnd: HWND): BOOL; Function capDriverGetName(hwnd: HWND; szName: LPSTR; wSize: WORD): BOOL; Function capDriverGetVersion(hwnd: HWND; szVer: LPSTR; wSize: WORD): BOOL; Function capDriverGetCaps(hwnd: HWND; s: PCAPDRIVERCAPS; wSize: WORD): BOOL; Function capFileSetCaptureFile(hwnd: HWND; szName: LPCSTR): BOOL; Function capFileGetCaptureFile(hwnd: HWND; szName: LPSTR; wSize: WORD): BOOL; Function capFileAlloc(hwnd: HWND; dwSize: DWORD): BOOL; Function capFileSaveAs(hwnd: HWND; szName: LPCSTR): BOOL; Function capFileSetInfoChunk(hwnd: HWND; lpInfoChunk: PCAPINFOCHUNK): BOOL; Function capFileSaveDIB(hwnd: HWND; szName: LPCSTR): BOOL; Function capEditCopy(hwnd: HWND): BOOL; Function capSetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): BOOL; Function capGetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): DWORD; Function capGetAudioFormatSize(hwnd: HWND): DWORD; Function capDlgVideoFormat(hwnd: HWND): BOOL; Function capDlgVideoSource(hwnd: HWND): BOOL; Function capDlgVideoDisplay(hwnd: HWND): BOOL; Function capDlgVideoCompression(hwnd: HWND): BOOL; Function capGetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): DWORD; Function capGetVideoFormatSize(hwnd: HWND): DWORD; Function capSetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): BOOL; Function capPreview(hwnd: HWND; f: BOOL): BOOL; Function capPreviewRate(hwnd: HWND; wMS: WORD): BOOL; Function capOverlay(hwnd: HWND; f: BOOL): BOOL; Function capPreviewScale(hwnd: HWND; f: BOOL): BOOL; Function capGetStatus(hwnd: HWND; s: PCAPSTATUS; wSize: WORD): BOOL; Function capSetScrollPos(hwnd: HWND; lpP: PPOINT): BOOL; Function capGrabFrame(hwnd: HWND): BOOL; Function capGrabFrameNoStop(hwnd: HWND): BOOL; Function capCaptureSequence(hwnd: HWND): BOOL; Function capCaptureSequenceNoFile(hwnd: HWND): BOOL; Function capCaptureStop(hwnd: HWND): BOOL; Function capCaptureAbort(hwnd: HWND): BOOL; Function capCaptureSingleFrameOpen(hwnd: HWND): BOOL; Function capCaptureSingleFrameClose(hwnd: HWND): BOOL; Function capCaptureSingleFrame(hwnd: HWND): BOOL; Function capCaptureGetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL; Function capCaptureSetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL; Function capSetMCIDeviceName(hwnd: HWND; szName: LPCSTR): BOOL; Function capGetMCIDeviceName(hwnd: HWND; szName: LPSTR; wSize: WORD): BOOL; Function capPaletteOpen(hwnd: HWND; szName: LPCSTR): BOOL; Function capPaletteSave(hwnd: HWND; szName: LPCSTR): BOOL; Function capPalettePaste(hwnd: HWND): BOOL; Function capPaletteAuto(hwnd: HWND; iFrames, iColors: INT): BOOL; Function capPaletteManual(hwnd: HWND; fGrab: BOOL; iColors: INT): BOOL; {-- The only exported functions from AVICAP.DLL ------------------------------}. Function capCreateCaptureWindowA( LpszWindowName : LPCSTR; DwStyle : DWORD; X, y : int; NWidth, nHeight : int; HwndParent : HWND; NID : int. ): HWND; stdcall; Function capGetDriverDescriptionA( WDriverIndex : UINT; LpszName : LPSTR; CbName : int; LpszVer : LPSTR; CbVer : int. ): BOOL; stdcall; Function capCreateCaptureWindowW( LpszWindowName : LPCWSTR; DwStyle : DWORD; X, y : int; NWidth, nHeight : int; HwndParent : HWND; NID : int. ): HWND; stdcall; Function capGetDriverDescriptionW( WDriverIndex : UINT; LpszName : LPWSTR; CbName : int; LpszVer : LPWSTR; CbVer : int. ): BOOL; stdcall; Function capCreateCaptureWindow( LpszWindowName : LPCSTR; DwStyle : DWORD; X, y : int; NWidth, nHeight : int; HwndParent : HWND; NID : int. ): HWND; stdcall; // capCreateCaptureWindowA. Function capGetDriverDescription( WDriverIndex : UINT; LpszName : LPSTR; CbName : int; LpszVer : LPSTR; CbVer : int. ): BOOL; stdcall; // capGetDriverDescriptionA. {-- New information chunk IDs ------------------------------------------------}. Const. InfotypeDIGITIZATION_TIME = $54494449; // mmioFOURCC ('I','D','I','T'). InfotypeSMPTE_TIME = $504D5349; // mmioFOURCC ('I','S','M','P'). {-- String IDs from status and error callbacks -------------------------------}. IDS_CAP_BEGIN = 300; // "Capture Start". IDS_CAP_END = 301; // "Capture End". IDS_CAP_INFO = 401; // "%s". IDS_CAP_OUTOFMEM = 402; // "Out of memory". IDS_CAP_FILEEXISTS = 403; // "File '%s' exists -- overwrite it?". IDS_CAP_ERRORPALOPEN = 404; // "Error opening palette '%s'". IDS_CAP_ERRORPALSAVE = 405; // "Error saving palette '%s'". IDS_CAP_ERRORDIBSAVE = 406; // "Error saving frame '%s'". IDS_CAP_DEFAVIEXT = 407; // "avi". IDS_CAP_DEFPALEXT = 408; // "pal". IDS_CAP_CANTOPEN = 409; // "Cannot open '%s'". IDS_CAP_SEQ_MSGSTART = 410; // "Select OK to start capture\nof video sequence\nto %s.". IDS_CAP_SEQ_MSGSTOP = 411; // "Hit ESCAPE or click to end capture". IDS_CAP_VIDEDITERR = 412; // "An error occurred while trying to run VidEdit.". IDS_CAP_READONLYFILE = 413; // "The file '%s' is a read-only file.". IDS_CAP_WRITEERROR = 414; // "Unable to write to file '%s'.\nDisk may be full.". IDS_CAP_NODISKSPACE = 415; // "There is no space to create a capture file on the specified device.". IDS_CAP_SETFILESIZE = 416; // "Set File Size". IDS_CAP_SAVEASPERCENT = 417; // "SaveAs: %2ld%% Hit Escape to abort.". IDS_CAP_DRIVER_ERROR = 418; // Driver specific error message. IDS_CAP_WAVE_OPEN_ERROR = 419; // "Error: Cannot open the wave input device.\nCheck sample size, frequency, and channels.". IDS_CAP_WAVE_ALLOC_ERROR = 420; // "Error: Out of memory for wave buffers.". IDS_CAP_WAVE_PREPARE_ERROR = 421; // "Error: Cannot prepare wave buffers.". IDS_CAP_WAVE_ADD_ERROR = 422; // "Error: Cannot add wave buffers.". IDS_CAP_WAVE_SIZE_ERROR = 423; // "Error: Bad wave size.". IDS_CAP_VIDEO_OPEN_ERROR = 424; // "Error: Cannot open the video input device.". IDS_CAP_VIDEO_ALLOC_ERROR = 425; // "Error: Out of memory for video buffers.". IDS_CAP_VIDEO_PREPARE_ERROR = 426; // "Error: Cannot prepare video buffers.". IDS_CAP_VIDEO_ADD_ERROR = 427; // "Error: Cannot add video buffers.". IDS_CAP_VIDEO_SIZE_ERROR = 428; // "Error: Bad video size.". IDS_CAP_FILE_OPEN_ERROR = 429; // "Error: Cannot open capture file.". IDS_CAP_FILE_WRITE_ERROR = 430; // "Error: Cannot write to capture file. Disk may be full.". IDS_CAP_RECORDING_ERROR = 431; // "Error: Cannot write to capture file. Data rate too high or disk full.". IDS_CAP_RECORDING_ERROR2 = 432; // "Error while recording". IDS_CAP_AVI_INIT_ERROR = 433; // "Error: Unable to initialize for capture.". IDS_CAP_NO_FRAME_CAP_ERROR = 434; // "Warning: No frames captured.\nConfirm that vertical sync interrupts\nare configured and enabled.". IDS_CAP_NO_PALETTE_WARN = 435; // "Warning: Using default palette.". IDS_CAP_MCI_CONTROL_ERROR = 436; // "Error: Unable to access MCI device.". IDS_CAP_MCI_CANT_STEP_ERROR = 437; // "Error: Unable to step MCI device.". IDS_CAP_NO_AUDIO_CAP_ERROR = 438; // "Error: No audio data captured.\nCheck audio card settings.". IDS_CAP_AVI_DRAWDIB_ERROR = 439; // "Error: Unable to draw this data format.". IDS_CAP_COMPRESSOR_ERROR = 440; // "Error: Unable to initialize compressor.". IDS_CAP_AUDIO_DROP_ERROR = 441; // "Error: Audio data was lost during capture, reduce capture rate.". {-- Status string IDs --------------------------------------------------------}. IDS_CAP_STAT_LIVE_MODE = 500; // "Live window". IDS_CAP_STAT_OVERLAY_MODE = 501; // "Overlay window". IDS_CAP_STAT_CAP_INIT = 502; // "Setting up for capture - Please wait". IDS_CAP_STAT_CAP_FINI = 503; // "Finished capture, now writing frame %ld". IDS_CAP_STAT_PALETTE_BUILD = 504; // "Building palette map". IDS_CAP_STAT_OPTPAL_BUILD = 505; // "Computing optimal palette". IDS_CAP_STAT_I_FRAMES = 506; // "%d frames". IDS_CAP_STAT_L_FRAMES = 507; // "%ld frames". IDS_CAP_STAT_CAP_L_FRAMES = 508; // "Captured %ld frames". IDS_CAP_STAT_CAP_AUDIO = 509; // "Capturing audio". IDS_CAP_STAT_VIDEOCURRENT = 510; // "Captured %ld frames (%ld dropped) %d.%03d sec.". IDS_CAP_STAT_VIDEOAUDIO = 511; // "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps). %ld audio bytes (%d,%03d sps)". IDS_CAP_STAT_VIDEOONLY = 512; // "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps)". IDS_CAP_STAT_FRAMESDROPPED = 513; // "Dropped %ld of %ld frames (%d.%02d%%) during capture.". {== FilePreview dialog =======================================================}. Function GetOpenFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall; Function GetSaveFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall; Function GetOpenFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall; Function GetSaveFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall; Function GetOpenFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; // GetOpenFileNamePreviewA. Function GetSaveFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; // GetSaveFileNamePreviewA. Implementation. Function MKFOURCC( ch0, ch1, ch2, ch3: Char ): FOURCC; Begin. Result := (DWord(Ord(ch0))) or. (DWord(Ord(ch1)) shl 8) or. (DWord(Ord(ch2)) shl 16) or. (DWord(Ord(ch3)) shl 24); End; Function mmioFOURCC( ch0, ch1, ch2, ch3: Char ): FOURCC; Begin. Result := MKFOURCC(ch0,ch1,ch2,ch3); End; Function aviTWOCC(ch0, ch1: Char): TWOCC; Begin. Result := (Word(Ord(ch0))) or. (Word(Ord(ch1)) shl 8); End; {-- Query macros -------------------------------------------------------------}. Function ICQueryAbout(hic: HIC): BOOL; Begin. Result := ICSendMessage(hic, ICM_ABOUT, $FFFFFFFF, ICMF_ABOUT_QUERY) = ICERR_OK; End; Function ICAbout(hic: HIC; hwnd: HWND): DWORD; Begin. Result := ICSendMessage(hic, ICM_ABOUT, hwnd, 0); End; Function ICQueryConfigure(hic: HIC): BOOL; Begin. Result := ICSendMessage(hic, ICM_CONFIGURE, $FFFFFFFF, ICMF_CONFIGURE_QUERY) = ICERR_OK; End; Function ICConfigure(hic: HIC; hwnd: HWND): DWORD; Begin. Result := ICSendMessage(hic, ICM_CONFIGURE, hwnd, 0); End; {-- Get/Set state macros -----------------------------------------------------}. Function ICGetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD; Begin. Result := ICSendMessage(hic, ICM_GETSTATE, DWORD(pv), cb); End; Function ICSetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD; Begin. Result := ICSendMessage(hic, ICM_SETSTATE, DWORD(pv), cb); End; Function ICGetStateSize(hic: HIC): DWORD; Begin. Result := ICGetState(hic, nil, 0); End; {-- Get value macros ---------------------------------------------------------}. Function ICGetDefaultQuality(hic: HIC): DWORD; Begin. ICSendMessage(hic, ICM_GETDEFAULTQUALITY, DWORD(@Result), sizeof(Result)); End; Function ICGetDefaultKeyFrameRate(hic: HIC): DWORD; Begin. ICSendMessage(hic, ICM_GETDEFAULTKEYFRAMERATE, DWORD(@Result), sizeof(Result)); End; {-- Draw window macro --------------------------------------------------------}. Function ICDrawWindow(hic: HIC; prc: PRECT): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_WINDOW, DWORD(prc), sizeof(prc^)); End; {-- ICCompressBegin() - start compression from a source fmt to a dest fmt ----}. Function ICCompressBegin(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_COMPRESS_BEGIN, DWORD(lpbiInput), DWORD(lpbiOutput)); End; {-- ICCompressQuery() - determines if compression from src to dst is supp ----}. Function ICCompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_COMPRESS_QUERY, DWORD(lpbiInput), DWORD(lpbiOutput)); End; {-- ICCompressGetFormat() - get the output format (fmt of compressed) --------}. // if lpbiOutput is nil return the size in bytes needed for format. Function ICCompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_COMPRESS_GET_FORMAT, DWORD(lpbiInput), DWORD(lpbiOutput)); End; Function ICCompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD; Begin. Result := ICCompressGetFormat(hic, lpbi, nil); End; {-- ICCompressSize() - return the maximal size of a compressed frame ---------}. Function ICCompressGetSize(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_COMPRESS_GET_SIZE, DWORD(lpbiInput), DWORD(lpbiOutput)); End; Function ICCompressEnd(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_COMPRESS_END, 0, 0); End; {-- ICDecompressBegin() - start compression from src fmt to a dest fmt -------}. Function ICDecompressBegin(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_DECOMPRESS_BEGIN, DWORD(lpbiInput), DWORD(lpbiOutput)); End; {-- ICDecompressQuery() - determines if compression is supported -------------}. Function ICDecompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_DECOMPRESS_QUERY, DWORD(lpbiInput), DWORD(lpbiOutput)); End; {-- ICDecompressGetFormat - get the output fmt (fmt of uncompressed data) ----}. // if lpbiOutput is NULL return the size in bytes needed for format. Function ICDecompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_DECOMPRESS_GET_FORMAT, DWORD(lpbiInput), DWORD(lpbiOutput)); End; Function ICDecompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD; Begin. Result := ICDecompressGetFormat(hic, lpbi, nil); End; {-- ICDecompressGetPalette() - get the output palette ------------------------}. Function ICDecompressGetPalette(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_DECOMPRESS_GET_PALETTE, DWORD(lpbiInput), DWORD(lpbiOutput)); End; Function ICDecompressSetPalette(hic: HIC; lpbiPalette: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_DECOMPRESS_SET_PALETTE, DWORD(lpbiPalette), 0); End; Function ICDecompressEnd(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DECOMPRESS_END, 0, 0); End; {-- ICDecompressEx() - decompress a single frame -----------------------------}. Function ICDecompressEx( Hic : HIC; DwFlags : DWORD; LpbiSrc : PBITMAPINFOHEADER; LpSrc : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; LpbiDst : PBITMAPINFOHEADER; LpDst : PVOID; XDst : int; YDst : int; DxDst : int; DyDst : int. ): DWORD; stdcall; Var. Ic : TICDECOMPRESSEX; Begin. Ic.dwFlags := dwFlags; Ic.lpbiSrc := lpbiSrc; Ic.lpSrc := lpSrc; Ic.xSrc := xSrc; Ic.ySrc := ySrc; Ic.dxSrc := dxSrc; Ic.dySrc := dySrc; Ic.lpbiDst := lpbiDst; Ic.lpDst := lpDst; Ic.xDst := xDst; Ic.yDst := yDst; Ic.dxDst := dxDst; Ic.dyDst := dyDst; // note that ICM swaps round the length and pointer. // length in lparam2, pointer in lparam1. Result := ICSendMessage(hic, ICM_DECOMPRESSEX, DWORD(@ic), sizeof(ic)); End; {-- ICDecompressExBegin() - start compression from a src fmt to a dest fmt ---}. Function ICDecompressExBegin( Hic : HIC; DwFlags : DWORD; LpbiSrc : PBITMAPINFOHEADER; LpSrc : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; LpbiDst : PBITMAPINFOHEADER; LpDst : PVOID; XDst : int; YDst : int; DxDst : int; DyDst : int. ): DWORD; stdcall; Var. Ic : TICDECOMPRESSEX ; Begin. Ic.dwFlags := dwFlags; Ic.lpbiSrc := lpbiSrc; Ic.lpSrc := lpSrc; Ic.xSrc := xSrc; Ic.ySrc := ySrc; Ic.dxSrc := dxSrc; Ic.dySrc := dySrc; Ic.lpbiDst := lpbiDst; Ic.lpDst := lpDst; Ic.xDst := xDst; Ic.yDst := yDst; Ic.dxDst := dxDst; Ic.dyDst := dyDst; // note that ICM swaps round the length and pointer. // length in lparam2, pointer in lparam1. Result := ICSendMessage(hic, ICM_DECOMPRESSEX_BEGIN, DWORD(@ic), sizeof(ic)); End; {-- ICDecompressExQuery() ----------------------------------------------------}. Function ICDecompressExQuery( Hic : HIC; DwFlags : DWORD; LpbiSrc : PBITMAPINFOHEADER; LpSrc : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; LpbiDst : PBITMAPINFOHEADER; LpDst : PVOID; XDst : int; YDst : int; DxDst : int; DyDst : int. ): DWORD; stdcall; Var. Ic : TICDECOMPRESSEX; Begin. Ic.dwFlags := dwFlags; Ic.lpbiSrc := lpbiSrc; Ic.lpSrc := lpSrc; Ic.xSrc := xSrc; Ic.ySrc := ySrc; Ic.dxSrc := dxSrc; Ic.dySrc := dySrc; Ic.lpbiDst := lpbiDst; Ic.lpDst := lpDst; Ic.xDst := xDst; Ic.yDst := yDst; Ic.dxDst := dxDst; Ic.dyDst := dyDst; // note that ICM swaps round the length and pointer. // length in lparam2, pointer in lparam1. Result := ICSendMessage(hic, ICM_DECOMPRESSEX_QUERY, DWORD(@ic), sizeof(ic)); End; Function ICDecompressExEnd(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DECOMPRESSEX_END, 0, 0). End; Function ICDrawSuggestFormat( Hic : HIC; LpbiIn : PBITMAPINFOHEADER; LpbiOut : PBITMAPINFOHEADER; DxSrc : int; DySrc : int; DxDst : int; DyDst : int; HicDecomp : HIC. ): DWORD; stdcall; Var. Ic : TICDRAWSUGGEST; Begin. Ic.lpbiIn := lpbiIn; Ic.lpbiSuggest := lpbiOut; Ic.dxSrc := dxSrc; Ic.dySrc := dySrc; Ic.dxDst := dxDst; Ic.dyDst := dyDst; Ic.hicDecompressor := hicDecomp; // note that ICM swaps round the length and pointer. // length in lparam2, pointer in lparam1. Result := ICSendMessage(hic, ICM_DRAW_SUGGESTFORMAT, DWORD(@ic), sizeof(ic)); End; {-- ICDrawQuery() - determines if the compressor is willing to render fmt ----}. Function ICDrawQuery(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_QUERY, DWORD(lpbiInput), 0); End; Function ICDrawChangePalette(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_CHANGEPALETTE, DWORD(lpbiInput), 0); End; Function ICGetBuffersWanted(hic: HIC; lpdwBuffers: PDWORD): DWORD; Begin. Result := ICSendMessage(hic, ICM_GETBUFFERSWANTED, DWORD(lpdwBuffers), 0); End; Function ICDrawEnd(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_END, 0, 0); End; Function ICDrawStart(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_START, 0, 0); End; Function ICDrawStartPlay(hic: HIC; lFrom, lTo: DWORD): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_START_PLAY, lFrom, lTo); End; Function ICDrawStop(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_STOP, 0, 0); End; Function ICDrawStopPlay(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_STOP_PLAY, 0, 0); End; Function ICDrawGetTime(hic: HIC; lplTime: PDWORD): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_GETTIME, DWORD(lplTime), 0); End; Function ICDrawSetTime(hic: HIC; lTime: DWORD): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_SETTIME, lTime, 0); End; Function ICDrawRealize(hic: HIC; hdc: HDC; fBackground: BOOL): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_REALIZE, DWORD(hdc), DWORD(fBackground)); End; Function ICDrawFlush(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_FLUSH, 0, 0); End; Function ICDrawRenderBuffer(hic: HIC): DWORD; Begin. Result := ICSendMessage(hic, ICM_DRAW_RENDERBUFFER, 0, 0); End; {-- ICSetStatusProc() - Set the status callback function ---------------------}. // ICMessage is not supported on NT. Function ICSetStatusProc( Hic : HIC; DwFlags : DWORD; LParam : DWORD; FpfnStatus : TICStatusProc. ): DWORD; stdcall; Var. Ic : TICSETSTATUSPROC; Begin. Ic.dwFlags := dwFlags; Ic.lParam := lParam; Ic.Status := fpfnStatus; // note that ICM swaps round the length and pointer. // length in lparam2, pointer in lparam1. Result := ICSendMessage(hic, ICM_SET_STATUS_PROC, DWORD(@ic), sizeof(ic)); End; {== Helper routines for DrawDib and MCIAVI... ================================}. Function ICDecompressOpen(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER): HIC; Begin. Result := ICLocate(fccType, fccHandler, lpbiIn, lpbiOut, ICMODE_DECOMPRESS); End; Function ICDrawOpen(fccType, fccHandler: DWORD; lpbiIn: PBITMAPINFOHEADER): HIC; Begin. Result := ICLocate(fccType, fccHandler, lpbiIn, nil, ICMODE_DRAW); End; {-- DrawDibUpdate() - redraw last image (may only be valid with DDF_BUFFER) --}. Function DrawDibUpdate(hdd: HDRAWDIB; hdc: HDC; x, y: int): BOOL; Begin. Result := DrawDibDraw(hdd, hdc, x, y, 0, 0, nil, nil, 0, 0, 0, 0, DDF_UPDATE); End; {== Useful macros ============================================================}. {-- Macro to get stream number out of a FOURCC ckid --------------------------}. Function FromHex(n: BYTE): BYTE; Begin. If n >= Ord('A') then. Result := Ord(n) + 10 - Ord('A'). Else. Result := Ord(n) - Ord('0'); End; Function StreamFromFOURCC(fcc: DWORD): BYTE; Begin. Result := (FromHex(Lo(LoWord(fcc))) shl 4) + FromHex(Hi(LoWord(fcc))); End; {-- Macro to get TWOCC chunk type out of a FOURCC ckid -----------------------}. Function TWOCCFromFOURCC(fcc: DWORD): WORD; Begin. Result := HiWord(fcc); End; {-- Macro to make a ckid for a chunk out of a TWOCC and a stream num (0-255) -}. Function ToHex(n: BYTE): BYTE; Begin. If n > 9 then. Result := n - 10 + Ord('A'). Else. Result := n + Ord('0'); End; Function MAKEAVICKID(tcc: WORD; stream: BYTE): DWORD; Begin. Result := MakeLONG((ToHex(stream and $0F) shl 8) or ToHex((stream and $F0) shr 4),tcc); End; {-- Helper macros ------------------------------------------------------------}. Function AVIStreamSampleToSample(pavi1, pavi2: PAVISTREAM; l: DWORD): DWORD; Begin. Result := AVIStreamTimeToSample(pavi1,AVIStreamSampleToTime(pavi2, l)); End; Function AVIStreamNextSample(pavi: PAVISTREAM; l: DWORD): DWORD; Begin. Result := AVIStreamFindSample(pavi,l+1,FIND_NEXT or FIND_ANY); End; Function AVIStreamPrevSample(pavi: PAVISTREAM; l: DWORD): DWORD; Begin. Result := AVIStreamFindSample(pavi,l-1,FIND_PREV or FIND_ANY); End; Function AVIStreamNearestSample(pavi: PAVISTREAM; l: DWORD): DWORD; Begin. Result := AVIStreamFindSample(pavi,l,FIND_PREV or FIND_ANY); End; Function AVIStreamNextKeyFrame(pavi: PAVISTREAM; l: DWORD): DWORD; Begin. Result := AVIStreamFindSample(pavi,l+1,FIND_NEXT or FIND_KEY); End; Function AVIStreamPrevKeyFrame(pavi: PAVISTREAM; l: DWORD): DWORD; Begin. Result := AVIStreamFindSample(pavi,l-1,FIND_PREV or FIND_KEY); End; Function AVIStreamNearestKeyFrame(pavi: PAVISTREAM; l: DWORD): DWORD; Begin. Result := AVIStreamFindSample(pavi,l,FIND_PREV or FIND_KEY). End; Function AVIStreamIsKeyFrame(pavi: PAVISTREAM; l: DWORD): BOOL; Begin. Result := AVIStreamNearestKeyFrame(pavi,l) = l; End; Function AVIStreamPrevSampleTime(pavi: PAVISTREAM; t: DWORD): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamPrevSample(pavi,AVIStreamTimeToSample(pavi,t))); End; Function AVIStreamNextSampleTime(pavi: PAVISTREAM; t: DWORD): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamNextSample(pavi,AVIStreamTimeToSample(pavi,t))); End; Function AVIStreamNearestSampleTime(pavi: PAVISTREAM; t: DWORD): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamNearestSample(pavi,AVIStreamTimeToSample(pavi,t))); End; Function AVIStreamNextKeyFrameTime(pavi: PAVISTREAM; t: DWORD): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamNextKeyFrame(pavi,AVIStreamTimeToSample(pavi, t))); End; Function AVIStreamPrevKeyFrameTime(pavi: PAVISTREAM; t: DWORD): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamPrevKeyFrame(pavi,AVIStreamTimeToSample(pavi, t))); End; Function AVIStreamNearestKeyFrameTime(pavi: PAVISTREAM; t: DWORD): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamNearestKeyFrame(pavi,AVIStreamTimeToSample(pavi, t))); End; Function AVIStreamStartTime(pavi: PAVISTREAM): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamStart(pavi)); End; Function AVIStreamLengthTime(pavi: PAVISTREAM): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamLength(pavi)); End; Function AVIStreamEnd(pavi: PAVISTREAM): DWORD; Begin. Result := AVIStreamStart(pavi) + AVIStreamLength(pavi); End; Function AVIStreamEndTime(pavi: PAVISTREAM): DWORD; Begin. Result := AVIStreamSampleToTime(pavi, AVIStreamEnd(pavi)); End; Function AVIStreamSampleSize(pavi: PAVISTREAM; lPos: DWORD; plSize: PDWORD): DWORD; Begin. Result := AVIStreamRead(pavi,lPos,1,nil,0,plSize,nil); End; Function AVIStreamFormatSize(pavi: PAVISTREAM; lPos: DWORD; plSize: PDWORD): HResult; Begin. Result := AVIStreamReadFormat(pavi,lPos,nil,plSize); End; Function AVIStreamDataSize(pavi: PAVISTREAM; fcc: DWORD; plSize: PDWORD): HResult; Begin. Result := AVIStreamReadData(pavi,fcc,nil,plSize). End; {== MCIWnd ===================================================================}. Function MCIWndSM(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD; Begin. Result := SendMessage(hWnd, Msg, wParam, lParam); End; {-- Can macros ---------------------------------------------------------------}. Function MCIWndCanPlay(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd,MCIWNDM_CAN_PLAY,0,0) <> 0; End; Function MCIWndCanRecord(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd,MCIWNDM_CAN_RECORD,0,0) <> 0; End; Function MCIWndCanSave(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd,MCIWNDM_CAN_SAVE,0,0) <> 0; End; Function MCIWndCanWindow(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd,MCIWNDM_CAN_WINDOW,0,0) <> 0; End; Function MCIWndCanEject(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd,MCIWNDM_CAN_EJECT,0,0) <> 0; End; Function MCIWndCanConfig(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd,MCIWNDM_CAN_CONFIG,0,0) <> 0; End; Function MCIWndPaletteKick(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd,MCIWNDM_PALETTEKICK,0,0) <> 0; End; Function MCIWndSave(hwnd: HWND; szFile: LPCSTR): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_SAVE, 0, LPARAM(szFile)); End; Function MCIWndSaveDialog(hwnd: HWND): DWORD; Begin. Result := MCIWndSave(hwnd, LPCSTR(-1)); End; // If you dont give a device it will use the current device.... Function MCIWndNew(hwnd: HWND; lp: PVOID): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_NEW, 0, LPARAM(lp)); End; Function MCIWndRecord(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_RECORD, 0, 0); End; Function MCIWndOpen(hwnd: HWND; sz: LPCSTR; f: BOOL): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_OPEN, WPARAM(f), LPARAM(sz)); End; Function MCIWndOpenDialog(hwnd: HWND): DWORD; Begin. Result := MCIWndOpen(hwnd, LPCSTR(-1), False); End; Function MCIWndClose(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_CLOSE, 0, 0); End; Function MCIWndPlay(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_PLAY, 0, 0); End; Function MCIWndStop(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_STOP, 0, 0); End; Function MCIWndPause(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_PAUSE, 0, 0); End; Function MCIWndResume(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_RESUME, 0, 0); End; Function MCIWndSeek(hwnd: HWND; lPos: DWORD): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_SEEK, 0, lPos); End; Function MCIWndEject(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_EJECT, 0, 0); End; Function MCIWndHome(hwnd: HWND): DWORD; Begin. Result := MCIWndSeek(hwnd, MCIWND_START); End; Function MCIWndEnd(hwnd: HWND): DWORD; Begin. Result := MCIWndSeek(hwnd, MCIWND_END); End; Function MCIWndGetSource(hwnd: HWND; prc: PRECT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GET_SOURCE, 0, LPARAM(prc)); End; Function MCIWndPutSource(hwnd: HWND; prc: PRECT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_PUT_SOURCE, 0, LPARAM(prc)); End; Function MCIWndGetDest(hwnd: HWND; prc: PRECT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GET_DEST, 0, LPARAM(prc)); End; Function MCIWndPutDest(hwnd: HWND; prc: PRECT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_PUT_DEST, 0, LPARAM(prc)); End; Function MCIWndPlayReverse(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_PLAYREVERSE, 0, 0); End; Function MCIWndPlayFrom(hwnd: HWND; lPos: DWORD): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_PLAYFROM, 0, lPos); End; Function MCIWndPlayTo(hwnd: HWND; lPos: DWORD): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_PLAYTO, 0, lPos); End; Function MCIWndPlayFromTo(hwnd: HWND; lStart, lEnd: DWORD): DWORD; Begin. MCIWndSeek(hwnd, lStart); Result := MCIWndPlayTo(hwnd, lEnd); End; Function MCIWndGetDeviceID(hwnd: HWND): UINT; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETDEVICEID, 0, 0); End; Function MCIWndGetAlias(hwnd: HWND): UINT; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETALIAS, 0, 0); End; Function MCIWndGetMode(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETMODE, len, LPARAM(lp)); End; Function MCIWndGetPosition(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETPOSITION, 0, 0); End; Function MCIWndGetPositionString(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETPOSITION, len, LPARAM(lp)); End; Function MCIWndGetStart(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETSTART, 0, 0); End; Function MCIWndGetLength(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETLENGTH, 0, 0); End; Function MCIWndGetEnd(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETEND, 0, 0); End; Function MCIWndStep(hwnd: HWND; n: DWORD): DWORD; Begin. Result := MCIWndSM(hwnd, MCI_STEP, 0, n); End; Procedure MCIWndDestroy(hwnd: HWND); Begin. MCIWndSM(hwnd, WM_CLOSE, 0, 0); End; Procedure MCIWndSetZoom(hwnd: HWND; iZoom: UINT); Begin. MCIWndSM(hwnd, MCIWNDM_SETZOOM, 0, iZoom); End; Function MCIWndGetZoom(hwnd: HWND): UINT; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETZOOM, 0, 0); End; Function MCIWndSetVolume(hwnd: HWND; iVol: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_SETVOLUME, 0, iVol); End; Function MCIWndGetVolume(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETVOLUME, 0, 0); End; Function MCIWndSetSpeed(hwnd: HWND; iSpeed: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_SETSPEED, 0, iSpeed); End; Function MCIWndGetSpeed(hwnd: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETSPEED, 0, 0); End; Function MCIWndSetTimeFormat(hwnd: HWND; lp: LPCSTR): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_SETTIMEFORMAT, 0, LPARAM(lp)); End; Function MCIWndGetTimeFormat(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETTIMEFORMAT, len, LPARAM(lp)); End; Procedure MCIWndValidateMedia(hwnd: HWND); Begin. MCIWndSM(hwnd, MCIWNDM_VALIDATEMEDIA, 0, 0); End; Procedure MCIWndSetRepeat(hwnd: HWND; f: BOOL); Begin. MCIWndSM(hwnd, MCIWNDM_SETREPEAT, 0, LPARAM(f)); End; Function MCIWndGetRepeat(hwnd: HWND): BOOL; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETREPEAT, 0, 0) <> 0; End; Function MCIWndUseFrames(hwnd: HWND): DWORD; Begin. Result := MCIWndSetTimeFormat(hwnd, 'frames'); End; Function MCIWndUseTime(hwnd: HWND): DWORD; Begin. Result := MCIWndSetTimeFormat(hwnd, 'ms'); End; Procedure MCIWndSetActiveTimer(hwnd: HWND; active: UINT); Begin. MCIWndSM(hwnd, MCIWNDM_SETACTIVETIMER, active, 0); End; Procedure MCIWndSetInactiveTimer(hwnd: HWND; inactive: UINT); Begin. MCIWndSM(hwnd, MCIWNDM_SETINACTIVETIMER, inactive, 0); End; Procedure MCIWndSetTimers(hwnd: HWND; active, inactive: UINT); Begin. MCIWndSM(hwnd, MCIWNDM_SETTIMERS, active, inactive); End; Function MCIWndGetActiveTimer(hwnd: HWND): UINT; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETACTIVETIMER, 0, 0); End; Function MCIWndGetInactiveTimer(hwnd: HWND): UINT; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETINACTIVETIMER, 0, 0); End; Function MCIWndRealize(hwnd: HWND; fBkgnd: BOOL): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_REALIZE, WPARAM(fBkgnd), 0); End; Function MCIWndSendString(hwnd: HWND; sz: LPCSTR): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_SENDSTRING, 0, LPARAM(sz)); End; Function MCIWndReturnString(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_RETURNSTRING, len, LPARAM(lp)); End; Function MCIWndGetError(hwnd: HWND; lp: LPSTR; len: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETERROR, len, LPARAM(lp)); End; Function MCIWndGetPalette(hwnd: HWND): HPALETTE; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETPALETTE, 0, 0); End; Function MCIWndSetPalette(hwnd: HWND; hpal: HPALETTE): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_SETPALETTE, hpal, 0); End; Function MCIWndGetFileName(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETFILENAME, len, LPARAM(lp)); End; Function MCIWndGetDevice(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETDEVICE, len, LPARAM(lp)); End; Function MCIWndGetStyles(hwnd: HWND): UINT; Begin. Result := MCIWndSM(hwnd, MCIWNDM_GETSTYLES, 0, 0); End; Function MCIWndChangeStyles(hwnd: HWND; mask: UINT; value: DWORD): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_CHANGESTYLES, mask, value); End; Function MCIWndOpenInterface(hwnd: HWND; pUnk: PUNKNOWN): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_OPENINTERFACE, 0, LPARAM(pUnk)); End; Function MCIWndSetOwner(hwnd: HWND; hwndP: HWND): DWORD; Begin. Result := MCIWndSM(hwnd, MCIWNDM_SETOWNER, hwndP, 0); End; {== AVICAP - Window class for AVI capture ====================================}. Function AVICapSM(hwnd: HWND; m: UINT; w: WPARAM; l: LPARAM): DWORD; Begin. If IsWindow(hwnd) then. Result := SendMessage(hwnd,m,w,l). Else. Result := 0; End; {-- Message crackers for above -----------------------------------------------}. Function capSetCallbackOnError(hwnd: HWND; fpProc: TCAPERRORCALLBACK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_ERROR, 0, LPARAM(@fpProc)) <> 0; End; Function capSetCallbackOnStatus(hwnd: HWND; fpProc: TCAPSTATUSCALLBACK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_STATUS, 0, LPARAM(@fpProc)) <> 0; End; Function capSetCallbackOnYield(hwnd: HWND; fpProc: TCAPYIELDCALLBACK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_YIELD, 0, LPARAM(@fpProc)) <> 0; End; Function capSetCallbackOnFrame(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_FRAME, 0, LPARAM(@fpProc)) <> 0; End; Function capSetCallbackOnVideoStream(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_VIDEOSTREAM, 0, LPARAM(@fpProc)) <> 0; End; Function capSetCallbackOnWaveStream(hwnd: HWND; fpProc: TCAPWAVECALLBACK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_WAVESTREAM, 0, LPARAM(@fpProc)) <> 0; End; Function capSetCallbackOnCapControl(hwnd: HWND; fpProc: TCAPCONTROLCALLBACK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_CAPCONTROL, 0, LPARAM(@fpProc)) <> 0; End; Function capSetUserData(hwnd: HWND; lUser: DWORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_USER_DATA, 0, lUser) <> 0; End; Function capGetUserData(hwnd: HWND): DWORD; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_USER_DATA, 0, 0); End; Function capDriverConnect(hwnd: HWND; i: INT): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DRIVER_CONNECT, i, 0) <> 0; End; Function capDriverDisconnect(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0) <> 0; End; Function capDriverGetName(hwnd: HWND; szName: LPSTR; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DRIVER_GET_NAME, wSize, LPARAM(szName)) <> 0; End; Function capDriverGetVersion(hwnd: HWND; szVer: LPSTR; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DRIVER_GET_VERSION, wSize, LPARAM(szVer)) <> 0; End; Function capDriverGetCaps(hwnd: HWND; s: PCAPDRIVERCAPS; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DRIVER_GET_CAPS, wSize, LPARAM(s)) <> 0; End; Function capFileSetCaptureFile(hwnd: HWND; szName: LPCSTR): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_FILE_SET_CAPTURE_FILE, 0, LPARAM(szName)) <> 0; End; Function capFileGetCaptureFile(hwnd: HWND; szName: LPSTR; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_FILE_GET_CAPTURE_FILE, wSize, LPARAM(szName)) <> 0; End; Function capFileAlloc(hwnd: HWND; dwSize: DWORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_FILE_ALLOCATE, 0, dwSize) <> 0; End; Function capFileSaveAs(hwnd: HWND; szName: LPCSTR): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_FILE_SAVEAS, 0, LPARAM(szName)) <> 0; End; Function capFileSetInfoChunk(hwnd: HWND; lpInfoChunk: PCAPINFOCHUNK): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_FILE_SET_INFOCHUNK, 0, LPARAM(lpInfoChunk)) <> 0; End; Function capFileSaveDIB(hwnd: HWND; szName: LPCSTR): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_FILE_SAVEDIB, 0, LPARAM(szName)) <> 0; End; Function capEditCopy(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_EDIT_COPY, 0, 0) <> 0; End; Function capSetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_AUDIOFORMAT, wSize, LPARAM(s)) <> 0; End; Function capGetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): DWORD; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_AUDIOFORMAT, wSize, LPARAM(s)); End; Function capGetAudioFormatSize(hwnd: HWND): DWORD; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_AUDIOFORMAT, 0, 0); End; Function capDlgVideoFormat(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0) <> 0; End; Function capDlgVideoSource(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0) <> 0; End; Function capDlgVideoDisplay(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEODISPLAY, 0, 0) <> 0; End; Function capDlgVideoCompression(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEOCOMPRESSION, 0, 0) <> 0; End; Function capGetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): DWORD; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_VIDEOFORMAT, wSize, LPARAM(s)); End; Function capGetVideoFormatSize(hwnd: HWND): DWORD; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0); End; Function capSetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_VIDEOFORMAT, wSize, LPARAM(s)) <> 0; End; Function capPreview(hwnd: HWND; f: BOOL): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_PREVIEW, WPARAM(f), 0) <> 0; End; Function capPreviewRate(hwnd: HWND; wMS: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_PREVIEWRATE, wMS, 0) <> 0; End; Function capOverlay(hwnd: HWND; f: BOOL): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_OVERLAY, WPARAM(f), 0) <> 0; End; Function capPreviewScale(hwnd: HWND; f: BOOL): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_SCALE, WPARAM(f), 0) <> 0; End; Function capGetStatus(hwnd: HWND; s: PCAPSTATUS; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_STATUS, wSize, LPARAM(s)) <> 0; End; Function capSetScrollPos(hwnd: HWND; lpP: PPOINT): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_SCROLL, 0, LPARAM(lpP)) <> 0; End; Function capGrabFrame(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_GRAB_FRAME, 0, 0) <> 0; End; Function capGrabFrameNoStop(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0) <> 0; End; Function capCaptureSequence(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SEQUENCE, 0, 0) <> 0; End; Function capCaptureSequenceNoFile(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SEQUENCE_NOFILE, 0, 0) <> 0; End; Function capCaptureStop(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_STOP, 0, 0) <> 0; End; Function capCaptureAbort(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_ABORT, 0, 0) <> 0; End; Function capCaptureSingleFrameOpen(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SINGLE_FRAME_OPEN, 0, 0) <> 0; End; Function capCaptureSingleFrameClose(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SINGLE_FRAME_CLOSE, 0, 0) <> 0; End; Function capCaptureSingleFrame(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SINGLE_FRAME, 0, 0) <> 0; End; Function capCaptureGetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_SEQUENCE_SETUP, wSize, LPARAM(s)) <> 0; End; Function capCaptureSetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_SEQUENCE_SETUP, wSize, LPARAM(s)) <> 0; End; Function capSetMCIDeviceName(hwnd: HWND; szName: LPCSTR): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_SET_MCI_DEVICE, 0, LPARAM(szName)) <> 0; End; Function capGetMCIDeviceName(hwnd: HWND; szName: LPSTR; wSize: WORD): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_GET_MCI_DEVICE, wSize, LPARAM(szName)) <> 0; End; Function capPaletteOpen(hwnd: HWND; szName: LPCSTR): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_PAL_OPEN, 0, LPARAM(szName)) <> 0; End; Function capPaletteSave(hwnd: HWND; szName: LPCSTR): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_PAL_SAVE, 0, LPARAM(szName)) <> 0; End; Function capPalettePaste(hwnd: HWND): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_PAL_PASTE, 0, 0) <> 0; End; Function capPaletteAuto(hwnd: HWND; iFrames, iColors: INT): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_PAL_AUTOCREATE, iFrames, iColors) <> 0; End; Function capPaletteManual(hwnd: HWND; fGrab: BOOL; iColors: INT): BOOL; Begin. Result := AVICapSM(hwnd, WM_CAP_PAL_MANUALCREATE, WPARAM(fGrab), iColors) <> 0; End; {== Externals ================================================================}. Const. VFWDLL = 'MSVFW32.DLL'; AVIFILDLL = 'AVIFIL32.DLL'; AVICAPDLL = 'AVICAP32.DLL'; {-- Returns version of VFW ---------------------------------------------------}. Function VideoForWindowsVersion: DWord; pascal; external VFWDLL; {-- Call these to start stop using VfW from your app -------------------------}. { TODO: Where are these functions? }. // function InitVFW: DWORD; stdcall; // function TermVFW: DWORD; stdcall; {-- ICM function declarations ------------------------------------------------}. Function ICInfo(fccType, fccHandler: DWORD; lpicinfo: PICINFO) : BOOL ; stdcall ; external VFWDLL; Function ICInstall(fccType, fccHandler: DWORD; lParam: LPARAM; szDesc: LPSTR; wFlags: UINT) : BOOL ; stdcall ; external VFWDLL; Function ICRemove(fccType, fccHandler: DWORD; wFlags: UINT) : BOOL ; stdcall ; external VFWDLL; Function ICGetInfo(hic: HIC; picinfo: PICINFO; cb: DWORD) : DWORD ; stdcall ; external VFWDLL; Function ICOpen(fccType, fccHandler: DWORD; wMode: UINT) : HIC ; stdcall ; external VFWDLL; Function ICOpenFunction(fccType, fccHandler: DWORD; wMode: UINT; lpfnHandler: TFarProc) : HIC ; stdcall ; external VFWDLL; Function ICClose(hic: HIC) : DWORD ; stdcall ; external VFWDLL; Function ICSendMessage(hic: HIC; msg: UINT; dw1, dw2: DWORD) : DWORD ; stdcall ; external VFWDLL; {== Compression functions ====================================================}. {-- ICCompress() - compress a single frame -----------------------------------}. Function ICCompress( Hic : HIC; DwFlags : DWORD; // flags. LpbiOutput : PBITMAPINFOHEADER; // output format. LpData : PVOID; // output data. LpbiInput : PBITMAPINFOHEADER; // format of frame to compress. LpBits : PVOID; // frame data to compress. Lpckid : PDWORD; // ckid for data in AVI file. LpdwFlags : PDWORD; // flags in the AVI index. LFrameNum : DWORD; // frame number of seq. DwFrameSize : DWORD; // reqested size in bytes. (if non zero). DwQuality : DWORD; // quality within one frame. LpbiPrev : PBITMAPINFOHEADER; // format of previous frame. LpPrev : PVOID // previous frame. ) : DWORD; cdecl; external VFWDLL; {== Decompression functions ==================================================}. {-- ICDecompress() - decompress a single frame -------------------------------}. Function ICDecompress( Hic : HIC; DwFlags : DWORD; // flags (from AVI index...). LpbiFormat : PBITMAPINFOHEADER; // BITMAPINFO of compressed data. // biSizeImage has the chunk size. LpData : PVOID; // data. Lpbi : PBITMAPINFOHEADER; // DIB to decompress to. LpBits : PVOID. ): DWORD; cdecl; external VFWDLL; {== Drawing functions ========================================================}. {-- ICDrawBegin() - start decompressing data with fmt directly to screen -----}. // return zero if the decompressor supports drawing. Function ICDrawBegin( Hic : HIC; DwFlags : DWORD; // flags. Hpal : HPALETTE; // palette to draw with. Hwnd : HWND; // window to draw to. Hdc : HDC; // HDC to draw to. XDst : int; // destination rectangle. YDst : int; DxDst : int; DyDst : int; Lpbi : PBITMAPINFOHEADER; // format of frame to draw. XSrc : int; // source rectangle. YSrc : int; DxSrc : int; DySrc : int; DwRate : DWORD; // frames/second = (dwRate/dwScale). DwScale : DWORD. ): DWORD; cdecl; external VFWDLL; {-- ICDraw() - decompress data directly to the screen ------------------------}. Function ICDraw( Hic : HIC; DwFlags : DWORD; // flags. LpFormat : PVOID; // format of frame to decompress. LpData : PVOID; // frame data to decompress. CbData : DWORD; // size of data. LTime : DWORD // time to draw this frame. ): DWORD; cdecl; external VFWDLL; {== Helper routines for DrawDib and MCIAVI... ================================}. Function ICLocate(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER; wFlags: WORD): HIC; stdcall; external VFWDLL; Function ICGetDisplayFormat(hic: HIC; lpbiIn, lpbiOut: PBITMAPINFOHEADER; BitDepth: int; dx, dy: int): HIC; stdcall; external VFWDLL; {== Higher level functions ===================================================}. Function ICImageCompress( Hic : HIC; // compressor to use. UiFlags : UINT; // flags (none yet). LpbiIn : PBITMAPINFO; // format to compress from. LpBits : PVOID; // data to compress. LpbiOut : PBITMAPINFO; // compress to this (NULL ==> default). LQuality : DWORD; // quality to use. PlSize : PDWORD // compress to this size (0=whatever). ): THANDLE; stdcall; external VFWDLL; Function ICImageDecompress( Hic : HIC; // compressor to use. UiFlags : UINT; // flags (none yet). LpbiIn : PBITMAPINFO; // format to decompress from. LpBits : PVOID; // data to decompress. LpbiOut : PBITMAPINFO // decompress to this (NULL ==> default). ): THANDLE; stdcall; external VFWDLL; {-- ICCompressorChoose() - allows user to choose compressor, quality etc... --}. Function ICCompressorChoose( Hwnd : HWND; // parent window for dialog. UiFlags : UINT; // flags. PvIn : PVOID; // input format (optional). LpData : PVOID; // input data (optional). Pc : PCOMPVARS; // data about the compressor/dlg. LpszTitle : LPSTR // dialog title (optional). ): BOOL; stdcall; external VFWDLL; Function ICSeqCompressFrameStart(pc: PCOMPVARS; lpbiIn: PBITMAPINFO): BOOL; stdcall; external VFWDLL; Procedure ICSeqCompressFrameEnd(pc: PCOMPVARS); stdcall; external VFWDLL; Function ICSeqCompressFrame( Pc : PCOMPVARS; // set by ICCompressorChoose. UiFlags : UINT; // flags. LpBits : PVOID; // input DIB bits. PfKey : PBOOL; // did it end up being a key frame? PlSize : PDWORD // size to compress to/of returned image. ): PVOID; stdcall; external VFWDLL; Procedure ICCompressorFree(pc: PCOMPVARS); stdcall; external VFWDLL; {== DrawDib functions ========================================================}. {-- DrawDibOpen() ------------------------------------------------------------}. Function DrawDibOpen: HDRAWDIB; stdcall; external VFWDLL; {-- DrawDibClose() -----------------------------------------------------------}. Function DrawDibClose(hdd: HDRAWDIB): BOOL; stdcall; external VFWDLL; {-- DrawDibGetBuffer() -------------------------------------------------------}. Function DrawDibGetBuffer(hdd: HDRAWDIB; lpbi: PBITMAPINFOHEADER; dwSize: DWORD; dwFlags: DWORD): PVOID; stdcall; external VFWDLL; {-- DrawDibGetPalette() - get the palette used for drawing DIBs --------------}. Function DrawDibGetPalette(hdd: HDRAWDIB): HPALETTE; stdcall; external VFWDLL; {-- DrawDibSetPalette() - set the palette used for drawing DIBs --------------}. Function DrawDibSetPalette(hdd: HDRAWDIB; hpal: HPALETTE): BOOL; stdcall; external VFWDLL; {-- DrawDibChangePalette() ---------------------------------------------------}. Function DrawDibChangePalette(hdd: HDRAWDIB; iStart, iLen: int; lppe: PPALETTEENTRY): BOOL; stdcall; external VFWDLL; {-- DrawDibRealize() - realize the palette in a HDD --------------------------}. Function DrawDibRealize(hdd: HDRAWDIB; hdc: HDC; fBackground: BOOL): UINT; stdcall; external VFWDLL; {-- DrawDibStart() - start of streaming playback -----------------------------}. Function DrawDibStart(hdd: HDRAWDIB; rate: DWORD): BOOL; stdcall; external VFWDLL; {-- DrawDibStop() - start of streaming playback ------------------------------}. Function DrawDibStop(hdd: HDRAWDIB): BOOL; stdcall; external VFWDLL; {-- DrawDibBegin() - prepare to draw -----------------------------------------}. Function DrawDibBegin( Hdd : HDRAWDIB; Hdc : HDC; DxDst : int; DyDst : int; Lpbi : PBITMAPINFOHEADER; DxSrc : int; DySrc : int; WFlags : UINT. ): BOOL; stdcall; external VFWDLL; {-- DrawDibDraw() - actually draw a DIB to the screen ------------------------}. Function DrawDibDraw( Hdd : HDRAWDIB; Hdc : HDC; XDst : int; YDst : int; DxDst : int; DyDst : int; Lpbi : PBITMAPINFOHEADER; LpBits : PVOID; XSrc : int; YSrc : int; DxSrc : int; DySrc : int; WFlags : UINT. ): BOOL; stdcall; external VFWDLL; {-- DrawDibEnd() -------------------------------------------------------------}. Function DrawDibEnd(hdd: HDRAWDIB): BOOL; stdcall; external VFWDLL; {-- DrawDibTime() - for debugging purposes only ------------------------------}. Function DrawDibTime(hdd: HDRAWDIB; lpddtime: PDRAWDIBTIME): BOOL; stdcall; external VFWDLL; {-- Display profiling --------------------------------------------------------}. Function DrawDibProfileDisplay(lpbi: PBITMAPINFOHEADER): DWORD; stdcall; external VFWDLL; {-- Functions ----------------------------------------------------------------}. Procedure AVIFileInit; stdcall; external AVIFILDLL; // Call this first! Procedure AVIFileExit; stdcall; external AVIFILDLL; Function AVIFileAddRef(pfile: PAVIFILE): UDWORD; stdcall; external AVIFILDLL; Function AVIFileRelease(pfile: PAVIFILE): UDWORD; stdcall; external AVIFILDLL; Function AVIFileOpenA(var ppfile: PAVIFILE; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; external AVIFILDLL; Function AVIFileOpenW(var ppfile: PAVIFILE; szFile: LPCWSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; external AVIFILDLL; Function AVIFileOpen(var ppfile: PAVIFILE; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; external AVIFILDLL name 'AVIFileOpenA'; Function AVIFileInfoW(pfile: PAVIFILE; pfi: PAVIFILEINFOW; lSize: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIFileInfoA(pfile: PAVIFILE; pfi: PAVIFILEINFOA; lSize: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIFileInfo(pfile: PAVIFILE; pfi: PAVIFILEINFOA; lSize: DWORD): HResult; stdcall; external AVIFILDLL name 'AVIFileInfoA'; Function AVIFileGetStream(pfile: PAVIFILE; var ppavi: PAVISTREAM; fccType: DWORD; lParam: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIFileCreateStreamW(pfile: PAVIFILE; var ppavi: PAVISTREAM; psi: PAVISTREAMINFOW): HResult; stdcall; external AVIFILDLL; Function AVIFileCreateStreamA(pfile: PAVIFILE; var ppavi: PAVISTREAM; psi: PAVISTREAMINFOA): HResult; stdcall; external AVIFILDLL; Function AVIFileCreateStream(pfile: PAVIFILE; var ppavi: PAVISTREAM; psi: PAVISTREAMINFOA): HResult; stdcall; external AVIFILDLL name 'AVIFileCreateStreamA'; Function AVIFileWriteData(pfile: PAVIFILE; ckid: DWORD; lpData: PVOID; cbData: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIFileReadData(pfile: PAVIFILE; ckid: DWORD; lpData: PVOID; lpcbData: PDWORD): HResult; stdcall; external AVIFILDLL; Function AVIFileEndRecord(pfile: PAVIFILE): HResult; stdcall; external AVIFILDLL; Function AVIStreamAddRef(pavi: PAVISTREAM): UDWORD; stdcall; external AVIFILDLL; Function AVIStreamRelease(pavi: PAVISTREAM): UDWORD; stdcall; external AVIFILDLL; Function AVIStreamInfoW (pavi: PAVISTREAM; psi: PAVISTREAMINFOW; lSize: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIStreamInfoA (pavi: PAVISTREAM; psi: PAVISTREAMINFOA; lSize: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIStreamInfo(pavi: PAVISTREAM; psi: PAVISTREAMINFOA; lSize: DWORD): HResult; stdcall; external AVIFILDLL name 'AVIStreamInfoA'; Function AVIStreamFindSample(pavi: PAVISTREAM; lPos: DWORD; lFlags: DWORD): DWORD; stdcall; external AVIFILDLL; Function AVIStreamReadFormat(pavi: PAVISTREAM; lPos: DWORD; lpFormat: PVOID; lpcbFormat: PDWORD): HResult; stdcall; external AVIFILDLL; Function AVIStreamSetFormat(pavi: PAVISTREAM; lPos: DWORD; lpFormat: PVOID; cbFormat: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIStreamReadData(pavi: PAVISTREAM; fcc: DWORD; lp: PVOID; lpcb: PDWORD): HResult; stdcall; external AVIFILDLL; Function AVIStreamWriteData(pavi: PAVISTREAM; fcc: DWORD; lp: PVOID; cb: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIStreamRead( Pavi : PAVISTREAM; LStart : DWORD; LSamples : DWORD; LpBuffer : PVOID; CbBuffer : DWORD; PlBytes : PDWORD; PlSamples : PDWORD. ): HResult; stdcall; external AVIFILDLL; Function AVIStreamWrite( Pavi : PAVISTREAM; LStart, LSamples : DWORD; LpBuffer : PVOID; CbBuffer : DWORD; DwFlags : DWORD; PlSampWritten : PDWORD; PlBytesWritten : PDWORD. ): HResult; stdcall; external AVIFILDLL; // Right now, these just use AVIStreamInfo() to get information, then. // return some of it. Can they be more efficient? Function AVIStreamStart(pavi: PAVISTREAM): DWORD; stdcall; external AVIFILDLL; Function AVIStreamLength(pavi: PAVISTREAM): DWORD; stdcall; external AVIFILDLL; Function AVIStreamTimeToSample(pavi: PAVISTREAM; lTime: DWORD): DWORD; stdcall; external AVIFILDLL; Function AVIStreamSampleToTime(pavi: PAVISTREAM; lSample: DWORD): DWORD; stdcall; external AVIFILDLL; Function AVIStreamBeginStreaming(pavi: PAVISTREAM; lStart, lEnd: DWORD; lRate: DWORD): HResult; stdcall; external AVIFILDLL; Function AVIStreamEndStreaming(pavi: PAVISTREAM): HResult; stdcall; external AVIFILDLL; {-- Helper functions for using IGetFrame -------------------------------------}. Function AVIStreamGetFrameOpen(pavi: PAVISTREAM; lpbiWanted: PBITMAPINFOHEADER): PGETFRAME; stdcall; external AVIFILDLL; Function AVIStreamGetFrame(pg: PGETFRAME; lPos: DWORD): PVOID; stdcall; external AVIFILDLL; Function AVIStreamGetFrameClose(pg: PGETFRAME): HResult; stdcall; external AVIFILDLL; // !!! We need some way to place an advise on a stream.... // STDAPI AVIStreamHasChanged (PAVISTREAM pavi); {-- Shortcut function --------------------------------------------------------}. Function AVIStreamOpenFromFileA(var ppavi: PAVISTREAM; szFile: LPCSTR; fccType: DWORD; LParam: DWORD; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL; Function AVIStreamOpenFromFileW(var ppavi: PAVISTREAM; szFile: LPCWSTR; fccType: DWORD; LParam: DWORD; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL; Function AVIStreamOpenFromFile(var ppavi: PAVISTREAM; szFile: LPCSTR; fccType: DWORD; LParam: DWORD; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL name 'AVIStreamOpenFromFileA'; {-- Use to create disembodied streams ----------------------------------------}. Function AVIStreamCreate(var ppavi: PAVISTREAM; lParam1, lParam2: DWORD; PclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL; // PHANDLER AVIAPI AVIGetHandler (PAVISTREAM pavi, PAVISTREAMHANDLER psh); // PAVISTREAM AVIAPI AVIGetStream (PHANDLER p); {-- Stuff to support backward compat. ----------------------------------------}. Function AVIStreamFindKeyFrame(pavi: PAVISTREAM; lPos: DWORD; lFlags: DWORD): DWORD; stdcall; external AVIFILDLL name 'AVIStreamFindSample'; // Non-portable: this is alias for method name. // FindKeyFrame FindSample. Function AVIStreamClose(pavi: PAVISTREAM): UDWORD; stdcall; external AVIFILDLL name 'AVIStreamRelease'; Function AVIFileClose(pfile: PAVIFILE): UDWORD; stdcall; external AVIFILDLL name 'AVIFileRelease'; Procedure AVIStreamInit; stdcall; external AVIFILDLL name 'AVIFileInit'; Procedure AVIStreamExit; stdcall; external AVIFILDLL name 'AVIFileExit'; {== AVISave routines and structures ==========================================}. Function AVIMakeCompressedStream( Var ppsCompressed : PAVISTREAM; PpsSource : PAVISTREAM; LpOptions : PAVICOMPRESSOPTIONS; PclsidHandler : PCLSID. ): HResult; stdcall; external AVIFILDLL; // Non-portable: uses variable number of params. // EXTERN_C HRESULT CDECL AVISaveA (LPCSTR szFile, // CLSID FAR *pclsidHandler, // AVISAVECALLBACK lpfnCallback, // int nStreams, // PAVISTREAM pfile, // LPAVICOMPRESSOPTIONS lpOptions, // ...); Function AVISaveVA( SzFile : LPCSTR; PclsidHandler : PCLSID; LpfnCallback : TAVISAVECALLBACK; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): HResult; stdcall; external AVIFILDLL; // Non-portable: uses variable number of params. // EXTERN_C HRESULT CDECL AVISaveW (LPCWSTR szFile, // CLSID FAR *pclsidHandler, // AVISAVECALLBACK lpfnCallback, // int nStreams, // PAVISTREAM pfile, // LPAVICOMPRESSOPTIONS lpOptions, // ...); Function AVISaveVW( SzFile : LPCWSTR; PclsidHandler : PCLSID; LpfnCallback : TAVISAVECALLBACK; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): HResult; stdcall; external AVIFILDLL; // #define AVISave AVISaveA. Function AVISaveV( SzFile : LPCSTR; PclsidHandler : PCLSID; LpfnCallback : TAVISAVECALLBACK; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): HResult; stdcall; external AVIFILDLL name 'AVISaveVA'; Function AVISaveOptions( Hwnd : HWND; UiFlags : UINT; NStreams : int; Var ppavi : PAVISTREAM; Var plpOptions : PAVICOMPRESSOPTIONS. ): BOOL; stdcall; external AVIFILDLL; Function AVISaveOptionsFree(nStreams: int; var plpOptions: PAVICOMPRESSOPTIONS): HResult; stdcall; external AVIFILDLL; {-----------------------------------------------------------------------------} Function AVIBuildFilterW(lpszFilter: LPWSTR; cbFilter: DWORD; fSaving: BOOL): HResult; stdcall; external AVIFILDLL; Function AVIBuildFilterA(lpszFilter: LPSTR; cbFilter: DWORD; fSaving: BOOL): HResult; stdcall; external AVIFILDLL; Function AVIBuildFilter(lpszFilter: LPSTR; cbFilter: DWORD; fSaving: BOOL): HResult; stdcall; external AVIFILDLL name 'AVIBuildFilterA'; Function AVIMakeFileFromStreams(var ppfile: PAVIFILE; nStreams: int; var papStreams: PAVISTREAM): HResult; stdcall; external AVIFILDLL; Function AVIMakeStreamFromClipboard(cfFormat: UINT; hGlobal: THANDLE; var ppstream: PAVISTREAM): HResult; stdcall; external AVIFILDLL; {-- Clipboard routines -------------------------------------------------------}. Function AVIPutFileOnClipboard(pf: PAVIFILE): HResult; stdcall; external AVIFILDLL; Function AVIGetFromClipboard(var lppf: PAVIFILE): HResult; stdcall; external AVIFILDLL; Function AVIClearClipboard: HResult; stdcall; external AVIFILDLL; {-- Editing routines ---------------------------------------------------------}. Function CreateEditableStream(var ppsEditable: PAVISTREAM; psSource: PAVISTREAM): HResult; stdcall; external AVIFILDLL; Function EditStreamCut(pavi: PAVISTREAM; plStart, plLength: PDWORD; var ppResult: PAVISTREAM): HResult; stdcall; external AVIFILDLL; Function EditStreamCopy(pavi: PAVISTREAM; plStart, plLength: PDWORD; var ppResult: PAVISTREAM): HResult; stdcall; external AVIFILDLL; Function EditStreamPaste(pavi: PAVISTREAM; plPos, plLength: PDWORD; pstream: PAVISTREAM; lStart, lEnd: DWORD): HResult; stdcall; external AVIFILDLL; Function EditStreamClone(pavi: PAVISTREAM; var ppResult: PAVISTREAM): HResult; stdcall; external AVIFILDLL; Function EditStreamSetNameA(pavi: PAVISTREAM; lpszName: LPCSTR): HResult; stdcall; external AVIFILDLL; Function EditStreamSetNameW(pavi: PAVISTREAM; lpszName: LPCWSTR): HResult; stdcall; external AVIFILDLL; Function EditStreamSetInfoW(pavi: PAVISTREAM; lpInfo: PAVISTREAMINFOW; cbInfo: DWORD): HResult; stdcall; external AVIFILDLL; Function EditStreamSetInfoA(pavi: PAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: DWORD): HResult; stdcall; external AVIFILDLL; Function EditStreamSetInfo(pavi: PAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: DWORD): HResult; stdcall; external AVIFILDLL name 'EditStreamSetInfoA'; Function EditStreamSetName(pavi: PAVISTREAM; lpszName: LPCSTR): HResult; stdcall; external AVIFILDLL name 'EditStreamSetNameA'; {-- MCIWnd -------------------------------------------------------------------}. Function MCIWndCreateA(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl; external VFWDLL; Function MCIWndCreateW(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCWSTR): HWND; cdecl; external VFWDLL; Function MCIWndCreate(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl; external VFWDLL name 'MCIWndCreateA'; Function MCIWndRegisterClass: BOOL; cdecl; external VFWDLL; {== AVICAP - Window class for AVI capture ====================================}. {-- The only exported functions from AVICAP.DLL ------------------------------}. Function capCreateCaptureWindowA( LpszWindowName : LPCSTR; DwStyle : DWORD; X, y : int; NWidth, nHeight : int; HwndParent : HWND; NID : int. ): HWND; stdcall; external AVICAPDLL; Function capGetDriverDescriptionA( WDriverIndex : UINT; LpszName : LPSTR; CbName : int; LpszVer : LPSTR; CbVer : int. ): BOOL; stdcall; external AVICAPDLL; Function capCreateCaptureWindowW( LpszWindowName : LPCWSTR; DwStyle : DWORD; X, y : int; NWidth, nHeight : int; HwndParent : HWND; NID : int. ): HWND; stdcall; external AVICAPDLL; Function capGetDriverDescriptionW( WDriverIndex : UINT; LpszName : LPWSTR; CbName : int; LpszVer : LPWSTR; CbVer : int. ): BOOL; stdcall; external AVICAPDLL; Function capCreateCaptureWindow( LpszWindowName : LPCSTR; DwStyle : DWORD; X, y : int; NWidth, nHeight : int; HwndParent : HWND; NID : int. ): HWND; stdcall; external AVICAPDLL name 'capCreateCaptureWindowA'; Function capGetDriverDescription( WDriverIndex : UINT; LpszName : LPSTR; CbName : int; LpszVer : LPSTR; CbVer : int. ): BOOL; stdcall; external AVICAPDLL name 'capGetDriverDescriptionA'; {== FilePreview dialog =======================================================}. Function GetOpenFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL; Function GetSaveFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL; Function GetOpenFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall; external VFWDLL; Function GetSaveFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall; external VFWDLL; Function GetOpenFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL name 'GetOpenFileNamePreviewA'; Function GetSaveFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL name 'GetSaveFileNamePreviewA'; End.

Views.

Вьюверы: ограниченый доступ к данным.

Что такое вьверы?

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

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

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

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

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

Преимущества вьюверов

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

Фокусировка

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

Более простая работа с данными

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

Гибкость

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

Безопасность

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

С помощью команд grant (предоставлять) и revoke (отнимать) можно разрешить доступ каждому пользователю только к определенным объектам базы данных, включая вьюверы. Если вьювер, а также все базовые таблицы и вьюверы, на которых он основан, принадлежат одному владельцу, то этот владелец может давать разрешение другим пользователям на использование этого вьювера и в то же время запретить непосредственное использование базовых таблиц и вьюверов. Это простой и вместе с тем эффективный механизм обеспечения защиты данных. Детальное описание команд grant и revoke дается в Руководстве по администрированию доступа к SQL Серверу.

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

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

· Доступ может быть разрешен только к определенным столбцам базовой таблицы. Например, можно определить вьювер, в котором будут видны все строки из таблицы titles, но данные в столбцах royalty (гонорар) и advance (аванс) будут скрыты, поскольку они носят коммерческий характер;

· Доступ может быть разрешен только к определенным строкам и столбцам базовой таблицы;

· Доступ может быть разрешен только к тем строкам, которые удовлетворяют условиям соединения с несколькими базовыми таблицами. Например, можно определить вьювер, в котором соединяются данные из таблиц titles, authors и titleauthor, чтобы были видны фамилии авторов вместе с названиями книг, которые они написали. В этом вьювере можно не показывать персональную информацию об авторах и информацию коммерческого характера;

· Доступ может быть разрешен только к итоговым данным в основной таблице. Например, через вьювер category_price (категория_цена) пользователь может узнать только средние цены по каждому виду книг;

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

Чтобы определить вьювер, пользователь должен получить разрешение на выполнение команды creat view (создать вьювер) от владельца базы данных и иметь соответствующие права доступа ко всем таблицам или вьюверам, которые используются в определении этого вьювера.

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

Пользователь, владеющий объектом в базе, должен сам следить за тем, как другие пользователи используют его информацию через вьюверы. Рассмотрим ситуацию, когда владелец базы данных разрешил “Гарольду” создавать вьюверы, а пользователь по имени “Моди” разрешила “Гарольду” выбирать данные из своей таблицы. С этими правами “Гарольд” может определить вьювер, через который будет открыта вся информация из таблицы, принадлежащей “Моди”. Если после этого “Моди” отберет у “Гарольда” права на чтение данных из своей таблицы, он тем не менее может увидеть их через свой вьювер.

Логическая независимость данных

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

Например, предположим, что база данных была реструктурирована с помощью оператора select into (выбрать в) и таблица titles была разделена на две новых таблицы titletext и titlenumbers с удалением таблицы titles:

Titletext (title_id, title, type, notes).

Titlenumbers (title_id, pub_id, price, advance, royalty, total_sales, pub_date).

Заметим, что прежняя таблица titles может быть “восстановлена” с помощью соединения по столбцу title_id двух новых таблиц. Чтобы защитить от этого изменения пользователей, достаточно создать вьювер на основе двух новых таблиц. Можно даже назвать его прежним именем titles.

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

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

Примеры вьюверов

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

Select *

From titles.

Where price > $15.

And advance > $5000.

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

Create view hiprice.

As select *

From titles.

Where price > $15.

And advance > $5000.

Когда SQL Сервер получит эту команду, то вместо выполнения оператора выбора select, который указан здесь после ключевого слова as, сервер сохранит этот оператор, который фактически является определением вьювера hiprice, в системной таблице syscomments. Информация о каждом столбце вьювера будет также записана в системные таблицы sysobjects и syscolumns.

Теперь, при обращении к вьюверу hiprice, SQL Сервер объединит выполняемый оператор с определением вьювера hiprice. Например, пользователь может изменить все цены в hiprice также, как и в любой другой таблице, с помощью следующего оператора:

Update hiprice.

Set price = price * 2.

SQL Сервер сам находит определение вьювера в системных таблицах и конвертирует этот оператор обновления следующим образом:

Update titles.

Set price = price * 2.

Where price > $15.

And advance > $5000.

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

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

Обновление базовой таблицы может привести к изменениям в данных, видимых через вьювер. Например, если увеличить цену книги “You can combat computer stress” до 25.95 долларов, то ее можно будет увидеть через вьювер, поскольку она будет удовлетворять условиям отбора данных в этом вьювере.

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

Создание вьюверов

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

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

Синтаксис команды создания вьюверов

Оператор создания вьюверов имеет следующий общий вид:

Create view [[название_базы.]владелец.]название_вьювера.

[(название_столбца [, название_столбца]...)].

As select [distinct] оператор_выбора.

[with check option].

Как было показано в примере, приведенном в предыдущем разделе, пользователь может не указывать названий столбцов в предложении create оператора создания вьювера. В этом случае SQL Сервер присваивает столбцам вьювера те же названия и те же типы данных, что приведены в списке выбора оператора select. Этот список может быть заменен звездочкой (*), как в предыдущем примере, или быть частью списка названий столбцов базовой таблицы.

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

Вьюверы, созданные с ключевым словом distinct нельзя обновлять.

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

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

· Если два или более столбца вьювера, в противном случае, получат одинаковое название. Это обычно происходит при построении вьювера на основе соединения, когда соединяемые таблицы имеют столбцы с одинаковым названием;

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

Далее приводится пример определение вьювера, в котором изменено название столбца по сравнению с табличным названием:

Create view pub_view (Publisher, city, state).

As select pub_name, city, state.

From publishers.

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

Create view pub_view2.

As select Publisher = pub_name, city, state.

From publishers.

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

В следующем разделе рассматривается оператор выбора, определяющий вьювер, ключевое слово distinct и опция with check option (опция проверки). После этого описывается команда удаления вьюверов drop.

Использование оператора выбора при создании вьюверов

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

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

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

· В нем нельзя использовать предложения order by и compute;

· В нем нельзя использовать ключевое слово into;

· В нем нельзя использовать временные таблицы.

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

Чтобы создать вьювер, в котором отображаются все строки таблицы titles, содержащие информацию только из части столбцов (проекция), можно воспользоваться следующим оператором:

Create view titles_view.

As select title, type, price, pubdate.

From titles.

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

Определение вьювера с вычисляемым столбцом

Далее приводится определение вьювера, значение в одном из столбцов которого вычисляется из величин, содержащихся в столбцах price, royalty и total_sales:

Create view accounts (title, advance, amt_due).

As select titles.title_id, advance, (price * royalty /100 ) * total_sales.

From titles, roysched.

Where price > $15.

And advance > $5000.

And titles.title_id = roysched.title_id.

And total_sales between lorange and hirange.

В этом примере список столбцов должен быть указан в предложении creat, поскольку в данном случае нет названия для столбца, в котором перемножаются величины из столбцов price, royalty и total_sales. Вычисляемый столбец получил название amt_due, которое должно быть указано на том же по порядку месте в предложении creat, что и соответствующее ему вычисляемое выражение в предложении select.

Определение вьювера с агрегирующими и встроенными функциями

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

Create view categories (category, average_price).

As select type, avg(price).

From titles.

Group by type.

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

Create view categories (category, average_price).

As select type, avg(price).

From titles.

Where type = "business".

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

Определение вьювера через соединение

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

Create view cities (authorname, acity, publishername, pcity).

As select au_lname, authors.city, pub_name, publishers.city.

From authors, publishers.

Where authors.city = publishers.city.

Построение вьювера из других вьюверов

Вьювер можно определить на основе других вьюверов, например:

Create view hiprice_computer.

As select title, price.

From hiprice.

Where type = 'popular_comp'

Построение вьювера с ключевым словом distinct

Пользователь может определить вьювер, в котором не будут повторяться строки, например:

Create view author_codes.

As select distinct au_id.

From titleauthor.

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

SQL Сервер обеспечивает отсутствие дубликатов, когда вьювер открывается в первый раз и перед каждой проекцией или селекцией. Вьюверы выглядят и ведут себя как обычные таблицы. Если выполняется проекция во вьювере без повторений, т.е. выбираются все строки по некоторым столбцам, то могут появиться результаты, которые кажутся повторяющимися. Однако, каждая строка вьювера по прежнему будет уникальной. Например, предположим, что создается вьювер без повторений myview с тремя столбцами a,b, и c, которые содержат следующие величины:

Таблица 9-1: Пример вьювера myview без повторений.

A. B. C. 1. 1. 2. 1. 2. 3. 1. 1. 0.

Если появится запрос:

Select a,b from myview,

То результаты будут выглядеть следующим образом:

A b.

--- -----

1 1.

1 2.

1 1.

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

Вьюверы со счетчиками

Пользователь может определить вьювер со столбцом счетчика, например:

Create view sales_view.

As select syb_identity, stor_id.

From sales_daily.

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

· В операторе выбора указан только один столбец счетчик;

· Вьювер строится на основе только одной таблицы;

· Значение счетчика не используется в вычисляемых столбцах;

· Вьювер не содержит агрегирующих функций.

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

Использование опции with check в определении вьювера

Обычно, SQL Сервер не проверяет попадают ли модифицируемые операторами insert (вставка) и update (обновление) строки в область видимости вьювера или нет. Оператор может через вьювер вставить строку в базовую таблицу, которую не видно во вьювере, или изменить в строке данные таким образом, что строка не будет удовлетворять условиям отбора во вьювер.

Если вьювер определяется с опцией with check (с проверкой), то при выполнении операторов модификации данных insert и update, будет проводиться проверка видимости данных. Другими словами, при вставке или модификации данных через этот вьювер, они должны оставаться видимыми, в противном случае оператор будет трактоваться как ошибочный.

Далее приводится пример вьювера stores_cal, созданного с опцией with check. В этом вьювере содержатся данные о книжных магазинах, расположенных в Калифорнии, но нет информации о магазинах, расположенных в других штатах. В этот вьювер отбираются все строки из таблицы stores, в которых в поле штат указана величина “CA”:

Create view stores_cal.

As select * from stores.

Where state = "CA".

With check option.

Когда пользователь вставляет новую строку через вьювер stores_cal, SQL Сервер проверяет удовлетворяет ли новая строка условиям видимости в этом вьювере. Следующий оператор вставки является ошибочным, поскольку втавляется строка, в которой указан штат Нью-Йорк (NY), а не Калифорния:

Insert stores_cal.

Values ("7100", "Castle Books", "351 West 24 St.", "New York", "NY", "USA", "10011", "Net 30").

Когда пользователь модифицирует строку через вьювер stores_cal, SQL Сервер проверяет удовлетворяет ли эта строка условиям видимости в этом вьювере. Следующий оператор обновления является ошибочным, поскольку в нем код штата изменяется с “CA” на “MA”. Если допустить такое обновление, то новая строка не будет видна через этот вьювер.

Update stores_cal.

Set state = "MA".

Where stor_id = "7066".

Построение вьювера на основе другого вьювера с опцией with check

Если вьювер был опеределен с опцией with check, то все вьюверы определенные на его базе (вторичные вьюверы) также будут удовлетворять этому условию. Каждая строка, вставляемая или обновляемая во вторичном (derived) вьювере должна быть видна в базовом вьювере.

Рассмотрим вьювер stores_cal30, который определяется на основе вьювера stores_cal. Во вторичный вьювер включается информация о книжых магазинах в Калифорнии с атрибутом payterms, равным “Net 30”:

Create view stores_cal30.

As select * from stores_cal.

Where payterms = "Net 30".

Поскольку вьювер stores_cal создавался в опцией with check, то все строки вставляемые или обновляемые во вторичном вьювере stores_cal30 должны быть видны через базовый вьювер stores_cal, т.е. любая строка, в которой указан штат отличный от Калифорнии будет отвергнута.

Заметим, что сам вторичный вьювер stores_cal30 был определен без опции with check. Отсюда следует, что через этот вьювер возможна вставка или обновление строк, у которых поле payterms не равно "Net 30". Следующий оператор обновления будет успешно выполнен, несмотря на то, что обновляемая строка не будет больше видна во вьювере stores_cal30:

Update stores_cal30.

Set payterms = "Net 60".

Where stor_id = "7067".

Ограничения вьюверов основанных на внешнем соединении

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

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

Например, предположим, что имеются следующие таблицы:

Таблица А.

A. 1. 2. 3.

Таблица В.

B. C. 1. 10. 2. 11. 6. 12.

Определим вьювер на основе этих двух таблиц с помощью внешнего соединения:

Create view A_B as.

Select a,b,c from A,B.

Where A.a*=B.b.

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

Select a,c from A_B where c = 10.

A с.

---- ----

1 10.

2 NULL.

3 NULL.

(Выбрано 3 строки).

Ограничение (с=10) не повлияло на число выводимых строк. Здесь появились неопределенные значения в столбце внутренней таблицы для каждой строки, в которой либо находиться другое значение (2 строка), либо во второй таблице отсутствует соответствующее внешнему соединению значение (3 строка).

Выборка данных через вьювер

Когда через вьювер пользователь выбирает данные, SQL Сервер проверяет существование всех запрашиваемых в операторе объектов и возможности доступа к ним из данного оператора. Если все проверки закончились успешно, то SQL Сервер объединяет этот оператор с определением вьювера и транслирует его в запрос к базовым таблицам, как уже отмечалось в предыдущем разделе. Этот процесс называется раскрытием вьювера (view resolution).

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

Create view hiprice.

As select *

From titles.

Where price > $15.

And advance > $5000.

Select title, type.

From hiprice.

Where type = 'popular_comp'

SQL Сервер объединяет запрос к вьюверу hiprice с его определением и в результате получается следующий запрос:

Select title, type.

From titles.

Where price > $15.

And advance > $5000.

And type = 'popular_comp'

В общем случае через вьювер можно запрашивать данные также как и через обычную таблицу. Здесь также можно использовать соединения, проводить группировку (в предложении group by), включать подзапросы в любых комбинациях. Однако, если вьювер определяется внешним соединением или с агрегирующими функциями, то запрос к этому вьюверу может привести к неожиданным результатам, как это было отмечено в предыдущем разделе “Ограничения вьюверов ...”.

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

Раскрытие вьювера

Когда пользователь определяет вьювер, SQL Сервер проверяет существование базовых таблиц и вьюверов, преречисленных в предложении from, и выдает сообщение об ошибке при возникновении проблем. Аналогичная проверка проводится при появлении запроса через вьювер.

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

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

· Все базовые таблицы и вьюверы, а также соответствующие столбцы, на которых основан данный вьювер, должны существовать;

· Типы данных всех столбцов, от которых зависит данный вьювер, должны быть совместимы с типами данных соответствующих столбцов вьювера;

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

Если хотя бы одно из этих условий не выполнено, то SQL Сервер выдает сообщение об ошибке.

Переопределение вьюверов

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

В качестве примера рассмотрим таблицу authors и три вьювера, определенные далее. Каждый последующий вьювер базируется на предыдущем, т.е. view2 базируется на view1, а view3 базируется на view2. В этом смысле view2 зависит от view1, а view3 от обеих предшествующих вьюверов.

Далее после названия каждого вьювера приведено его определение:

View1:

Create view view1 as.

Select au_lname, phone from authors.

Where postalcode like "94%".

View2:

Create view view2 as.

Select au_lname, phone from view1.

Where au_lname like "[M-Z]%".

View3:

Create view view3 as.

Select au_lname, phone from view2.

Where au_lname = "MacFeather".

Таблица authors (авторы), на которой базируются эти вьюверы, состоит из столбцов au_id (код автора), au_lname (фамилия), au_ftname (имя), phone (телефон), address (адрес), city (город), state (штат), postalcode (почтовый код).

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

Если переопределить вьювер view2 таким образом, что вьювер view3 не может быть из него получен, то вьювер view3 становиться неправильным и его необходимо переопределить. Например, если в новой версии вьювера view2 содержится только один столбец au_lname вместо двух, то вьювер view3 нельзя будет использовать, поскольку он не имеет доступа к столбцу phone объекта, от которого он зависит.

Тем не менее вьювер view3 будет существовать и его можно будет вновь использовать, если удалить новую версию вьювера view2 и восстановить верию view2 с двумя столбцами au_lname и phone.

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

Переименование вьюверов

Пользователь может переименовать вьювер с помощью системной процедуры sp_rename. Синтаксис вызова этой процедуры имеет следующий вид:

Sp_rename objname, newname.

Например, для переименования вьювера titleview в bookview можно использовать следующую команду:

Sp_rename titles_view, bookview.

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

Изменение и удаление базовых объектов

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

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

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

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

Изменение данных через вьювер

Хотя SQL Сервер не накладывает никаких ограничений на выборку данных через вьювер, и хотя язык Transact-SQL накладывает минимальные ограничения на изменение данных через вьювер по сравнению с другими версиями языка SQL, тем не менее существуют следующие виды модификации данных, которые нельзя проводить через вьювер:

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

· Нельзя проводить обновление, вставку и удаление данных через вьювер, в котором вычисляются итоговые значения или групповые итоговые значения;

· Нельзя проводить обновление, вставку и удаление данных через вьювер, который определяется с опцией distinct (различные);

· Оператор вставки insert можно использовать лишь в том случае, если все столбцы базовой таблицы, в которых не допускаются неопределенные значения (NOT NULL), включены во вьювер, через который происходит вставка, поскольку в противном случае SQL Сервер не может присвоить соответствующим полям базовой таблицы исходные значения;

· Если вьювер определен с опцией with check option, то все вставляемые или обновляемые через него (или через любой зависимый от него вьювер) строки должны удовлетворять условиям видимости в этом вьювере;

· Нельзя удалять (оператором delete) данные через мультитабличный (т.е. определенный на основе нескольких таблиц) вьювер;

· Нельзя вставлять (оператором insert) данные через мультитабличный вьювер, определенный с опцией with check option;

· Можно обновлять (оператором update) данные через мультитабличный вьювер, определенный с опцией with check option. Это обновление будет ошибочным лишь в том случае, если изменяется значение в столбце, который встречается в одном из выражений предложения where вместе с названиями столбцов из других таблиц;

· Нельзя использовать операторы insert и update для мультитабличных вьюверов, определенных с опцией distinct (различные);

· Нельзя обновлять (оператором update) значение в поле счетчика (IDENTITY). Владелец таблицы или владелец базы данных или системный администратор могут вставлять точно указанное значение в поле счетчика, если для этой таблицы установлена опция identity_insert;

· Если вставляется или обновляется строка через мультитабличный вьювер, то все изменяемые столбцы должны принадлежать к одной таблице;

· Команду writetext нельзя применять к тектовым (text) или графическим (image) полям вьювера.

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

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

Ограничения на обновление через вьюверы

Вычисляемые столбцы в определении вьювера

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

Create view accounts (title_id, advance, amt_due).

As select titles.title_id, advance, (price * royalty/100) * total_sales.

From titles, roysched.

Where price > $15.

And advance > $5000.

And titles.title_id = roysched.title_id.

And total_sales between lorange and hirange.

Через этот вьювер видны следующие строки:

Select * from accounts.

Title_id advance amt_due.

--------- -------- ---------

PC1035 7,000.00 32,240.16.

PC8888 8,000.00 8,190.00.

PS1372 7,000.00 809.63.

TC3218 7,000.00 785.63.

(Выбрано 4 строки)).

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

Предложения group by и compute by в определении вьювера

Второе ограничение касается вьюверов, содержащих агрегирующие функции (подведение итогов), т.е. вьюверов, определение которых содержит конструкции group by или compute by. Далее приведен пример вьювера с конструкцией группировки (group by) и показаны видимые через него данные:

Create view categories (category, average_price).

As select type, avg(price).

From titles.

Group by type.

Select * from categories.

Category average_price.

------------- -------------

UNDECIDED NULL.

Business 13.73.

Mod_cook 11.49.

Popular_comp 21.48.

Psychology 13.50.

Trad_cook 15.96.

(Выбрано 6 строк).

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

Теоретически можно представить себе обновление и удаление через этот вьювер, но SQL Сервер не поддерживает эти возможности.

Неопределенные значения в базовых объектах

Третье ограничение касается оператора вставки (insert), когда в базовых таблицах или вьюверах имеются столбцы, в которых нельзя использовать неопределенное значение (NOT NULL).

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

Рассмотрим следующий вьювер:

Create view titleview.

As select title_id, price, total_sales.

From titles.

Where type = 'business'

Неопределенные значения не разрешены в столбце title базовой таблицы titles, поэтому и вставка через вьювер titleview не разрешена. Хотя столбец title даже не упоминается во вьювере, тем не менее запрет на использование в нем неопределенных значений делает любую вставку через этот вьювер ошибочной.

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

Вьюверы, определенные с опцией with chek option

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

Мультитабличные вьюверы

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

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

· Вьювер определен без опции with check option;

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

Например, рассмотрим следующий вьювер, в который включены столбцы из таблиц titles и publishers и который не имеет опции проверки модификации with check option:

Create view multitable_view.

As select title, type, titles.pub_id, state.

From titles, publishers.

Where titles.pub_id = publishers.pub_id.

Каждый оператор вставки или обновления должен модифицировать данные или только из таблицы titles или только из таблицы publishers. Следующий оператор обновления является правильным:

Update multitable_view.

Set type = "user_friendly".

Where type = "popular_comp".

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

Update multitable_view.

Set type = "cooking_trad",

State = "WA".

Where type = "trad_cook".

Вьюверы со столбцами-счетчиками

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

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

Удаление вьюверов

Чтобы удалить вьювер из базы данных, нужно выполнить команду drop view (удалить вьювер). Эта команда имеет следующий вид:

Drop view [[база_данных.]владелец.]название_вьювера.

[, [[база_данных.]владелец.]название_вьювера] ...

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

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

Drop view hiprice.

Когда выполняется команда drop view, название указанного вьювера удаляется из системных таблиц sysprocedures, sysobjects, syscolumns, syscomments, sysprotects sysdepends. Все права на этот вьювер также анулируются.

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

Использование вьюверов для обеспечения безопасности

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

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

Revoke all on titles to public.

Grant all on bookview to public.

Grant all on titles to sales.

Более подробную информацию о том, как предоставлять (grant) и отнимать (revoke) права, можно посмотреть в Руководстве пользователя по средствам ограничения доступа SQL Сервера.

Получение информации о вьюверах

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

Пользователь может получить отчет о вьювере с помощью системной процедуры sp_help. Например:

Sp_help hiprice.

Name Owner type Created_on.

--------- ------ ----- -------------------

Hiprice dbo view Feb 12 1987 11:57AM.

Data_located_on_segment When_created.

---------------------------- --------------------

Column_name Type Length Precision Scale.

------------ ------- -------- --------- ---------

Title_id tid 6 NULL NULL.

Title varchar 80 NULL NULL.

Type char 12 NULL NULL.

Pub_id char 4 NULL NULL.

Price money 8 NULL NULL.

Advance money 8 NULL NULL.

Royalty int 4 NULL NULL.

Total_sales int 4 NULL NULL.

Notes varchar 200 NULL NULL.

Pubdate datetime 8 NULL NULL.

Null Default_name Rule_name Identity.

------ -------------- --------- --------

0 NULL NULL 0.

1 NULL NULL 0.

0 NULL NULL 0.

No defined keys for this object.

(return status = 0).

Чтобы увидеть определение вьювера, которое было помещено в оператор создания вьювера (creat view), нужно выполнить системную процедуру sp_helptext:

Sp_helptext hiprice.

----------

(1 row affected).

Text.

-----------------------

Create view hiprice.

As select *

From titles.

Where price > $15.

And advance > $5000.

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

Sp_depends titles.

Things inside the current database that reference the object (Объекты текущей базы данных, которые зависят от данного объета).

Object type.

------------- --------------------------

Dbo.hiprice view.

Dbo.titleview view.

Dbo.reptq1 stored procedure.

Dbo.reptq2 stored procedure.

Dbo.reptq3 stored procedure.

©Drkb::02989.

VirtualTreeView, FAQ по компоненту

Что такое VirtualTreeView? Это компонент, заменяющий стандартные TTreeView, TStringGrid, TListView, отличается высокой скоростью и удобством работы, а также имеет много расширений. Найти сам компонент можно на сайте: http://delphi-gems.com/VirtualTreeview/ Существует хорошее расширение компонента для работы отображения файлов, аналогично Windows Explorer: http://www.mustangpeak.net/

Основы работы с компонентом Рассмотрим пример простейшего приложения с использованием этого компонента, где он будет использоваться только для отображения данных. Думаю, он будет полезен тем, кто начинает работу с этим компонентом. Если компоненты правильно установлены в среде Дельфи, то для начала нужно найти в палитре компонентов найти вкладку VirtualControls, а в ней компонент VirtualStringTree и положить его на форму. Назовем его VST. Компонент не хранит названий элементов дерева. Но зато каждому элементу можно сопоставить указатель на любую структуру данных, где можно хранить название элемента и не только. В связи с этим создадим простую запись, где будет храниться название элемента и его порядковый номер:

Code: Type. PVSTRecord = ^TVSTRecord; TVSTRecord = record. ElementName: string; ElementNumber: Integer; End;

Теперь укажем компоненту, с каким размером данных он будет работать:

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. VST.NodeDataSize := SizeOf(TVSTRecord); End;

Virtual ListView с контекстным меню

В Delphi5/Demos есть пример Virtual ListView. программка чем-то напоминает explorer, но без контекстного меню. контекстное меню приделывается так:

Как определить, работает ли программа в виртуальной машине VMware?

Code: //////////////////////////////////////////////////////////////////////////////// // // Simple VMware check on i386. // // Note: There are plenty ways to detect VMware. This short version bases. // on the fact that VMware intercepts IN instructions to port 0x5658 with. // an magic value of 0x564D5868 in EAX. However, this is *NOT* officially. // documented (used by VMware tools to communicate with the host via VM). // // Because this might change in future versions - you should look out for. // additional checks (e.g. hardware device IDs, BIOS informations, etc.). // Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS. // Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi). // Function IsVMwarePresent(): LongBool; stdcall; // platform; Begin. Result := False; {$IFDEF CPU386}. Try. Asm. Mov eax, 564D5868h. Mov ebx, 00000000h. Mov ecx, 0000000Ah. Mov edx, 00005658h. In eax, dx. Cmp ebx, 564D5868h. Jne @@exit. Mov Result, True. @@exit: End; Except. Result := False; End; {$ENDIF}. End;

WebSnap.

Итак, ура, мы добрались до новинок в Delphi 6. А именно, до набора компонентов, называемого WebSnap, находящихся на одноименной закладке в IDE Delphi. Технологияявляется дальнейшим развитием технологии WebBroker, еще более упрощающей разработку приложений для Web. Поддержка нескольких Web модулей делает возможной разделить труд по разработке приложения между несколькими разработчиками, возможность доступа к объектам модуля из скрипта, выполняемого на стороне сервера дает возможность «оживить» HTML страницы. Готовое приложение состоит из exe файла (или DLL в зависимости от формата приложения ) и набора файлов с HTML шаблонами страниц. Это позволяет вносить изменения в дизайн страниц без перекомпиляции проекта, а также разделить труд программиста и дизайнера. Для программиста приложениепредставляет собой набор модулей, генерирующих информацию для отображения пользователю с помощью ряда компонентов.Модули делятся на два типа: 1.Web Data Module – модуль для хранения компонентов общих для других модулей. В нем можно размещать невизуальные компоненты. Хорошая аналогия – модуль данных (Data Module) при разработке приложений баз данных. Данный модуль представляет собой просто хранилище компонентов. Содержимое его не отображается на этапе выполнения. 2.Web Page Module – модуль страницы. Данный модуль представляет собой контейнер для размещения компонентов и генерации одной HTML(или XML) страницы приложения. В реализации модуля помимо файлов с расширением pas и xfm, традиционных для любого модуля в Delphi, присутствует файл с расширением html, в котором хранится шаблон HTML страницы для данного модуля. Общая архитектура приложения представлена ниже:

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

Назначение Web Request и Web Response тоже, что и в технологии Web Broker. Далее Page Dispatcher (диспетчер страниц) анализирует запрос и на основании пути запроса решает, какому модулю (Page module)он должен быть передан для дальнейшей обработки. Модуль генерирует запрошенную информацию, которая и отображается затем пользователю. Все гениальное просто. Более подробная схема работы модуля страницы (Page Module) приведена ниже. HTML страница генерируется компонентом-продюсером на основании шаблона страницы. Шаблон страницы может содержать вставки со скриптами. Программист имеет возможность из скрипта обращаться ккомпонентам приложения. Скрипт транслируется скриптовой машиной (Script Engine) в вызовы методов и свойств компонентов-адаптеров. Адаптеры являются мостом между приложением и скриптом в HTML странице.

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

Что касается компонентов, то все компоненты с закладки WebSnap, как и следует ожидать, можно разделить на:

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

· Адаптеры – компоненты, позволяющие вам обращаться к свойствам объектов приложения из скриптового языка на стороне сервера, теги которого размещаются в тексте шаблона страницы.

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

· Другие вспомогательные компоненты.

Первый проект

А пока мы попробуем соорудить наш первый проект с использованием технологии WebSnap. Для этого выберем пункт меню File/New/Other в появившемся диалоге мы перейдем на закладку WebSnap. При этом мы увидим три пункта: WebSnap Application, WebSnap Data Module, WebSnap Page Module. Зачем нужен первый пункт, я думаю, вы догадались – он вызывает мастера созданияприложения. Второй пункт, WebSnap Data Module, позволяет добавить в проект модуль данных. Третий пункт WebSnap Page Module – для генерации заготовки модуля страницы. Итак, выберем пункт WebSnap Application. При этом появится диалог мастера создания приложения WebSnap.

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

Первая группа параметров Sever type позволяет выбрать формат приложения. Эти форматы были описаны в первой части статьи. Мы выберем формат CGI stand-alone executable. Вторая группа – Application Module Components предназначена для выбора компонентов, которые будут размещены в основном модуле приложения и вид данного модуля. Можно выбрать один из двух видов модулей: Page Module или Data Module. Назначение их было описано выше, отметим только, что слово Application в названии указывает на то, что модуль будет главным в приложении. Далее, нажав кнопку Components, мы увидим диалог выбора компонентов, которые будут размещены в модуле приложения. Пока мы не разобрались с назначением компонентов, мы оставим там все без изменений. Третья группа параметров позволяет настроить параметры основного модуля приложения. Первый параметр Page Name позволяет указать имя страницы модуля (доступен лишь для типа модуля Page Module). Второй параметр Caching позволяет задать режим кэширования нашего приложения. По умолчанию параметр имеет значение Cache Instance, т.е разрешить кэширование. Второе возможное значение Destroy Instance отключает кэширование. Мы так же оставим данный параметр без изменения. Кнопка Page Options вызывает диалог настроек параметров модуля приложения, изображенный ниже.

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

Рассмотрим этот диалог. Группа параметров Producer позволяет выбрать тип продюсера страницы (строка ввода Type) и скриптовый язык (JScript или VBasic). Вторая группа HTML позволяет указать шаблон для генерации HTML страницы. Третья группа параметров позволяет настроить параметры страницы имя, заголовок, видимость (параметр published) и необходимость аутентификации пользователя для просмотра данной страницы (параметр Login Required). Имя дублирует параметр Page Name предыдущего диалога. Опять же пока мы в данном диалоге оставим все без изменений. Нажав кнопку ОК в обоих диалогах, мы получим заготовку приложения. Заготовка включает всего один модуль – Unit1. В нем содержится описание главного модуля приложения с именем PageProducerPage1.

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

Теперь осталось сохранить и скомпилировать проект (Ctrl-F9) и полученный исполняемый файл и шаблон страницы Unit1.html разместить на Web сервере в директории для скриптов. Запустим Web броузер и в строке адреса наберем http://localhost/cgi-bin/Project1.exe (в случае использования Apache, для других Web серверов адрес может быть другим). В окне броузера мы увидим надпись PageProducerPage1 Поздравляю, Вы создали первое приложение WebSnap. После того как чепчики будут подброшены вверх, мы продолжим. Взглянем на наш модуль, и попробуем разобраться, для чего служит каждый из размещенных в нем компонентов.

Компонент Назначение TWebAppComponents. Содержит ссылки на другие компоненты, обеспечивающие функциональность приложения ApplicationAdapter. Позволяет задать параметры приложения и позволяет обращаться к этим параметрам через глобальный объект Application в из скрипта на HTML странице PageDispatcher. Диспетчер пользовательских запросов. Анализирует запросы пользователя и переадресует эти запросы, модулям, ответственным за их обработку. AdapterDispatcher. AdapterDispatcher автоматически обрабатывает ввод данных из HTML форм, используя поля с информацией адаптера, расположенного в модуле. PageProducer. Генерирует HTML страницу по заданному шаблону

Для доработки нашей страницы, мы установим свойство Title компонента ApplicationAdapter равным «Заголовок нашего приложения». А теперь сюрприз, сгенерированная HTML страница может быть просмотрена без переноса приложения на Web сервер. Для этого всего лишь необходимо выбрать закладку «Preview» в нижней части окна редактирования.

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

Для этого понадобится нажать кнопку с изображением стрелки указывающей вправо. Визуализация страниц может значительно ускорить разработку Web приложений. Другая закладка Unit1.html – содержит текст шаблона страницы – вы можете сделать страничку более симпатичной, правда, в среде разработки Вам она может отображаться не совсем так, как должна (например, я подправил цвет фона страницы, однако в IDE фон продолжал оставаться белым). Двигаемся далее, как уже вскользь упоминалось, приложениеможет содержать (и в реальных проектах содержит ) несколько модулей страниц. Добавим новый модуль страницы в наше приложение. Идем в пункт меню File/New/Other и на закладке диалога, перейдя на закладку Web Snap, выбираем элемент WebSnap Page Module. Нашему вниманию будет представлен диалог выбора параметров модуля. Назначение параметров мы уже рассмотрели. Нажав кнопку ОК, мы получим модуль страницы с именем PageProducerPage2. Теперь, если мы скомпилируем наше приложение, и разместим его на Web севере (для этого необходимо скопировать файлы Unit1.html, Unit2.html, Project1.exe в папку для скриптов на сервере) в окне браузера мы увидим, что вверху страницы ниже заголовка появилась панель навигации по страницам нашего приложения. Сразу возникает вопрос, а как она появилась, ведь мы ничего не делали для ее генерации? Ответ кроется в файле Unit1.html. Трудно не заметить, что помимо тегов HTML страница содержит теги <% %>, внутри которых расположены операторы скриптового языка. Данные операторы выполняются на стороне сервера, результат их работы вставляется в страницу, отсылаемую клиенту. Из скриптов можно обращаться к большинству компонентов, расположенных в модулях. Это вносит замечательную гибкость и открывает большие возможности для создания сложных динамических страниц. Текст скрипта необходимо заключать в тег <% %>. В качестве скриптовых языков могут применяться JScript и VBScript. Мы будем использовать JScript. Теперь становится ясно, что функция: <% e = new Enumerator(Pages) s = '' c = 0 for (; !e.atEnd(); e.moveNext()) { if (e.item().Published) { if (c>0) s += ' | ' if (Page.Name != e.item().Name) s += '<a href="' + e.item().HREF + '">' + e.item().Title + '</a>' else s += e.item().Title c++ } } if (c>1) Response.Write(s) %> в файле Unit1.html генерирует панель навигации. Текст функции достаточно понятен, некоторые комментарии необходимы лишь для последнего оператора Response.Write – данный оператор выводит строку с результатом работы скрипта в HTML файл страницы. Есть еще один способ это использование тега <%= %>. Пример можно увидеть в том же Unit1.html: <%= Application.Title %> В результате работы этого скрипта на страницу выводится ее заголовок.

Использование TAdapter.

Адаптеры предназначены для хранения различных параметров и процедур и предоставляют возможность обращаться к ним из скрипта. На страницесодержит несколько видов адаптеров. Наиболее неспециализированным из них является адаптер класса TAdapter. Параметры адаптера хранятся в так называемых полях (AdapterFields). На самом деле, поля TAdapter представляют программисту возможность задать обработчики для получения значения поля и других его параметров. TAdapter имеет свойство Data для хранения и управления своими полями. Процедуры (Actions) позволяют вызывать из скрипта выполнение каких-либо действий для управления ими TAdapter содержит свойство Actions. Рассмотрим пример создания страницы для ввода имени пользователя. Поместим компонент TAdapter в наш модуль PageModule2. Определим поле, которое будет возвращать имя пользователя. Для этого из инспектора объектов вызовем редактор свойства Data нашего адаптера Adapter1. В редакторе нажмем кнопку New Item, нам будет предложен диалог выбора типа поля. Мы выберем тип AdapterField, т.к он наиболее подходит для хранения небольших строк. В диалоге при этом появится элемент AdapterField1, соответствующий нашему полю. Выберем его. Теперь в инспекторе объектов перейдем на закладку Events и определим текст обработчик события OnGetValue. Данное событие возникает каждый раз, когда требуется узнать значение поля. Затребованное значение поля необходимо возвращать через параметр Value, передаваемый в обработчике. Код обработчика: Value:=FValue; FValue здесь переменная, в которой мы будем запоминать значение поля AdapterField1, необходимо определить эту переменную в секции public декларации TPageProducerPage2 как FValue:String; Для инициализации значения FValue в обработчике события OnCreate нашего модуля введем код: FValue:=’Неизвестный человек’; Теперь мы можем получать доступ к данному полю из скрипта. Для начала мы попробуем выводить значение поля пользователю. Для этого в код шаблона HTML страницы Unit2.html надо добавить после закрывающегося тега </table> следующий код: <BR><BR> Добрый день, уважаемый <%=Adapter1.AdapterField1.DisplayText%>. Скомпилировав проект и поместив его на Web сервер, мы на странице PageProducerPage2 увидим внизу страницы надпись «Добрый день, уважаемый Неизвестный человек». Далее создадим процедуру (action) для изменения значения имени пользователя. В инспекторе объектов вызовем редактор свойства Actions, и нажав кнопку New Item из появившегося диалога выберем тип процедуры AdapterAction. Будет создана новая процедура - AdapterAction1. В инспекторе объектов установим следующие свойства для процедуры:

Свойство Значение Описание DisplayLabel. OK. Текст для отображения в HTML шаблоне ActionName. GetNameAction1. Имя процедуры для использования в скриптах

Осталось написать код обработчика события OnExecute нашей процедуры: FValue:=AdapterField1.ActionValue.Values[0]; Данная строка сохраняет значение поля AdapterField1 в переменную FValue. Чтобы дать пользователю возможность вводить свое имя в текст Unit2.html (после строки “Добрый день ……”) добавим определение формы ввода: <FORM NAME="INPUT_NAME_FORM" METHOD=POST> <INPUT TYPE=HIDDEN NAME="__action" VALUE = "<%=Adapter1.GetNameAction1.AsFieldValue%>"> Ваше имя: <INPUT TYPE=INPUT VALUE="<%=Adapter1.AdapterField1.EditText%>" NAME= "<%=Adapter1.AdapterField1.InputName%>"> <INPUT TYPE=SUBMIT VALUE="<%=Adapter1.GetNameAction1.DisplayLabel%>" onclick="'INPUT_NAME_FORM.__action.value=<%=Adapter1.GetNameAction1.AsFieldValue%>'"> </FORM> Скомпилируем проект, перенесем его на Web сервер – поприветствуем себя J. PagedAdapter отличается тем, что позволяет разделить большой объем информации на страницы. Размер информации, размещаемой на одной странице, задается в свойстве PageSize. Парольный доступ к странице Очень часто требуется обеспечить ограничение доступа к определенным страницам приложения. Одним из методов решения данной задачи является парольная защита. Технологияпозволяет реализовать доступ к страницам по паролю. Для поддержки парольного доступа в главном модуле должны присутствовать следующие компоненты:

· Компонент TWebUserList, который содержит список пользователей, их паролей и прав доступа

· Компонент TSessionsService, который содержит информацию о пользователях, использующих приложение в данный момент.

· Компонент TEndUserSessionAdapter, который обрабатывает события подключения пользователя

· Добавить эти компоненты можно либо на этапе создания модуля страницы в диалоге Web App Components

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

либо поместить их самостоятельно в уже созданный модуль. Мы воспользуемся вторым способом и обеспечим парольную защиту страницы PageProducerPage2. Разместим в модуле PageProducerPage1 вышеуказанные компоненты. Для свойства UserItems WebUserList1 из инспектора объектов вызовем редактор и введем двух пользователей, которым будет позволен доступ к странице: Mike с паролем 123 и admin с паролем admin. Следующий шаг – указать необходимость парольной защиты страницы, если это не было сделано на этапе создания модуля. Для этого в конце файла Unit2.pas, содержащим описание PageProducerPage2, найдем в конце секцию: initialization if WebRequestHandler <> nil then WebRequestHandler.AddWebModuleFactory(TWebPageModuleFactory.Create(TPageProducerPage2, TWebPageInfo.Create([wpPublished {, wpLoginRequired}], '.html'), crOnDemand, caCache)); и раскомментируем фрагмент “,wpLoginRequierd”. Кроме того, здесь можно исправить еще одну вещь, правда не относящуюся к парольной защите, а именно сделать отображение русских названий страниц в панели навигации. Для этого необходимо в конструкторе TWebPageInfo добавить параметр с русским названием страницы. Таким образом секция initialization будет выглядеть теперь так: initialization if WebRequestHandler <> nil then WebRequestHandler.AddWebModuleFactory(TWebPageModuleFactory.Create(TPageProducerPage2, TWebPageInfo.Create([wpPublished , wpLoginRequired], '.html','PageProducerPage2','Страница с паролем'), crOnDemand, caCache)); Теперь нужно сделать страничку для ввода имени и пароля пользователя. Наиболее простым представляется воспользоваться для этого компонентом AdapterPageProducer. Итак, как обычно, идем в меню File/New/Other. Выбираем закладкуи элемент WebSnap Page Module. В диалоге параметров страницы изменяем тип продюсера с PageProducer на AdapterPageProducer, а также снимаем флажок Published, т.к по умолчанию страница для ввода пароля не должна отображаться в панели навигации. В результате мы получим модуль страницы с единственным компонентом AdapterPageProducer. Компонент AdapterPageProducer представляет собой специализированный продюсер, позволяющий генерировать HTML страницы для отображения полей адаптеров. Принцип создания страницы в AdapterPageProducer1 очень прост. Весь документ представляет набор web компонентов, которые программист добавляет в редакторе, а с помощью инспектора объектов при необходимости настраивает их свойства и события. Web компоненты могут быть вложены один в другой. Все это позволяет комфортно и быстро проектировать HTML документы. В качестве адаптера для обеспечения доступа к имени пользователя и его паролю мы используем компонент класса LoginFormAdapter1, который необходимо добавить в модуль. Далее двойным кликом мыши на компоненте AdapterPageProducer вызовем визуальный редактор HTML страницы. В нем нажмем кнопку New Item и добавим Web компонент типа AdapterForm, т.е HTML форму. Далее, еще раз нажав кнопку New Item ( при выбранном Web компоненте AdapterForm1 ) и добавим Web компонент типа AdapterFieldGroup, т.е набор полей для редактирования полей адаптера. Для AdapterFieldGroup1 установим свойство Adapter равным LoginFormAdapter1, таким образом указав поля какого адаптера мы будем отображать. Далее выберем web компонент AdapterForm1, еще раз нажмем кнопку New Item и добавим web компонент типа AdapterCommandGroup, т.е набор кнопок для вызова процедур адаптера. Для web компонента AdapterCommandGroup зададим свойство DisplayComponent равным AdapterFieldGroup1. Результат наших трудов представлен на рисунке ниже:

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

Остался последний шаг, перейти в модуль PageProducderPage1(т.е главную страницу) указать в свойстве LoginPage компонента EndUserSessionAdapter1 значение AdapterPageProducerPage3. Все можно компилировать наш шедевр и переносить на web сервер. Смотрим, что получается – вверху страницы появилась ссылка с текстом Login. Выбираем, вводим имя и пароль, в качестве следующей страницы указываем “Страница с паролем”, жмем кнопку Login. Что не работает, не попадаем мы на указанную страницу? Аналогично. Ну, хорошо, тогда в среде Delphi создадим новый проектприложения, но в качестве формата выберем не CGI, а WebDebug. В созданный проект подключим те же модули, предварительно удалив сгенерированный мастером главный модуль. Запустим, надо же работает. Парадокс? Ошибка разработчиков? Влияние злых инопланетных пришельцев? Именно такие мысли посещали и меня, пока я внимательно не прочел документацию. Все оказалось просто. Для хранения информации о том авторизован пользователь или нет используется SessionService. Он сохраняет эту информацию в памяти приложения, посему приложение должно быть запущено между запросами пользователя. В случае CGI этого не происходит, т.к протокол построен таким образом, что после обработки одного запроса приложение выгружается. Это и есть причина неработоспособности нашего примера в формате CGI. Еще одним важным моментом является то, что пользователей в WebUserList мы добавляли на этапе разработки. Однако при этом отсутствует возможность управлять списком пользователей вне IDE. Решением данной проблемы является хранения списка пользователей во внешнем файле. Компонент WebUserList имеет метод SaveToFile для сохранения списка пользователей в файл и метод LoadFromFile для загрузки данных о пользователях из файла. При этом формат файла – текстовый, а пароли хранятся в открытом виде. Поэтому администратору сайта необходимо предпринимать дополнительные меры по ограничению доступа к файлу с данными пользователей.

Работа с базами данных

Современные базы данных представляют возможность хранить и обрабатывать большие объемы информации. Возможность работы с базами данных на сегодняшний день является просто необходимым атрибутом любого средства разработки приложений для Web. Технологияв этом смысле не стала исключением, т.к она предоставляет достаточно продуманные и удобные средства публикации содержимого БД, а в соединении с описанной в первой части статьи технологией Internet Express позволяет строить приложения для работы с БД, удовлетворяющие запросам самых привередливых пользователей. Итак, попробуем спроектировать страничку для отображения содержимого таблицы базы данных. В качестве таковой будет использована таблица biolife.db (BDE alias) из примеров, поставляемых с Delphi. Опубликовать данные можно несколькими способами. На мой взгляд для вывода информации наиболее удобно использовать компонент-пробюсер AdapterPageProducer в сочетании с адаптером DataSetAdapter. Добавим в проект новый модуль страницы (при добавлении не забудьте указать тип пробюсера AdapterPageProducer). В полученный модуль добавим DataSetAdapter. Также добавим компоненты доступа к данным TTable и TSession. Установим свойства компонентов следующим образом:

Свойство Значение Назначение свойства Session1. AutoSessionName. True. Автоматическое присвоение имени новой сессии * TTable. SessionName. Session1_1. Имя сессии * DatabaseName. DBDEMOS. Псевдоним базы данных * TableName. Biolife.db. Таблица базы данных Active. True. Активность (доступность данных) таблицы DataSetAdapter1. DataSet. Table1. Компонент, предоставляющий данные из БД для адаптера

* - необходимость установки обусловлена особенностями BDE После вышеперечисленных действий, двойным кликом мыши на компоненте AdapterPageProducer1, вызовем редактор для построения HTML страницы. Нажмем в редакторе кнопку New Item и добавим web компонент AdapterForm, далее на AdapterForm1 той же кнопкой добавим AdapterFieldGroup для отображения информации из полей таблицы. В инспекторе объектов свойство Adapter установим равным DataSetAdapter1. Следующим web компонентом, который мы добавим на AdapterForm1будет AdapterCommandGroup, в котором будут отображаться кнопки навигации по таблице. Свойство DisplayComponent установим равным AdapterFieldGroup1. Все в первом приближении страничка готова. Результат представлен ниже.

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

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

WEBSnap vs WEBBroker.

Ниже в таблице приведены основные отличия технологий друг от друга:

Web Broker. Обратно совметима Можно использовать любой из продюсеров WebBroker. Реализована для CLX, поддерживается в Kylix. На сегодня реализация доступна только для Windows. Хотя Borland уже заявила о том, что технология будет перенесена в Kylix. В приложении может быть лишь один Web модуль Поддержка нескольких модулей делает возможным распределение работы между несколькими разработчиками В приложении может быть лишь один продюсер. Несколько специализированных диспетчеров могут обрабатывать каждый свой вид запроса Нет поддержки скриптов Поддержка скриптов на стороне сервера (JScript или VBScript). Нет встроенной поддержки именования страниц Возможно обращаться из скриптов к объектам, содержащим свойства страниц Нет встроенной поддержки сессий Поддержка сессий иммется, что позволяет легко реализовать идентификацию пользователя при доступе к страницам Только несколько компонентов позволяют визуализировать процесс разработки. Процесс разработки в основном невизуален дизайнер позволяет строить Web страницы с возможностью немедленного предпросмотра результата в IDE.

Автор статьи: Mike Goblin.

Http://www.delphimaster.ru.

©Drkb::03436.

What is the message Generating font matrix when starting Kylix?

Why am I getting a message that says "Generating font matrix. Please wait" when I start Kylix?

This should only happen the first time you start Kylix using the startkyix script. The font matrix is used by the Wine implementation of the Win32 API and you should wait until it finishes. There have been reports of this appearing to take forever in some Linux versions. If it seems to take too long you can try canceling it and Kylix should still run okay.

©Drkb::04607.

WhoIs, Демо получения информации с WhoIs сервера.

WhoIs, Демо получения информации с WhoIs сервера

Code: //////////////////////////////////////////////////////////////////////////////// // // **************************************************************************** // * Project Name : WhoIs. // * Unit Name : uMain. // * Purpose : Демонстрационный пример получения информации с WhoIs сервера. // * Author : Александр (Rouse_) Багель. // * Version : 1.00. // **************************************************************************** // Unit uMain; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Winsock; Type. TfrmMain = class(TForm). EdServer: TLabeledEdit; EdRecipient: TLabeledEdit; GroupBox1: TGroupBox; MemReport: TMemo; Button1: TButton; Procedure Button1Click(Sender: TObject); End; Var. FrmMain: TfrmMain; Implementation. {$R *.dfm}. Function WhoIs(Server, Query: String; Timeout: Integer; Var Response: TStringList): Boolean; Const. MAXBLOCKSIZE = 1024; Var. WSAData: TWSAData; HSocket: TSocket; Addr_in: sockaddr_in; Host: PHostEnt; InAddr, NoBlock: u_long; FDSet: TFDSet; Time: timeval; Buff: array [0..MAXBLOCKSIZE - 1] of Char; RecvCount: Integer; Begin. // инициализируем WinSock. Result := WSAStartup(MakeWord(1, 0), WSAData) = NOERROR; If not Result then Exit; Try. // создаем сокет. HSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); If hSocket = INVALID_SOCKET then. Begin. Result := False; Exit; End; Try. // Определяем, что ввел пользователь имя хоста или его адрес. InAddr := inet_addr(PChar(Server)); If InAddr = INADDR_NONE then. Begin. Host := gethostbyname(PChar(Server)); If not Assigned(Host) then. Begin. Result := False; Exit; End; InAddr := PInAddr(Host.h_addr_list^)^.S_addr; End; // Подготавливаем структуру для соединения. FillChar(Addr_in, SizeOf(sockaddr_in), 0); Addr_in.sin_addr.S_addr := InAddr; Addr_in.sin_family:= AF_INET; Addr_in.sin_port := htons(IPPORT_WHOIS); // Устанавливаем интервалы таймаута. Setsockopt(hSocket, SOL_SOCKET, SO_RCVTIMEO, @Timeout, SizeOf(Integer)); Setsockopt(hSocket, SOL_SOCKET, SO_SNDTIMEO, @Timeout, SizeOf(Integer)); // Соединение с сервером - довольно долгий процесс, поэтому мы поступим по. // хитрому - а именно переводим сокет в неблокирующий режим. NoBlock := 1; Ioctlsocket(hSocket, FIONBIO, NoBlock); // соединяемся. If connect(hSocket, Addr_in, SizeOf(sockaddr_in)) = SOCKET_ERROR then. Case WSAGetLastError of. // Обычно при неблокирующем соединении выдается вот эта ошибка. // на попытку соединения, поэтому мы будем ждать окончания. // соединения через select. WSAEWOULDBLOCK: Begin. FD_ZERO(FDSet); FD_SET(hSocket, FDSet); Time.tv_sec := Timeout div 1000; Time.tv_usec := Timeout; If select(0, nil, @FDSet, nil, @Time) <> 1 then. Begin. Result := False; Exit; End; End; Else. Begin. Result := False; Exit; End; End; // Соединились - теперь неблокирующий режим нам не нужен. // Возвращаем все как было. NoBlock := 0; Ioctlsocket(hSocket, FIONBIO, NoBlock); // Обязательно проверяем чтобы в конце запроса стояло #13#10. Query := Query + sLineBreak; // И отправляем запрос серверу. If Send(hSocket, Query[1], Length(Query), 0) = SOCKET_ERROR then. Begin. Result := False; Exit; End; // Запрос отправлен - начинаем читать данные пока не кончатся. RecvCount := 1; While RecvCount > 0 do. Begin. RecvCount := recv(hSocket, Buff, MAXBLOCKSIZE, 0); Response.Text := Response.Text + String(Buff); End; Finally. // Завершаем установленную сессию. Shutdown(hSocket, SD_BOTH); // Закрываем сокет. Closesocket(hSocket); End; Finally. // Деинициализируем WinSock. WSACleanup; End; End; Procedure TfrmMain.Button1Click(Sender: TObject); Var. S: TStringList; Begin. S := TStringList.Create; Try. // edServer.Text = whois.alldomains.com. // edRecipient.Text = borland.com. WhoIs(edServer.Text, edRecipient.Text, 10000, S); MemReport.Lines.Assign(S); Finally. S.Free; End; End; End.

Проект также доступен по адресу: http://rouse.front.ru/whois.zip Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::03390.

Why can’t I connect to an Access database using the BDE and native MSACCESS driver?

Why can't I connect to an Access database using the BDE and native MSACCESS driver?

Access 2000/XP:

You cannot connect to an Access 2000 database using the BDE's native MSACCESS driver. It is recommended that you use ADO. You could also connect using the BDE with ODBC.

Access 95 or 97:

You may get the message "BDE error 13059" and "General SQL error". If you are trying to connect to Access 95 or 97 databases using the BDE's native MSACCESS driver, then you need to have DAO 3.0 installed for Access 95 or DAO 3.5 for Access 97 (DAO = Data Access Objects for Visual Basic). You can install the DAO by doing a custom installation of MS Office and selecting only to install Data Access Objects for Visual Basic. You must also have the correct DLL32 setting in the BDE Administrator for the DAO you have installed: IDDA3532.DLL for Access 97, IDDAO32.DLL for Access 95.

©Drkb::02748.

Why can't I run my Kylix application outside of the IDE?

What do I need to do to run a Kylix application outside of the IDE?

You need to have your LD_LIBRARY_PATH variable set to your bin directory. Your bin directory is located under your Kylix directory. You can set this by sourcing the kylixpath script. From an xterm window go to the Kylix bin directory and enter.

Source kylixpath.

See the README file for more details.

©Drkb::04604.

WideString -->String.

Code: {:Converts Unicode string to Ansi string using specified code page. @param ws Unicode string. @param codePage Code page to be used in conversion. @returns Converted ansi string. } Function WideStringToString(const ws: WideString; codePage: Word): AnsiString; Var. L: integer; Begin. If ws = '' then. Result := '' else. Begin. L := WideCharToMultiByte(codePage, WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR, @ws[1], - 1, nil, 0, nil, nil); SetLength(Result, l - 1); If l > 1 then. WideCharToMultiByte(codePage, WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR, @ws[1], - 1, @Result[1], l - 1, nil, nil); End; End; { WideStringToString }.

Windows XP манифест в Delphi.

Delphi.Diagnostinc.Ru.

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

Зачем?

В Windows XP есть менеджер тем (theme manager) который изменяет вид большинства стандартных объектов Windows. Misrosoft утверждает что старые версии библиотеки comctl32.dll содержат код для поддержки различных платформ семейства Windows. Microsoft разумно решила почистить содержимое comctl32.dll для улучшения работы тем в Windows XP. Теперь получается что существует две версии библиотеки: старая (версия 5.8) которая имеет обратную совместимость всех предыдущих версий Windows (в том числе и XP) и новую версию (версия 6) которая совместима только с XP (ну и следующими версиями Windows).

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

Что такое манифест?

Что такое манифест, и какую роль он играет в выборе версии 6.0 библиотеки comctl32.dll для моего приложения? Манифест - XML документ который должен быть подлинкован в ресурсы вашего приложения. Обычно ресурсы используются для хранения таких вещей как картинки, иконки и курсоры мыши. (С тем как использовать ресурсы вы можете прочитать в моей статье. Прим. Переводчика) XML документ, когда подключается в ресурсную секцию позволяет решить Windows XP какую версию comctl32.dll использовать.

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

Чтобы подключить этот XML манифест в ваше приложение Вы для начала должны знать константы предоставленные Microsoft. Когда вы добавляете ресурс в ваше приложение, есть номер группы и порядковый номер, связанный с ресурсом. Номер группы обычно называется понятным именем. Если вы посмотрите проводник ресурсов (resource explorer), поставляемый с Delphi в виде демонстрационного проекта (распологается {$delphi\Demos}) вы увидите группы называемые "Strings" (Строки), "Bitmaps" (Картинки), "Icons" (Иконки) или "Cursos" (Курсоры мыши) - это просто представления номер группы. Номер группы для "Manifest" (манифеста) - 24, в соответствии с заголовками C распространяемыми Microsoft. Номер манифеста для определения версии библиотеки comctl32.dll - 1 (Также в соответствии с заголовками C распространяемыми Microsoft). Эта информация будет необходима когда мы будем создавать наш новый ресурс (.RES файл) для подключения к нашему приложению. Для создания необходимого .RES файла нам нужно создать файл .RC в котором будет содержаться наш XML манифест, принадлежащий к соответствующей группе и номеру ресурса. В zip-архиве включенном в этот документ вы увидите два файла:

· 1. WindowsXP.RC

· 2. WindowsXP.Manifest

Файл WindowsXP.RC содержит инструции для подключения WindowsXP.Manifest (XML-документа), а именно:

· 1 24 "WindowsXP.Manifest"

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

Code: <?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly. Xmlns="urn:schemas-microsoft-com:asm.v1". ManifestVersion="1.0"> <assemblyIdentity. Name="CiaoSoftware.Ciao.Shell.Contacts". ProcessorArchitecture="x86". Version="5.1.0.0". Type="win32"/> <description>Windows Shell</description> <dependency> <dependentAssembly> <assemblyIdentity. Type="win32". Name="Microsoft.Windows.Common-Controls". Version="6.0.0.0". ProcessorArchitecture="x86". PublicKeyToken="6595b64144ccf1df". Language="*". /> </dependentAssembly> </dependency> </assembly>

Элементы управления Windows XP.

В Delphi 7 впервые появилась возможность настраивать пользовательский интерфейс приложений для использования в Windows XP. Для этого в состав ресурсов приложения должен включаться манифест Windows XP. Это дополнение призвано обеспечить корректное взаимодействие элементов управления приложения с системной библиотекой ComCtl32.dll версии 6, используемой в Windows XP. Собственно все особенности работы приложений под управлением Windows XP вызваны именно появлением новой версии этой библиотеки. Впрочем, об этом подробно рассказывается ниже.

©Drkb::00390.

Пользовательский интерфейс Windows XP.

При первом знакомств с Windows XP сразу же обращаешь внимание на существенные изменения в оформлении пользовательскою интерфейса этой операционной системы. Все нововведения основаны на использовании нового способа отрисовки элементов управления, который реализован в системной динамической библиотеке ComCtl32.dll версии 6. Эта библиотека входит в состав операционной системы Windows XP.

Примечание.

Обратите внимание, что все более ранние операционные системы фирмы Microsoft используют ComCtl32.dll версии 5 с традиционным стилем оформления элементов управления. И, конечно, нельзя заставить Windows 2000 выглядеть как Windows XP простой заменой версии ComCtl32.dll. Операционная система должна уметь использовать новые возможности.

Теперь элементы управления в стиле Windows XP могут иметь собственную цветовую палитру, текстуры, стили заполнения и, самое главное, различные методы отрисовки своих составных частей. Например, элемент управления может рисовать собственное поле ввода данных обычным способом, а рамку—с использованием маски XOR.

Совокупность правил и методов поведения, оформления и отрисовки элементов управления называется визуальным стилем (visual style). Совместно с Windows XP поставляется один готовый стиль.

Если разработчик хочет, чтобы его приложение могло использовать новые возможности Windows XP, он должен включить в состав проекта специальный ресурс — манифест (manifest). Манифест представляет собой документ XML, содержащий необходимую для библиотеки ComCtl32.dll версии 6 информацию.

Такое приложение будет чувствовать себя комфортно в среде Windows XP. Но и при запуске в старых операционных системах оно просто будет использовать стандартный набор возможностей ComCtl32.dll версии 5 и выглядеть, как и любое другое приложение.

Кроме этого, Windows XP также имеет библиотеку ComCtl32.dll версии 5 и именно она используется по умолчанию.

©Drkb::00391.

Манифест Windows XP.

Итак, начнем с манифеста. Он представляет собой документ в формате XML, содержащий всю информацию, необходимую для взаимодействия приложения и библиотеки ComCtl32.dll версии 6.

Примечание.

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

Пример манифеста.

Code: <?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.vl" manifestVersion="l.0"> <assemblyIdentity version="l.0.0.0". ProcessorArchitecture="X86". Name="CompanyName.ProductName.YourApp". Type="win32". /> <description>Your application description here.</description> <dependency> <dependentAs s embly> <assemblyIdentity. Type="win32". Name="Microsoft.Windows.Common-Controls". Version="6.0.0.0". ProcessorArchitecture="X86". PublicKeyToken="6595b64144ccfldf". Language="*". /> </dependentAss embly> </dependency> </assembly>

Обратите внимание, что в элементе.

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

При загрузке приложения операционная система Windows XP считывает манифест (если он есть) и получает информацию о том, что для выполнения приложения потребуется библиотека ComCtl32.dll версии 6.

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

<AssemblyIdentity>.

Вы можете добавить манифест в ваше приложение двумя способами:

Использовать компонент TxpManifest;

Добавить манифест в ресурсы приложения вручную.

©Drkb::00392.

Включение манифеста Windows XP в ресурсы приложения.

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

Для начала необходимо создать исходный файл ресурса RC, включающий единственную строку:

1 24 "ХР.manifest".

Где 1 — номер ресурса версии библиотеки ComCtl32.dll, а 24 — номер ресурса манифеста (нумерация соответствует заголовочным файлам, распространяемых Microsoft); "ХР.manifest" — имя файла с документом XML, содержащим манифест. Естественно, манифест нужно настроить в соответствии с потребностями вашего проекта.

Теперь нужно откомпилировать файл ресурса при помощи строчного компилятора-ресурсов \Delphi7\Bin\brcc32.exe и разместить его в папке проекта.

И последняя операция — добавьте в исходный код файла проекта директиву подключения ресурса манифеста:

Code: {$R xpmanifest.res}.

Визуальные стили и темы оформления.

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

Начиная с операционной системы Widows 95 пользователям был доступен пакет обновления Microsoft Plus!, который позволял использовать темы оформления рабочего стола Windows. Темой называется совокупность настроек цветов, шрифтов, курсоров и прочих ресурсов, необходимых для создания унифицированного пользовательского интерфейса.

Все параметры одной темы сохраняются в файле с расширением theme в виде секций и значений, подобно файлам INI. Существующие темы доступны для выбора в системном диалоге Display Options.

Визуальные стили, интегрированные в Windows ХР, управляют внешним видом и поведением элементов управления. При этом визуальный стиль использует настройки параметров пользовательского интерфейса, заданные текущей темой. Для управления темами визуального стиля операционная система использует менеджер тем.

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

Совместно с Windows XP поставляется только один визуальный стиль, и он составляет приятное и свежее впечатление о пользовательском интерфейсе операционной системы.

©Drkb::00395.

Визуальные стили в Delphi.

TActionManager является своего рода "командным пунктом", из которого должны управляться элементы управления приложения. Нас интересует только одно свойство этого компонента.

Code: Property Style: TActionBarStyle;

Компоненты настройки цветовой палитры.

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

TstandardColorMap — по умолчанию настроен на стандартную цветовую палитру Windows;

TXPColorMap — по умолчанию настроен на стандартную цветовую палитру Windows XP;

TTwilightColorMap — по умолчанию настроен на стандартную полутоновую (черно-белую) палитру Windows.

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

Все панели инструментов (класс TActionToolBar), созданные в этом компоненте (см. гл. 8), имеют свойство.

Code: Property ColorMap: TCustomActionBarColorMap;

Wizards.

Помощники.

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

Есть два помощника, "Simple Table" и "Master-Detail". Помощники запрашивать назначение подключения данных и позволять выбрать нужные поля для отчета. Важно заметить, что должен быть активный DataView до запуска помощника, или это должен быть Direct Data View или SQL Data View. Простые отчеты обычно создаются для списков. Обычное использование включает списки клиентов, телефонные списки и подобное. Помощник Master-Detail используется, когда требуются более сложные отчеты, такие как счета, списки на заказ продукции и подобное.

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

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

Упражнения.

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

Упражнение 23: простой отчет.

1. первый шаг это выбор DataView, который будет предоставлять данные для отчета.

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

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

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

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

Упражнение 24: Master-Detail отчет.

Помощник Master-Detail Report имеет несколько дополнительных шагов, больше чем в простом отчете. Это связано с тем фактом, что используется больше одной таблицы в отчете. В действительности здесь есть главная таблица (например, информация о клиенте) и подчиненная (элементы заказа).

1. Подобно помощнику простого отчета, первый шаг это выбор DataView. Только в данном случае DataView должен относиться к главной таблице.

2. в шаге два, выбор подчиненной (Detail) таблицы. Заметим, что DataView выбранный в первом шаге, больше не доступен, это сделано для уменьшения ошибок. Подобно помощнику простого отчета, в следующем шаге выбираются поля и порядок для обеих таблиц.

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

После этого, оставшиеся шаги идентичны помощнику простого отчета.

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

WMI - практика применения в Delphi.

Автор: Алексей Павлов

1. Предисловие.Приветствую всех любителей Delphi! В этой статье я хочу поведать вам об одной из замечательных, с моей точки зрения, технологии, разработанной Microsoft для облегчения нашей жизни. Теперь любой программист, используя любой современный язык программирования (не исключая и скрип языков!) может с лёгкостью узнать о своём компьютере практически всё. Теперь программисты всех "вероисповеданий" могут определить, какое оборудование установлено на их компьютере, узнать информацию о материнской плате и процессоре, параметры БИОСа, какие процессы запущены в данный момент, какова температура процессора и скорость вращения кулера, какие настройки графической системы, какие.… Одним словом, все о чём вы так долго мечтали, стало доступно благодаря WMI. Звучит заманчиво, не так ли? ;).

Естественно, что WMI - это не только набор параметров. А что это такое - читайте ниже.

2. Введение.Для того, чтобы не лишиться большей части потенциальных читателей на начальном этапе, скажу сразу, что применение Windows Management Instrumentation (WMI) я буду рассматривать в основном с практической точки зрения (т.е. теории в этой статье будет немного). Сразу хочу оговориться, что т.к. я собираюсь осветить вопрос практического использования технологии WMI в Delphi и намериваюсь достигнуть этой цели достаточно быстро, то я не стану разжёвывать все, с чем нам придётся сталкиваться по ходу повествования и ограничусь минимумом теории. Так что материал изначально ориентирован на тех читателей, кто уверено чувствует себя в области применения интерфейсов, технологии COM и кто умеет работать с литературой.

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

· "Внутри Windows Management Interface".

· "Сценарии WMI для начинающих"

Примечание: : авторы статьи "Внутри Windows Management Interface" интерпретируют аббревиатуру WMI как Windows Management Interface, хотя сами создатели (фирма Microsoft) придерживаются следующей трактовки: Windows Management Instrumentation, что в общем говоря правильнее. Но и интерпретация буквы "I", как "Interface", а не как " Instrumentation " вполне понятна и простительна, т.к. многие разработчики рассматривают WMI не иначе как набор интерфейсов, позволяющих получать доступ к определённым компонентам системы.

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

3. Теория.

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

Windows Management Instrumentation (WMI) - технология, входящая в состав ядра Windows 2000 и предоставляющая доступ с помощью интерфейсов к объектам системы.

Представлю несколько упрощённую архитектуру WMI в том виде, в котором она нас будет интересовать в нашем конкретном случае. Быстро пробежимся по всем её компонентам.

Объекты Win32.

- с этим элементом ассоциированы компоненты Win32, к данным которых мы желаем получить доступ

Провайдер Win32.

- представители объектов Win32, т.е. провайдер осуществляет связь между "внешним миром" и компонентами системы. Нас провайдеры будут интересовать как COM (DCOM) серверы, которые могут быть реализованы как внутренние (в виде DLL), так и внешние (в виде самостоятельных приложений).

CIM Object Manager.

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

Классы CIM.

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

Windows Management API.

- интерфейс прикладного программирования, по средствам которого управляющие приложения обращаются к объектам, а провайдеры поставляют данные и определения класса.

Наша программа является в данном случае не чем иным как контроллером, работающим с помощью Windows Management API с провайдерами (серверами).

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

4. Практика.

Подготовка.

Итак, начнём с того, что нам необходимо сделать перед тем, как непосредственно начать использовать мощь технологии WMI в своих программах:

· установить систему Windows 2000 или NT 4.0 SP4 и выше;

· установить Microsoft Internet Explorer (IE) 5.0 и выше;

· установить WMI SDK;

После того, как вы установили WMI SDK, импортируйте следующие библиотеки типов:

· Active DS Type Library (Version 1.0)

· Microsoft WMI Scripting v1.1 Library (Version 1.1)

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

Порядок действий.

1. Первым делом нам необходимо подсоединиться к интересующему нас пространству имён. Для данной цели используется интерфейс IWbemLocator и его единственный метод ConnectServer, который позволит нашей программе (в данном случае наша программа является WMI клиентом) получить указатель на интерфейс IWbemServices, который связан с выбранным нами пространством имён на выбранном нами компьютере (не стоит забывать, что технология WMI основана на COM/DCOM, что позволяет использовать её удалённо). Методы объектов типа SWbemServices предназначены для произведения операций в выбранном пространстве имён. Да, надеюсь, вы знаете, где можно посмотреть имя интересующего вас пространства имён и WMI класса, если нет, то перечитываем предложенные к прочтению статьи или открываем WMI SDK и просматриваем раздел Win32 Classes.

1. После того, как мы подсоединились к выбранному нами пространству имён и получили указатель на объект, связанный с данным пространством имён, нам необходимо получить описание интересующего нас класса в выбранном нами пространстве имён (возможно, звучит мудрёно, но на практике всё гораздо проще, в чём вы скоро сами убедитесь). Для этого воспользуемся методом Get объекта SWbemServices, который вернёт описание (definition) указанного нами класса (на этом этапе вы уже можете считать имена свойств класса и названия поддерживаемых им методов, естественно, все свойства будут содержать null; так же вы можете создать свой класс на базе полученного описания и дополнить его своими свойствами и методами). Таким образом, мы получим указатель на объект типа SWbemObject.

1. Затем нам необходимо получить непосредственно экземпляр (instance) класса, описание которого мы получили. Для этого воспользуемся методом Instances_ объекта SWbemObject, который создаст объект, осуществляющий нумерацию всех экземпляров (instances) данного класса типа SWbemObjectSet. Говоря по-русски, будет создана коллекция всех объектов данного класса. Полученный объект SWbemObjectSet будет содержать объекты SWbemObject.

1. Вот собственно и всё. Получив из объекта SWbemObjectSet экземпляр класса, нам остаётся считать его свойства и воспользоваться его методами.

Теперь перейдём к рассмотрению самих примеров. Вашему вниманию будут предложены четыре примера, полные исходные тексты и рабочие exe-файлы которых вы найдёте в прилагаемом к статье архиве.

5. Примеры.

5.1. Получение данных о центральном процессоре.

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

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

Code: Unit Unit1; Interface. Uses. …, WbemScripting_TLB, OleServer, ActiveX; Type. TForm1 = class(TForm). … SWbemLocator1: TSWbemLocator; …; Private. { Private declarations }. Procedure ShowProp(SProp: SWBemProperty); Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. Service: ISWbemServices; ObjectSet: ISWbemObjectSet; SObject: ISWbemObject; PropSet: ISWbemPropertySet; SProp: ISWbemProperty; PropEnum, Enum: IEnumVariant; TempObj: OleVariant; Value: Cardinal; StrValue: string; Begin. // см. Примечание 1. Service := SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0, Nil); // см. Примечание 2. SObject := Service.Get('Win32_Processor', wbemFlagUseAmendedQualifiers, nil); // см. Примечание 3. ObjectSet := SObject.Instances_(0, nil); { Далее нам нужно из коллекции ObjectSet получить экземпляр объекта, Соответствующий классу Win32_Processor. Делается это с помощью метода Item объекта ObjectSet. В качестве первого параметра этого метода указывается путь к объекту, Экземпляр которого вы желаете извлечь из коллекции. Данный метод возвращает объект типа SWbemObject. Но нам не известно, как выглядит этот путь. Использовать дополнительный класс SwbemObjectPath тоже нет никакого желания. Так что делаю "финт ушами": } // SObject:= ObjectSet.Item('???', 0); Enum := (ObjectSet._NewEnum) as IEnumVariant; Enum.Next(1, TempObj, Value); SObject := IUnknown(TempObj) as SWBemObject; { Полагаю, что данный приём понятен читателю и в комментариях не нуждается. Вот практически и всё - осталось прочитать интересующие нас свойства. Сколько было слов и как всё просто оказалось в действительности :). Перебираем свойства объекта SObject: } While (PropEnum.Next(1, TempObj, Value) = S_OK) do. Begin. SProp := IUnknown(TempObj) as SWBemProperty; StrValue := ''; ListBox1.AddItem(SProp.Name, nil); ShowProp(SProp); End; End; Procedure TForm1.ShowProp(SProp: SWBemProperty); Begin. If (SProp.Get_Value < > null) then. Begin. With SProp do. Begin. If Name = 'Name' then. Label2.Caption := Get_Value. Else if Name = 'Manufacturer' then. …. End; { with }. End; { if }. End; End.

WMI - практика применения в Delphi.

Алексей Павлов дата публикации 24-10-2002 15:11.

1. Предисловие.

Приветствую всех любителей Delphi! В этой статье я хочу поведать вам об одной из замечательных, с моей точки зрения, технологии, разработанной Microsoft для облегчения нашей жизни. Теперь любой программист, используя любой современный язык программирования (не исключая и скрип языков!) может с лёгкостью узнать о своём компьютере практически всё. Теперь программисты всех "вероисповеданий" могут определить, какое оборудование установлено на их компьютере, узнать информацию о материнской плате и процессоре, параметры БИОСа, какие процессы запущены в данный момент, какова температура процессора и скорость вращения кулера, какие настройки графической системы, какие.… Одним словом, все о чём вы так долго мечтали, стало доступно благодаря WMI. Звучит заманчиво, не так ли? Естественно, что WMI - это не только набор параметров. А что это такое - читайте ниже.

2. Введение.

Для того, чтобы не лишиться большей части потенциальных читателей на начальном этапе, скажу сразу, что применение Windows Management Instrumentation (WMI) я буду рассматривать в основном с практической точки зрения (т.е. теории в этой статье будет немного). Сразу хочу оговориться, что т.к. я собираюсь осветить вопрос практического использования технологии WMI в Delphi и намериваюсь достигнуть этой цели достаточно быстро, то я не стану разжёвывать все, с чем нам придётся сталкиваться по ходу повествования и ограничусь минимумом теории. Так что материал изначально ориентирован на тех читателей, кто уверено чувствует себя в области применения интерфейсов, технологии COM и кто умеет работать с литературой.

· "Внутри Windows Management Interface".

· "Сценарии WMI для начинающих"

3. Теория.

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

Объекты Win32.

- с этим элементом ассоциированы компоненты Win32, к данным которых мы желаем получить доступ

Провайдер Win32.

CIM Object Manager.

Классы CIM.

Windows Management API.

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

4. Практика.

Подготовка.

· установить систему Windows 2000 или NT 4.0 SP4 и выше;

· установить Microsoft Internet Explorer (IE) 5.0 и выше;

· установить WMI SDK;

После того, как вы установили WMI SDK, импортируйте следующие библиотеки типов:

· Active DS Type Library (Version 1.0)

· Microsoft WMI Scripting v1.1 Library (Version 1.1)

Порядок действий.

[ К содержанию ].

5. Примеры.

5.1. Получение данных о центральном процессоре.

Code: Unit Unit1; Interface. Uses. …, WbemScripting_TLB, OleServer, ActiveX; Type. TForm1 = class(TForm). … SWbemLocator1: TSWbemLocator; …; Private. { Private declarations }. Procedure ShowProp(SProp: SWBemProperty); Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. Service: ISWbemServices; ObjectSet: ISWbemObjectSet; SObject: ISWbemObject; PropSet: ISWbemPropertySet; SProp: ISWbemProperty; PropEnum, Enum: IEnumVariant; TempObj: OleVariant; Value: Cardinal; StrValue: string; Begin. // см. Примечание 1. Service:= SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0, nil); // см. Примечание 2. SObject:= Service.Get('Win32_Processor', wbemFlagUseAmendedQualifiers, nil); // см. Примечание 3. ObjectSet:= SObject.Instances_(0, nil); { Далее нам нужно из коллекции ObjectSet получить экземпляр объекта, Соответствующий классу Win32_Processor. Делается это с помощью метода Item объекта ObjectSet. В качестве первого параметра этого метода указывается путь к объекту, Экземпляр которого вы желаете извлечь из коллекции. Данный метод возвращает объект типа SWbemObject. Но нам не известно, как выглядит этот путь. Использовать дополнительный класс SwbemObjectPath тоже нет никакого желания. Так что делаю "финт ушами": } // SObject:= ObjectSet.Item('???', 0); Enum:= (ObjectSet._NewEnum) as IEnumVariant; Enum.Next(1, TempObj, Value); SObject:= IUnknown(TempObj) as SWBemObject; { Полагаю, что данный приём понятен читателю и в комментариях не нуждается. Вот практически и всё - осталось прочитать интересующие нас свойства. Сколько было слов и как всё просто оказалось в действительности. Перебираем свойства объекта SObject: } While (PropEnum.Next(1, TempObj, Value) = S_OK) do. Begin. SProp:= IUnknown(TempObj) as SWBemProperty; StrValue:= ''; ListBox1.AddItem(SProp.Name, nil); ShowProp(SProp); End; End; Procedure TForm1.ShowProp(SProp: SWBemProperty); Begin. If (SProp.Get_Value <> null) then. Begin. With SProp do. Begin. If Name = 'Name' then. Label2.Caption:= Get_Value. Else if Name = 'Manufacturer' then. …. End; { with }. End; { if }. End; End.

Пояснения к коду:

Примечание 1.

Подсоединяемся к пространству имён 'root\CIMV2' нашего компьютера. Метод ConnectServer принимает следующие параметры:

ObjwbemServices = ConnectServer(

[ strServer = "" ],

[ strNameSpace = "" ],

[ strUser = "" ],

[ strPassword = "" ],

[ strLocale = "" ],

[ strAuthority = "" ],

[ iSecurityFlags = 0 ],

[ objwbemNamedValueSet = null ].

)

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

· strNameSpace - необязательный к указанию параметр, содержащий строку, указывающую к какому пространству имён вы собираетесь подключиться. Если не указан, то устанавливается в значение по умолчанию.

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

· StrPassword - см. StrUser.

· StrLocale - необязательный к указанию параметр, содержащий код местности (localization code). Должен содержать нулевую строку для применения действующего кода местности.

· StrAuthority - необязательный к указанию параметр, предназначенный для работы в сетях с системой Kerberos.

· ISecurityFlags - необязательный к указанию параметр. Если содержит 0, то метод ConnectServer вернёт результат только после того, как соединение с сервером будет установлено, т.е. если соединение установить не удалось - ваша программа повиснет. Если содержит значение wbemConnectFlagUseMaxWait, то приложение ждёт две минуты после чего возвращает код ошибки.

· ObjwbemNamedValueSet - необязательный к указанию параметр. Обычно его не определяют (nil). Вообще говоря, можно указать объект типа SWbemNamedValueSet, который будет содержать информацию, которая может быть использована провайдером, обслуживающим данный запрос.

Подробнее обо всех свойствах см. Platform SDK.

Примечание 2.

Теперь получим описание интересующего нас класса, т.е. Win32_Processor. Делается это с помощью метода Get полученного нами объекта Service. Метод Get принимает следующие параметры:

ObjWbemObject = Get(

[ strObjectPath = "" ],

[ iFlags = 0 ],

[ objWbemNamedValueSet = null ].

)

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

· IFlags - необязательный к указанию параметр. Принимает только одно значение: wbemFlagUseAmendedQualifiers.

· ObjWbemNamedValueSet - см. выше.

Подробнее обо всех свойствах см. Platform SDK.

Примечание 3.

Теперь надо получить коллекцию экземпляров класса Win32_Processor. Делается это с помощью метода Instances_ объекта SObject. Метод Instances_ принимает следующие параметры:

ObjWbemObjectSet = Instances_(

[ iFlags = wbemFlagReturnImmediately ],

[ objwbemNamedValueSet = null ].

)

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

· ObjwbemNamedValueSet - см. выше.

Подробнее обо всех свойствах см. Platform SDK.

[ К коду ].

Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\GetProcessorData и \Exe-files соответственно.

Вот что у меня получилось:

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

5.2. Получение данных о запущенных процессах.

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

Code: … Var. Form1: TForm1; ListItem: TListItem; Implementation. {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. Service: ISWbemServices; ObjectSet: ISWbemObjectSet; SObject: ISWbemObject; PropSet: ISWbemPropertySet; SProp: ISWbemProperty; PropEnum, Enum: IEnumVariant; TempObj: OleVariant; Value: Cardinal; Column: TListColumn; Begin. ListView1.Items.BeginUpdate; ListView1.Items.Clear; Service:= SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0, nil); SObject:= Service.Get('Win32_Process', wbemFlagUseAmendedQualifiers, nil); ObjectSet:= SObject.Instances_(0, nil); Enum:= (ObjectSet._NewEnum) as IEnumVariant; { На данном этапе начинаются некоторые незначительные отличия от первого примера. В предыдущем примере, мы знали, что у нас был единственный экземпляр класса. Win32_Processor, характеризующий центральный процессор. В данном примере мы имеем столько экземпляров, сколько запущенных процессов, Поэтому их все необходимо перебрать и получить их свойства: } // в этом цикле перебираю все имеющиеся экземпляры. While (Enum.Next(1, TempObj, Value) = S_OK) do. Begin. SObject:= IUnknown(TempObj) as SWBemObject; PropSet:= SObject.Properties_; PropEnum:= (PropSet._NewEnum) as IEnumVariant; ListItem:= ListView1.Items.Add; // перебираю свойства. While (PropEnum.Next(1, TempObj, Value) = S_OK) do. Begin. SProp:= IUnknown(TempObj) as SWBemProperty; If ListView1.Items.Count = 1 then. Begin. Column := ListView1.Columns.Add; Column.Width := 100; Column.Caption := SProp.Name; End; ShowProp(SProp); End; End; { while }. ListView1.Items.EndUpdate; End; // В процедуре ShowProp происходит определение типа свойства. // и соответствующие приведение типа. Procedure TForm1.ShowProp(SProp: ISWbemProperty); Var. StrValue: string; Count: Cardinal; Begin. StrValue:= ''; If VarIsNull(SProp.Get_Value) then. StrValue:= '' Else. Case SProp.CIMType of. //******************************************************************// WbemCimtypeUint8, wbemCimtypeSint8, wbemCimtypeUint16, wbemCimtypeSint16, WbemCimtypeUint32, wbemCimtypeSint32, wbemCimtypeSint64: If VarIsArray(SProp.Get_Value) then. Begin. If VarArrayHighBound(SProp.Get_Value, 1) > 0 then. For Count:= 1 to VarArrayHighBound(SProp.Get_Value, 1) do. StrValue:= StrValue + ' ' + IntToStr(SProp.Get_Value[Count]); End. Else. StrValue:= IntToStr(SProp.Get_Value); //******************************************************************// WbemCimtypeReal32, wbemCimtypeReal64: StrValue:= FloatToStr(SProp.Get_Value); //******************************************************************// … //******************************************************************// Else. MessageBox(0, PChar('Unknown type'), PChar(Form1.Caption), MB_OK); End; {case}. If ListItem.Caption = '' then. ListItem.Caption := StrValue. Else. ListItem.SubItems.Add(StrValue); End; End.

Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ GetProcessData и \Exe-files соответственно. А выглядит это так:

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

5.3. Запуск приложений и выключение компьютера.

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

Code: … Var. Form1: TForm1; Service: ISWbemServices; InParam, OutParam, SObject, Process: ISWbemObject; Method: ISWbemMethod; SProp1, SProp2, MyProperty: ISWbemProperty; Implementation. {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. PropValue: OleVariant; Begin. Service:= SWbemLocator1.ConnectServer('.', 'root\cimv2', '', '', '', '', 0, nil); // см. Примечание 1. Service.Security_.Set_ImpersonationLevel(wbemImpersonationLevelImpersonate); Process:= Service.Get('Win32_Process', 0, nil); // см. Примечание 2. Method:= Process.Methods_.Item('Create', 0); // см. Примечание 3. InParam:= Method.InParameters.SpawnInstance_(0); // см. Примечание 4. MyProperty:= InParam.Properties_.Add('CommandLine', wbemCimtypeString, False, 0); { С помощью метода Set_Value объекта ISWbemProperty присваеваем свойству CommandLine. Значение Notepad.exe. } PropValue:= 'Notepad.exe'; MyProperty.Set_Value(PropValue); // После того, как все входные свойства определены, запускаем приложение. // OutParam - объект, возвращаемый методом ExecMethod_ OutParam:= Process.ExecMethod_('Create', InParam, 0, nil); // Получения выходных параметров из возвращённого объекта OutParam типа SWbemObject. SProp1:= outParam.Properties_.Item('ReturnValue', 0); // Проверяю, удалось ли запустить приложение. Если свойство ReturnValue не равно 0, // то произошла ошибка. If SProp1.Get_Value = 0 then. Begin. SProp2:= outParam.Properties_.Item('ProcessID', 0); Button2.Enabled:= True; Button1.Enabled:= False; Sleep(300); SetForegroundWindow(Form1.Handle); End. Else. MessageBox(0, PChar('Не удалось запустить приложение.'), PChar(Form1.Caption), MB_OK); End; Procedure TForm1.Button2Click(Sender: TObject); Var. PropValue: OleVariant; Begin. SObject:= Service.Get('Win32_Process.Handle="' + WideString(SProp2.Get_Value) + '"', 0, nil); Method:= SOBject.Methods_.Item('Terminate', 0); InParam:= Method.InParameters.SpawnInstance_(0); MyProperty:= InParam.Properties_.Add('Reason', wbemCimtypeUint32, False, 0); PropValue:= 0; MyProperty.Set_Value(PropValue); OutParam:= SObject.ExecMethod_('Terminate', InParam, 0, nil); SProp1:= outParam.Properties_.Item('ReturnValue', 0); If SProp1.Get_Value = 0 then. Begin. Button1.Enabled:= True; Button2.Enabled:= False; End. Else. MessageBox(0, PChar('Не удалось закрыть приложение.'), PChar(Form1.Caption), MB_OK); End; Procedure TForm1.Button3Click(Sender: TObject); Var. ObjectSet: ISWbemObjectSet; Enum: IEnumVariant; TempObj: OleVariant; Value: Cardinal; Begin. // Выключение компьютера - использование Shutdown без свойств. If MessageBox(0, PChar('Если вы выберете ''Да'', ваш компьютер выключится!'), PChar(Form1.Caption), MB_YESNO or MB_ICONEXCLAMATION or MB_DEFBUTTON2) = mrYes then. Begin. Service:= SWbemLocator1.ConnectServer('.', 'root\cimv2', '', '', '', '', 0, nil); Service.Security_.Privileges.Add(wbemPrivilegeShutdown, True); // см. Примечание 5. // SObject:= Service.Get('Win32_OperatingSystem', wbemFlagUseAmendedQualifiers, nil); // ObjectSet:= SObject.Instances_(0, nil); ObjectSet:= Service.ExecQuery('SELECT * FROM Win32_OperatingSystem WHERE Primary=True', 'WQL', wbemFlagReturnImmediately, nil); Enum:= (ObjectSet._NewEnum) as IEnumVariant; While (Enum.Next(1, TempObj, Value) = S_OK) do. Begin. SObject:= IUnknown(tempObj) as SWBemObject; SObject.ExecMethod_('Shutdown', nil, 0, nil); End; End; { if MessageBox }. End; End.

Пояснения к коду:

Примечание 1.

Security_ - данное свойство используется в том случае, когда вы собираетесь считать или установить настройки безопасности для объекта SWbemServices. Объект SWbemSecurity имеет следующие свойства: AuthenticationLevel, ImpersonationLevel, Privileges. Нас в данном случае будет интересовать только второе свойство. ImpersonationLevel - Числовое значение. Данное свойство определяет, может ли процесс, владельцем которого является WMI, пользоваться правами вашей учётной записи, что может быть необходимо при обращении к другим процессам. Я буду пользоваться значением '3' (wbemImpersonationLevelImpersonate), что означает, что я наделяю данный объект правами того, кто его вызвал. Об остальных уровнях наследования прав читайте в SDK.

Примечание 2.

Свойство Methods_ объекта SWbemObject представляет собой объект типа SWbemMethodSet, который является не чем иным, как коллекцией методов данного класса (или экземпляра класса). Данное свойство предназначено только для чтения (read-only). Единственный метод Item объекта SWbemMethodSet возвращает объект типа SWbemMethod. Метод Item принимает следующие параметры:

ObjMethod = Item(

StrName,

[ iFlags = 0 ].

)

StrName - необходимый параметр. Имя метода, указатель на который должен быть возвращён данным методом.

Примечание 3.

Свойство InParameters объекта SWbemMethod определяет входные параметры для данного метода. Метод SpawnInstance_ объекта SWbemObject создаёт новый экземпляр класса. Данный метод имеет следующие входные параметры:

ObjNewInstance = SpawnInstance_(

[ iFlags = 0 ].

)

Единственный параметр iFlags зарезервирован и не обязателен к указанию. Если указывается, то должен быть равен 0.

Примечание 4.

Свойство Properties_ объекта SWbemObject представляет собой объект типа SWbemPropertySet, который является коллекцией свойств для данного класса или экземпляра. Метод Add объекта SWbemPrivilegeSet добавляет объект типа SWbemProperty к объекту SWbemPrivilegeSet. Данный метод имеет следующие входные параметры:

ObjProperty = Add(

StrName,

ICIMType,

[ bIsArray = FALSE ],

[ iFlags = 0 ].

)

· strName - обязательный к указанию параметр. Имя нового свойства.

· iCIMType - обязательный к указанию параметр. Определяет тип (CIMType) свойства.

· bIsArray - необязательный к указанию параметр. Определяющий является ли данное свойство массивом. По умолчанию False.

· iFlags - необязательный к указанию параметр. Зарезервирован. Если указывается, то должен быть равен 0.

Примечание 5.

Для получения коллекции экземпляров Win32_OperatingSystem я намеренно воспользовался методом ExecQuery объекта ISWbemServices, что бы продемонстрировать работу данной ф-ии. Использование данного метода равносильно используемой мною ранее конструкции. Кстати, синтаксис WQL вам ничего не напоминает? Правильно - WQL прямой потомок ANSI SQL, и соответствует синтаксису SQL. В WQL введены незначительные семантические изменения необходимые для работы с WMI. Так что вам даже не придётся учить новый язык запросов, для того что бы использовать WMI - Microsoft оказалась гуманной и мудрой в этом отношении и в очередной раз не усложнила нашу жизнь Для интересующихся правилами составления запросов: откруваем SDK, раздел "Querying with WQL", всё понятно и доступно.

Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ UseMethods и \Exe-files соответственно.

5.4. Получения значений c температурных сенсоров и с установленных вентиляторов.

Данный пример не содержит каких-либо новых решений или приёмов, кроме проверки на существование провайдера (вернее возможности работать с ним), осуществляющего связь между требуемым компонентом системы и программой. У меня (Chaintech 7VJL (Apogee) VIA KT333 / Athlon XP 1600+ / Windows 2000 Professional SP3) не удаётся получить свойства некоторых классов, например, Win32_Fan и Win32_TemperatureProbe. Выражается это в том, что не удаётся получить экземпляр ни одного из этих классов. Дело в том, что WMI не может получить доступ к WMI провайдеру. Но, т.к. данные классы имеются в хранилище CIM классов, то получить описание данных классов удаётся:

Code: Service:= SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0, nil); SObject:= Service.Get('Win32_Fan', wbemFlagUseAmendedQualifiers, nil);

Но при выполнении:

ObjectSet:= SObject.Instances_(0, nil);

Метод Instances_ не возвращает требуемой коллекции экземпляров и функция Enum.Next(1, TempObj, Value) вернёт значение S_FALSE, а при попытке выполнить PropSet := SObject.Properties_; как я сделал в первом примере, вы получите отказ в доступе (Access Violation), причина понятна….

Я проверял работу данного примера и на материнской плате Gigabyte VIA KT266 с аналогичным процессором и операционной системой - результат тот же.

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

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

Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ FanAndTemperature и \Exe-files соответственно.

6. Послесловие.

На этом я закончу рассказ о применении технологии WMI. Надеюсь, что теперь вы прониклись мыслью о том, что WMI крайне удобная и относительно несложная в реализации технология, которая поможет решить массу ваших проблем Microsoft продолжает активно развивать WMI, и в скором времени мы получим мощнейший инструмент, области применения которого очень и очень обширны. Нам, людям занимающимся программированием, как никому другому приходится год от года, месяц от месяца пополнять свой "боевой" арсенал всё новыми и новыми знаниями, приёмами, инструментами и методологиями. На мой взгляд, технология WMI может занять достойное место в вашем личном арсенале знаний. P.S. Если вам что-то не понятно в примерах или самой теории, то прежде чем отягощать кого-либо своими расспросами, откройте Platform SDK Documentation, затратьте немного своего драгоценного времени и поищите самостоятельно ответы на свои вопросы. Как показывает практика многих поколений - решение, найденное самостоятельно, стоит нескольких, полученных от кого-то. Но если всё же у вас ничего не выйдет - пишите мне, будем разбираться вместе

7. Список использованной литературы.

1. Platform SDK Release: August 2002.

Алексей Павлов Специально для Королевства Delphi Moscow Power Engineering Institute (Technical University) Faculty of Nuclear Power Plants 21.10.02.

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

©Drkb::02241.

Содержание.

Rave Report - Руководство разработчика.
Rave Report - Руководство пользователя.
RC4.
RNA API.
Runtime error 230 when running Kylix application outside of the IDE.
Send e-mails via WinSock API?
Sending a file via DCOM.
Sharpen a Bitmap.
Should I install Kylix as root or a regular user?
SSL – безопасные сокеты.
StrAlloc и GetMem.
Stream Read Error.
StringGrid, выделить фиксированные строки.
StringGrid, Печать в ячейку.
TADOConnection.
TADODataSet.
TADOQuery.
TADOStoredProc.
TADOTable.
TColor ---> HTML Color.
TComponent.
TControl.
TCustomADODataSet.
TCustomControl.
Как удалить сегодняшнюю дату из TDateTimePicker?
TDateTimePicker в StringGrid.
TGraphicControl.
TMemoryStream --> Array of Byte.
TMetaFile - ошибка при работе с памятью.
TObject.
Параметры.
Тгасегt, Принцип трассировки маршрута прохождения сетевого запроса.
Компонент TRvNDRWriter.
Компонент TRvProject.
Компонент TRvSystem.
TSimpleDataSet.
TSQLDataSet.
TSQLQuery.
TSQLTable.
TStream.
TWinControl.
Функции преобразования UNICODE и ANSI строк.
UPDATE из SЕLЕСТ'а.
Using a DSO on Apache 2.0.43, created with Kylix 3.
Using Tapi.
Благодарности.
Как завершить сеанс работы или перезагрузить Windows NT?
Выставляем горячие клавиши для Delphi приложения.
Выполняем встроенные команды Windows.
Ссылки на сайты по Дельфи.
Как программно вазвать окно Завершение работы Windows?
Программирование на основе Win32 API в Delphi (статья).
Как выключить компьютер с любой версией Windows?
Как определить видеокарту?
Как перевести монитор в режим stand-by?
Свои апплеты в панели управления.
Как удалить все файлы из Recent Documents List?
Компонент PowerControl.
Простейшая авторизация в ISAPI/CGI приложениях.
Связка ActiveX - Internet Explorer.
WEB страничка внутри Delphi приложения.
Views.
WebSnap.
What is the message Generating font matrix when starting Kylix?
WhoIs, Демо получения информации с WhoIs сервера.
Why can’t I connect to an Access database using the BDE and native MSACCESS driver?
Why can't I run my Kylix application outside of the IDE?
Элементы управления Windows XP.
Пользовательский интерфейс Windows XP.
Манифест Windows XP.
Визуальные стили и темы оформления.
Wizards.
WMI - практика применения в Delphi.