Статьи по Delphi (004)…
Пример отсылки письма используя COM объект Outlook.
Автор: Vit WEB-сайт: http://forum.vingrad.ru
uses Outlook_TLB;
var
outlook: _application;
procedure Init;
begin
outlook := Coapplication_.Create;
end;
procedure SendEmail;
begin
with Outlook.CreateItem(olMailItem) as mailitem do
begin
To_ := 'email@email.com';
cc := 'email2@email.com';
Subject := 'This is subject line';
Attachments.Add('FileName', 1, 1, 'This is attachment');
Body := 'This is email body';
Send;
end;
end;
Пример программирования com портов.
unit TestRosh;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
PortCombo: TComboBox;
Label2: TLabel;
BaudCombo: TComboBox;
Label3: TLabel;
ByteSizeCombo: TComboBox;
Label4: TLabel;
ParityCombo: TComboBox;
Label5: TLabel;
StopBitsCombo: TComboBox;
Label6: TLabel;
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
Memo2: TMemo;
Edit2: TEdit;
Label7: TLabel;
Button2: TButton;
Label8: TLabel;
Edit3: TEdit;
procedure Button1Click(Sender: TObject);
procedure Memo2Change(Sender: TObject);
procedure Memo1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure PortComboChange(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Memo1DblClick(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
Registry;
var
hPort: THandle;
procedure TForm1.Memo1Change(Sender: TObject);
var
i: Integer;
begin
Edit1.Text := '';
for i := 1 to Length(Memo1.Text) do
Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '
end;
procedure TForm1.Memo2Change(Sender: TObject);
var
i: Integer;
begin
Edit2.Text := '';
for i := 1 to Length(Memo2.Text) do
Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '
end;
procedure TForm1.Button1Click(Sender: TObject);
var
S, D: array[0..127] of Char;
actual_bytes: Integer;
DCB: TDCB;
begin
FillChar(S, 128, #0);
FillChar(D, 128, #0);
DCB.DCBlength := SizeOf(DCB);
if not GetCommState(hPort, DCB) then
begin
ShowMessage('Can''t get port state: ' + IntToStr(GetLastError));
Exit;
end;
try
DCB.BaudRate := StrToInt(BaudCombo.Text);
except
BaudCombo.Text := IntToStr(DCB.BaudRate);
end;
try
DCB.ByteSize := StrToInt(ByteSizeCombo.Text);
except
ByteSizeCombo.Text := IntToStr(DCB.ByteSize);
end;
if ParityCombo.ItemIndex > -1 then
DCB.Parity := ParityCombo.ItemIndex
else
ParityCombo.ItemIndex := DCB.Parity;
if StopBitsCombo.ItemIndex > -1 then
DCB.StopBits := StopBitsCombo.ItemIndex
else
StopBitsCombo.ItemIndex := DCB.StopBits;
if not SetCommState(hPort, DCB) then
begin
ShowMessage('Can''t set new port settings: ' + IntToStr(GetLastError));
Exit;
end;
PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
StrPCopy(S, Memo1.Text);
if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then
begin
ShowMessage('Can''t write to port: ' + IntToStr(GetLastError));
Exit;
end;
if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then
ShowMessage('Can''t read from port: ' + IntToStr(GetLastError))
else
ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes');
Memo2.Text := D;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
with TRegistry.Create do
begin
OpenKey('Shkila', True);
WriteString('Port', PortCombo.Text);
WriteString('Baud Rate', BaudCombo.Text);
WriteString('Byte Size', ByteSizeCombo.Text);
WriteString('Parity', IntToStr(ParityCombo.ItemIndex));
WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex));
Destroy;
end;
if not CloseHandle(hPort) then
begin
ShowMessage('Can''t close port: ' + IntToStr(GetLastError));
Exit;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
hPort := CreateFile(PChar(PortCombo.Text),
GENERIC_READ + GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hPort = INVALID_HANDLE_VALUE then
ShowMessage('Can''t open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))
else
Button2.Hide;
end;
procedure TForm1.PortComboChange(Sender: TObject);
begin
FormDestroy(Sender);
Button2.Show;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
with TRegistry.Create do
begin
OpenKey('Shkila', True);
PortCombo.Text := ReadString('Port');
BaudCombo.Text := ReadString('Baud Rate');
ByteSizeCombo.Text := ReadString('Byte Size');
ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));
StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits'));
Destroy;
end;
end;
procedure TForm1.Memo1DblClick(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo2.Lines.Clear;
Edit1.Text := '';
Edit2.Text := '';
end;
end.
|
Асинхронный режим чтения из Com-порта.
Оформил: DeeCo
Автор: Терехов Александр
ВступлениеПорядок запуска и работы "службы" (назовем все описываемое ниже так) Com-портов состоит из нескольких достаточно хорошо описанных шагов ( см. статьи по теме ): Инициализация Com-порта посредством вызова функции CreateFile. Установка параметров Com-порта посредством последовательного вызова функций GetCommState и SetCommState, а также SetupComm. Установка параметров тайм-аутов для чтения и записи - GetCommTimeouts и SetCommTimeouts. Собственно записи в Com-порт - WriteFile и чтения из него - ReadFile. Закрытие порта по окончанию работ CloseHandle. Очень большой сложности описанные выше шаги не представляют, однако реализация чтения данных из порта в асинхронном (неблокирующем) режиме заставляет почесать затылок. Об этом и поговорим. Чтение из Com-порта. Судя по контексту справки, касающейся функции CreateFile, для "отлова" момента поступления данных в Com-порт следует использовать функцию WaitCommEvent. Предварительно установив маску SetCommMask на то событие, которое хотелось бы отследить. Нужное событие наступает - вызываем функцию ReadFile для чтения поступающих данных. Казалось бы все в порядке, но... Вызов функции WaitCommEvent насмерть тормозит приложение, пока какие-либо данные не поступят в Com-порт. Можно конечно, просто взять и запустить в непрерывном цикле ReadFile, однако приложение хотя и будет как-то шевелиться, но это шевеление скорее всего будет напоминать предсмертные судороги. Как выход из ситуации многие предлагают использовать потоки (thread), забывая при этом описать как это делать :) Итак потоки. В модуле Classes для потоков определен специальный класс TThread. Для создания потоков специалисты рекомендуют использовать именно его, а не создавать потоки используя BeginThread и EndThread, т.к. библиотека VCL не является защищенной для потоков в такой реализации. Следуя советам экспертов, для организации контроля поступающих данных в Com-порт и будем использовать готовый класс TThread. В раздел interface определим тип переменных этого класса, переопределив только один метод класса - Execute, ну и дополнительно объявим свой метод, который и займется опросом Com-порта. Далее в разделе глобальных переменных определим поток-переменную полученного выше типаCommThread:TCommThread; //наш поток, в котором будет работать процедура опроса портаЗатем в разделе implementation начинаем ваять.
ВНИМАНИЕ!!! К этому времени порт уже должен быть инициализирован функцией CreateFile.
1. Инициализируем поток, используя метод Create.
type
//определим тип TComThread - наследника класса TThread
TCommThread = class(TThread)
private
//процедура, занимающаяся опросом порта
procedure QueryPort;
protected
//переопределим метод запуска потока
procedure Execute; override;
end;
procedure StartComThread;
//инициализация нашего потока
begin {StartComThread}
//пытаемся инициализировать поток
CommThread := TCommThread.Create(False);
//проверяем получилось или нет
if CommThread = nil then
begin {Nil}
//ошибка, все выключаем и выходим
SysErrorMessage(GetLastError);
fmMain.btnStop.Click;
Exit;
end; {Nil}
end; {StartComThread}
Куски кода взяты из файла проекта, поэтому нажимание на кнопку btnStop главной формы fmMain - это "примочки" примера, не обращайте внимания.
Запускаем процедуру опроса порта в нашем потоке.
procedure TCommThread.Execute;
begin {Execute}
repeat
QueryPort; //процедура опроса порта будет производиться пока поток не будет прекращен
until Terminated;
end; {Execute}
Реализуем асинхронные опрос порта и чтение из него данных
procedure TCommThread.QueryPort;
var
MyBuff: array[0..1023] of Char; //буфер для чтения данных
ByteReaded: Integer; //количество считанных байт
Str: string; //вспомогательная строка
Status: DWord; //статус устройства (модема)
begin {QueryPort}
//получим статус COM-порта устройства (модема)
if not GetCommModemStatus(hPort, Status) then
begin {ошибка при получении статуса модема}
//ошибка, все выключаем и выходим
SysErrorMessage(GetLastError);
fmMain.btnStop.Click;
Exit;
end; {ошибка при получении статуса модема}
//Обработаем статус устройства (модема) и будем включать(выключать) лампочки
//готовность устройства (модема) получать данные
fmMain.imgCTSOn.Visible := ((Status and MS_CTS_ON) = MS_CTS_ON);
//готовность устройства (модема) к сеансу связи
fmMain.imgDSROn.Visible := ((Status and MS_DSR_ON) = MS_DSR_ON);
//принимаются данные с линии сигнала
fmMain.imgRLSDOn.Visible := ((Status and MS_RLSD_ON) = MS_RLSD_ON);
//входящий звонок
fmMain.imgRingOn.Visible := ((Status and MS_RING_ON) = MS_RING_ON);
//читаем буфер из Com-порта
FillChar(MyBuff, SizeOf(MyBuff), #0);
if not ReadFile(hPort, MyBuff, SizeOf(MyBuff), ByteReaded, nil) then
begin {ошибка при чтении данных}
//ошибка, все закрываем и уходим
SysErrorMessage(GetLastError);
fmMain.btnStop.Click;
Exit;
end; {ошибка при чтении данных}
//данные пришли
if ByteReaded > 0 then
begin {ByteReaded>0}
//посчитаем общее количество прочитанных байтов
ReciveBytes := ReciveBytes + ByteReaded;
//преобразуем массив в строку
Str := string(MyBuff);
//отправим строку на просмотр
fmMain.Memo1.Text := fmMain.Memo1.Text + Str;
//покажем количество считанных байтов
fmMain.lbRecv.Caption := 'recv: ' + IntToStr(ReciveBytes) + ' bytes...';
end; {ByteReaded>0}
end; {QueryPort}
На этом по поводу использования потоков для считывания данных из Com-порта, пожалуй, все.
Прилагающийся пример
Следуя правилам хорошего тона, прикладываю ко всему написанному работающий пример.
В примере используется самое доступное устройство для пользователей интернет - модем (на Com-порту). В качестве "примочек" я использовал лампочки, которые включаются (или выключаются) при изменении статуса модема. Можно было прикрутить лампочки-детекторы входящих-выходящих сигналов, но вместо них используются счетчики байтов.
Реализация кода включения-выключения не самая лучшая: можно было бы использовать TImageList для хранения изображений лампочек. Но почему-то ??? (кто знает почему - напишите) использование ImageList.GetBitmap при наличии запущенного потока "подвешивает" приложение насмерть. Причем это происходит под Windows'98, если тоже самое делать под Windows'95, то все в порядке.Для проверки работоспособности примера попробуйте понабирать AT-команды ATZ - инициализировать модем ATH - положить трубку ATH1 - поднять трубку ATS0=1 - включить автоподнятие трубки на первый сигнал ATS0=0 - выключить автоподнятие трубки ATDP_номер_телефона_интернет_провайдера - мне нравится больше всего :) ATDP - набор в импульсном режиме, ATDT - набор в тоновом режиме
Да, еще. Проект написан под Delphi3, при использовании Delphi более свежих версий возможны ошибки "несовпадения типов".
В этим случае поменяйте типы "ошибочных" переменных с Integer на Cardinal.
Скачать проект — ComPort.zip (17K)
Слияние двух бинарных файлов.
Самым простым способом является открытие первого, перемещение в его конец, и копирование с этого места второго файла.
var
f1, f2: file;
xfer: Word;
buf: PChar;
begin
AssignFile(f1, name1);
Reset(f1);
Seek(f1, Filesize(f1));
AssignFile(f2, name2);
Reset(f2);
GetMem(buf, 65000);
repeat
BlockRead(f1, buf^, 65000, xfer);
BlockWrite(f2, buf^, xfer);
until
xfer < 65000;
CloseFile(f1);
CloseFile(f2);
end;
|
Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE.
Прописать в \HKEY_LOCAL_MACHINE\SOFTWARE\ORACLE параметр: NLS_NUMERIC_CHARACTERS = '.,'
Или.
После соединения с ORACLE выполнить ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'
Конфликт имен параметров.
Автор: Kurt Barthelmess Некоторые обработчики событий (типа TStringGrid OnDrawCell) получают параметры с именами Col и Row.Возникает проблема при использовании следующего кода:
with Sender as TStringGrid do ..... |
Kurt Barthelmess нашел как обойти эту проблему. Объявите:
var CellCol: Longint absolute Col; CellRow: Longint absolute Row; |
Этот трюк позволяет обойтись без локальных переменных и работать с одноименными параметрами.
Как законнектиться через Dial-Up соединение по умолчанию.
| Интернетчик орёт на жену: -Ты изменяла? Жена: -Нет, что ты! Как ты мог подумать такое И:- Нет, лучше сразу скажи, Ты изменяла? Ж:- Да перестань, и в мыслях не было! И: - Если я узнаю, что ты изменила, убью! Ж: - Скажи мне, что случилось? И: Что-что! В Интернет войти не могу, сервер выдаёт "Ваш пароль неверный"! Не мог-же он сам измениться!(орёт) Ты изменяла? |
uses
Registry, windows;
// Показать или скрыть диалог dial-up
function DUNDialDefault(Hide: Boolean): Boolean;
var
Reg: TRegistry;
TempResult: Boolean;
name, con: string;
ASW: Integer;
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\RemoteAccess', False) then
begin
TempResult := True;
name := Reg.ReadString('Default');
end
else
tempresult := False;
Reg.Free;
if TempResult = True then
begin
if Hide = True then
ASW := SW_HIDE
else
ASW := SW_SHOWDEFAULT;
con := 'rnaui.dll,RnaDial ' + name;
ShellExecute(0, nil, 'rundll32.exe' , PChar(con), 'C:\windows\', ASW);
end;
Result := tempResult;
end;
|
В Win2000 и WinXP можно воспользоваться WinInet:
Для этого добавьте WinInet в секцию uses. Затем используйте следующую команду:
InternetAutoDial (INTERNET_AUTODIAL_FORCE_ONLINE, handle); |
Handle = родительское окно.
Консольные приложения в Delphi.
| Автор: Alex G. Fedorov |
| Все настоящие программисты делятся на три категории: на тех, кто пишет программы, завершающиеся по нажатию F10, Alt-F4, Alt-X. Все остальные принципы деления надуманны. |
Статья представляет собой изучение создания консольного приложения в Delphi. Прежде чем начать вникать в подробности, необходимо уточнить, что консольные приложения это особый вид Windows приложений - с одной стороны он имеет полный доступ к функциям Win API, с другой - не имеет графического интерфейса и выполняется в текстовом режиме.
Простая консольная программа
На момент написания статьи (1997г.), в Delphi не было возможности автоматически создавать консольные приложения (возможно на сегодняшний день этот недостаток устранён), поэтому мы создадим пустой файл и поместим в него следующий код:
program ConPrg;
{$APPTYPE CONSOLE}
begin
end.
|
Затем сохраним этот файл с расширением .dpr - в данном случае conprg.dpr. Далее, его можно загрузить в Delphi (File|Open) и приступить к добавлению кода.
Обратите внимание: Если Вы запустите вышеприведённую программу, то она немедленно завершится, так как в ней нет никакого рабочего кода.
Для начала, в неё можно добавить строчку readln:
program ConPrg;
{$APPTYPE CONSOLE}
begin
readln
end.
|
Вы увидите пустое текстовое окошко, которое закроется, если нажать клавишу Enter.
Идём дальше
Как упоминалось раньше, Вы можете использовать почти любую функцию Win32 API из консольного приложения. Такое приложение очень удобно ещё и тем, что о пользовательском интерфейсе можно вообще не думать, а для вывода информации использовать только пару функций Write/Writeln. Примеров применения консольных приложений великое множество: это и различного вида утилиты, и тестовые программы для проверки работы функций API и т.д. Мы не будет погружаться в примеры того как использовать определённые API, а поговорим только о Консольных API (Console API).
Консольные API (Console API)
Microsoft предоставляет определённый набор функций, которые очень даже полезны при создании консольных приложений. Для начала скажу, что существует по крайней мере два дескриптора (handles), которые связаны с консольным окном. Один для ввода, второй для вывода. Ниже приводятся две небольшие функции, которые показывают, как получить эти дескрипторы.
//----------------------------------------- // Получение дескриптора для консольного ввода //----------------------------------------- function GetConInputHandle : THandle; begin Result := GetStdHandle(STD_INPUT_HANDLE) end; //----------------------------------------- // Получение дескриптора для консольного вывода //----------------------------------------- function GetConOutputHandle : THandle; begin Result := GetStdHandle(STD_OUTPUT_HANDLE) end; |
Так же, лучше сразу создать свои функции для таких простых операций как позиционирование курсора, очистки экрана и отображение/скрытие курсора (так как в консольных API они немножко громозки и запутаны). Вот как они выглядят:
//----------------------------------------- // Установка курсора в координаты X, Y //----------------------------------------- procedure GotoXY(X, Y: Word); begin Coord.X := X; Coord.Y := Y; SetConsoleCursorPosition(ConHandle, Coord); end; //----------------------------------------- // Очистка экрана - заполнение его пробелами //----------------------------------------- procedure Cls; begin Coord.X := 0; Coord.Y := 0; FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW); GotoXY(0, 0); end; //-------------------------------------- // Показываем/Скрываем курсор //-------------------------------------- procedure ShowCursor(Show: Bool); begin CCI.bVisible := Show; SetConsoleCursorInfo(ConHandle, CCI); end; |
Как Вы успели заметить, мы воспользовались четырьмя функциями консольного API: GetStdHandle, SetConsoleCursorPosition, FillConsoleOutputCharacter, SetConsoleCursorInfo. Иногда может возникнуть задача определения размера консольного окна по вертикали и по горизонтали. Для этого мы создадим две переменные: MaxX и MaxY, типа WORD:
//-------------------------------------- // Инициализация глобальных переменных //-------------------------------------- procedure Init; begin // Получаем дескриптор вывода (output) ConHandle := GetConOutputHandle; // Получаем максимальные размеры окна Coord := GetLargestConsoleWindowSize(ConHandle); MaxX := Coord.X; MaxY := Coord.Y; end; |
Мы даже можем сделать "цикл обработки сообщений" (message loop) - для тех, кто только начинает программировать в Delphi - цикл обработки сообщений необходимо делать, если приложение создаётся в чистом API - при этом необходимы как минимум три составляющие: WinMain, message loop и window proc.
Ниже приведён код "цикла обработки сообщений":
SetConsoleCtrlHandler(@ConProc, False);
Cls;
//
// "Цикл обработки сообщений"
//
Continue := True;
while Continue do
begin
ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
case IBuff.EventType of
KEY_EVENT :
begin
// Проверяем клавишу ESC и завершаем программу
if ((IBuff.KeyEvent.bKeyDown = True) and
(IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
Continue := False;
end;
_MOUSE_EVENT :
begin
with IBuff.MouseEvent.dwMousePosition do
StatusLine(Format('%d, %d', [X, Y]));
end;
end;
end {While}
|
Так же можно добавить "обработчик событий" и перехватывать такие комбинации клавиш как Ctrl+C и Ctrl+Break:
//-----------------------------------------------------
// Обработчик консольных событий
//-----------------------------------------------------
function ConProc(CtrlType: DWord): Bool; stdcall; far;
var
S: string;
begin
case CtrlType of
CTRL_C_EVENT: S := 'CTRL_C_EVENT';
CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
else
S := 'UNKNOWN_EVENT';
end;
MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
Result := True;
end;
|
Чтобы посмотреть всё это в действии, я сделал небольшую демонстрационную программу, которая содержит подпрограммы, приведённые выше, а так же некоторые другие возможности. Далее приведён полный исходный код этого приложения. Наслаждайтесь!
{
[]-----------------------------------------------------------[]
CON001 - Show various Console API functions. Checked with Win95
version 1.01
by Alex G. Fedorov, May-July, 1997
alexfedorov@geocities.com
09-Jul-97 some minor corrections (shown in comments)
[]-----------------------------------------------------------[]
}
program Con001;
{$APPTYPE CONSOLE}
uses
Windows, SysUtils;
const
// Некоторые стандартные цвета
YellowOnBlue = FOREGROUND_GREEN or FOREGROUND_RED or
FOREGROUND_INTENSITY or BACKGROUND_BLUE;
WhiteOnBlue = FOREGROUND_BLUE or FOREGROUND_GREEN or
FOREGROUND_RED or FOREGROUND_INTENSITY or
BACKGROUND_BLUE;
RedOnWhite = FOREGROUND_RED or FOREGROUND_INTENSITY or
BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE
or BACKGROUND_INTENSITY;
WhiteOnRed = BACKGROUND_RED or BACKGROUND_INTENSITY or
FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE
or FOREGROUND_INTENSITY;
var
ConHandle: THandle; // Дескриптор консольного окна
Coord: TCoord; // Для хранения/установки позиции экрана
MaxX, MaxY: Word; // Для хранения максимальных размеров окна
CCI: TConsoleCursorInfo;
NOAW: LongInt; // Для хранения результатов некоторых функций
//-----------------------------------------
// Получение дескриптора для консольного ввода
//-----------------------------------------
function GetConInputHandle : THandle;
begin
Result := GetStdHandle(STD_INPUT_HANDLE)
end;
//-----------------------------------------
// Получение дескриптора для консольного вывода
//-----------------------------------------
function GetConOutputHandle : THandle;
begin
Result := GetStdHandle(STD_OUTPUT_HANDLE)
end;
//-----------------------------------------
// Установка курсора в координаты X, Y
//-----------------------------------------
procedure GotoXY(X, Y : Word);
begin
Coord.X := X;
Coord.Y := Y;
SetConsoleCursorPosition(ConHandle, Coord);
end;
//-----------------------------------------
// Очистка экрана - заполнение его пробелами
//-----------------------------------------
procedure Cls;
begin
Coord.X := 0;
Coord.Y := 0;
FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW);
GotoXY(0, 0);
end;
//--------------------------------------
// Показываем/Скрываем курсор
//--------------------------------------
procedure ShowCursor(Show : Bool);
begin
CCI.bVisible := Show;
SetConsoleCursorInfo(ConHandle, CCI);
end;
//--------------------------------------
// Инициализация глобальных переменных
//--------------------------------------
procedure Init;
begin
// Получаем дескриптор вывода (output)
ConHandle := GetConOutputHandle;
// Получаем максимальные размеры окна
Coord := GetLargestConsoleWindowSize(ConHandle);
MaxX := Coord.X;
MaxY := Coord.Y;
end;
//---------------------------------------
// рисуем строку статуса ("status line")
//---------------------------------------
procedure StatusLine(S : string);
begin
Coord.X := 0; Coord.Y := 0;
WriteConsoleOutputCharacter(ConHandle, PChar(S), Length(S)+1, Coord, NOAW);
FillConsoleOutputAttribute (ConHandle, WhiteOnRed, Length(S), Coord, NOAW);
end;
//-----------------------------------------------------
// Консольный обработчик событий
//-----------------------------------------------------
function ConProc(CtrlType : DWord) : Bool; stdcall; far;
var
S: string;
begin
case CtrlType of
CTRL_C_EVENT: S := 'CTRL_C_EVENT';
CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
else
S := 'UNKNOWN_EVENT';
end;
MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
Result := True;
end;
{
[]-----------------------------------------------------------[]
Основная программа - показывает использование некоторых подпрограмм
а так же некоторых функций консольного API
[]-----------------------------------------------------------[]
}
var
R: TSmallRect;
Color: Word;
OSVer: TOSVersionInfo;
IBuff: TInputRecord;
IEvent: DWord;
Continue: Bool;
begin
// Инициализация глобальных переменных
Init;
// Расположение окна на экране
{!! 1.01 !!}
with R do
begin
Left := 10;
Top := 10;
Right := 40;
Bottom := 40;
end
{!! 1.01 !!}
SetConsoleWindowInfo(ConHandle, False, R);
// Устанавливаем обработчик событий
SetConsoleCtrlHandler(@ConProc, True);
// Проверяем обработчик событий
GenerateConsoleCtrlEvent(CTRL_C_EVENT, 0);
// Изменяем заголовок окна
SetConsoleTitle('Console Demo');
// Прячем курсор
ShowCursor(False);
Coord.X := 0; Coord.Y := 0;
// Устанавливаем белый текст на синем фоне
Color := WhiteOnBlue;
FillConsoleOutputAttribute(ConHandle, Color, MaxX * MaxY, Coord, NOAW);
// Console Code Page API is not supported under Win95 - only GetConsoleCP
Writeln('Console Code Page = ', GetConsoleCP);
Writeln('Max X=', MaxX,' Max Y=', MaxY);
Readln; // ожидаем ввода пользователя
Cls; // очищаем экран
ShowCursor(True); // показываем курсор
// Use some Win32API stuff
OSVer.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(OSVer);
with OSVer do
begin
Writeln('dwMajorVersion = ', dwMajorVersion);
Writeln('dwMinorVersion = ', dwMinorVersion);
Writeln('dwBuildNumber = ', dwBuildNumber);
Writeln('dwPlatformID = ', dwPlatformID);
end;
// ожидаем ввода пользователя
Readln;
// Удаляем обработчик событий
SetConsoleCtrlHandler(@ConProc, False);
Cls;
// "Цикл обработки сообщений"
Continue := True;
while Continue do
begin
ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
case IBuff.EventType of
KEY_EVENT :
begin
// Проверяем клавишу ESC и завершаем программу
if ((IBuff.KeyEvent.bKeyDown = True) and
(IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
Continue := False;
end;
_MOUSE_EVENT :
begin
with IBuff.MouseEvent.dwMousePosition do
StatusLine(Format('%d, %d', [X, Y]));
end;
end;
end {While}
end.
|
Как можно гарантированно очистить экран в консольном приложении.
| Автор: Олег Кулабухов |
| Холодильник не был корректно закрыт перед последним выключением питания. Произвести проверку содержимого холодильника? При проверке было найдено один или несколько испорченых продуктов. Сохранить их в отдельном отсеке? Восстановить испорченные продукты? Восстановление не удалось, продукты доступны только для просмотра. |
Нужно просто использовать GetConsoleScreenBufferInfo() для ввода нескольких пустых строк.
program Project1;
{$APPTYPE CONSOLE}
uses
Windows;
{$R *.RES}
var
sbi: TConsoleScreenBufferInfo;
i: integer;
begin
Writeln('A Console Applicaiton');
Writeln('Press Enter To Clear The Screen');
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
sbi);
Readln;
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
sbi);
for i := 0 to sbi.dwSize.y do
writeln;
Writeln('Press Enter To End');
Readln;
end.
|
Как в консольном приложении можно задать цвет текста, вывести текст в нужном месте.
| Кафе... Неугомонная толпа, девушки на подиумах, официантки снуют в разные стороны. Бармен стоит, разливает бокалы, от посетителей нет отбоя... Вдруг в бар заходит лошадь, подходит к бармену и просит виски с содовой. Мужик в шоке, но наливает стакан виски, неотрывая офигевший взляд от лошади. Конь ему в ответ и говорит: "Да чё ты так смотришь, мужик, не боись, я к тебе в бар буду каждые выходные приходить, мне виски постоянно, понял???" А чё бармену то надо... Он, естественно, согласился, и сразу бросился к директору городского цирка. Мол, приходите ко мне на выходные в бар - за 500 баксов покажу говорящую лошадь. Директор, естественно, не поверил, но пошёл узнать, чё это за фигня там в баре у них. Приходит, значит, в субботу вечером,- и ровно в 8 часов заходит лошадь, кричит бармену, чтоб принесли заказ и садится за ближайший свободный столик. Директор сам не свой. Подбегает к лошади, просит, умоляет, чтоб она у него в цирке выступала. Лошадь ему: Л: -А платить сколько будете ?? Д: - согласен 1000$ за выход!! Л: - Тысяча, говоришь, это там, где площадка такая круглая ?? Ещё там звери всякие, мои сородичи по кругу бегают ?? д: -Ага, он самый, это и есть цирк. л: - Ну ладно, я , в принципе, согласен, только не пойму вот никак, зачем вам в том цирке программисты нужны??? %) |
Цвет Текста задается командой SetTextColor(Color), параметр Color - целое число от 0 до 15.
Вывод текста в указанном месте экрана задается командой GotoXY(X,Y,Text).
X,Y-координаты экрана Text - переменная типа StringВот текст модуля, напоминающего про наш любимый ДОС (CRT-like):
unit UffCRT;
interface
procedure ClrScr;
procedure SetAttr(attr: word);
function GetAttr: word;
procedure GotoXY(aX, aY: integer); { zero-based coords }
function WhereX: integer;
function WhereY: integer;
implementation
uses Windows;
var
UpperLeft: TCoord = (X:0; Y:0);
hCon: integer;
procedure GotoXY(aX, aY: integer);
var
aCoord: TCoord;
begin
aCoord.x:=aX;
aCoord.y:=aY;
SetConsoleCursorPosition(hCon,aCoord);
end;
procedure SetAttr(attr: word);
begin
SetConsoleTextAttribute(hCon,attr);
end;
function WhereX: integer;
var
ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
Result:=ScrBufInfo.dwCursorPosition.x;
end;
function WhereY: integer;
var
ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
Result:=ScrBufInfo.dwCursorPosition.y;
end;
function GetAttr: word;
var
ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
Result:=ScrBufInfo.wAttributes;
end;
procedure ClrScr;
var
fill: integer;
ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
fill:=ScrBufInfo.dwSize.x*ScrBufInfo.dwSize.y;
FillConsoleOutputCharacter(hCon,' ',fill,UpperLeft,fill);
FillConsoleOutputAttribute(hCon,ScrBufInfo.wAttributes, fill,
UpperLeft, fill);
GotoXY(0,0);
end;
initialization
hCon := GetStdHandle(STD_OUTPUT_HANDLE);
end.
|
Теперь можно творить такое:
uses UffCRT;
...
ClrScr;
SetAttr($1E);
GotoXY(32,12);
write('Delphi World is the BEST!');
ReadLn;
...
|
Переключение консольного приложения в полный экран.
| - Алло!!! Я у вас купил компьютер и он сдох, а была пожизненая гарантия?! - Ну все - гарантия кончилась... |
{
There is no documented way to make a console application fullscreen.
The following code works for both NT and Win9x.
For win NT I used the undocumented SetConsoleDisplayMode and
GetConsoleDisplayMode functions.
}
{
function GetConsoleDisplayMode(var lpdwMode: DWORD): BOOL; stdcall;
external 'kernel32.dll';
// lpdwMode: address of variable for current value of display mode
}
function NT_GetConsoleDisplayMode(var lpdwMode: DWORD): Boolean;
type
TGetConsoleDisplayMode = function(var lpdwMode: DWORD): BOOL;
stdcall;
var
hKernel: THandle;
GetConsoleDisplayMode: TGetConsoleDisplayMode;
begin
Result := False;
hKernel := GetModuleHandle('kernel32.dll');
if (hKernel > 0) then
begin @GetConsoleDisplayMode :=
GetProcAddress(hKernel, 'GetConsoleDisplayMode');
if Assigned(GetConsoleDisplayMode) then
begin
Result := GetConsoleDisplayMode(lpdwMode);
end;
end;
end;
{
function SetConsoleDisplayMode(hOut: THandle; // standard output handle
dwNewMode: DWORD; // specifies the display mode
var lpdwOldMode: DWORD // address of variable for previous value of display mode
): BOOL; stdcall; external 'kernel32.dll';
}
function NT_SetConsoleDisplayMode(hOut: THandle; dwNewMode: DWORD;
var lpdwOldMode: DWORD): Boolean;
type
TSetConsoleDisplayMode = function(hOut: THandle; dwNewMode: DWORD;
var lpdwOldMode: DWORD): BOOL;
stdcall;
var
hKernel: THandle;
SetConsoleDisplayMode: TSetConsoleDisplayMode;
begin
Result := False;
hKernel := GetModuleHandle('kernel32.dll');
if (hKernel > 0) then
begin @SetConsoleDisplayMode :=
GetProcAddress(hKernel, 'SetConsoleDisplayMode');
if Assigned(SetConsoleDisplayMode) then
begin
Result := SetConsoleDisplayMode(hOut, dwNewMode, lpdwOldMode);
end;
end;
end;
function GetConsoleWindow: THandle;
var
S: AnsiString;
C: Char;
begin
Result := 0;
Setlength(S, MAX_PATH + 1);
if GetConsoleTitle(PChar(S), MAX_PATH) <> 0 then
begin
C := S[1];
S[1] := '$';
SetConsoleTitle(PChar(S));
Result := FindWindow(nil, PChar(S));
S[1] := C;
SetConsoleTitle(PChar(S));
end;
end;
function SetConsoleFullScreen(bFullScreen: Boolean): Boolean;
const
MAGIC_CONSOLE_TOGGLE = 57359;
var
dwOldMode: DWORD;
dwNewMode: DWORD;
hOut: THandle;
hConsole: THandle;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
dwNewMode := Ord(bFullScreen);
NT_GetConsoleDisplayMode(dwOldMode);
hOut := GetStdHandle(STD_OUTPUT_HANDLE);
Result := NT_SetConsoleDisplayMode(hOut, dwNewMode, dwOldMode);
end
else
begin
hConsole := GetConsoleWindow;
Result := hConsole <> 0;
if Result then
begin
if bFullScreen then
begin
SendMessage(GetConsoleWindow, WM_COMMAND, MAGIC_CONSOLE_TOGGLE, 0);
end
else
begin
// Better solution than keybd_event under Win9X ?
keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0);
keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), 0, 0);
keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), KEYEVENTF_KEYUP, 0);
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
AllocConsole;
try
SetConsoleFullScreen(True);
Write('Hi, you are in full screen mode now. Type something [Return]: ');
Readln(s);
SetConsoleFullScreen(False);
// ShowMessage(Format('You typed: "%s"', [s]));
finally
FreeConsole;
end;
end;
|
Запуск программ с передачей консольного ввода и чтением вывода.
Автор: Алексей Бойко WEB-сайт: http://www.sources.ruЭто пример запуска консольных программ с передачей ей консольного ввода (как если бы он был введен с клавиатуры после запуска программы) и чтением консольного вывода. Таким способом можно запускать например стандартный виндовый ftp.exe (в невидимом окне) и тем самым отказаться от использования специализированных, зачастую глючных компонент.
function ExecuteFile(FileName, StdInput: string;
TimeOut: integer;
var StdOutput: string): boolean;
label
Error;
type
TPipeHandles = (IN_WRITE, IN_READ,
OUT_WRITE, OUT_READ,
ERR_WRITE, ERR_READ);
type
TPipeArray = array[TPipeHandles] of THandle;
var
i: integer;
ph: TPipeHandles;
sa: TSecurityAttributes;
Pipes: TPipeArray;
StartInf: TStartupInfo;
ProcInf: TProcessInformation;
Buf: array[0..1024] of byte;
TimeStart: TDateTime;
function ReadOutput: string;
var
i: integer;
s: string;
BytesRead: longint;
begin
Result := '';
repeat
Buf[0] := 26;
WriteFile(Pipes[OUT_WRITE], Buf, 1, BytesRead, nil);
if ReadFile(Pipes[OUT_READ], Buf, 1024, BytesRead, nil) then
begin
if BytesRead > 0 then
begin
buf[BytesRead] := 0;
s := StrPas(@Buf[0]);
i := Pos(#26, s);
if i > 0 then
s := copy(s, 1, i - 1);
Result := Result + s;
end;
end;
if BytesRead1024 then
break;
until false;
end;
begin
Result := false;
for ph := Low(TPipeHandles) to High(TPipeHandles) do
Pipes[ph] := INVALID_HANDLE_VALUE;
// Создаем пайпы
sa.nLength := sizeof(sa);
sa.bInheritHandle := TRUE;
sa.lpSecurityDescriptor := nil;
if not CreatePipe(Pipes[IN_READ], Pipes[IN_WRITE], @sa, 0) then
goto Error;
if not CreatePipe(Pipes[OUT_READ], Pipes[OUT_WRITE], @sa, 0) then
goto Error;
if not CreatePipe(Pipes[ERR_READ], Pipes[ERR_WRITE], @sa, 0) then
goto Error;
// Пишем StdIn
StrPCopy(@Buf[0], stdInput + ^Z);
WriteFile(Pipes[IN_WRITE], Buf, Length(stdInput), i, nil);
// Хендл записи в StdIn надо закрыть - иначе выполняемая программа
// может не прочитать или прочитать не весь StdIn.
CloseHandle(Pipes[IN_WRITE]);
Pipes[IN_WRITE] := INVALID_HANDLE_VALUE;
FillChar(StartInf, sizeof(TStartupInfo), 0);
StartInf.cb := sizeof(TStartupInfo);
StartInf.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartInf.wShowWindow := SW_SHOW; // SW_HIDE если надо запустить невидимо
StartInf.hStdInput := Pipes[IN_READ];
StartInf.hStdOutput := Pipes[OUT_WRITE];
StartInf.hStdError := Pipes[ERR_WRITE];
if not CreateProcess(nil, PChar(FileName), nil,
nil, True, NORMAL_PRIORITY_CLASS,
nil, nil, StartInf, ProcInf) then
goto Error;
TimeStart := Now;
repeat
Application.ProcessMessages;
i := WaitForSingleObject(ProcInf.hProcess, 100);
if i = WAIT_OBJECT_0 then
break;
if (Now - TimeStart) * SecsPerDay > TimeOut then
break;
until false;
if iWAIT_OBJECT_0 then
goto Error;
StdOutput := ReadOutput;
for ph := Low(TPipeHandles) to High(TPipeHandles) do
if Pipes[ph]INVALID_HANDLE_VALUE then
CloseHandle(Pipes[ph]);
CloseHandle(ProcInf.hProcess);
CloseHandle(ProcInf.hThread);
Result := true;
Exit;
Error:
if ProcInf.hProcessINVALID_HANDLE_VALUE then
begin
CloseHandle(ProcInf.hThread);
i := WaitForSingleObject(ProcInf.hProcess, 1000);
CloseHandle(ProcInf.hProcess);
if iWAIT_OBJECT_0 then
begin
ProcInf.hProcess := OpenProcess(PROCESS_TERMINATE,
FALSE,
ProcInf.dwProcessId);
if ProcInf.hProcess 0 then
begin
TerminateProcess(ProcInf.hProcess, 0);
CloseHandle(ProcInf.hProcess);
end;
end;
end;
for ph := Low(TPipeHandles) to High(TPipeHandles) do
if Pipes[ph]INVALID_HANDLE_VALUE then
CloseHandle(Pipes[ph]);
end;
Как переназначить вывод в файл для консольной программы, запускаемой по CreateProcess.
Автор: Кузнецов Алексей Специально для Королевства Delphi Я не профи в Win API, просто у меня возникла именно такая проблема. Я нашел решение устраивающее меня. И к тому же решил, поделился с вами. Если кому-то требуется что-то другое - дерзайте, я с удовольствием прочту на "Королевстве" что и как у вас получилось. Handle = Хэндл = Рукоятка :)Хочу предложить 2 способа:
1) Простой, с использованием command.com /c имя_консольной_проги > имя_файла_куда_переназначить_StdOut 2) С использованием Win API (2 штуки) Вы уж сами выберите, что вам подходит больше. Я использую способ № 2.2. Рассмотрим их более подробно на примерах.Способ №1
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
begin
GetStartupInfo(StartupInfo);
with StartupInfo do
begin
wShowWindow := SW_HIDE; //не показывать окно
dwFlags := STARTF_USESHOWWINDOW;
end;
// для примера будем запускать [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?'
Win32Check(CreateProcess(nil, 'command.com /c grep.exe ? > MyStdOut.txt',
nil, nil, FALSE, CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcessInformation));
// ждем пока наш процесс отработает
WaitForSingleObject(ProcInfo.hProcess, INFINITE);
Win32Check(CloseHandle(ProcInfo.hProcess);
end;
|
Способ №2.1
var
ProcInfo: TProcessInformation;
StartupInfo: TStartupInfo;
hOut, hOutDup: THandle;
begin
// Создаем файл в который и будем переназначать StdOut
// Например, с такими настройками, вы можете их изменить под свои нужды
hOut := CreateFile('MyStdOut.txt', GENERIC_WRITE, 0, nil,
CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if (hOut = INVALID_HANDLE_VALUE) then
RaiseLastWin32Error;
end;
|
Win32Check(DuplicateHandle(GetCurrentProcess, hOut, GetCurrentProcess, @hOutDup, 0, TRUE, DUPLICATE_SAME_ACCESS));Небольшое замечание: следует отметить, что если вы пишите прогу ТОЛЬКО под NT/2000, то сделать рукоятку наследуемой можно проще:
Win32Check(SetHandleInformation (hOut, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT);
И не надо будет заводить дубликат рукоятки hOutDup.
// эта рукоятка нам уже не нужна, хотя вы можете ее // использовать для своих целей Win32Check(CloseHandle(hOut)); GetStartupInfo(StartupInfo); with StartupInfo do begin wShowWindow := SW_HIDE; // не показывать окно dwFlags := dwFlags or STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; hStdOutput := hOutDup; // присваиваем рукоятку на свой файл end; |
Для примера будем запускать [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?' Вызов CreateProcess с флагом bInheritHandles = TRUE !!!
Win32Check(CreateProcess(nil, 'grep.exe ?', nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcInfo)); // ждем пока наш процесс отработает WaitForSingleObject(ProcInfo.hProcess, INFINITE); Win32Check(CloseHandle(ProcInfo.hProcess)); // если вы больше ничего не хотите делать с файлом, в который // перенаправили StdOut, то закроем его Win32Check(CloseHandle(hOutDup)); end; |
Этот способ мне показал Юрий Зотов (поместив его в разделе "Обсуждение статьи"), спасибо. Оказывается, рукоятку гораздо проще сделать наследуемой, если использовать SECURITY_ATTRIBUTES.
var
ProcInfo: TProcessInformation;
StartupInfo: TStartupInfo;
SecAtrtrs: TSecurityAttributes;
hOut: THandle;
begin
with SecAtrtrs do
begin
nLength := SizeOf(TSecurityAttributes);
lpSecurityDescriptor := nil;
bInheritHandle := true; // ВОТ ОНО !!! Наша рукоятка будет НАСЛЕДУЕМОЙ
end;
// Создаем файл в который и будем переназначать StdOut
// Например, с такими настройками, вы можете их изменить под свои нужды
hOut := CreateFile('MyStdOut.txt', GENERIC_WRITE, 0, @SecAtrtrs,
CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if (hOut = INVALID_HANDLE_VALUE) then
RaiseLastWin32Error;
GetStartupInfo(StartupInfo);
with StartupInfo do
begin
wShowWindow := SW_HIDE; // не показывать окно
dwFlags := dwFlags or STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
hStdOutput := hOutDup; // присваиваем рукоятку на свой файл
end;
// для примера будем запускать
// [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?'
// Вызов CreateProcess с флагом bInheritHandles = TRUE !!!
Win32Check(CreateProcess(nil, 'grep.exe ?', nil, nil, TRUE,
CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcInfo));
// ждем пока наш процесс отработает
WaitForSingleObject(ProcInfo.hProcess, INFINITE);
Win32Check(CloseHandle(ProcInfo.hProcess));
// если вы больше ничего не хотите делать с файлом, в который
// перенаправили StdOut, то закроем его
Win32Check(CloseHandle(hOut));
end;
|
Кстати, кто хочет узнать на эту тему больше - откройте Win32.hlp (поставляется вместе с Делфой) и на закладке "Предметный указатель" наберите "Creating a Child Process with Redirected Input and Output", "Inheritance" и "SECURITY_ATTRIBUTES" и ВНИМАТЕЛЬНО изучите. Изучив эти (и смежные) разделы вы сможете переназначить StdOut, StdIn и StdErr куда вам захочется.
Как вывести результат работы консоли в Memo.
Автор: Song WEB-сайт: http://www.torry.net
procedure RunDosInMemo(CmdLine: string; AMemo: TMemo);
const
ReadBuffer = 2400;
var
Security: TSecurityAttributes;
ReadPipe, WritePipe: THandle;
start: TStartUpInfo;
ProcessInfo: TProcessInformation;
Buffer: Pchar;
BytesRead: DWord;
Apprunning: DWord;
begin
Screen.Cursor := CrHourGlass;
Form1.Button1.Enabled := False;
with Security do
begin
nlength := SizeOf(TSecurityAttributes);
binherithandle := true;
lpsecuritydescriptor := nil;
end;
if Createpipe(ReadPipe, WritePipe,
@Security, 0) then
begin
Buffer := AllocMem(ReadBuffer + 1);
FillChar(Start, Sizeof(Start), #0);
start.cb := SizeOf(start);
start.hStdOutput := WritePipe;
start.hStdInput := ReadPipe;
start.dwFlags := STARTF_USESTDHANDLES +
STARTF_USESHOWWINDOW;
start.wShowWindow := SW_HIDE;
if CreateProcess(nil,
PChar(CmdLine),
@Security,
@Security,
true,
NORMAL_PRIORITY_CLASS,
nil,
nil,
start,
ProcessInfo) then
begin
repeat
Apprunning := WaitForSingleObject
(ProcessInfo.hProcess, 100);
ReadFile(ReadPipe, Buffer[0],
ReadBuffer, BytesRead, nil);
Buffer[BytesRead] := #0;
OemToAnsi(Buffer, Buffer);
AMemo.Text := AMemo.text + string(Buffer);
Application.ProcessMessages;
until (Apprunning <> WAIT_TIMEOUT);
end;
FreeMem(Buffer);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(ReadPipe);
CloseHandle(WritePipe);
end;
Screen.Cursor := CrDefault;
Form1.Button1.Enabled := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
RunDosInMemo('ping -t 192.168.28.200', Memo1);
end;
Как консольное приложение может узнать, что Винды завершаются.
| Автор: Nomadic |
| Нищий на улице обращяется к Интернетчику: - Гражданин, подайте на пропитание. - А y тебя HTTPS есть? - Нет. - Тогда не дам, опасно. |
BOOL Ctrl_Handler( DWORD Ctrl )
{
if( (Ctrl == CTRL_SHUTDOWN_EVENT) || (Ctrl == CTRL_LOGOFF_EVENT) )
{
// Вау! Юзер обламывает!
}
else
{
// Тут что-от другое можно творить. А можно и не творить :-)
}
return TRUE;
}
function Ctrl_Handler(Ctrl: Longint): LongBool;
begin
if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then
begin
// Вау, вау
end
else
begin
// Am I creator?
end;
Result := true;
end;
|
А где-то в программе:
SetConsoleCtrlHandler( Ctrl_Handler, TRUE ); |
Короче, смотри описание SetConsoleCtrlHandler -- там всё есть.
Консольная программа – перевод фунтов в килограммы.
program funt2kg;
{$APPTYPE CONSOLE}
// Функция Rus преобразует ANSI-строку в ASCII-строку
function Rus(mes: string): string;
// В ANSI русские буквы кодируются числами от 192 до 255,
// в ASCII - от 128 до 175 (А..Яа..п) и от 224 239 (р..я).
var
i: integer; // номер обрабатываемого символа
begin
for i := 1 to length(mes) do
case mes[i] of
'А'..'п': mes[i] := Chr(Ord(mes[i]) - 64);
'р'..'я': mes[i] := Chr(Ord(mes[i]) - 16);
end;
rus := mes;
end;
// основная программа
var
f: real; // вес в фунтах }
w: real; // вес в граммах }
k: integer; // кол-во килограмм }
g: integer; // кол-во грамм }
// w = f*0,4095 = k*1000 + g
begin
writeln(Rus('Фунты-килограммы'));
writeln(Rus('Введите вес в фунтах и нажмите <Enter>'));
write('-> ');
readln(f);
w := f * 409.5; // один фунт - это 409,5 гр.
if w > 1000 then
begin
k := Trunc(w / 1000);
g := Round(w - k * 1000);
end
else
begin
k := 0;
g := Round(w);
end;
write(f: 4: 2, Rus(' ф. - это '));
if k >= 1 then write(k, Rus(' кг. '));
writeln(g, Rus(' гр.'));
write(Rus('Для завершения нажмите <Enter>'));
readln;
end.
Как сделать, чтобы в DBGrid вместо цифр были соответствующие константы.
| Ламер к юзеру пришел, и спросил наш ламер: "Что такой дисковод, и что такое сканер?" Юзер голову поднял и ответил ясно: "Шел бы ты куда подальше, идиот несчастный!" |
procedure TForm1.Grid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
// ВАЖНО: имя поля большими буквами!
if Column.Field.FieldName = 'PLATEZH' then
begin
Grid1.Canvas.FillRect(Rect);
if Column.Field.AsInteger = 0 then
Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'наличными')
else
Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'безнал');
end;
end;
|
Что я получаю от наличия ConstraintBroker.
Автор: NomadicConstraintBroker позволяет Вам включать проверки на ограничения в данные. Это означает, что когда Вы запрашиваете данные, Вы получаете вместе с ними и правила, которым они дорлжны удовлетворять. Эти правила автоматически без дополнительного кода входят в силу. Поскольку это происходит без единой строчки кода, то Вам не требуется переписывать или обновлять приложение каждый раз при изменении правил. Фактически это простое решение задачи обновления клиентского приложения без выхода из него. Каждое приложение, использующее ConstraintBroker, автоматически получает это качество..
Как ограничить длину текста, вводимого в TEdit, так чтобы ширина текста не превышала ширину ТЕditа.
| Windows CE + Windows ME + Windows NT = Windows CEMENT. |
В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна ТЕdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство ТЕdit'а MaxLength равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress ТЕdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область ТЕdit'а новый символ отбрасывается и вызывается MessageBeep.
procedure TForm1.FormCreate(Sender: TObject);
var
cRect: TRect;
bm: TBitmap;
s: string;
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
s := 'W';
while bm.Canvas.TextWidth(s) do
s := s + 'W';
if length(s) > 1 then
begin
Delete(s, 1, 1);
Edit1.MaxLength := Length(s);
end;
end;
{Другой вариант}
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
cRect: TRect;
bm: TBitmap;
begin
if ((Ord(Key) VK_TAB) and (Ord(Key) VK_RETURN) and
(Ord(Key) VK_LEFT) and (Ord(Key) VK_BACK)) then
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
begin
Key := #0;
MessageBeep(-1);
end;
bm.Free;
end;
end;
|
Ограничение размеров окна.
private
{ Private declarations }
procedure WMGetMinMaxInfo(var Info: TWMGetMinMaxInfo); message wm_GetMinMaxInfo;
implementation
{$R *.DFM}
procedure TForm1.WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo);
begin
with Info.MinMaxInfo^ do
begin
ptMinTrackSize.x := 200;
ptMinTrackSize.y := 100;
ptMaxTrackSize.x := 300;
ptMaxTrackSize.y := 200;
ptMaxPosition.x := BoundsRect.Left;
ptMaxPosition.y := BoundsRect.top;
end;
inherited;
end;
|
Использовать консоль в неконсольном приложении.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
For implementing console input/output for non-console applications you
should use the AllocConsole and FreeConsole functions.
The AllocConsole function allocates a new console for the calling process.
The FreeConsole function detaches the calling process from its console.
Example below demonstrates using these functions:
**
Um eine Konsole in Nicht-Konsole Anwendungen zu
implementieren, verwende die AllocConsole API Funktion auf
und FreeConsole um sie wieder freizugeben.
Das Untenstehende Beispiel zeigt, wie man diese Funktionen
verwendet.
}
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
AllocConsole;
try
// Change color attributes
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
FOREGROUND_BLUE OR FOREGROUND_GREEN or
BACKGROUND_RED );
Write('Type here your words and press ENTER: ');
Readln(s);
ShowMessage(Format('You typed: "%s"', [s]));
finally
FreeConsole;
end;
end;
Контролы в WinXP выглядят как в WinXP.
Наверняка, если ты кодишь на Delphi и твоя ось на данный момент это Windows XP ты заметил что твои проги после компиляции не выглядят по ХР'шному, т.е. все кнопки и другие элементы программы остались такими же как и в прошлых Виндах (Win98,2000 и т.д.)... Чтобы исправить эту проблему и продолжить нормально кодить под Win XP делаем следущее: 1) Создаем файл (например mainfest.txt) со следующим содержимым и сохраняем его:| <?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> <assemblyIdentity name="Microsoft.Windows.ApplicationName" processorArchitecture="x86" version="1.0.0.0" type="win32"/> <description>ApplicationDescription</description> <dependency> <dependentAssembly> <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="x86" publicKeyToken="6595b64144ccf1df" language="*" /> </dependentAssembly> </dependency> </assembly> |
2)Создаем еще один файл , в нем пишем:
| 1 24 [путь к файлу]/manifest.txt и сохранем его в папку ../Delphi/Bin/ с именем resfile.rc |
{$R resfile.res}
|
Вот и всё! Теперь можно смело сказать что ваша прога заточена под Windows XP ;)
Сворачивание компонентов на форме.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject); begin CloseWindow(Button1.Handle); end;
Размещать свои элементы управления в диалоге печати.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Unit for TExtendedPrintDialog
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtDlgs, extctrls, stdctrls, CommDlg, Dlgs;
type
TExtendedPrintDialog = class(TPrintDialog)
private
fExtendedPanel: TPanel;
fCheckBoxOne,
fCheckBoxTwo: TCheckbox;
fButton: TButton;
protected
procedure DoShow; override;
function GetStaticRect: TRect;
function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
override;
public
constructor Create(AOwner: TComponent); override;
function Execute: Boolean; override;
end;
implementation
constructor TExtendedPrintDialog.Create(AOwner: TComponent);
var
iTop: Integer;
begin
inherited;
fExtendedPanel := TPanel.Create(Self);
with fExtendedPanel do
begin
Name := 'ExtendedPanel';
Caption := '';
SetBounds(0, 0, 169, 200); // (204, 5, 169, 200);
BevelOuter := bvNone;
BorderWidth := 6;
TabOrder := 1;
fButton := TButton.Create(Self);
with fButton do
begin
Name := 'SomeButton';
Caption := '&Options';
SetBounds(0, 10, 50, 21);
Parent := fExtendedPanel;
end;
fCheckBoxOne := TCheckbox.Create(Self);
with fCheckBoxOne do
begin
Name := 'CheckboxOne';
Caption := 'Upside-down print';
SetBounds(fButton.Left + fButton.Width + 10, 3, 110, 21);
fCheckBoxOne.Parent := fExtendedPanel;
end;
fCheckBoxTwo := TCheckbox.Create(Self);
with fCheckBoxTwo do
begin
Name := 'CheckboxTwo';
Caption := 'Sideways print';
SetBounds(fButton.Left + fButton.Width + 10, 23, 100, 21);
Parent := fExtendedPanel;
end;
end
end;
procedure TExtendedPrintDialog.DoShow;
var
PreviewRect, StaticRect: TRect;
begin
{ Set preview area to entire dialog }
GetClientRect(Handle, PreviewRect);
StaticRect := GetStaticRect;
{ Move extended area to right of static area }
PreviewRect.Left := StaticRect.Left;
PreviewRect.Top := StaticRect.Bottom;
Inc(PreviewRect.Top, 4);
fExtendedPanel.BoundsRect := PreviewRect;
fExtendedPanel.ParentWindow := Handle;
inherited DoShow;
end;
function TExtendedPrintDialog.Execute: Boolean;
begin
Template := 'DLGTEMPLATE';// this is in the extdlgs.rc
Result := inherited Execute;
end;
function TExtendedPrintDialog.GetStaticRect: TRect;
begin
if Handle <> 0 then
begin
GetWindowRect(GetDlgItem(Handle, grp1), Result); // print range group box
MapWindowPoints(0, Handle, Result, 2);
end
else
Result := Rect(0, 0, 0, 0)
end;
function TExtendedPrintDialog.TaskModalDialog(DialogFunc: Pointer;
var DialogData): Bool;
begin
TPrintDlg(DialogData).Flags := TPrintDlg(DialogData).Flags or
PD_ENABLESETUPTEMPLATE;
TPrintDlg(DialogData).lpSetupTemplateName := Template;
Result := inherited TaskModalDialog(DialogFunc, DialogData);
end;
end.
//Example, Beispiel:
uses
Unit2;
procedure TForm1.Button1Click(Sender: TObject);
var
PrintDialog: TExtendedPrintDialog;
begin
PrintDialog := TExtendedPrintDialog.Create(nil);
if PrintDialog.Execute then
{do soemthing}
end;
Использование клавиш для управления компонентами.
| Автор: Robert Wittig |
| Все, что написано на клаве Ведет к погибели иль славе... |
Надеюсь, что вам помог.
procedure TForm1.FormActivate(Sender: TObject);
begin
{ Делаем ссылку на нового обработчика сообщений }
Application.OnMessage := ProcessFormMessages;
end;
procedure tForm1.ProcessFormMessages(var Msg: tMsg;
var Handled: Boolean);
var
Increment: Byte;
TheControl: tWinControl;
begin
{ проверка наличия системного сообщения KeyDown }
case Msg.Message of
WM_KEYDOWN: if Msg.wParam in [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT] then
begin
{ изменяем величину приращения взависимости
от состояния клавиши Shift }
if GetKeyState(VK_SHIFT) and $80 = 0 then
Increment := 8
else
Increment := 1;
{ Этот код перемещает управление на родительский
GroupBox, если один из его контейнерных элементов
получает фокус. Если вам необходимо управлять
элементами внутри контейнера, удалите блок IF и
измените в блоке CASE TheControl на ActiveControl }
if (ActiveControl.Parent is tGroupBox) then
TheControl := ActiveControl.Parent
else
TheControl := ActiveControl;
case Msg.wParam of
VK_UP: TheControl.Top := TheControl.Top - Increment;
VK_DOWN: TheControl.Top := TheControl.Top + Increment;
VK_LEFT: TheControl.Left := TheControl.Left - Increment;
VK_RIGHT: TheControl.Left := TheControl.Left + Increment;
end;
{ сообщаем о том, что сообщение обработано }
Handled := True;
end;
end;
end;
|
Контролировать Excel, используя OLE.
uses
ComObj;
var
ExcelApp: OleVariant;
implementation
procedure TForm1.Button1Click(Sender: TObject);
const
// SheetType
xlChart = -4109;
xlWorksheet = -4167;
// WBATemplate
xlWBATWorksheet = -4167;
xlWBATChart = -4109;
// Page Setup
xlPortrait = 1;
xlLandscape = 2;
xlPaperA4 = 9;
// Format Cells
xlBottom = -4107;
xlLeft = -4131;
xlRight = -4152;
xlTop = -4160;
// Text Alignment
xlHAlignCenter = -4108;
xlVAlignCenter = -4108;
// Cell Borders
xlThick = 4;
xlThin = 2;
var
ColumnRange: OleVariant;
// Function to get the number of Rows in a Certain column
function GetLastLine(AColumn: Integer): Integer;
const
xlUp = 3;
begin
Result := OLEConTainer1.OleObject.Range[Char(96 + AColumn) +
IntToStr(65536)].end[xlUp].Rows.Row;
end;
begin
{ Start Excel }
// By using GetActiveOleObject, you use an instance o
// f Word that's already running,
// if there is one.
try
ExcelApp := GetActiveOleObject('Excel.Application');
except
try
// If no instance of Word is running, try to Create a new Excel Object
ExcelApp := CreateOleObject('Excel.Application');
except
ShowMessage('Cannot start Excel/Excel not installed ?');
Exit;
end;
end;
// Add a new Workbook, Neue Arbeitsmappe offnen
ExcelApp.Workbooks.Add(xlWBatWorkSheet);
// Open a Workbook, Arbeitsmappe offnen
ExcelApp.Workbooks.Open('c:\YourFileName.xls');
// Rename the active Sheet
ExcelApp.ActiveSheet.Name := 'This is Sheet 1';
// Rename
ExcelApp.Workbooks[1].WorkSheets[1].Name := 'This is Sheet 1';
// Insert some Text in some Cells[Row,Col]
ExcelApp.Cells[1, 1].Value := 'SwissDelphiCenter.ch';
ExcelApp.Cells[2, 1].Value := 'http://www.swissdelphicenter.ch';
ExcelApp.Cells[3, 1].Value := FormatDateTime('dd-mmm-yyyy', Now);
// Setting a row of data with one call
ExcelApp.Range['A2', 'D2'].Value := VarArrayOf([1, 10, 100, 1000]);
// Setting a formula
ExcelApp.Range['A11', 'A11'].Formula := '=Sum(A1:A10)';
// Change Cell Alignement
ExcelApp.Cells[2, 1].HorizontalAlignment := xlright;
// Change the Column Width.
ColumnRange := ExcelApp.Workbooks[1].WorkSheets[1].Columns;
ColumnRange.Columns[1].ColumnWidth := 20;
ColumnRange.Columns[2].ColumnWidth := 40;
// Change Rowheight / Zeilenhohe andern:
ExcelApp.Rows[1].RowHeight := 15.75;
// Merge cells, Zellen verbinden:
ExcelApp.Range['B3:D3'].Mergecells := True;
// Apply borders to cells, Zellen umrahmen:
ExcelApp.Range['A14:M14'].Borders.Weight := xlThick; // Think line/ Dicke Linie
ExcelApp.Range['A14:M14'].Borders.Weight := xlThin; // Thin line Dunne Linie
// Set Bold Font in cells, Fettdruck in den Zellen
ExcelApp.Range['B16:M26'].Font.Bold := True;
// Set Font Size, Schriftgro?e setzen
ExcelApp.Range['B16:M26'].Font.Size := 12;
//right-aligned Text, rechtsbundige Textausrichtung
ExcelApp.Cells[9, 6].HorizontalAlignment := xlright;
// horizontal-aligned text, horizontale Zentrierung
ExcelApp.Range['B14:M26'].HorizontalAlignment := xlHAlignCenter;
// left-aligned Text, vertikale Zentrierung
ExcelApp.Range['B14:M26'].VerticallyAlignment := xlVAlignCenter;
{ Page Setup }
ExcelApp.ActiveSheet.PageSetup.Orientation := xlLandscape;
// Left, Right Margin (Seitenrander)
ExcelApp.ActiveSheet.PageSetup.LeftMargin := 35;
ExcelApp.ActiveSheet.PageSetup.RightMargin := -15;
// Set Footer Margin
ExcelApp.ActiveSheet.PageSetup.FooterMargin := ExcelApp.InchesToPoints(0);
// Fit to X page(s) wide by Y tall
ExcelApp.ActiveSheet.PageSetup.FitToPagesWide := 1; // Y
ExcelApp.ActiveSheet.PageSetup.FitToPagesTall := 3; // Y
// Zoom
ExcelApp.ActiveSheet.PageSetup.Zoom := 95;
// Set Paper Size:
ExcelApp.PageSetup.PaperSize := xlPaperA4;
// Show/Hide Gridlines:
ExcelApp.ActiveWindow.DisplayGridlines := False;
// Set Black & White
ExcelApp.ActiveSheet.PageSetup.BlackAndWhite := False;
// footers
ExcelApp.ActiveSheet.PageSetup.RightFooter := 'Right Footer / Rechte Fu?zeile';
ExcelApp.ActiveSheet.PageSetup.LeftFooter := 'Left Footer / Linke Fu?zeile';
// Show Excel Version:
ShowMessage(Format('Excel Version %s: ', [ExcelApp.Version]));
// Show Excel:
ExcelApp.Visible := True;
// Save the Workbook
ExcelApp.SaveAs('c:\filename.xls');
// Save the active Workbook:
ExcelApp.ActiveWorkBook.SaveAs('c:\filename.xls');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
// Quit Excel
if not VarIsEmpty(ExcelApp) then
begin
ExcelApp.DisplayAlerts := False; // Discard unsaved files....
ExcelApp.Quit;
end;
end;
|
Изображение контрола сохранить в файл.
| Билл Гейтс спросил меня, наверное, уже тысячу раз: - Хочешь сохранить изменения? Когда же он, наконец, спросит: - Хочешь изменить сохранения? |
procedure TForm1.GrabControl(const aControl: TControl;
const FileName: string);
var
B: TBitmap;
srcRect,dstRect: TRect;
begin
B:=TBitmap.Create;
with dstRect do begin
Left:=0;
Top:=0;
Right:=aControl.Width+1;
Bottom:=aControl.Height+1;
end;
with srcRect do begin
Left:=aControl.Left;
Right:=aControl.Left+aControl.Width;
Top:=aControl.Top;
Bottom:=aControl.Top+aControl.Height;
end;
B.Width:=aControl.Width;
B.Height:=aControl.Height;
B.Canvas.CopyRect(dstRect,Self.Canvas,srcRect);
// сохранить с палитрой 256 цветов
B.PixelFormat:=pf8bit;
B.SaveToFile(FileName);
B.Free;
end;
...
GrabControl(Memo1,'memo_pic.bmp');
GrabControl(Edit1,'edit_pic.bmp');
|
Управлять сервисом на другом компьютере в W2k.
| Три женщины одеваются в раздевалке после занятия спортивной аэробикой. Разговор, конечно, о мужьях. - Мой муж, - говорит первая, - работает учителем. Он всегда дарит мне коробку конфет или букет цветов перед тем, как овладеть мною. - А мой - ювелир, - говорит вторая, - перед тем как заняться любовью со мной, - он дарит мне жемчужину. Третья женщина задумалась на минутку и говорит: - А мой муж работает в Микрософт. Он всегда присаживается на край кровати и рассказывает мне, как это будет здорово для меня, когда он меня трахнет. |
uses
Windows, Messages, SysUtils, StdCtrls, SvcMgr;
var
ssStatus: TServiceStatus;
schSCManager, schService: SC_HANDLE ;
begin
schSCManager := OpenSCManager( PChar('Comp1'), // имя компьютера, nil - local machine
nil, // ServicesActive database
SC_MANAGER_ALL_ACCESS); // full access rights
if schSCManager = 0 then
exit; //Ошибка?
schService := OpenService(
schSCManager, // SCM database
PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent
SERVICE_ALL_ACCESS);
if schService = 0 then
exit; //Ошибка?
if not QueryServiceStatus(
schService, // handle to service
ssStatus) then // address of status information structure
exit; //Ошибка?
case ssStatus.dwCurrentState of:
SERVICE_RUNNING: ShowMessage('Работает!');
SERVICE_STOPPED: ShowMessage('Выключен');
// ну и т.д.
end;
end;
|
Получить заголовок элемента управления под мышкой.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetCaptionAtPoint(CrPos: TPoint): string;
var
textlength: Integer;
Text: PChar;
Handle: HWND;
begin
Result := 'Empty';
Handle := WindowFromPoint(CrPos);
if Handle = 0 then Exit;
textlength := SendMessage(Handle, WM_GETTEXTLENGTH, 0, 0);
if textlength <> 0 then
begin
getmem(Text, textlength + 1);
SendMessage(Handle, WM_GETTEXT, textlength + 1, Integer(Text));
Result := Text;
freemem(Text);
end;
end;
Функция вычисления контрольной суммы.
| Один программист спрашивает у другого: - Как ты считаешь контрольную сумму? Второй не задумываясь: - Я честно считаю контрольную сумму! |
//Проверка ИНН
//Функция вычисления контрольной суммы
function TForm1.KontrSumINN(n:integer;inn:string):integer;
var
s, i: integer;
checksum: array [1..11] of integer;
begin
s:=0;
checksum[1] :=3;
checksum[2] :=7;
checksum[3] :=2;
checksum[4] :=4;
checksum[5] :=10;
checksum[6] :=3;
checksum[7] :=5;
checksum[8] :=9;
checksum[9] :=4;
checksum[10]:=6;
checksum[11]:=8;
for i:=1 to n-1 do
s:=s+(strtoint(copy(inn,i,1))*checksum[12-n+i]);
Result:=s mod 11 mod 10;
end;
//Функция проверки ИНН, если ИНН правильный возвращает TRUE
function TForm1.INN(inn:string):boolean;
var
len:integer;
begin
len:=length(inn);
Result:=false;
if len = 10 then
if strtoint(copy(inn,10,1))=KontrSumINN(10,inn) then
Result:=true;
if len = 11 then
if strtoint(copy(inn,11,1))=KontrSumINN(11,inn) then
Result:=true;
if len = 12 then
if strtoint(copy(inn,12,1))=KontrSumINN(12,inn) then
Result:=true;
end;
//Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
if Inn('5436100041') then
label1.Caption:='ИНН Правильный!'
else
label1.Caption:='ИНН НЕ Правильный!';
// inn('5436100041')=true;
// inn('5436100042')=false;
end;
|
Получить активный элемент управления под курсором мышки.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{ Sie konnen z.B diese Funktion in einer allgemein gultigen
Prozedure aufrufen, die Sie dann allen betroffenen Ereignisse
zuweisen. }
{ You may call this function in a global event procedure,
linking as many components events to it as you need. }
function FindControlAtPos: TWinControl;
var
Pt: TPoint;
begin
GetCursorPos(Pt);
Result := FindControl(WindowFromPoint(Pt));
end;
{ (Beispiel) Hier die allgemein gultige Procedure fur OnMouseUp.
Die Behandlung von OnClick bleibt dabei erhalten:
die Funktionalitat aus OnMouseUp kommt dazu. }
{ (example) There's the global proc for the OnMouseUp event.
Note: OnClick keeps working, so you can "add" the OnMouseUp
facility to no cost. }
procedure TForm1.GenericMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
TWC: TWinControl;
begin
TWC := FindControlAtPos;
//what for a class !
Showmessage('Here we are: ' + TWC.ClassName);
//Let it blink...
TWC.Visible := False;
Sleep(150);
TWC.Visible := True;
end;
Преобразуем доменное имя в IP-адрес.
| Развод по-инетовски: В игнор и девичий IP. |
Описывается функция, которая показывает, как вычислить IP адрес компьютера в интернете по его доменному имени.
Объявляем Winsock, для использования в функции:
function HostToIP(name: string; var Ip: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
if Assigned (hostEnt^.h_addr_list) then begin
addr := hostEnt^.h_addr_list^;
if Assigned (addr) then begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else begin
Result := False;
end;
finally
WSACleanup;
end
end;
|
Вы можете разместить на форме Edit, Кнопку и Label и добавить к кнопке следующий обработчик события OnClick:
procedure TForm1.Button1Click(Sender: TObject);
var
IP: string;
begin
if HostToIp(Edit1.Text, IP) then
Label1.Caption := IP;
end;
|
Преобразование цвета RGB в HLS.
{ Максимальные значения }
const
HLSMAX = 240;
RGBMAX = 255;
UNDEFINED = (HLSMAX*2) div 3;
var
H, L, S: integer; { H-оттенок, L-яркость, S-насыщенность }
R, G, B: integer; { цвета }
procedure RGBtoHLS;
var
cMax, cMin: integer;
Rdelta, Gdelta, Bdelta: single;
begin
cMax := max( max(R,G), B);
cMin := min( min(R,G), B);
L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );
if (cMax = cMin) then
begin
S := 0;
H := UNDEFINED;
end
else
begin
if (L then
S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
else
S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
/ (2*RGBMAX-cMax-cMin) );
Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
if (R = cMax) then
H := round(Bdelta - Gdelta)
else
if (G = cMax) then
H := round( (HLSMAX/3) + Rdelta - Bdelta)
else
H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
if (H then
H:=H + HLSMAX;
if (H > HLSMAX) then
H:= H - HLSMAX;
end;
if Sthen
S:=0;
if S>HLSMAX then
S:=HLSMAX;
if Lthen
L:=0;
if L>HLSMAX then
L:=HLSMAX;
end;
procedure HLStoRGB;
var
Magic1, Magic2: single;
function HueToRGB(n1, n2, hue: single): single;
begin
if (hue then
hue := hue+HLSMAX;
if (hue > HLSMAX) then
hue:=hue - HLSMAX;
if (hue then
result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
else
if (hue then
result:=n2
else
if (hue then
result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
else
result:= ( n1 );
end;
begin
if (S = 0) then
begin
B:=round( (L*RGBMAX)/HLSMAX );
R:=B;
G:=B;
end
else
begin
if (L then
Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
else
Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
Magic1 := 2*L-Magic2;
R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
end;
if Rthen
R:=0;
if R>RGBMAX then
R:=RGBMAX;
if Gthen
G:=0;
if G>RGBMAX then
G:=RGBMAX;
if Bthen
B:=0;
if B>RGBMAX then
B:=RGBMAX;
end;
|
Преобразование в EBCDIC.
| Автор: Matthew Augier |
| - Ну какой ты гад, ну какой ты гад! - сказал громко Билл Гейтс и улыбнулся своему отражению. |
Const
a2e: array [0..255] of byte =
(000,001,002,003,055,045,046,047,022,005,037,011,012,013,014,159,
016,017,018,019,182,181,050,038,024,025,063,039,028,029,030,031,
064,090,127,123,091,108,080,125,077,093,092,078,107,096,075,097,
240,241,242,243,244,245,246,247,248,249,122,094,076,126,110,111,
124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
215,216,217,226,227,228,229,230,231,232,233,173,224,189,095,109,
121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
151,152,153,162,163,164,165,166,167,168,169,192,106,208,161,007,
104,220,081,066,067,068,071,072,082,083,084,087,086,088,099,103,
113,156,158,203,204,205,219,221,224,236,252,176,177,178,062,180,
069,085,206,222,073,105,154,155,171,015,186,184,183,170,138,139,
060,061,098,079,100,101,102,032,033,034,112,035,114,115,116,190,
118,119,120,128,036,021,140,141,142,065,006,023,040,041,157,042,
043,044,009,010,172,074,174,175,027,048,049,250,026,051,052,053,
054,089,008,056,188,057,160,191,202,058,254,059,004,207,218,020,
225,143,070,117,253,235,238,237,144,239,179,251,185,234,187,255);
Procedure StringA2E(var StringToConvert:String);
Var
Loop: Integer;
begin
For Loop := 1 to length(StringToConvert) do
StringToConvert[Loop] := a2e[ord(StringToConvert[Loop])];
end;
|
Конвертируем таблицу в Excel c использованием TExcelApplication.
// Переписываем
TabGrid := VarArrayCreate([0,(R - 1),0,(C - 1)],VarVariant);
...
TabGrid[I,J] := FieldToVariant(dbGrid.Columns.Items[J].Field);
// И пишем функцию:
function FieldToVariant(Field:TField):OLEVariant;
begin
Result := '';
case Field.DataType of
ftString, ftFixedChar, ftWideString, ftMemo,
ftFmtMemo: Result := '''' + Field.AsString;
ftSmallint, ftInteger, ftWord, ftLargeint, ftAutoInc:
Result := Field.AsInteger;
ftFloat, ftCurrency, ftBCD: Result := Field.AsFloat;
ftBoolean: Result := Field.AsBoolean;
ftDate, ftTime, ftDateTime: Result := Field.AsDateTime;
end
end;
|
Сделать картинке 2D свертку.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
This function performs a 2D convolution on an image.
It can be used for a very wide range of image processing operations
such as image smoothing, anti-aliasing, edge detection,
detail enhancment, etc. It is very fast.
}
uses
Graphics, Windows;
type
TRGBTripleArray = array[0..10000] of TRGBTriple;
PRGBTripleArray = ^TRGBTripleArray;
T3x3FloatArray = array[0..2] of array[0..2] of Extended;
implementation
function Convolve(ABitmap: TBitmap; AMask: T3x3FloatArray;
ABias: Integer): TBitmap;
var
LRow1, LRow2, LRow3, LRowOut: PRGBTripleArray;
LRow, LCol: integer;
LNewBlue, LNewGreen, LNewRed: Extended;
LCoef: Extended;
begin
LCoef := 0;
for LRow := 0 to 2 do
for LCol := 0 to 2 do
LCoef := LCoef + AMask[LCol, LRow];
if LCoef = 0 then LCoef := 1;
Result := TBitmap.Create;
Result.Width := ABitmap.Width - 2;
Result.Height := ABitmap.Height - 2;
Result.PixelFormat := pf24bit;
LRow2 := ABitmap.ScanLine[0];
LRow3 := ABitmap.ScanLine[1];
for LRow := 1 to ABitmap.Height - 2 do
begin
LRow1 := LRow2;
LRow2 := LRow3;
LRow3 := ABitmap.ScanLine[LRow + 1];
LRowOut := Result.ScanLine[LRow - 1];
for LCol := 1 to ABitmap.Width - 2 do
begin
LNewBlue :=
(LRow1[LCol - 1].rgbtBlue * AMask[0,0]) + (LRow1[LCol].rgbtBlue * AMask[1,0]) +
(LRow1[LCol + 1].rgbtBlue * AMask[2,0]) +
(LRow2[LCol - 1].rgbtBlue * AMask[0,1]) + (LRow2[LCol].rgbtBlue * AMask[1,1]) +
(LRow2[LCol + 1].rgbtBlue * AMask[2,1]) +
(LRow3[LCol - 1].rgbtBlue * AMask[0,2]) + (LRow3[LCol].rgbtBlue * AMask[1,2]) +
(LRow3[LCol + 1].rgbtBlue * AMask[2,2]);
LNewBlue := (LNewBlue / LCoef) + ABias;
if LNewBlue > 255 then
LNewBlue := 255;
if LNewBlue < 0 then
LNewBlue := 0;
LNewGreen :=
(LRow1[LCol - 1].rgbtGreen * AMask[0,0]) + (LRow1[LCol].rgbtGreen * AMask[1,0]) +
(LRow1[LCol + 1].rgbtGreen * AMask[2,0]) +
(LRow2[LCol - 1].rgbtGreen * AMask[0,1]) + (LRow2[LCol].rgbtGreen * AMask[1,1]) +
(LRow2[LCol + 1].rgbtGreen * AMask[2,1]) +
(LRow3[LCol - 1].rgbtGreen * AMask[0,2]) + (LRow3[LCol].rgbtGreen * AMask[1,2]) +
(LRow3[LCol + 1].rgbtGreen * AMask[2,2]);
LNewGreen := (LNewGreen / LCoef) + ABias;
if LNewGreen > 255 then
LNewGreen := 255;
if LNewGreen < 0 then
LNewGreen := 0;
LNewRed :=
(LRow1[LCol - 1].rgbtRed * AMask[0,0]) + (LRow1[LCol].rgbtRed * AMask[1,0])
+ (LRow1[LCol + 1].rgbtRed * AMask[2,0]) +
(LRow2[LCol - 1].rgbtRed * AMask[0,1]) + (LRow2[LCol].rgbtRed * AMask[1,1])
+ (LRow2[LCol + 1].rgbtRed * AMask[2,1]) +
(LRow3[LCol - 1].rgbtRed * AMask[0,2]) + (LRow3[LCol].rgbtRed * AMask[1,2])
+ (LRow3[LCol + 1].rgbtRed * AMask[2,2]);
LNewRed := (LNewRed / LCoef) + ABias;
if LNewRed > 255 then
LNewRed := 255;
if LNewRed < 0 then
LNewRed := 0;
LRowOut[LCol - 1].rgbtBlue := trunc(LNewBlue);
LRowOut[LCol - 1].rgbtGreen := trunc(LNewGreen);
LRowOut[LCol - 1].rgbtRed := trunc(LNewRed);
end;
end;
end;
// example use
// edge detection
procedure TForm1.Button1Click(Sender: TObject);
var
LMask: T3x3FloatArray;
begin
LMask[0,0] := -1;
LMask[1,0] := -1;
LMask[2,0] := -1;
LMask[0,1] := -1;
LMask[1,1] := 8;
LMask[2,1] := -1;
LMask[0,2] := -1;
LMask[1,2] := -1;
LMask[2,2] := -1;
Image1.Picture.Bitmap := Convolve(Image1.Picture.Bitmap, LMask, 0);
end;
Координаты курсора в Memo.
| Тяжело сгонять муху курсором с монитора. |
var X, Y: LongInt; begin Y := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0); X := Memo1.Perform(EM_LINEINDEX, Y, 0); inc(Y); X := Memo1.SelStart - X + 1; Form1.Caption := 'X = ' + IntToStr(X) + ' : ' + 'Y = ' + IntToStr(Y); end; |
Координаты курсора в Memo 2.
procedure CaretPos(H: THandle; var L, C: Word);
begin
L := SendMessage(H, EM_LINEFROMCHAR, -1, 0);
C := LoWord(SendMessage(H, EM_GETSEL, 0, 0)) -
SendMessage(H, EM_LINEINDEX, -1, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LineNum, ColNum: Word;
begin
CaretPos(Memo1.Handle, LineNum, ColNum);
Edit1.Text := IntToStr(LineNum) + ' ' + IntToStr(ColNum);
end;
|
Хотя в Delphi 5 свойство CaretPos уже включено в memo.
Как поместить прозрачную фоновую картинку на компонент CoolBar.
procedure TForm1.Button1Click(Sender: TObject);
var
Bm1 : TBitmap;
Bm2 : TBitmap;
begin
Bm1 := TBitmap.Create;
Bm2 := TBitmap.Create;
Bm1.LoadFromFile('c:\download\test.bmp');
Bm2.Width := Bm1.Width;
Bm2.Height := Bm1.Height;
bm2.Canvas.Brush.Color := CoolBar1.Color;
bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
bm1.Free;
CoolBar1.Bitmap.Assign(bm2);
bm2.Free;
end;
|
Координатная сетка.
unit grid_;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormPaint(Sender: TObject);
var
x0, y0: integer; // координаты начала координатных осей
dx, dy: integer; // шаг координатной сетки (в пикселях)
h, w: integer; // высота и ширина области вывода координатной сетки
x, y: integer;
lx, ly: real; // метки (оцифровка) линий сетки по X Y
dlx, dly: real; // шаг меток (оцифровки) линий сетки по X и Y
cross: integer; // счетчик не оцифрованных линий сетки
dcross: integer; // количество не оцифрованных линий между оцифрованными
begin
x0 := 30;
y0 := 220; // оси начинаются в точке (40,250)
dx := 40;
dy := 40; // шаг координатной сетки 40 пикселей
dcross := 1; // помечать линии сетки X: 1 - каждую;
// 2 - через одну;
// 3 - через две;
dlx := 0.5; // шаг меток оси X
dly := 1.0; // шаг меток оси Y, метками будут: 1, 2, 3 и т.д.
h := 200;
w := 300;
with form1.Canvas do
begin
cross := dcross;
MoveTo(x0, y0);
LineTo(x0, y0 - h); // ось X
MoveTo(x0, y0);
LineTo(x0 + w, y0); // ось Y
// засечки, сетка и оцифровка по оси X
x := x0 + dx;
lx := dlx;
repeat
MoveTo(x, y0 - 3);
LineTo(x, y0 + 3); // засечка
cross := cross - 1;
if cross = 0 then //оцифровка
begin
TextOut(x - 8, y0 + 5, FloatToStr(lx));
cross := dcross;
end;
Pen.Style := psDot;
MoveTo(x, y0 - 3);
LineTo(x, y0 - h); // линия сетки
Pen.Style := psSolid;
lx := lx + dlx;
x := x + dx;
until (x > x0 + w);
// засечки, сетка и оцифровка по оси Y
y := y0 - dy;
ly := dly;
repeat
MoveTo(x0 - 3, y);
LineTo(x0 + 3, y); // засечка
TextOut(x0 - 20, y, FloatToStr(ly)); // оцифровка
Pen.Style := psDot;
MoveTo(x0 + 3, y);
LineTo(x0 + w, y); // линия сетки
Pen.Style := psSolid;
y := y - dy;
ly := ly + dly;
until (y < y0 - h);
end;
end;
end.
Сделать немерцающей анимацию при помощи CopyRect.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
var
Form1: TForm1;
x, y, xvel, yvel, xold, yold: Integer;
implementation
{$R *.dfm}
{You will need an image, called ImageSprite, containing a sprite bitmap with
black as the background (the transparent part). You will also need an image,
called ImageMask, containing a black silouette of the sprite with white as the
background and an Image called ImageBackground containing the background
image. All these images are set to visible := false. Image1 is the image you
will see and is the same size as the background image.}
procedure TForm1.Button1Click(Sender: TObject);
var
ARect: TRect; // Destination/Source rectangles
begin
//Initialize sprites position/velocity
x := 0;
y := 100;
xvel := 3;
yvel := 2;
xold := 0;
yold := 0;
// copy background to the image
ARect := Rect(0, 0, ImageBackground.Width, ImageBackground.Height);
with Image1.Canvas do
begin
CopyMode := cmSrcCopy;
CopyRect(ARect, ImageBackground.Canvas, ARect);
end;
// start animation
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Dest, Sour: TRect; // Destination/Source rectangles
begin
// Erase sprite from old position
Sour := Rect(xold, yold, xold + ImageMask.Width, yold + ImageMask.Height);
with Image1.Canvas do
begin
CopyMode := cmSrcCopy;
CopyRect(Sour, ImageBackground.Canvas, Sour);
end;
// Draw new sprite
Sour := Rect(0, 0, ImageMask.Width, ImageMask.Height);
Dest := Rect(x, y, x + ImageMask.Width, y + ImageMask.Height);
with Image1.Canvas do
begin
// Place mask onto image
CopyMode := cmSrcAnd;
CopyRect(Dest, ImageMask.Canvas, Sour);
// Place sprite into mask
CopyMode := cmSrcPaint;
CopyRect(Dest, ImageSprite.Canvas, Sour);
end;
{if multiple sprites are being used, then erase them all before drawing them
all. Do not erase and draw each sprite in turn}
// store sprites old position before updating
xold := x;
yold := y;
{ Update sprites position (equations to describe movement of sprite }
Inc(x, xvel);
Inc(y, yvel);
if (x > ImageBackground.Width - ImageMask.Width) or (x < 0) then xvel := -xvel;
if (y > ImageBackground.Height - ImageMask.Height) or (y < 0) then yvel := -yvel;
end;
Скопировать все файлы вместе с подкаталогами.
procedure TForm1.Button1Click(Sender: TObject);
var
OpStruc: TSHFileOpStruct;
frombuf, tobuf: array [0..128] of Char;
begin
FillChar( frombuf, Sizeof(frombuf), 0 );
FillChar( tobuf, Sizeof(tobuf), 0 );
StrPCopy( frombuf, 'c:\1\*.*' );
StrPCopy( tobuf, 'c:\2' );
with OpStruc do
begin
Wnd:= Handle;
wFunc:= FO_COPY;
pFrom:= @frombuf;
pTo:=@tobuf;
fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted:= False;
hNameMappings:= nil;
lpszProgressTitle:= nil;
end;
ShFileOperation( OpStruc );
end;
|
Скопировать, удалить, вставить в TWebBrowser.
uses
ActiveX;
// Copy the selected text to the clipboard
procedure TForm1.Button7Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
// Cut the selected text
procedure TForm1.Button8Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
// Delete the selected text
procedure TForm1.Button9Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_DELETE, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
initialization
OleInitialize(nil);
finalization
OleUninitialize;
end.
// as of Internet Explorer 4
|
Копирование директорий и удаление директорий в корзину.
Автор: Xavier Pacheco
unit MainFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons;
type
TMainForm = class(TForm)
GroupBox1: TGroupBox;
spbtnGetFromDir: TSpeedButton;
spbtnGetToDir: TSpeedButton;
edtFromDir: TEdit;
edtToDir: TEdit;
Button1: TButton;
GroupBox2: TGroupBox;
edtRecycleDir: TEdit;
spbtnRecycleBin: TSpeedButton;
btnRecycleDir: TButton;
btnClose: TButton;
procedure spbtnGetFromDirClick(Sender: TObject);
procedure spbtnGetToDirClick(Sender: TObject);
procedure btnCopyDirectoryClick(Sender: TObject);
procedure spbtnRecycleBinClick(Sender: TObject);
procedure btnRecycleDirClick(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
uses ShellAPI, FileCtrl;
{$R *.DFM}
function GetDirectory: string;
begin
if not SelectDirectory(Result, [sdAllowCreate, sdPerformCreate, sdPrompt], 0)
then
Result := EmptyStr;
end;
procedure CopyDirectoryTree(AHandle: THandle; const AFromDirectory,
AToDirectory: string);
var
SHFileOpStruct: TSHFileOpStruct;
FromDir: PChar;
ToDir: PChar;
begin
GetMem(FromDir, Length(AFromDirectory) + 2);
try
GetMem(ToDir, Length(AToDirectory) + 2);
try
FillChar(FromDir^, Length(AFromDirectory) + 2, 0);
FillChar(ToDir^, Length(AToDirectory) + 2, 0);
StrCopy(FromDir, PChar(AFromDirectory));
StrCopy(ToDir, PChar(AToDirectory));
with SHFileOpStruct do
begin
Wnd := AHandle; // Assign the window handle
wFunc := FO_COPY; // Specify a file copy
pFrom := FromDir;
pTo := ToDir;
fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted := False;
hNameMappings := nil;
lpszProgressTitle := nil;
if SHFileOperation(SHFileOpStruct) <> 0 then
RaiseLastWin32Error;
end;
finally
FreeMem(ToDir, Length(AToDirectory) + 2);
end;
finally
FreeMem(FromDir, Length(AFromDirectory) + 2);
end;
end;
procedure ToRecycle(AHandle: THandle; const ADirName: string);
var
SHFileOpStruct: TSHFileOpStruct;
DirName: PChar;
BufferSize: Cardinal;
begin
BufferSize := Length(ADirName) + 1 + 1;
GetMem(DirName, BufferSize);
try
FillChar(DirName^, BufferSize, 0);
StrCopy(DirName, PChar(ADirName));
with SHFileOpStruct do
begin
Wnd := AHandle;
wFunc := FO_DELETE;
pFrom := DirName;
pTo := nil;
fFlags := FOF_ALLOWUNDO;
fAnyOperationsAborted := False;
hNameMappings := nil;
lpszProgressTitle := nil;
end;
if SHFileOperation(SHFileOpStruct) <> 0 then
RaiseLastWin32Error;
finally
FreeMem(DirName, BufferSize);
end;
end;
procedure TMainForm.spbtnGetFromDirClick(Sender: TObject);
begin
edtFromDir.Text := GetDirectory;
end;
procedure TMainForm.spbtnGetToDirClick(Sender: TObject);
begin
edtToDir.Text := GetDirectory;
end;
procedure TMainForm.btnCopyDirectoryClick(Sender: TObject);
begin
CopyDirectoryTree(Handle, edtFromDir.Text, edtToDir.Text);
end;
procedure TMainForm.spbtnRecycleBinClick(Sender: TObject);
begin
edtRecycleDir.Text := GetDirectory;
end;
procedure TMainForm.btnRecycleDirClick(Sender: TObject);
begin
ToRecycle(0, edtRecycleDir.Text);
end;
procedure TMainForm.btnCloseClick(Sender: TObject);
begin
Close;
end;
end.
Скопировать, удалить, переместить всю директорию.
uses
ShellApi;
function CopyDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_COPY;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;
function MoveDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_MOVE;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;
function DelDir(dir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_DELETE;
fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
pFrom := PChar(dir + #0);
end;
Result := (0 = ShFileOperation(fos));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if cCopyDir('d:\download', 'e:\') = True then
ShowMessage('Directory copied.');
end;
|
Копирование содержимого директории, вместе с поддиректориями.
Автор: VID WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Копирование содержимого директории, вместе с поддиректориями.
Фукция копирует СОДЕРЖИМОЕ директории SourceDir в директорию TargetDir.
Копируются все файлы, подкаталоги, и файлы находящиеся в этих подкаталогах.
Аргумент StopIfNotAllCopied: если значение этого аргумента = True,
то при первой же ошибке копирования файла или папки, работы функции
прекратится а функуция вернёт False. В случае если этот аргумент = False,
то ошибки копирования учитываться не будут.
Аргумент OverWriteFiles: если True, то существующие файлы будут переписаны.
Зависимости: SysUtils, FileCtrl, Windows
Автор: VID, snap@iwt.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 31 января 2003 г.
***************************************************** }
function FullDirectoryCopy(SourceDir, TargetDir: string; StopIfNotAllCopied,
OverWriteFiles: Boolean): Boolean;
var
SR: TSearchRec;
I: Integer;
begin
Result := False;
SourceDir := IncludeTrailingBackslash(SourceDir);
TargetDir := IncludeTrailingBackslash(TargetDir);
if not DirectoryExists(SourceDir) then
Exit;
if not ForceDirectories(TargetDir) then
Exit;
I := FindFirst(SourceDir + '*', faAnyFile, SR);
try
while I = 0 do
begin
if (SR.Name <> '') and (SR.Name <> '.') and (SR.Name <> '..') then
begin
if SR.Attr = faDirectory then
Result := FullDirectoryCopy(SourceDir + SR.Name, TargetDir + SR.NAME,
StopIfNotAllCopied, OverWriteFiles)
else if not (not OverWriteFiles and FileExists(TargetDir + SR.Name))
then
Result := CopyFile(Pchar(SourceDir + SR.Name), Pchar(TargetDir +
SR.Name), False)
else
Result := True;
if not Result and StopIfNotAllCopied then
exit;
end;
I := FindNext(SR);
end;
finally
SysUtils.FindClose(SR);
end;
end;
Пример использования:
FullDirectoryCopy('C:\a', 'D:\b');
// Скопирует содержимое директории C:\a (не не саму директорию) в директорию D:\b
Как скопировать директорию с файлами.
unit FilesOp;
interface
uses Forms, SysUtils, ShellAPI, Dialogs;
procedure CopyFiles(const FromFolder: string; const ToFolder: string);
implementation
procedure CopyFiles(const FromFolder: string; const ToFolder: string);
var
Fo : TSHFileOpStruct;
buffer : array[0..4096] of char;
p : pchar;
begin
FillChar(Buffer, sizeof(Buffer), #0);
p := @buffer;
StrECopy(p, PChar(FromFolder)); //директория, которую мы хотим скопировать
FillChar(Fo, sizeof(Fo), #0);
Fo.Wnd := Application.Handle;
Fo.wFunc := FO_COPY;
Fo.pFrom := @Buffer;
Fo.pTo := PChar(ToFolder); //куда будет скопирована директория
Fo.fFlags := 0;
if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then
ShowMessage('File copy process cancelled')
end;
end.
|
Копирование файлов.
| F8 - Copy? Да кто ж тебе это сказал?! |
Копирование методом TurboPascal.
type
{Для индикации процесса копирования}
TCallBack = procedure (Position, Size: Longint);
procedure FastFileCopy(const InfileName, OutFileName: string;
CallBack: TCallBack);
const
BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }
type
PBuffer = ^TBuffer;
TBuffer = array [1..BufSize] of Byte;
var
Size : integer;
Buffer : PBuffer;
infile, outfile : file;
SizeDone, SizeFile: Longint;
begin
if (InFileName <> OutFileName) then
begin
buffer := nil;
AssignFile(infile, InFileName);
System.Reset(infile, 1);
try
SizeFile := FileSize(infile);
AssignFile(outfile, OutFileName);
System.Rewrite(outfile, 1);
try
SizeDone := 0; New(Buffer);
repeat
BlockRead(infile, Buffer^, BufSize, Size);
Inc(SizeDone, Size);
CallBack(SizeDone, SizeFile);
BlockWrite(outfile,Buffer^, Size)
until
Size finally
if Buffer <> nil then
Dispose(Buffer);
System.close(outfile)
end;
finally
System.close(infile);
end;
end
else
raise EInOutError.Create('File cannot be copied into itself');
end;
|
Копирование методом потока.
procedure FileCopy(const SourceFileName, TargetFileName: string);
var
S, T : TFileStream;
begin
S := TFileStream.Create(sourcefilename, fmOpenRead );
try
T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
try
T.CopyFrom(S, S.Size ) ;
FileSetDate(T.Handle, FileGetDate(S.Handle));
finally
T.Free;
end;
finally
S.Free;
end;
end;
|
Копирование методом LZExpand.
uses
LZExpand;
procedure CopyFile(FromFileName, ToFileName : string);
var
FromFile, ToFile: file;
begin
AssignFile(FromFile, FromFileName);
AssignFile(ToFile, ToFileName);
Reset(FromFile);
try
Rewrite(ToFile);
try
if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)then
raise Exception.Create('Error using LZCopy')
finally
CloseFile(ToFile);
end;
finally
CloseFile(FromFile);
end;
end;
|
Копирование методами Windows.
uses
// !!! важно
ShellApi;
function WindowsCopyFile(FromFile, ToDir : string) : boolean;
var
F: TShFileOpStruct;
begin
F.Wnd := 0; F.wFunc := FO_COPY;
FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile);
ToDir:=ToDir+#0; F.pTo:=pchar(ToDir);
F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
result:=ShFileOperation(F) = 0;
end;
// пример копирования
procedure TForm1.Button1Click(Sender: TObject);
begin
if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then
ShowMessage('Copy Failed');
end;
|
Скопировать файлы с диалогом анимации.
Сначала в разделе uses объявляем модуль ShellAPI.
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI; |
Затем следующим образом обрабатываем нажатие кнопки:
procedure TForm1.Button1Click(Sender: TObject);
var
Fo : TSHFileOpStruct;
buffer : array [0..4096] of char;
p : pchar;
begin
FillChar(Buffer, sizeof(Buffer), #0);
p := @buffer;
//Начали подключение файлов, предназначенных для копирования
p := StrECopy(p, 'C:\first.rar') + 1;
p := StrECopy(p, 'C:\second.rar') + 1;
p := StrECopy(p, 'C:\third.rar') + 1;
p := StrECopy(p, 'C:\5.rar') + 1;
p := StrECopy(p, 'C:\6.rar') + 1;
p := StrECopy(p, 'C:\7.rar') + 1;
FillChar(Fo, sizeof(Fo), #0);
Fo.Wnd := Handle;
Fo.wFunc := FO_COPY; //Действие
Fo.pFrom := @Buffer; //Источник
Fo.pTo := 'c:\1\'; //Назначение - показываем куда копируем
Fo.fFlags := 0;
if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then
ShowMessage('Cancelled')
end;
|
Заметим, что в качестве действия мы указали константу FO_COPY - это значит, что решено копировать файлы, помимо этого значения можно также указывать:
FO_COPY FO_DELETE FO_MOVE FO_RENAMEФункция, которая устанавливает дату одного файла, равную дате другого файла.
procedure CopyFileDate(const Source, Dest: String);
var
SourceHand, DestHand: word;
begin
SourceHand := FileOpen(Source, fmOutput); { открываем исходный файл }
DestHand := FileOpen(Dest, fmInput); { открываем целевой файл }
FileSetDate(DestHand, FileGetDate(SourceHand)); { получаем/устанавливаем дату }
FileClose(SourceHand); { закрываем исходный файл }
FileClose(DestHand); { закрываем целевой файл }
end;
|
Копируем файл в буфер обмена.
uses
ShlObj, ClipBrd;
procedure CopyFilesToClipboard(FileList: string);
var
DropFiles: PDropFiles;
hGlobal: THandle;
iLen: Integer;
begin
iLen := Length(FileList) + 2;
FileList := FileList + #0#0;
hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
SizeOf(TDropFiles) + iLen);
if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');
begin
DropFiles := GlobalLock(hGlobal);
DropFiles^.pFiles := SizeOf(TDropFiles);
Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);
GlobalUnlock(hGlobal);
Clipboard.SetAsHandle(CF_HDROP, hGlobal);
end;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat');
end;
//Separate the files with a #0.
|
Копируем файл с индикатором процесса.
{ 1. }
{
You need a TProgressBar on your form for this tip.
Fьг diesen Tip wird eine TProgressBar ьеnцtigt.
}
procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
var
FromF, ToF: file of byte;
Buffer: array[0..4096] of char;
NumRead: integer;
FileLength: longint;
begin
AssignFile(FromF, Source);
reset(FromF);
AssignFile(ToF, Destination);
rewrite(ToF);
FileLength := FileSize(FromF);
with Progressbar1 do
begin
Min := 0;
Max := FileLength;
while FileLength > 0 do
begin
BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
FileLength := FileLength - NumRead;
BlockWrite(ToF, Buffer[0], NumRead);
Position := Position + NumRead;
end;
CloseFile(FromF);
CloseFile(ToF);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyFileWithProgressBar1('c:\Windows\Welcome.exe', 'c:\temp\Welcome.exe');
end;
{ 2. }
{***************************************}
// To show the estimated time to copy a file:
procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
var
FromF, ToF: file of byte;
Buffer: array[0..4096] of char;
NumRead: integer;
FileLength: longint;
t1, t2: DWORD;
maxi: integer;
begin
AssignFile(FromF, Source);
reset(FromF);
AssignFile(ToF, Destination);
rewrite(ToF);
FileLength := FileSize(FromF);
with Progressbar1 do
begin
Min := 0;
Max := FileLength;
t1 := TimeGetTime;
maxi := Max div 4096;
while FileLength > 0 do
begin
BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
FileLength := FileLength - NumRead;
BlockWrite(ToF, Buffer[0], NumRead);
t2 := TimeGetTime;
Min := Min + 1;
// Show the time in Label1
label1.Caption := FormatFloat('0.00', ((t2 - t1) / min * maxi - t2 + t1) / 100);
Application.ProcessMessages;
Position := Position + NumRead;
end;
CloseFile(FromF);
CloseFile(ToF);
end;
end;
{ 3. }
{***************************************}
// To show the estimated time to copy a file, using a callback function:
type
TCallBack = procedure(Position, Size: Longint); { export; }
procedure FastFileCopy(const InFileName, OutFileName: string;
CallBack: TCallBack);
implementation
procedure FastFileCopyCallBack(Position, Size: Longint);
begin
Form1.ProgressBar1.Max := Size;
Form1.ProgressBar1.Position := Position;
end;
procedure FastFileCopy(const InFileName, OutFileName: string;
CallBack: TCallBack);
const
BufSize = 3 * 4 * 4096; { 48Kbytes gives me the best results }
type
PBuffer = ^TBuffer;
TBuffer = array[1..BufSize] of Byte;
var
Size: DWORD;
Buffer: PBuffer;
infile, outfile: file;
SizeDone, SizeFile: LongInt;
begin
if (InFileName <> OutFileName) then
begin
buffer := nil;
Assign(infile, InFileName);
Reset(infile, 1);
try
SizeFile := FileSize(infile);
Assign(outfile, OutFileName);
Rewrite(outfile, 1);
try
SizeDone := 0;
New(Buffer);
repeat
BlockRead(infile, Buffer^, BufSize, Size);
Inc(SizeDone, Size);
CallBack(SizeDone, SizeFile);
BlockWrite(outfile, Buffer^, Size)
until Size < BufSize;
FileSetDate(TFileRec(outfile).Handle,
FileGetDate(TFileRec(infile).Handle));
finally
if Buffer <> nil then
Dispose(Buffer);
CloseFile(outfile)
end;
finally
CloseFile(infile);
end;
end
else
raise EInOutError.Create('File cannot be copied onto itself')
end; {FastFileCopy}
procedure TForm1.Button1Click(Sender: TObject);
begin
FastFileCopy('c:\daten.txt', 'c:\test\daten2.txt', @FastFileCopyCallBack);
end;
{ 4. }
{***************************************}
function CopyFileWithProgressBar2(TotalFileSize,
TotalBytesTransferred,
StreamSize,
StreamBytesTransferred: LARGE_INTEGER;
dwStreamNumber,
dwCallbackReason: DWORD;
hSourceFile,
hDestinationFile: THandle;
lpData: Pointer): DWORD; stdcall;
begin
// just set size at the beginning
if dwCallbackReason = CALLBACK_STREAM_SWITCH then
TProgressBar(lpData).Max := TotalFileSize.QuadPart;
TProgressBar(lpData).Position := TotalBytesTransferred.QuadPart;
Application.ProcessMessages;
Result := PROGRESS_CONTINUE;
end;
function TForm1.CopyWithProgress(sSource, sDest: string): Boolean;
begin
// set this FCancelled to true, if you want to cancel the copy operation
FCancelled := False;
Result := CopyFileEx(PChar(sSource), PChar(sDest), @CopyFileWithProgressBar2,
ProgressBar1, @FCancelled, 0);
end;
end;
|
Скопировать файл с заполнением своего ProgressBara.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ComCtrls, Gauges;
type
TMainForm = class(TForm)
prbCopy: TProgressBar;
btnCopy: TButton;
procedure btnCopyClick(Sender: TObject);
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.btnCopyClick(Sender: TObject);
var
SrcFile, DestFile: file;
BytesRead, BytesWritten, TotalRead: Integer;
Buffer: array[1..500] of byte;
FSize: Integer;
begin
{ Assign both the source and destination files to their
respective file variables }
AssignFile(SrcFile, 'srcfile.tst');
AssignFile(DestFile, 'destfile.tst');
// Open the source file for read access.
Reset(SrcFile, 1);
try
// Open destination file for write access.
Rewrite(DestFile, 1);
try
{ Encapsulate this into a try..except so that we can erase the file if
an error occurs. }
try
// Initialize total bytes read to zero.
TotalRead := 0;
// Obtain the filesize of the source file
FSize := FileSize(SrcFile);
{ Read SizeOf(Buffer) bytes from the source file
and add these bytes to the destination file. Repeat this
process until all bytes have been read from the source
file. A progress bar is provided to show the progress of the
copy operation. }
repeat
BlockRead(SrcFile, Buffer, SizeOf(Buffer), BytesRead);
if BytesRead > 0 then
begin
BlockWrite(DestFile, Buffer, BytesRead, BytesWritten);
if BytesRead <> BytesWritten then
raise Exception.Create('Error copying file')
else
begin
TotalRead := TotalRead + BytesRead;
prbCopy.Position := Trunc(TotalRead / Fsize) * 100;
prbCopy.Update;
end;
end
until BytesRead = 0;
except
{ On an exception, erase the destination file as it may be
corrupt. Then re-raise the exception. }
Erase(DestFile);
raise;
end;
finally
CloseFile(DestFile); // Close the destination file.
end;
finally
CloseFile(SrcFile); // Close the source file.
end;
end;
end.
Как скопировать картинку в буфер обмена.
| Программист после очень длительного сидения за компьютером выходит на улицу и смотрит на небо: "Боже, у Тебя тоже Windows стоит?!" |
Clipboard.Assign(Image1.Picture); |
Изменить режим копирования изображения.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TMainForm = class(TForm)
imgCopyTo: TImage;
imgCopyFrom: TImage;
cbCopyMode: TComboBox;
btnDrawImages: TButton;
btnCopy: TButton;
procedure FormShow(Sender: TObject);
procedure btnCopyClick(Sender: TObject);
procedure btnDrawImagesClick(Sender: TObject);
private
procedure DrawImages;
procedure GetCanvasRect(AImage: TImage; var ARect: TRect);
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.GetCanvasRect(AImage: TImage; var ARect: TRect);
var
R: TRect;
R2: TRect;
begin
R := AImage.Canvas.ClipRect;
with AImage do
begin
ARect.TopLeft := Point(0, 0);
ARect.BottomRight := Point(Width, Height);
end;
R2 := ARect;
ARect := R2;
end;
procedure TMainForm.DrawImages;
var
R: TRect;
begin
// Draw an ellipse in img1
with imgCopyTo.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clWhite;
GetCanvasRect(imgCopyTo, R);
FillRect(R);
Brush.Color := clRed;
Ellipse(10, 10, 100, 100);
end;
// Draw an ellipse in img2
with imgCopyFrom.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clWhite;
GetCanvasRect(imgCopyFrom, R);
FillRect(R);
Brush.Color := clBlue;
Ellipse(30, 30, 120, 120);
end;
end;
procedure TMainForm.FormShow(Sender: TObject);
begin
// Initialize the combobox to the first item
cbCopyMode.ItemIndex := 0;
DrawImages;
end;
procedure TMainForm.btnCopyClick(Sender: TObject);
var
cm: Longint;
CopyToRect,
CopyFromRect: TRect;
begin
// Determine the copy mode based on the combo box selection
case cbCopyMode.ItemIndex of
0: cm := cmBlackNess;
1: cm := cmDstInvert;
2: cm := cmMergeCopy;
3: cm := cmMergePaint;
4: cm := cmNotSrcCopy;
5: cm := cmNotSrcErase;
6: cm := cmPatCopy;
7: cm := cmPatInvert;
8: cm := cmPatPaint;
9: cm := cmSrcAnd;
10: cm := cmSrcCopy;
11: cm := cmSrcErase;
12: cm := cmSrcInvert;
13: cm := cmSrcPaint;
14: cm := cmWhiteness;
else
cm := cmSrcCopy;
end;
// Assign the selected copymode to Image1's CopyMode property.
imgCopyTo.Canvas.CopyMode := cm;
GetCanvasRect(imgCopyTo, CopyToRect);
GetCanvasRect(imgCopyFrom, CopyFromRect);
// Now copy Image2 onto Image1 using Image1's CopyMode setting
imgCopyTo.Canvas.CopyRect(CopyToRect, imgCopyFrom.Canvas, CopyFromRect);
end;
procedure TMainForm.btnDrawImagesClick(Sender: TObject);
begin
DrawImages;
end;
end.
Копировать и вставлять TreeNode.
var
SL : TStringList;
procedure TForm1.CutBtnClick(Sender: TObject);
var
i, j, StartLevel : integer;
TNSel : TTreeNode;
begin
TNSel := TreeView1.Selected;
if TNSel <> nil then begin
StartLevel := TNSel.Level;
i := TNSel.AbsoluteIndex;
j := i; // note for later deletion
if SL = nil then
SL := TStringList.Create
else
SL.Clear;
SL.AddObject(TNSel.Text, pointer(0));
inc(i);
with TreeView1 do begin
while Items[i].Level > StartLevel do begin
{stop before next sibling to top node\}
SL.AddObject(Items[i].Text, pointer(Items[i].Level - StartLevel));
inc(i);
end; {while Items[i].Level > StartLevel\}
Items[j].Delete;
end; {with TreeView1\}
end; {if TNSel <> nil\}
end;
procedure TForm1.PasteBtnClick(Sender: TObject);
var
i, Level : integer;
TNSel, TN : TTreeNode;
begin
with TreeView1 do begin
TNSel := Selected;
if TNSel <> nil then begin
TN := Items.Insert(TNSel, SL.Strings[0]);
Level := integer(SL.Objects[0]); // should be 0
for i := 1 to SL.Count - 1 do begin
if integer(SL.Objects[i]) < Level then begin
{go up one level\}
TN := TN.Parent;
Level := integer(SL.Objects[i]);
end; {if integer(SL.Objects[i]) < Level\}
if Level = integer(SL.Objects[i]) then
{same level\}
TN := Items.Add(TN, SL.Strings[i])
else begin
{go down one level\}
TN := Items.AddChild(TN, SL.Strings[i]);
Level := integer(SL.Objects[i]);
end; {if Level = integer(SL.Objects[i])\}
end; {for i := 1 to SL.Count - 1\}
end; {if TNSel <> nil\}
end; {with TreeView1\}
end;
|
Копирование записи в пределах одной и той же таблицы.
Автор: OAmiry (Borland) "Каким образом мне копировать запись в пределах одного и того же TTable? То есть, если я вижу текущую запись на экране и хочу ее скопировать в ту же таблицу с изменением индекса поля(ей), то какие действия мне необходимо предпринять?"Необходимы два TTable, связанные с одной таблицей. Когда Table1 позиционируется в копируемой строке, с помощью Table2 вы можете выполнить операцию добавления записи. Пример: {только для демонстрации идеи, пример может быть нерабочим}.
procedure TForm1.Button1Click(Sender: TObject);
var
i: Cardinal;
srcStream: TBlobStream;
begin
try
with Table1 do
begin
CheckBrowseMode;
if EOF or BOF then
raise Exception.Create('Разместите курсор на правильной строке');
end;
with Table2 do
begin
Append;
for i := 0 to Table1.FieldCount - 1 do
if Table1.Fields[i].DataType < ftBytes then
FieldByName(Table1.Fields[i].FieldName).Assign(Table1.Fields[i])
else
try
srcStream := nil;
srcStream := TBlobStream.Create(TBlobField(Table1.Fields[i]), bmRead);
TBlobField(FieldByName(Table1.Fields[i].FieldName)).LoadFromStream(srcStream);
finally
if Assigned(srcStream) then
srcStream.Free;
end;
Post;
end;
except
on E: EDBEngineError do
MessageDlg(E.Message, mtError, [mbOk], 0);
on E: Exception do
MessageDlg(E.Message, mtError, [mbOk], 0);
end;
end;
|
Копирование записи из одной таблицы в другую.
Автор: Josh
procedure TTableRecordCopy(Source, Destination: TTable);
{ПРЕДПОЛОЖЕНИЕ: Обе таблицы имеют курсор в нужной строке и
компоненты Table ссылаются на таблицы с совместимыми величинами.}
var
i, lCount: Integer;
begin
lCount := Source.FieldCount;
for i := 0 to lCount - 1 do
if (not Source.Fields[i].IsNull) and (Source.Fields[i].CanModify) then
Destination.FieldByName(Source.Fields[i].FieldName).Assign(Source.Fields[i]);
end;
|
Это работает для всех типов полей.
Копирование экрана.
| Новая марка монохромных мониторов ViewSonic имеет в качестве символа трех пингвинов. |
unit ScrnCap;
interface
uses
WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
{ Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
{ Копирование всего экрана }
function CaptureScreen : TBitmap;
{ Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
{ Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;
implementation
function GetSystemPalette : HPalette;
var
PaletteSize : integer;
LogSize : integer;
LogPalette : PLogPalette;
DC : HDC;
Focus : HWND;
begin
result:=0;
Focus:=GetFocus;
DC:=GetDC(Focus);
try
PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
GetMem(LogPalette, LogSize);
try
with LogPalette^ do
begin
palVersion:=$0300;
palNumEntries:=PaletteSize;
GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
end;
result:=CreatePalette(LogPalette^);
finally
FreeMem(LogPalette, LogSize);
end;
finally
ReleaseDC(Focus, DC);
end;
end;
function CaptureScreenRect(ARect : TRect) : TBitmap;
var
ScreenDC : HDC;
begin
Result:=TBitmap.Create;
with result, ARect do
begin
Width:=Right-Left;
Height:=Bottom-Top;
ScreenDC:=GetDC(0);
try
BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
finally
ReleaseDC(0, ScreenDC);
end;
Palette:=GetSystemPalette;
end;
end;
function CaptureScreen : TBitmap;
begin
with Screen do
Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;
function CaptureClientImage(Control : TControl) : TBitmap;
begin
with Control, Control.ClientOrigin do
result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;
function CaptureControlImage(Control : TControl) : TBitmap;
begin
with Control do
if Parent=nil then
result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
else
with Parent.ClientToScreen(Point(Left, Top)) do
result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.
|
Копирование экрана 2.
// Для копирования изображения, находящегося в клиентской части
// формы есть метод GetFormImage. Для копирования любого
// прямоугольника экрана можно воспользоваться функциями GDI.
// Копирование произвольной прямоугольной области экрана
Function CaptureScreenRect( ARect: TRect ): TBitmap;
var
ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do
begin
Width := Right - Left;
Height := Bottom - Top;
// получаем для экрана контекст устройства
ScreenDC := GetDC( 0 );
try
// копируем оттуда прямоугольную область на канву
// растрового изображения
BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC,
Left, Top, SRCCOPY );
finally
ReleaseDC( 0, ScreenDC );
end;
end;
end;
// Таким образом, задавая нужный прямоугольник, можно получить
// изображение любой части экрана, получить изображение любого
// элемента формы(кнопок , выпадающих списков и так далее).
// Пример для копирования нужного элемента формы или всей формы,
// включая и заголовок и рамку:
Function CaptureControlImage( Control: TControl ): TBitmap;
begin
with Control do
IF Parent = nil Then
Result := CaptureScreenRect( Bounds( Left, Top, Width,Height ))
Else
With Parent.ClientToScreen( Point( Left, Top )) DO
Result := CaptureScreenRect( Bounds( X, Y, Width,Height ));
end;
|
Копирование содержимого экрана на форму.
var
Image3: TImage;
procedure TSaverForm.CopyScreen;
var
DeskTopDC: HDc;
DeskTopCanvas: TCanvas;
DeskTopRect: TRect;
begin
Image3 := TImage.Create(SaverForm);
with Image3 do
begin
Height := Screen.Height;
Width := Screen.Width;
end;
Image3.Canvas.copymode := cmSrcCopy;
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
Image3.Canvas.CopyRect(Image3.Canvas.ClipRect, DeskTopCanvas,
DeskTopCanvas.ClipRect);
Image2.Picture.Assign(Image3.Picture);
{image2 расположен на целевой форме и выровнен по области клиента}
end;
procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Image3.Free;
end;
|
Попробуйте следующий HAX 244, взятый из Авг/Сен номера журнала Visual Developer. Это работает, и работает хорошо.
{ смотри текстовое описание за последним END. }
unit Scrncap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics;
function CaptureScreenRect(ARect: TRect): TBitmap;
function CaptureScreen: TBitmap;
function CaptureClientImage(Control: TControl): TBitmap;
function CaptureControlImage(Control: TControl): TBitmap;
implementation
{ используем следующий код для захвата прямоугольной области экрана }
function CaptureScreenRect(ARect: TRect): TBitmap;
var
ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do
begin
Width := Right - Left;
Height := Bottom - Top;
ScreenDC := GetDC(0);
try
BitBlt(Canvas.Handle, 0, 0, Width, Height,
ScreenDC, Left, Top, SRCCOPY);
finally
ReleaseDC(0, ScreenDC);
end;
end;
end;
{ используем следующий код для захвата целого экрана }
function CaptureScreen: TBitmap;
begin
with Screen do
Result := CaptureScreenRect(Rect(0, 0, Width, Height));
end;
{ используем следующий код для захвата клиентской области
формы или элемента управления...}
function CaptureClientImage(Control: TControl): TBitmap;
begin
with Control, Control.ClientOrigin do
Result := CaptureScreenRect(Bounds(X, Y, ClientWidth,
ClientHeight));
end;
{ используйте следующий код для захвата целой формы
или элемента управления }
function CaptureControlImage(Control: TControl): TBitmap;
begin
with Control do
if Parent = nil then
Result := CaptureScreenRect(Bounds(Left, Top, Width,
Height))
else
with Parent.ClientToScreen(Point(Left, Top)) do
Result := CaptureScreenRect(Bounds(X, Y, Width, Height));
end;
end.
{
Источник: Visual Developer, HAX #244, Авг/Сент 1996
захват экрана с помощью Delphi
В Delphi, если вы хотите получить изображение клиентской области формы,
необходимо вызвать GetFormlmage. Но иногда возникает необходимость
получения снимка формы целиком, вместе с заголовком, контуром и всем
содержимым. Или целиком всего экрана. Если бы у вас был дефицит времени,
мы бы в этом случае посоветовали показывать диалоговое окно с надписью
"Теперь нажмите кнопку Print Screen!", после чего работать с
изображением, помещенным в буфер обмена.
Но мы никуда не спешим. Комбинирование хостов Delphi с несколькими
функциями GDI сводят задачу получения снимка экрана всего к одной
строчке кода.
CaptureScreenRect, в листинге 1, демонстрирует это. Код получает
экранный контекст устройства с помощью GetDC(O), и затем копирует
прямоугольную область этого DC на холст изображения (Bitmap). Для
копирования используется BitBlt. Смысл использования BitBlt (и
любой функции GDI) в том, что Delphi помнит, что дескриптор холста
есть DC, необходимый Windows.
Остальные функции копирования экрана в листинге 1 захватывают
прямоугольник и отдает реальную работу на откуп CaptureScreenRect.
CaptureScreen захватывает для прямоугольника целый экран.
CaptureClientImage и CaptureControlImage захватывают прямоугольник
области клиента и элемента управления, соответственно.
Эти четыре функции могут быть использованы для захвата любой
произвольной области экрана, а также экранных областей форм,
кнопок, полей редактирования, СоmbоВох'ов и пр.. Не забывайте
после работы освобождать используемые вами картинки (Bitmap). }
|
Как скопировать структуру таблицы.
Автор: http://www.swissdelphicenter.ch
{
As we know, Paradox Tables consist in a table file and some corresponding index files
there are many way to copy them:
1. Using TBatchMover (at DataAccess Pallete) with Mode : BatCopy
But you can't copy the tables corresponding index files, TBatchMove just
copies the structure and data.
2. Using FileCopy
But you can't copy the tables corresponding index files automatically,
you should define each files
.. and many more
The Simple way is:
Put two TTables on your form, name it as tbSource and tbTarget.
Then, put this procedure under implementation area
}
type
TForm1 = class(TForm)
tbSource: TTable;
tbTarget: TTable;
// ...
end;
implementation
procedure TForm1.Button1Click(Sender: TObject);
begin
tbSource.TableName := 'Source.DB';
// The name of your tables which you want to copy from
tbTarget.TableName := 'Target.DB';
// The name of your tables which you will to copy to
// You Can set the tbSource.DataBaseName to an existing path/Alias
// where you store your DB
// You Can set the tbTarget.DataBaseName to an existing path/Alias
// where you want to store the duplicate DB
tbSource.StoreDefs := True;
tbTarget.StoreDefs := True;
tbSource.FieldDefs.Update;
tbSource.IndexDefs.Update;
tbTarget.FieldDefs := tbSource.FieldDefs;
tbTarget.IndexDefs := tbSource.IndexDefs;
tbTarget.CreateTable;
// Actually you can set these code up to only 5 lines :)
end;
end.
Копирование текста DBMemo.
...да, вы забыли упомянуть перед этим о TMemoField. Звучит зловеще (как вы заметили), но это не трудно. Вся хитрость заключается в создании TStringList и перекачивания в него данных для последующего использования. Вот простая процедура без проверок и уведомлений об ошибках, использующая модуль WinCRT:
procedure TForm1.Button1Click(Sender: TObject);
var
I: integer;
StringList: TStringList;
begin
StringList := TStringList.Create;
try
StringList.Assign(Table1Memo);
for I := 0 to StringList.Count - 1 do
writeln(StringList[I])
finally
StringList.Free
end
end;
|
Копирование в буфер обмена.
procedure CopyButtonClick(Sender: TObject);
begin
if ActiveControl is TMemo then
TMemo(ActiveControl).CopyToClipboard;
if ActiveControl is TDBMemo then
TDBMemo(ActiveControl).CopyToClipboard;
if ActiveControl is TEdit then
TEdit(ActiveControl).CopyToClipboard;
if ActiveControl is TDBedit then
TDBedit(ActiveControl).CopyToClipboard;
end;
procedure PasteButtonClick(Sender: TObject);
begin
if ActiveControl is TMemo then
TMemo(ActiveControl).PasteFromClipboard;
if ActiveControl is TDBMemo then
TDBMemo(ActiveControl).PasteFromClipboard;
if ActiveControl is TEdit then
TEdit(ActiveControl).PasteFromClipboard;
if ActiveControl is TDBedit then
TDBedit(ActiveControl).PasteFromClipboard;
end;
|
Копировать векторное изображение.
procedure TForm1.Button1Click(Sender: TObject);
var
mf: TMetaFile;
mfc: TMetaFileCanvas;
i: integer;
ClipBrdFormat: word;
data: cardinal;
palette: hPalette;
p: array [0..90] of TPoint;
begin
mf := TMetaFile.Create;
mf.Width := 100;
mf.Height := 100;
mfc := TMetafileCanvas.Create(mf, 0);
with mfc do
begin
Pen.Color := clBlack;
FrameRect(ClipRect);
MoveTo(0, 50);
LineTo(100, 50);
LineTo(95, 48);
MoveTo(100, 50);
LineTo(95, 52);
MoveTo(50, 100);
LineTo(50, 0);
LineTo(48, 5);
MoveTo(50, 0);
LineTo(52, 5);
Brush.Style := bsClear;
Font.name := 'arial';
Font.Size := 6;
TextOut(55, 0, 'Y');
TextOut(95, 38, 'X');
Pen.Color := clRed;
for i := low(p) to high(p) do
p[i] := Point(i, round(50 - 30 * sin((i - 50) / 5)));
Polyline(p);
end;
mfc.Free;
mf.SaveToClipboardFormat(ClipBrdFormat, data, palette);
OpenClipboard(Application.Handle);
EmptyClipboard;
SetClipboardData(ClipBrdFormat, data);
CloseClipboard;
mf.Inch := 200;
Form1.Canvas.Draw(0, 0, mf);
mf.Free;
end;
|
Как скопировать самого себя.
| Злобный юзверь приходит к админу: - Вот, у меня Word повис... (уничтожил данные, потерял русские буквы... сами знаете) :( - А что ты сделал? - Ну, я (то-то и то-то)... - А, так он всегда вешается. - Ну, надо же было сообщение какое нибудь выдать... Или флажок какой поставить... - Слушай, отстань. Ты когда грузился, большой такой флажок видел? |
CopyFile(PChar(ParamStr(0)), PChar('Новый_путь' +
ExtractFileName(ParamStr(0))), True);
|
CORBA клиент-сервер.
Автор: Xavier Pacheco
unit ufrmCorbaClient;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, SimpleCorbaServer_TLB, corbaObj, Grids;
type
TForm1 = class(TForm)
GroupBox1: TGroupBox;
Label2: TLabel;
edtDatabase: TEdit;
Label3: TLabel;
edtUserName: TEdit;
Label4: TLabel;
edtPassword: TEdit;
Button5: TButton;
GroupBox2: TGroupBox;
memoSQL: TMemo;
GroupBox3: TGroupBox;
Button6: TButton;
grdCorbaData: TStringGrid;
procedure ConnectClick(Sender: TObject);
procedure ExecuteClick(Sender: TObject);
private
{ Private declarations }
FQueryServer: IQueryServer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.ConnectClick(Sender: TObject);
begin
if not (assigned(FQueryServer)) then
FQueryServer := TQueryServerCorbaFactory.CreateInstance('SimpleServer');
FQueryServer.Login(edtDatabase.Text, edtUserName.Text, edtPassword.Text);
end;
procedure TForm1.ExecuteClick(Sender: TObject);
var
i, j: integer;
CorbaData: OLEVariant;
begin
FQueryServer.SQL := memoSQL.Text;
FQueryServer.Execute;
grdCorbaData.ColCount := FQueryServer.FieldCount;
grdCorbaData.RowCount := 0;
j := 0;
while not (FQueryServer.EOF) do
begin
inc(j);
grdCorbaData.RowCount := j;
CorbaData := (FQueryServer.Data);
for i := 0 to FQueryServer.FieldCount - 1 do
begin
grdCorbaData.Cells[i + 1, j - 1] := CorbaData[i];
end;
FQueryServer.Next;
end;
end;
end.
Скачать весь проект
CORBA - Архитектура распределенных объектов.
Оформил: DeeCo
Сервер компании Epsylon Technologies.
Обзор архитектуры CORBA. Обобщенная Архитектура построения Брокеров Объектных Запросов разработана для поддержки интеграции самых разнообразных объектных систем. Спецификация CORBA устанавливает принципы создания Брокеров Объектных Запросов, которые и допускают такую интеграцию. Запрос посылается от клиента к серверу. Клиент это приложение, или нечто другое, выполняющее операцию над объектом, а реализация объекта - это код и данные, которые на самом деле выполняют эту операцию. ORB способен выполнить все действия, необходимые для нахождения реализация указанного объекта, подготовке этой реализации к обработке запроса и передаче данных, относящихся к запросу. Интерфейс, предоставляемый клиенту абсолютно не зависит от местоположения реализации объекта, языка программирования, на котором он написан или каких-либо других аспектов, не влияющих на определение интерфейса для данного объекта. Брокер Объектных Запросов. При определении конкретной архитектуры Брокер Объектных Запросов вовсе необязательно должен быть реализован как один компонент, но каждая реализация должна реализовывать три категории операций: Операции, которые одинаковы для всех реализаций ORB-а. Операции, специфичные для конкретного объектного типа. Операции, специфичные для отдельных видов реализаций объектов. Различные реализации ORB-а могут поддерживать различные виды реализаций, а различные адаптеры объектов могут обеспечивать различные наборы сервисов для клиента и реализаций. Ядро Брокера Объектных Запросов обеспечивает основные механизмы для манипуляций объектами и выполнения запросов. Спецификация CORBA предназначается для поддержки различных механизмов реализации объектов, поэтому структура ядра не определяется. Вместо этого задается набор интерфейсных функций, которые должны присутствовать в каждой реализации ORB-а и тем самым маскируют отличия между различными реализациями Брокеров Объектных Запросов. Объекты. Система объектов обеспечивает клиента набором сервисов. Клиент способен запросить некоторый сервис. Объект - это нечто, что обеспечивает один или более сервисов, которые клиент может запросить. Пример Брокеров Объектных Запросов. Доступно широкое множество способов реализации конкретных ORB-ов. Далее будут приведены примеры таких реализаций. Следует иметь ввиду, что конкретный ORB может быть реализован сразу несколькими способами. ORB, включаемый в клиентское и серверное приложение. Если имеется подходящий механизм коммуникаций, то возможна реализация ORB-а в виде набора подпрограмм как со стороны клиента, так и со стороны реализации объекта. Вызовы методов могут транслироваться в работу со средствами взаимодействия процессов (Inter Process Communication - IPC). ORB, выполненный в виде сервера. С целью обеспечения централизованного сбора и управления всевозможной информацией, ORB может быть реализован в виде отдельного приложения. Взаимодействующие приложения устанавливают контакт с ORB-ом посредством нормальных механизмов IPC. ORB как часть системы. Для повышения надежности, защиты данных и достижения лучшей производительности ORB может быть реализован как часть операционной системы. При этом ссылки на объект могут быть сделаны постоянными, таким образом, уменьшая время, необходимое для обработки каждого запроса. При реализации ORB-а как части операционной системы возможны всевозможные виды оптимизации, такие как избежание кодирования и декодирования данных, если клиент и сервер находятся на одной и той же машине. ORB, основанный на библиотеках. Если код объекта занимает небольшой объем и не требует никаких дополнительных средств, то он может быть выполнен в виде библиотеки. При этом все заглушки на самом деле будут являться настоящими методами. При этом предполагается, что имея доступ к данным реализации, клиент не разрушит эти данные. Реализации объектов. Реализация объекта обеспечивает само понятие объекта, обычно задавая данные для конкретного экземпляра объекта и код для выполнения методов объекта. Часто реализация будет использовать другие объекты или вспомогательные программы для обеспечения функционирования объектов. В некоторых случаях выполнение операции над объектом влечет некие побочные действия не над объектами. Конкретный ORB может поддерживать широкий набор объектных реализаций: отдельные серверы, библиотеки, объектно-ориентированные системы управления базами данных и др. С помощью использования дополнительных Адаптеров Объектов теоретически можно поддерживать любую реализацию объекта. Адаптеры объектов. Адаптер объектов - это первичный путь для обеспечения сервиса конкретной реализацией объекта. Предполагается, что имеется несколько адаптеров объектов, каждый из которых обеспечивает доступ к объектам определенного вида. Сервисы, которые обеспечиваются ORB-ом посредством адаптеров объектов часто включают: генерацию и интерпретацию ссылок на объекты, вызов методов, активацию и деактивацию реализаций объектов, а также регистрацию конкретных реализаций и отображение объектных ссылок и реализаций. Информация, которая находится в каждом из хранилищ может быть произвольно изменена в любой момент времени с помощью методов, обеспечиваемых реализацией ORB-а. Однако, неосторожное изменение, сделанное во время работы может привести нарушить целостность информации, находящейся в каждом из хранилищ и сделать невозможным дальнейшее функционирование ORB-а. Скелет реализации. Для конкретного отображения и, возможно, используемого адаптера объектов определяется свой порядок вызова методов каждого объекта. Этот интерфейс в общем случае является интерфейсов обратных вызовов. При необходимости ORB вызывает требуемые процедуры. Динамическая обработка запросов. Также доступен интерфейс для динамической обработки поступающих запросов. В этом случае реализация объекта взаимодействует с заданным интерфейсом по аналогии с интерфейсом динамических вызовов. Подпрограммы динамической отработки запросов могут вызываться как с помощью интерфейса динамических вызовов, так и с помощью процедур-заглушек, каждый метод дает одинаковый результат. Запросы. Клиент запрашивает сервисы инициированием запросов. Запрос - это событие, то есть действие, происходящее в конкретный момент. С запросом связана информация, состоящая из операции, объекта, у которого запрашивается сервис, нуля или более действительных параметров вызова и необязательный контекст запроса. Форма запроса - это описание или шаблон, который может быть выполнен произвольное количество раз. Форма запроса определяется отображением для конкретного языка программирования. Альтернативной формой запроса является использования Интерфейса Динамических Вызовов, который позволяет создать запрос, добавить аргументы и выполнить запрос. Под значением понимается допустимый параметр запроса. Значение которое определяет объект, называется ссылкой на объект, связанной с конкретным экземпляром объекта. Выполнение запроса вызывает выполнение соответствующего сервиса. После завершения запроса клиенту возвращается результат запроса (если он есть). В случае ненормального завершения запроса клиенту возвращается исключение. Исключение может содержать специфические параметры, специфические для данного типа исключений. Параметры.Параметр характеризуется режимом передачи и своим типом. Режим определяет, должно ли передаваться значение параметра от клиента к серверу (in), от сервера к клиенту (out) или в обоих направлениях (inout). Возвращаемое значение. Если есть возвращаемое значение, то оно рассматривается как параметр типа out. Исключения. Исключение свидетельствует о том, что операция не была успешно выполнена. Исключение может содержать дополнительную информацию, специфичную для конкретного исключения. Контекст. Контекст запроса обеспечивает передачу дополнительной, специфичной для операции информации, которая может повлиять на выполнение запроса. Параметры запросов определяются их позицией. Параметры могут быть входные, выходные и входные и выходные одновременно. Как результат запрос может возвратить одно значение, как, впрочем, и любые выходные параметры. В случае возникновения исключения значение всех выходных параметров не определено. Интерфейсы. Интерфейс - это описание множества возможных операций, которые клиент может выполнять над объектом. Объект удовлетворяет интерфейсу, если он может быть указан как конечным объектом для каждого потенциального запроса, описанного в интерфейсе. Типу интерфейса удовлетворяют только объектные типы. Интерфейс ORB-а. Интерфейс ORB-а является функциям, вызываемым непосредственно у Брокера Объектных Запросов и идентичным для всех ORB-ов, не зависящим от конкретного объекта либо адаптера объектов. Но так как большинство действий с объектами выполняется посредством адаптеров объектов, существует всего несколько общих операций, которые могут быть выполнены над каждым объектом. Эти операции могут вызываться как клиентом, так и реализацией объекта. Интерфейс динамического выполнения вызовов. Этот интерфейс допускает динамическое создание запросов к объекту вместо вызова процедуры, декорирующей такое создание. При динамическом создании запроса клиент должен указать всю информацию. Необходимую выполнения операции. Например, информация о типах параметров может быть получена с помощью хранилища описаний объектов. Клиентская часть - заглушки. Для объектно-неориентированных языков программирования задается программный интерфейс для доступа к методам объекта-заглушки, имеющегося у клиента. Эта заглушка осуществляет передачу запроса и обычно оптимизирована для выполнения под управлением конкретного ORB-а. Если доступно более одного ORB-а, то у них может быть различное внутреннее представление заглушек. Объектно-ориентированные языки программирования, такие как C++ и Smalltalk такого интерфейса не требуют. Обзор протокола GIOP. Спецификация протокола GIOP состоит из следующих элементов: Определение Общего Представления Данных (Common Data Representation - CDR). CDR - это способ кодирования типов данных, определенных в IDL в низкоуровневое представление, пригодное для передачи их по имеющимся каналам связи между ORB-ами. Формат сообщения протокола GIOP. Сообщения протокола GIOP обеспечивают нахождение объекта, отработку запросов, а также простейшее управление каналом коммуникации. Предположения о транспорте. Спецификация GIOP описывает общие предположения, которые делаются при рассмотрении любого сетевого транспортного слоя, который может быть использован для обмена сообщениями протокола GIOP. Также описываются общие принципы управления соединением. Спецификация IIOP добавляет к спецификации протокола GIOP следующий пункт: Транспорт для сообщений протокола IIOP. Спецификация IIOP описывает, каким образом агенты могут установить соединение по протоколу TCP/IP и использовать его для передачи сообщений протокола GIOP. Протокол IIOP не является самостоятельной спецификацией - это специализированное отображение протокола GIOP поверх транспортного слоя TCP/IP. Спецификация GIOP (без элементов, специфичных для IIOP) может рассматриваться как самостоятельный документ, являющийся базовым для обеспечения в будущем отображения на новые транспортные протоколы. Протокол обмена GIOP. За исключением редкого случая прямых вызовов методов между классами одного и того же языка программирования необходим механизм кодирования вызова метода в некоторую последовательность байт (byte stream) у клиента и декодирования этой последовательности у сервера. Для этой цели спецификация CORBA определяет Общий Протокол обмена между Брокерами Объектных Запросов (General Inter-Orb Protocol - GIOP). Кроме того, определен протокол передачи сообщений протокола GIOP поверх транспортного протокола TCP/IP, являющегося основным видом взаимодействия в Internet, ввиду чего этот протокол получил название Протокола обмена между Брокерами Объектных в Internet (Internet Inter-Orb Protocol - IIOP). Протокол IIOP должен поддерживаться всеми Брокерами Объектных Запросов независимо от особенностей их реализации, что является главным требованием для обеспечения взаимодействия между произвольными ORB-ами двух разных и совершенно независимых производителей. Особенности и цели протокола. Протоколы GIOP и IIOP допускают взаимодействие между различными ORB-ами независимо от платформ, на которых они выполняются, операционных систем, под управлением которых происходит взаимодействие и прочих аппаратно- и программно-зависимых аспектов. При разработке этих протоколов преследовались следующие цели: Распространенность. Протоколы GIOP и IIOP разрабатывались с учетом доступного широко распространенного и гибкого транспортного механизма (TCP/IP) и задает минимум дополнительных протоколов, необходимых для передачи запросов между отдельными ORB-ами. Простота. Помимо прочих требований, протокол GIOP сделан максимально простым. Его простота допускает возможность реализации взаимодействия по этому протоколу практически в любой системе. Масштабируемость. Протокол GIOP/IIOP должен поддерживаться как отдельными ORB-ами, так и ORB-ами, объединенными в сеть на уровне Internet и, возможно, шире. Небольшие затраты на реализацию. Реализация поддержки протоколов GIOP/IIOP должна потребовать минимальных затрат как в плане инженерного проектирования, так в плане распространения готовых ORB-ов. Общность. В то время как IIOP изначально определен поверх протокола TCP/IP, сообщения, которыми происходит обмен в рамках протокола GIOP специально разработаны для реализации поверх любого протокола, который базируется на установленном между сервером и клиентом соединении. Архитектурная независимость. Спецификация GIOP делает минимальные предположения об архитектуре агентов, которые поддерживают обмен данными по этому протоколу. Спецификация GIOP считает ORB некой системой с неизвестной архитектурой. Подход конкретного ORB-а к обеспечению поддержки протокола GIOP/IIOP не определен. Например, ORB может принять IIOP в качестве внутреннего протокола, использовать его только для внешнего обмена, используя для обмена в рамках самого ORB-а какие-то дополнительные средства коммуникации или выбрать нечто среднее между этими двумя крайностями. Все что требуется от ORB-а - это чтобы существовало нечто способное принимать и отправлять сообщения по протоколу IIOP. Формат сообщений протокола GIOP. Перед тем, как описывать сообщения протокола GIOP, необходимо определить понятие клиента и сервера. Под клиентом далее понимается агент, который открыл соединение и инициировал запрос. Сервер - это агент, который принял соединение и этот запрос получил. Протокол GIOP определяет семь сообщений, список которых приведен далее в таблице вместе с указанием того, какая сторона какие сообщения может посылать.Хранилище описаний представляет из себя сервис, который обеспечивается постоянным объектом, доступном из программы. Во время выполнения программы он дает доступ к информации, аналогичной той, что сохраняется в IDL описании объекта. Эта информация может быть использована для выполнения запроса - таким образом программа, которая не предусматривала использование объекта какого-либо типа, определить доступные у этого типа методы, типы его параметров и осуществить вызов.
CORBA клиент – Java Server.
Автор: Xavier Pacheco
unit uDelphiClient;
interface
uses
Windows, Messages, SysUtils, CorbInit, CorbaObj, orbpas, Classes, Graphics,
Controls, Forms, Dialogs,
StdCtrls;
type
ISimpleText = interface
['{49F25940-3C3C-11D3-9703-0000861F6726}']
function SetText(const txt: string): string;
end;
TSimpleTextStub = class(TCorbaStub, ISimpleText)
public
function SetText(const txt: string): string;
end;
TForm1 = class(TForm)
edtDelphiText: TEdit;
btnDelphiTextLate: TButton;
btnDelphiTextEarlyClick: TButton;
edtResult: TEdit;
procedure btnDelphiTextLateClick(Sender: TObject);
procedure btnDelphiTextEarlyClickClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.btnDelphiTextLateClick(Sender: TObject);
var
JavaServer: TAny;
begin
JavaServer := ORB.Bind('IDL:CorbaServer/SimpleText:1.0');
edtResult.Text := JavaServer.setText(edtDelphiText.text);
end;
{ TSimpleTextStub }
function TSimpleTextStub.SetText(const txt: string): string;
var
InBuf: IMarshalInBuffer;
OutBuf: IMarshalOutBuffer;
begin
FStub.CreateRequest('setText', True, OutBuf);
OutBuf.PutText(pchar(txt));
FStub.Invoke(OutBuf, InBuf);
Result := UnmarshalText(InBuf);
end;
procedure TForm1.btnDelphiTextEarlyClickClick(Sender: TObject);
var
JavaServer: ISimpleText;
begin
JavaServer := CorbaBind(ISimpleText) as ISimpleText;
edtResult.Text := JavaServer.SetText(edtDelphiText.text);
end;
initialization
CorbaStubManager.RegisterStub(ISimpleText, TSimpleTextStub);
CorbaInterfaceIDManager.RegisterInterface(ISimpleText,
'IDL:CorbaServer/SimpleText:1.0');
end.
Скачать весь проект
Корпоративное WEB-приложение 1.
| 12 Заповедей от Админа. 1. Прав всегда Админ, ибо в трех лицах есть он единая власть высшая в классе дисплейном! 2. Неправ вечно юзер, ибо прав всегда Админ! 3. Не возжелай ни места, ни системника, ни профиля, ни монитора, ни мыши Админа своего, и да пребудет с тобой вечное благословение его! 4. И если вошел Юзер в систему без высшего на то дозволения (Админа) - горе ему, ибо порушится профиль его! 5. Да убоится юзер установить прогу неустановленную на комп казенный - ибо не дозволено сие! 6. Да не будет превышен профиль юзерский, ибо сказал Админ: "Аз воздам за то обрезанием… профиля твоего!" 7. Не возжелай войти под паролем чужим в систему, ибо надолго потом из дисплейки выйдешь ты! 8. А если кто разрешение на папку сменит - горе юзеру этому, ибо всемогущ в системе своей Админ! 9. Да убоятся пользователи толпиться на местах своих подобно стадам овец безмозглых, ибо всеведущ Админ! 10. И да убоится юзер качать вирусы, ибо админомерзкое занятие сие! 11. А если кто из юзеров возжелает порнухи или чата админа своего - горе и позор ему, ибо высшие удовольствия эти лишь Админу дозволены! 12. А тот юзер, который прочел строки эти и не проникся смирением и не осознал, что тварь он ламероидная и чайник нечищенный в сиянии славы высшего существа Админоподобного - горе ему, ибо навеки отлучены они будут от сети великой!!! Во имя отца Билли Гейтса, и сына его Microsofta, и святого духа админовского. |
На сегодняшний день, создание внутренних корпоративных веб-приложений уже, пожалуй, не просто дань моде, когда все, что так или иначе связано с интернетом считалось популярным и прогрессивным. Нынче менеджеры стали более скупы в раздаче финансов для IT-отделов. Но вместе с тем приходит понимание, что бизнес-приложения предприятий перенесенные на новую технологическую "веб-оснастку" действительно значительно уменьшают издержки по поддержанию данных приложений в актуальном состояние в дальнейшем. Вот краткий перечень достоинств, которыми обладают корпоративные веб-приложения:
не требуют инсталляции и обновления клиентского программного обеспечения; снижают затраты на обучение - в качестве клиентской части используется стандартный веб-броузер; пользователи могут работать на любой платформе; логика приложения сосредоточена на стороне сервера; возможность интеграции с ресурсами интерета; создание сколь угодно привлекательного веб-интерфейса.Если мы будем рассматривать веб-приложения с точки зрения программиста, то представить их можно как некий особый класс систем клиент-сервер, в которых взаимодействие с пользователем осуществляется через стандартный веб-броузер. Если сравнивать структуру веб-приложения и классического приложения, основанного на технологии клиент-сервер, то можно охарактеризовать составляющие компоненты следующим образом:
В роли "тонкого клиента", которые отвечает за отображения данных и передачу их от пользователя серверу, выступает броузер. Пользовательский интерфейс всецело определяется HTML-документом, со всеми возможными дизайнерскими ухищрениями. Веб-сервер обеспечивает работу по протоколу HTTP, принимает запросы от клиента, взаимодействует непосредственно с веб-приложением, передает ответы клиенту. Веб-приложение - программа, которая, используя веб-сервер, обрабатывает запросы от клиента, производит необходимые манипуляции с данными, передает ответы клиенту.Давайте на практическом примере разберем все стадии создания законченного веб-приложения стандартными средствами Delphi 5. О том, насколько расширился диапазон компонентов для веб-приложений в новой версии Delphi 6, мы поговорим отдельно, и в конце цикла статей.
Подобная тема уже рассматривалась на нашем сайте. Смотрите материал "Создание web-приложений в среде Delphi" (www.mcsa.ru/d2.shtml), где достаточно подробно разбирался вопрос, как обычное консольное приложение, созданное в Delphi, без использования визуальных компонентов "превратить" в приложение для веб-сервера. Но сейчас мы рассмотрим создание веб-приложения с использованием специализированных компонентов Delphi.
Создать подобное приложение в Delphi не сложнее, чем стандартную визуальную программу для Windows. Что бы создать новое веб-приложение в Delphi 5, следует выбрать пункт Web Server Application. При этом существуют три различных варианта реализации приложения:
ISAPI/NSAPI Dynamic Link Library CGI Stand-alone executable Win-CGI Stand-alone executableТут нам придется обратиться к теории, чтобы четко представлять себе разницу между тем или иным типом веб-приложений. Вообще стандартная функциональность веб-сервера, это передача клиенту статических фалов по протоколу HTTP. Но чаще всего требуеться, чтобы информация, поступающая клиенту формировалась динамически. Для того чтобы веб-сервер мог получить, и соответственно передать от приложения данные клиенту, используют интерфейсы веб-сервера.
В общем случае их всего два: API (Application Program Interface - программный интерфейс приложений) и CGI (Common Gateway Interface - общий интерфейс шлюзов). Интерфейс типа API представляет собой традиционный программный интерфейс, вполне привычный для программистов использующих Delphi. При его использование нужно создать динамически загружаемый программный модуль, в котором должен быть реализован набор стандартных функций или классов операционной системы. Но помимо этого, возможно, использовать функции, которые предоставляет веб-сервер. К данному типу можно отнести интерфейсы ISAPI, NSAPI, WSAPI, Apache API, Java Servlet API и другие.
При создание рассматриваемого нами веб-приложения, будет использоваться интерфейс ISAPI, так как именно он реализован в MS IIS (Microsoft Internet Information Server). А именно этот веб-сервер от Microsoft, разумнее всего использовать для поддержки корпоративного веб-приложения. Но обо всем по порядку.
ISAPI (Internet Server Application Programming Interface) - программныей интерфейс, разработанный для сервера. ISAPI изначально был создан как Microsoft Information Server API, но в дальнейшем был предложен в качестве открытого стандарта. С помощью ISAPI возможно создавать два типа динамических модулей для веб-сервера: непосредственно обработчики событий и фильтры.
Обработчик событий представляет собой библиотеку DLL (Dynamic-Link Library), которая загружается и вызывается веб-сервером. Обработчик вызывается веб-сервером при получение клиентского запроса с URL, типа http://server/myapp.dll?запрос. При этом IIS вызывает библиотеку myapp.dll и передает ей параметр "запрос".
Работа обработчика запросов ISAPI происходит в следующей последовательности:
При получение первого клиентского запроса загружается соответствующая dll, создается и инициализируется объект типа CHttpServer. Для каждого конкретного запроса создается отдельный объект CHttpServerContext. Непосредственно для обработки запроса вызывается метод объекта CHttpServer, которому в качестве параметра передается указатель на CHttpServerContext. При этом, для каждой dll существует только один экземпляр CHttpServer, методы которого исполняются в адресном пространстве веб-сервера одновременно в нескольких потоках, при чем переменные объекта CHttpServer доступны для них всех. Сам объект CHttpServer не выгружается из памяти даже при прекращение выполнения запросов и доступен в течение всего времени работы веб-сервера.ISAPI-фильтр - это dll, которая загружается на при первом запросе от клиента, а непосредственно при старте IIS и вызывается для обработки определенных событий, возникающих при обращение клиента к веб-серверу. Это может быть как предварительная обработка заголовка клиентского запроса (например на корректность передаваемых данных), действие при ошибочных ситуациях (выдача ошибки 404 File Not Found или др.), авторизация клиента, запись данных в журнал веб-сервера и т.п. Создание ISAPI-фильтра ничем не отличается от создания стандартного ISAPI-приложения. Необходимо будет лишь указать IIS, что та или иная dll является ISAPI-фильтром.
Интерфейс CGI отличается от рассмотренного выше. Принцип его работы сводиться к следующему: веб-сервер запускает внешнею программу (являющуюся веб-приложением) в отдельном процессе операционной системы. При этом сервер устанавливает ряд переменных окружения с которыми взаимодействует приложения. Стандартно это заголовок HTTP-запроса, адрес запрашиваемого документа, строка параметров, в которой могут, к примеру, содержаться данные передаваемые из броузера пользователем и ряд других. Запущенное приложение анализирует данные переменные и в соответствии с внутренней логикой выдает HTTP-заголовок, которые и возвращается клиенту веб-сервером. Время жизни CGI-программы ограничено временем обслуживания пользовательского запроса, по окончанию его выполнения процесс завершается. При этом для каждого отдельного запроса запускается копия веб-приложения. Данные приложения не могут взаимодействовать друг с другом и не имеют программной связи с веб-сервером.
Если сравнивать CGI и API, вернее непосредственно ISAPI, то можно увидеть их достоинства и недостатки. Причем верна такая парадоксальная мысль, что в определенных условиях и для конкретных задач, недостатки одного или другого интерфейса легко "трансформируются" в достоинства. На данный момент CGI наиболее распространенный интерфейс и его поддерживают практически все веб-сервира без необходимости установки дополнительных модулей. CGI-программа может создаваться с использованием любого языка и средства разработки, поскольку запускается как независимый от веб-сервера процесс и строго говоря, зависимо только от операционной системы.
Преимуществом создания веб-приложений с использованием CGI является их относительная большая надежность и безопасность для веб-сервера, так как они выполняются независимо и даже в случае краха вряд ли могут привести к нарушению функциональности веб-сервера в целом. Веб-приложения использующие CGI обладают и рядом недостатков. При обработки большого количества запросов, веб-сервер испытывает значительные нагрузки, так как для каждого запроса необходимо отдельно заново запускать приложение. К тому же не имеется возможности взаимодействовать с данными, поступающими от других запущенных приложений и веб-сервера (кроме переменных окружения), что не позволяет создать достаточно масштабные и сложные проекты.
Основным преимуществом использования ISAPI можно считать то, что они, взаимодействуя с веб-сервером и объектами запросов поступающих от других пользователей позволяют создавать многопользовательские приложения. Это особенно важно при создание многопользовательских приложений работающих с базами данных и имеющих сложную логику. В качестве примера можно привести чаты, где например каждый обработчик событий может обращаться к общему для всех запросов списку сообщений. Или интернет-магазин использующий список выбранных в корзину товаров. Главнй недостаток ISAPI, что данный интерфейс поддерживается исключительно сервером MS ISS. Кроме того, при некорректной работе ISAPI-приложения возможны сбои в работе всего веб-сервера.
Еще одна существующая угроза, заключена в следующем: ввиду того, что IIS весьма часто подвергается хакерским атакам и вообще не очень надежный сервер использовать его как полноценные веб-сервер вне корпоративной сети, скорее всего не стоит. Но в том случае, если IIS будет использован как внутренний корпоративный веб-сервер, с использованием веб-приложений - это практически идеальный вариант.
Почему мы все же выбираем ISAPI-приложение, если есть возможность создания (и средствами Delphi в том числе) приложенный для CGI, ASP и т.д.? Дело в том, что подобные веб-приложения быстрее и требуют меньших ресурсов. Веб-приложение основанное на ISAPI многопоточно, и для обработки запроса клиента не требуется загрузки еще одной копии приложения. По сравнению с тем же пресловутым ASP, они имеют гораздо больший перечень функциональных возможностей. Например, можно использовать все множества функций Win32 API без необходимости писать для этого COM-объекты и существенно выигрывают по скорости, за счет того, что их код уже откомпилирован и оптимизирован. Веб-приложения основанные на ISAPI кроме того легко создаются из любого уже существующего приложения. Если оно было написано на Delphi, то все может совестить к тому, чтобы заменить визуальные объекты на специальные веб-компоненты, не переписывая ту часть, где сосредоточена сама логика приложения, и его работа, например с базами данных.
В следующей части материала мы определим непосредственно логику приложения и структура баз данных. А также создадим веб-интерфейс приложения и рассмотрим особенности модуля Delphi WebModule.
Корпоративное WEB-приложение 2.
| Сын спрашивает у папы программиста: - Пап, откуда дети берутся? - Отстань сынок, я занят, спроси у Яндекса! |
В предыдущем материале мы рассмотрели особенности работы и различия в реализации ISAPI/NSAPI и CGI приложений для веб-сервера. Теперь настал черед использовать полученные навыки на практике.
Так как мы будем создавать ISAPI-приложение, то соответственно необходимо, чтобы на компьютере был установлен IIS. В Windows 9.xx он также именуется как Personal Web Server и находиться обычно в папке PWS инсталляционного диска. Для установки IIS в Windows 2000 необходимо выбрать компоненты служб IIS при установке или добавление компонентов Windows.
Для создания ISAPI-приложения в Delphi необходимо создать новый проект Web Server Application. Как видите по умолчанию сразу же доступен специальный модуль WebModule. Он является обязательным и дает возможность веб-приложению ответить на запрос HTTP, пропуская запрос и ответ к соответствующим обработчикам ActionItems. Приложение может содержать только один WebModule.
Так как это основной объект, с которым придется работать, создавая веб-приложение, стоит рассмотреть WebModule подробнее. К главным событиям WebModule относятся:
OnCreate Это событие происходит в тот момент, когда приложение создает WebModule. Чаще всего его следует использовать для инициализации переменных и объектов, содержащихся в приложении. OnDestroy Происходит перед уничтожением WebModule. Здесь желательно производить освобождение объектов, созданных динамически в приложении. BeforeDispatch Событие происходит перед тем, как диспетчер устанавливает соответствие запроса HTTP с ActionItems. AfterDispatch Происходит после того, как HTTP ответ был успешно сформирован ActionItems, но еще не передан клиенту.Создавая ISAPI приложения, нужно помнить, что объект WebModule может быть создан один раз и не создаваться при каждом запросе, следовательно, не будут генерироваться события OnCreate и OnDestroy объекта WebModule.
WebModule имеет два важных свойства Request и Response, с помощью которых принимает и передает данные IIS. Response - автоматически создаваемый объект WebModule, содержащий информацию, которая будет передана клиенту, в результате обработки запроса. После того как все свойства Response будут заполнены, будет сформирован HTTP ответ, который и будет передан клиенту.
Среди свойств объекта Response существуют следующие:
ContentType Тип содержимого HTTP ответа в соответствии со спецификацией MIME. Его необходимо использовать, чтобы установить тип содержимого передаваемого клиенту. Если к примеру нужно передать изображение в формате GIF, необходимо установить ContentType = 'image/gif'. Content Содержит непосредственно информацию, передаваемую клиенту в ответ на сообщение запроса HTTP. ContentStream Определяет Stream объект, который будет передан клиенту. Используют в основном для передачи клиенту содержимого отличного от ContentType = 'text/*'. Request Также автоматически создаваемый объект WebModule, с помощью которого можно получить информацию от пользователя. В принципе Request представляет текущий HTTP запрос в удобной для обработке форме. Его основные свойства: ContentFields Предоставляет содержимое полей POST запроса. QueryFields Предоставляет содержимое GET запроса. То есть извлекает необходимый параметр, передаваемый приложению из url. Как ContentFields, так и QueryFields возвращаю параметры в виде "имя = значение".Пойдем дальше. Попробуем создать простейшее веб-приложение, что-то вроде новой вариации "Hello, world!" для IIS. WebModule у нас уже создан. Теперь возьмем с закладки компонентов Delphi Internet, компонент PageProducer, что отвечает за выдачу HTML-документа.
В свойстве HTMLDoc PageProducer наберем всем известное "Hello, world!". Теперь необходимо создать Add Item - новый обработчик событий. Сделаем так, чтобы он запускался по умолчанию. Для этого переведем свойство Default из False в True. И заключительный шаг - укажем обработчику на то, что он должен выдавать результат созданного PageProducer. В свойстве Producer выберем PageProducer.
Наше веб-приложение готово. Готовый dll нужно скопировать в каталог веб-сервера и запустить его через броузер, по адресу вроде http://localhost/cgi-bin/Project1.dll. В окне броузера должно появиться приветствие "Hello, world!".
На сегодня это пока все. В следующий раз попробуем создать что-то более существенное, например, подключиться к базе данных.
Корректное закрытие базы данных приложением Delphi.
Очень интересный и полезный вопрос!! Я сам так с ним до конца и не разобрался! Но я попробую систематизировать события, происходящие при запросе на завершение работы Windows: Windows посылает сообщение WM_QUERYENDSESSION главным окнам всех запущенных приложений, при этом приложения должно сообщить свою готовность к завершению работы. Если при этом хотя бы одно из приложений ответит отрицательно, Windows прерывает процесс завершения работы. Delphi перехватывает это сообщение, и, в свою очередь, вызывает метод TForm.CloseQuery, (в главной форме, естественно), который генерирует событие OnCloseQuery, в обработчике которого можно указать на неготовность завершения приложения и отмены завершения работы Windows. Если я правильно понимаю, если ваше приложение "не мешает" Windows завершить свою работу, Windows нормально НЕ завершает работу приложения, поскольку для этого нет необходимости, не нужно освобождать память, ресурсы и пр. Так, если это утверждение верно (это легко можно проверить, но я слишком ленив сейчас), то событие OnCloseQuery - ваш единственный шанс сохранения данных на диске. Я не думаю что эта логика слишком плоха, просто это одна из тех причуд Windows, которую нужно знать и пользоваться ею. Что может произойти в описанном выше сценарии: редактируемая в настоящий момент запись не будет отправлена (Post) в базу данных, но та же самая вещь может случиться и при нормальном завершении приложения.При выходе из windows, вы вызываете WM_CLOSE api (или что-то типа этого) для каждого работающего в настоящий момент приложения. Программа закрывается точно таким же образом, как если бы вы щелкнули на кнопке закрытия или вызвали close из главной формы. Поэтому вам не нужно предпринимать никаких дополнительный действий, связанных с завершением работы с таблицами.
Как правильно соединяться с базой данных под Personal Oracle.
Автор: NomadicA: user/password@2: Это так для Oracle SQL Plus, и более других его утилит. А в BDE надо оставить все как для соединения с сетевым сервером, (протокол TNS, имя пользователя, кодировку, интерфейсную DLL) только вместо имени сервера написать "2:". Это годится и для случая, когда на одной машине и сетевой сервер и приложение.
Корректная функция возведения в степень.
Автор: Mikel WEB сайт: http://forum.vingrad.ru
function power(Base, Exponent: Extended): Extended;
var
ex: extended;
begin
power := 0;
if (exponent <> 0)
and (frac(trunc((1 / exponent) * 1000000) / 1000000) = 0)
and (base < 0) then
begin
if round(1 / exponent) mod 2 = 0 then
exit;
ex := Exp(Exponent * Ln(-Base));
power := -ex;
end
else
begin
if Exponent = 0.0 then
power := 1.0
else if (Base = 0.0) and (Exponent > 0.0) then
power := 0.0
else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
power := IntPower(Base, Integer(Trunc(Exponent)))
else
power := Exp(Exponent * Ln(Base))
end;
end;
Теперь можем вычислить нечетный корень из отрицательного числа.
Корректное округление чисел.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
The function Round of the Delphi doesn't work
like it is usually expected.
The odd numbera are rounded down and the even numbers up.
Die Round Funktion in Delphi gibt normalerweise nicht
die erwartete Zahl zигьск.
Die ungeraden Zahlen werden abgerundet, die geraden aufgerundet
Example/ Beispiel:
x:= Round(17.5) = x = 18
x:= Round(12.5) = x = 12
}
function DoRound(const X: Extended): Int64;
begin
Result := 0;
if X0 then
Result := trunc(X + 0.5);
if Xthen
Result := trunc(X - 0.5);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(FormatFloat('0.00', DoRound(17.5))); // - 18
ShowMessage(FormatFloat('0.00', DoRound(12.5))); // - 13
//This rounds every value to 0.05 steps
//Rundet in 0.05 Schritten
ShowMessage(FormatFloat('0.00', Round(17.22 / 0.05) * 0.05)); // - 17.20
end;
{***Another function:***}
function RoundUp(Value: Extended): Int64;
procedure Set8087CW(NewCW: Word);
asm
MOV Default8087CW,AX
FNCLEX
FLDCW Default8087CW
end;
const
RoundUpCW = $1B32;
var
OldCW: Word;
begin
OldCW := Default8087CW;
try
Set8087CW(RoundUpCW);
Result := Round(Value);
finally
Set8087CW(OldCW);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(FormatFloat('0.00', RoundUp(19.32))); // - 19
end;
Как реализовать визуальный отсчет времени.
Автор: Cobalt
var Min3: integer;
procedure TForm1.Button1Click(Sender: TObject);
begin
timer1.enabled:=true;
Min3:=3*60;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption:=Format('%d : %2d',[Min3 div 60, Min3 mod 60 ]);
Dec(Min3);
if Min3 < 0 then
// Что-то делаешь - 3 минуты закончились
end;
|
Как узнать число кадров AVI файла, и выяснить как долго будет проигрываться этот файл.
| Звонок в фирму: - Сколько байтов в вашем компьютере? - ??? Сколько надо, столько и будет! - А сколько надо для мультивидео? |
procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.TimeFormat := tfFrames;
ShowMessage('Number of frames = ' + IntToStr(MediaPlayer1.Length));
MediaPlayer1.TimeFormat := tfMilliseconds;
ShowMessage('Number of milliseconds = ' + IntToStr(MediaPlayer1.Length));
end;
|
Сколько файлов есть в определённой папке.
Автор: Vit WEB-сайт: http://forum.vingrad.ru
function GetFileCount(Dir: string): integer;
var
fs: TSearchRec;
begin
Result := 0;
if FindFirst(Dir + '\*.htm', faAnyFile - faDirectory - faVolumeID, fs) = 0
then
repeat
inc(Result);
until
FindNext(fs) <> 0;
FindClose(fs);
end;
Найти количество дескрипторов форм, используемых вашим приложением.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function EnumProc(wnd: HWND; var count: DWORD): Bool; stdcall;
begin
Inc(count);
result := True;
EnumChildWindows(wnd, @EnumProc, integer(@count));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
count: DWORD;
begin
count := 0;
EnumThreadWindows(GetCurrentThreadID, @EnumProc, Integer(@count));
Caption := Format('%d window handles in use', [count]);
end;
Подсчитать количество вхождений подстроки в строке.
Автор: RhinoFC WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Подсчитать количество вхождений подстроки в строке
Понадобилось подсчитать количество вхождений подстроки в строку,
вот и появилась эта функция. Возможно в ней и нет изюминки,
но может кому и пригодится.
Зависимости: System
Автор: Дмитрий, bestonix@mail.ru, ICQ:155133146, Тольятти
Copyright: Дмитрий
Дата: 17 октября 2002 г.
***************************************************** }
function CntRecurrences(substr, str: string): integer;
var
cnt, p: integer;
begin
cnt := 0;
while str <> '' do
begin
p := Pos(substr, str);
if p > 0 then
inc(cnt)
else
p := 1;
Delete(str, 1, (p + Length(substr) - 1));
end;
Result := cnt;
end;
Алгоритм подсчёта времени, которое ушло на какую-либо операцию.
| Интернациональная встреча Нового Года (2000). Американец, хвастаясь успехами своей страны: - А вот у нас, в Америке .... Наш _ВОЕННЫЙ_ программер, поднимая лицо из тарелки с салатом: - А вот нет больше твоей Америки Американец, обливаясь холодным потом: - Как нет?? Почему?? Наш, пуская пузыри в салат (неразборчиво): - А у нас проблема 2000 была на 12 часов раньше .... |
var
OperBegin, OperEnd: TTimeStamp;
Total: LongWord;
begin
OperBegin := DateTimeToTimeStamp(Now); {запоминается момент начала операции}
{Здесь размещается код операции}
OperEnd := DateTimeToTimeStamp(Now); {запоминается момент окончания операции}
Total := OperEnd.Time - OperBegin.Time;
end;
|
Найти количество вхождений подстроки в строку.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function CountPos(const subtext: string; Text: string): Integer;
begin
if (Length(subtext) = 0) or (Length(Text) = 0) or (Pos(subtext, Text) = 0) then
Result := 0
else
Result := (Length(Text) - Length(StringReplace(Text, subtext, '', [rfReplaceAll]))) div
Length(subtext);
end;
Подсчет количества слов в строке.
Автор: Алексей Вуколов WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Подсчет количества слов в строке.
Возвращает количество слов в строке, границы слов определяются в
соответствие с набором разделителей.
Описание параметров:
s - строка, в которой происходит подсчет слов;
Delimiters множество, содержащее символы-разделители слов;
Возвращаемое значение - количество слов
Зависимости: SysUtils, UBPFD.WordScan
Автор: vuk, vuk@fcenter.ru
Copyright: Алексей Вуколов
Дата: 18 апреля 2002 г.
***************************************************** }
function CountWords(const s: string; Delimiters: TSysCharSet): integer;
var
wStart, wLen: integer;
begin
Result := 0;
wStart := 1;
while WordScan(s, wStart, wLen, Delimiters) do
begin
inc(Result);
inc(wStart, wLen);
end;
end;
Пример использования:
WordCount := CountWords('This is a sample', [' ']);
Самый быстрый способ определить частоту проца.
Автор: Shady.
uses registry;
...
function GetCpuMhz: Word;
begin
with tregistry.Create do
begin
rootkey := HKEY_LOCAL_MACHINE;
openkey('\hardware\description\system\centralprocessor\0\', false);
result := readinteger('~mhz');
free;
end;
end;
Извлечь информацию о процессоре.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
//Sometimes u need to know some information about the CPU
//like: brand id, factory speed, wich instruction set supported etc.
//If so, than u can use this code.
//2002 by -=LTi=-
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
Tfrm_main = class(TForm)
img_info: TImage;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure info(s1, s2: string);
end;
var
frm_main: Tfrm_main;
gn_speed_y: Integer;
gn_text_y: Integer;
const
gn_speed_x: Integer = 8;
gn_text_x: Integer = 15;
gl_start: Boolean = True;
implementation
{$R *.DFM}
procedure Tfrm_main.FormShow(Sender: TObject);
var
_eax, _ebx, _ecx, _edx: Longword;
i: Integer;
b: Byte;
b1: Word;
s, s1, s2, s3, s_all: string;
begin
//Set the startup colour of the image
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));
gn_text_y := 5; //position of the 1st text
asm //asm call to the CPUID inst.
mov eax,0 //sub. func call
db $0F,$A2 //db $0F,$A2 = CPUID instruction
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
for i := 0 to 3 do //extract vendor id
begin
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1:= s1 + chr(b);
b := lo(_edx);
s2:= s2 + chr(b);
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('CPU', '');
info(' - ' + 'Vendor ID: ', s + s2 + s1);
asm
mov eax,1
db $0F,$A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
//06B1
//|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|
b := lo(_eax) and 15;
info(' - ' + 'Stepping ID: ', IntToStr(b));
b := lo(_eax) shr 4;
info(' - ' + 'Model Number: ', IntToHex(b, 1));
b := hi(_eax) and 15;
info(' - ' + 'Family Code: ', IntToStr(b));
b := hi(_eax) shr 4;
info(' - ' + 'Processor Type: ', IntToStr(b));
//31. 28. 27. 24. 23. 20. 19. 16.
// 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
b := lo((_eax shr 16)) and 15;
info(' - ' + 'Extended Model: ', IntToStr(b));
b := lo((_eax shr 20));
info(' - ' + 'Extended Family: ', IntToStr(b));
b := lo(_ebx);
info(' - ' + 'Brand ID: ', IntToStr(b));
b := hi(_ebx);
info(' - ' + 'Chunks: ', IntToStr(b));
b := lo(_ebx shr 16);
info(' - ' + 'Count: ', IntToStr(b));
b := hi(_ebx shr 16);
info(' - ' + 'APIC ID: ', IntToStr(b));
//Bit 18 =? 1 //is serial number enabled?
if (_edx and $40000) = $40000 then
info(' - ' + 'Serial Number ', 'Enabled')
else
info(' - ' + 'Serial Number ', 'Disabled');
s := IntToHex(_eax, 8);
asm //determine the serial number
mov eax,3
db $0F,$A2
mov _ecx,ecx
mov _edx,edx
end;
s1 := IntToHex(_edx, 8);
s2 := IntToHex(_ecx, 8);
Insert('-', s, 5);
Insert('-', s1, 5);
Insert('-', s2, 5);
info(' - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);
asm
mov eax,1
db $0F,$A2
mov _edx,edx
end;
info('', '');
//Bit 23 =? 1
if (_edx and $800000) = $800000 then
info('MMX ', 'Supported')
else
info('MMX ', 'Not Supported');
//Bit 24 =? 1
if (_edx and $01000000) = $01000000 then
info('FXSAVE & FXRSTOR Instructions ', 'Supported')
else
info('FXSAVE & FXRSTOR Instructions Not ', 'Supported');
//Bit 25 =? 1
if (_edx and $02000000) = $02000000 then
info('SSE ', 'Supported')
else
info('SSE ', 'Not Supported');
//Bit 26 =? 1
if (_edx and $04000000) = $04000000 then
info('SSE2 ', 'Supported')
else
info('SSE2 ', 'Not Supported');
info('', '');
asm //execute the extended CPUID inst.
mov eax,$80000000 //sub. func call
db $0F,$A2
mov _eax,eax
end;
if _eax > $80000000 then //any other sub. funct avail. ?
begin
info('Extended CPUID: ', 'Supported');
info(' - Largest Function Supported: ', IntToStr(_eax - $80000000));
asm //get brand ID
mov eax,$80000002
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3:= s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s3 + s + s1 + s2;
asm
mov eax,$80000003
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s_all + s3 + s + s1 + s2;
asm
mov eax,$80000004
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('Brand String: ', '');
if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
info('', ' - ' + s_all + s3 + s + s1 + s2);
end
else
info(' - Extended CPUID ', 'Not Supported.');
end;
procedure Tfrm_main.info(s1, s2: string);
begin
if s1 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clyellow;
img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);
end;
if s2 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clWhite;
img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);
end;
Inc(gn_text_y, 13);
end;
end.
Работа с портами микропроцессора.
| Автор: Pavlo Zolotarenki |
| Отряд милиции особого назначения разогнал толпу бунтующих программистов.... до 1ГГц. |
Модуль для работы с портами микропроцессора с сохранением синтаксиса. Работает под Win9x. НЕ работает под WinNT.
//Copyright(c) 1998 Zolotarenko P.V pvz@mail.univ.kiev.ua
unit Ports;
interface
type
TPort = class
private
procedure Set_(index_: word; value: byte); register;
function Get_(index_: word): byte; register;
public
property Element[index_: word]: byte read Get_ write Set_; default;
end;
TPortW = class
private
procedure Set_(index_: word; value: Word); register;
function Get_(index_: word): word; register;
public
property Element[index_: word]: word read Get_ write Set_; default;
end;
var
Port: TPort;
PortW: TportW;
implementation
procedure TPort.Set_(index_: word; value: byte);
begin
asm
mov dx,index_
mov al,value
out dx,al
end;
end;
function TPort.Get_(index_: word): byte;
begin
asm
mov dx,index_
in al,dx
mov @Result,al
end;
end;
procedure TPortW.Set_(index_: word; value: word);
begin
asm
mov dx,index_
mov ax,value
out dx,ax
end;
end;
function TPortW.Get_(index_: word): word;
begin
asm
mov dx,index_
in ax,dx
mov @Result,ax
end;
end;
initialization
Port := TPort.Create;
PortW := TPortW.Create;
finalization
Port.free;
PortW.free;
end.
|
Как получить информацию о загрузке процессора.
| Автор: Nomadic |
| Сообщение Windows: "CPU not found. Software emulation". |
Читать из реестра HKEY_DYN_DATA\PerfStats\StatData соответствующий ключ Kernel \CPUUsage.
Показывает загруженость процессора.
Автор: DDA WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Показывает загруженость процессора
Показывает загруженость процессора
Зависимости: registry,Windows, SysUtils, Forms,Gauges,
Classes, Controls, ExtCtrls, StdCtrls;
Автор: DDA, Vologda
Copyright: Где-то найдено
Дата: 11 февраля 2004 г.
***************************************************** }
unit Unit1;
interface
uses
registry, Windows, SysUtils, Forms, Gauges, Classes, Controls, ExtCtrls,
StdCtrls;
type
TForm1 = class(TForm)
Gauge1: TGauge;
Timer1: TTimer;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
def: string;
reg: TRegistry;
Buffer: array[0..1000] of integer;
begin
//-------------------------------
reg := TRegistry.Create;
reg.RootKey := HKEY_DYN_DATA;
def := '';
if reg.OpenKey('PerfStats\StartStat', false) = TRUE then
begin
reg.ReadBinaryData('KERNEL\CPUusage', buffer, 1000);
end;
reg.CloseKey;
Timer1.Enabled := true;
end;
//-------------------------------
procedure TForm1.Timer1Timer(Sender: TObject);
var
def: string;
reg: TRegistry;
B: array[1..4] of integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_DYN_DATA;
def := '';
if reg.OpenKey('PerfStats\StatData', false) = TRUE then
begin
reg.ReadBinaryData('KERNEL\CPUusage', b, 4);
end;
reg.CloseKey;
Gauge1.Progress := b[1];
Application.ProcessMessages;
//-------------------------------
end;
end.
Три примера крэка программ.
Автор: Bad_guy WEB сайт: http://cracklab.narod.ru Вот три примера крэка программ с нарастанием по сложности (в пределах своей компетентности). 1. Самая простая защита программы, которая мне попалась за мой период работы - Screen Loupe for Windows 95 NT v4.5 [122 Kb] - она увеличивает часть рабочего стола, показывает координаты мыши на столе, цвет под указателем мыши в виде #XXXXXX, грабит экран и другое, вообщем иногда нужна. Она относится к классу Shareware (мой любимый) и показав себя в действии требует регистрации в течение ХХ дней (это не имеет значения) с начала использования. Ну, я взял и, недолго думая, поставил в SоftIсе'е брэйкпойнты на GetWindowTextA и GetDlgItemTextA (надеюсь вы знаете как это делать, если нет, то сначала прочитайте текстик, ссылка на который находится в самом верху этой страницы), ввёл данные в поля Name, Company, Serial#, причём на месте Serial# я обычно ставлю 12345 (3039h). Нажимаю OK и программа забрейкпойнтилась по GetDlgItemTextA - нажав 2 раза F12 и посмотрев в регистре ESI вы увидите введённое имя, по следующему GetDlgItemTextA увидите вашу фирму, а далее по ещё одному GetDlgItemTextA, оказавшись по адресу 40626B можно посмотреть в регистре ECX (команда: db ECX) кое-что (ну, что узнали?), а затем пройдя по F10 до адреса 406271, посмотрите на EAX - я там увидел 3039 (это шестнадцатиричное 12345), далее EAX копируется в EBX. Сейчас можно предположить, что правильный номер, когда он вычислится, будет: во-первых - сравниваться с EBX, во-вторых - в шестнадцатиричном виде. Я посмотрел далее и вот оно !!! по адресу 4062B8 CMP EAX, EBX , а дальше JZ XXX... Смотрим правильный рег. номер командой ?EAX , можно записать его на бумажку и подпрыгивать от радости, когда программа скажет вам Thank You!, но я предлагаю сделать проще: когда вы ещё по адресу 4062B8 - пишите команду r ebx=eax - и выходим из SoftIce'a, ну что ж, одна программа сломана. Вот, где она сохраняет свои регистрационные данные: HKEY_CURRENT_USER\Software\Software by Design\Screen Loupe for Windows 95/NT\Registration 2. Более сложная защита программы (...но на самом деле очень простая :-), которой защищено БОЛЬШИНСТВО программ класса ShareWare была применена авторами программы BadCopy99 v1.5 [273 Kb] Программа эта весьма замечательная и интерфейс у неё симпатичный, она нужна для того, чтобы считывать информацию с попорченных дискет и дисков(помните такую ошибку: "Неудаётся произвести чтение с устройства"), нечитаемые сектора заменяются нулями. Ну для начала я открыл её в Restorator'e и сразу понял, что написана она на Дельфи и установка брейкпонтов GetWindowTextA, GetDlgItemTextA ничего мне не даст, тогда я воспользовался ЗАМЕЧАТЕЛЬНЕЙШИМ брейкпойнтом bpx hmemcpy и, конечно, не безрезультатно. Посмотрим, сколько раз программа прервётся по hmemcpy ---- 4 раза - появился MessageBox, ага - очень хорошо даже окошечко ввода данных не закрылось, теперь по четвёртому hmemcpy будем начинать смотреть алгоритм работы программы - смотрим, смотрим (жмём F12 пока RET ни кончатся) - ну вот мы пришли на код:MOV EDX, [EBP-38] POP EAX CALL 00403E94Перед входом в процедуру смотрим данные по адресу EAX
:d EAX - это введённый вами код;теперь EDX:
:dedx - ну что ? вот и код - ещё тёпленький совсем !Нет, конечно я соврал, большинство программ защищено лучше, а эта - полминутный крэк для новичка. 3. Ну и наконец самый сложный способ защиты (для новичка)...надо сказать я долго думал, прежде чем выбрал эту программу...пожалуй это будет Xara3D4 (2 May 2000) [989 Kb] - вы набираете текст на клавиатуре, он выводится как трехмерный объект, вы можете вращать его, натягивать на него текстуру, на фоне тоже можно использовать текстуру из внешнего файла, выходной файл может быть либо анимация: GIF, AVI; либо картинка: BMP, GIF, JPG. Но плоха она тем, что пока вы не "зарегистрированы" на фоне КРУПНЫМИ БУКАМИ сотни раз написано слово DEMO, и ясно, что пока мы это не уберём, о качественном результате речь не идёт. Метод защиты у этой программы довольно запутанный, проверка пароля зарыта где-то в процедурах. Сразу же оговорюсь, что ломает она себя сама, как и Screen Loupe, но в отличие от неё она для вычисления своего пароля использует имя компьютера + случайно или псевдо-случайно сгенерированный для себя код. Вот это-то меня поначалу и подвело: поломавшись она создала свой ключ в реестре, а я взял, да и скопировал этот ключ + псевдо-случайно сгенерированный код (который она показывает в заголовке окна регистрации) из реестра в файл реестра и думал, что всё на этом, не тут-то было: пришёл я на работу, установил программу, подсунул в реестр те данные и круто обломался...ведь имя компьютера на работе другое. И тогда мне в голову пришла мысль злостно её поломать ХА-ХА-ХА
4. Сразу предупрежу вас о граблях-программах на которые иногда мне приходилось наступать. Дело в том, что существуют ShareWare программы (их примерно 25% от общего числа ShareWare), которые практически невозможно взломать (обычно они очень дорогие от 40$ или очень дешёвые 2$) Комментарий от 7 мая 2002 года: C прискорбием сообщаю, что программы скаченные мной в 2002 году удивили меня хорошей защитой - теперь не взломать где-то 50-70% этих программ. Что ж, может это и хорошо, что программисты умнеют ?!, а может это я скачиваю слишком "умные" программы ? Комментарий от 16 августа 2002 года: Оказалось, что программисты не умнеют, а просто юзают ASProtect и подобные программы, да ещё категорически отказываются изучать методы защиты своих программ (из личного общения с shareware программистами).
Взлом программ это просто - электронная кулинарная книга.
| Автор: Fess |
| K хакеру подходит ламер, протягивает исходник своей неработающей программы и спрашивает: - Где у меня ошибка? - В ДНК!!! |
У меня она нашлась на 80510EF2. Ставим бряк на эту область памяти. Ведь проге эту строчку считывать когда-нибудь надо, а? Это делается командой bpmb , т.е. у меня это bpmb 80510EF2 Ввели. Хорошо. Нажимаем кнопку "Зарегистрировать" и вываливаемя в Soft-Ice. Далее все просто. Нажимаем F12 не вывалимся в программу kulinar.exe, здесь для этого надо нажать 7 раз. Потом нажимаем на F12 еще несколько раз пока не увидим присвоение eax адреса в памяти (5 раз), и там будут такие строки (взято из Win32Dasm).
:004EF314 8B8530FEFFFF mov eax, dword ptr [ebp+FFFFFE30] :004EF31A 50 push eax :004EF31B 8D8528FEFFFF lea eax, dword ptr [ebp+FFFFFE28] :004EF321 E80286FFFF call 004E7928 :004EF326 FFB528FEFFFF push dword ptr [ebp+FFFFFE28] :004EF32C 6868F44E00 push 004EF468 :004EF331 8D8524FEFFFF lea eax, dword ptr [ebp+FFFFFE24] :004EF337 E8006FF7FF call 0046623C :004EF33C FFB524FEFFFF push dword ptr [ebp+FFFFFE24] :004EF342 8D852CFEFFFF lea eax, dword ptr [ebp+FFFFFE2C] :004EF348 BA03000000 mov edx, 00000003 :004EF34D E8324CF1FF call 00403F84 :004EF352 8B952CFEFFFF mov edx, dword ptr [ebp+FFFFFE2C] :004EF358 58 pop eax :004EF359 E8764CF1FF call 00403FD4 :004EF35E 0F85BA000000 jne 004EF41E :004EF364 8B15DCBD4F00 mov edx, dword ptr [004FBDDC] :004EF36A 8B12 mov edx, dword ptr [edx] |
Я тут подумал и решил сделать вывод номера функцией MessageBoxA Формат команды такой.
MessageBoxA(идентификатор окна, заголовок,текст,атрибуты) |
Т.е. наш текст на асме будет выглядеть так:
push 0 ; идентификатор окна push edx ;заголовок - где edx адрес правильного номера push edx ;текст - где edx адрес правильного номера push 0 ; аттрибуты стандартные call MessageBoxA ;Вызов процедуры генерации окна |
Т.к. я не догнал как вызвать MessageBoxA в уже скомпилированной проге решил вызвать какой-нибудь из уже существующих с нашмими параметрами. Я решил взять по адресу 40C26F. Т.е. введем рush'и и прыгнем jumр'ом. Писать будем начиная 4EF358 программу все равно запорем. Теперь переименовываем файл kulinar.ex_, который мы распаковали и дисассемблировали в kulcrk.exe. Копируем сюда же qview. Набираем в командной строке: qview kulcrk.exe. Нажимаем Enter, вошли. Т.к. у Delphi реальные адреса в программе не совпадают с виртуальными (в памяти), то придется искать по сигнатуре. Т.е. ищем сначала такую строку E8324CF1FF8B952CFEFFFF для этого переходим в режим дизассемблера два раза F4. И в режим 32 бит. F2 один раз. Такая строка встречается 1 раз по адресу EE758 приглядывамся, это она и есть значит здесь 4EF358=EE758. Теперь ищем Call MessageBoxA, если подумать, то его можно узнать выразив из разницы значений 4EF358-EE758= 400C00, значит если в памяти MessageBox находится по адресу 40C26F значит реально он находится 40C26F - 400C00 = B66f. Теперь с адреса EE758, нажав Tab начинаем писать :
push 0 push edx push edx push 0 jmp B66f |
With best wishes Fess.
Алгоритм действий при взломе ShareWare программы, защищённой паролем.
Автор: Bad_guy WEB сайт: http://cracklab.narod.ru 1. Исследуем язык, на котором написана программа. Я обычно использую Restorator 2.50 [1024 Kb], либо Ехеsсоре'ом [409 Kb] можно посмотреть. Сразу же узнаём запакована программа или нет. 1.1 Тип языка я определяю по размеру файла и по ресурсам: Assembler - размер файла меньше 40 Kb (если не использует картинок), присутствует раздел Dialog в ресурсах. На ассемблере обычно пишут перцы, так что шанс взломать резко снижается (скорее будет патч, нежели подбор номера). Visual C++ - размер файла - разный, если меньше 40 Kb и файл импортирует функции из модуля MFC42.DLL или больше 40 + присутствуют ресурсы Dialog, тогда это С++, по моему опыту ломается лучше всего, так как структура программы более менее линейна (наглядна)+ запрашиваются WinAPI функции, на которые всегда можно поставить брейкпойнт. Delphi - определется легче всего - в ресурсах присутствует раздел "RCDATA" или "DATA" - кто как показывает, в котором обязательно есть ресурс PACKAGEINFO + почти всегда ресурс типа TFORM1 (или другой, но обязательно с буквы T). Ломаются такие программы не очень сложно, учитывая то, что множество программистов Delphi - любители (новички), однако сам код, откомпилированный в Дельфе очень не нагляден - бесконечные джампы и процедуры + не используются "наши" API функции (но зато железно работает hmemcpy) Visual Basic - что касается самого Бэсика, так я его не уважаю, потому что программы работают только при наличии VBRUNxxx.DLL или другой (в зависимости от версии) ботвы в системных папках (в PATH-папках) + код не скомпилирован по человечески (до версии 5) и можно ломать только декомпилятором. Начиная с версии 5 стал создаваться некоторый скомпилированный код (вообщем SоftIсе'ом можно поломать). Отличить VB программу от других легко - открываем в Exescope и видим, что импортируется библиотека вида VB######.dll или MSVBVM##.dll. 1.2 Запакована или нет? Самый простой способ это проверить - открыть программу в Restorator'e и посмотреть все ресурсы, если вместо ресурсов высвечивается надпись "Ресурс повреждён" - значит файл пожат, а это в свою очередь означает, что путь патча нам уже закрыт. Комментарий от 22 мая 2002 года: наконец-то до меня дошла (или я дошёл) версия компрессора UPX (1.20) [117 Kb], которая может разжимать сжатые любыми версиями UPX программы, теперь бы ещё распаковщик Аsраск'а... Комментарий от 17 августа 2002 года: Распаковшик AsPack тоже был найден, может быть скоро можно будет его здесь скачать (называется AspackDie у меня - v1.4). Также нашёлся распаковщик PECompact (моего любимого) - называется UnPECompact 1.31 (написал тот же чувак, что и AspackDie). 2. Ищем в программе куда нужно вводить код (ну, я думаю сами найдёте). 3. Вводим код в соответствующее окно и, не нажимая Enter, вызываем SoftIce и ставим брейкпойнты bpx getdlgitemtexta, bpx windowtexta - для любой программы + bpx hmemcpy - для Delphi- программы, затем нажимаем на "ОК"-кнопку и мы должны попасть в SofIce по одному из этих брейкпойнтов. 4. Что же далее: вот мы в SоftIсе'е, я обычно первый раз гоню программу по F10, смотрю и запоминаю, пока не вылезет окно сообщения о неправильном рег. номере (назовём его окно "обломис"). Вы скажете, ну и что же ты запоминаешь: а вот что - я плевать хотел на всякие Call и прочие умные вещи, я запоминаю долго ли я гоню по F10, а также все условные переходы (jz, jnz, jne, je ...). Когда вам вылезло окно "обломис", возвращаемся в SoftIce, смотрим вверх и ищем то место, где есть условный переход, который так или иначе может увести нас от вызова "обломиса", а теперь ищем процедуру, которая может изменить флаг, на который реагирует этот переход (для jz, jnz, jne, je - это флаг Z). Могу с уверенностью сказать, что если вы уже на этом месте и всё вышесказанное получается, то большая половина дела уже сделана (похоже программисты забыли поставить шлагбаум, хотя такой как я программист мог бы приколоться - поставить пустышку). 5. Теперь надо начать ковырять процедуру, да не очень усердно - вдруг пустышка. Да вот тут то я могу вам ничем не помочь все они сделаны по разному, ну признаюсь на этом этапе я обычно ставлю брейк на процедуру, выхожу и пробую ввести рег. данные заново, а потом, как тупой америкос, попав в SoftIce начинаю тупо смотреть содержимое регистров и вот что самое интересное в не более 50% случаев - помогает и я рано или поздно вижу правильный рег. номер в каком-нибудь регистре. Ну, я представляю что сейчас подумал обо мне профессионал, случайно забредший на эту страницу, что ж, лень, как известно, двигатель прогресса, а я ужасно ленивый, просто иногда даже злюсь на себя. Да, кстати, надо иметь чутьё на рег. номер - иногда они бывают вот такие: &^&$&%&ufs - и если до процедуры, на которую мы поставили брейк вы его не нашли, то поищите внутри неё.Вообще надо действовать по ситуации, потому что не один крэкер не даст вам супер оптимальной и в то же время простой инструкции по взлому, а для того, чтобы заниматься крэком, нужно немногое - настойчивость, голова на плечах (знающая немного ассемблера), а также мания величия (ну этого, я заметил, почти у всех компьютерщиков хватает, даже у меня, иначе вы это сейчас бы не читали, а я бы не писал).
Пример вычисления контрольной суммы (CRC32).
Автор: Vit WEB сайт: http://forum.vingrad.ru
function CRC32(const IniCRC:Integer;Source:AnsiString):Integer; asm Push EBX Push ESI Push EDI Or EDX,EDX Jz @Done Mov ESI,EDX Mov ECX,[EDX-4] Jecxz @Done Lea EDI,@CRCTbl Mov EDX,EAX Xor EAX,EAX Cld @L1: Lodsb Mov EBX,EDX Xor EBX,EAX And EBX,$FF Shl EBX,2 Shr EDX,8 And EDX,$FFFFFF Xor EDX,[EDI+EBX] Dec ECX Jnz @L1 Mov EAX,EDX @Done: Pop EDI Pop ESI Pop EBX Ret @CRCTbl: DD $00000000, $77073096, $ee0e612c, $990951ba DD $076dc419, $706af48f, $e963a535, $9e6495a3 DD $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988 DD $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91 DD $1db71064, $6ab020f2, $f3b97148, $84be41de DD $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7 DD $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec DD $14015c4f, $63066cd9, $fa0f3d63, $8d080df5 DD $3b6e20c8, $4c69105e, $d56041e4, $a2677172 DD $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b DD $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940 DD $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59 DD $26d930ac, $51de003a, $c8d75180, $bfd06116 DD $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f DD $2802b89e, $5f058808, $c60cd9b2, $b10be924 DD $2f6f7c87, $58684c11, $c1611dab, $b6662d3d DD $76dc4190, $01db7106, $98d220bc, $efd5102a DD $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433 DD $7807c9a2, $0f00f934, $9609a88e, $e10e9818 DD $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01 DD $6b6b51f4, $1c6c6162, $856530d8, $f262004e DD $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457 DD $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c DD $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65 DD $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2 DD $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb DD $4369e96a, $346ed9fc, $ad678846, $da60b8d0 DD $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9 DD $5005713c, $270241aa, $be0b1010, $c90c2086 DD $5768b525, $206f85b3, $b966d409, $ce61e49f DD $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4 DD $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad DD $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a DD $ead54739, $9dd277af, $04db2615, $73dc1683 DD $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8 DD $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1 DD $f00f9344, $8708a3d2, $1e01f268, $6906c2fe DD $f762575d, $806567cb, $196c3671, $6e6b06e7 DD $fed41b76, $89d32be0, $10da7a5a, $67dd4acc DD $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5 DD $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252 DD $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b DD $d80d2bda, $af0a1b4c, $36034af6, $41047a60 DD $df60efc3, $a867df55, $316e8eef, $4669be79 DD $cb61b38c, $bc66831a, $256fd2a0, $5268e236 DD $cc0c7795, $bb0b4703, $220216b9, $5505262f DD $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04 DD $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d DD $9b64c2b0, $ec63f226, $756aa39c, $026d930a DD $9c0906a9, $eb0e363f, $72076785, $05005713 DD $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38 DD $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21 DD $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e DD $81be16cd, $f6b9265b, $6fb077e1, $18b74777 DD $88085ae6, $ff0f6a70, $66063bca, $11010b5c DD $8f659eff, $f862ae69, $616bffd3, $166ccf45 DD $a00ae278, $d70dd2ee, $4e048354, $3903b3c2 DD $a7672661, $d06016f7, $4969474d, $3e6e77db DD $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0 DD $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9 DD $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6 DD $bad03605, $cdd70693, $54de5729, $23d967bf DD $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94 DD $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d end;
Расчёт контрольной суммы файла CRC-32 (Доработано).
Автор: MegaVolt WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Расчёт контрольной суммы файла CRC-32
Функция находит контрольную сумму файла FileName
(полное имя файла с путём). Если возникает ошибка
(файл не найден или его нельзя открыть для чтения)
выдаётся сообщение об этом. Если это не нужно
то удалить строки с выводом сообщения.
Зависимости: classes, Sysutils, Dialogs;
Автор: MegaVolt, MegaVoltik@yahoo.com
Copyright: :( Не помню :( Взято где то в сети
несколько доработано и после обсуждения в
Дата: 3 декабря 2002 г.
***************************************************** }
unit Crc32;
interface
uses
classes, Sysutils, Dialogs;
function FileCRC32(const FileName: string): Cardinal;
function UpdateCRC32(InitCRC: Cardinal; BufPtr: Pointer; Len: Word): LongInt;
implementation
type
CRCTable = array[0..255] of Cardinal;
const
BufLen = 32768;
CRC32Table: CRCTable =
($00000000, $77073096, $EE0E612C, $990951BA,
$076DC419, $706AF48F, $E963A535, $9E6495A3,
$0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
$09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
$1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
$1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
$14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
$3B6E20C8, $4C69105E, $D56041E4, $A2677172,
$3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
$32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
$26D930AC, $51DE003A, $C8D75180, $BFD06116,
$21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
$2802B89E, $5F058808, $C60CD9B2, $B10BE924,
$2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
$76DC4190, $01DB7106, $98D220BC, $EFD5102A,
$71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
$7807C9A2, $0F00F934, $9609A88E, $E10E9818,
$7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
$6B6B51F4, $1C6C6162, $856530D8, $F262004E,
$6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
$62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
$4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
$4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
$44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
$5005713C, $270241AA, $BE0B1010, $C90C2086,
$5768B525, $206F85B3, $B966D409, $CE61E49F,
$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
$59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
$EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
$EAD54739, $9DD277AF, $04DB2615, $73DC1683,
$E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
$E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
$F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
$F762575D, $806567CB, $196C3671, $6E6B06E7,
$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
$F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
$D6D6A3E8, $A1D1937E, $38D8C2C4, $04FDFF252,
$D1BB67F1, $A6BC5767, $3FB506DD, $048B2364B,
$D80D2BDA, $AF0A1B4C, $36034AF6, $041047A60,
$DF60EFC3, $A867DF55, $316E8EEF, $04669BE79,
$CB61B38C, $BC66831A, $256FD2A0, $5268E236,
$CC0C7795, $BB0B4703, $220216B9, $5505262F,
$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
$C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
$9B64C2B0, $EC63F226, $756AA39C, $026D930A,
$9C0906A9, $EB0E363F, $72076785, $05005713,
$95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
$92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
$81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
$88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
$8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
$A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
$A7672661, $D06016F7, $4969474D, $3E6E77DB,
$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
$A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
$BAD03605, $CDD70693, $54DE5729, $23D967BF,
$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
var
Buf: array[1..BufLen] of Byte;
function UpdateCRC32(InitCRC: Cardinal; BufPtr: Pointer; Len: Word): LongInt;
var
crc: Cardinal;
index: Integer;
i: Cardinal;
begin
crc := InitCRC;
for i := 0 to Len - 1 do
begin
index := (crc xor Cardinal(Pointer(Cardinal(BufPtr) + i)^)) and $000000FF;
crc := (crc shr 8) xor CRC32Table[index];
end;
Result := crc;
end;
function FileCRC32(const FileName: string): Cardinal;
var
InFile: TFileStream;
crc32: Cardinal;
Res: Integer;
BufPtr: Pointer;
begin
BufPtr := @Buf;
crc32 := $FFFFFFFF;
try
InFile := TFileStream.Create(FileName, fmShareDenyNone);
Res := InFile.Read(Buf, BufLen);
while (Res <> 0) do
begin
crc32 := UpdateCrc32(crc32, BufPtr, Res);
Res := InFile.Read(Buf, BufLen);
end;
InFile.Destroy;
except
on E: Exception do
begin
if Assigned(InFile) then
InFile.Free;
ShowMessage(Format('При обработке файла [%s] вышла ' +
'вот такая ошибочка [%s]', [FileName, E.Message]));
end;
end;
Result := not crc32;
end;
end.
Пример использования:
var
i: cardinal;
begin
i := FileCRC32('c:\autoexec.bat');
ShowMessage('Контрольная сумма файла = ' IntToStr(i));
CreateProcess, который возвращает консольный вывод.
| - Можно ли научить слона работать в Windows? - Нет, он ведь боится мышей. |
procedure ExecConsoleApp(CommandLine: AnsiString; Output: TStringList; Errors:
TStringList);
var
sa: TSECURITYATTRIBUTES;
si: TSTARTUPINFO;
pi: TPROCESSINFORMATION;
hPipeOutputRead: THANDLE;
hPipeOutputWrite: THANDLE;
hPipeErrorsRead: THANDLE;
hPipeErrorsWrite: THANDLE;
Res, bTest: Boolean;
env: array[0..100] of Char;
szBuffer: array[0..256] of Char;
dwNumberOfBytesRead: DWORD;
Stream: TMemoryStream;
begin
sa.nLength := sizeof(sa);
sa.bInheritHandle := true;
sa.lpSecurityDescriptor := nil;
CreatePipe(hPipeOutputRead, hPipeOutputWrite, @sa, 0);
CreatePipe(hPipeErrorsRead, hPipeErrorsWrite, @sa, 0);
ZeroMemory(@env, SizeOf(env));
ZeroMemory(@si, SizeOf(si));
ZeroMemory(@pi, SizeOf(pi));
si.cb := SizeOf(si);
si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
si.wShowWindow := SW_HIDE;
si.hStdInput := 0;
si.hStdOutput := hPipeOutputWrite;
si.hStdError := hPipeErrorsWrite;
(* Remember that if you want to execute an app with no parameters you nil the
second parameter and use the first, you can also leave it as is with no
problems. *)
Res := CreateProcess(nil, pchar(CommandLine), nil, nil, true,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, @env, nil, si, pi);
// Procedure will exit if CreateProcess fail
if not Res then
begin
CloseHandle(hPipeOutputRead);
CloseHandle(hPipeOutputWrite);
CloseHandle(hPipeErrorsRead);
CloseHandle(hPipeErrorsWrite);
Exit;
end;
CloseHandle(hPipeOutputWrite);
CloseHandle(hPipeErrorsWrite);
//Read output pipe
Stream := TMemoryStream.Create;
try
while true do
begin
bTest := ReadFile(hPipeOutputRead, szBuffer, 256, dwNumberOfBytesRead,
nil);
if not bTest then
begin
break;
end;
Stream.Write(szBuffer, dwNumberOfBytesRead);
end;
Stream.Position := 0;
Output.LoadFromStream(Stream);
finally
Stream.Free;
end;
//Read error pipe
Stream := TMemoryStream.Create;
try
while true do
begin
bTest := ReadFile(hPipeErrorsRead, szBuffer, 256, dwNumberOfBytesRead,
nil);
if not bTest then
begin
break;
end;
Stream.Write(szBuffer, dwNumberOfBytesRead);
end;
Stream.Position := 0;
Errors.LoadFromStream(Stream);
finally
Stream.Free;
end;
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
CloseHandle(hPipeOutputRead);
CloseHandle(hPipeErrorsRead);
end;
(* got it from yahoo groups, so no copyrights for this piece :p and and example
of how to use it. put a button and a memo to a form. *)
procedure TForm1.Button1Click(Sender: TObject);
var
OutP: TStringList;
ErrorP: TStringList;
begin
OutP := TStringList.Create;
ErrorP := TstringList.Create;
ExecConsoleApp('ping localhost', OutP, ErrorP);
Memo1.Lines.Assign(OutP);
OutP.Free;
ErrorP.Free;
end;
|
Как использовать CreateWindow(Ex).
| Автор: lel |
| Для перехода к следующей ошибке нажмите кнопку ДАЛЕЕ. |
program winmin; uses windows, messages; var wc : TWndClassEx; MainWnd : HW Mesg : TMsg; function WindowProc(wnd:HWND; Msg : Integer; Wparam:Wparam; Lparam:Lparam):Lresult; stdcall; Begin case msg of wm_destroy : Begin postquitmessage(0); exit; Result:=0; End; else Result:=DefWindowProc(wnd,msg,wparam,lparam); end; End; var xPos,yPos,nWidth,nHeight : Integer; begin wc.cbSize:=sizeof(wc); wc.style:=cs_hredraw or cs_vredraw; wc.lpfnWndProc:=@WindowProc; wc.cbClsExtra:=0; wc.cbWndExtra:=0; wc.hInstance:=HInstance; wc.hIcon:=LoadIcon(0,idi_application); wc.hCursor:=LoadCursor(0,idc_arrow); wc.hbrBackground:=COLOR_BTNFACE+1; wc.lpszMenuName:=nil; wc.lpszClassName:='WinMin : Main'; RegisterClassEx(wc); xPos:=100; yPos:=150; nWidth:=400; nHeight:=250; MainWnd:=CreateWindowEx( 0, 'WinMin : Main', 'Win Min', ws_overlappedwindow, xPos, yPos, nWidth, nHeight, 0, 0, Hinstance, nil ); ShowWindow(Mai! nWnd,CmdShow); While GetMessage(Mesg,0,0,0) do begin TranslateMessage(Mesg); DispatchMessage(Mesg); end; end. |
Программное создание базы данных Access (DAO DBEngine).
Автор: Savva WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Программное создание базы данных Access (DAO DBEngine)
Функция создания файла базы данных Access.
PS. кто будет использовать - в комментариях отметьте версии ОС, Access,Delphi.
Зависимости: ComObj, Dialogs,
Автор: savva, savva@nm.ru, ICQ:126578975, Орел
Copyright: Сапронов Алексей (Savva)
Дата: 11 октября 2002 г.
***************************************************** }
function CreateDatabase(DatabaseName: string): boolean;
var
DBEngine, Workspace: Variant;
const
dbLangGeneral = ';LANGID=0x0409;CP=1252;COUNTRY=0';
dbVersion30 = 32;
begin
result := false;
try
try
DBEngine := CreateOleObject('DAO.DBEngine.36');
except
try {For DAO 3.5}
DBEngine := CreateOleObject('DAO.DBEngine.35');
except
raise;
end;
end;
Workspace := DBEngine.Workspaces[0];
try
Workspace.CreateDatabase(DatabaseName, dbLangGeneral, dbVersion30);
except on e0: EOleException do
ShowMessage(e0.Message);
end;
except on e1: EOleException do
ShowMessage(e1.Message);
end;
result := true;
end;
Пример использования:
... CreateDatabase(db_name); ...
Создание ODBC драйвера для MSAccess.
Автор: Konstantin Einstein WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание ODBC драйвера для MSAccess
Функция создает ODBC драйвер для MSAccess.
В функцию передается имя файла и имя для драйвера.
В конкретной редакции драйвер создается в разделе "System DSN".
Зависимости: Windows, SysUtils, Dialogs, Variants;
Автор: Konstantin Einstein
Copyright: Konstantin Einstein
Дата: 9 декабря 2002 г.
***************************************************** }
unit CreateODBCforMDB;
interface
uses
Windows, SysUtils, Dialogs, Variants;
const
ODBC_ADD_DSN = 1; (* Add data source *)
ODBC_CONFIG_DSN = 2; (* Configure (edit) data source *)
ODBC_REMOVE_DSN = 3; (* Remove data source *)
ODBC_ADD_SYS_DSN = 4; (* add a system DSN *)
ODBC_CONFIG_SYS_DSN = 5; (* Configure a system DSN *)
ODBC_REMOVE_SYS_DSN = 6; (* remove a system DSN *)
type
TSQLConfigDataSource = function(hwndParent: HWND;
fRequest: WORD;
lpszDriver: LPCSTR;
lpszAttributes: LPCSTR): BOOL; stdcall;
function CreateODBCDriver(fail_name, driver_name: string): Boolean;
implementation
function CreateODBCDriver(fail_name, driver_name: string): Boolean;
var
pFn: TSQLConfigDataSource;
hLib: LongWord;
strDriver, strAttr: string;
fResult: BOOL;
srInfo: TSearchRec;
begin
Result := True;
hLib := LoadLibrary('ODBCCP32'); //load from default path
if (hLib <> NULL) then
begin
@pFn := GetProcAddress(hLib, 'SQLConfigDataSource');
if (@pFn <> nil) then
begin (* force (re-)create DSN *)
strDriver := 'Microsoft Access Driver (*.mdb)';
strAttr := Format('DSN=' + driver_name + #0 +
'DBQ=%s' + #0 +
'Exclusive=0' + #0 +
'Description=' + driver_name + ' DSN' + #0 + #0,
[fail_name]);
fResult := pFn(0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1]);
if (fResult = false) then
begin
ShowMessage('Create DSN (Datasource) failed!');
Result := False;
Exit;
end;
// test/create MDB file associated with DSN
if (FindFirst(fail_name, 0, srInfo) <> 0) then
begin
strDriver := 'Microsoft Access Driver (*.mdb)';
strAttr := Format('DSN=' + driver_name + #0 +
'DBQ=%s' + #0 +
'Exclusive=0' + #0 +
'Description=' + driver_name + ' DSN' + #0 +
'CREATE_DB="%s"'#0 + #0,
[fail_name, fail_name]);
fResult := pFn(0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1]);
if (fResult = false) then
begin
ShowMessage('Create MDB (Database file) failed!');
Result := False;
end;
end;
FindClose(srInfo);
end;
FreeLibrary(hLib);
end
else
begin
ShowMessage('Unable to load ODBCCP32.DLL');
Result := False;
end;
Result := fResult;
end;
end.
Программное создание таблиц и ключей (первичных и вторичных) для БД Access.
Автор: Дима WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Программное создание таблиц/ключей(первичных и вторичных) для бд Access
В принципе данный пример описан на сайте http://www.olap.ru/desc/microsoft/borland_ado.asp ,за
исключением создания ключей. Там же можно прочитать , о том как включить ссылку на библиотеку
типов ADOX(Для этого следует выбрать Project | Import Type Library главного меню среды
разработки Delphi, а затем из списка доступных библиотек типов выбрать Microsoft ADO Ext.
2.5 for DDL and Security. Чтобы избежать конфликтов с именами уже имеющихся классов Delphi
(например, TTable), следует переименовать классы ADOX, заменив имена на что-нибудь типа TADOXxxx.
Затем нужно убрать отметку из опции Generate Component Wrapper — в данном случае нам нужен
только файл *.pas, содержащий интерфейс для доступа к объектам ADOX, а затем нажать кнопку
Create Unit. Это приведет к созданию файла ADOX_TLB.PAS, содержащего интерфейс к библиотеке
типов ADOX. Создав этот файл, мы должны сослаться на него, а также на модуль ADODB в
предложении Uses главного модуля нашего проекта).
Создаются 2 таблицы (Otdel,Departament).Поле NumDepartament в таблице Otdel является
внешним ключем к полю NumDepartament в таблице NumDepartament. Поля NumDepartament и
NumOtdel в таблицах Departament и Otdel сответственно являются первичными ключами.
Зависимости: Библиотека типов ADOX
Автор: Дима
Copyright: http://www.olap.ru/desc/microsoft/borland_ado.asp + msdn
Дата: 30 июля 2003 г.
***************************************************** }
var
Catalog: _Catalog;
Table: _Table;
Column: _Column;
FKKey: _Key;
begin
Catalog := CoCatalog.Create;
try
Catalog.Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0;' +
'Data Source=' + DatabaseName + ';Persist Security Info=False');
//DatabaseName - Путь к файлу с базой данных (C:\1\12.mdb)
//=============================================DOLGNOST=========================
Table := CoTable.Create;
try
Table.Name := 'Dolgnost';
Table.ParentCatalog := Catalog;
Column := CoColumn.Create;
try
with Column do
begin
ParentCatalog := Catalog;
Name := 'NumDolgnost';
Type_ := adInteger;
end;
Table.Columns.Append(Column, 0, 0);
finally
Column := nil;
end;
with Table.Columns do
begin
Append('NameDolgnost', adVarWChar, 50);
end;
Catalog.Tables.Append(Table);
finally
Table := nil;
end;
//=============================================DEPARTAMENT======================
Table := CoTable.Create;
try
Table.Name := 'Departament';
Table.ParentCatalog := Catalog;
Column := CoColumn.Create;
try
with Column do
begin
ParentCatalog := Catalog;
Name := 'NumDepartament';
Type_ := adInteger;
end;
Table.Columns.Append(Column, 0, 0);
finally
Column := nil;
end;
with Table.Columns do
begin
Append('NameDepartament', adVarWChar, 50);
end;
Catalog.Tables.Append(Table);
finally
Table := nil;
end;
//==============================Создание первичных ключей=======================
//Otdel
FKKey := CoKey.Create;
try
with FKKey do
begin
Name := 'PKNumOtdel';
Type_ := adKeyPrimary;
Columns.Append('NumOtdel', adInteger, 0);
end;
Catalog.Tables['Otdel'].Keys.Append(FKKey, 0, EmptyParam, '', '');
finally
FKKey := nil;
end;
//Departament
FKKey := CoKey.Create;
try
with FKKey do
begin
Name := 'PKNumDepartament';
Type_ := adKeyPrimary;
Columns.Append('NumDepartament', adInteger, 0);
end;
Catalog.Tables['Departament'].Keys.Append(FKKey, 0, EmptyParam, '', '');
finally
FKKey := nil;
end;
//==============================Создание вторичных ключей=======================
//Otdel
FKKey := CoKey.Create;
try
with FKKey do
begin
Name := 'FKNumOtdel';
Type_ := adKeyForeign;
Columns.Append('NumDepartament', adInteger, 0);
RelatedTable := 'Departament';
Columns['NumDepartament'].RelatedColumn := 'NumDepartament';
UpdateRule := adRICascade;
end;
Catalog.Tables['Otdel'].Keys.Append(FKKey, 0, EmptyParam, '', '');
finally
FKKey := nil;
end;
finally
Catalog = nil;
end;
Как программно создать Alias.
procedure TForm1.Button3Click(Sender: TObject);
var
MyList: TStringList;
begin
MyList := TStringList.Create;
try
with MyList do
begin
Add('SERVER NAME=IB_SERVER:/PATH/DATABASE.GDB');
Add('USER NAME=MYNAME');
end;
Session1.AddAlias('NewIBAlias', 'INTRBASE', MyList);
finally
MyList.Free;
end;
end;
|
Как программно создать Alias 2.
procedure CreateAlias();
const
DlPs = 5;
var
wrstr, wrstr1 :string;
AParams: TStringList;
Psevdonm: array [1..DlPs] of string;
i: integer;
begin
//Заполним массив
Psevdonm[1] := 'TERMNNSI,NSI'; // имя,каталог
Psevdonm[2] := 'TERMNBASE,BASE';
Psevdonm[3] := 'TERMNTNL,BASE\TNL';
Psevdonm[4] := 'TERMNARH,ARH';
Psevdonm[5] := 'TERMNTELE,TELE';
// if not DirectoryExists(datapath) then begin
// createdir(datapath) ;
// end;
for i := 1 to DlPs do
begin
// Для начала проверим каталоги
wrstr1 := Copy(Psevdonm[i],Pos(',',Psevdonm[i])+1, Length(Psevdonm[i])-Pos(',',Psevdonm[i])+1);
if not DirectoryExists(wrstr1) then
begin
CreateDirectory(PChar(CurrntDir+'\'+wrstr1),nil);
end;
// Если нет псевдонима, то создадим или подправим
wrstr := Copy(Psevdonm[i],1,Pos(',',Psevdonm[i])-1);
if not Session.IsAlias(wrstr) then
begin
try
Session.AddStandardAlias(wrstr,wrstr1,'PARADOX');
Session.SaveConfigFile;
except
SaveTekJrn('ERR:Ошибка создания алиаса - '+wrstr);
Exit;
end;
end;
//Настроим алиас
AParams := TStringList.Create;
AParams.Add('PATH=' + CurrntDir+'\'+wrstr1);
Session.ModifyAlias(wrstr,AParams);
Session.SaveConfigFile;
// Освобождение списка
AParams.Free;
end;
end;
|
Создание алиасов.
procedure CheckAlias(const AliasName, AliasType, AliasPath: String);
{ Если алиас не существует, создать его }
var
SList: TStrings;
i: Integer;
AliasFound: Boolean;
begin
{ Проверка существования алиса BDE }
try
SList := TStringList.Create;
Session.GetAliasNames(SList);
AliasFound := False;
for i:=0 to SList.Count-1 do
if SList[i]=AliasName then
begin
AliasFound := True;
break;
end;
finally
SList.Free;
end;
if AliasFound then
begin
try
SList := TStringList.Create;
Session.GetAliasParams(AliasName,SList);
{А в 4-ой версии SList[2]!!! и без слова Path }
if SList[0]< > 'PATH='+AliasPath then { Правильно ли задан путь }
begin
SList[0] := 'PATH='+AliasPath;
Session.ModifyAlias(AliasName,SList);
end;
finally
SList.Free;
end;
end
else
Session.AddStandardAlias(AliasName,AliasPath,AliasType); { Создать новый алиас }
Session.SaveConfigFile;
end;
|
Создание псевдонима базы данных с указанием пути к каталогу с базой.
Автор: Александр WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание псевдонима базы данных с указанием пути к каталогу с базой
Данная процедура создает нужный псевдоним (Alias), если он не существует, для
базы данных, прописывает путь к базе данных. Если такой псевдоним существует,
то проверяется его соответствие заданным параметрам.
Зависимости: DBTables
Автор: Александр, rda@im.net.ua, Мелитополь
Copyright: Help Delphi
Дата: 28 апреля 2002 г.
***************************************************** }
procedure Create_Alias;
var
AParams: TStringList;
Dir: string;
begin
Dir := ExtractFilePath(ParamStr(0)) + 'BASE'; //Путь к базе. В данном случае
//это \Каталог программы\ВАSЕ
AParams := TStringList.Create;
if not Session.IsAlias('cssm') then //Проверка существования псевдонима
//cssm
begin
Session.AddStandardAlias('cssm', Dir, 'PARADOX');
end
else
try
begin
AParams.Clear;
AParams.Add('PATH=' + Dir);
Session.ModifyAlias('cssm', AParams);
Session.SaveConfigFile;
end;
finally
AParams.Free;
end;
end;
Как создать все поддиректории за один проход.
Пример использует информационное поле (label) и кнопку на форме. Когда пользователь кликает по кнопке, то все поддиректории, содержащиеся в пути создаются (если они ещё не созданы). Результат записывается в текстовое поле:
uses FileCtrl;
procedure TForm1.Button1Click(Sender: TObject);
var
Dir: string;
begin
Dir := 'C:\APPS\SALES\LOCAL';
ForceDirectories(Dir);
if DirectoryExists(Dir) then
Label1.Caption := Dir + ' was created'
end;
|
Создание и удаление полей во время выполнения программы.
TField-компоненты (или, точнее, потомки компонента TField с соответствующим типом поля) могут создаваться во время проектирования программы с помощью Fields Editor (редактора полей). Fields Editor вызывается двойным щелчком на иконке компонента TTable или TQuery. Но потомки TField могут быть созданы и удалены и в режиме выполнения программы. Потомки компонента TField (такие как, например, TStringField, TIntegerField и др.) создаются методом Create для того типа потомка TField, который подходит к соответствующему полю набора данных. Другими словами, для поля строкового типа текущего набора данных необходимо вызвать метод Create класса TStringField, являющегося потомком TField. Методу Create необходим один параметр - владелец потомка TField, расположенный на TForm. После создания компонента наследника TField для того, чтобы новый экземпляр объекта мог установить связь с необходимым полем набора данных, необходимо установить несколько ключевых свойств. Вот их список: FieldName: имя поля в таблице Name: уникальный идентификатор компонента-потомка TField. Index: позиция компонента-потомка TField в массиве TFields (свойство Fields компонента TTable или TQuery, с которым будет связан TField). DataSet: компонент TTable или TQuery, с которым будет связан TField.Приведенный ниже код демонстрирует способ создания TStringField. TForm названа Form1 (здесь ссылка на переменную Self), активный набор данных TQuery имеет имя Query1 и поле, для которого создается компонент TStringField, расположено в таблице dBASE с именем CO_NAME. Новый потомок TField будет вторым TField в свойстве-массиве Fields компонента Query1. Имейте в виду, что набор данных, связанный с новым потомком TField (в нашем случае Query1), перед добавлением TField должен быть закрыт, а после добавления вновь открыт.
procedure TForm1.Button2Click(Sender: TOObject); var T: TStringField; begin Query1.Close; T := TStringField.Create(Self); T.FieldName := 'CO_NAME'; T.Name := Query1.Name + T.FieldName; T.Index := Query1.FieldCount; T.DataSet := Query1; Query1.FieldDefs.UpDate; Query1.Open; end; |
Для удаления существующего потомка TField достаточно вызова метода Free данного компонента. В примере, приведенном ниже, метод TForm FindComponent используется для получения указателя на компонент TStringField с именем Query1CO_NAME. Возвращаемая функцией FindComponent величина в случае успешного завершения будет иметь тип TComponent или nil в противном случае. Возвращаемое значение может использоваться для того, чтобы определить, действительно ли существует компонент до того, как будет применен метод Free.
procedure TForm1.Button1Click(Sender: TObject);
var
TC: TComponent;
begin
TC := FindComponent('Query1CO_NAME');
if not (TC = nil) then
begin
Query1.Close;
TC.Free;
Query1.Open;
end;
end;
|
Как и при создании TField, набор данных, связанный с потомком TField и активный в настоящий момент, перед вызовом данного метода должен быть закрыт и впоследствии вновь активирован.
Создание и использование интерфейса.
Интерфейсы играют главную роль в технологиях СОМ (Component Object Model - компонентная модель объектов), CORBA (Common Object Request Broker Architecture - архитектура с брокером требуемых общих объектов) и связанных с ними технологиях удаленного доступа, т. е. технологиях доступа к объектам, расположенным (и выполняющимся) на другой машине. Их основная задача - описать свойства, методы и события удаленного объекта в терминах машины клиента, т. е. на используемом при разработке клиентского приложения языке программирования. С помощью интерфейсов программа клиента обращается к удаленному объекту так, как если бы он был ее собственным объектом. Тема интерфейсов достаточно обширна и интересна. В этой главе даются лишь самые общие сведения об интерфейсах. Сведение этой темы в одну главу с классами не случайно, т. к. интерфейс представляет собой пустой класс, т. е. класс, в котором провозглашены, но никак не расшифрованы свойства и методы.Интерфейсы представляют собой частный случай описания типов. Они объявляются с помощью зарезервированного слова interface. Например:
type
IEdit = interface
procedure Copy; stdcall;
procedure Cut; stdcall;
procedure Paste; stdcall;
function Undo: Boolean; stdcall;
end;
Такое объявление эквивалентно описанию абстрактного класса в том смысле, что провозглашение интерфейса не требует расшифровки объявленных в нем свойств и методов.
В отличие от классов интерфейс не может содержать поля, и, следовательно, объявляемые в нем свойства в разделах read и write могут ссылаться только на методы. Все объявляемые в интерфейсе члены размещаются в единственной секции public. Методы не могут быть абстрактными (abstract), виртуальными (virtual), динамическими (dynamic) или перекрываемыми (override). Интерфейсы не могут иметь конструкторов или деструкторов, т. к. описываемые в них методы реализуются только в рамках поддерживающих их классов, которые называются интерфейсными.
Если какой-либо класс поддерживает интерфейс (т. е. является интерфейсным), имя этого интерфейса указывается при объявлении класса в списке его родителей:
TEditor = class(TInterfacedObject, IEdit) procedure Copy; stdcall; procedure Cut; stdcall; procedure Paste; stdcall; function Undo: Boolean; stdcall; end;
В отличие от обычного класса интерфейсный класс может иметь более одного родительского интерфейса:
type
IMylnterface = interface procedure Delete; stdcall;
end;
TMyEditor = class(TInterfacedObiect, lEdit, IMylnterface)
procedure Copy; stdcall;
procedure Cut; stdcall;
procedure Paste; stdcall;
function Undo: , Boolean; stdcall;
procedure Delete; stdcall;
end;
В любом случае в разделе реализации интерфейсного класса необходимо описать соответствующие интерфейсные методы. Если, например, объявлен интерфейс.
IPaint = interface procedure CirclePaint(Canva: TCanvas; X, Y, R: Integer); procedure RectPaint(Canva: TCanvas; X1, Y1, X2, Y2: Integer); end;
И использующий его интерфейсный класс.
TPainter = class(TInterfacedObject, IPaint) procedure CirclePaint(Canva: TCanvas; X, Y, R: Integers); procedure RectPaint(Canva: TCanvas; X1, Y1, X2, Y2: Integer); end;
То в разделе implementation следует указать реализацию методов:
procedure TPainter.CirclePaint(Canva: TCanvas; X, Y, R: Integers;
begin
with Canva do
Ellipse(X, Y, X + 2 * R, Y + 2 * R);
end;
procedure TPainter.RectPaint(Canva: TCanvas; X1, Y1, X2, Y2: Integer);
begin
with Canva do
Rectangle(XI, Yl, X2, Y2)
end;
Теперь можно объявить интерфейсный, объект класса TPainter, чтобы с его помощью нарисовать окружность и квадрат:
procedure TForm1.PaintBoxIPaint(Sender: TObject); var Painter: IPaint; begin Painter := TPainter.Create; Painter.CirclePaint(PaintBoxl.Canvas, 10, 0, 10); Painter.RectPaint(PaintBoxl.Canvas, 40, 0, 60, 20); end;
Несмотря на то что интерфейс всегда объявляется до объявления использующего его интерфейсного класса и, следовательно, известен компилятору, его методы обязательно должны быть перечислены в объявлении класса. В нашем случае простое указание.
type TPainter = class(TInterfacedObject, IPaint) end;было бы ошибкой: компилятор потребовал бы вставить описание методов CirclePaint и RectPaint.
Подобно тому как все классы в Object Pascal порождены от единственного родителя TObject, все интерфейсные классы порождены от общего предка TInterfacedObject. Этот предок умеет распределять память для интерфейсных объектов и использует глобальный интерфейс lunknow:
type
TInterfacedObject = class(TObject, lUnknown)private
FRefCount: Integer;
protected
function Querylnterface(
const IID: TGUID; out Obj): Integer; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public
property RefCount: Integer read FRefCount;
end;
Если бы в предыдущем примере класс TPainter был описан так:
TPainter = class(IPaint) procedure CirclePaint(Canva: TCanvas; X, Y, R: Integer); procedure RectPaint(Canva: TCanvas; X1, Y1, X2, Y2: Integer); end;компилятор потребовал бы описать недостающие методы Queryinterface, _Add И _Release класса TInterfacedObject. Поле FRef Count этого класса служит счетчиком вызовов интерфейсного объекта и используется по принятой в Windows схеме: при каждом обращении к методу Add интерфейса IUnknow счетчик наращивается на единицу, при каждом обращении к Release - на единицу сбрасывается. Когда значение этого поля становится равно 0, интерфейсный объект уничтожается и освобождается занимаемая им память. Если интерфейс предполагается использовать в технологиях COM/DCOM или CORBA, его методы должны описывать с директивой stdcall или (для объектов Автоматизации) safecall
К интерфейсному объекту можно применить оператор приведения типов as, чтобы использовать нужный интерфейс:
procedure PaintObjects(P: TInterfacedObject)
var
X: IPaint;
begin
try
X := P as IPaint;
X.CirclePaint(PaintBoxl.Canvas, 0, 0, 20)
except
ShowMessage('Объект не поддерживает интерфейс IPaint')
end
end;
Встретив такое присваивание, компилятор создаст код, с помощью которого вызывается метод Queryinterface интерфейса IUnknow с требованием вернуть ссылку на интерфейс IPaint. Если объект не поддерживает указанный интерфейс, возникает исключительная ситуация.
Интерфейсы, рассчитанные на использование в удаленных объектах, должны снабжаться глобально-уникальным идентификатором (guiD). Например:
IPaint = interface
['{A4AFEB60-7705-11D2-8B41-444553540000}']
procedure CirclePaint(Canva: TCanvas; X, Y, R: Integer);
procedure RectPaint(Canva: TCanvas; Xl, Yl, X2, Y2: Integer);
end;
Глобально-уникальные идентификаторы создаются по специальной технологии, гарантирующей ничтожно малую вероятность того, что два guid совпадут. Эта технология включена в Windows 32: чтобы получить guid для вновь созданного интерфейса в среде Delphi, достаточно нажать клавиши Ctrl+Shift+G. Для работы с guid в модуле System объявлены следующие типы:
type
PGUID = ^TGUID;
TGUID = record Dl: LongWord;
D2: Word;
D3: Word;
D4: array[0..7] of Byte;
end;
Программист может объявлять типизированные константы типа tguid, например:
const IID_IPaint: TGUID= ['{A4AFEB61-7705-11D2-8B41-444553540000}'] ;
Константы guid могут использоваться вместо имен интерфейсов при вызове подпрограмм. Например, два следующих обращения идентичны:
procedure Paint(const IID: TGUID); Paint(IPaint) ; Paint(IID_Paint);
С помощью зарезервированного слова implements программист может делегировать какому-либо свойству некоторого класса полномочия интерфейса. Это свойство должно иметь тип интерфейса или класса. Если свойство имеет тип интерфейса, имя этого интерфейса должно указываться в списке родителей класса, как если бы это был интерфейсный класс:
type
IMylnterface = interface procedure P1; procedure P2;
end;
TMyClass = class(TObject, IMylnterface)
FMyInterface: IMylnterface;
property Mylnterface: IMylnterface
read FMyInterface implements IMylnterface;
end;
Обратите внимание: в этом примере класс TMyciass не является интерфейсным, т. е. классом, в котором исполняются методы p1 и P2. Однако если из него убрать определение уполномоченного свойства Mylnterface, он станет интерфейсным, и в нем должны быть описаны методы интерфейса IMylnterface.
Уполномоченное свойство обязательно должно иметь часть read. Если оно имеет тип класса, класс, в котором оно объявлено, не может иметь других уполномоченных свойств.
Создание объектов любого типа.
CLASSES.PAS определяет функцию с именем FindClass, возвращающую классовую ссылку на этот класс (такую же, как и при регистрации класса). Вот пример, который динамически создает компоненты на основе имени класса, введенного в поле редактирования. Не забывайте при этом вызвать RegisterClasses и перечислять все возможные классы, которые вы имеете намерение создать.
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Grids, DBGrids, ExtCtrls, DBCtrls, DB, DBTables;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
public
NextTop: integer;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
NewObj: TControl;
NewClass: TPersistentClass;
begin
NewClass := FindClass(Edit1.Text);
NewObj :=
TControl(TComponentClass(NewClass).Create(Self));
NewObj.Parent := Self;
NewObj.Name := NewObj.ClassName + IntToStr(NextTop);
NewObj.Top := NextTop;
NextTop := NextTop + 20;
end;
initialization
RegisterClasses([TButton, TEdit, TLabel]);
end.
|
Создание Active Server Page (ASP) приложений в Delphi.
| Долгое время существовала гипотеза, что если миллион обезьян посадить за пишущие машинки, то по теории вероятности через некоторое время они напечатают "Войну и мир". Теперь, с развитием Интернета, мы знаем, что это не так... |
Новый продукт Boorland - 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>
<CENTER>
<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', то клиент, получивший данный документ, увидит отклик 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 документ. Для этого в редакторе библиотеки типов отметим интерфейс ITest и вызовем команду New Method нажатием кнопки 1:
Назовем вновь созданный метод ScriptContent набив этот текст в названии метода с мигающей кареткой. Данный метод не должен иметь параметров. Далее вызовем команду Refresh нажатием кнопки 2. После этого в модуле реализации (U1_01.pas) появится заготовка, где следует описать реализацию. Метод реализуем следующим образом:
procedure TTest.ScriptContent;
begin
if Assigned(Response) then
Response.write('First call to ASP server');
end;
|
В данном примере происходит обращение к методу Write интерфейса IResponse. Проверка Assigned(Response) гарантирует, что в момент записи сообщений имеется ссылка на интерфейс.
После этого следует модифицировать созданный Delphi HTML документ для тестирования сервера, который хранится в файле Test.asp. В этом документе имеется VB скрипт следующего содержания:
<% Set DelphiASPObj = Server.CreateObject("ASP01.Test")
DelphiASPObj.{Insert Method name here}
%>
|
Скрипт в данном виде работать не будет. Необходимо заменить фразу в фигурных скобках {Insert Method name here} на имя метода ASP сервера, который генерирует отклик. В данном примере это имя ScriptContent. Финальные исправления выглядят следующим образом:
<% Set DelphiASPObj = Server.CreateObject("ASP01.Test")
DelphiASPObj.ScriptContent
%>
|
Проект необходимо скомпилировать и далее можно приступить к его тестированию. Для этого необходимо создать виртуальную директорию на IIS, причем эта директория обязана иметь разрешение как на Read (из нее будут читаться данные), так и на Execute (из нее будет загружена и запущена ASP01.dll). Альтернатива - разместить эти файлы в разных директориях, одна из которых имеет доступ Read, а вторая - Execute. Но в любом случае выбранные директории должны экспонироваться через HTTP протокол. Поэтому в первую очередь необходимо обратиться к WWW сервису IIS, посмотретьсписок доступных директорий и при необходимости создать новые с соответствующими правами доступа. В данном конкретном примере на компьютере, который имеет IP адрес 10.10.10.65 была создана виртуальная директория /Test, которая соответствует физическому адресу на компьютере C:\ASPTest. Директория имеет доступ на Read и Execute и туда были скопированы оба файла. Далее в Microsoft Internet Explorer следует набрать команду в поле Address: HTTP://10.10.10.65/Test/Test.asp. Видно, что скрипт ( текст между ) был замещен результатом выполнения метода ScriptContent в ASP сервере.
Рассмотрим теперь подробнее, каким образом выполняется скрипт в странице Test.asp. IIS, который получает запрос на Test.asp он считывает ее содержимое из хранилища, находит скрипт и выполняет ее. При этом в фоне запускается VB и вызывается команда CreateObject. Если ASP01.dll ранее не была загружена, то происходит ее загрузка. Для данного запроса создается COM обьект - экземпляр класса TTest (он описан в модуля реализации, для данного примера - U1_01.pas). Ссылка на интерфейс IDispatch (он поддерживается в классе TTest) сохраняется в переменной DelphiASPObj. В дальнейшем написании кода после имени переменной, хранящей ссылку на IDispatch, можно набирать любой текст. Компилятор VB использует текст, который содержится в скрипте и следует после имени переменной (в данном примере: переменная - DelphiASPObj, метод - .ScriptContent) для того, чтобы передать его ASP серверу. Если ASP сервер найдет метод с данным именем, то он его выполнит. При отсутствии метода с таким именем генерируется исключение. Поэтому при написании скриптов для ASP сервера следует быть внимательным в названиях методов и при наличии исключений в первую очередь проверить корректность имен методов. При вызове какого-либо метода ASP серверу становятся доступные интерфейсы IRequest и IResponse.
Теперь рассмотрим пример создания более сложного ASP сервера, где анализируется запрос клиента при помощи методов интерфейса IRequest. Задачу поставим следующим образом: дадим возможность клиенту найти по фрагменту имени поля ENAME таблицы EMP в базе данных ORCL (генерирует Oracle при установке) . Для этого в каком-либо редакторе форм создадим форму, содержащую однострочный редактор текста и кнопку Submit. HTML документ этой формы выглядит следующим образом:
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1257">
<meta name="GENERATOR" content="Microsoft FrontPage Express 2.0">
<title>Untitled Normal Page</title>
</head>
<body bgcolor="#FFFFFF">
<form action="http://10.10.10.65/Test/Test.asp" method="POST" name="Query">
<p>Name (fragment)<input type="text" size="20" name="T1"></p>
<p><input type="submit" name="B1" value="Submit"></p>
</form>
</body>
</html>
|
При реализации этой формы вместо IP адреса 10.10.10.65 следует указать IP адрес компьютера, на котором установлен ASP сервер. Поместим этот документ в директорию C:\ASPTest, которая имеет доступ на Read и Execute (см. выше) под именем Name.htm. Но перед тем, как создавать модуль данных и обращаться к серверу базы данных необходимо выяснить, каким образом анализируется запрос клиента в ASP сервере.
Запрос клиента можно анализировать при помощи вызова методов интерфейса IRequest, ссылка на который находится в свойстве Request класса TASPObject - предка класса, где реализуется ASP сервер. Интерфейс IRequest предоставляет три свойства - QueryString, Form и Body в которых находятся ссылки на интерфейс IRequestDictionary. QueryString содержит параметры запроса, Form содержит список контролей, предоставляемых клиенту, а Body содержит данные, которые клиент ввел на контроли. Нам потребуются данные, поэтомк ниже будет анализироваться свойство Body, но все сказанное ниже о методах IRequestDisctionary применимо и к любому другому свойству типа ICustomDictionary - QueryString, Form.
IRequestDictionary определен в модуле ASPTlb.pas следующим образом:
IRequestDictionary = interface(IDispatch)
['{D97A6DA0-A85F-11DF-83AE-00A0C90C2BD8}']
function Get_Item(Var_: OleVariant): OleVariant; safecall;
function Get__NewEnum: IUnknown; safecall;
function Get_Count: SYSINT; safecall;
function Get_Key(VarKey: OleVariant): OleVariant; safecall;
property Item[Var_: OleVariant]: OleVariant read Get_Item; default;
property _NewEnum: IUnknown read Get__NewEnum;
property Count: SYSINT read Get_Count;
property Key[VarKey: OleVariant]: OleVariant read Get_Key;
end;
|
Документация о свойствах этого интерфейса отсутствует и остается только догадываться, каким образом из него можно извлечь параметры запроса введенные пользователем. Привлекая документацию по компоненту TWebDispatcher, который используется при создании CGI приложений и ISAPI DLL, где также можно анализировать параметры запроса пользователя, можно догадаться что свойство Count содержит число контролей на форме - для формы сделанной выше в Name.htm оно равно 2 . Свойство Key - имя контролей - для формы в Name.htm это имена T1 (текст) и B1 (кнопка). И, наконец, свойство Item содержит введенные пользователем значения. И все эти рассуждения правильные. Но реализовано все это настолько поразительно криво. Поскольку файл ASPTlb.pas представляет собой перевод соответствующего *.h C++ файла, распространяемым Microsoft, претензии по его реализации следует адресовать этой компании.
Свойство Count работает как положено - возвращает двойку для примера выше. Но при попытке извлечь имя ключа обнаруживается неприятная особенность - в коллекции Key[] индексы начинаются с единицы, а не с нуля, как это принято в подобного типа приложениях. Все же обращаясь к коллекции Key с соответствующим индексом - 1 или 2 для примера выше можно получить названия контролей в виде строковых переменных. Аналогичная попытка извлечь данные, введенные пользователем в контроли, ни к чему хорошему ни приводят - при попытке присвоить строковой переменной значения из коллекции Item[] (которая обьявлена аналогична коллекции Key[]) происходит исключение. Анализируя значение, возвращаемое коллекцией Item[I] можно обнаружить, что возвращается интерфейс - потомок IDispatch. Методы и свойства этого интерфейса не описаны. Отсутствие описания интерфейса а также возврат ссылки на него в переменной типа OLE variant, а не IDispatch характерно для продуктов, которые находятся в процессе разработки. При разработке заголовки методов интерфейса, список параметров методов и их число постоянно меняется и чтобы не происходили исключения в клиентных приложениях, часто используют позднее связывание. Этот факт настораживает - не исключена возможность изменения методов интерфейса в будущем и это может привести к потере работоспособности созданных ранее ASP серверов. Но будем надеяться, что данный интерфейс устоялся и Microsoft вследствии занятости просто забыл внести изменения в интерфейсный модуль и дать его документацию.
Интерфейс - потомок IDispatch два свойства: Count, которое возвращает всегда 1 и Item[] - коллекцию, которое возвращает текст, введенный клиентом в контроле. Коллекция Item начинается с индекса 1. Для понимания и тестирования запроса в ASP сервере сделаем небольшое дополнение к проекту. Воспользовавшись редактором библиотек типов создадим новый метод RequestProp, как это было описано ранее (Рис. 2). Напишем следующий код для метода RequestProp:
procedure TTest.RequestProp;
var
S: string;
V: OLeVariant;
I, J, N: integer;
begin
S := '';
if Assigned(Request) then
if Request.Body.Count > 0 then
begin
for I := 1 to Request.Body.Count do
begin
S := S + 'Key' + IntToStr(I) + '=' + Request.Body.Key[I] + '<BR>';
V := Request.Body.Item[I];
if not VarIsEmpty(V) then
if varType(V) = varDispatch then
begin
N := V.Count;
S := S + 'ItemCount' + IntToStr(I) + '=' + IntToStr(N) + '<BR>';
if N > 0 then
for J := 1 to N do
S := S + V.Item[J] + '<BR>';
end;
end;
end;
if Assigned(Response) then
Response.write(S);
end;
|
Скомпилируем проект и в созданном ранее файле Test.asp изменим VB скрипты следующим образом: вместо строки DelphiASPObj.ScriptContent напишем строку DelphiASPObj. RequestProp. После этого в Internet Explorer следует обратиться к Name.htm следующей командой: http://10.10.10.65/Test/Name.htm, где вместо 10.10.10.65 следует набрать IP адрес сервера. В полученной форме.
Введем какое-либо значение в редакционный контроль и нажмем кнопку Submit. После этого получим результат выполнения приведенного выше кода метода RequestProp:
Key1=T1 ItemCount1=1 AM Key2=B1 ItemCount2=1 SubmitТо есть для определения параметров, введенных клиентом в какой-либо контроль, необходимо просмотреть все ключи, найти индекс интересуемого нас контроля (в данном примере он 1, что соответствует ключу T1) и извлечь значение, введенное клиентом, посредством вызова команды Request.Body.Item[Index].Item[1].
Теперь можно перейти к модификации имеющегося сервера - создание нового метода для доступа к базам данных. На него необходимо поместить невизуальные компоненты доступа к данным, визуальные компоненты нельзя использовать в ASP сервере. Вообще, в приложениях такого типа - ASP, ISAPI/NSAPI, CGI показ модальных форм с контролями (а диалоги - частный вид таких форм) ни к чему хорошему не приводит. При попытке показать диалог, контроли на диалоге будут созданы, на них будет помещен текст и\или картинки и приложение будет ожидать, когда диалог будет закрыт (нажатием кнопки OK или Cancel) чтобы продолжить свою работу. Особенность заключается в том, что диалог невидим. Поэтому его нельзя закрыть ни нажатием кнопок (они не получают сообщения OnClick) ни акселератором (сигналы с клавиатуры не посылаются невидимым контролям). Визуально программист наблюдает следующее - приложение висит, отклик с ASP сервера клиент не получает и для повторной компиляции проекта требуется перезагрузка системы. Даже если команды показа диалогов отсутствуют в ASP сервере, они могут быть показаны в процессе работы приложения - например, BDE пришлет сообщения об ошибке. Поэтому данный факт надо принимать во внимание при написании кода, где необходимо тщательно проверять данные перед их использованием, чтобы внешние приложения не сообщали об ошибках.
Традиционно доступ к данным очуществляется через BDE, при этом необходимо использовать компонеты TSession, TDatabase и TQuery. Однако, при обращении к данным в ASP сервере, выяснилось, что BDE нельзя использовать для доступа к SQL серверам. Исключение происходит при попытке соединиться с базой данных после передачи login параметров. Из серверов тестировались Oracle и Interbase. Через BDE удалось получить доступ только к DBDEMOS, которая не требует аутентификации пользователя при обращении к данным.
К счастью, в Delphi5 появилась альтернативный способ доступа данных - через ADO (Active Data Objects). Для работы с ADO прежде всего необходимо использовать компонент TADOConnection. Поставим его на форму. В инспекторе обьектов выберем свойство ConnectionString и вызовем диалог для создания строки. В предложенном диалоге выберем Microsoft OLE DB Provider for Oracle и нажмем кнопку Next.
На второй странице диалога необходимо указать имя сервера (в данном примере - beq-local) и параметры аутентификации - имя пользователя (SCOTT) и пароль (TIGER). Обязательно ставится метка в Allow Saving Password контроле - иначе ASP сервер попытается показать Login диалог! Протестировать соединение можно нажатием кнопки Test Connection - должно быть сообщение об успешном соединении с сервером.
Далее в инспекторе обьектов необходимо свойство LoginPromp в False. При работе с другими примерами необходимо также изменять свойство DefaultDatabase - имя базы данных, но для данного примера это не обязательно. Проверить правильность установок можно при помощи изменения свойства Connected в True, при этом не должен появить Login диалог или информация об исключении.
Поставим компонент TADOQuery на модуль данных и в свойстве Connection сошлемся на определенный выше компонент ADOConnection1.
Модуль данных, на которые можно помещать невизуальные компоненты, не создается автоматически при вызове эксперта для создания ASP сервера,. Поэтому его необходимо создавать отдельно. Вызовем команду File/New/Data Module добавим модуль данных к проекту. Запомним вновь созданный файл под именем U1_02.pas. Следует учесть, что созданный модуль данных не будет создаваться автоматически при старте приложения или при обращении клиента. Поэтому необходимо переписать конструктор и деструктор класса TTest, реализация которого находится в файле U1_01.pas. Сошлемся на модуль U1_02.pas в модуле U1_01.pas. В обьявлении класса TTest в секции private определим переменную FData типа TDataModule1. В секции public обьявим процедуры AfterConstruction и BeforeDesctruction c обязательной директивой override:
TTest = class(TASPObject, ITest)
private
FData: TDataModule1;
protected
...
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
end;
|
Реализуем процедуры AfterConstruction и BeforeDestruction в секции реализации:
procedure TTest.AfterConstruction;
begin
inherited;
FData := TDataModule1.Create(nil);
end;
procedure TTest.BeforeDestruction;
begin
if Assigned(FData) then
begin
FData.Query1.Active := False;
FData.ADOConnection1.Connected := False;
FData.Free;
end;
inherited;
end;
|
Далее следует создать новый метод в библиотеке типов, назовем его QueryResponse. Реализуем его следующим образом:
procedure TTest.QueryResponse;
var
S: string;
I, J: integer;
begin
S := Request.Body.Item[1].Item[1];
if FData.ADOQuery1.Active then
FData.ADOQuery1.Close;
FData.ADOQuery1.SQL.Clear;
FData.ADOQuery1.SQL.Add('Select * from EMP');
FData.ADOQuery1.SQL.Add('where ENAME like ''%' + S + '%''');
FData.ADOQuery1.Active := True;
if FData.ADOQuery1.RecordCount > 0 then
begin
FData.ADOQuery1.First;
for J := 0 to FData.ADOQuery1.Fields.Count - 1 do
Response.write(FData.ADOQuery1.Fields[J].FieldName + ' ');
Response.write('<BR>');
for I := 1 to FData.ADOQuery1.RecordCount do
begin
for J := 0 to FData.ADOQuery1.Fields.Count - 1 do
Response.write(FData.ADOQuery1.Fields[J].AsString + ' ');
Response.write('<BR>');
if I then
FData.ADOQuery1.Next;
end;
end;
end;
|
В этом методе динамически создается SQL запрос, при этом используются параметры, введенные клиентом в форму. С этим запросом происходит обращение к SQL серверу и возвращаемые данные помещаются в HTML документ. В созданном ранее файле Test.asp изменим VB скрипты следующим образом: вместо строки DelphiASPObj.ScriptContent напишем строку DelphiASPObj. QueryResponse. После этого в Microsoft Internet Explorer обращаемя к странице Name.htm.
При использовании ASP сервера можно поместить параметры, необходимые для его работы, в HTML документ. Эти параметры могут редактироваться в документе и, таким образом, можно изменять опции под конкретный сайт. Это является удобным при распространении ASP сервера: купившая его компания может изменить начальные установки так, что они отвечают требованиям компании. Для этого достаточно отредактировать HTML документ, что может быть сделано при использовании специалистов низкой квалификации. Пример проиллюстрируем следующим образом: определим в заговке класса TTest (U1_01.pas) две переменные: FCompanyName:string и FCopyrightYear:string; Определим в библиотеке типов два новых свойства: CompanyName:string и CopyrightYear:integer. На методы *Read и *Wirte для этих свойств определим чтение и возврат данных из описанных выше переменных. Добавим новый метод в библиотеку типов ShowCopyright, который реализуем следующим образом:
procedure TTest.ShowCopyright;
var
S: OLEVariant;
begin
S := Format('Copyright (C) %d by %s', [FCopyrightYear, FCompanyName]);
if Assigned(Response) then
Response.write(S);
end;
|
В созданном ранее файле Test.asp изменим VB скрипты:
<% Set DelphiASPObj = Server.CreateObject("ASP01.Test")
DelphiASPObj.CompanyName = "My Company"
DelphiASPObj.CopyrightYear = 1999
DelphiASPObj.ShowCopyright
%>
|
Результатом обращения к ASP серверу при помощи команды: http://10.10.10.65/Test/Test.asp (вместо 10.10.10.65 следует выбрать IP адрес сервера) будет генерация страницы.
Если в файле Test.asp изменить имя компании - а это можно сделать при помощи любого текстового редактора, то все изменения будут отражаться в HTML документе.
В заключении следует рассмотреть out-of-process ASP сервера. Эти сервера реализуются в *.exe приложениях и работают они в отдельном адресном пространстве. До сих пор рассматривались in-process сервера, которые работают в адресном пространстве IIS и реализуются в динамически загружаемых библиотеках - DLL. Для их создания необходимо открыть готовый проект, компиляция которого приводит к созданию *.exe файла или создать новый проект посредством вызова команды File/New Application. После этого необходимо выполнить команду File/New/ActiveX/Active Server Object. Будет создана библиотека типов, содержащая методы OnStartPage и OnEndPage.Все, что было сказано выше для in-process сервера применимо и к out-of-process: делаются новые методы и из вызываются из VB скриптов *.asp страницы. Сложности возникают при попытке протестировать out-of-process сервер. По умолчанию параметры IIS установлены таким образом, что запрещают запуск приложений: разрешен запуск только DLL. Более того, в администраторе IIS отсутствует опция, которая позволяет разрешить или запретить использование приложения, как ASP сервера. Для того, чтобы разрешить запуск исполняемого файла, как ASP сервера, необходимо выполнить следующий VB скрипт:
Set oWebService = GetObject("IIS://LocalHost/W3svc")
oWebService.Put "AspAllowOutOfProcComponents", True
oWebService.SetInfo
|
Для того, чтобы он был выполнен, необходимо, чтобы текущий пользователь имел статус администратора. По этой причине данный скрипт бесполезно определять в HTML документе и запускать его, используя IE: любой пользователь интернета имеет статус гостя. Данный скрипт необходимо поместить в обработчик какого-либо события в среде разработке VB и запустить его оттуда.
Я не сумел сделать аналог данного скрипта в Delphi: не найден метод, аналогичный методу VB GetObject. Очевидно, что метод GetObject возвращает ссылку на IDispatch IIS. Но при этом в качестве параметра он использует строку, которая не является классовой (GUID отсутствкует в системном реестре). В Delphi аналогичные методы отсутствуют, по крайней мере, в виде простых вспомогательных функций. Возможно данный метод станет доступным в следующих версиях Delphi.
Создание autoincrement поля.
Согласно электронной документации по DBD, "автоприращиваемое" (Autoincrement) поле таблиц Paradox должно содержать значение Valcheck Minimum value. Это отлично работает с новой таблицей, но вы не сможете добавить Аиtоinсгеmеnt поле к существующей таблице, т.к. все значения Valchecks неактивны!Решение: измените тип поля с + на N, установите минимальное значение и восстановите тип поля на +.
Создание банковского ключа.
function CheckCtrlKey( aNLs : string; aMfo : real ) : boolean;
const
{12345678901234567890xxx}
msk : string[28]= '71371371371371371371713';
var
i : byte;
s : integer;
nls : string[28];
bic : string[10];
begin
bic := LeftPad( Real0Str( aMfo, 9, 0 ), 9 );
if bic[7] < > '0' then {< =Простая проверка -- это РКЦ?}
{ не учитывает ГРКЦ }
nls := bic[7]+bic[8]+bic[9]
else
nls := '0'+ bic[5]+bic[6]; { РКЦ }
nls := aNLs + nls;
s:= 0;
for i := 1 to 23 do
s := s + ( ( (byte(nls[i])-48) * (byte(msk[i])-48) ) mod 10 );
s := s mod 10;
CheckCtrlKey := s = 0;
end;
|
Создание больших массивов.
| Программист с женой отправились в супермаркет. Сделав все необходимые закупки, они вышли на улицу, и жена сказала: - Стой здесь и смотри в оба за этими десятью сумками, пока я схожу и разыщу такси. Когда жена вернулась, то увидела обалдевшего мужа, переставляющего сумки с места на место. Программист: - Ты сказала, что здесь десять сумок, а я насчитал только 9! Жена: - Но их было десять! Программист: - Нет, давай вместе считать: 0, 1, 2, 3... |
В 16-битной версии Delphi вам необходимо работать с блоками по 32K или 64K и картой. Вы могли бы сделать приблизительно следующее:
type chunk: array[0..32767] of byte; pchunk: ^chunk; var BigArray: array[0..31] of pChunk; |
Для создания массива:
for i := 0 to high(bigArray) do new(bigArray[i]); |
Для получения доступа к n-ному байту в пределах массива (n должен иметь тип longint):
bigArray[n shr 15]^[n and $7FFF] := y; x := bigArray[n shr 15]^[n and $7fff]; |
Для освобождения массива после его использования необходимо сделать следующее:
for i := 0 to high(bigArray) do dispose (bigArray[i]); |
Создание пустого wav-файла.
Автор: Nick Hodges Как мне создать пустой wav-файл? Это просто пустой двоичный файл? The TMediaPlayer может открыть звуковой файл, если он содержит, по крайней мере, один байт данных. Я обнаружил это, когда с помощью данного компонента пытался создать и открыть звуковой файл, содержащий только заголовок звукового файла. The TMediaplayer не захотел этого делать.Нижеприведенный код создаст звуковой файл размером 1 байт. Конечно это криво, но это работает. Вам необходимо лишь добавить MMSYSTEM ко всем модулям, использующим данную функцию.
function CreateNewWave(NewFileName: string): Boolean; var DeviceID: Word; Return: LongInt; MciOpen: TMCI_Open_Parms; MciRecord: TMCI_Record_Parms; MciPlay: TMCI_Play_Parms; MciSave: TMCI_SaveParms; MCIResult: LongInt; Flags: Word; TempFileName: array[0..255] of char; begin MediaPlayer.Close; StrPCopy(TempFileName, NewFileName); MciOpen.lpstrDeviceType := 'waveaudio'; MciOpen.lpstrElementName := ''; Flags := Mci_Open_Element or Mci_Open_Type; MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen)); DeviceID := MciOpen.wDeviceId; MciRecord.dwTo := 1; Flags := Mci_To or Mci_Wait; MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord)); mciPlay.dwFrom := 0; Flags := Mci_From or Mci_Wait; MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay)); mciSave.lpfileName := TempFilename; Flags := MCI_Save_File or Mci_Wait; MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave)); Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0; end; |
Вот небольшой компонент, позволяющий стирать любую часть wave-файла:
unit Nickmp;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, MPlayer, MMSystem;
type
TNickMediaPlayer = class(TMediaPlayer)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
function DeleteWaveChunk(aFrom, aTo: LongInt): Longint;
published
{ Published declarations }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TNickMediaPlayer]);
end;
function TNickMediaPlayer.DeleteWaveChunk(aFrom, aTo: LongInt): Longint;
var
DeleteParms: TMCI_WAVE_DELETE_PARMS;
Flags: LongInt;
begin
Flags := 0;
if Wait then
Flags := mci_Wait;
if Notify then
Flags := Flags or mci_Notify;
DeleteParms.dwCallback := Handle;
Flags := Flags or mci_From;
DeleteParms.dwFrom := aFrom;
Flags := Flags or mci_To;
DeleteParms.dwTo := aTo;
Result := mciSendCommand(DeviceID, mci_Delete, Flags, Longint(@DeleteParms));
end;
end.
|
Создаём заблокированный файл.
Автор: Christian CristoforiЕсть как минимум два способа сделать это, но один из них, при помощи Windows API (LockFileEx и UnlockFileEx) используя параметр LOCKFILE_EXCLUSIVE_LOCK не очень хорош на мой взгляд.
Поэтому предлагаю другой способ, путём создания файла при помощи функции OpenFile:
hMyLockedFile := OpenFile( 'c:\DelphiWorld.dat', ofStruct, OF_CREATE or OF_READWRITE or OF_SHARE_EXCLUSIVE ); |
Теперь Вы можете работать с файлом, но пользователи уже не смогут изменить его!
Браузер своими руками.
Автор: Павел Я не могу понять - все развели какой-то базар вокруг войны Интернет браузеров. Ie, Ns, Opera... Все чего-то там себе выбирают... Меня эта проблема не волнует, я могу сам написать себе браузер - такой, как мне захочется. А тебе слабо? Я думаю, что нет. Через десять минут у тебя тоже будет свой навигатор. Предварительные установки Ты снова должен запустить Delphi. Именно он позволяет очень быстро и без особых проблем написать свой собственный браузер. Когда запустишь, то найди закладку "Internet". Здесь должен быть компонент "WebBrowser" (он должен быть последний). Если у тебя версия Delphi меньше, чем пятая, то этого компонента может и не быть. Он может отсутствовать и если ты отказался устанавливать инет-компоненты (по умолчанию они ставятся). Выбери "Import ActiveX Control" из меню "Component". В списке выбора этого окна (сверху) найди строку "Microsoft Internet Controls (Version 1.1)". Версия может отличаться, но нам с тобой - акваланг. Теперь нажми кнопку "Install". Перед тобой откроется окно и запрос. На запрос ты должен ответить "Yes". После того, как Delphi прошуршит мозгами, появится окно, которое сообщит об успешной установке нового компонента. Нажми "OK" и закрой все, что открыл Delphi. Для этого выбери "Close All" из меню "File". Теперь и у тебя есть компонент "WebBrowser", только он расположен на странице "ActiveX" палитры компонентов. Как ты мог заметить, мы будем использовать "Microsoft Internet Controls", т.е. движок установленного на твоем компе IE. А это значит, что твой браузер подхватит все болезни и глюки своего движка. Единственное, что может успокоить - так это то, что интерфейс не будет таким занудным. Он будет таким, как ты захочешь, потому что сделан твоими руками. Первые шаги Сейчас ты уже готов приступить к программированию. Создай новый проект ("File" -> "New Application") и сразу измени заголовок и иконку. Как это делается, я рассказал в статье про мега-медиа-плеер в этом же номере. Двигаемся дальше. Установи на форму наш компонент "WebBrowser" (он находится на закладке "Internet" или "ActiveX") - у тебя появится белый квадрат с именем WebBrowser1. После этого брось на форму "CoolBar", который находится на закладке "Win32" палитры компонентов. Это панелька, которая должна выровняться по верхнему краю на твоей форме. Теперь выдели WebBrowser1 и перейди в ObjectInspector. Щелкни по свойству "Align" и в выпадающем списке выбери "alClient". "WebBrowser" должен растянуться на все свободное место формы. Теперь брось на CoolBar1 (мы его недавно установили на форму) панель "ToolBar" из закладки "Win32" и "ComboBox" из закладки "Standart" палитры компонентов. Все это ты должен бросить именно внутрь CoolBar1, иначе ты получишь полный отстой. После этого нужно выделить CoolBar1 и перейти в ObjectInspector. Здесь ты должен изменить строку "AutoSize" на "true" (по умолчанию она "false").Если что-то не получилось, то читай статью заново. Если и это не поможет, то попробуй накатить пивка, это помогает думать :). Если все в порядке, то выделяй ComboBox1 (выпадающий список) и переходи в ObjectInspector. Здесь ты должен выделить закладку "Events" и произвести сложнейшее действие ДоублеКлике по строке "OnKeyDown". ДоублеКлике нужно производить в правой половине строки. Если ты не помнишь, где находиться "право" :), то щелкай по выпадающему списку (это и есть "право"). Как и раньше, Delphi создаст процедуру. Она будет вызываться каждый раз, когда ты будешь вводить какую-нибудь букву в "ComboBox". Здесь ты должен написать следующее:
procedure TForm1.ComboBox1KeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if Key = VK_RETURN then
WebBrowser1.Navigate(ComboBox1.Text);
end;
Примечание! Набирать на клаве нужно только то, что написано между Begin и End, все остальное уже должно быть создано Delphi. В данном случае ты должен набрать только "if Key= VK_RETURN then WebBrowser1.Navigate(ComboBox1.Text)", причем без кавычек. Я остальные строчки привожу только чтобы тебе было удобно глазеть и сравнивать с тем, что за тебя делает Delphi.
Теперь то же самое, но по понятиям:
Процедура ComboBox1.КлавишаНажата (Sender - Адрес ComboBox1;
Key - КодНажатойКлавиши; Shift - состояние клавиш Shift, Ctrl,Alt)
Начало
Если КодНажатойКлавиши равен Enter, то
WebBrowser1.Перейти на адрес, указанный в ComboBox1
Конец
Нажми "F9", и твоя прога должна засвистеть. Введи какой-нибудь адрес в строку ComboBox и нажми Enter (это клавиша на кейборде :)). Если ты правильно ввел адрес, то в WebBrowser1 через несколько минут должен появиться указанный Home Page. Когда наиграешься со своим произведением, то возвращайся в Delphi. Мы еще многое должны сегодня успеть сделать.
Улучшаем свой браузер
Кликни по ToolBar1 и снова переходи в ObjectInspector. Здесь нужно изменить свойства "AutoSize", "ShowCaption" и "Flat" на "true" (все они по умолчанию равны false). Теперь щелкай правой кнопкой по ToolBar1 и из появившейся менюшки выбирай пункт "New Button". На ToolBar1 должна появиться новая пимпа с именем "ToolButton1". Выдели ее и в ObjectInspector-е поменяй свойство Caption на "Открыть". Создай еще насколько кнопок с заголовками: Назад, Вперед, Стоять, Обновить и Печать.
Установи еще на форму "OpenDialog" из закладки "Dialogs" палитры компонентов. Он нам скоро понадобится.
Теперь дважды кликни по кнопке "Открыть", и Delphi автоматически создаст процедуру, которая будет вызываться при нажатии этой кнопки. В этой процедуре нужно написать следующее:
procedure TForm1.ToolButton1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
WebBrowser1.Navigate(OpenDialog1.FileName);
ComboBox1.Text := OpenDialog1.FileName;
end;
end;
Как всегда, объясняю по понятиям:
Начать
Если OpenDialog1 удачно запущен, то
Начать
WebBrowser1.Перейти на указанное имя файла в OpenDialog1;
ComboBox1.Текст присвоить значение OpenDialog1.ИмяФайла
Закончить
Закончить
Теперь ты можешь запустить прогу и открыть с помощью этой пимпы любой файл на диске. Но, я думаю, что торопиться не надо. Заставим работать остальные кнопки! Дважды кликни по кнопке "Назад". Какой будет результат, ты уже догадался. Напиши тут следующее:
procedure TForm1.ToolButton2Click(Sender: TObject); begin WebBrowser1.GoBack; end;Я думаю, что здесь ничего объяснять не надо. Мы просто заставляем WebBrowser1 идти на предыдущую страницу. Повтори те же операции для кнопки "Вперед", чтобы создать процедуру. Напиши для нее следующий код:
procedure TForm1.ToolButton3Click(Sender: TObject); begin WebBrowser1.GoForward; end;
Для кнопки "Стоять" напиши: "Стоять на месте свистком в небо, руки по швам". Шучу :). Напиши лучше это:
procedure TForm1.ToolButton4Click(Sender: TObject);
begin
WebBrowser1.Stop;
end;
// Для пимпы "Обновить":
procedure TForm1.ToolButton5Click(Sender: TObject);
begin
WebBrowser1.Refresh;
end;
// И, наконец, для пимпы "Печать":
procedure TForm1.ToolButton6Click(Sender: TObject);
var
PostData, Headers: OLEvariant;
begin
WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT, PostData,
Headers);
end;
Здесь только одна строка, но очень сложная, поэтому я не стану ее объяснять. Скажу только, что в этой строке я посылаю команду через OLE ядру IE. Просто скопируй ее один к одному в свой исходник и поверь мне на слово.
Теперь можешь нажать "F9", и твоя прога должна запуститься. Попробуй поиграть с ней. Неплохие ощущения? Закрывай свой браузер, остались последние штрихи!
Последние штрихи
Твой браузер почти готов. Я только наведу небольшой марафет.
Для начала брось на форму StatusBar из закладки "Win32" и измени у него свойство "SimplePanel" в true (по умолчанию false). Теперь выдели WebBrowser1 и щелкни по закладке "Events" в ОьjесInsресtог-е. Дважды кликни по строке "OnStatusTextChange" и напиши в созданной процедуре следующее:
procedure TForm1.WebBrowser1StatusTextChange(Sender: TObject; const Text: WideString); begin StatusBar1.SimpleText := Text; end;Здесь мы присваиваем переменную "Text" (в ней хранится текст подсказки) в StatusBar1. Теперь ты сможешь видеть подсказки в строке состояния.
Давай добавим ещё индикатор загрузки. Для этого брось на форму ProgressBar из закладки "Win32". Измени у него свойство "Align" на "alBottom", чтобы он находился вдоль нижней границы формы. Снова выдели WebBrowser1 и щелкни по закладке "Events" в ОьjесInsресtог-е. Дважды щелкни по строке "OnProgressChange" и напиши в созданной процедуре:
procedure TForm1.WebBrowser1ProgressChange(Sender: TObject; Progress, ProgressMax: Integer); begin ProgressBar1.Max := ProgressMax; ProgressBar1.Position := Progress; end;Здесь мы созданному ProgressBar1 (индикатор загрузки) присваиваем максимальное значение (ProgressMax) и текущее значение (Progress). Теперь надо украсить наши кнопки, а то они смотрятся как сам IE. Для этого брось на форму ImageList и произведи по нему ДоублеКлик. Перед тобой откроется окно. Сюда нужно добавить картинки размером 16х16. Для этого нажми кнопку "Add", и перед тобой откроется стандартное окно открытия файла. Найди картинку и нажми "Открыть". Повтори эту процедуру 6 раз (6 картинок для 6-и кнопок). После всего этого нажми "ОК". Теперь выдели ToolBar1 и в ObjectInspector-е измени свойство Images на "ImageList1". На твоих кнопках должны появиться картинки. Если ты добавлял картинки не в том порядке, как они у тебя стоят на форме, то можешь пересортировать их с помощью свойства ImageIndex у кнопки. Например: щелкни по кнопке "Стоять" и измени ImageIndex на 0. На кнопке должна появиться картинка, указанная первой в ImageList1. Можешь создать еще один ImageList, который подставляется в HotImages. В этом случае картинки из этого ИмаджеЛиста будут подставляться на кнопку, когда ты наводишь на нее маусом. Конец Все, косметический ремонт окончен. Дави на "F9", и Delphi в последний раз создаст тебе окончательную версию. Можешь пользоваться полноценным браузером в свое удовольствие. Конечно же, это не все возможности, которые можно выцепить из WebBrowser1. Сюда еще очень многое можно добавить - главное, чтобы хватило воображения и умений. Но это уже специфические детали, и я их описывать не буду, потому что тебе понадобится объяснять все принципы программирования на Delphi. А это - целая история. Пиши, если что, и удачи!
Он будет таким, как ты захочешь, потому что сделан твоими руками.
Создание CGI счётчика в Delphi.
| Когда нормальный человек, уезжая из дома одевает на жену пояс верности, веб-дизайнер ставит на нее счетчик... |
Если Вы программируете в Delphi и, хотели бы, чтобы Ваш любимый компилятор поучавствовал в создании Вашей веб-странички, то можно начать с маленькой, но довольно важной части веб-проекта - счётчика. Обычно, счётчик выглядит как кнопка на странице. В данном случае это JPEG картинка, генерируемая на лету.
Те, кто желает сразу приступить к компиляции, могут скачать исходник и, в случае возникновения каких либо вопросов, вернуться к данной статье.
Для начала давайте посмотрим - как этот счётчик может выглядеть:
Вызывается счётчик тэгом IMG примерно так:
<img src="http://ww5.borland.com/ scripts/CounterCGI.exe?FileName=Article"> |
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 скрипта из директории в директорию и с одного сервера на другой.
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; |
Процедура SetVariable будет использоваться для инициализации нужных нам переменных.
procedure SetVariable(var S : string; const Value, default: string);
begin
S := Value;
if S = '' then
S := default;
end;
|
Вся суть CGI скрипта заключается в событие OnAction. Давайте рассмотрим его по шагам.
procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); |
Сперва объявим некоторые локальные переменные.
var ScriptPath, LocalPath, FileName, Txt, FontColor, BackgroundColor, FontName, FontSize: string; Today, LastEver, Ever, LastToday: Integer; LastDate: TDate; MS: TMemoryStream; Panel: TPanel; Memo: TMemo; Bitmap: TBitmap; Form: TForm; fp: TextFile; |
Теперь вызовем GetPaths, чтобы выяснить путь к скрипту, а так же локальный путь. В данном примере мы будем помещать наши счётчики в директорию "counters". Физический путь будет выглядеть примерно так "C:\InetPub\counters".
begin GetPaths(Request, ScriptPath, LocalPath); LocalPath := LocalPath + 'counters\'; |
Затем, мы получаем все параметры, переданные вместе с вызовом скрипта. Параметры поступают к нам через свойство Request.QueryFields. Обратите внимание, что если какой-то параметр не был передан, то SetVariable устанавливает его по умолчанию.
with Request.QueryFields do begin FileName := LocalPath+Values['FileName']+'.txt'; SetVariable(Txt,Values['Txt'],'You are visitor %d today, and %d ever.'); SetVariable(FontName,Values['FontName'],'Arial'); SetVariable(FontSize,Values['FontSize'],'10'); SetVariable(FontColor,Values['FontColor'],'clWhite'); SetVariable(BackgroundColor,Values['BackgroundColor'],'clBlack'); end; |
Теперь мы должны быть уверены, что присутствует файл для данного счётчика. Если его нет, то просто создаём его.
try
// Write a new empty counter file if it doesn't exist
if not FileExists(FileName) then
begin
AssignFile(fp, FileName);
Rewrite(fp);
WriteLn(fp, 0);
WriteLn(fp, Date);
WriteLn(fp, 0);
CloseFile(fp);
end;
|
Итак, файл существует. Естевственно, если мы создали его, что счётчик будет равен 0, иначе будем считывать старые значения, и зменять их, если необходимо. Обратите внимание , на то, как мы отслеживаем общее число посещение и посещений за день.
// Читаем старые значения счётчика AssignFile(fp,FileName); Reset(fp); ReadLn(fp,LastEver); Ever := LastEver+1; ReadLn(fp,LastDate); ReadLn(fp,LastToday); if Date = LastDate then Today := LastToday+1 else Today := 1; CloseFile(fp); |
И в заключении, надо записать новые значения в файл, содержащий данные счётчика.
// Записываем новые значения счётчика AssignFile(fp, FileName); Rewrite(fp); WriteLn(fp, Ever); WriteLn(fp, Date); WriteLn(fp, Today); CloseFile(fp); |
Теперь приступим к созднию того, что в конечном итоге будет называться JPEG. Для начала сделаем невидимым TForm которая содержит TPanel и TMemo. Так же устанавливаем FontName и FontSize.
Form := TForm.Create(nil); with Form.Font do begin name := FontName; Size := StrToInt(FontSize); end; |
Удостоверимся в том, что текст, который мы помещаем в memo контрол, содержит значения счётчика, считанные из файла.
Txt := Format(Txt, [Today, Ever]); |
Далее мы создаём панель. Ширина и высота будут определяться шириной текста, который мы помещаем в неё. Так же устанавливаем скашивание для 3D эффекта.
Panel := TPanel.Create(nil); with Panel do begin BevelInner := bvRaised; BevelOuter := bvLowered; Parent := Form; Width := Form.Canvas.TextWidth(Txt) + 9; Height := Form.Canvas.TextHeight(Txt) + 9; end; |
Помещаем memo в панель, и устанавливаем её ширину и высоту, а так же цвет, который указан в BackgroundColor.
Memo := TMemo.Create(nil); with Memo do begin Top := 2; Left := 2; Width := Panel.Width-5; Height := Panel.Height-5; Alignment := taCenter; Color := StringToColor(BackgroundColor); BorderStyle := bsNone; Parent := Panel; end; |
Теперь необходимо сделать изображение эелемента управления, который мы создали. Для этого создаём TBitmap и закрашеваем его панелью. За одно рисуем текст на битмапе.
Bitmap := TBitmap.Create;
with Bitmap do
begin
Width := Panel.Width-1;
Height := Panel.Height-1;
Canvas.Lock;
Panel.PaintTo(Canvas.Handle,0,0);
Canvas.Unlock;
Canvas.Brush.Style := bsClear;
with Canvas.Font do
begin
name := FontName;
Size := StrToInt(FontSize);
Color := StringToColor(FontColor);
end;
Canvas.TextOut(4,3,Txt);
end;
|
Затем преобразовываем bitmap в JPEG. JPEG будет записан в memory stream. Этот поток будет связан с браузером и передаваться посетителю странички в виде картинки.
with Response do
begin
MS := TMemoryStream.Create;
with TJPEGImage.Create do
begin
CompressionQuality := 75;
Assign(Bitmap);
SaveToStream(MS);
Free;
end;
ContentType := 'image/jpeg';
MS.Position := 0;
SendResponse;
SendStream(MS);
end;
|
Освобождаем ресурсы:
Panel.Free; Bitmap.Free; Form.Free; |
На всякий случай обрабатываем исключительные ситуации.
except
on E: Exception do
Response.Content := E.message;
end;
Handled := True;
end;
|
Вот собственно и всё. Наслаждайтесь счётчиком, сделанным в Delphi 5 :).
Как написать собственный класс.
Автор: Vit WEB-сайт: http://forum.vingrad.ruВот пример написания класса. Этот класс вычисляет сумму квадратов введенных чисел. Этот класс написан мной только для примера, и я исходил из воображений наглядности, а не оптимальности. Большая часть реализации не только не оптимальна, но и бессмыслена, но показывает бОльшую часть простейших приемов создания класса.
unit Unit2;
interface
uses classes, Sysutils;
{Нам нужен процедурный тип для создания собственного события.
Собственно - это описание процедуры которая должна будет
исполнятся при каких-нибудь обстоятельствах}
type
TError = procedure(Sender: TObject; Error: string) of object;
{Описание нашего класса, мы его наследуем от TObject, потому ?то нам практи?ески не нужна
никакия функциональность предков}
type
TStatistic = class(TObject)
private {здесь описываются только внутренние переменные и процедуры - "для служебного пользования"}
{Описание полей, т.е. переменных которые работают только внутри класса, "снаружи" они не
доступны.}
FList: TStringList;
FPrecision: byte;
{Тоже переменная - для определения события}
FonError: TError;
{функция - будет использоваться только внутри класса, "снаружи" напрямую не доступна}
function GetCount: integer;
public {Описанное здесь доступно для пользователя класса}
{Конструктор - метод создания класса, имеет смысл его описывать только если он делает
?то-то специфи?еское - например нам надо будет создать переменную FList. В противном слу?ае
его описание можно опустить - будет работать конструктор родительского класса}
constructor Create;
{Деструктор - метод разрушения класса}
destructor Destroy; override;
{Описание методов - собственно методы мало ?ем отли?аются от процедур}
procedure AddValue(Value: string);
procedure Clear;
function Solve: real;
{Описание свойств. Обратите внимание само свойство не способно хранить никакую информацию, это
только указатель на внутренюю струкруру. Например для хранения свойства Precision используется
переменная FPrecision. А для ?тение свойства Count используется функция GetCount}
property Precision: byte read FPrecision write FPrecision;
property Count: integer read GetCount;
{Описание событий. ?то такое событие? - Это указатель на процедуру. Сам класс реализации этой процедуры
не знает. Классу известно только заголовок процедуры, вы в коде программы будете писать реализацию
процедуры, а класс только в нужный момент передаст ей управление, используя указатель onError}
property onError: TError read FonError write FonError;
end;
implementation
{ TStatistic }
constructor TStatistic.Create;
begin
inherited; {Вна?але надо вызвать конструктор класса-родителя}
FList := TStringList.create; {создаем структуры нашего класса}
end;
destructor TStatistic.Destroy;
begin
FList.Free; {Разрушаем структуры нашего класса}
inherited; {в последнюю о?ередь вызываем деструктор клсса-родителя}
end;
procedure TStatistic.AddValue(Value: string);
begin
FList.add(Value); {Примерно так мы реализуем метод}
end;
procedure TStatistic.Clear;
begin
FList.clear;
end;
function TStatistic.GetCount: integer;
begin
Result := FList.count + 1;
end;
function TStatistic.Solve: real;
var
i: integer;
begin
result := 0;
for i := 0 to FList.count - 1 do
begin
try
result := result + (Sqr(strtofloat(FList[i])));
except
{интересная конструкция. "on e:exception do" - мы "отлавливаем" ошибку как переменную "e".
Эта переменная имеет о?ень полезное свойство e.message - оно содержит описание ошибки. Далее
следует вызов события. Вна?але мы проверяем использует ли пользователь событие:
"if Assigned(FOnError) then", если использует то вызываем его процедуру: FOnError, с параметрами:
self - зарезервированная переменная - указатель на экземпляр нашего класса, e.message - описание
ошибки}
on e: exception do
if Assigned(FOnError) then
FOnError(Self, e.message);
end;
end;
end;
end.
Вот пример использования этого класса:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure OnError(Sender: TObject; Error: string);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
Statistic: TStatistic;
begin
Statistic := TStatistic.create;
Statistic.onError := onError;
Statistic.AddValue('123423');
Statistic.AddValue('123423');
showmessage(floattostr(Statistic.solve));
Statistic.Clear;
Statistic.AddValue('123423');
Statistic.AddValue('12ssss3');
showmessage(floattostr(Statistic.solve));
Statistic.Free;
end;
procedure TForm1.OnError(Sender: TObject; Error: string);
begin
showmessage('Error inside class:' + Sender.ClassName + #13#10+Error);
end;
end.
Как реализовать правильный выпадающий контрол (Combo).
Когда-то потратил немало времени на разбор, как же все таки работаю дропдаун контролы. В итоге мной был написан маленький юнит, который я положил у себя в каталоге Demo для ознакомления интерисующихся. Он маленький (его основная задача -- показать принцип работы, а все остальное -- как реализуешь), я думаю, что большинству он пригодиться, поэтому публикую здесь.
unit edit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TPopupListbox = class(TCustomListbox)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
end;
TTestDropEdit = class(TEdit)
private
FPickList: TPopupListbox;
procedure CMCancelMode(var message: TCMCancelMode); message CM_CancelMode;
procedure WMKillFocus(var message: TMessage); message WM_KillFocus;
protected
procedure CloseUp(Accept: Boolean);
procedure DropDown;
procedure WndProc(var message: TMessage); override;
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
end;
implementation
procedure TPopupListBox.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do
begin
Style := Style or WS_BORDER;
ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;
WindowClass.Style := CS_SAVEBITS;
end;
end;
procedure TPopupListbox.CreateWnd;
begin
inherited CreateWnd;
Windows.SetParent(Handle, 0);
CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
end;
procedure TPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
TTestDropEdit(Owner).CloseUp((X >= 0) and (Y >= 0) and
(X and (Y end;
{ TTestDropEdit }
constructor TTestDropEdit.Create(Owner: TComponent);
begin
inherited Create(Owner);
Parent := Owner as TWinControl;
FPickList := TPopupListbox.Create(nil);
FPickList.Visible := False;
FPickList.Parent := Self;
FPickList.IntegralHeight := True;
FPickList.ItemHeight := 11;
FPickList.Items.CommaText :='1,2,3,4,5,6,7,8,9,0';
end;
destructor TTestDropEdit.Destroy;
begin
FPickList.Free;
inherited;
end;
procedure TTestDropEdit.CloseUp(Accept: Boolean);
begin
if FPickList.Visible then
begin
if GetCapture <> 0 then
SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
SetWindowPos(FPickList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
if FPickList.ItemIndex <> -1 then
Text := FPickList.Items.Strings[FPickList.ItemIndex];
FPickList.Visible := False;
Invalidate;
end;
end;
procedure TTestDropEdit.DropDown;
var
P: TPoint;
I,J,Y: Integer;
begin
if Assigned(FPickList) and (not FPickList.Visible) then
begin
FPickList.Width := Width;
FPickList.Color := Color;
FPickList.Font := Font;
FPickList.Height := 6 * FPickList.ItemHeight + 4;
FPickList.ItemIndex := FPickList.Items.IndexOf(Text);
P := Parent.ClientToScreen(Point(Left, Top));
Y := P.Y + Height;
if Y + FPickList.Height > Screen.Height then
Y := P.Y - FPickList.Height;
SetWindowPos(FPickList.Handle, HWND_TOP, P.X, Y, 0, 0,
SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
FPickList.Visible := True;
Invalidate;
Windows.SetFocus(Handle);
end;
end;
procedure TTestDropEdit.CMCancelMode(var message: TCMCancelMode);
begin
if (message.Sender <> Self) and (message.Sender <> FPickList) then
CloseUp(False);
end;
procedure TTestDropEdit.WMKillFocus(var message: TMessage);
begin
inherited;
CloseUp(False);
end;
procedure TTestDropEdit.WndProc(var message: TMessage);
procedure DoDropDownKeys(var Key: Word; Shift: TShiftState);
begin
case Key of
VK_UP, VK_DOWN:
if ssAlt in Shift then
begin
if FPickList.Visible then
CloseUp(True)
else
DropDown;
Key := 0;
end;
VK_RETURN, VK_ESCAPE:
if FPickList.Visible and not (ssAlt in Shift) then
begin
CloseUp(Key = VK_RETURN);
Key := 0;
end;
end;
end;
begin
case message.Msg of
WM_KeyDown, WM_SysKeyDown, WM_Char:
with TWMKey(message) do
begin
DoDropDownKeys(CharCode, KeyDataToShiftState(KeyData));
if (CharCode <> 0) and FPickList.Visible then
begin
with TMessage(message) do
SendMessage(FPickList.Handle, Msg, WParam, LParam);
Exit;
end;
end
end;
inherited;
end;
end.
|
Создать компонент любого класса.
unit InfoForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
Dbctrls, Dbgrids, Dblookup, Dbtables, Ddeman, Dialogs,
Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
Olectrls, Outline, Tabnotbk, Tabs, ExtDlgs, CheckLst, ToolWin;
type
TForm1 = class(TForm)
Panel1: TPanel;
ComboBox1: TComboBox;
Label1: TLabel;
Label2: TLabel;
ComboBox2: TComboBox;
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
function GetNextName (MyClass: TComponentClass): string;
procedure UpdateList;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TClassArray = array [1..133] of TPersistentClass;
// definition temporary used to check the data types
// TClassArray = array [1..133] of TComponentClass;
const
ClassArray: TClassArray = (
TApplication,
TBatchMove,
TColorDialog,
TFindDialog,
TReplaceDialog,
TFontDialog,
TOpenDialog ,
TOpenPictureDialog,
TSavePictureDialog,
TSaveDialog,
TPrintDialog,
TPrinterSetupDialog,
TBevel,
TCustomLabel,
TDBText,
TLabel,
TImage,
TPaintBox,
TShape,
TSpeedButton,
TSplitter,
TToolButton,
TAnimate,
TButton,
TBitBtn,
TCheckBox,
TDBCheckBox,
TRadioButton,
TComboBox,
TDBComboBox,
TDriveComboBox,
TFilterComboBox,
TCustomDBGrid,
TDBGrid,
TDBLookupList,
TPopupGrid,
TOutline,
TDrawGrid,
TStringGrid,
TDBRadioGroup,
TRadioGroup,
TGroupBox,
TDBNavigator,
TPanel,
TDBImage,
TDBLookupControl,
TDBLookupComboBox,
TDBLookupListBox,
TPopupDataList,
THeader,
THintWindow,
TMediaPlayer,
TNotebook,
TOleContainer,
TPage,
TScroller,
TTabSet,
TDBEdit,
TInplaceEdit,
TMaskEdit,
TCustomRichEdit,
TDBRichEdit,
TRichEdit,
TDBMemo,
TMemo,
TDBLookupCombo,
TEdit,
THotKey,
TCheckListBox,
TDBListBox,
TDirectoryListBox,
TFileListBox,
TListBox,
TListView,
TStaticText,
TPageControl,
TTabbedNotebook,
TTabControl,
TTreeView,
TUpDown,
TDateTimePicker,
TDBCtrlGrid,
TDBCtrlPanel,
THeaderControl,
TOleControl,
TProgressBar,
TScrollBar,
TScrollBox,
TStatusBar,
TTabPage,
TTabSheet,
TToolWindow,
TCoolBar,
TToolBar,
TTrackBar,
TImageList,
TDatabase,
TDataModule,
TQuery,
TStoredProc,
TTable,
TUpdateSQL,
TDataSource,
TDdeClientConv,
TDdeClientItem,
TDdeMgr,
TDdeServerConv,
TDdeServerItem,
TBinaryField,
TBytesField,
TVarBytesField,
TBlobField,
TGraphicField,
TMemoField,
TBooleanField,
TDateTimeField,
TDateField,
TTimeField,
TNumericField,
TBCDField,
TFloatField,
TCurrencyField,
TIntegerField,
TAutoIncField,
TSmallintField,
TWordField,
TStringField,
TMainMenu,
TPopupMenu,
TMenuItem,
TScreen,
TSession,
TTimer
);
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
// register all of the classes
RegisterClasses (ClassArray);
// copy class names to the listbox
for I := Low (ClassArray) to High (ClassArray) do
ComboBox1.Items.Add (ClassArray [I].ClassName);
UpdateList;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
MyClass: TComponentClass;
MyComp: TComponent;
begin
MyClass := TComponentClass (GetClass (ComboBox1.Text));
if MyClass = nil then
Beep
else
begin
MyComp := MyClass.Create (self);
MyComp.Name := GetNextName (MyClass);
if MyClass.InheritsFrom (TControl) then
// if MyComp is TControl then // alternative version
begin
TControl (MyComp).Left := X;
TControl (MyComp).Top := Y;
TControl (MyComp).Parent := self;
end;
end;
UpdateList;
end;
function TForm1.GetNextName (MyClass: TComponentClass): string;
var
I, nTot: Integer;
begin
nTot := 0;
for I := 0 to ComponentCount - 1 do
if Components [I].ClassType = MyClass then
Inc (nTot);
Result := Copy (MyClass.ClassName, 2, Length (MyClass.ClassName) - 1) +
IntToStr (nTot);
end;
procedure TForm1.UpdateList;
var
I: Integer;
begin
Combobox2.Items.Clear;
for I := 0 to ComponentCount - 1 do
ComboBox2.Items.Add (Components [I].Name);
end;
end.
|
Загрузить весь проект
Создание модуля компонента.
Перед началом работы по созданию нового компонента нужно создать отдельный каталог для модуля и других файлов компонента. После этого можно приступить к созданию модуля компонента. Для того чтобы создать модуль компонента, необходимо из меню Component выбрать команду New Component и в поля открывшегося диалогового окна New Component ввести информацию о создаваемом компоненте. Поле Ancestor type должно содержать базовый тип для создаваемого компонента. Базовый тип компонента можно задать непосредственным вводом имени типа или выбором из раскрывающегося списка. Для разрабатываемого компонента базовым компонентом является стандартный компонент Edit (поле ввода-редактирования). Поэтому базовым типом для типа разрабатываемого компонента является тип TEdit. В поле Class Name необходимо ввести имя класса разрабатываемого компонента, например TNkEdit. Вспомните, что в Delphi имена типов должны начинаться буквой т. В поле Palette Page нужно ввести имя вкладки палитры компонентов, на которую после создания компонента будет добавлен его значок. Название вкладки палитры компонентов можно выбрать из раскрывающегося списка. Если в поле Palette Page ввести имя еще не существующей вкладки палитры компонентов, то непосредственно перед добавлением компонента вкладка с указанным именем будет создана. В поле Unit, file name находится автоматически сформированное имя файла модуля создаваемого компонента. Delphi присваивает модулю компонента имя, которое совпадает с именем типа компонента, но без буквы T. Щелкнув на кнопке с тремя точками, можно выбрать каталог, в котором должен быть сохранен модуль компонента.После нажатия кнопки ОК к текущему проекту добавляется сформированный Delphi-модуль, представляющий собой заготовку (шаблон) модуля компонента. Текст этого модуля приведен в листинге:
unit NkEdit;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, StdCtrls;
type
TEdit1 = class(TEdit)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TNkEdit]);
end;
end.
В объявлении нового класса указан только тип родительского класса. В раздел реализации помещена процедура Register, которая используется во время установки созданного программистом компонента на указанную вкладку палитры компонентов Delphi для регистрации нового класса.
В сформированное Delphi объявление класса нового компонента нужно внести дополнения: объявить свойство, поле данных этого свойства, функцию доступа к полю данных, процедуру установки значения поля данных, конструктор и деструктор. Если на некоторые события компонент должен реагировать не так, как базовый, то в объявление класса нужно поместить описание соответствующих процедур обработки событий.
В следующем листинге приведен текст модуля компонента NkEdit после внесения всех необходимых изменений.
unit NkEdit;
interface
uses
Windows, Messages, SysUtils,
Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TNkEdit = class(TEdit)
private
FNumb: single; // число, находящееся в поле редактирования
// Это описание функции доступа
// и процедуры установки поля FNumb
function GetNumb: single;
procedure SetNumb(value: single);
protected
procedure KeyPress(var Key: Char); override;
public
published
constructor Create(AOwner: TComponent);
// свойство компонента
override; property Numb: single read GetNumb write SetNumb;
end;
procedure Register;
implementation
// процедура регистрации компонента
procedure Register;
begin
RegisterComponents('Samples', [TNkEdit]);
end;
// конструктор компонента
constructor TNkEdit.Create(AOwner: TComponent);
begin
// don't forget to call the ancestors' constructor
inherited Create(AOwner);
end;
// функция доступа к полю FNumb
function TNkEdit.GetNumb: single;
begin
try // поле Text может быть пустым Result:=StrToFloat(text); except
on EConvertError do
begin
Result := 0; text: = ' ';
end;
end;
end;
// процедура записи в поле FNumb
procedure TNkEdit.SetNumb(Value: single);
begin
FNumb := Value;
Text := FloatToStr(value);
end;
// процедура обработки события KeyPress
procedure TNkEdit.KeyPress(var key: char);
begin
case key of
'0'..'9', #8, #13: ;
'-': if Length(text) <> 0 then key := #0;
else
if not ((key = DecimalSeparator) and
(Pos(DecimalSeparator, text) = 0))
then key := #0;
end;
inherited KeyPress(key);
// вызов процедуры обработки события
// OnKeyPress родительского класса
end;
end.
В описание класса TNkEdit добавлено объявление свойства Numb, которое представляет собой число, находящееся в поле редактирования. Для хранения Значения свойства Numb используется поле FNumb. Функция GetNumb необходима для доступа к полю FNumb, а процедура setNumb — для установки значения свойства.
Конструктор класса TNkEdit сначала вызывает конструктор родительского класса (TEdit), присваивает значение свойству Text, затем устанавливает значение свойства Numb.
Реакция компонента NkEdit на нажатие клавиши клавиатуры определяется процедурой обработки события TNkEdit.KeyPress, которая замещает соответствующую процедуру базового класса. В качестве параметра процедура TNkEdit.KeyPress получает код нажатой клавиши. Перед вызовом процедуры обработки события OnKeyPress родительского класса код нажатой клавиши проверяется на допустимость. Если нажата недопустимая для компонента NkEdit клавиша, то код символа заменяется на ноль. Допустимыми для компонента NkEdit являются цифровые клавиши, разделитель целой и дробной частей числа (в зависимости от настройки Windows: точка или запятая), "минус", (позволяет удалить ошибочно введенный символ) и .
Здесь следует вспомнить, что в тексте программы дробная часть числовой константы отделяется от целой части точкой. Во время работы программы при вводе исходных данных пользователь должен использовать тот символ, который задан в настройке Windows. В качестве разделителя обычно применяют запятую (это для России стандартная настройка) или точку. Приведенная процедура обработки события OnKeyPress учитывает, что настройка Windows может меняться, и поэтому введенный пользователем символ сравнивается не с константой, а со значением глобальной переменной
DecimalSeparator, которая содержит символ-разделитель, используемый в Windows в данный момент.
После ввода текста модуля компонента модуль нужно откомпилировать и сохранить.
Мастер создания компонент.
unit ExpCompF;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, ComCtrls, Buttons, ExtCtrls, Menus, FileCtrl, ExptIntf;
type
// expert form
TCompWizForm = class(TForm)
PageControl1: TPageControl;
SheetMain: TTabSheet;
SheetProperties: TTabSheet;
SheetSingle: TTabSheet;
Label1: TLabel;
EditClassName: TEdit;
Label2: TLabel;
Label3: TLabel;
EditUnitName: TEdit;
StringGridProps: TStringGrid;
Label4: TLabel;
Label5: TLabel;
Label9: TLabel;
Label10: TLabel;
EditPropName: TEdit;
CheckRead: TCheckBox;
CheckWrite: TCheckBox;
EditDefault: TEdit;
RadioAccess: TRadioGroup;
BtnRevert: TBitBtn;
BtnPrev: TBitBtn;
BtnNext: TBitBtn;
PopupGrid: TPopupMenu;
NewProperty1: TMenuItem;
RemoveProperty1: TMenuItem;
Label6: TLabel;
LabelPropNo: TLabel;
SheetPreview: TTabSheet;
MemoPreview: TMemo;
Panel1: TPanel;
BitBtnGenerate: TBitBtn;
BitBtnClose: TBitBtn;
BitBtnExit: TBitBtn;
ComboParentClass: TComboBox;
ComboPage: TComboBox;
ComboTypeName: TComboBox;
procedure FormCreate(Sender: TObject);
procedure StringGridPropsSelectCell(Sender: TObject; Col, Row: Longint;
var CanSelect: Boolean);
procedure PageControl1Change(Sender: TObject);
procedure BtnPrevClick(Sender: TObject);
procedure NewProperty1Click(Sender: TObject);
procedure RemoveProperty1Click(Sender: TObject);
procedure BtnNextClick(Sender: TObject);
procedure BtnRevertClick(Sender: TObject);
procedure EditClassNameExit(Sender: TObject);
procedure PageControl1Changing(Sender: TObject;
var AllowChange: Boolean);
procedure BitBtnGenerateClick(Sender: TObject);
procedure BitBtnCloseClick(Sender: TObject);
private
CurrProp, TotProps: Integer;
function GetProp(Prop: Integer): string;
function GetType(Prop: Integer): string;
function GetRead(Prop: Integer): string;
function GetWrite(Prop: Integer): string;
function GetAccess(Prop: Integer): string;
function GetDefault(Prop: Integer): string;
function PropertyDefinition(I: Integer): string;
public
procedure UpdateSingle;
procedure UpdateGrid;
procedure FillMemo;
end;
// standard expert
TExtCompExp = class(TIExpert)
public
function GetStyle: TExpertStyle; override;
function GetName: string; override;
function GetAuthor: string; override;
function GetComment: string; override;
function GetPage: string; override;
function GetGlyph: HICON; override;
function GetState: TExpertState; override;
function GetIDString: string; override;
function GetMenuText: string; override;
procedure Execute; override;
end;
// project expert
TPrjExtCompExp = class(TExtCompExp)
public
function GetStyle: TExpertStyle; override;
function GetName: string; override;
function GetIDString: string; override;
end;
var
CompWizForm: TCompWizForm;
procedure Register;
implementation
{$R *.DFM}
uses
Registry;
// extended component expert form
function TCompWizForm.GetProp(Prop: Integer): string;
begin
Result := StringGridProps.Cells[0, Prop];
end;
function TCompWizForm.GetType(Prop: Integer): string;
begin
Result := StringGridProps.Cells[1, Prop];
end;
function TCompWizForm.GetRead(Prop: Integer): string;
begin
Result := StringGridProps.Cells[2, Prop];
end;
function TCompWizForm.GetWrite(Prop: Integer): string;
begin
Result := StringGridProps.Cells[3, Prop];
end;
function TCompWizForm.GetAccess(Prop: Integer): string;
begin
Result := StringGridProps.Cells[4, Prop];
end;
function TCompWizForm.GetDefault(Prop: Integer): string;
begin
Result := StringGridProps.Cells[5, Prop];
end;
procedure TCompWizForm.UpdateSingle;
begin
LabelPropNo.Caption := IntToStr(CurrProp);
EditPropName.Text := GetProp(CurrProp);
ComboTypeName.Text := GetType(CurrProp);
EditDefault.Text := GetDefault(CurrProp);
CheckRead.Checked := GetRead(CurrProp) <> '';
CheckWrite.Checked := GetWrite(CurrProp) <> '';
if GetAccess(CurrProp) <> '' then
RadioAccess.ItemIndex :=
RadioAccess.Items.IndexOf(GetAccess(CurrProp));
end;
procedure TCompWizForm.UpdateGrid;
begin
with StringGridProps do
begin
Cells[0, CurrProp] := EditPropName.Text;
Cells[1, CurrProp] := ComboTypeName.Text;
if CheckRead.Checked then
Cells[2, CurrProp] := 'Get' + EditPropName.Text
else
Cells[2, CurrProp] := '';
if CheckWrite.Checked then
Cells[3, CurrProp] := 'Set' + EditPropName.Text
else
Cells[3, CurrProp] := '';
if RadioAccess.ItemIndex >= 0 then
Cells[4, CurrProp] := RadioAccess.Items[
RadioAccess.ItemIndex];
Cells[5, CurrProp] := EditDefault.Text;
Row := CurrProp;
end;
end;
procedure TCompWizForm.FormCreate(Sender: TObject);
var
nMod, nComp: Integer;
CompClass: TClass;
Reg: TRegistry;
begin
with StringGridProps do
begin
Cells[0, 0] := 'property';
Cells[1, 0] := 'type';
Cells[2, 0] := 'read';
Cells[3, 0] := 'write';
Cells[4, 0] := 'access';
Cells[5, 0] := 'default';
end;
CurrProp := 1;
TotProps := 1;
PageControl1.ActivePage := SheetMain;
// get the list of palette pages
Reg := TRegistry.Create;
if Reg.OpenKey(
'Software\Borland\Delphi\3.0\Palette',
False) then
Reg.GetValueNames(ComboPage.Items);
Reg.Free;
// special code for the expert
if ToolServices <> nil then
begin
// get the list of installed components
// plus their parent classes
for nMod := 0 to
ToolServices.GetModuleCount - 1 do
for nComp := 0 to
ToolServices.GetComponentCount(nMod) - 1 do
begin
ComboParentClass.Items.Add(
ToolServices.GetComponentName(nMod, nComp));
try
CompClass := FindClass(ToolServices.
GetComponentName(nMod, nComp)).ClassParent;
while (CompClass <> TComponent) and
(ComboParentClass.Items.IndexOf(
CompClass.ClassName) = -1) do
begin
ComboParentClass.Items.Add(
CompClass.ClassName);
CompClass := CompClass.ClassParent;
end;
except on E: Exception do
ShowMessage(E.Message);
end;
end;
end; // end of special expert code
end;
procedure TCompWizForm.StringGridPropsSelectCell(Sender: TObject; Col,
Row: Longint; var CanSelect: Boolean);
begin
if (Row <> 0) then
CurrProp := Row;
end;
procedure TCompWizForm.PageControl1Change(Sender: TObject);
begin
if PageControl1.ActivePage = SheetSingle then
UpdateSingle
else
UpdateGrid;
if PageControl1.ActivePage = SheetPreview then
FillMemo;
end;
procedure TCompWizForm.BtnPrevClick(Sender: TObject);
begin
UpdateGrid;
if CurrProp > 1 then
begin
Dec(CurrProp);
UpdateSingle;
end;
end;
procedure TCompWizForm.NewProperty1Click(Sender: TObject);
begin
Inc(TotProps);
StringGridProps.RowCount := StringGridProps.RowCount + 1;
end;
procedure TCompWizForm.RemoveProperty1Click(Sender: TObject);
var
I: Integer;
begin
if MessageDlg('Are you sure you want to delete the ' +
StringGridProps.Cells[0, CurrProp] + ' property?',
mtConfirmation, [mbYes, mbNo], 0) = idYes then
// set the line to ''
for I := 0 to 5 do
StringGridProps.Cells[I, CurrProp] := '';
end;
procedure TCompWizForm.BtnNextClick(Sender: TObject);
begin
UpdateGrid;
if CurrProp < TotProps then
begin
Inc(CurrProp);
UpdateSingle;
end
else if MessageDlg('Do you want to add a new property?',
mtConfirmation, [mbYes, mbNo], 0) = idYes then
begin
NewProperty1Click(self);
Inc(CurrProp);
UpdateSingle;
end;
end;
procedure TCompWizForm.BtnRevertClick(Sender: TObject);
begin
// re-update the value, loosing changes
UpdateSingle;
end;
function TCompWizForm.PropertyDefinition(I: Integer): string;
begin
Result := 'property ' + GetProp(I) +
': ' + GetType(I);
if GetRead(I) <> '' then
Result := Result + ' read ' + GetRead(I)
else
Result := Result + ' read f' + GetProp(I);
if GetWrite(I) <> '' then
Result := Result + ' write ' + GetWrite(I)
else
Result := Result + ' write f' + GetProp(I);
if GetDefault(I) <> '' then
Result := Result + ' default ' + GetDefault(I);
Result := Result + ';'
end;
procedure TCompWizForm.FillMemo;
var
I: Integer;
begin
with MemoPreview.Lines do
begin
Clear;
BeginUpdate;
// intestation
Add('unit ' + EditUnitName.Text + ';');
Add('');
Add('interface');
Add('');
Add('uses');
Add(' Windows, Messages, SysUtils, Classes, Graphics,');
Add(' Controls, Forms, Dialogs, StdCtrls;');
Add('');
Add('type');
Add(' ' + EditClassName.Text +
' = class(' + ComboParentClass.Text + ')');
Add(' private');
// add a field for each property
Add(' {data fields for properties}');
for I := 1 to TotProps do
if GetProp(I) <> '' then
Add(' f' + GetProp(I) + ': ' +
GetType(I) + ';');
// add get functions and set procedures
Add(' protected');
Add(' {set and get methods}');
for I := 1 to TotProps do
begin
if GetRead(I) <> '' then
Add(' function ' + GetRead(I) +
': ' + GetType(I) + ';');
if GetWrite(I) <> '' then
Add(' procedure ' + GetWrite(I) +
'(Value: ' + GetType(I) + ');');
end;
// add public and published properties,
// plus the constructor
Add(' public');
for I := 1 to TotProps do
if (GetProp(I) <> '') and
(GetAccess(I) = 'public') then
Add(' ' + PropertyDefinition(I));
Add(' constructor Create (AOwner: TComponent); override;');
Add(' published');
for I := 1 to TotProps do
if (GetProp(I) <> '') and
(GetAccess(I) = 'published') then
Add(' ' + PropertyDefinition(I));
Add(' end;');
Add('');
Add('procedure Register;');
Add('');
Add('implementation');
Add('');
// constructor
Add('constructor ' + EditClassName.Text +
'.Create (AOwner: TComponent);');
Add('begin');
Add(' inherited Create (AOwner);');
Add(' // set default values');
for I := 1 to TotProps do
if (GetProp(I) <> '') and (GetDefault(I) <> '') then
Add(' f' + GetProp(I) + ' := ' + GetDefault(I) + ';');
Add('end;');
Add('');
// rough code of the functions
Add('{property access functions}');
Add('');
for I := 1 to TotProps do
begin
if GetRead(I) <> '' then
begin
Add('function ' + EditClassName.Text + '.' +
GetRead(I) + ': ' + GetType(I) + ';');
Add('begin');
Add(' Result := f' + GetProp(I) + ';');
Add('end;');
Add('');
end;
if GetWrite(I) <> '' then
begin
Add('procedure ' + EditClassName.Text + '.' +
GetWrite(I) + '(Value: ' + GetType(I) + ');');
Add('begin');
Add(' if Value <> f' + GetProp(I) + ' then');
Add(' begin');
Add(' f' + GetProp(I) + ' := Value;');
Add(' // to do: add side effect as: Invalidate;');
Add(' end;');
Add('end;');
Add('');
end;
end;
Add('{registration procedure}');
Add('');
Add('procedure Register;');
Add('begin');
Add(' RegisterComponents (''' + ComboPage.Text +
''', [' + EditClassName.Text + ']);');
Add('end;');
Add('');
Add('end.');
EndUpdate;
end;
end;
procedure TCompWizForm.EditClassNameExit(Sender: TObject);
begin
// copies the initial part of the class name
// (8 characters, but not the initial 'T')
if EditUnitName.Text = '' then
EditUnitName.Text := Copy(EditClassName.Text, 2, 8);
end;
procedure TCompWizForm.PageControl1Changing(Sender: TObject;
var AllowChange: Boolean);
begin
if PageControl1.ActivePage = SheetMain then
if (EditClassName.Text = '') or (ComboParentClass.Text = '')
or (ComboPage.Text = '') then
begin
AllowChange := False;
MessageDlg('You must fill the main form data first',
mtError, [mbOK], 0);
end;
end;
procedure TCompWizForm.BitBtnGenerateClick(Sender: TObject);
var
Directory, Filename: string;
begin
if SelectDirectory(Directory,
[sdAllowCreate, sdPerformCreate, sdPrompt], 0) then
begin
Filename := Directory + '\' +
EditUnitName.Text + '.pas';
// checks if the file already exists
if not FileExists(Filename) then
// save the file
MemoPreview.Lines.SaveToFile(Filename)
else
MessageDlg('The file ' + Filename +
' already exists'#13#13 +
'Choose a new unit name in the Main page'#13 +
'or select a new directory for the file',
mtError, [mbOK], 0);
// special code for the expert
if ToolServices <> nil then
// open the component file as a project
ToolServices.OpenProject(Filename);
end;
end;
procedure TCompWizForm.BitBtnCloseClick(Sender: TObject);
begin
// alternative code (modal expert form - main window)
if MessageDlg('Are you sure you want to quit the'#13 +
'Extended Component Wizard, loosing your work?',
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
begin
ModalResult := mrCancel;
Close;
end;
end;
// ***********************************
// standard + project component expert
// ***********************************
function TExtCompExp.GetStyle: TExpertStyle;
begin
Result := esStandard;
end;
function TPrjExtCompExp.GetStyle: TExpertStyle;
begin
Result := esProject;
end;
function TExtCompExp.GetName: string;
begin
Result := 'Standard Extended Component Wizard'
end;
function TPrjExtCompExp.GetName: string;
begin
Result := 'Project Extended Component Wizard'
end;
function TExtCompExp.GetAuthor: string;
begin
Result := 'Marco and Tim';
end;
function TExtCompExp.GetComment: string;
begin
Result := 'Extended Component Wizard';
end;
function TExtCompExp.GetPage: string;
begin
Result := 'Projects';
end;
function TExtCompExp.GetGlyph: HICON;
begin
Result := LoadIcon(HInstance,
MakeIntResource('EXTCOMPEXP'));
end;
function TExtCompExp.GetState: TExpertState;
begin
Result := [esEnabled];
end;
function TExtCompExp.GetIDString: string;
begin
Result := 'DDHandbook.ExtCompExp'
end;
function TPrjExtCompExp.GetIDString: string;
begin
Result := 'DDHandbook.PrjExtCompExp';
end;
function TExtCompExp.GetMenuText: string;
begin
Result := '&Extended Component Wizard...';
end;
procedure TExtCompExp.Execute;
begin
// try closing the project
if ToolServices.CloseProject then
begin
CompWizForm := TCompWizForm.Create(Application);
try
CompWizForm.ShowModal;
finally
CompWizForm.Free;
end;
end;
end;
// include icon
{$R ECEICON.RES}
// registration
procedure Register;
begin
RegisterLibraryExpert(TExtCompExp.Create);
RegisterLibraryExpert(TPrjExtCompExp.Create);
end;
end.
Скачать весь проект
Создание консольного приложения.
Автор: Павел А теперь забудьте обо всех этих кнопочках, пиктограммах и пропахших мышами приложениях - настоящие программисты и пользователи обожают текстовый режим! Если же говорить серьезно, иногда программы в текстовом режиме могут быть полезными. Примерам таких программ несть числа, и основная проблема всегда заключалась в том, что они запускались в окне DOS и не имели доступа к Windows API или к таким ресурсам, как принтеры и память (не говоря уже о том, что это были 16-разрядные приложения с 640-килобайтовым ограничением на используемую память). Теперь, когда Delphi поддерживает создание консольных приложений, можно создавать 32-разрядные текстовые приложения с использованием линейной модели памяти и с возможностью работать с Windows API и применять ресурсы Обычно консольные приложения используются, когда не нужно вводить информацию большого объема и требования к интерфейсу сведены к минимуму. Ну и заметим к тому же, что простенькое "Hello, world!", созданное путем размещения компонента TLabel в форме, будет иметь размер около 150 Кбайт, в то время как консольное "Hello, world!" уложится в 10... Пример консольного приложения Лучший способ изучить консольные приложения- создать пресловутое "Hello, world!". Для создания его вручную сделайте следующее. 1. Выберите команду File/New Application. 2. Выберите команду File/Remove From Project, и появится диалоговое окно, Remove From Project, показанное на рис. 1.15. 3. В проекте содержится один модуль формы. Выберете его и щелкните на кнопке ОК. Появится диалоговое окно Save changes to Unit1.pas? 4. Щелкните на кнопке No, и форма будет удалена из проекта. Сохраните проект как EgConsoleHello.Хотя мы создаем "бесформенное" приложение, оно все еще не является консольным и использует GUI, а значит, сравнимо по размеру с бронтозавром. Выберите команду View/Project Source, и в редакторе появится следующий текст.
program EgConsoleHello;
uses
Forms;
{$R *.RES}
begin
Application.Initialize;
Application.Run;
end;
Этого слишком много, чтобы быть достаточным. Вы видите, что подключен модуль Forms, однако он не используется, поэтому данную строку можно удалить. Строки с Application используются для инициализации OLE-сервера и вывода главной формы. Поскольку мы не используем ни того, ни другого, удалите и эти строки. Последнее действие - объяснить компилятору, что мы хотим создать обычное, простое, незамысловатое консольное приложение. Этого можно достичь с помощью команды $APPTYPE. Код в результате будет выглядеть так.
program EgConsoleHello;
{$APPTYPE CONSOLE}
{$R *.RES}
begin
end;
Ax да! Мы же собирались вывести свое приветствие! Для этого добавьте между begin и end строку.
WriteLn ('Hello, world!');
Сохраните, скомпилируйте и запустите проект из командной строки. Надеюсь, вам понравилось? И еще одно замечание - консольные приложения используют стандартные потоки ввода-вывода, а значит, вы можете использовать функции Read, ReadLn, Write и WriteLn.
Функции Windows API для консольного приложения
Вы можете делать гораздо больше в консольном приложении, чем просто считывать и выводить текст. Вам доступно около 40 функций Windows API для работы с дисплеем, например изменение атрибутов выводимых символов или изменение размеров консоли.
В листинге 1.1 изменяется текст, выводимый в заголовке консольного окна. Вы можете найти этот пример на дополнительно распространяемой дискете в папке EgConsoleTitle.
Листинг 1.1. Изменение заголовка консольного окна.
program EgConsoleTitle;
{$APPTYPE CONSOLE}
uses
Windows, SysUtils;
{$R *.RES}
var
sNewTitle, sErrMsg: string;
begin
sNewTitle := 'Welcome to Con5ole World';
if not SetConsoleTitle(PChar(sNewTitle)) then
begin
sErrMsg := 'Unable to set caption - ' + SysErrorMessage(GetLastError);
MessageBox(0, PChar(sErrMsg), 'Error', MB_ICONEXCLAMATION + MB_OK);
end;
ReadLn;
end.
Здесь функция API SetConsoleTitle возвращает False, если назначить новый заголовок невозможно. GetLastError возвращает числовое значение последней ошибки API, которое SysErrorMessage конвертирует в строку для вывода на экран.
Совет: Поставляемая с Delphi система справки по Win32 содержит функции консольного API. Для доступа к ним выведите пункт Console Reference и щелкните на кнопке.
Создание консольных приложений.
| Автор: Михаил Чумак |
| Переустановка Windows - как разморозка холодильника. Помогает, но ненадолго... |
Этот код был использован для вывода результатов работы программы проверки (неважно чего) чтобы не приходилось смотреть файл с результатами. Главная проблема была в том, что консоль (если запуск был из Windows) оставалась висеть позади формы до её закрытия. Вреда конечно никакого, но не приятно. Если же запуск из Нортона или т.п., то всё идёт нормально.
program MyProgram;
{$APPTYPE CONSOLE}
uses
Windows, Forms, Dialogs, SysUtils, StdCtrls, Controls; // и (или) т.п.
...
var
...
SH, SW: integer;
MainForm: TForm; // если нужна форма
Memo: TMemo;
// могут быть также любые другие визуальные компоненты
...
// здесь могут быть процедуры и функции, т.е вс? как в обычном Паскале
begin
... // здесь какой-то код
{ а здесь, перед выводом формы, есть два пути:}
{ так}
// Отцепиться от консоли, т.е она просто исчезнет (в случае запуска из Windows)
// и останется только форма
FreeConsole;
{ или так}
// Handle:= GetForegroundWindow; // Получить Handle консоли
// ShowWindow(Handle, SW_HIDE); // Спрятать консоль
// а в конце, перед завершением
// ShowWindow(Handle, SW_SHOW); // Показать консоль
{ для помещения формы в центр экрана}
SH := Screen.Height;
SW := Screen.Width;
MainForm := TForm.Create(nil);
with MainForm do
try
BorderStyle := bsSizeable;
Height := 390;
Width := 390;
Left := (SW - Width) div 2;
Top := (SH - Height) div 2;
Caption := 'Моя программа';
// здесь могут быть и другие компоненты
Memo := TMemo.Create(MainForm);
with Memo do
begin
Parent := MainForm;
Align := alClient;
BorderStyle := bsNone;
Font.Name := 'Courier New Cyr';
Font.Size := 9;
ScrollBars := ssVertical;
Lines.LoadFromFile('MyProgram.txt');
end;
ShowModal;
finally
Free;
end;
{ или можно вывести сообщение, например в случае неудачи (или наоборот)}
with CreateMessageDialog('Текст сообщения', mtInformation, [mbOk]) do
try
Caption := 'Заголовок';
ShowModal;
finally
Free;
end;
...
// это для второго пути, иначе она так и останется висеть св?рнутой
// ShowWindow(Handle, SW_SHOW); // Показать консоль
end.
|
Как создавать не квадратные формы и контролы.
Всё, что нам нужно, это HRGN и дескриптор (handle) элемента управления. SetWindowRgn имеет три параметра: дескриптор окна, которое будем менять, дескритор региона и булевый (boolean) параметр, который указывает - перерисовывать или нет после изменения. Как только у нас есть дескриптор и регион, то можно вызвать SetWindowRgn(Handle, Region, True) и вуаля!
Заметьте, что Вы не должны освобождать регион при помощи DeleteObject, так как после вызова SetWindowRgn владельцем региона становится операционная система.
function BitmapToRgn(Image: TBitmap): HRGN;
var
TmpRgn: HRGN;
x, y: integer;
ConsecutivePixels: integer;
CurrentPixel: TColor;
CreatedRgns: integer;
CurrentColor: TColor;
begin
CreatedRgns := 0;
Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
inc(CreatedRgns);
if (Image.Width = 0) or (Image.Height = 0) then
exit;
for y := 0 to Image.Height - 1 do
begin
CurrentColor := Image.Canvas.Pixels[0,y];
ConsecutivePixels := 1;
for x := 0 to Image.Width - 1 do
begin
CurrentPixel := Image.Canvas.Pixels[x, y];
if CurrentColor = CurrentPixel then
inc(ConsecutivePixels)
else
begin
// Входим в новую зону
if CurrentColor = clWhite then
begin
TmpRgn := CreateRectRgn(x - ConsecutivePixels, y, x, y + 1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
CurrentColor := CurrentPixel;
ConsecutivePixels := 1;
end;
end;
if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
MaskBmp: TBitmap;
begin
MaskBmp := TBitmap.Create;
try
MaskBmp.LoadFromFile('c:\Мои документы\DW.bmp');
Height := MaskBmp.Height;
Width := MaskBmp.Width;
// ОС владеет регионом, после вызова SetWindowRgn
SetWindowRgn(Self.Handle, BitmapToRgn(MaskBmp), True);
finally
MaskBmp.Free;
end;
end;
|
Создание кросс-таблицы.
Автор: Michael Lant Вы можете создать их в DBD как QBE-шки. Пользуясь компонентом TQBE для загрузки одной из библиотек, вы можете непосредственно использовать QBE-шки в вашем Delphi-приложении. В следующем примере предполагается, что каждый служащий каждый день сообщает оператору о своем месторасположении. Код определяет начало трудовой недели с понедельника плюс еще четыре рабочих дня с показом соответствующей даты. Строки с 1 по 5 в QBE1.QBE (нулевая описательная) в нижеприведенной процедуре заменяются кодом. Результат всего этого в том, что строка (если имеется) для каждого человека отображается в колонке установленного результата и значение 'X' включается если только запись существует. Для создания агрегатной таблицы можно было бы подсчитывать результаты. Текст в QBE1.QBE :
CALLIN.DB | StaffNo | Date |
| _join1 | 3/10/95 |
| _join2 | 3/11/95 |
| _join3 | 3/12/95 |
| _join4 | 3/13/95 |
| _join5 | 3/14/95 |
XTAB.DB | StaffNo |Mon |Tue |Wed |Thu |Fri |
| _join1 |changeto X| | | | |
| _join2 | |changeto X| | | |
| _join3 | | |changeto X| | |
| _join4 | | | |changeto X| |
| _join5 | | | | |changeto X|
procedure TCallInReport.ButtonSelectClick(Sender: TObject);
begin
TableXTab.active := false;
if EditWeekOf.Text = '' then
begin
messageBeep(0);
messageDlg('Для выбора записи необходима дата.', mtInformation, [mbOK], 0);
exit;
end;
Screen.Cursor := crHourGlass;
dtWeekOf := StrToDate(EditWeekOf.Text);
dtStartDate := dtWeekOf - DayOfWeek(dtWeekOf) + 2;
TableXTab.active := false;
TableXTab.EmptyTable;
TableXTab.active := true;
{
Замените строки 1 - 5 в QBE1.QBE реальными датами
}
QBE1.QBE.Strings[1] := ' | _join1 | ' + DateToStr(dtStartDate) + ' | ';
QBE1.QBE.Strings[2] := ' | _join2 | ' + DateToStr(dtStartDate + 1) + ' | ';
QBE1.QBE.Strings[3] := ' | _join3 | ' + DateToStr(dtStartDate + 2) + ' | ';
QBE1.QBE.Strings[4] := ' | _join4 | ' + DateToStr(dtStartDate + 3) + ' | ';
QBE1.QBE.Strings[5] := ' | _join5 | ' + DateToStr(dtStartDate + 4) + ' | ';
try
QBE1.active := true;
except
on E: EDataBaseError do
begin
if E.Message = 'Ошибка создания дескриптора курсора' then
{ Ничего не делайте. Делая TQBE активной, мы пытаемся создать курсор.
Это вызывает исключительную ситуацию, которую мы должны перехватить.
Пока я не нашел способа как отделаться от исключения. }
else
begin
Screen.Cursor := crDefault;
raise;
end;
end;
else
Screen.Cursor := crDefault;
raise;
end;
TableXTab.refresh;
Screen.Cursor := crDefault;
TableXTab.active := true;
end;
|
Как создать dBASE таблицу во время выполнения.
Данная процедура полезна для создания временных таблиц :
procedure MakeDataBase;
begin
with TTable.Create(nil) do
begin
DatabaseName := 'c:\temp'; (* alias *)
TableName := 'test.dbf';
TableType := ttDBase;
with FieldDefs do
begin
Add('F_NAME', ftString,20,false);
Add('L_NAME', ftString,30,false);
end;
CreateTable;
{ create a calculated index }
with IndexDefs do
begin
Clear;
{ don't forget ixExpression in calculated indexes! }
AddIndex('name','Upper(L_NAME)+Upper(F_NAME)',[ixExpression]);
end;
end;
end;
|
Создание указанного пути.
Автор: VID WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание указанного пути
Функция CreateDirEx создаёт указанный путь DIR. В отличии от функции CreateDir,
для CreateDirEx нет необходимости существования каталога, в которому будет
размещаться создаваемый новый каталог.
Т.е., пусть существует путь
C:\Folder
Нам надо создать путь C:\Folder\Level1\Level2
При использовании CreateDir пришлось бы дважды вызывать эту функцию, сначала
для создания C:\Folder\Level1\ а затем для C:\Folder\Level1\Level2.
В случае работы с функцией CreateDirEx ей достаточно лишь передать параметр:
CreateDirEx('C:\Folder\Level1\Level2') и необходимый путь будет создан,
в независимости от того существовала вообще ли до этого папка C:\Folder
Зависимости: FileCtrl, SysUtils
Автор: VID, snap@iwt.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 28 января 2003 г.
***************************************************** }
function CreateDirEx(Dir: string): Boolean;
var
I, L: Integer;
CurDir: string;
begin
if ExcludeTrailingBackslash(Dir) = '' then
exit;
Dir := IncludeTrailingBackslash(Dir);
L := Length(Dir);
for I := 1 to L do
begin
CurDir := CurDir + Dir[I];
if Dir[I] = '\' then
begin
if not DirectoryExists(CurDir) then
if not CreateDir(CurDir) then
Exit;
end;
end;
Result := True;
end;
Пример использования:
CreateDirEx(AnyFolderName), // где AnyFolderName - любой допустимый в файловой системе путь.
Как создать новый DSN из программы.
Автор: Vit WEB-сайт: http://forum.vingrad.ru
type
TSQLConfigDataSource =
function(hwndParent: Integer;
fRequest: Integer;
lpszDriverString: string;
lpszAttributes: string): Smallint; stdcall;
function SQLConfigDataSource(hwndParent: Integer; fRequest: Integer;
lpszDriverString: string; lpszAttributes: string): Integer; stdcall;
var
func: TSQLConfigDataSource;
OdbccpHMODULE: HMODULE;
begin
OdbccpHMODULE := LoadLibrary('c:\WINDOWS\SYSTEM\odbccp32.dll');
if OdbccpHMODULE = 0 then
raise Exception.Create(SysErrorMessage(GetLastError));
func := GetProcAddress(OdbccpHMODULE, PChar('SQLConfigDataSource'));
if @func = nil then
raise Exception.Create('Error Getting adress for SQLConfigDataSource' +
SysErrorMessage(GetLastError));
Result := func(hwndParent, fRequest, lpszDriverString, lpszAttributes);
FreeLibrary(OdbccpHMODULE);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if SQLConfigDataSource(0, 1, 'Microsoft Excel Driver (*.xls)',
Format('DSN=%s;DBQ=%s;DriverID=790', ['MyDSNName',
'c:\temp\temp.xls'])) <> 1 then
ShowMessage('Cannot create ODBC alias');
end;
PS: Если вы собираетесь работать с этим DSN через BDE, то надо закрыть и открыть Session, иначе он не будет доступен.
Создание DTD для объекта (XML).
| - Дорогая, у меня для тебя сюрприз: я открыл новый ужасный вирус и назвал его твоим именем! |
За созданием кода для сериализации и десериализации объектов в Delphi логично перейти к рассмотрению вопроса о возможности генерации соответствующего DTD для сохраняемых в XML классов. DTD понадобится нам, если мы захотим провести проверку XML документа на корректность и допустимость с помощью одного из XML анализаторов. Работа с анализатором MSXML рассмотрена в статье Загрузка и анализ документа XML..
Автоматическое создание DTD очень простая задача. У нас все для этого есть. Необходимо рекурсивно пройтись по всем свойствам объекта и сгенерировать модели содержания для каждого тега. При сериализации в XML мы не использовали атрибутов, а значит мы не сможем в DTD установить контроль над содержанием конкретных элементов. Остается только определить модель содержания для XML, т.е. вложенность тегов в друг друга.
Создадим процедуру GenerateDTD(), которая обеспечит запись формируемого DTD для заданного объекта Component в заданный поток Stream. Она создает список DTDList, в котором будут накапливаться атрибуты DTD, после чего передает всю черновую работу процедуре GenerateDTDInternal().
{
Процедура генерации DTD для заданного объекта в
соответсвии с published интерфейсом его класса.
Вход:
Component - объект
Выход:
текст DTD в поток Stream
}
procedure GenerateDTD(Component: TObject; Stream: TStream);
var
DTDList: TStringList;
begin
DTDList := TStringList.Create;
try
GenerateDTDInternal(Component, DTDList, Stream, Component.ClassName);
finally
DTDList.Free;
end;
end;
|
Следующий код просматривает свойства объекта, составляет их список, а затем формирует из этого модель содержания для элемента. Для свойств классовых типов используется рекурсия. Поскольку при сериализации объекта мы не использовали атрибутов, то определений для них создавать нет необходимости.
Для всех неклассовых типов модель содержания это - (#PCDATA). К примеру, свойство объекта Tag: integer превращается в .
Отдельно подходим к коллекциям. Для них необходимо указать на множественность дочернего тега элемента коллекции. Например, для свойства TMyCollection модель содержания может выглядеть так: .
{
Внутренняя рекурсивная процедура генерации DTD для заданного объекта.
Вход:
Component - объект
DTDList - список уже определенных элементов DTD
для предотвращения повторений.
Выход:
текст DTD в поток Stream
}
procedure GenerateDTDInternal(Component: TObject; DTDList: TStrings;
Stream: TStream; const ComponentTagName: string);
var
PropInfo: PPropInfo;
TypeInf, PropTypeInf: PTypeInfo;
EnumInfo: PTypeInfo;
TypeData: PTypeData;
i, j: integer;
AName, PropName, sPropValue, s, TagContent: string;
PropList: PPropList;
NumProps: word;
PropObject: TObject;
const
PCDATA = '#PCDATA';
procedure addElement(const ElementName: string; Data: string);
var
s: string;
begin
if DTDList.IndexOf(ElementName) <> -1 then
exit;
DTDList.Add(ElementName);
s := 'then
Data := PCDATA;
s := s + '(' + Data + ')>'#13#10;
Stream.write(PChar(s)[0], length(s));
end;
begin
{ Playing with RTTI }
TypeInf := Component.ClassInfo;
AName := TypeInf^.name;
TypeData := GetTypeData(TypeInf);
NumProps := TypeData^.PropCount;
GetMem(PropList, NumProps*sizeof(pointer));
try
{ Получаем список свойств }
GetPropInfos(TypeInf, PropList);
TagContent := '';
for i := 0 to NumProps-1 do
begin
PropName := PropList^[i]^.name;
PropTypeInf := PropList^[i]^.PropType^;
PropInfo := PropList^[i];
{ Пропустить не поддерживаемые типы }
if not (PropTypeInf^.Kind in [tkDynArray, tkArray,
tkRecord, tkInterface, tkMethod]) then
begin
if TagContent <> '' then
TagContent := TagContent + '|';
TagContent := TagContent + PropName;
end;
case PropTypeInf^.Kind of
tkInteger, tkChar, tkFloat, tkString,
tkWChar, tkLString, tkWString, tkVariant,
tkEnumeration, tkSet:
begin
{ Перевод в DTD. Для данных типов модель содержания - #PCDATA }
addElement(PropName, PCDATA);
end;
{
Код был бы полезен при использовании атрибутов
tkEnumeration:
begin
TypeData:= GetTypeData(GetTypeData(PropTypeInf)^.BaseType^);
s := '';
for j := TypeData^.MinValue to TypeData^.MaxValue do
begin
if s <> '' then s := s + '|';
s := s + GetEnumName(PropTypeInf, j);
end;
addElement(PropName, s);
end;
}
tkClass: { Для классовых типов рекурсивная обработка }
begin
PropObject := GetObjectProp(Component, PropInfo);
if Assigned(PropObject)then
begin
{ Для дочерних свойств-классов - рекурсивный вызов }
if (PropObject is TPersistent) then
GenerateDTDInternal(PropObject, DTDList, Stream, PropName);
end;
end;
end;
end;
{ Индивидуальный подход к некоторым классам }
{ Для коллекций необходимо включить в модель содержания тип элемента }
if (Component is TCollection) then
begin
if TagContent <> '' then
TagContent := TagContent + '|';
TagContent := TagContent + (Component as TCollection).ItemClass.ClassName + '*';
end;
{ Добавляем модель содержания для элемента }
addElement(ComponentTagName, TagContent);
finally
FreeMem(PropList, NumProps*sizeof(pointer));
end;
end;
|
Закоментированный код нам не нужен, но он не удален, т.к. он демонстрирует получение списка возможных значений для перечисления (Enumeration) и набора (Set). Это может понадобится, если появится необходимость генерировать свойства в виде атрибутов XML тегов и, соответственно, DTD для возможных значений этих атрибутов.
Создать динамический массив.
Массив, который может менять свой размер во время работы программы, нужен тогда, когда неизвестно количество элементов на стадии разработки программы. Например, Вам не известен размер изображения, которое нужно будет поместить в память.
Этот динамический массив основан на массиве Delphi. Поэтому обращение к нему быстро и удобно. Тип TArray – это массив нужного типа. 128 элементов можно заменить любым другим числом, хоть 0. Повлиять это может только на отладку программы, так как Delphi выведет (если уместится) именно это количество элементов. PArray – это указатель на TArray. При обращении к элементам массива для Delphi главное, чтобы этот элемент существовал в памяти, то есть, чтобы под него была выделена память. А проверять, находится ли номер нужного элемента между 0 и 127 Delphi не будет.
Главным методом объекта является SetCount. Он сделан таким образом, что при изменении количество элементом старые данные не теряются, а новые элементы всегда обнуляются.
Процедура Reset обнуляет все существующие элементы.
Для того чтобы сделать этот массив, например, массивом целых чисел нужно поменять все double на integer или еще что-то.
Если Ваша программа часто обращается к элементам массива, то имеет смысл создать переменную типа PArray и присвоить ей адрес данных (поле p динамического массива), а дальше обращаться к ней, как к самому обыкновенному массиву. Только не забудьте обновлять эту переменную при изменении количества элементов.
type
TForm1 = ...
...
end;
TArray = array [0..127] of double;
PArray = ^TArray;
TDynArray = object
p: PArray;
count: integer;
constructor Create(ACount: integer); { инициализация }
procedure SetCount(ACount: integer); { установка количества элементов }
procedure Reset; { обнуление данных }
destructor Destroy; { уничтожение }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
constructor TDynArray.Create(aCount: integer);
begin
p := nil;
count := 0;
SetCount(ACount);
end;
procedure TDynArray.SetCount(ACount: integer);
var
np: PArray;
begin
if count = ACount then
Exit;
{ память не была выделена }
if p = nil then
begin
{ новое количество элементов в массиве равно 0 }
if ACount then
begin
count := 0;
end
{ новое количество элементов в массиве больше 0 }
else
begin
{ выделение памяти }
GetMem(p, ACount * sizeof(double));
{ обнуление данных }
fillchar(p^, ACount * sizeof(double), 0);
count := ACount;
end;
end
else
begin
{ новое количество элементов в массиве равно 0 }
if ACount then
begin
{ освобождение памяти }
FreeMem(p, count * sizeof(double));
count := 0;
end
else
begin
{ выделение памяти }
GetMem(np, ACount * sizeof(double));
{ требуется увеличить количество элементов }
if ACount > count then
begin
{ перемещение старых данных на новое место }
move(p^, np^, count * sizeof(double));
{ обнуление новых элементов массива }
fillchar(np^[count], (ACount - count) * sizeof(double), 0);
end
else
begin
{ перемещение части старых данных на новое место }
move(p^, np^, ACount * sizeof(double));
end;
{ освобождение старой памяти }
FreeMem(p, count * sizeof(double));
p := np;
count := ACount;
end;
end;
end;
procedure TDynArray.Reset;
begin
{ обнуление данных }
fillchar(p^, count * sizeof(double), 0);
end;
destructor TDynArray.Destroy;
begin
SetCount(0);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
a: TDynArray;
i: integer;
s: string;
begin
a.Create(3);
a.p[0] := 10;
a.p[1] := 20;
{ второй элемент не указывается, но вследствие обнуления
при создании массива он равен 0 }
s := 'Элементы в массиве:';
for i := 0 to a.count - 1 do
s := s + #13#10 + IntToStr(i+1) + ': ' + FloatToStr(a.p[i]);
ShowMessage(s);
a.SetCount(4);
a.p^[3] := 50;
{ значения первых элементов не теряются }
s := 'Элементы в массиве:';
for i := 0 to a.count - 1 do
s := s + #13#10 + IntToStr(i+1) + ': ' + FloatToStr(a.p[i]);
ShowMessage(s);
a.Destroy;
end;
|
Создаём Excel файл без OLE.
const
CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
CXlsEof: array[0..1] of Word = ($0A, 00);
CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
begin
CXlsBof[4] := BuildNumber;
XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;
procedure XlsEndStream(XlsStream: TStream);
begin
XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;
procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;
const AValue: Integer);
var
V: Integer;
begin
CXlsRk[2] := ARow;
CXlsRk[3] := ACol;
XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
V := (AValue shl 2) or 2;
XlsStream.WriteBuffer(V, 4);
end;
procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;
const AValue: Double);
begin
CXlsNumber[2] := ARow;
CXlsNumber[3] := ACol;
XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
XlsStream.WriteBuffer(AValue, 8);
end;
procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
const AValue: string);
var
L: Word;
begin
L := Length(AValue);
CXlsLabel[1] := 8 + L;
CXlsLabel[2] := ARow;
CXlsLabel[3] := ACol;
CXlsLabel[5] := L;
XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
FStream: TFileStream;
I, J: Integer;
begin
FStream := TFileStream.Create('c:\e.xls', fmCreate);
try
XlsBeginStream(FStream, 0);
for I := 0 to 99 do
for J := 0 to 99 do
begin
XlsWriteCellNumber(FStream, I, J, 34.34);
// XlsWriteCellRk(FStream, I, J, 3434);
// XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J]));
end;
XlsEndStream(FStream);
finally
FStream.Free;
end;
end;
|
Динамическое создание полей.
| Автор: Marco Romanini (SysOp) Delphi Tech Support |
| День 1-й. Бог создал свет. День 2-й. Бог создал юзера. День 3-й. Бог создал Дос. День 4-й. Бог создал Windows 3.11 День 5-й. Бог создал Windows День 6-й. Бог создал женщину-юзверя. День 7-й. Бог не в силах был что-то сделать. |
var
I: Integer;
Field: TField;
begin
{ Поля можно добавлять только к неактивному набору данных. }
Table1.Active := False;
{ Распределяем определенные поля если набор данных еще не был активным. }
Table1.FieldDefs.Update;
{ Создаем все поля из определений и добавляем к набору данных. }
for I := 0 to Table1.FieldDefs.Count - 1 do
begin
{ Вот где мы действительно сообщаем набору данных о необходимости создания поля. }
{ Поле "назначается", но нам нужно не это, нам нужна просто ссылка на новое поле. }
Field := Table1.FieldDefs[I].CreateField(Table1);
end;
{ Вот пример того, как вы можете добавить дополнительные, вычисленные поля }
Field := TStringField.Create(Table1);
Field.FieldName := 'Total';
Field.Calculated := True;
Field.DataSet := Table1;
{ Теперь мы можем увидеть наши поля. }
Table1.Active := True;
end;
|
Динамическое создание полей 2.
Автор: Eryk
Как мне определить на лету другое поле подобно команде "Define" в редакторе полей (Fields Editor)? (Калькулируемое поле, другими словами?)Следующий код создаст полный набор 'default' TField для TTable и добавит затем калькулируемое поле:
procedure TForm1.Button1Click(Sender: TObject);
var
f: TField;
i: integer;
begin
Table1.Close;
for i := 0 to Table1.FieldDefs.Count - 1 do
Table1.FieldDefs.Items[i].CreateField(Table1);
f := TStringField.Create(Table1);
f.Name := 'Table1CalcField';
f.FieldName := 'CalcField';
f.DisplayLabel := 'CalcField';
f.Calculated := True;
f.DataSet := Table1;
Table1.Open;
end;
|
...следующий пример создаст два новых TField в TTable, 'базируясь' на TField, определенных в режиме редактирования. Одно из новых полей калькулируемое, другое нет:
procedure TForm1.Button1Click(Sender: TObject); var f1, f2: TField; begin Table1.Close; f1 := TStringField.Create(Table1); f1.Name := 'Table1CalcField'; f1.FieldName := 'CalcField'; f1.DisplayLabel := 'CalcField'; f1.Calculated := True; f1.DataSet := Table1; f2 := TFloatField.Create(Table1); f2.Name := 'Table1Population'; f2.FieldName := 'Population'; f2.DisplayLabel := 'Population'; f2.DataSet := Table1; Table1.Open; end; |
Пример создания FileListBox.
Автор: Mikel WEB-сайт: http://forum.vingrad.ru
{uses ShellApi}
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
s: string;
begin
s := listbox1.Items[SendMessage(ListBox1.Handle, lb_GetCurSel, 0, 0)];
if edit1.Text[length(edit1.text)] <> '\' then
edit1.text := concat(edit1.text + '\');
if (not FileExists(edit1.text + s)) and (s[1] = '[') and (s[length(s)] = ']')
then
DlgDirList(handle,
PChar(edit1.text + copy(s, 2, length(s) - 2)),
ListBox1.Handle,
Edit1.Handle,
faAnyFile
);
if edit1.Text[length(edit1.text)] <> '\' then
edit1.text := concat(edit1.text + '\');
if FileExists(edit1.text + s) then
begin
caption := edit1.text + s;
ShellExecute(handle, 'open', PChar(edit1.text + s), '', 'c:\', sw_show);
end
end;
procedure TForm1.FormShow(Sender: TObject);
begin
edit1.Width := 1024 * 8 - 1;
edit1.Visible := false;
DlgDirList(handle,
PChar('c:\'),
ListBox1.Handle,
Edit1.Handle,
faAnyFile
);
listbox1.Sorted := false;
listbox1.Sorted := true;
end;
Пример создания FileListBox 2.
Автор: Mikel WEB-сайт: http://forum.vingrad.ru
{uses ShellAPI}
type
PListBox = ^TListBox;
procedure FillList(List: PListBox; pathh, mask: string; attr: Cardinal);
var
path: string;
ser: TSearchRec;
begin
path := pathh;
if path[length(path)] <> '\' then
path := path + '\';
List^.Items.Clear;
if FindFirst(path + mask, attr, ser) <> 0 then
exit;
List^.Items.Add(ser.Name);
while FindNext(ser) = 0 do
begin
if ser.Attr and faDirectory = faDirectory then
List^.Items.Add(' [' + Ser.Name + ']')
else
List^.Items.Add(Ser.Name);
end;
List^.Sorted := false;
list^.Sorted := true;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FillList(@ListBox1, edit1.text, '*.*', faAnyFile);
end;
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
s: string;
begin
s := ListBox1.Items[SendMessage(ListBox1.Handle, lb_GetCurSel, 0, 0)];
if (not FileExists(edit1.text + s)) and (s[1] + s[2] = ' [') and (s[length(s)]
= ']') then
begin
FillList(@ListBox1, edit1.text + copy(s, 3, length(s) - 3), '*.*',
faAnyFile);
edit1.text := edit1.text + copy(s, 3, length(s) - 3) + '\';
end;
if FileExists(edit1.text + s) then
ShellExecute(handle, 'open', PChar(edit1.text + s), '', 'c:\', sw_show);
end;
Добавим иконки:
{uses ShellAPI}
type
PListBox = ^TListBox;
procedure FillList(List: PListBox; pathh, mask: string; attr: Cardinal);
var
path: string;
ser: TSearchRec;
begin
path := pathh;
if path[length(path)] <> '\' then
path := path + '\';
List^.Items.Clear;
if FindFirst(path + mask, attr, ser) <> 0 then
exit;
List^.Items.Add(ser.Name);
while FindNext(ser) = 0 do
begin
if ser.Attr and faDirectory = faDirectory then
List^.Items.Add(' [' + Ser.Name + ']')
else
List^.Items.Add(Ser.Name);
end;
List^.Sorted := false;
list^.Sorted := true;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FillList(@ListBox1, edit1.text, '*.*', faAnyFile);
listbox1.itemheight := 18;
end;
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
s: string;
Icon: hIcon;
IconIndex: word;
begin
IconIndex := 1;
s := ListBox1.Items[SendMessage(ListBox1.Handle, lb_GetCurSel, 0, 0)];
if (not FileExists(edit1.text + s)) and (s[1] + s[2] = ' [') and (s[length(s)]
= ']') then
begin
FillList(@ListBox1, edit1.text + copy(s, 3, length(s) - 3), '*.*',
faAnyFile);
edit1.text := edit1.text + copy(s, 3, length(s) - 3) + '\';
end;
if FileExists(edit1.text + s) then
ShellExecute(handle, 'open', PChar(edit1.text + s), '', 'c:\', sw_show);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
a: array of integer;
i: integer;
begin
SetLength(a, ListBox1.Items.Count + 1);
//ZeroMemory(@a,ListBox1.Items.Count*4);
for i := 0 to ListBox1.Items.Count + 1 do
a[i] := 10;
beep;
beep;
beep;
beep;
beep;
SendMessage(ListBox1.Handle, lb_SetTabStops, ListBox1.Items.Count,
Integer(@a));
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
icon: hIcon;
iconindex: word;
bm: TBitmap;
begin
iconindex := 1;
bm := TBitmap.create;
bm.Width := 34;
bm.Height := 34;
ListBox1.Canvas.TextOut(17 + Rect.Left, Rect.Top, ListBox1.Items[index]);
if (copy(ListBox1.Items[index], 1, 2) = ' [') and
(not FileExists(edit1.text + ListBox1.Items[Index])) then
begin
Icon := ExtractAssociatedIcon(HInstance,
PChar(edit1.text + copy(ListBox1.Items[Index], 3,
length(ListBox1.Items[Index]) - 3)), IconIndex);
DrawIcon(bm.Canvas.Handle, 0, 0, Icon);
bm.Canvas.StretchDraw(classes.rect(0, 0, 16, 16), bm);
ListBox1.Canvas.CopyRect(classes.rect(0, rect.top, 16, rect.top + 16),
bm.canvas, classes.rect(0, 0, 16, 16));
end
else
begin
Icon := ExtractAssociatedIcon(HInstance,
PChar(edit1.text + ListBox1.Items[Index]),
IconIndex);
DrawIcon(bm.Canvas.Handle, 0, 0, Icon);
bm.Canvas.StretchDraw(classes.rect(0, 0, 16, 16), bm);
ListBox1.Canvas.CopyRect(classes.rect(0, rect.top, 16, rect.top + 16),
bm.canvas, classes.rect(0, 0, 16, 16));
end;
bm.Free;
CloseHandle(Icon);
end;
procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
ListBox1.Repaint;
end;
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
k: word;
begin
k := 0;
Listbox1.OnKeyDown(sender, k, shift);
end;
Создание TList со списком файлов, отсортированных по дате.
Автор: MBo.
type
PSRec=^TSearchRec;
function DateCompare(Item1, Item2: Pointer): Integer;
begin
if PSRec(Item1)^.Time> PSRec(Item2)^.Time then Result:=1 else
if PSRec(Item1)^.Time=PSRec(Item2)^.Time then Result:=0 else
Result:=-1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i:Integer;
SRList:TList;
SR:TSearchRec;
PSR:PSRec;
begin
SRList:=TList.Create;
if F SRList.Count> 1 then SRList.Sort(DateCompare);
for i:=0 to SRList.Count-1 do
Memo1.Lines.Add(PSRec(SRList.Items[i])^.Name+' '+
DateTimeToStr(FileDateToDateTime(PSRec(SRList.Items[i])^.Time)));
SRList.Free;
end;
|
Проблема получения времени создания файла.
Попробуйте следующую функцию, которая не требует вызова FindFirst:
function GetFileDate(TheFileName: string): string; var FHandle: integer; begin FHandle := FileOpen(TheFileName, 0); result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle))); FileClose(FHandle); end; |
Одно маленькое предупреждение: время, возвращаемое Win32-функцией, отсчитывается от Гринвича, поэтому вам необходимо привести полученный результат к локальному времени. Чтобы быть уверенным, проверьте документацию. (Я уверен, что FindNextFile делает это правильно).
Создание фона на форме.
Как заполнить фон моей формы повторяющимся изображением?
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Bitmap: TBitmap;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP');
end;
procedure TForm1.FormPaint(Sender: TObject);
var
X, Y, W, H: LongInt;
begin
with Bitmap do
begin
W := Width;
H := Height;
end;
Y := 0;
while Y < Height do
begin
X := 0;
while X < Width do
begin
Canvas.Draw(X, Y, Bitmap);
Inc(X, W);
end;
Inc(Y, H);
end;
end;
end.
|
Как создать новую форму, которая бы не отбирала фокус у существующей.
Автор: Олег Кулабухов.
uses Unit2; procedure TForm1.Button1Click(Sender: TObject); begin Form2 := TForm2.Create(Application); Form2.Visible := FALSE; ShowWindow(Form2.Handle, SW_SHOWNA); end; |
Можно ли создать форму, которая получает дополнительные параметры в методе Сгеаtе.
Просто замените конструктор Create класса Вашей формы.
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm2 = class(TForm)
private
{Private declarations}
public
{Public declarations}
constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
end;
var
Form2: TForm2;
implementation
{$R *.DFM}
constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
Create(aOwner);
Caption := aCaption;
end;
uses
Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
Unit2.Form2.Show;
end;
|
Создание таблицы FOXPRO.
| До чего же несовершенна техника! Человеку, чтобы прийти в себя, необходимо два пальца, а компьютеру - три. |
if savedialog1.execute then
begin
if FileExists(savedialog1.filename) then
DeleteFile(savedialog1.filename);
//QUERY.DataSource НЕ ЗАПОЛНЕНО иначе взрыв гарантирован
with Session do
begin
ConfigMode := cmSession;
try
AddStandardAlias('TEMPDB', extractfilepath(savedialog1.filename),
'FOXPRO'); //FOXPRO
finally
ConfigMode := cmAll;
end;
end;
with database1 do
begin
databasename:='tst';
LoginPrompt := False;
Params.Values['PATH'] :=extractfilepath(savedialog1.filename);
DriverName:='Microsoft FoxPro Driver (*.dbf)';
AliasName:='TEMPDB';
end;
query1.paramcheck := false;
Query1.DatabaseName := 'tst';
Query1.SQL.Clear;
vrem:=Trim(ChangeFileExt(extractfilename(SaveDialog1.fileName),' '));
query1.sql.Add('CREATE TABLE '''+vrem+''' (');
query1.sql.Add('last_name CHAR(20),');
query1.sql.Add('first_name CHAR(15),');
query1.sql.Add('salary DECIMAL(10,2));'); //NUMERIC
query1.ExecSQL;
query1.close;
end; // от savedialog
|
Создание игры Пятнашки.
Источник: mycomp.com.ua Оформил: RT17.
Можно ли в Delphi создать что-нибудь непохожее на базы данных? «Нет! — ехидно скажут программисты на Си, — Все непохожее на базы данных пишеться на СиСи+». Хотя это еще как сказать. Мне несколько раз подряд попадались исходные тексты некоторых игр, «написанные на Си», в которых самого Си было максимум процентов 5-10, а все остальное — чистой воды Ассемблер! Случайность это или все-таки закономерность? На мой взгляд, с таким же успехом можно использовать связку Delphi-Ассемблер. Тем более, что в Delphi есть все для создания крупномасштабных проектов, в том числе и игр (например, поддержка OpenGL — для работы с 3D-графикой; OpenGL, кстати, использовался при создании Quake III). Я, конечно, не собираюсь в этой статье рассказывать, как создать в Delphi Quake III (не по мне такие задачи). Речь пойдет о более приземленных вещах. А именно, о маленькой простой игре, которой можно дополнить набор мелкомягких игр, устанавливаемых вместе с Windows. Эта игра в народе называется «пятнашки» — очень популярная раньше настольная (вернее даже, наручная) игра, которая продавалась в квадратных коробочках с большой цифрой 15 на крышке, в которой нужно было расставить квадратики с числами в порядке от 1 до 15. Ну что, вспомнили? Нет!?… Да, трудное у вас было детство… Ну да ладно. Итак, значит, будем писать «пятнашки» в Delphi.
Для начала приступим к созданию интерфейса. Здесь все полностью зависит от вашей фантазии. Но я остановлюсь на праздном сером оформлении (см. Рис. 1). Теперь о том, как получить такой образец серости и примитивизма. Сначала на форме располагается компонент TPanel со свойствами BevelInner и BevelOuter, равными bvLowered, для создания эффекта бордюра по краям формы. Затем на полученную панель ставится еще одна панель меньшего размера со свойством BevelOuter равным bvRaised, BevelInner —bvLowered, а цвет Color —clBlack. Эта вторая панель будет фоном для кнопок с цифрами. Затем добавляются кнопки (компоненты TButton или TSpeedButton) с названиями about, game, exit и кнопка начать игру (компонент TSpeedButton). Расположение их показано на рисунке. Теперь надо создать те самые квадратики с цифрами. Эту роль играют компоненты TButton. Расположите их на второй панели именно так, как показано на рисунке, то есть, кнопка с цифрой (Caption) 1 должна иметь имя (Name) Button1, кнопка 2 —Button2 и т.д. Это важно. Объясняю, почему. При добавлении компонента на форму он автоматически заносится в список (массив) компонентов формы и получает индекс начиная с 0. В дальнейшем взаимодействие с кнопками программой будет осуществляться через их индексы. Поэтому если у вас кнопка с именем Button1 будет иметь Caption 2, вам просто будет сложнее работать с ней. Что касается размеров кнопок, то я установил параметры Heigth и Width каждой по 50. Да, еще. Чтобы посмотреть индекс кнопки, размещенной на форме, в ее процедуре-обработчике события (Event), например, OnClick, наберите:
form1.caption:=inttostr((sender as tbutton).componentindex);
Это приведет к тому, что при нажатии на кнопку ее индекс будет выводиться в заголовке формы. Потом эту строчку можете удалить.
Теперь, когда интерфейс программы готов, можно перейти непосредственно к программированию. Опишем глобальные переменные модуля. В разделе var (там, где написано Form1: TForm1) напишите:
a:array[1..16]of byte; i,k,fl,rn,p,m:byte; x,y,x1,y1,num,pos,lr,td,lr1,td1:integer; flag:boolean;
(назначение переменных я буду объяснять далее). После этого нужно написать процедуру, генерирующую массив случайных чисел от 1 до 16 так, чтобы они не повторялись. Потом по этому массиву будут расставляться кнопки с числами. Случайные числа будем заносить в массив a. Цифра 16 будет означать пустую область, на которой нет кнопки. Процедура заполнения массива случайными числами выглядит следующим образом:
procedure rndarr; begin for k:=1 to 16 do a[k]:=0; randomize; i:=1; repeat rn:=random(16)+1; fl:=0; k:=1; while (a[k]<>rn) and (k<>17) do inc(k); if k=17 then begin a[i]:=rn; Inc(i); end; until i=17; end;
Обращаю ваше внимание на то, что приведенная выше процедура не является обработчиком какого-либо события, поэтому не нужно ее объявлять в интерфейсной части модуля. Просто наберите ее как есть после Implementation {$R *.DFM}. Такие процедуры называются пользовательскими. (Для того чтобы узнать, какие числа появляются в массиве после выполнения этой процедуры, можно использовать окно Watch). Визуализация массива На этом принципе работают многие игры. Например, тот же тетрис: имеется некий двумерный массив (стакан), в котором нули — пустые позиции, единицы — квадратики, из которых строятся фигуры тетриса. Далее в массиве эти единицы сдвигаются, и массив выводится на экран с заменой 0 и 1 на графические элементы. Это повторяется несколько раз, что создает эффект падения фигур. В данном случае все должно происходить аналогичным образом: все перемещения производятся в массиве, а в соответствии числам из массива располагаются сами «пятнашки». Для того чтобы это осуществить, нужно написать процедуру, в которой читаются элементы массива, соответствующие индексам компонентов-кнопок с цифрами. Затем происходит обращение к этим кнопкам по их индексу и размещение их соответственно значениям в массиве. То есть, если первым элементом массива является число 15, то первой кнопкой в левом верхнем углу будет кнопка с цифрой 15 и т.д. Вот эта процедура (наберите ее после первой):
procedure drawarr; begin p:=0; for i:=0 to 3 do for k:=0 to 3 do begin p:=p+1; if a[p]<>16 then begin with TButton(form1.components[a[p]+5]) do begin left:=k*50+2; top:=i*50+2; end; end; end; end;
Так как у меня первая кнопка в массиве компонентов формы имеет индекс 6 (:-)), то я при обращении к кнопкам прибавляю к значению из массива число 5, чтобы получить их индексы:
TButton(form1.components[a[p]+5]));
Кнопки имеют размер 5050, первая из них расположена правее на 2 пикселя от левого края черной (второй) панели и на 2 пикселя ниже от верхнего ее края, поэтому, чтобы правильно их расположить, будем умножать переменные i и k на 50 и прибавлять 2. Таким образом, если, например, i и k равны 0, то координаты первой кнопки в левом верхнем углу, по отношению к черной панели, равны (2,2), если i=0, k=1, то координаты —(2,52), и т.д. Начать игру Начнем работу с процедурами-обработчиками событий. Первая из них — обработчик события OnClick кнопки (TSpeedButton) «Начать игру». Дважды щелкните по этой кнопке. При этом откроется редактор кода с таким заголовком процедуры:
procedure TForm1.SpeedButton2Click(Sender: TObject); begin rndarr; drawarr; form1.speedbutton2.caption:='Начать игру заново'; end;
Таким образом, при нажатии на кнопку «Начать игру» происходит генерация массива случайных чисел процедурой rndarr, затем — размещение кнопок с цифрами соответственно числам в массиве процедурой drawarr и, наконец, изменение названия кнопки Начать игру на Начать игру заново. Теперь можете запустить программу и поклацать кнопкой «Начать игру». О кнопках с цифрами Предпоследний этап. Нужно сделать так, чтобы при нажатии на кнопку с цифрой определялось направление ее движения, т.е. то место, где нет другой кнопки. Для этого клацните дважды, например, по кнопке 15 и в появившейся процедуре-обработчике события OnClick (как и в предыдущий раз) между Begin и End наберите:
if flag then exit; {если flag=true — выход из процедуры}
pos:=0;m:=0;num:=0;
num:=(sender as tbutton).componentindex-5; {num — номер нажатой кнопки}
for i:=1 to 16 do if a[i]=num then pos:=i; {определение ее позиции в массиве}
{определение направления движения}
if (pos-1>0)and(pos-1<>4)and(pos-1<>8)and(pos-1<>12)and(a[pos-1]=16)then m:=1;
if (pos+1<17)and(pos+1<>5)and(pos+1<>9)and(pos+1<>13)and(a[pos+1]=16)then m:=2;
if (pos-4>0)and(a[pos-4]=16)then m:=3;
if (pos+4<17)and(a[pos+4]=16)then m:=4;
if m=0 then exit; {если вокруг кнопки пустой позиции нет — выход}
flag:=true; {установливаем флаг, означающий, что кнопка в движении}
lr1:=(sender as tbutton).left; {сохраняем в lr1 и td1 начальные координаты}
td1:=(sender as tbutton).top;
lr:=0;td:=0;
form1.move(sender); {вызов процедуры перемещения кнопки}
В Object Inspector в разделе Events для остальных кнопок с цифрами напротив события OnClick укажите эту процедуру. Таким образом, она будет выполняться при нажатии любой кнопки с цифрой. В этой процедуре определяется, есть ли рядом с нажатой кнопкой пустая позиция. Если таковая слева, то m:=1, справа —m:=2, сверху —m:=3, снизу —m:=4. Определение «слева или справа» происходит путем вычета или прибавления к позиции нажатой кнопки единицы, определение «сверху или снизу» — через вычет или прибавление 4. Переменная Flag служит для того чтобы определить, движется ли какая-либо кнопка или нет. Если движется — процедура не должна выполняться. Процедура перемещения кнопки form1.move описана далее. Двигай кнопкой Чтобы как-то «оживить» игру, требуется движение. В данном случае — движение кнопок. Для реализации заметного человеческому глазу и более-менее плавного движения потребуется компонент TTimer. Выберите его из списка компонентов и расположите в любом месте формы. Установите его свойство Interval равным 1. Затем в его единственном событии OnTimer в Object Inspector напишите move и нажмите Enter. На экране появится тело процедуры-обработчика этого события:
procedure TForm1.move(Sender: TObject);
begin
timer1.enabled:=true; {включение таймера}
case m of {исходя из направления движения}
1:dec(lr,5); {уменьшаем на 5 lr}
2:inc(lr,5); {увеличиваем на 5 lr}
3:dec(td,5);
4:inc(td,5);
end;
with TButton(components[num+5])do begin {перемещаем компонент}
left:=lr1+lr;top:=td1+td;end;
if (abs(lr)=50) or (abs(td)=50) then {когда пройдено 50 шагов}
begin
timer1.enabled:=false; {выключаем таймер}
lr:=0;
td:=0;
flag:=false;
case m of {перестановка чисел в массиве}
1:begin a[pos-1]:=a[pos];a[pos]:=16;end;
2:begin a[pos+1]:=a[pos];a[pos]:=16;end;
3:begin a[pos-4]:=a[pos];a[pos]:=16;end;
4:begin a[pos+4]:=a[pos];a[pos]:=16;end;
end;
fl:=0;
for i:=1 to 16 do if a[i]<>i then fl:=1; {определяем, расставлены ли кнопки по порядку от 1 до 15}
if fl=0 then showmessage('Вы выиграли!'); {если кнопки расставлены как надо — сообщение «Вы выиграли!»}
end;
end;
Основная часть программы уже написана. Осталось внести последние штрихи. Создайте форму AboutBox и в процедуре-обработчике события OnClick кнопки About напишите: AboutBox.Show. Аналогично, для кнопки Exit напишите Close — для выхода из программы. Да, еще. В Object Inspector в параметре формы BorderStyle выберите bsDialog — форму с таким стилем невозможно развернуть или изменить ее размер. Также, по желанию, можно сделать меню (компонент TPopUpMenu) для кнопки Game.
Создание карты в игре методом спрайтов.
Автор: Мироводин Д.А. Оформил: RT17.
В играх, где используется простая 2D проекция, используется наверное два способа построения игрового пространства (карт). Первый о котором и будет рассказ, заключается в построение карты из спрайтов одинакового размера. А второй из уже готовых больших изображений, но об этом в другой главе. Преимущества этого способа - малый объем ресурсов графики, следовательно не требовательность к ресурсам. Практически любой размер карты - он ограничен лишь массивом и т.д. К минусам можно отнести сложность подгона текстур друг к другу. Этот способ построения карт применялся в таких БОЕВИКАХ ( не побоюсь этого слова ) игрового фронта как : WARCRAFT, DUNE и т.д. С помощью этого типа карт можно написать неплохую RPG или стратегия. Ну приступим. Первое что нам нужно это спрайты:
Преимущества этого способа - малый объем ресурсов графики, следовательно не требовательность к ресурсам. Практически любой размер карты - он ограничен лишь массивом и т.д. К минусам можно отнести сложность подгона текстур друг к другу. Этот способ построения карт применялся в таких БОЕВИКАХ ( не побоюсь этого слова ) игрового фронта как : WARCRAFT, DUNE и т.д. С помощью этого типа карт можно написать неплохую RPG или стратегия. Ну приступим. Первое что нам нужно это спрайты : В примере я сделал файл Flur1.bmp там 20 спрайтов размером 32 x 32 / при создании старайтесь делать спрайты квадратные - упрощается вычисление/. Спрайты индексируются 0 ... 19; Что представляет из себя карта - это двух мерный массив , элементы которого - индексы спрайтов. Например:
MAP: Array [0..100,0..10]of integer;
Это означает, что мы хоти создать карту размером 100 x 100 спрайтов, допустим размер спрайта 32 x 32 тогда общая длина/ширина карты в пикселях будет 3200 x 3200. Но что вам мешает создавать карты, 1000 x 1000 клеток. ( Пример в HMM2 максимальная карта 128 x 128 при размере спрайта 32 пикселя ) Я советую создать класс для карты, вот как сделал бы я :
type TFlur= class private SpriteLastIndex, // Кол-во спрайтов в Resource SpriteWH:integer;// Размер спрайта, должен быть квадрат Resource:TBitmap;// Ресурсы графики public Table:Tlist; // Массив карты развернутый в список Width,Heigth:Integer;// Ширина и высота карты в спрайтах Constructor Create(Const X,Y,Sprite:integer);// ширина, высота, размер спрайта Procedure LoadResource(FileName:String); // путь к BMP ресурсу Procedure RandomGenerator; // случайное заполнение Table Procedure Draw(DestHandle:TCanvas;X,Y:Integer;SourceRect:TRect); // Canvas для вывода, // Смещение X и Y относительно начала DestHandle // SourceRect - какой кусок карты Table выводить на экран, В КОЛ-ВАХ СПРАЙТОВ Destructor Destroy; override; end;
По поводу Table - я использовал TList вместо Array т.к. при создании мы можем не знаем, какого размера карту будем делать. В игре создавая один TFlur можно подгружать туда новые карты динамически, при переходе на новый уровень ( зону, город ... ), без замедления. Рассмотрим процедуру Draw, т.к. все остальное достаточно понятно :
Procedure TFlur.Draw(DestHandle:TCanvas;X,Y:Integer;SourceRect:TRect);
var
I,J:integer;
dx,dy:integer; // для смещений в пикселях
TableIndex:^integer; // указатель на элемент Table
begin
// Делаем проверку
if SourceRect.Left<0 then exit;
if SourceRect.Top<0 then exit;
if SourceRect.Left+SourceRect.Right>Heigth-1 then exit;
if SourceRect.Top+SourceRect.Bottom>Width-1 then exit;
dx:=0;dy:=0;// обнуляем смещение
// зададим цикл по области карты для показа
for I:=SourceRect.Left to SourceRect.Left+SourceRect.Right do
begin
for J:=SourceRect.Top to SourceRect.Top+SourceRect.Bottom do
begin
TableIndex:=(Table.Items[Width*J+I]);
// Уже знакомой прцедурой копируем один спрайт на экран
BitBlt(DestHandle.Handle,dx+X,dy+Y,SpriteWH,
SpriteWh,Resource.Canvas.Handle,TableIndex^*SpriteWh, 0,SRCCopy);
inc(dy,SpriteWH);// увеличиваем смещение dy на SpriteWH
end;
Inc(dx,SpriteWH);dy:=0;// увеличиваем смещение dx на SpriteWH, обнуляем dy
end;
end;
Достанем элемент из списка с координатами I,J.
1. Если вы хотите сделать что-то подобное Color Lines, шахмат, морского боя и т.д. вам совсем не обязательно вводить Table - поле всегда имеет одинаковые размеры.
2. При выполнении Flur.Draw неплохо ввести проверку на значения SourceRect ( я сделал ее внутри процедуры обработки клавиатуры).
3. Все объекты карты - дома, леса, юниты, технику и д.р. желательно привязывать к координатам пиксельным ( да и вообще скроллинг карты надо делать то же пиксельным - но об зтом позже ).
4. Дописать загрузку Table из файла.
5. При выводе графики на в окно происходит мерцание курсора. Это связано с тем, что обновление курсора намного медленнее, чем вывод графики. Исправить это можно следующим способом. С формы убирается курсор ( Form1.Cursor:=crNone; ). Координаты курсора запоминаем в двух переменных. При от рисовки делаем так : создаем буфер, рисуем Flur в буфер, далее туда пихаем картинку из ImаgеList'а. И выводим буфер на экран. Плюсы этого метода: можно сделать курсор любой формы и менять его по ходу игры, ну и избавимся от дрожания.
Хранить спрайты можно не только в BMP, но и в TImageList. При этом появляется множество удобств:1. Можно спрайты не вытягивать в линейку, а рисовать на прямоугольнике - допустим 640x480. При загрузке достаточно указать размер спрайта, а ImageList сам их разобьет.
2. Удобно добиваться прозрачности. Это может понадобится для спрайтов не квадратной формы - ромб. Они пригодятся для изометрии.
3. Скорость вывода на экран потрясающая. Смотрите пример.
Итак, что я переписал в TFlur : коструктор и Draw.
constructor TFlur.Create(ConstMapX,MapY,SpriteW,SpriteH:integer;ResFileName:String); // MapX,MapY - размер карты в спрайтах // SpriteW,SpriteH - размер спрайта // ResFileNama - путь к BMP var Resource:Tbitmap; // BMP с ресурсами begin Resource:=Tbitmap.Create; // Грузим ресурсы из ResFileName Resource.LoadFromFile(ResFileName); ImageList:=TImageList.CreateSize(SpriteW,SpriteH); // Создаем лист под спрайты ImageList.DrawingStyle :=dsNormal; // Устанавливаем параметры ImageList.Masked := False; ImageList.Add(Resource,Resource); .... end;
И изменения в TFlur.Draw :
.... for J:=SourceRect.Top to SourceRect.Top+SourceRect.Bottom do begin TableIndex:=(Table.Items[Width*J+I]); ImageList.Draw(DestCanvas,dx+X,dy+Y,TableIndex^); Inc(dy,32); end; Inc(dx,32); ....
При компиляции использовал компонент THeadedTimer ( инсталируйте его из директории THeadedTimer, как установить компоненты Вы надеюсь знаете ). Этот компонент аналог стандартного TTimer, но использованы потоки - высокая скорость работы. И последнее - если вы будете совместно использовать Flur и спрайты то копируйте все в БУФЕР. Т.е. карту в буфер, спрайты и курсор в буфер, буфер на экран.
Если есть у кого ссылки на ресурсы с графикой от игр ( лучше стратегий и RPG ) или вообще текстуры, но текстуры к ИГРАМ, а не web ( формат BMP, DIB, PSD) то прошу присылать ссылки. Кто напишет что что-нибудь дельное используя эти методы обязательно размещу. Если ВЫ знаете другие методы построения карт в играх прошу присылать идеи.
Часть 2.
Прежде чем читать данную статью, настоятельно рекомендую прочесть ее первую часть.
В первой части я показал как можно создать карту из набора спрайтов и вывести ее на любой TCanvas. При этом карта создавалась как таблица из наборов номеров спрайтов, этот способ удобен там, где все объекты привязаны к координатам спрайтов. Чтобы было более понятно, приведу простой пример:
Игра шахматы. Все фигурки привязаны к координатам доски ( у нас к координатам карты), и их передвижение возможно только в этих координатах. Но при переносе фигуры появляются другие координаты - промежуточные. И если ограничиваться координатами доски не возможно создать плавного перемещения, анимации.
Для достижения плавного скроллинга карты, анимации объектов приходится вводить координаты пиксельные.
Изменению подверглись только выделенные красным строчки.
type TFlur2= class private SpriteLastIndex, // Кол-во спрайтов в Resource SpriteWH:integer;// Размер спрайта, должен быть квадрат Resource:TBitmap;// Ресурсы графики Width1,Heigth1:Integer;// Ширина и высота карты в спрайтах public Table:TList; // Массив карты развернутый в список Width,Heigth:Integer;// Ширина и высота карты в пикселях Constructor Create(Const X,Y,Sprite:integer);// ширина, высота карты , размер спрайта в пикселях Procedure LoadResource(FileName:String); // путь к BMP ресурсу Procedure RandomGenerator; // случайное заполнение Table Procedure Draw(DestHandle:TCanvas;X,Y:Integer;SourceRect:TRect); // Canvas для вывода, // Смещение X и Y относительно начала DestHandle // SourceRect - какой кусок карты Table выводить на экран, в пикселях Destructor Destroy; override; end;
Как Вы видите изменений произошло не очень много, но зато пришлось полностью переписать процедуру вывода готовой карты - Draw. При вызове конструктора, в качестве параметров X и Y передается размер карты в пикселях ( ранее в количествах спрайтов ). Как и в TFlur значения X и Y должны быть равны - только квадратная карта, это связано с особенностью хранения массива со значениями спрайтов. Еще одно условие X должен делиться на Sprite без остатка :).
Если подробно рассматривать, что происходит в процедуре Draw, то вот основные моменты.
1. Сначала происходит проверка, можно ли показать данные координаты.
2. Далее, путем округления в большую сторону, получаем координаты (X1,Y1,X2,Y2). Эти координаты в системе спрайтов (т.е. 0 соответствует 0, 32 - 1, 64 - 2 ... ).
3. Получаем координаты сосмещением (dx,dy).
4. Выводим спрайт в координаты (dx,dy).
В принципе на словах, это не очень понятно, но просто попробуйте нарисовать на бумаге и я думаю Вы разберетесь.
Теперь можно задаться вопросом: а за чем все это было нужно, и чем TFlur хуже?
Все очень просто, теперь появилась возможность скроллировать карту хоть по 1 пикселю, а раньше только по 32 ( т.е. по ширине спрайта карты ). При этом будет достигаться плавность перемещения. И вот второй момент. Если Вы захотите поместить на карту объекты ( а Вы точно захотите ! ), то они могут находится на любом месте карты ( и экрана соответственно ).
Чтобы поместить на нашу карту анимированные спрайты я написал небольшой класс TSprite. Замечу что он не универсальный и далеко не совершенный. Просто для своих целей Вы можете дописать необходимые вам пункты, но я остановлюсь на этом далее.
Вот заголовок класса TSprite:
type TSprite=Class // Внутренние координаты спрайта, real по тому, что // вычисление ведется через sin и cos - достигается // более плавное перемещение. Возможность поворота по // любому углу. FCoordXFl, FCoordYFl:Real; // "Экранные" координаты FCoordX, FCoordY, FAngle:Integer; // FAngle - вектор направления скорости спрайта, может // принимать значения от 0 до 360 ( 0,45,90,135 ... 360 для данной программы) FSpeed:Integer; // "скорость" FCount:Integer; // Счетчик движений - всего 4 изображения анимации на каждое движение FGo:boolean; // Стоим или идем Imagelist:TImagelist; constructor Create(AX,AY,AAngle:integer); Procedure DrawNext(АСаnvаs:TCanvas;Dest:TRect); Procedure Rotate(AAngle:integer); end;
Я думаю тут должно быть все понятно, но все же остановлюсь на некоторых моментах. Для чего вводятся 2 переменные на каждую координату? Все очень просто : спрайт выводится на экран и с координатами FCoordX и FCoordY. А FCoordXFl и FCoordYXFl нужны вот для чего: допустим спрайт движется под углом 15 градусов и его шаг 1 пиксель. При вычислении приращения его координат получаем следующее : по оси Y приращение Cos(15)*1~0.965 а по оси X Sin(15)*1~0.25 При округлении получаем по оси Y - 1, по оси X - 0! Вот так вроде двигаемся на северо-восток, а приращение только по Y. Но в принципе можно использовать только Real и потом их просто округлять.
При выполнении процедуры DrawNext передается параметр Dest:TRect - это видимая область карты, она изображена на рисунке розовым цветом. Если координаты спрайта не попадают в нее, то он не выводится.
Теперь остановимся на возможностях модернизации данного класса и других тонкостях.
1.Количество спрайтов на одно движение должно быть как можно больше ( в моем примере их всего 4 и видно дерганность при ходьбе героя).
2.Угол поворота в идеале 5 градусов, только тогда можно добиться очень хорошей и плавной анимации.
3.Если Вы собираетесь писать RTS или RPG, то все параметры героя - сила, ловкость, количество маны, жизнь и т.д. так же включают в класс.
4. Лучше всего написать один класс 'родительский' и от него делать все дочерние. Например класс 'Static Sprite' - от него можно породить магазины, дома героев, замки - для RPG и ангары, заводы - для RTS. Это проще чем писать отдельный класс для каждого нового объекта. Ну не мне вас учить ООП.
5. Нужно включить контроль столкновений. При этом лучше всего проверять сначала просто по габаритам спрайта, а потом по его маске - ведь спрайт занимает не все пространство внутри квадрата.
6.Спрайты включаются в список ( если их больше 1 ). Тогда с ними легче обращаться - удалять, добавлять ...Например так:
Оптимизация - как много в этом слове ! Конечно Вас не устроила скорость работы данного примера. Но я и не старался это сделать - 320x320 при 10-15 кадрах это мало. Если Вы собираетесь делать игру с разрешением 640x480 то вот способы оптимизации. Вся загвоздка в тормознутости TCanvas - по этому обойдемся без него. Самое лучшее использовать DirectX - смотрите раздел Lib и компонент DelphiX. И еще один вариант - Dib, так же смотрите в разделе Lib есть пара компонентов для работы, получается вполне приличная скорость с поддержкой всевозможных эффектов.
Дерзайте !
Исходники можна взять здесь.
Создаем гипер-ссылку в Delphi.
Автор: Павел На самом деле создать гиперссылку в Delphi очень просто. Алгоритм тут такой: мы ставим на форму метку (TLabel), приводим ее внешний вид к привычному нам виду гиперссылки в нашем браузере (рассмотрим на примере IE), и пишем обработчик события OnClick. Чтобы нам можно было постоянно использовать гиперссылку в наших программах, мы создадим компонент!Сейчас мы на простом примере разберемся с созданием ссылки в Delphi, а затем оформим все в виде компонента. Начинаем с того, что ставим на форму нашего проекта метку (TLabel), пусть ее имя останется Label1. Теперь мы напишем обработчик события OnClick, для нее:
procedure TForm1.Label1Click(Sender: TObject); begin ShellExecute(handle, 'open', 'http://delphiworld.narod.ru/', nil, nil, SW_SHOW); end;Теперь поясню, что мы здесь написали. Функция ShellExecute предназначена для открытия или печати файла, как исполняемого, так и документа. Первый параметр это handle родительского окна, второй параметр - строка, указывает, что надо сделать с файлом, третий параметр содержит имя открываемого файла, четвертый параметр указывает дополнительные параметры запуска исполняемого файла, пятый параметр определяет директорию по умолчанию, последний параметр определяет где будет отображен файл после октрытия. !!! Кстати если Вы уже попробовали запустить приведенный код, то скорее всего у Вас ничего не вышло, потому что функция ShellExecute, находится в модуле ShellAPI, который конечно же надо добавить в секцию uses, кода нашего приложения. Теперь разберем параметры относительно нашего случая: handle - это дескриптор главной формы (аналогично Form1.handle) open - тип действия с файлом. Нам надо его открыть. http://delphiworld.narod.ru/ - имя файла, который надо открыть. У нас это может быть гиперссылка, содержащая абсолютный URI. nil - здесь никаких дополнительных параметров открытия файла не должно быть, поэтому nil. nil - директория по умолчанию нас так же не интересует. SW_SHOW - активирует окно и отображает его с текущими размерами и положением. Об остальных режимах можно узнать в хелпе (о функции ShellExecute). Надо отметить, что второй и третий параметры функции являются нуль терминированными строками, т.е. строками типа PChar, поэтому для использования в функции имени файла, полученного из OpenDialog1, нужно использовать PChar(OpenDialog1.Filename).
Поскольку в браузере (при настройках по умолчанию) ссылка меняет цвет в зависимости от своего состояния и действий пользователя. Мы тоже сделаем так. Для этого заведем три константы (в них будут определяться цвета), которые надо поместить в раздел Implementation:
...
implementation
const
link = clBlue; //цвет ссылки
alink = clRed; //цвет ссылки в момент нажатия
vlink = clPurple; // цвет посещеной ссылки
{$R *.DFM}
...
Теперь в обработчике события формы OnCreate надо написать:
procedure TForm1.FormCreate(Sender: TObject); begin Label1.font.Color := link; end;
В обработчике события метки OnMouseDown мы напишем:
procedure TForm1.Label1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Label1.Font.Color := alink; end;
А в обработчике события OnMouseUp нашей метки мы напишем:
procedure TForm1.Label1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Label1.Font.Color := vlink; end;Для придания полной реалистичности нашей ссылке, надо установить свойство метки Cursor в crHandPoint. Т.е. при наведении на ссылку указатель будет иметь вид привычной нам кисти руки с вытянутым указательным пальцем и сделать ссылку подчеркнутой. Ну вот и разобрались, а теперь напишем компонент. Там все предельно просто и понятно, поэтому объяснения напишу только в виде комментариев в коде. Как инсталлировать компонент (и все другие вопросы связанные с самим написанием компонент), смотрите в статьях "Пособие по написанию компонент" и "Пособие по написанию компонент. Часть 2". В качестве родительского класса (Ancestor Type) мы конечно же должны выбрать TLabel.
Привожу полный код модуля компонента Link класса Tlink (текст модуля надо сохранить в файле Link.pas):
unit Link;
interface
uses
Windows, SysUtils, Classes, Forms, StdCtrls, ShellAPI, Menus,
Controls, Graphics;
type
TLink = class(TLabel)
private
//поле для хранения URL
FURL: string;
// поля для хранения настроек цветов ссылки
FlinkColor, FAlinkColor, FVlinkColor: TColor;
protected
public
//конструктор и деструктор
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
//события, которые нам надо переопределить
procedure Click; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
published
//свойства, которые будут видны в Object Inspector
property URL: string read FURL write FURL;
property LinkColor: TColor read FLinkColor write FLinkColor default clBlue;
property ALinkColor: TColor read FALinkColor write FALinkColor default
clRed;
property VLinkColor: TColor read FVLinkColor write FVLinkColor default
clPurple;
end;
procedure Register;
implementation
constructor TLink.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//устанавливаем цвета
FALinkColor := clRed;
FLinkColor := clBlue;
FVLinkColor := clPurple;
//сделаем метку синей и подчеркнутой
with Font do
begin
Color := FLinkColor;
Style := [fsUnderline];
end;
end;
procedure TLink.Click;
begin
inherited Click;
//если поле URL заполнено, то перейдем по ссылке
if FURL <> '' then
ShellExecute(GetDesktopWindow(), 'open', PChar(FURl), nil, nil, SW_SHOW);
end;
procedure TLink.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
Integer);
begin
if Button = mbLeft then
begin
FLinkColor := Font.Color;
Font.Color := FALinkColor;
end;
inherited;
end;
procedure TLink.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
Integer);
begin
if Button = mbLeft then
Font.Color := FVLinkColor;
inherited;
end;
destructor TLink.Destroy;
begin
//уничтожим компонент
inherited;
end;
procedure Register;
begin
//надо, чтобы компонент появился в палитре
RegisterComponents('http://delphiworld.narod.ru/', [TLink]);
end;
end.
Вот мы и разобрались с созданием гипер-ссылок в Delphi, как оказалось все очень просто!
Создание ловушек (Hook) в Delphi.
Рано или поздно каждый программист сталкивается с таким понятим как ловушки. Чтобы приступить к ипользованию ловушек необходимо обзавестись windows SDK, который можно так же скачать с сайта Microsoft. В прилагаемом к статье архиве содержатся два проекта: hooks.dpr - это пример приложения работающего с ловушками, а hookdll.dpr - собственно сама DLL.
Что такое ловушки (Hooks)?
Проще говоря, ловушка - это функция, которая является частью DLL или часть Вашего приложения, при помощи которой можно контролировать 'происходящее' внутри окошек операционной системы. Идея состоит в том, чтобы написать функцию, которая будет вызываться каждый раз, когда будет возникать определённое событие - например, когда пользователь нажмёт клавишу или переместит мышку. Ловушки были задуманы Microsoft в первую очередь, чтобы облегчить программистам отладку приложений. Однако существует множество способов использования ловушек - например, чаще всего при помощи ловушек пишутся клавиатурные шпионы.
Итак, существует два типа ловушек - глобальные и локальные. Локальная ловушка отслеживает только те события, которые происходят только в одной программе (или потоке). Глобальная ловушка отслеживает события во всей системе (во всех потоках). Оба типа ловушек устанавливаются одинаково, однако единственно отличие заключается в том, что локальная ловушка вызывается в пределах Вашего приложения, в то время как глобальную ловушку необходимо хранить и вызывать из отдельной DLL.
Процедуры ловушки
Далее следует краткое описание каждой процедуры и структуры, необходимой для ловушки.
Функция SetWindowsHookEx.
Функция SetWindowsHookEx необходима для установки ловушки. Давайте посмотрим на аргументы данной функции:
| idHook | Integer | Число, представляющее тип ловушки - например WH_KEYBOARD |
| lpfn | TFNHookProc | Адрес в памяти функции ловушки |
| hMod | Hinst | Дескриптор dll в которой находится функция. Если это локальная ловушка, то этот параметр 0. |
| dwThreadID | Cardinal | 'id потока', который Ваша программа будет контролировать. Если это глобальная ловушка, то параметр должен быть 0. |
SetWindowsHookEx возвращает дескриптор (т.е. идентификатор) текущей ловушки, который можно использовать в функции UnhookWindowsHookEx для последующего удаления ловушки.
Функция hook.
Функция hook это процедура, которая вызывает в случае, если необходимое нам событие происходит. Например, если установлена ловушка типа WH_KEYBOARD, то окно будет передавать в ловушку информацию о том, какая клавища была нажата. Для Вашей процедуры hook необходимы следующие аргументы:
| Code | Integer | Указывает на то, что означают следующие два параметра |
| wParam | word | Параметр размером в 1 слово (word) |
| lParam | longword | Параметр размером в 2 слова |
Функция hook возвращает значение типа longword.
Функция CallNextHookEx.
Данная функция предназначена для работы с цепочкой функций ловушек. Когда ловушка установлена на определённое событие, то может возникнуть такая ситуация, когда кто-нибудь тоже захочет установить ловушку на это же событие. Когда Вы устанавливаете ловушку при помощи SetWindowsHookEx, то Ваша процедура ловушки добавляется в начало списка процедур ловушек. Поэтому основная задача функции CallNextHookEx заключается в том, чтобы вызвать следующий в списке обработчик ловушки. Когда Ваша процедура ловушки завершится, то она должна вызовать CallNextHookEx, а затем вернуть заданное значение, в зависимости от типа ловушки.
Функция UnhookWindowsHookEx.
Данная функция просто напросто удаляет Вашу ловушку. Единственный аргумент этой функции - это дескриптор ловушки, возвращаемы функцией SetWindowsHookEx.
Локальная ловушка
Сперва давайте создадим локальную ловушку. Необходимый для неё код содержится в 'local.pas'. При запуске Hooks.exe будет отображена небольшая форма. Для использования локальной ловушки достаточно нажать кнопку Add/Remove Local Hook на этой форме. После установки локальной ловушки, Вы заметите, что при нажатии и отпускании любой клавиши будет раздаваться звуковой сигнал (естевственно, когда hooks.exe будет иметь фокус. Ведь это локальная ловушка).
Самая первая функция в local.pas - SetupLocalHook, которая соственно и создаёт локальную ловушку, указывая на процедуру ловушки KeyboardHook. В данном случае это простой вызов SetWindowsHookEx, и, если возвращённый дескриптор > 0, указывающий на то, что процедура работает, то сохраняет этот дескриптор в CurrentHook и возвращает true, иначе будет возвращено значение false. Далее идёт функция RemoveLocalHook, которая получает в качестве параметра сохранённый дескриптор в CurrentHook и использует его в UnhookWindowsHookEx для удаления ловушки. Последняя идёт процедура hook, которая всего навсего проверяет - была ли отпущена клавиша и если надо, то выдаёт звуковой сигнал.
Глобальная ловушка
Глобальная ловушка выглядит немного сложнее. Для создания глобальной ловушки нам понадобится два проекта - певый для создания исполняемого файла и второй для создания DLL, содержащей процедуру ловушки. Глобальная ловушка, которая представлена в примере, сохраняет в файле log.txt каждые 20 нажатий клавиш. Чтобы использовать глобальную ловушку, достаточно на форме hook.exe нажать кнопку add/remove global hook. Затем, например, в записной книжке (notepad) достаточно набрать какой-нибудь текст, и Вы увидите, что в log.txt этот текст сохранится.
Наша Dll содержит две процедуры. Первая - это процедура hook, которая идентична для той, которую мы рассмотрели для локальной ловушки. Вторая процедура необходима инициализации dlls, и содержит текущий номер клавиши, которая была нажата, а также дескриптор ловушки, которая была создана.
Исполняемый файл сперва должен загрузить процедуры из DLL, а затем использовать SetWindowsHookEx, чтобы создать глобальную ловушку.
В заключении...
Представленный пример объясняет - как перехватывать события клавиатуры. Чтобы узнать, как использовать ловушки других типов, таких как WH_MOUSE, необходимо разобраться с windows SDK.
Как создать простейший эксперт.
Автор: http://www.swissdelphicenter.ch
{
This unit can be compiled into a package and will
then appear in the delphi Help menu.
}
unit SDCSimpleExpert;
interface
uses ToolsApi;
type
TSDCSimpleExpert = class(TNotifierObject, IOTAMenuWizard, IOTAWizard)
public
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
procedure Execute;
function GetMenuText: string;
end;
procedure Register;
implementation
uses Dialogs;
procedure Register;
begin
{register expert}
RegisterPackageWizard(TSDCSimpleExpert.Create);
end;
{ TSDCSimpleExpert }
procedure TSDCSimpleExpert.Execute;
begin
{code to execute when menu item is clicked}
ShowMessage('Hello SwissDelphiCenter Simple Expert.');
end;
function TSDCSimpleExpert.GetIDString: string;
begin
{unique expert identifier}
Result := 'SwissDelphiCenter.SimpleExpert';
end;
function TSDCSimpleExpert.GetMenuText: string;
begin
{caption of menu item in help menu}
Result := 'SwissDelphiCenter Simple Expert';
end;
function TSDCSimpleExpert.GetName: string;
begin
{name of the expert}
Result := 'SwissDelphiCenter Simple Expert';
end;
function TSDCSimpleExpert.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
end.
Как создать свой пункт меню в Дельфи IDE.
Автор: http://www.swissdelphicenter.ch
{....}
uses ToolsApi, Menus;
{....}
var
item: TMenuItem;
begin
{get reference to delphi's mainmenu. You can handle it like a common TMainMenu}
with (BorlandIDEServices as INTAServices).GetMainMenu do
begin
item := TMenuItem.Create(nil);
item.Caption := 'A Mewn caption';
Items.Add(item);
end;
end;
Создание уникального табличного индекса.
Автор: Галимарзанов Фанис Очень часто требуется решить проблему уникальности индекса для таблиц - не всегда можно дополнять ключ меткой времени. Для этого можно использовать метод TTable.OnPostError. При создании таблицы добавляем поле Ax типа ftInteger или ftSmallInt, которое будет замыкать ключевые поля. К примеру, необходимо создать таблицу платежей абонентов, в которой могут существовать несколько платежей, проведенных в один день.abKod : код абонента, входит в первичный ключ Data : дата платежа, входит в первичный ключ Ax : дополнительное поле, входит в первичный ключ и замыкает его TypeOpl : тип оплаты Summ : сумма платежа
В примере уникальность ключа можно обеспечить за счет поля Data, но это достигается за счет включения кода вида.
taOplData.Value:=taOplData.Value+Time; |
В нашем случае при попытке записи не уникального ключа возбуждается исключение и программа переходит на обработку этого исключения.
const
eKeyViol = 9729; // код ошибки BDE - нарушение уникальности записи
procedure TForm1.Table1PostError(DataSet: TDataSet; E: EDatabaseError;
var Action: TDataAction);
begin
if (E is EDBEngineError) then // здесь обычный код распознавания кода ошибки
if (E as EDBEngineError).Errors[0].Errorcode = eKeyViol then
begin
DataSet.FieldByName('Ax').Value := DataSet.FieldByName('Ax').Value + 1;
// Увеличиваем значение поля Ax и повторяем попытку Post
Action := daRetry; // повторить операцию сохранения
end;
end;
|
Этот метод я применяю во всех приложениях. Кстати - для начинающих, пишем код метода OnPostError только для одной таблицы, для остальных. имеющих поле Ах, - с помощью инспектора свойств-событий назначаем для события OnPostError ссылку на метод первой таблицы, для которой мы писали код.
Как проиндексировать программно базу.
Table1.AddIndex('ИмяИндекса', 'СписокПолей', [опции]); // Подробнее в хелпе
|
Создание индексного файла из Delphi.
| Законы программизма от Ваще. 1. Ничто не работает так, как планировалось запрограммировать. 2. Ничто не программируется так, как должно работать. 3. Хороший программист характеризуется умением доказать почему задачу невозможно выполнить, когда ему просто лень её выполнять. 4. На решение проблемы уходит в три раза меньше времени, чем на обсуждение всех "за" и "против" её решения. 5. Обещанный срок сдачи - это аккуратно расчитанная дата окончания проекта плюс шесть месяцев. 6. Программисту всегда известна последовательность действий, которыми пользователь может повесить его программу, но он никогда не чинит эту проблему, надеясь на то, что никому никогда не придёт в голову эту последовательность исполнять. 7. Настоящие программисты любят Windows - все ошибки, сделанные по собственной тупости, можно свалить на Microsoft. 8. Следствие - 99% проблем, сваливаемых на Microsoft, является следствием тупости самих программистов. 9. В приступе злости все почему-то молотят по невинному монитору, вместо системного блока. 10. В случае голодовки настоящий программист ещё месяц сможет питатся едой, выковырянной из-под кнопок клавиатуры. 11. Настоящий программист уже как минимум поменял три залитых пивом клавиатуры. 12. Все, кто испытывает проблемы с настройкой кодировки, автоматически считаются неандертальцами. 13. Дилетантские разговоры о компьютерах вызывают резкую тошноту влоть до приступов рвоты. Вопрос о том как поменять "обои" в Windows вызывает желание перерезать горло вопрошающему. 14. У большинства людей, нуждающихся в твоей помощи, причина ошибки в работе программы чисто генетическая. 15. HTML, HTTP, FTP, SMTP, TCP/IP, RTFM и т.д. - это слова, а не аббревиатуры. 16. Словосочетание "мышка-норушка" не несёт никакого смысла. 17. Самые мистические проблемы, широко раздуваемые и афишируемые, в конце концов оказываются твоими глупейшими ошибками. 18. Следствие - если твоя программа выполняет мистические действия, значит, ты сделал что-то невероятно тупое. 19. Самое плохое ощущение для программиста - когда вокруг тебя стоят десять человек и все пытаются найти причину проблемы в твоей программе, а ты уже понял, в чём проблема, но боишься сказать, потому что это что-то вопиюще глупое... 20. Решение всех жизненных проблем находится на интернете. Надо только уметь хорошо искать. 21. Конфликт логических указаний в жизни вызывает фатальную ошибку в работе мозга программиста - возможно повышение температуры и сильное головокружение вплоть до рвоты или потери сознания. 22. Тех, кто презирает программистов, программисты презирают сильнее, чем те, кто презирает программистов, презирающих программистов, которые презирают тех, кто их презирает. 23. Если ты понял предыдущее - то ты программист. |
Если вы используете таблицы dBASE или Paradox, то для создания нового индекса воспользуйтесь методом AddIndex. Для примера:
Table1.AddIndex('Articles','Title', []) ;
|
Поддержка/обновление индексного файла, если только при создании вы не выставили флаг "необслуживаемый", происходит автоматически.
Программно создать ярлык.
| Автор: Gavrilo |
| Прежде чем вставить дискету в дисковод, проверьте ее на вирусы!!! |
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;
|
Программно создать ярлык 2.
| Автор: VRSLazy@mail.ru |
| Интеллигентный компьютерный специалист всегда выглядит хорошо, но он не носит с собой зеркало. У него куча компакт дисков. |
Может ещё так можно ярлыки делать?
// не помню какая из них нужна, вообще наити можно поиском в *.pas в каталоге
uses...ShlObj, ComObj, ActiveX, shellapi, ComCtrls, ...
// disk:\Program Files\Borland\Delphi5\Source
procedure SetShortCut(path, cmd, icon, wd, name, arg: string);
var
ShellObject: IUnknown;
LinkFile: IPersistFile;
ShellLink: IShellLink;
begin
try
CoInitialize(nil);
ShellObject := CreateComObject(CLSID_ShellLink);
LinkFile := ShellObject as IPersistFile;
ShellLink := ShellObject as IShellLink;
// RTFM - интерфейсу IShellLink, там вс? описано
ShellLink.SetPath(@cmd[1]);
ShellLink.SetWorkingDirectory(@wd[1]);
ShellLink.SetIconLocation(@icon[1], 0);
// вместо 0 можно указать номер иконки если их там много...
ShellLink.SetDescription(@name[1]);
ShellLink.SetArguments(@arg[1]);
LinkFile.Save(PWChar(WideString(path)), true);
finally
ShellObject := Unassigned;
CoUninitialize;
end;
end;
|
Программно создать ярлык 3.
| Автор: Nomadic |
| Программист увидел НЛО: - У кого-то диск полетел... |
function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string):
IPersistFile;
var
MyObject: IUnknown;
MySLink: IShellLink;
MyPFile: IPersistFile;
WideFile: WideString;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do
begin
SetPath(PChar(CmdLine));
SetArguments(PChar(Args));
SetWorkingDirectory(PChar(WorkDir));
end;
WideFile := LinkFile;
MyPFile.Save(PWChar(WideFile), False);
Result := MyPFile;
end;
procedure CreateShortcuts;
var
Directory, ExecDir: string;
MyReg: TRegIniFile;
begin
MyReg := TRegIniFile.Create(
'Software\MicroSoft\Windows\CurrentVersion\Explorer');
ExecDir := ExtractFilePath(ParamStr(0));
Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' +
ProgramMenu;
CreateDir(Directory);
MyReg.Free;
CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir,
Directory + '\Demonstration.lnk');
CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir,
Directory + '\Installation notes.lnk');
CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir,
Directory + '\Install Intel Video Interactive.lnk');
end;
|
Гм. Вообще правильнее в процедуре CreateShortcuts пользовать Win32API::GetSpecialFolderLocation с нужным параметром (CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае "Рабочего стола").
Юнит для создания ярлыков без использования модулей ShlObj и ComObj.
Автор: KosilkA
unit shortcut;
interface
uses windows;
procedure CreateLink(const FileName, LinkSelfFileName: pchar);
procedure CreateLinkEx(const FileName, RunParams, WorkDir, LinkSelfFileName,
Description, IconFile: pchar; IconNumber, WndParams: cardinal);
implementation
/////////////////////////////////// cuts from ShlObj
const
CLSID_ShellLink: TGUID = (
D1: $00021401; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00,
$46));
type
{$EXTERNALSYM _SHITEMID}
_SHITEMID = record
cb: Word; { Size of the ID (including cb itself) }
abID: array[0..0] of Byte; { The item ID (variable length) }
end;
TSHItemID = _SHITEMID;
{$EXTERNALSYM SHITEMID}
SHITEMID = _SHITEMID;
PItemIDList = ^TItemIDList;
{$EXTERNALSYM _ITEMIDLIST}
_ITEMIDLIST = record
mkid: TSHItemID;
end;
TItemIDList = _ITEMIDLIST;
{$EXTERNALSYM IShellLinkA}
IShellLinkA = interface(IUnknown) { sl }
['{000214EE-0000-0000-C000-000000000046}']
function GetPath(pszFile: PAnsiChar; cchMaxPath: Integer;
var pfd: TWin32FindData; fFlags: DWORD): HResult; stdcall;
function GetIDList(var ppidl: PItemIDList): HResult; stdcall;
function SetIDList(pidl: PItemIDList): HResult; stdcall;
function GetDescription(pszName: PAnsiChar; cchMaxName: Integer): HResult;
stdcall;
function SetDescription(pszName: PAnsiChar): HResult; stdcall;
function GetWorkingDirectory(pszDir: PAnsiChar; cchMaxPath: Integer):
HResult; stdcall;
function SetWorkingDirectory(pszDir: PAnsiChar): HResult; stdcall;
function GetArguments(pszArgs: PAnsiChar; cchMaxPath: Integer): HResult;
stdcall;
function SetArguments(pszArgs: PAnsiChar): HResult; stdcall;
function GetHotkey(var pwHotkey: Word): HResult; stdcall;
function SetHotkey(wHotkey: Word): HResult; stdcall;
function GetShowCmd(out piShowCmd: Integer): HResult; stdcall;
function SetShowCmd(iShowCmd: Integer): HResult; stdcall;
function GetIconLocation(pszIconPath: PAnsiChar; cchIconPath: Integer;
out piIcon: Integer): HResult; stdcall;
function SetIconLocation(pszIconPath: PAnsiChar; iIcon: Integer): HResult;
stdcall;
function SetRelativePath(pszPathRel: PAnsiChar; dwReserved: DWORD): HResult;
stdcall;
function Resolve(Wnd: HWND; fFlags: DWORD): HResult; stdcall;
function SetPath(pszFile: PAnsiChar): HResult; stdcall;
end;
{$EXTERNALSYM IShellLink}
IShellLink = IShellLinkA;
/////////////////////////////////// End of cuts from ShlObj
/////////////////////////////////// cuts from ActiveX
type
{$EXTERNALSYM IPersist}
IPersist = interface(IUnknown)
['{0000010C-0000-0000-C000-000000000046}']
function GetClassID(out classID: TGUID): HResult; stdcall;
end;
{$EXTERNALSYM IPersistFile}
IPersistFile = interface(IPersist)
['{0000010B-0000-0000-C000-000000000046}']
function IsDirty: HResult; stdcall;
function Load(pszFileName: PWideChar; dwMode: Longint): HResult;
stdcall;
function Save(pszFileName: PWideChar; fRemember: BOOL): HResult;
stdcall;
function SaveCompleted(pszFileName: PWideChar): HResult;
stdcall;
function GetCurFile(out pszFileName: PWideChar): HResult;
stdcall;
end;
procedure CoUninitialize; stdcall; external 'ole32.dll' name 'CoUninitialize';
function CoInitialize(pvReserved: Pointer): HResult; stdcall; external
'ole32.dll' name 'CoInitialize';
function CoCreateInstance(const clsid: TGUID; unkOuter: IUnknown;
dwClsContext: Longint; const iid: TGUID; out pv): HResult; stdcall; external
'ole32.dll' name 'CoCreateInstance';
////////////////////////////////// End of cuts from ActiveX
procedure CreateLink(const FileName, LinkSelfFileName: pchar);
var
IObject: IUnknown;
begin
Coinitialize(nil);
if CoCreateInstance(CLSID_ShellLink, nil, 1 or
4, IUnknown, IObject) <> 0 then
begin
CoUninitialize;
exit;
end;
(IObject as IShellLink).SetPath(FileName);
(IObject as IPersistFile).Save(PWChar(WideString(LinkSelfFileName)), FALSE);
CoUninitialize;
end;
procedure CreateLinkEx(const FileName, RunParams, WorkDir, LinkSelfFileName,
Description, IconFile: pchar; IconNumber, WndParams: cardinal);
var
IObject: IUnknown;
begin
Coinitialize(nil);
if CoCreateInstance(CLSID_ShellLink, nil, 1 or
4, IUnknown, IObject) <> 0 then
begin
CoUninitialize;
exit;
end;
with (IObject as IShellLink) do
begin
SetPath(FileName);
SetArguments(RunParams);
SetWorkingDirectory(WorkDir);
SetDescription(Description);
SetIconLocation(IconFile, IconNumber);
SetShowCmd(WndParams);
end;
(IObject as IPersistFile).Save(PWChar(WideString(LinkSelfFileName)), FALSE);
CoUninitialize;
end;
end.
Как открыть диалог создания ярлыка.
Автор: http://www.swissdelphicenter.ch
uses
registry, shellapi;
function Launch_CreateShortCut_Dialog(Directory: string): Boolean;
var
reg: TRegistry;
cmd: string;
begin
Result := False;
reg := TRegistry.Create;
try
reg.Rootkey := HKEY_CLASSES_ROOT;
if reg.OpenKeyReadOnly('.LNK\ShellNew') then
begin
cmd := reg.ReadString('Command');
cmd := StringReplace(cmd, '%1', Directory, []);
Result := True;
WinExec(PChar(cmd), SW_SHOWNORMAL);
end
finally
reg.Free;
end;
end;
{Example}
procedure TForm1.Button1Click(Sender: TObject);
begin
Launch_CreateShortCut_Dialog('c:\temp');
end;
Создать ярлык на рабочем столе.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses ComObj, ActiveX, ShlObj, Registry;
const
{ Registry key where Folder information is kept }
SFolderKey = '\Software\Microsoft\Windows\CurrentVersion\' +
'Explorer\Shell Folders';
function GetFolderLocation(const FolderType: string): string;
{ Retrieves from registry path to folder indicated in FolderType }
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
if not OpenKey(SFolderKey, False) then
{ open key where shell folder information is kept. }
raise ERegistryException.CreateFmt('Folder key "%s" not found',
[SFolderKey]);
{ Get path for specified folder }
Result := ReadString(FolderType);
if Result = '' then
raise ERegistryException.CreateFmt('"%s" item not found in registry',
[FolderType]);
CloseKey;
finally
Free;
end;
end;
procedure MakeNotepad;
const
// NOTE: Assumed location for Notepad:
AppName = 'c:\windows\notepad.exe';
var
SL: IShellLink;
PF: IPersistFile;
LnkName: WideString;
begin
OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
IShellLink, SL));
{ IShellLink implementers are required to implement IPersistFile }
PF := SL as IPersistFile;
OleCheck(SL.SetPath(PChar(AppName))); // set link path to proper file
{ create a path location and filename for link file }
LnkName := GetFolderLocation('Desktop') + '\' +
ChangeFileExt(ExtractFileName(AppName), '.lnk');
PF.Save(PWideChar(LnkName), True); // save link file
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MakeNotepad;
end;
end.
Как создать поле Lookup во время выполнения приложения.
uses
Forms, Classes, Controls, StdCtrls, Db, DBTables, DBCtrls;
type
TForm1 = class(TForm)
Table1: TTable; // DBDemos customer table
Table2: TTable; // DBDemos orders table
Button1: TButton;
DBLookupComboBox1: TDBLookupComboBox;
DataSource1: TDataSource;
Table2CustNo: TFloatField; // CustNo key field object used for Lookup
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
with TStringField.Create(Table2) do
begin
FieldName := 'MyLookup';
FieldKind:= fkLookup;
DataSet := Table2;
name := Dataset.name + FieldName;
KeyFields:= 'CustNo';
LookUpDataset:= Table1;
LookUpKeyFields:= 'CustNo';
LookUpResultField:= 'Company';
DbLookupCombobox1.DataField:= FieldName;
DataSource1.DataSet:= Dataset;
Table2.FieldDefs.Add(name, ftString, 20, false);
end;
DbLookupCombobox1.DataSource:= Datasource1;
Table1.Active:= True;
Table2.Active:= True;
end;
end.
|
Создание множества экземпляров.
list:=Tlist.create;
For i:= 1 to 1000 do
begin
SSObject:=TSSObject.create;
{поместите куда-нибудь ссылку на созданный объект - например, в Tlist}
list.add(SSObject);
end;
|
Создать мультимедийный таймер.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
The timeSetEvent function starts a specified timer event.
The multimedia timer runs in its own thread. After the event is activated,
it calls the specified callback function or sets or pulses the spe
cified event object.
MMRESULT timeSetEvent(
UINT uDelay,
UINT uResolution,
LPTIMECALLBACK lpTimeProc,
DWORD_PTR dwUser,
UINT fuEvent
);
uDelay:
Event delay, in milliseconds
uResolution:
Resolution of the timer event, in milliseconds.
A resolution of 0 indicates periodic events should occur with the
greatest possible accuracy.
You should use the use the maximum value appropriate to reduce system overhead.
fuEvent:
TIME_ONESHOT Event occurs once, after uDelay milliseconds.
TIME_PERIODIC Event occurs every uDelay milliseconds.
}
uses
MMSystem;
var
mmResult: Integer;
// callback function
procedure TimeCallBack(TimerID, Msg: Uint; dwUser, dw1, dw2: DWORD); pascal;
begin
// Do something here. This procedure will be executed each 10 ms
Form1.Label1.Caption := Form1.Label1.Caption + '%';
end;
// Set a new timer with a delay of 10 ms
procedure TForm1.Button1Click(Sender: TObject);
begin
mmResult := TimeSetEvent(10, 0, @TimeCallBack, 0, TIME_PERIODIC);
end;
// Cancel the timer event.
procedure TForm1.FormDestroy(Sender: TObject);
begin
TimeKillEvent(mmResult);
end;
Создать, изменить и удалить TrayIcon.
В программах для Window 95 и выше часто используется TrayIcon – иконка справа на TaskBar, которая позволяет программе почти не занимать места на экране и при этом быть всегда доступной. Для работы с TrayIcon используется функция Shell_NotifyIcon, в которую передается команда: NIM_ADD, NIM_MODIFY или NIM_DELETE для создания изменения и удаления соответственно, и структура TNotifyIconData. У каждой TrayIcon в вашем приложении должен быть свой uID.
const
WM_NOTIFYTRAYICON = WM_USER + 1;
...
private
procedure WMTRAYICONNOTIFY(var Msg: TMessage); message WM_NOTIFYTRAYICON;
...
uses
ShellAPI;
procedure TForm1.WMTRAYICONNOTIFY(var Msg: TMessage);
var
s: string;
begin
case Msg.LParam of
WM_MOUSEMOVE: s := 'Мышь сдвинута';
WM_LBUTTONDOWN: s := 'Левая кнопка нажата';
WM_LBUTTONUP: s := 'Левая кнопка отпущена';
WM_LBUTTONDBLCLK: s := 'Два раза нажата левая кнопка';
WM_RBUTTONDOWN: s := 'Правая кнопка нажата';
WM_RBUTTONUP: s := 'Правая кнопка отпущена';
WM_RBUTTONDBLCLK: s := 'Два раза нажата правая кнопка';
else s := IntToStr(Msg.LParam);
end;
ListBox1.Items.Add(s);
ListBox1.ItemIndex := ListBox1.Items.Count - 1;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
tray: TNotifyIconData;
Ic: TIcon;
begin
Ic := TIcon.Create;
Ic.LoadFromFile('Icon1.ico');
with tray do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := Form1.Handle;
uID := 1;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := Ic.Handle;
szTip := ('Это наша иконка');
end;
Shell_NotifyIcon(NIM_ADD, Addr(tray));
Ic.Destroy;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
tray: TNotifyIconData;
Ic: TIcon;
begin
Ic := TIcon.Create;
Ic.LoadFromFile('Icon2.ico');
with tray do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := Form1.Handle;
uID := 1;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := Ic.Handle;
szTip := ('Это другая иконка');
end;
Shell_NotifyIcon(NIM_MODIFY, Addr(tray));
Ic.Destroy;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
tray: TNotifyIconData;
begin
with tray do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := Form1.Handle;
uID := 1;
end;
Shell_NotifyIcon(NIM_DELETE, Addr(tray));
end;
|
Создание новой MS Access базы данных.
Автор: Vit WEB-сайт: http://forum.vingrad.ruПриведенная ниже процедура создает пустую базу данных MS Access.
procedure CreateMSAccessDatabase(filename: string);
var
DAO: Variant;
i: integer;
const
Engines: array[0..2] of string = ('DAO.DBEngine.36', 'DAO.DBEngine.35',
'DAO.DBEngine');
function CheckClass(OLEClassName: string): boolean;
var
Res: HResult;
begin
Result := CoCreateInstance(ProgIDToClassID(OLEClassName), nil,
CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IDispatch, Res) = S_OK;
end;
begin
for i := 0 to 2 do
if CheckClass(Engines[i]) then
begin
DAO := CreateOleObject(Engines[i]);
DAO.Workspaces[0].CreateDatabase(filename,
';LANGID=0x0409;CP=1252;COUNTRY=0', 32);
exit;
end;
raise Exception.Create('DAO engine could not be initialized');
end;
Как создать таблицу.
Вариантов несколько:
Сделать это с помошью менеджера соответствующей базы данных, например таблицу для Paradox создать в Paradox'e С помощью Database Desktop - утилита , постовляемая с BDE и большинством борландовских продуктов. Я не думаю что вы встретите проблемы при создании таблицы - там всё очень просто. Из программы.Здесь 2 варианта, вариант первый, использовать метод CreateTable у таблицы, вот пример из справки по Дельфи как Борланд предлагает это делать:
with Table1 do
begin
Active := False;
DatabaseName := 'DBDEMOS';
TableType := ttParadox;
TableName := 'CustInfo';
{ Don't overwrite an existing table }
if not Table1.Exists then
begin
{ The Table component must not be active }
{ First, describe the type of table and give }
{ it a name }
{ Next, describe the fields in the table }
with FieldDefs do
begin
Clear;
with AddFieldDef do
begin
Name := 'Field1';
DataType := ftInteger;
Required := True;
end;
with AddFieldDef do
begin
Name := 'Field2';
DataType := ftString;
Size := 30;
end;
end;
{ Next, describe any indexes }
with IndexDefs do
begin
Clear;
{ The 1st index has no name because it is
{ a Paradox primary key }
with AddIndexDef do
begin
Name := '';
Fields := 'Field1';
Options := [ixPrimary];
end;
with AddIndexDef do
begin
Name := 'Fld2Indx';
Fields := 'Field2';
Options := [ixCaseInsensitive];
end;
end;
{ Call the CreateTable method to create the table }
CreateTable;
end;
end;
Есть другой метод, который нравится мне гораздо больше, он проще в реализации и работает стабильнее - выполнить Query типа "Create Table".
Создание нового WAV-файла.
Данный документ был создан по многочисленным просьбам пользователей и описывает дополнительную функциональность компонента Delphi TMediaPlayer. Новая функциональность компонента заключается в возможности создания при записи нового файла формата .wav. Процедура "SaveMedia" создает тип record, передаваемый команде MCISend. Существует исключение, которое вызывает закрытие медиа при любой ошибке, возникающей при открытии определенного файла. Приложение состоит из двух кнопок. Button1 вызывает по-порядку процедуры OpenMedia и RecordMedia. Процедура CloseMedia вызывается при генерации приложением исключительной ситуации. Button2 вызывает процедуры StopMedia,SaveMedia и CloseMedia.
unit utestrec;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, MPlayer, MMSystem, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure AppException(Sender: TObject; E: Exception);
private
FDeviceID: Word;
{ Private declarations }
public
procedure OpenMedia;
procedure RecordMedia;
procedure StopMedia;
procedure SaveMedia;
procedure CloseMedia;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
var
MyError, Flags: Longint;
procedure TForm1.OpenMedia;
var
MyOpenParms: TMCI_Open_Parms;
MyPChar: PChar;
TextLen: Longint;
begin
Flags := mci_Wait or mci_Open_Element or mci_Open_Type;
with MyOpenParms do
begin
dwCallback := Handle; // TForm1.Handle
lpstrDeviceType := PChar('WaveAudio');
lpstrElementName := PChar('');
end;
MyError := mciSendCommand(0, mci_Open, Flags,
Longint(@MyOpenParms));
if MyError = 0 then
FDeviceID := MyOpenParms.wDeviceID;
end;
procedure TForm1.RecordMedia;
var
MyRecordParms: TMCI_Record_Parms;
TextLen: Longint;
begin
Flags := mci_Notify;
with MyRecordParms do
begin
dwCallback := Handle; // TForm1.Handle
dwFrom := 0;
dwTo := 10000;
end;
MyError := mciSendCommand(FDeviceID, mci_Record, Flags,
Longint(@MyRecordParms));
end;
procedure TForm1.StopMedia;
var
MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID <> 0 then
begin
Flags := mci_Wait;
MyGenParms.dwCallback := Handle; // TForm1.Handle
MyError := mciSendCommand(FDeviceID, mci_Stop, Flags,
Longint(@MyGenParms));
end;
end;
procedure TForm1.SaveMedia;
type // не реализовано в Delphi
PMCI_Save_Parms = ^TMCI_Save_Parms;
TMCI_Save_Parms = record
dwCallback: DWord;
lpstrFileName: PAnsiChar; // имя файла, который нужно сохранить
end;
var
MySaveParms: TMCI_Save_Parms;
begin
if FDeviceID <> 0 then
begin
// сохраняем файл...
Flags := mci_Save_File or mci_Wait;
with MySaveParms do
begin
dwCallback := Handle;
lpstrFileName := PChar('c:\message.wav');
end;
MyError := mciSendCommand(FDeviceID, mci_Save, Flags,
Longint(@MySaveParms));
end;
end;
procedure TForm1.CloseMedia;
var
MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID <> 0 then
begin
Flags := 0;
MyGenParms.dwCallback := Handle; // TForm1.Handle
MyError := mciSendCommand(FDeviceID, mci_Close, Flags,
Longint(@MyGenParms));
if MyError = 0 then
FDeviceID := 0;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenMedia;
RecordMedia;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
StopMedia;
SaveMedia;
CloseMedia;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := AppException;
end;
procedure TForm1.AppException(Sender: TObject; E: Exception);
begin
CloseMedia;
end;
end.
|
Создание страниц компонента Notebook во время работы приложения.
procedure TForm1.Button1Click(Sender: TObject);
var
NewPage: TWinControl;
begin
TabbedNotebook1.Pages.Add(Edit1.Text);
NewPage := TabbedNotebook1.Pages.Objects[TabbedNotebook1.Pages.Count - 1]
as TWinControl;
with TLabel.Create(Self) do
begin
Left := 20;
Top := 20;
Caption := '&Телефон: ';
Parent := NewPage;
end;
with TEdit.Create(Self) do
begin
Left := 100;
Top := 20;
Text := '1-800-555-1212';
Parent := NewPage;
end;
end;
|
Создание объектных переменных.
В новостной группе я несколько раз встречал вопросы подобного плана, указывающие на недостаток понимания работы экземпляра объекта. Я понимаю, что данный вопрос могут задать скорее новички в программировании, поэтому свой рассказ я начну издалека - с организации классов в Delphi. Я надеюсь, что моя "попытка" ликбеза по крайней мере объяснит суть предмета. Во всяком случае, рекомендую данный материал для всех, кто хоть раз сталкивался с ошибками указателей, исключительными ситуациями и GPF.Когда вы объявляете переменную некоторого типа класса, как например...
var MyVar: TMyClass; |
Delphi распределит и заполнит память за вас, но и вы должны немного потрудиться. Когда вы используете один из классов Delphi или свой собственный, вы должны создать его экземпляр. Что это значит: вы должны распределить память и установить на распределенный блок памяти указатель. В некоторых языках это выглядит безобразно, в Delphi же это выглядит так...
MyVar := TMyClass.Create; |
procedure Example; var MyObj: TMyClass; // класс, который вы создаете MyList: TList; // встроенный класс begin MyObj := TMyClass.Create; // теперь MyObj содержит адрес блока памяти, // распределенной для экземпляра вашего класса MyList := TList.Create; // Код для работы с MyList // .... // здесь что-то делаем с объектом // .... MyList.Free; // Ресурсы MyList удаляются из кучи MyObj.Free; // тоже самое для MyObj end; |
Создать ярлык объекта в любой папке.
| - Дискеты не нужны? - А новые? - Еще девочки. |
procedure TForm1.Button1Click(Sender: TObject);
var
MyObject: IUnknown;
MyIcon: IShellLink;
MyPFile: IPersistFile;
FileName: string;
Directory: string;
WFileName: WideString;
MyReg: TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MyIcon := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
//Указать что является запускающей программой
FileName := 'C:\Project.exe';
with MyIcon do
begin
// Какой файл подвергаеться воздействию запускающей программы
SetArguments('C:\Project.exe');
//Установить путь к запускающему файлу
SetPath(PChar(FileName));
// Установить рабочую директорию
SetWorkingDirectory(PChar(ExtractFilePath(FileName)));
end;
MyReg :=
TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
{Begin_Чтобы положить ярлык на Desktop}
Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
{End_Чтобы положить ярлык на Desktop}
{Begin_Чтобы положить ярлык в start menu}
//{Directory := MyReg.ReadString('Shell Folders','Start Menu','')+
// '\Whoa!'; //CreateDir(Directory);
{End_Чтобы положить ярлык в start menu}
{Begin_Чтобы положить ярлык в любую директор.}
//Directory := 'c:\windows\desktop';
{End_Чтобы положить ярлык в любую директор.}
WFileName := Directory + '/ShortCut1.lnk';
MyPFile.Save(PWChar(WFileName), False);
MyReg.Free;
end;
|
Пример создания 3D движка.
Автор: BoogeMan Оформил: RT17.
OpenGL - стандартный для большинства платформ и операционных систем набор низкоуровневых функций двумерной и трехмерной графики, библиотека, широко используемая в промышленных CAD-системах и играх. Поставляется в составе операционной системы Windows, начиная с версии OSR2 в виде двух DLL-файлов - opengl32.dll и glu32.dll. Первая из этих библиотек и есть собственно набор функций OpenGL, вторая содержит дополнительный набор функций, упрощающих кодирование, но построенных и выполняемых с подключением opengl32.dll и являющаяся надстройкой. То, что эти библиотеки поставляются в составе операционной системы, значительно упрощает распространение разработанных приложений. То, что OpenGL распространяется в виде динамических библиотек, упрощает доступ к его функциям. При выборе базы для построения приложений графики несомненными достоинствами OpenGL являются его простота и стандартность - код в случае необходимости можно легко перенести на другую платформу или под другую операционную систему. Для более подробной информации о OpenGL смотрите здесь.
Ну что, начнем?
Для начала создадим пару классов для дальнейшей работы.
3D объект.
unit gl_max;
interface
uses
Windows, Messages, Classes, Graphics, Forms, ExtCtrls, Controls, Dialogs, SysUtils, OpenGL;
type
gl_color=array[1..3]of glfloat;
gl_Rotate=array[1..3]of glfloat;
text_cor=record
x,y:glfloat; //нормаль (вектор)
end;
normal=record
x,y,z:glfloat; //нормаль (вектор)
znak:boolean; //знак нормали
end;
sl_point=^tpoint;
tpoint=record
x,y,z:integer;
texture:text_cor;
smooh_nrml:normal;
n:integer; //координаты и номер
select:boolean; //выделение точки
color:gl_color; //цвет вершины
next:sl_point; //сл. точка в списке
end;
tpoint_fl=record
x,y,z:glfloat;
end;
sl_poly=^tpoly;
tpoly=record
vr:array[1..3]of sl_point; //Ссылки на точки в списке
nrml:normal; //каждый полигон имеет свою нормаль
gl_p_color:boolean; //цвет полигона или по верширнам
color:gl_color; //цвет полигона
next:sl_poly; //ссылка на сл. полигон
end;
sl_obj=^tGL_object3D;
tGL_object3D = class
obj_set:record
texture,smooth,
color_m,light:boolean;
draw_mode:glenum;
end;
angcn,angfr:array[1..3]of glfloat;
next:sl_obj;
x,y,z:integer;
select:boolean;
smooth:boolean;
private
fall_points:sl_point; //Список точек
next_p,new_p:sl_point; //Список точек
fall_polys,next_poly:sl_poly; //список полигонов
sh_points:boolean;
sh_frame:boolean;
public
function put_point(x,y,z:integer):sl_point;
function put_polygon:sl_poly;
function get_selested:integer;
function get_point(x,y,z:integer):sl_point;
function get_sel_poly:sl_poly;
procedure set_text_cor(x,y:glfloat);
function get_col_points:integer;
function get_col_polys:integer;
procedure ved_diap(x,y,z,rad:glfloat);
procedure ved_poly_by_point;
function line_per(x1,y1,z1,x2,y2,z2:glfloat;var nrm:normal):tpoint_fl;
procedure reset_ss_normals;
procedure reset_sm_nrml_sel;
procedure reset_sm_nrml;
procedure filter_obj(x,y,z,rad:glfloat);
procedure sin_obj(kof:glfloat);
procedure set_s_color(r,g,b:glfloat);
procedure de_sel;
procedure invert_obj(x,y,z:boolean);
procedure clear_obj;
procedure select_all;
procedure invert_select;
procedure show_points(mode:boolean);
procedure show_frame(mode:boolean);
procedure invert_nrm;
procedure del_polygons;
procedure del_points;
procedure reset_normals; //производит расщет всех нормалей
procedure invert_normals; //инвертирует все нормали
procedure LoadFromFile(const FileName : String);
procedure Save_to_File(const FileName : String);
procedure Draw;
end;
Список 3D объектов, единичный объект которого будет класс tGL_object3D.
tList_objects3D = class
private
fall_obj,new_obj,next_obj:sl_obj;
public
function put_obj(x,y,z:integer;filename:string):sl_obj;
function GET_obj_XY(x,y:integer):sl_obj;
function GET_obj_Xz(x,z:integer):sl_obj;
function get_col_s:integer;
function get_col:integer;
procedure sel_point_xz(x,z:integer);
procedure set_color(r,g,b:glfloat);
procedure SET_TEXT_CORD(x,y:glfloat);
procedure filter_list(x,y,z,rad:glfloat);
procedure reset_nrm_s;
procedure del_poly_obj;
procedure sdv_object(x,y,z:integer);
procedure del_s_points;
procedure sel_point_xy(x,y:integer);
procedure put_poly_obj;
procedure save_to_file_s(filename:string);
procedure sel_all_points;
procedure select_all;
procedure inv_select;
procedure inv_smooth;
procedure set_draw_mode(mode:glenum);
procedure show_points(b:boolean);
procedure save_to_list_file(filename:string);
procedure load_from_list_file(filename:string);
procedure put_point_In_s(x,y,z:integer);
procedure sdv_points_obj(xh,yh,zh:integer);
procedure invert_objects(x,y,z:boolean);
procedure Inv_sel_points;
procedure obr_nrm_sel;
procedure draw_list;
procedure draw_list_xy(pw,ph,xsm,ysm,st:integer);
procedure draw_list_xz(pw,ph,xsm,ysm,st:integer);
procedure calk_sm_nrml;
procedure del_obj;
procedure clear;
end;
И несколько дополнительный функций:
procedure butbar3d(x1,y1,z1,x2,y2,z2:real;dr_type:glenum); function get_Normal(p1,p2,p3:tpoint;zn:boolean):normal; function get_Normal_fl(p1,p2,p3:tpoint_fl):normal; function get_dl_line(x1,y1,z1,x2,y2,z2:glfloat):glfloat; function get_S_abc(x1,y1,z1,x2,y2,z2,x3,y3,z3:integer):glfloat; function getpoint(p1,p2,pt1,pt2,pt3:tpoint_fl;nrm:normal):tpoint_fl; function get_angle(x,y:glfloat):glfloat; function point_in_triangle(x1,y1,x2,y2,x3,y3,x,y:glfloat):boolean; function PixelInOtr(x1,y1,x2,y2,x,y:glfloat):boolean; procedure rotate_point(angle:glfloat;var x,y:glfloat); procedure butbar3d_in(x1,y1,z1,x2,y2,z2:real;dr_type:glenum);
Теперь немного о самой форме :
Будем обрабатывать следующие:
procedure FormCreate(Sender: TObject); // выбираем нужный адаптер и устанавливаем нужные размеры окна procedure FormDestroy(Sender: TObject); //возврощаем все что взяли procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); //смотрем что зажато procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); //смотрем что отпустили procedure FormKeyPress(Sender: TObject; var Key: Char); //смотрем что нажали
Исходный текст можна взять здесь.
Как в Oracle создать sequence с некоторого номера.
Автор: Nomadic.
create sequence minvalue 10; |
Как создать каретку своей собственной формы.
Автор: http://www.swissdelphicenter.ch
{
The example below demonstrates creating custom caret:
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Image1: TImage;
Edit1: TEdit;
procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
CreateCaret(Memo1.Handle, Image1.Picture.Bitmap.Handle, 0, 0);
ShowCaret(Memo1.Handle);
end;
procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
CreateCaret(Edit1.Handle, 0, 10, 4);
ShowCaret(Edit1.Handle);
end;
end.
{The form file source (*.dfm) }
object Form1: TForm1
Left = 192
Top = 107
Width = 544
Height = 375
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Image1: TImage
Left = 12
Top = 4
Width = 16
Height = 16
AutoSize = True
Picture.Data = {
07544269746D6170B6020000424DB602000000000000B6000000280000001000
0000100000000100100000000000000200000000000000000000100000000000
000000000000000080000080000000808000800000008000800080800000C0C0
C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
FF00000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F
00000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000
0000FF7FFF7FFF7FFF7FFF7F00000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000
000000000000FF7FFF7FFF7F0000000000000000FF7FFF7FFF7FFF7F00000000
0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000000
0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F000000000000
0000000000000000FF7FFF7FFF7F00000000FF7FFF7FFF7FFF7F000000000000
00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
000000000000000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
000000000000000000000000FF7FFF7FFF7FFF7FFF7F00000000000000000000
0000000000000000000000000000FF7FFF7FFF7FFF7F00000000000000000000
0000000000000000000000000000FF7FFF7FFF7F000000000000000000000000
00000000000000000000000000000000FF7F0000000000000000000000000000
0000}
end
object Memo1: TMemo
Left = 12
Top = 36
Width = 149
Height = 149
Lines.Strings = ('Memo1')
TabOrder = 0
OnMouseDown = Memo1MouseDown
end
object Edit1: TEdit
Left = 220
Top = 60
Width = 121
Height = 21
TabOrder = 1
Text = 'Edit1'
OnMouseDown = Edit1MouseDown
end
end
Как создать собственное Hint-окно.
Автор: Олег Кулабухов.
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := false;
Panel1.Visible := false;
Panel1.BevelInner := bvNone;
Panel1.BevelOuter := bvNone;
Panel1.BorderStyle := bsSingle;
Panel1.Color := clWhite;
Button1.Hint := 'Hint test';
end;
procedure TForm1.ShowAHint(x: integer;
y: integer;
Caption: string;
Duration: LongInt);
var
dc: hdc;
OldFont: hFont;
pt: TSize;
p: pChar;
begin
if Timer1.Enabled <> false then
Timer1.Enabled := false;
Timer1.Enabled := false;
if Panel1.Visible <> false then
Panel1.Visible := false;
if Caption = '' then
exit;
Panel1.Caption := caption;
{Get the width of the caption string}
GetMem(p, Length(Panel1.Caption) + 1);
StrPCopy(p, Panel1.Caption);
dc := GetDc(Panel1.Handle);
OldFont := SelectObject(dc, Panel1.Font.Handle);
GetTextExtentPoint32(dc, p, Length(Panel1.Caption), pt);
SelectObject(dc, OldFont);
ReleaseDc(Panel1.Handle, Dc);
FreeMem(p, Length(Panel1.Caption) + 1);
{Position and show the panel}
Panel1.Left := x;
Panel1.Top := y;
Panel1.Width := pt.cx + 6;
Panel1.Height := pt.cy + 2;
Panel1.Visible := true;
{Fire off the timer to hide the panel}
Timer1.Interval := Duration;
Timer1.Enabled := true;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if Panel1.Visible <> false then
Panel1.Visible := false;
Timer1.Enabled := false;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
{Let the button repaint}
Application.ProcessMessages;
ShowAHint(Button1.Left,
Button1.Top + Button1.Height + 6,
Button1.Hint,
2000);
end;
|
Код создания палитры.
var
Form1: TForm1;
blueVal: Byte;
BluePalette: HPalette;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
LogicalPalette: PLogPalette;
ColorIndex: LongInt;
begin
GetMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
GetSystemPaletteEntries(Canvas.Handle, 0, 256,
LogicalPalette^.palPalEntry[0]);
with LogicalPalette^ do
begin
palVersion := $300;
palNumEntries := 256;
{$R-}
for ColorIndex := 10 to 245 do
with palPalEntry[ColorIndex] do
begin
peRed := 0;
peGreen := 0;
peBlue := 255 - (ColorIndex - 10);
peFlags := PC_NOCOLLAPSE;
end;
end;
{$R+}
BluePalette := CreatePalette(LogicalPalette^);
FreeMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(BluePalette);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
OldPal: HPALETTE;
begin
OldPal := SelectPalette(Canvas.Handle, BluePalette, False);
RealizePalette(Canvas.Handle);
canvas.pen.color := $02000000 or (BlueVal * $00010000);
canvas.pen.width := 10;
canvas.moveto(0, 0);
canvas.lineto(X, Y);
SelectPalette(Canvas.Handle, OldPal, False);
Inc(BlueVal);
if BlueVal > 255 then
BlueVal := 0;
end;
|
Для создания панелей в двумя полосами слева, которые можно двигать.
Для создания панелей в двумя полосами слева, которые можно двигать друг относительно друга, используют компонент ControlBar (вкладка Additional), на котором обычно размещают один или несколько ToolBar (вкладка Win32). Чтобы сделать возможным "вытаскивание" панели из ControlBar нужно написать следующий код:
procedure TForm1.FormCreate(Sender: TObject);
begin
ToolBar1.DockSite := true;
ToolBar1.DragKind := dkDock;
ToolBar1.DragMode := dmAutomatic;
end;
procedure TForm1.ControlBar1DockOver(Sender: TObject;
Source: TDragDockObject; X, Y: Integer; State: TDragState;
var Accept: Boolean);
begin
Accept := (Source.Control is TToolBar);
if Accept then
with Source.DockRect do
begin
TopLeft := ControlBar1.ClientToScreen(ControlBar1.ClientRect.TopLeft);
Right := Left + Source.Control.Width;
Bottom := Top + Source.Control.Height;
end;
end;
|
Вы можете убрать метод FormCreate, установив нужные свойства компонента ToolBar1 на стадии разработки при помощи Object Inspector.
Создание потомка от класса зарегистрированного в Delphi.
Для того, чтобы определить когда мышь над компонентом, в данном примере это будет панель, мы создадим новый класс, который будет являться потомком класса TPanel, и будет обрабатывать некоторые необходимые нам для данной задачи сообщения Windows.
Для этого определим следующим образом новый тип:
type
TMyPanel = class(TPanel)
public
procedure CMMouseEnter (var message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave (var message: TMessage); message CM_MOUSELEAVE;
end;
|
Называться наш новый класс будет TMyPanel. Определить его можете до определение класса формы, т.е. сразу после директивы uses.
После объявления экземпляра формы нужно объявить экземпляр нашего нового класса:
var Form1: TForm1; MyPanel1: TMyPanel; |
В разделе implemetation обрабатываем несколько сообщения, именно этими обработчиками наш класс и будет отличаться от класса стандартной панели.
procedure TMyPanel.CMMouseEnter (var message: TMessage); begin Form1.Label1.Caption := 'Мышь на панели'; end; procedure TMyPanel.CMMouseLEAVE (var message: TMessage); begin Form1.Label1.Caption : ='Мышь вне панели'; end; |
По созданию окна создаём экземпляр нашего класса:
procedure TForm1.FormCreate(Sender: TObject);
begin
MyPanel1 := TMyPanel.Create(self);
with MyPanel1 do
begin
Parent := Form1;
Visible := true;
Left := 100;
Top := 100;
end;
end;
|
По уничтожению окна, соответственно, - уничтожаем:
procedure TForm1.FormDestroy(Sender: TObject); begin MyPanel1.Destroy; end; |
Создание таблицы Paradox.
Вот маленький кусочек кода для создания таблицы Paradox:
with TTable.create(self) do
begin
DatabaseName := 'C:\temp';
TableName := 'FOO';
TableType := ttParadox;
with FieldDefs do
begin
Add('Age', ftInteger, 0, True);
Add('Name', ftString, 25, False);
Add('Weight', ftFloat, 0, False);
end;
IndexDefs.Add('MainIndex', 'IntField', [ixPrimary, ixUnique]);
CreateTable;
end;
|
Принцип создания плагинов в Delphi.
Иногда нужные мысли приходят после того, как программа сдана заказчику. Для этого придумали плугины. Плугины - это простая dll библиотека, в которой обязательно присутствует ряд процедур и функций, которые выполняют определенные разработчиком действия, например (из моей практики):
function PluginType : PChar; |
function PluginName : PChar; |
function PluginExec(AObject: ТТип): boolean; |
И ещё, я делал res файл с небольшим битмапом и компилировал его вместе с плугином, который отображался в меню соответствующего плугина. Откомпилировать res файл можно так:
создайте файл с расширением *.rc напишите в нём : bitmap RCDATA LOADONCALL 1.bmp где bitmap - это идентификатор ресурса RCDATA LOADONCALL - тип и параметр 1.bmp - имя локального файла для кампиляций откомпилируйте этот файл программой brcc32.exe, лежащей в папке ...\Delphi5\BIN\ . Загрузка плагина Перейдём к теоретической части. Раз плугин это dll значит её можно подгрузить следующими способами: Прищипыванием её к программе!
function PluginType : PChar; external 'myplg.dll'; // в таком случае dll должна обязательно лежать возле exe и мы не можем передать // туда конкретное имя! не делать же все плугины одного имени! это нам не подходит. // Программа просто не загрузится без этого файла! Выдаст сообщение об ошибке. // Этот способ может подойти для поддержки обновления вашей программы! |
var
// объявляем процедурный тип функции из плугина
PluginType: function: PChar;
//объявляем переменную типа хендл в которую мы занесём хендл плугина
PlugHandle: THandle;
procedure Button1Click(Sender: TObject);
begin
//грузим плугин
PlugHandle := LoadLibrary('MYplg.DLL');
//Получилось или нет?
if PlugHandle <> 0 then
begin
// ищем функцию в dll
@PluginType := GetProcAddress(plugHandle,'Plugintype');
if @PluginType <> nil then
//вызываем функцию
ShowMessage(PluginType);
end;
//освобождаем библиотеку
FreeLibrary(LibHandle);
end;
|
//как вы поняли загружает dll и возвращает её хендл function LoadLibrary(lpLibFileName : Pchar):THandle; // пытается найти обработчик в переданной ей хендле dll, // при успешном выполнении возвращает указатель обработчика. function GetProcAddress(Module: THandle; ProcName: PChar): TFarProc //освобождает память, занитую dll function FreeLibrary(LibModule: THandle); |
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Menus, Grids, DBGrids;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
//меню, которое будет содержать ссылки на плугины
N1231: TMenuItem;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
//лист, в котором мы будем держать имена файлов плугинов
PlugList : TStringList;
//Процедура загрузки плугина
procedure LoadPlug(fileName : string);
//Процедура инициализации и выполнения плугина
procedure PlugClick(sender : TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
|
procedure TForm1.LoadPlug(fileName: string);
var
//Объявление функции, которая будет возвращать имя плугина
PlugName : function : PChar;
//Новый пункт меню
item : TMenuItem;
//Хендл dll
handle : THandle;
//Объект, с помощью которого мы загрузим картинку из dll
res :TResourceStream;
begin
item := TMenuItem.create(mainMenu1); //Создаём новый пункт меню
handle := LoadLibrary(Pchar(FileName)); //загружаем dll
if handle <> 0 then //Если удачно, то идём дальше...
begin
@PlugName := GetProcAddress(handle,'PluginName'); //грузим процедуру
if @PlugName <> nil then
item.caption := PlugName
//Если всё прошло, идём дальше...
else
begin
ShowMessage('dll not identifi '); //Иначе, выдаём сообщение об ошибке
Exit; //Обрываем процедуру
end;
PlugList.Add(FileName); //Добавляем название dll
res:= TResourceStream.Create(handle,'bitmap',rt_rcdata); //Загружаем ресурс из dll
res.saveToFile('temp.bmp'); res.free; //Сохраняем в файл
item.Bitmap.LoadFromFile('Temp.bmp'); //Загружаем в пункт меню
FreeLibrary(handle); //Уничтожаем dll
item.onClick:=PlugClick; //Даём ссылку на обработчик
Mainmenu1.items[0].add(item); //Добавляем пункт меню
end;
end;
|
procedure TForm1.PlugClick(sender: TObject);
var
//Объявление функции, которая будет выполнять плугин
PlugExec : function(AObject : TObject): boolean;
//Объявление функции, которая будет возвращать тип плугина
PlugType : function: PChar;
//Имя dll
FileName : string;
//Хендл dll
handle : Thandle;
begin
with (sender as TmenuItem) do
filename:= plugList.Strings[MenuIndex];
//Получаем имя dll
handle := LoadLibrary(Pchar(FileName)); //Загружаем dll
//Если всё в порядке, то идём дальше
if handle <> 0 then
begin
//Загружаем функции
@plugExec := GetProcAddress(handle,'PluginExec');
@plugType := GetProcAddress(handle,'PluginType');
//А теперь, в зависимости от типа, передаём нужный ей параметр...
if PlugType = 'FORM' then
PlugExec(Form1)
else
//Если плугин для формы, то передаём форму
if PlugType = 'CANVAS' then
PlugExec(Canvas)
else
//Если плугин для канвы, то передаём канву
if PlugType = 'MENU' then
PlugExec(MainMenu1)
else
//Если плугин для меню, то передаём меню
if PlugType = 'BRUSH' then
PlugExec(Canvas.brush)
else
//Если плугин для заливки, то передаём заливку
if PlugType = 'NIL' then
PlugExec(nil);
//Если плугину ни чего не нужно, то ни чего не передаём
end;
FreeLibrary(handle); //Уничтожаем dll
end;
procedure TForm1.FormCreate(Sender: TObject);
var
SearchRec : TSearchRec; //Запись для поиска
begin
plugList:=TStringList.create; //Создаём запись для имён dll'ок
//ищем первый файл
if FindFirst('*.dll',faAnyFile, SearchRec) = 0 then
begin
LoadPlug(SearchRec.name); //Загружаем первый найденный файл
while FindNext(SearchRec) = 0 do
LoadPlug(SearchRec.name);
//Загружаем последующий
FindClose(SearchRec); //Закрываем поиск
end;
//Левые параметры
canvas.Font.pitch := fpFixed;
canvas.Font.Size := 20;
canvas.Font.Style:= [fsBold];
end;
end.
|
library plug;
uses
SysUtils, graphics, Classes, windows;
{$R bmp.RES}
function PluginType : Pchar;
begin
//Мы указали реакцию на этот тип
Plugintype := 'CANVAS';
end;
function PluginName:Pchar;
begin
//Вот оно, название плугина. Эта строчка будет в менюшке
PluginName := 'Canvas painter';
end;
|
function PluginExec(Canvas:TCanvas):Boolean;
var
X : integer;
I : integer;
Z : byte;
S : string;
color : integer;
proz : integer;
begin
color := 10;
proz :=0;
S:= 'hello всем это из плугина ля -- ля';
for Z:=0 to 200 do
begin
proz:=proz+2;
X:= 0;
for I:=1 to length(S) do
begin
X:=X + 20;
Canvas.TextOut(X,50,S[i]);
color := color+X*2+Random(Color);
canvas.Font.Color := color+X*2;
canvas.font.color := 10;
canvas.TextOut(10,100,'execute of '+inttostr(proz div 4) + '%');
canvas.Font.Color := color+X*2;
sleep(2);
end;
end;
PluginExec:=True;
end;
exports
PluginType, PluginName, PluginExec;
end.
|
Создание PolyPolygon используя массив точек.
procedure TForm1.Button1Click(Sender: TObject); var ptArray : array[0..9] of TPOINT; PtCounts : array[0..1] of integer; begin PtArray[0] := Point(0, 0); PtArray[1] := Point(0, 100); PtArray[2] := Point(100, 100); PtArray[3] := Point(100, 0); PtArray[4] := Point(0, 0); PtCounts[0] := 5; PtArray[5] := Point(25, 25); PtArray[6] := Point(25, 75); PtArray[7] := Point(75, 75); PtArray[8] := Point(75, 25); PtArray[9] := Point(25, 25); PtCounts[1] := 5; PolyPolygon(Form1.Canvas.Handle, PtArray,PtCounts,2); end; |
Создание pop-up меню своего компонента и кое-что еще о классе TComponentExpert.
Автор: Раструсный Владислав Юрьевич.
Давайте рассмотрим создание простейшего одноуровневого контекстного меню на своем компоненте, которое будет открываться при щелчке правой кнопкой по нему в самом верху контекстного меню Delphi.
Прежде всего вам следует разделить код вашего компонента на Design-time и Run-time. Для этого перенесите ваш компонент в модуль, с названием, например, MyComponent.pas, а процедуры регистрации его в палитре компонентов (procedure Register и т.д.) в модуль, с названием, например, MyComponentReg. На такие меры приходится идти из-за того, что Borland не включила в исходные коды исходник файла Proxies.pas.
Итак, получим два файла:
MyComponent.pas:
unit MyComponent;
interface
uses
SysUtils, Classes;
type
TMyComponent = class(TComponent)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
end;
|
MyComponentReg.pas:
unit MyComponentReg;
interface
uses DesignIntf, DesignEditors, MyComponent, Classes, Dialogs;
type
TMyComponentEditor = class(TComponentEditor)
private
procedure ExecuteVerb(Index: Integer); override;
function GetVerbCount: Integer; override;
function GetVerb(Index: Integer): string; override;
procedure Edit; override;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TMyComponent]);
RegisterComponentEditor(TMyComponent, TMyComponentEditor);
end;
{ TMyComponentEditor }
procedure TMyComponentEditor.Edit;
begin
ShowMessage('TMyComponent component v1.0 by Rastrusny Vladislav');
end;
procedure TMyComponentEditor.ExecuteVerb(Index: Integer);
begin
inherited;
case Index of
0: //Действие при выборе первого определенного пункта меню
end;
end;
function TMyComponentEditor.GetVerb(Index: Integer): string;
begin
case Index of
0: Result := 'Demo Menu Item 1'; //Название первого пункта меню
end;
end;
function TMyComponentEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
end.
|
Рассмотрим теперь, что же тут написано. В первом файле просто определен компонент MyComponent. В нем вы определяете все свойства и методы вашего компонента. Все как обычно. Теперь - второй файл MyComponentReg. Он содержит процедуры регистрации компонента и процедуру регистрации редактора компонента (TComponentEditor). Этот редактор и будет отображать меню и прочие безобразия. Итак:
Определяем TMyComponentEditor как потомка TComponentEditor. Сам по себе этот класс является "воплотителем" интерфейса IComponentEditor, хотя нам все равно. Для того, чтобы все это заработало нам нужно будет переопределить стандартные методы класса TComponentEditor. Рассмотрим его:
type
TComponentEditor = class(TBaseComponentEditor, IComponentEditor)
private
FComponent: TComponent;
FDesigner: IDesigner;
public
constructor Create(AComponent: TComponent; ADesigner: IDesigner); override;
procedure Edit; virtual;
function GetVerbCount: Integer; virtual;
function GetVerb(Index: Integer): string; virtual;
procedure ExecuteVerb(Index: Integer); virtual;
procedure Copy; virtual;
procedure PrepareItem(Index: Integer; const AItem: IMenuItem); virtual;
property Component: TComponent;
property Designer: IDesigner;
end;
|
Конструктор нам переопределять не нужно. Поэтому начнем с описания метода Edit.
Метод Edit вызывается при двойном щелчке по компоненту. Вот так просто! При двойном щелчке на компоненте! Если метод не определен, то при двойном щелчке будет выполнен первый пункт меню, которое вы определили.
Метод GetVerbCount: Integer должен возвращать количество определенных вами пунктов меню.
Метод GetVerb(Index: Integer): string должен возвращать название пункта меню № Index.
Метод ExecuteVerb(Index: Integer) вызывается при щелчке на пункте меню, определенном вами. Index - номер меню из метода GetVerb. В нем вы определяете действия, которые будут происходить при нажатии на ваш пункт меню.
Метод Copy вызывается при копировании вашего компонента в буфер обмена.
Свойство Component как вы уже наверное догадались позволяет получить доступ к компоненту, на котором щелкнули мышью и т.п.
Метод PrepareItem(Index: Integer; const AItem: IMenuItem) вызывается для каждого определенного вами пункта меню № Index и через параметр AItem передает сам пункт меню для настройки. Для работы нам нужно будет рассмотреть саму реализацию интерфейсас IMenuItem. Он определен в модуле DesignMenus.pas и является потомком интерфейса IMenuItems.
IMenuItems = interface
['{C9CC6C38-C96A-4514-8D6F-1D121727BFAF}']
// public
function SameAs(const AItem: IUnknown): Boolean;
function Find(const ACaption: WideString): IMenuItem;
function FindByName(const AName: string): IMenuItem;
function Count: Integer;
property Items[Index: Integer]: IMenuItem read GetItem;
procedure Clear;
function AddItem(const ACaption: WideString; AShortCut: TShortCut;
AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil;
hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload;
function AddItem(AAction: TBasicAction;
const AName: string = ''): IMenuItem; overload;
function InsertItem(const ACaption: WideString;
AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil;
hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload;
function InsertItem(Index: Integer; const ACaption: WideString;
AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil;
hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload;
function InsertItem(AAction: TBasicAction;
const AName: string = ''): IMenuItem; overload;
function InsertItem(Index: Integer; AAction: TBasicAction;
const AName: string = ''): IMenuItem; overload;
function AddLine(const AName: string = ''): IMenuItem;
function InsertLine(const AName: string = ''): IMenuItem; overload;
function InsertLine(Index: Integer; const AName: string = ''): IMenuItem; overload;
end;
IMenuItem = interface(IMenuItems)
['{DAF029E1-9592-4B07-A450-A10056A2B9B5}']
// public
function Name: TComponentName;
function MenuIndex: Integer;
function Parent: IMenuItem;
function HasParent: Boolean;
function IsLine: Boolean;
property Caption: WideString;
property Checked: Boolean;
property Enabled: Boolean;
property GroupIndex: Byte;
property HelpContext: THelpContext;
property Hint: string;
property RadioItem: Boolean;
property ShortCut: TShortCut;
property Tag: LongInt;
property Visible: Boolean;
end;
|
Начнем с конца. Т.е. с IMenuItem. Как видно, почти все члены интерфейса соответствуют членам класса TMenuItem. Т.е. обратившись в методе PrepareItem к AItem.Enabled:=false мы запретим выбор этого элемента меню. Что же касается класса TMenuItems, то они, видимо, предназначены для манипулирования элементом меню в качестве родительского для нескольких других. Думаю, в них опытным путем разобраться тоже не составит труда.
Что же касается процедуры RegisterComponentEditor, то она принимает два параметра: первый - класс компонента, для которого создается редактор свойств и второй - собственно сам класс редактора свойств.
Создание редакторов свойств.
Для создания редактора свойств нужно написать класс, унаследованный от TBasePropertyEditor. Но мы рассмотрим более функционального его потомка TPropertyEditor.
TPropertyEditor = class(TBasePropertyEditor, IProperty, IProperty70)
protected
procedure SetPropEntry(Index: Integer; AInstance: TPersistent;
APropInfo: PPropInfo); override;
protected
function GetFloatValue: Extended;
function GetFloatValueAt(Index: Integer): Extended;
function GetInt64Value: Int64;
function GetInt64ValueAt(Index: Integer): Int64;
function GetMethodValue: TMethod;
function GetMethodValueAt(Index: Integer): TMethod;
function GetOrdValue: Longint;
function GetOrdValueAt(Index: Integer): Longint;
function GetStrValue: string;
function GetStrValueAt(Index: Integer): string;
function GetVarValue: Variant;
function GetVarValueAt(Index: Integer): Variant;
function GetIntfValue: IInterface;
function GetIntfValueAt(Index: Integer): IInterface;
procedure Modified;
procedure SetFloatValue(Value: Extended);
procedure SetMethodValue(const Value: TMethod);
procedure SetInt64Value(Value: Int64);
procedure SetOrdValue(Value: Longint);
procedure SetStrValue(const Value: string);
procedure SetVarValue(const Value: Variant);
procedure SetIntfValue(const Value: IInterface);
protected
{ IProperty }
function GetEditValue(out Value: string): Boolean;
function HasInstance(Instance: TPersistent): Boolean;
{ IProperty70 }
function GetIsDefault: Boolean; virtual;
public
constructor Create(const ADesigner: IDesigner; APropCount: Integer); override;
destructor Destroy; override;
procedure Activate; virtual;
function AllEqual: Boolean; virtual;
function AutoFill: Boolean; virtual;
procedure Edit; virtual;
function GetAttributes: TpropertyAttributes; virtual;
function GetComponent(Index: Integer): TPersistent;
function GetEditLimit: Integer; virtual;
function GetName: string; virtual;
procedure GetProperties(Proc: TGetPropProc); virtual;
function GetPropInfo: PPropInfo; virtual;
function GetPropType: PTypeInfo;
function GetValue: string; virtual;
function GetVisualValue: string;
procedure GetValues(Proc: TGetStrProc); virtual;
procedure Initialize; override;
procedure Revert;
procedure SetValue(const Value: string); virtual;
function ValueAvailable: Boolean;
property Designer: IDesigner read FDesigner;
property PrivateDirectory: string read GetPrivateDirectory;
property PropCount: Integer read FPropCount;
property Value: string read GetValue write SetValue;
end;
|
Предположим, нам нужно создать редактор для текстового свойства, при нажатии кнопки "…" в Object Inspector.
Объявим специальный тип этого свойства TMyComponentStringProperty = string;
Далее, в компоненте укажем свойство данного типа property MyProperty: TMyComponentStringProperty, далее в Run-time части компонента (MyComponentReg.pas) объявим класс TMyCSPEditor (в переводе: TMyComponentStringPropertyEditor), унаследовав его от класса TStringProperty, который в свою очередь является потомком рассматриваемого класса TPropertyEditor: type TMyCSPEditor = class(TStringProperty) . Переопределим в нем несколько методов таким образом (фрагменты файла):
type
TVRSIDBListViewExcludeColumnsPropertyEditor = class(TStringProperty)
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
procedure TVRSIDBListViewExcludeColumnsPropertyEditor.Edit;
var Text: string;
begin
if InputQuery('Введите строковое значение',Text)=False then Exit;
Self.SetValue(Text);
end;
function TVRSIDBListViewExcludeColumnsPropertyEditor.GetAttributes: TPropertyAttributes;
begin
Result:=[paDialog];
end;
|
Итак, приступаем к рассмотрению методов класса TPropertyEditor. Начнем с тех, которые мы уже использовали.
Метод Edit. Просто вызывается при щелчке на кнопке "…" в Object Inspector. В TStringProperty не переопределен.
Метод SetValue(Text: string). Должен устанавливать значение свойства в переданную строку. В TStringProperty переопределен. Этот метод вызывается самим Object Inspector, когда пользователь вводит значение поля. Вы можете переопределить этот метод для установки вашего свойства в зависимости от значения, введенного пользователем. Если вы обнаруживаете ошибку в переданном параметре - вызовите исключение.
Метод GetAttributes: TPropertyAttributes. Задает параметры свойства. Рассмотрим их по порядку.
paValueList указывает, что редактор свойств возвращает список допустимых значений свойства через метод GetValues. В редакторе свойств рядом со свойством появляется раскрывающийся список paSortList указывает, что список, возвращенный GetValues нужно сортировать paSubProperties указывает, что у свойства имеются подсвойства (типа подсвойства Name у свойства Font класса TFont). Подсвойства, если этот флаг установлен, должны возвращаться методом GetProperties. paDialog указывает, что рядом со свойством должна быть кнопка "…", по нажатию которой вызывается метод Edit для редактирования значения свойства. Что мы и указали в нашем примере. paMultiSelect Разрешает отображать свойство в Object Inspector, даже если выделено более одного объекта paAutoUpdate указывает, что метод SetValue нужно вызывать при каждом изменении значения свойства, а не после нажатия Enter или выхода из Object Inspector (Пример: свойство Caption у формы изменяется одновременно с набором на клавиатуре) paReadOnly указывает, что значение через Object Inspector изменить нельзя. Оно устанавливается в классе TClassProperty, от которого унаследованы все классовые редакторы свойств типа TStrings, TFont и т.п. При установке рядом со значением свойства отображается строка, возвращенная методом GetValue и значение это изменить нельзя. paRevertable указывает, изменение значения свойства можно отменить. Это не касается вложенных подсвойств. paFullWidthName указывает Object Inspector, что прорисовка значения свойства не требуется и можно занять под имя свойства всю длину панели. paVolatileSubProperties установка этого значения указывает, что при любом изменении свойства нужно повторить сборку подсвойств (GetProperties) paVCL ??? paReference указывает, что свойство является указателем на что-либо. Используется вместе с paSubProperties для указазания отображения объекта, на которое ссылается в качестве подсвойств (TFont). paNotNestable указывает, что отображать значение свойства в момент, когда его подсвойства развернуты - небезопасно (этот пункт мне пока непонятен)Методы GetXXXValue и SetXXXValue. Используются для внутренней установки реального значения свойства. Как правило, используются методом GetValue и SetValue. В принципе, все эти методы уже определены в классе TPropertyEditor, и переопределять их не нужно.
Метод Modified вызывается для указания того факта, что значение свойства изменено. Это метод уже определен в TPropertyEditor и переопределять его не требуется.
Метод GetEditValue возвращает true, если значение можно редактировать.
Метод GetIsDefault возвращает true, если значение свойства в текущий момент является значением свойства по умолчанию. Т.е. метод должен возвращать true, если НЕ нужно сохранять значение свойства в .dfm файле.
Метод Activate вызывается при выборе свойства в Object Inspector. При использовании переопределения этого метода для отображения значения свойства исключительно в момент активизации нужно быть осторожным, если указаны параметры свойства paSubProperties и paMultiSelect.
Метод AllEqual вызывается всякий раз, когда выделяется более одного компонента. Если этот метод вернет true, будет вызван метод GetValue, в противоположном случае будет отображена пустая строка. Вызывается только, если указано свойство paMultiSelect. Очевидно, метод должен проверять совпадение свойств у все выбранных компонентов путем опроса метода GetComponent.
Метод AutoFill вызывается для определения, могут ли элементы списка быть выбраны по возрастанию. Указывается, только если указан параметр paValueList.
Метод GetComponent возвращает компонент с заданным индексом из выбранных компонентов.
Метод GetEditLimit возвращает максимальное количество символов, которые можно ввести в текстовое значение свойства. По умолчанию 255.
Метод GetName возвращает имя свойства, в котором знаки подчеркивания заменены на пробелы. Свойство метод должен переопределяться только, если свойство не предназначено для отображения в Object Inspector.
Метод GetComponentValue возвращает значение свойства типа TComponent в том и только в том случае, если свойство унаследовано от TComponent. Этот метод переопределяется в классе TComponentEditor.
Метод GetProperties вызывается для каждого подсвойства, которое редактируется. В метод передается параметр типа TGetPropertyProc. Это указатель на процедуру для обработки каждого свойства. Например, TClassProperty вызывает процедуру TGetPropertyProc для каждого published элемента класса, а TSetProperty - для каждого элемента множества. Т.е. при использовании подсвойств вы должны определить процедуру TGetPropertyProc, чтобы она определяла каждое подсвойство.
Метод GetPropType возвращает указатель на информацию о типе редактируемого свойства (TypeInfo (Type)).
Метод GetValue возвращает значение свойства в виде текстовой строки. Например, в TClassProperty этот метод переопределен для возвращения в качестве результата имени типа класса (TStrings и т.п.).
Метод ValueAvailable возвращает true, если можно получить доступ к значению свойства, не вызывая исключения.
Описания для остальных методов и свойств, к сожалению, найти не удалось, поэтому исследовать их можно только опытным путем.
По завершении создания редактора свойств не забудьте зарегистрировать его внутри метода register вызовом.
RegisterPropertyEditor(TypeInfo(<тип свойства>), <тип компонента>, <имя свойства>, <тип редактора свойства>); RegisterPropertyEditor(TypeInfo(TMyComponentsStringProperty), TMyComponent, '', TMCSPEditor); |
Передав вместо имени свойства пустую строку, мы указали тем самым, что имя может быть любым. Так же пустую строку можно передать вместо имени компонента.
Вот, собственно, и все. Пишите свой редактор свойств, переопределяйте нужные методы и вперед!
Delphi 7 ToolsAPI: Эксперты
Написание простейшего эксперта
Какой же код нужно написать для создания простейшего эксперта? Для этого нужно написать класс, унаследованный от IOTAWizard (определен в файле ToolsAPI.pas) или одного из его потомков, расположить в модуле процедуру Register, как мы это делали с компонентами, и вызвать внутри ее процедуру.
RegisterPackageWizard (const Wizard: IOTAWizard); |
Например:
RegisterPackageWizard (TMyExpert.Create as IOTAWizard); |
Передав ей в качестве параметра экземпляр заранее созданного эксперта. Рассмотрим класс IOTAWizard.
IOTAWizard = interface(IOTANotifier)
['{B75C0CE0-EEA6-11D1-9504-00608CCBF153}']
{ Expert UI strings }
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
{ Launch the AddIn }
procedure Execute;
end;
|
Интерфейс IOTANotifier нам не понадобится, поэтому давайте рассмотрим методы IOTAWizard: Метод GetIDString должен возвращать уникальный идентификатор эксперта. Например: MyCompany.MyExpert.
Метод GetName должен возвращать название эксперта.
Метод GetState должен возвращать [wsEnabled], если эксперт функционирует, wsChecked если выбран.
Метод Execute вызывается при запуске эксперта из среды IDE.
Итак, если вы хотите сами программировать действия вашего эксперта, включая добавление в меню IDE и прочее и прочее, унаследуйте его от IOTAWizard.
Если вы хотите, чтобы ваш эксперт отображался в репозитарии Delphi на произвольной странице и по щелчку по его иконке вызывался его метод Execute - унаследуйте его от IOTARepositoryWizard.
IOTARepositoryWizard = interface(IOTAWizard)
['{B75C0CE1-EEA6-11D1-9504-00608CCBF153}']
function GetAuthor: string;
function GetComment: string;
function GetPage: string;
function GetGlyph: Cardinal;
end;
|
Метод GetAuthor должен возвращать имя автора,
Метод GetComment - комментарий,
Метод GetPage - страницу на которой будет расположена иконка эксперта.
Метод GetGlyph - дескриптор иконки.
Если вы хотите, чтобы эксперт появлялся на странице форм в репозитарии - унаследуйте его от IOTAFormWizard. Он имеет все те же методы и свойства, что и IOTARepositoryWizard, если на странице проектов - от IOTAProjectWizard. Он тоже аналогичен IOTARepositoryWizard.
Если же вы хотите, чтобы пункт меню для вызова метода вашего эксперта Execute помещался в мень Help главного меню IDE, унаследуйте вашего эксперта от IOTAMenuWizard:
IOTAMenuWizard = interface(IOTAWizard)
['{B75C0CE2-EEA6-11D1-9504-00608CCBF153}']
function GetMenuText: string;
end;
|
Метод GetMenuText должен возвращать имя пункта меню для отображения, а метод GetState возвращает стиль элемента меню (Enabled, Checked).
Вот так все просто, оказывается!
Расположение эксперта внутри DLL библиотеки.
Если вы хотите расположить вашего эксперта не в пакете, а в DLL библиотеке, библиотека должна экспортировать функцию INITWIZARD0001 следующего формата:
type TWizardRegisterProc = function(const Wizard: IOTAWizard): Boolean; type TWizardTerminateProc = procedure; function INITWIZARD0001(const BorlandIDEServices: IBorlandIDEServices; RegisterProc: TWizardRegisterProc; var Terminate: TWizardTerminateProc): Boolean stdcall; |
Для регистрации вашего эксперта вызовите внутри этой функции RegisterProc и передайте ей экземпляр заранее созданного класса вашего эксперта. BorlandIDEServices - указатель на основной интерфейс для работы со всей IDE. Отдельные части его мы рассмотрим далее. По окончании работы IDE или при принудительной выгрузке вашего эксперта будет вызвана функция Terminate, которую вы должны передать среде.
Поместите полный путь к DLL в ключ реестра.
HKEY_CURRENT_USER\Software\Borland\Delphi\7.0\Experts |
Или.
HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\7.0\Experts |
Именем ключа может быть произвольная строка.
Эксперт будет запущен только при перезапуске среды, если она выполнялась. Вуаля!
Как динамически создавать пункты подменю в PopupMenu.
procedure TForm1.PopupMenu2Popup(Sender: TObject);
var
mi, msub: TmenuItem;
begin
with (Sender as TPopupMenu) do
begin
// Удаляем все пункты меню
// while Items.Count > 0 do Items.delete(0);
// Предыдущий код имел утечку памяти. Коррекция от Andrew Stewart (astewart@Strobes.co.nz)
while Items.Count > 0 do
Items[0].Free;
// Создаем обычный пункт "Первый"
mi := TMenuItem.Create(self);
with mi do
begin
Caption := 'Первый';
OnClick := MyClick;
end;
Items.Insert(0, mi);
// Создаем подменю "Подменю" c двумя пунктами "Подменю1" и
// "Подменю2"
mi := TMenuItem.Create(self);
with mi do
begin
Caption := 'Подменю';
msub := TMenuItem.Create(self);
with msub do
begin
Caption := 'Подменю1';
OnClick := MyClick;
end;
Insert(0, msub);
msub := TMenuItem.Create(self);
with msub do
begin
Caption := 'Подменю2';
OnClick := MyClick;
end;
Insert(1, msub);
end;
Items.Insert(1, mi);
end;
end;
procedure TForm1.MyClick(Sender: TObject);
begin
beep;
end;
|
Создание редактора свойства.
Автор: HTH, Dean (Classic Software) Если вы назвали свое свойство TableName, то полный цикл создания редактора свойств включает следующие шаги:1. Опишите класс редактора свойства:
type
TTableNameProperty = class(TStringProperty)
function GetAttributes: TPropertyAttributes; override;
procedure GetValues(Proc: TGetStrProc); override;
end;
implementation
{ TTableNameProperty }
function TTableNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paValueList];
end;
procedure TTableNameProperty.GetValues(Proc: TGetStrProc);
var
TableName: string;
begin
{ *************************************************
здесь вы должны добавить свой код, чтобы с помощью
цикла обойти имена всех таблиц, включенных в список
*************************************************** }
for I := 0 to ???? do
begin
TableName := ????[I];
Proc(TableName);
end;
end;
|
2. Затем вам необходимо зарегистрировать данный редактор свойства следующим образом (в вашей процедуре Register):
RegisterPropertyEditor(TypeInfo(string), TcsNotebook, 'TableName', TTableNameProperty); |
Как создать регион (HRNG) по маске.
Ниже приведена функция, которая создаёт HRGN из чёрно-белого битмапа. Все чёрные пиксели становятся регионом, а белые становятся прозрачными. Так же не составит труда сделать преобразования для поддержки всех цветов и чтобы один из них был прозрачным.
По окончании необходимо освободить регион при помощи функции DeleteObject.
function BitmapToRgn(Image: TBitmap): HRGN;
var
TmpRgn: HRGN;
x, y: integer;
ConsecutivePixels: integer;
CurrentPixel: TColor;
CreatedRgns: integer;
CurrentColor: TColor;
begin
CreatedRgns := 0;
Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
inc(CreatedRgns);
if (Image.Width = 0) or (Image.Height = 0) then
exit;
for y := 0 to Image.Height - 1 do
begin
CurrentColor := Image.Canvas.Pixels[0,y];
ConsecutivePixels := 1;
for x := 0 to Image.Width - 1 do
begin
CurrentPixel := Image.Canvas.Pixels[x,y];
if CurrentColor = CurrentPixel then
inc(ConsecutivePixels)
else
begin
// Входим в новую зону
if CurrentColor = clWhite then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
CurrentColor := CurrentPixel;
ConsecutivePixels := 1;
end;
end;
if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
end;
end;
|
Создание RES-файла с помощью BRCC.EXE.
Автор: Bob Villiers Данный метод обходит проблемы, связанные с Image Editor. В каталоге \DELPHI\BIN имеется утилита коммандной строки, названная BRCC.EXE, позволяющая создавать из файлов, содержащих изображения/иконки, RES-файлы, в обход Image Editor. (Тем не менее, Image Editor хорошо работает при создании или редактировании файлов с изображениями или курсорами. Проблемой был импорт.) Resource File Compiler описан в справке Windows API help в главе Windows Tools (где вы также можете прочесть о RC.EXE как о BRCC.EXE!). Это сэкономит вам какое-то время! Сначала, используя Блокнот, создайте файл определения ресурса (Resource Definition) (текстовый) с именем, скажем, MYRES.RC (с обязательным расширением RC). Разместите, каждую на отдельной строке, ссылки на изображения, иконки, и т.п., которые вы хотели бы включить в RES-файл, например:BITMAP1 BITMAP <путь><имя файла> BITMAP2 BITMAP <путь><имя файла> CURSOR1 CURSOR <путь><имя файла> ICON1 ICON <путь><имя файла>Затем (это не обязательно, но сохранит массу времени, особенно если вы экспериментируете), в том же каталоге создайте BAT-Файл, вызывающий программу для компиляции каждого ресурса:
"C:\DELPHI\BIN\BRCC/R %1"Назовите его, скажем, MAKERES.BAT.
Перейдите в DOS и в каталоге проекта введите "MAKERES MYRES.RC". Заданные ресурсы будут скомпилированы в новый файл MYRES.RES, который может быть прилинкован к вашему проекту как и прежде. Используйте Image Editor для проверки и редактирования.
Как создать вычисляемые поля во время исполнения программы.
Автор: Nomadic.
Смотрите книгу "Developing Custom Delphi Components" от Рэя Конопки.Здесь немного исправленный пример из этой книги -
function TMyClass.CreateCalcField(const AFieldName: string;
AFieldClass: TFieldClass; ASize: Word): TField;
begin
Result := FDataSet.FindField(AFieldName); // Field may already exists!
if Result <> nil then
Exit;
if AFieldClass = nil then
begin
DBErrorFmt(SUnknownFieldType, [AFieldName]);
end;
Result := FieldClass.Create(Owner);
with Result do
try
FieldName := AFieldName;
if (Result is TStringField) or (Result is TBCDField) or
(Result is TBlobField) or (Result is TBytesField) or
(Result is TVarBytesField) then
begin
Size := ASize;
end;
Calculated := True;
DataSet := FDataset;
Name := FDataSet.Name + AFieldName;
except
Free; // We must release allocated memory on error!
raise;
end;
end;
|
Создание индекса во время выполнения программы.
Автор: OAmiry (Borland)Ниже приведен код обработчика кнопки OnClick, с помощью которого строится индекс:
procedure TForm1.Button1Click(Sender: TObject);
var
bActive, bExclusive: Boolean;
begin
bActive := Table1.Active;
bExclusive := Table1.Exclusive;
Table1.IndexDefs.Update;
with Table1 do
begin
Close;
{таблица dBASE должна быть открыта в монопольном (exclusive) режиме}
Exclusive := TRUE;
Open;
if Table1.IndexDefs.IndexOf('FNAME') <> 0 then
Table1.AddIndex('FNAME', 'FNAME', []);
Close;
Exclusive := bExclusive;
Active := bActive;
end;
end;
|
Если вы собираетесь запускать проект из Delphi, пожалуйста убедитесь в том, что свойство таблицы Active в режиме проектирования установлено в False.
Создание таблицы по образу и подобию.
Создайте во время выполнения программы пустую таблицу, скопируйте структуру существующей, включая первичный индекс. На практике это выглядит примерно так:
var Table2 : TTable; begin Table1.FieldDefs.Update; Table1.IndexDefs.Update; Table2 := TTable.Create(nil); Table2.DatabaseName := Table1.DatabaseName; Table2.TableName := 'MyTable'; Table2.TableType := Table1.TableType; Table2.FieldDefs.Assign(Table1.FieldDefs); Table2.IndexDefs.Assign(Table1.IndexDefs); Table2.CreateTable ; end; |
...один способ сделать это.
Создаём Screen Saver.
Хранитель экрана (ScreenSaver) в Windows – это программа, размещенная в каталоге Windows или Windows\System. Расширение эта программа должна иметь scr. При запуске ScreenSaver должен реагировать на параметры. Если первый параметр – "/p", нужно создать окно предварительного просмотра. Если первый параметр – "/s", нужно запустить сам ScreenSaver. В ином случае нужно показать окно настроек хранителя экрана.
Для предварительного просмотра Windows создает окно, на месте которого ScreenSaver должен что-то рисовать. Чтобы отслеживать сообщения о перерисовке окна Preview, а также о его перемещении и закрытии, нужно создать дочернее окно в том же месте и такого же размера. Для этого нужно использовать WinAPI. Цикл, в котором обрабатываются сообщения, удобно сделать через PeekMessage, поскольку в этом случае можно создать событие OnIdle. В нем нужно рисовать что-то в окне предварительного просмотра.
Окно самого ScreenSaver-а можно делать без WinAPI. Для реагирования на события мыши и клавиатуры лучше всего использовать событие OnMessage. Чтобы ScreenSaver работал в фоновом режиме рисовать нужно в обработчике события OnIdle. Причем каждый раз нужно выполнять быструю операцию. Поскольку в окне ScreenSaver-а и в окне предварительного просмотра должно рисоваться одно и то же, удобно сделать единую процедуру, которая бы выполняла короткое действие. В качестве параметров ей нужно сообщать Canvas, высоту и ширину.
Поскольку, если программе не передаются никакие параметры, запускается окно настроек, то при его создании нужно проверять, где на винчестере находится программа. Если она находится не в каталоге Windows, то нужно скопировать файл, сменив расширение на scr.
В первом модуле находится окно хранителя экрана:
public
procedure OnMessage(var Msg: TMsg; var Handled: Boolean);
procedure OnIdle(Sender: TObject; var Done: Boolean);
end;
var
Form1: TForm1;
r, g, b: integer;
po: TPoint;
IniFileName: string;
procedure Draw(Canvas: TCanvas; var r, g, b: integer;
width, height: integer);
implementation
{$R *.DFM}
uses
IniFiles;
procedure Draw(Canvas: TCanvas; var r, g, b: integer;
width, height: integer);
begin
with Canvas do
begin
r := r + random(3) - 1;
if r then
r := 0;
if r > 255 then
r := 255;
g := g + random(3) - 1;
if g then
g := 0;
if g > 255 then
g := 255;
b := b + random(3) - 1;
if b then
b := 0;
if b > 255 then
b := 255;
Pen.Color := RGB(r, g, b);
LineTo(random(width), random(height));
end;
end;
procedure TForm1.OnMessage(var Msg: TMsg; var Handled: Boolean);
begin
case Msg.message of
WM_KEYDOWN, WM_KEYUP,
WM_SYSKEYDOWN, WM_SYSKEYUP,
WM_LBUTTONDOWN, WM_RBUTTONDOWN,
WM_MBUTTONDOWN: Close;
WM_MOUSEMOVE:
begin
if (msg.pt.x <> po.x) or (msg.pt.y <> po.y) then
Close;
end;
end;
end;
procedure TForm1.OnIdle(Sender: TObject; var Done: Boolean);
begin
Draw(Canvas, r, g, b, Width, Height);
Done := false;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
ini: TIniFile;
begin
Application.OnMessage := OnMessage;
Application.OnIdle := OnIdle;
{Эти два свойства можно установить при помощи Object Inspector}
BorderStyle := bsNone;
WindowState := wsMaximized;
ShowCursor(false);
GetCursorPos(po);
ini := TIniFile.Create(IniFileName);
if ini.ReadBool('settings', 'clear', true) then
Brush.Color := clBlack
else
Brush.Style := bsClear;
ini.Destroy;
end;
|
Окно настроек:
{$R *.DFM}
uses
IniFiles, Unit1;
procedure TForm2.FormCreate(Sender: TObject);
var
buf: array [0..127] of char;
ini: TIniFile;
begin
GetWindowsDirectory(buf, sizeof(buf));
if pos(UpperCase(buf), UpperCase(ExtractFilePath(ParamStr(0)))) then
if not CopyFile(PChar(ParamStr(0)), PChar(buf + '\MyScrSaver.scr'), false) then
ShowMessage('Can not copy the file');
ini := TIniFile.Create(IniFileName);
CheckBox1.Checked := ini.ReadBool('settings', 'clear', true);
ini.Destroy;
{Эти три свойства можно установить при помощи Object Inspector}
Button1.Caption := 'OK';
Button2.Caption := 'Cancel';
CheckBox1.Caption := 'Clear screen';
end;
procedure TForm2.Button1Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create(IniFileName);
ini.WriteBool('settings', 'clear', CheckBox1.Checked);
ini.Destroy;
Close;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
Close;
end;
|
Файл с самой программой (dpr). Чтобы открыть его выберите Project | View Source.
program Project1;
uses
Forms, Graphics, Windows, Messages,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
var
PrevWnd: hWnd;
rect: TRect;
can: TCanvas;
procedure Paint;
begin
Draw(can, r, g, b, rect.Right - rect.Left, rect.Bottom - rect.Top);
end;
function MyWndProc(wnd: hWnd; msg: integer;
wParam, lParam: longint): integer; stdcall;
begin
case Msg of
WM_DESTROY:
begin
PostQuitMessage(0);
result := 0;
end;
WM_PAINT:
begin
paint;
result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
else
result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
end;
procedure Preview;
const
ClassName = 'MyScreenSaverClass'#0;
var
parent: hWnd;
WndClass: TWndClass;
msg: TMsg;
code: integer;
begin
val(ParamStr(2), parent, code);
if (code <> 0) or (parent then
Exit;
with WndClass do
begin
style := CS_PARENTDC;
lpfnWndProc := addr(MyWndProc);
cbClsExtra := 0;
cbWndExtra := 0;
hIcon := 0;
hCursor := 0;
hbrBackground := 0;
lpszMenuName := nil;
lpszClassName := ClassName;
end;
WndClass.hInstance := hInstance;
Windows.RegisterClass(WndClass);
GetWindowRect(Parent, rect);
PrevWnd := CreateWindow(ClassName, 'MyScreenSaver',
WS_CHILDWINDOW or WS_VISIBLE or WS_BORDER, 0, 0, rect.Right - rect.Left,
rect.Bottom - rect.Top, Parent, 0, hInstance, nil);
can := TCanvas.Create;
can.Handle := GetDC(PrevWnd);
can.Brush.Color := clBlack;
can.FillRect(rect);
repeat
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
if Msg.message = WM_QUIT then
break;
TranslateMessage(Msg);
DispatchMessage(Msg);
end
else
Paint;
until
false;
ReleaseDC(PrevWnd, can.Handle);
can.Destroy;
end;
var
c: char;
buf: array [0..127] of char;
begin
GetWindowsDirectory(buf, sizeof(buf));
IniFileName := buf + '\myinifile.ini';
if (ParamCount >= 1) and (Length(ParamStr(1)) > 1) then
c := UpCase(ParamStr(1)[2])
else
c := #0;
case c of
'P': Preview;
'S':
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
else
begin
Application.Initialize;
Application.CreateForm(TForm2, Form2);
Application.Run;
end;
end;
end.
|
Написание сервисов Windows NT на WinAPI.
Автор: http://delphi.xonix.ru Причиной написания этой статьи, как не странно, стала необходимость написания своего сервиса. Но в Воrlаnd'е решили немного "порадовать" нас, пользователей Delphi 6 Personal, не добавив возможности создания сервисов (в остальных версиях Delphi 5 и 6 эта возможность имеется в виде класса TService). Решив, что еще не все потеряно, взял на проверку компоненты из одноименного раздела этого сайта. Первый оказался с многочисленными багами, а до пробы второго я не дошел, взглянув на исходник - модуль Forms в Uses это не только окошки, но и более 300 килобайт "веса" программы. Бессмысленного увеличения размера не хотелось и пришлось творить свое. Так как сервис из воздуха не сотворишь, то мой исходник и эта статья очень сильно опираются на MSDN. Итак, приступим к написанию своего сервисаОбычный Win32-сервис это обычная программа. Программу рекомендуется сделать консольной (DELPHI MENU | Project | Options.. | Linker [X]Generate Console Application) и крайне рекомендуется сделать ее без форм !!! и удалить модуль Forms из Uses. Рекомендуется потому, что, во-первых, это окошко показывать не стоит потому, что оно позволит любому юзеру, прибив ваше окошко прибить и сервис и, во-вторых, конечно же, размер файла (19Kb против 350 ). Поэтому удаляем форму (DELPHI MENU | Project | Remove from project... ). Удалив все формы, перейдем на главный модуль проекта, в котором удаляем текст между begin и end и Forms из Uses и добавляем Windows и WinSvc. В результате должно получиться что-то вроде этого.
program Project1;
uses
Windows, WinSvc;
{$R *.res}
begin
end.
На этом подготовительный этап закончен - начинаем писАть сервис.
Главная часть программы
Как уже отмечалось - сервис это обычная программа. Программа в Раsсаl'е находится между begin и end. После запуска нашего сервиса (здесь и далее под запуском сервиса понимается именно запуск его из Менеджера сервисов, а не просто запуск ехе'шника сервиса) менеджер сервисов ждет пока наш сервис вызовет функцию StartServiceCtrlDispatcher.Ждать он будет недолго - если в нашем ехе'шнике несколько сервисов то секунд 30, если один - около секунды, поэтому помещаем вызов StartServiceCtrlDispatcher поближе к begin.
StartServiceCtrlDispatcher качестве аргумента требует _SERVICE_TABLE_ENTRYA, поэтому добавляем в var DispatchTable : array [0..кол-во сервисов] of _SERVICE_TABLE_ENTRYA; и заполняем этот массив (естественно перед вызовом StartServiceCtrlDispatcher).
Т.к. в нашем ехешнике будет 1 сервис, то заполняем его так :
DispatchTable[0].lpServiceName := ServiceName; DispatchTable[0].lpServiceProc := @ServiceProc; DispatchTable[1].lpServiceName := nil; DispatchTable[1].lpServiceProc := nil;Советую завести константы ServiceName - имя сервиса и ServiceDisplayName - отображаемое имя. ServiceProc - основная функция сервиса(о ней ниже), а в функцию мы передаем ее адрес.
В DispatchTable[кол-во сервисов] все равно nil - это показывает функции, что предыдущее поле было последним. У меня получилось так :
begin
DispatchTable[0].lpServiceName := ServiceName;
DispatchTable[0].lpServiceProc := @ServiceProc;
DispatchTable[1].lpServiceName := nil;
DispatchTable[1].lpServiceProc := nil;
if not StartServiceCtrlDispatcher(DispatchTable[0]) then
LogError('StartServiceCtrlDispatcher Error');
end.
StartServiceCtrlDispatcher выполнится только после того, как все сервисы будут остановлены.
Функция LogError протоколирует ошибки - напишите ее сами.
Функция ServiceMain
ServiceMain - основная функция сервиса. Если в ехешнике несколько сервисов, но для каждого сервиса пишется своя ServiceMain функция. Имя функции может быть любым! и передается в DispatchTable.lpServiceProc:=@ServiceMain (см.предыдущущий абзац). У меня она называется ServiceProc и описывается так:
procedure ServiceProc(argc: DWORD; var argv: array of PChar); stdcall;argc кол-во аргументов и их массив argv передаются менеджером сервисов из настроек сервиса. НЕ ЗАБЫВАЙТЕ STDCALL!!! Такая забывчивость - частая причина ошибки в программе. В ServiceMain требуется выполнить подготовку к запуску сервиса и зарегистрировать обработчик сообщений от менеджера сервисов (Handler). Опять после запуска ServiceMain и до запуска RegisterServiceCtrlHandler должно пройти минимум времени. Если сервису надо делать что-нибудь очень долго и обязательно до вызова RegisterServiceCtrlHandler, то надо посылать сообщение SERVICE_START_PENDING функией SetServiceStatus. Итак, в RegisterServiceCtrlHandler передаем название нашего сервиса и адрес функции Наndlеr'а (см.далее). Далее выполняем подготовку к запуску и настройку сервиса. Остановимся на настройке поподробнее. Эта самая настройка var ServiceStatus : SERVICE_STATUS; (ServiceStatusHandle : SERVICE_STATUS_HANDLE и ServiceStatus надо сделать глобальными переменными и поместить их выше всех функций).
DwServiceType - тип сервиса.
SERVICE_WIN32_OWN_PROCESS Одиночный сервис SERVICE_WIN32_SHARE_PROCESS Несколько сервисов в одном процессе SERVICE_INTERACTIVE_PROCESS интерактивный сервис (может взаимодействовать с пользователем). Остальные константы - о драйверах. Если надо - смотрите их в MSDN.DwControlsAccepted - принимаемые сообщения (какие сообщения мы будем обрабатывать).
SERVICE_ACCEPT_PAUSE_CONTINUE приостановка/перезапуск SERVICE_ACCEPT_STOP остановка сервиса SERVICE_ACCEPT_SHUTDOWN перезагрузка компьютера SERVICE_ACCEPT_PARAMCHANGE изменение параметров сервиса без перезапуска (Win2000 и выше)Остальные сообщения смотрите опять же в MSDN (куда уж без него ;-).
dwWin32ExitCode и dwServiceSpecificExitCode - коды ошибок сервиса. Если все идет нормально, то они должны быть равны нулю, иначе коду ошибки. dwCheckPoint - если сервис выполняет какое-нибудь долгое действие при остановке, запуске и т.д. то dwCheckPoint является индикатором прогресса (увеличивайте его, чтобы дать понять, что сервис не завис), иначе он должен быть равен нулю. dwWaitHint - время, через которое сервис должен послать свой новый статус менеджеру сервисов при выполнении действия (запуска, остановки и т.д.). Если dwCurrentState и dwCheckPoint через это кол-во миллисекунд не изменится, то менеджер сервисов решит, что произошла ошибка. dwCurrentState - см. где-то здесь Ставим его в SERVICE_RUNNING, если сервис запущен После заполнения этой структуры посылаем наш новый статус функцией SetServiceStatus и мы работаем :). После этого пишем код самого сервиса. Я вернусь к этому попозже.Вот так выглядит моя ServiceMain :
procedure ServiceProc(argc: DWORD; var argv: array of PChar); stdcall;
var
Status: DWORD;
SpecificError: DWORD;
begin
ServiceStatus.dwServiceType := SERVICE_WIN32;
ServiceStatus.dwCurrentState := SERVICE_START_PENDING;
ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP
or SERVICE_ACCEPT_PAUSE_CONTINUE;
ServiceStatus.dwWin32ExitCode := 0;
ServiceStatus.dwServiceSpecificExitCode := 0;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
ServiceStatusHandle :=
RegisterServiceCtrlHandler(ServiceName, @ServiceCtrlHandler);
if ServiceStatusHandle = 0 then
WriteLn('RegisterServiceCtrlHandler Error');
Status := ServiceInitialization(argc, argv, SpecificError);
if Status <> NO_ERROR then
begin
ServiceStatus.dwCurrentState := SERVICE_STOPPED;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
ServiceStatus.dwWin32ExitCode := Status;
ServiceStatus.dwServiceSpecificExitCode := SpecificError;
SetServiceStatus(ServiceStatusHandle, ServiceStatus);
LogError('ServiceInitialization');
exit;
end;
ServiceStatus.dwCurrentState := SERVICE_RUNNING;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
if not SetServiceStatus(ServiceStatusHandle, ServiceStatus) then
begin
Status := GetLastError;
LogError('SetServiceStatus');
exit;
end;
// WORK HERE
// ЗДЕСЬ БУДЕТ ОСНОВНОЙ КОД ПРОГРАММЫ
end;
Функция Handler
Функция Handler будет вызываться менеджером сервисов при передаче сообщений сервису. Опять же название функции - любое. Адрес функции передается с помощью функции RegisterServiceCtrlHandler (см. выше). Функция имеет один параметр типа DWORD (Cardinal) - сообщение сервису. Если в одном процессе несколько сервисов - для каждого из них должна быть своя функция. procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall; Опять не забываем про stdcall.
Итак, функция получает код сообщения, который мы и проверяем. Начинаем вспоминать, что мы писали в ServiceStatus.dwControlsAccepted. У меня это SERVICE_ACCEPT_STOP и SERVICE_ACCEPT_PAUSE_CONTINUE, значит, мне надо проверять сообщения SERVICE_CONTROL_PAUSE, SERVICE_CONTROL_CONTINUE, SERVICE_CONTROL_STOP и выполнять соответствующие действия. Остальные сообщения:
ServiceStatus.dwControlsAccepted Обрабатываемые сообщения.
SERVICE_ACCEPT_PAUSE_CONTINUE SERVICE_CONTROL_PAUSE и SERVICE_CONTROL_CONTINUE SERVICE_ACCEPT_STOP SERVICE_CONTROL_STOP SERVICE_ACCEPT_SHUTDOWN SERVICE_CONTROL_SHUTDOWN SERVICE_ACCEPT_PARAMCHANGE SERVICE_CONTROL_PARAMCHANGE Также надо обрабатывать SERVICE_CONTROL_INTERROGATE. Что это такое - непонятно, но обрабатывать надо :) Передаем новый статус сервиса менеджеру сервисов функцией SetServiceStatus.Пример функции Handler:
procedure ServiceCtrlHandler(Opcode: Cardinal); stdcall;
var
Status: Cardinal;
begin
case Opcode of
SERVICE_CONTROL_PAUSE:
begin
ServiceStatus.dwCurrentState := SERVICE_PAUSED;
end;
SERVICE_CONTROL_CONTINUE:
begin
ServiceStatus.dwCurrentState := SERVICE_RUNNING;
end;
SERVICE_CONTROL_STOP:
begin
ServiceStatus.dwWin32ExitCode := 0;
ServiceStatus.dwCurrentState := SERVICE_STOPPED;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
if not SetServiceStatus(ServiceStatusHandle, ServiceStatus) then
begin
Status := GetLastError;
LogError('SetServiceStatus');
Exit;
end;
exit;
end;
SERVICE_CONTROL_INTERROGATE: ;
end;
if not SetServiceStatus(ServiceStatusHandle, ServiceStatus) then
begin
Status := GetLastError;
LogError('SetServiceStatus');
Exit;
end;
end;
Реализация главной функции программы
В функции ServiceMain (см.там, где отмечено) пишем код сервиса. Так как сервис обычно постоянно находится в памяти компьютера, то скорее всего код будет находиться в цикле. Например в таком:
repeat
// Что-нибудь делаем пока сервис не завершится.
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
// Но это пройдет если сервис не обрабатывает сообщения приостановки/перезапуска,
// иначе сервис никак не прореагирует. Другой вариант :
repeat
if ServiceStatus.dwCurrentState <> SERVICE_PAUSED then
// чего - то делаем
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
И третий, имхо, самый правильный вариант = использование потока:
Пишем функцию.
function MainServiceThread(p: Pointer): DWORD; stdcall; begin // что - то делаем end;
И в ServiceMain создаем поток.
var ThID: Cardinal; hThread := CreateThread(nil, 0, @MainServiceThread, nil, 0, ThID); // и ждем его завершения WaitForSingleObject(hThread, INFINITE); // закрывая после этого его дескриптор CloseHandle(hThread); // При этом hThread делаем глобальной переменной. // Теперь при приостановке сервиса(в Handler) // делаем так SERVICE_CONTROL_PAUSE: begin ServiceStatus.dwCurrentState := SERVICE_PAUSED; SuspendThread(hThread); // приостанавливаем поток end;
И при возобновлении работы сервиса SERVICE_CONTROL_CONTINUE:
begin ServiceStatus.dwCurrentState := SERVICE_RUNNING; ResumeThread(hThread); // возобновляем поток end;
Создание заставки.
Перед появлением главного окна во всех серьёзных приложениях сначала появляется заставка. Теперь и у Вас есть возможность повыёживаться! Для создания заставки выполняем следующую последовательность действий:
Начинаем создание нового приложение командой “New Application” (“Новое приложение”) из меню “File” (“Файл”).
Добавьте ещё одну форму: “New Form”(“Новая форма”) из меню “File” (“Файл”). Это окно и будет заставкой. У него нужно убрать рамку с полосой заголовка, установив свойство “BorderStyle” в “bsNone”. Теперь можно смело разработать дизайн окна заставки.
Из меню “Project” (“Проект”) выбрать команду “Options”(“Опции”). Зайти на закладку “Forms”(“Формы”) и Form2 из списка автоматически создаваемых форм (Auto-Create forms) перенести в список доступных форм (Available forms).
На форму-заставку с закладки System вынести компонент Timer. В его свойстве Interval установить значение 5000, а в событии OnTimer написать:
Timer1.Enabled := false; |
Это сделано для того, чтобы заставка была видна в период указанного времени – 5000 миллисекунд, т.е. 5 секунд.
Перейти в файл проекта, нажав Ctrl+F12 и выбрав Project1. Исходный код должен выглядеть так:
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
|
Теперь мы внесём сюда немного изменений и код должен стать таким:
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Form2 := TForm2.Create(Application);
Form2.Show;
Form2.Update;
while Form2.Timer1.Enabled do
Application.ProcessMessages;
Application.CreateForm(TForm1, Form1);
Form2.Hide;
Form2.Free;
Application.Run;
end.
|
Конструирование Splitter.
У меня есть форма с расположенными на ней компонентами TreeView и Memo. Значение свойства align обоих компонентов позволяет им занимать всю форму. Я хотел бы расположить между ними движок типа Splitter, пропорционально меняющий их размеры (один шире, другой меньше и наоборот), но к сожалению я обладаю лишь дистрибутивом Delphi2 (Splitter вошел в палитру только в Delphi3). Какой компонент мог бы с'имитировать поведение Splitter и как это реализовать? Предположим, Ваш TreeView расположен в левой, а Memo в правой части формы. Вам нужно сделать следующее: Установите свойство Align компонента TreeView на alLeft. Вырежьте (Ctrl-X) компонент TMemo из вашей формы. Добавьте компонент Panel и присвойте его свойству Align значение alClient. Внутри панели разместите другой компонент Panel. Установите его ширину, равной 8 пикселам, свойству Align присвойте значение alLeft. Скопируйте вырезанный компонент TMemo в панель Panel1 и присвойте свойству Align значение alClient.Panel2 - движок: теперь вам необходимо добавить процедуры, приведенные ниже. Ваш код будет выглядеть приблизительно так:
type
TForm1 = class(TForm)
TreeView1: TTreeview;
Panel1: TPanel;
Panel2: TPanel;
Memo1: TMemo;
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
private
Resizing: Boolean;
public
...
end;
procedure TForm1.Panel2MouseDown(Sender: TObject; Button:
TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Resizing := true;
end;
procedure TForm1.Panel2MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Resizing := false;
end;
procedure TForm1.Panel2MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if Resizing then
begin
TreeView1.Width := TreeView1.Width + X;
// Предохранение от странных ошибок перерисовки при изменении размеров:
Panel1.Invalidate;
end;
end;
|
Код может быть модифицирован для получения горизонтального движка - идея, надеюсь, понятна...
Написание хранителя экрана.
1.В файл проекта {*.DPR} добавить строку {$D SCRNSAVE } после строки подключения модулей (Uses...). 2.У окна формы убрать системное меню, кнопки и придать свойству WindowState значение wsMaximize. 3.Предусмотреть выход из хранителя при нажатии на клавиши клавиатуры, мыши и при перемещении курсора мыши. 4.Проверить параметры с которым был вызван хранитель и если это /c - показать окно настройки хранителя, а иначе (можно проверять на /s, а можно и не проверять) сам хранитель. /p - для отображения в окне установок хранителя экрана. 5.Скомпилировать хранитель экрана. 6.Переименовать *.EXE файл в файл *.SCR и скопировать его в каталог WINDOWS\SYSTEM. 7.Установить новый хранитель в настройках системы! Название хранителя может состоять из нескольких слов с пробелами, на любом языке. При работе хранителя необходимо прятать курсор мыши, только не забывайте восстанавливать его после выхода. Все параметры и настройки храните в файле .INI, так как хранитель и окно настройки не связаны друг с другом напрямую. Старайтесь сделать свой хранитель как можно меньше и быстрее. Иначе ваши долго работающие (в фоновом режиме) приложения будут работать еше дольше!--- в файле *.DPR ---
{$D SCRNSAVE Пример хранителя экрана}
//проверить переданные параметры}
IF (ParamStr(1) = '/c') OR (ParamStr(1) = '/C') THEN
// скрыть курсор мыши
ShowCursor(False);
// восстановить курсор мыши
ShowCursor(True);
|
Главное о чем стоит упомянуть это, что ваш хранитель экрана будет работать в фоновом режиме и он не должен мешать работе других запущенных программ. Поэтому сам хранитель должен быть как можно меньшего объема. Для уменьшения объема файла в описанной ниже программе не используется визуальные компоненты Delphi, включение хотя бы одного из них приведет к увеличению размера файла свыше 200кб, а так, описанная ниже программа, имеет размер всего 20кб!!! Технически, хранитель экрана является нормальным EXE файлом (с расширением .SCR), который управляется через командные параметры строки. Например, если пользователь хочет изменить параметры вашего хранителя, Windows выполняет его с параметром "-c" в командной строке. Поэтому начать создание вашего хранителя экрана следует с создания примерно следующей функции:
Procedure RunScreenSaver;
Var S : String;
Begin
S := ParamStr(1);
If (Length(S) > 1) Then Begin
Delete(S,1,1); { delete first char - usally "/" or "-" }
S[1] := UpCase(S[1]);
End;
LoadSettings; { load settings from registry }
If (S = 'C') Then RunSettings
Else If (S = 'P') Then RunPreview
Else If (S = 'A') Then RunSetPassword
Else RunFullScreen;
End;
|
Поскольку нам нужно создавать небольшое окно предварительного просмотра и полноэкранное окно, их лучше объединить используя единственный класс окна. Следуя правилам хорошего тона, нам также нужно использовать многочисленные нити. Дело в том, что, во-первых, хранитель не должен переставать работать даже если что-то "тяжелое" случилось, и во-вторых, нам не нужно использовать таймер. Процедура для запуска хранителя на полном экране - приблизительно такова:
Procedure RunFullScreen;
Var
R : TRect;
Msg : TMsg;
Dummy : Integer;
Foreground : hWnd;
Begin
IsPreview := False; MoveCounter := 3;
Foreground := GetForegroundWindow;
While (ShowCursor(False) > 0) do ;
GetWindowRect(GetDesktopWindow,R);
CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,0);
CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
SystemParametersInfo(spi_ScreenSaverRunning,1,@Dummy,0);
While GetMessage(Msg,0,0,0) do Begin
TranslateMessage(Msg);
DispatchMessage(Msg);
End;
SystemParametersInfo(spi_ScreenSaverRunning,0,@Dummy,0);
ShowCursor(True);
SetForegroundWindow(Foreground);
End;
|
Во-первых, мы проинициализировали некоторые глобальные переменные (описанные далее), затем прячем курсор мыши и создаем окно хранителя экрана. Имейте в виду, что важно уведомлять Windows, что это - хранителя экрана через SystemParametersInfo (это выводит из строя Ctrl-Alt-Del чтобы нельзя было вернуться в Windows не введя пароль). Создание окна хранителя:
Function CreateScreenSaverWindow(Width,Height : Integer;
ParentWindow : hWnd) : hWnd;
Var WC : TWndClass;
Begin
With WC do Begin
Style := cs_ParentDC;
lpfnWndProc := @PreviewWndProc;
cbClsExtra := 0; cbWndExtra := 0; hIcon := 0; hCursor := 0;
hbrBackground := 0; lpszMenuName := nil;
lpszClassName := 'MyDelphiScreenSaverClass';
hInstance := System.hInstance;
end;
RegisterClass(WC);
If (ParentWindow 0) Then
Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
ws_Child Or ws_Visible or ws_Disabled,0,0,
Width,Height,ParentWindow,0,hInstance,nil)
Else Begin
Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
ws_Visible or ws_Popup,0,0,Width,Height, 0,0,hInstance,nil);
SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize or
swp_NoRedraw);
End;
PreviewWindow := Result;
End;
|
Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения. Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра ? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:
Procedure RunPreview;
Var
R : TRect;
PreviewWindow : hWnd;
Msg : TMsg;
Dummy : Integer;
Begin
IsPreview := True;
PreviewWindow := StrToInt(ParamStr(2));
GetWindowRect(PreviewWindow,R);
CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,PreviewWindow);
CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
While GetMessage(Msg,0,0,0) do Begin
TranslateMessage(Msg); DispatchMessage(Msg);
End;
End;
|
Как Вы видите, window handle является вторым параметром (после "-p"). Чтобы "выполнять" хранителя экрана - нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:
Function PreviewThreadProc(Data : Integer) : Integer; StdCall;
Var R : TRect;
Begin
Result := 0; Randomize;
GetWindowRect(PreviewWindow,R);
MaxX := R.Right-R.Left; MaxY := R.Bottom-R.Top;
ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);
Repeat
InvalidateRect(PreviewWindow,nil,False);
Sleep(30);
Until QuitSaver;
PostMessage(PreviewWindow,wm_Destroy,0,0);
End;
|
Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить !). Для того, чтобы оперировать этим сообщением, нам нужна процедура:
Function PreviewWndProc(Window : hWnd; Msg,WParam,
LParam : Integer): Integer; StdCall;
Begin
Result := 0;
Case Msg of
wm_NCCreate : Result := 1;
wm_Destroy : PostQuitMessage(0);
wm_Paint : DrawSingleBox; { paint something }
wm_KeyDown : QuitSaver := AskPassword;
wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :
Begin
If (Not IsPreview) Then Begin
Dec(MoveCounter);
If (MoveCounter <= 0) Then QuitSaver := AskPassword;
End;
End;
Else Result := DefWindowProc(Window,Msg,WParam,LParam);
End;
End;
|
Если мышь перемещается, кнопка нажала, мы спрашиваем у пользователя пароль:
Function AskPassword : Boolean;
Var
Key : hKey;
D1,D2 : Integer; { two dummies }
Value : Integer;
Lib : THandle;
F : TVSSPFunc;
Begin
Result := True;
If (RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop',0,
Key_Read,Key) = Error_Success) Then
Begin
D2 := SizeOf(Value);
If (RegQueryValueEx(Key,'ScreenSaveUsePassword',nil,@D1,
@Value,@D2) = Error_Success) Then
Begin
If (Value 0) Then Begin
Lib := LoadLibrary('PASSWORD.CPL');
If (Lib > 32) Then Begin
@F := GetProcAddress(Lib,'VerifyScreenSavePwd');
ShowCursor(True);
If (@F nil) Then Result := F(PreviewWindow);
ShowCursor(False);
MoveCounter := 3; { reset again if password was wrong }
FreeLibrary(Lib);
End;
End;
End;
RegCloseKey(Key);
End;
End;
|
Это также демонстрирует использование registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции? TVSSFunc ОПРЕДЕЛЕН как:
Type TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall; // Теперь почти все готово, кроме диалога конфигурации. Это запросто: Procedure RunSettings; Var Result : Integer; Begin Result := DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc); If (Result = idOK) Then SaveSettings; End; |
Трудная часть -это создать диалоговый сценарий (запомните: мы не используем здесь Delphi формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:
SaverSettingsDlg DIALOG 70, 130, 166, 75
STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU
CAPTION "Settings for Boxes"
FONT 8, "MS Sans Serif"
BEGIN
DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16
PUSHBUTTON "Cancel", 6, 115, 28, 46, 16
CTEXT "Box &Color:", 3, 2, 30, 39, 9
COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
CTEXT "Box &Type:", 1, 4, 3, 36, 9
COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani
Jдгvinеn.", 7, 4, 57, 103, 16,
WS_CHILD | WS_VISIBLE | WS_GROUP
END
|
Почти также легко сделать диалоговое меню:
Function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer):
Integer; StdCall;
Var S : String;
Begin
Result := 0;
Case Msg of
wm_InitDialog : Begin
{ initialize the dialog box }
Result := 0;
End;
wm_Command : Begin
If (LoWord(WParam) = 5) Then EndDialog(Window,idOK)
Else If (LoWord(WParam) = 6) Then EndDialog(Window,idCancel);
End;
wm_Close : DestroyWindow(Window);
wm_Destroy : PostQuitMessage(0);
Else Result := 0;
End;
End;
|
После того, как пользователь выбрал некоторые установочные параметры, нам нужно сохранить их.
Procedure SaveSettings;
Var
Key : hKey;
Dummy : Integer;
Begin
If (RegCreateKeyEx(hKey_Current_User,
'Software\SilverStream',
0,nil,Reg_Option_Non_Volatile,
Key_All_Access,nil,Key,
@Dummy) = Error_Success) Then Begin
RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,
@RoundedRectangles,SizeOf(Boolean));
RegSetValueEx(Key,'SolidColors',0,Reg_Binary, @SolidColors,SizeOf(Boolean));
RegCloseKey(Key);
End;
End;
|
Загружаем параметры так:
Procedure LoadSettings;
Var
Key : hKey;
D1,D2 : Integer; { two dummies }
Value : Boolean;
Begin
If (RegOpenKeyEx(hKey_Current_User,
'Software\SilverStream',0,
Key_Read,
Key) = Error_Success) Then Begin
D2 := SizeOf(Value);
If (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1,
@Value, @D2) = Error_Success) Then
Begin
RoundedRectangles := Value;
End;
If (RegQueryValueEx(Key,'SolidColors',nil,@D1,
@Value,@D2) = Error_Success) Then
Begin
SolidColors := Value;
End;
RegCloseKey(Key);
End;
End;
|
Легко? Нам также нужно позволить пользователю, установить пароль. Я честно не знаю почему это оставлено разработчику приложений ? Тем не менее:
Procedure RunSetPassword;
Var
Lib : THandle;
F : TPCPAFunc;
Begin
Lib := LoadLibrary('MPR.DLL');
If (Lib > 32) Then Begin
@F := GetProcAddress(Lib,'PwdChangePasswordA');
If (@F nil) Then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);
FreeLibrary(Lib);
End;
End;
|
Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом. TPCPAFund ОПРЕДЕЛЕН как:
Type
TPCPAFunc = Function(A : PChar; Parent : hWnd;
B,C : Integer) : Integer; StdCall;
|
(Не спрашивайте меня что за параметры B и C) Теперь единственная вещь, которую нам нужно рассмотреть, - самая странная часть: создание графики. Я не великий ГУРУ графики, так что Вы не увидите затеняющие многоугольники, вращающиеся в реальном времени. Я только сделал некоторые ящики.
Procedure DrawSingleBox;
Var
PaintDC : hDC;
Info : TPaintStruct;
OldBrush : hBrush;
X,Y : Integer;
Color : LongInt;
Begin
PaintDC := BeginPaint(PreviewWindow,Info);
X := Random(MaxX); Y := Random(MaxY);
If SolidColors Then
Color :=
GetNearestColor(PaintDC,RGB(Random(255),Random(255),Random(255)))
Else Color := RGB(Random(255),Random(255),Random(255));
OldBrush := SelectObject(PaintDC,CreateSolidBrush(Color));
If RoundedRectangles Then
RoundRect(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y),20,20)
Else Rectangle(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y));
DeleteObject(SelectObject(PaintDC,OldBrush));
EndPaint(PreviewWindow,Info);
End;
|
Чтобы закончить создание хранителя, я даю Вам некоторые детали. Первые, глобальные переменные:
Var IsPreview : Boolean; MoveCounter : Integer; QuitSaver : Boolean; PreviewWindow : hWnd; MaxX,MaxY : Integer; RoundedRectangles : Boolean; SolidColors : Boolean; |
Затем исходная программа проекта (.dpr). Красива, а!?
program MySaverIsGreat;
uses
windows, messages, Utility; { defines all routines }
{$R SETTINGS.RES}
begin
RunScreenSaver;
end.
|
От переводчика. Если все же очень трудно обойтись без использования Delphi-форм, то можно поступить как в случае с вводом пароля: форму изменения параметров хранителя сохранить в виде DLL и инамически ее загружать при необходимости. Т.о. будет маленький и шустрый файл самого хранителя экрана и довеска DLL для конфигурирования и прочего (там объем и скорость уже не критичны).
Создаём SystemDSN при помощи Delphi.
Этот пример показывает один из способов создания ODBC драйвера для доступа к файлу Access MDB. Подобная операция применима к большинству файлов баз данных. Естевственно, Вам потребуется MDB файл, для того, чтобы связать его с DSN.
const
ODBC_ADD_DSN = 1; // Добавляем источник данных
ODBC_CONFIG_DSN = 2; // Конфигурируем (редактируем) источник данных
ODBC_REMOVE_DSN = 3; // Удаляем источник данных
ODBC_ADD_SYS_DSN = 4; // Добавляем системный DSN
ODBC_CONFIG_SYS_DSN = 5; // Конфигурируем системный DSN
ODBC_REMOVE_SYS_DSN = 6; // удаляем системный DSN
type
TSQLConfigDataSource = function( hwndParent: HWND; fRequest: WORD;
lpszDriver: LPCSTR; lpszAttributes: LPCSTR ) : BOOL; stdcall;
procedure Form1.FormCreate(Sender: TObject);
var
pFn: TSQLConfigDataSource;
hLib: LongWord;
strDriver: string;
strHome: string;
strAttr: string;
strFile: string;
fResult: BOOL;
ModName: array[0..MAX_PATH] of Char;
srInfo : TSearchRec;
begin
Windows.GetModuleFileName( HInstance, ModName, SizeOf(ModName) );
strHome := ModName;
while ( strHome[length(strHome)] <> '\' ) do
Delete( strHome, length(strHome), 1 );
// Тестовая база данных (Axes = Access)
strFile := strHome + 'TestData.MDB';
// загружаем библиотеку (путь по умолчанию)
hLib := LoadLibrary( 'ODBCCP32' );
if( hLib <> NULL ) then
begin
@pFn := GetProcAddress( hLib, 'SQLConfigDataSource' );
if( @pFn <> nil ) then
begin
// начинаем создание DSN
strDriver := 'Microsoft Access Driver (*.mdb)';
strAttr := Format( 'DSN=TestDSN' + #0 + 'DBQ=%s' + #0 +
'Exclusive=1' + #0 + 'Description=Test Data' + #0 + #0, [strFile] );
fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
if( fResult = false ) then
ShowMessage( 'Ошибка создания DSN (Datasource) !' );
// test/create MDB file associated with DSN
if( FindFirst( strFile, 0, srInfo ) <> 0 ) then
begin
strDriver := 'Microsoft Access Driver (*.mdb)';
strAttr := Format( 'DSN=TestDSN'+#0+ 'DBQ=%s'+#0+ 'Exclusive=1'+#0+
'Description=Test Data'+#0+ 'CREATE_DB="%s"'#0+#0, [strFile,strFile] );
fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
if( fResult = false ) then
ShowMessage( 'Ошибка создания MDB (файла базы данных) !' );
end;
FindClose( srInfo );
end;
FreeLibrary( hLib );
end
else
ShowMessage( 'Невозможно загрузить ODBCCP32.DLL' );
end;
|
Создание ярлыков на рабочем столе, старт меню, панели быстрого запуска.
uses
Registry,
ActiveX,
ComObj,
ShlObj;
type
ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU, _OTHERFOLDER);
function CreateShortcut(SourceFileName: string; // the file the shortcut points to
Location: ShortcutType; // shortcut location
SubFolder, // subfolder of location
WorkingDir, // working directory property of the shortcut
Parameters,
Description: string): // description property of the shortcut
string;
const
SHELL_FOLDERS_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\Explorer';
QUICK_LAUNCH_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\GrpConv';
var
MyObject: IUnknown;
MySLink: IShellLink;
MyPFile: IPersistFile;
Directory, LinkName: string;
WFileName: WideString;
Reg: TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
MySLink.SetPath(PChar(SourceFileName));
MySLink.SetArguments(PChar(Parameters));
MySLink.SetDescription(PChar(Description));
LinkName := ChangeFileExt(SourceFileName, '.lnk');
LinkName := ExtractFileName(LinkName);
// Quicklauch
if Location = _QUICKLAUNCH then
begin
Reg := TRegIniFile.Create(QUICK_LAUNCH_ROOT);
try
Directory := Reg.ReadString('MapGroups', 'Quick Launch', '');
finally
Reg.Free;
end;
end
else
// Other locations
begin
Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
try
case Location of
_OTHERFOLDER : Directory := SubFolder;
_DESKTOP : Directory := Reg.ReadString('Shell Folders', 'Desktop', '');
_STARTMENU : Directory := Reg.ReadString('Shell Folders', 'Start Menu', '');
_SENDTO : Directory := Reg.ReadString('Shell Folders', 'SendTo', '');
end;
finally
Reg.Free;
end;
end;
if Directory <> '' then
begin
if (SubFolder <> '') and (Location <> _OTHERFOLDER) then
WFileName := Directory + '\' + SubFolder + '\' + LinkName
else
WFileName := Directory + '\' + LinkName;
if WorkingDir = '' then
MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)))
else
MySLink.SetWorkingDirectory(PChar(WorkingDir));
MyPFile.Save(PWChar(WFileName), False);
Result := WFileName;
end;
end;
function GetProgramDir: string;
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
Result := reg.ReadString('Programs');
reg.CloseKey;
finally
reg.Free;
end;
end;
// Some examples:
procedure TForm1.Button1Click(Sender: TObject);
const
PROGR = 'c:\YourProgram.exe';
var
resPath: string;
begin
//Create a Shortcut in the Quckick launch toolbar
CreateShortcut(PROGR, _QUICKLAUNCH, '','','','Description');
//Create a Shortcut on the Desktop
CreateShortcut(PROGR, _DESKTOP, '','','','Description');
//Create a Shortcut in the Startmenu /"Programs"-Folder
resPath := CreateShortcut(PROGR, _OTHERFOLDER, GetProgramDir,'','','Description');
if resPath <> '' then
begin
ShowMessage('Shortcut Successfully created in: ' + resPath);
end;
end;
|
Как создать таблицу базы данных, не используя Database Desktop.
Положите компонент TTable на форму и попробуйте указанную ниже процедуру.
procedure TForm1.CreateMyTable(NameFile: string);
begin
with Table1 do
begin
Active := False;
DatabaseName := '';
TableName := NameFile;
TableType := ttDefault;
with FieldDefs do
begin
Clear;
Add('EmpNo', ftInteger, 0, False);
Add('LastName', ftString, 20, False);
Add('FirstName', ftString, 15, False);
Add('PhoneExt', ftString, 4, False);
Add('HireDate', ftDateTime, 0, False);
Add('Salary', ftFloat, 0, False);
end;
with IndexDefs do
begin
Clear;
Add('', 'EmpNo', [ixPrimary, ixUnique]);
Add('ByName', 'LastName;FirstName', [ixCaseInsensitive]);
end;
CreateTable;
Free;
end;
end;
|
Как создать таблицу базы данных, не используя Database Desktop 2.
sql := "CREATE TABLE "employee.db"( Last_Name CHAR(20),
First_Name CHAR(15), Salary NUMERIC(10,2),
Dept_No SMALLINT, PRIMARY KEY (Last_Name, First_Name))";
Query1.sql.text:=sql;
Query1.ExecSQL;
|
Как создать таблицу базы данных, не используя Database Desktop 3.
uses DB, DBTables, StdCtrls;
procedure TForm1.Button1Click(Sender: TObject);
var
tSource, TDest: TTable;
begin
TSource := TTable.create(self);
with TSource do
begin
DatabaseName := 'dbdemos';
TableName := 'customer.db';
open;
end;
TDest := TTable.create(self);
with TDest do
begin
DatabaseName := 'dbdemos';
TableName := 'MyNewTbl.db';
FieldDefs.Assign(TSource.FieldDefs);
IndexDefs.Assign(TSource.IndexDefs);
CreateTable;
end;
TSource.close;
end;
|
Как создать таблицу базы данных, не используя Database Desktop 4.
// Создание DBF-файла во время работы приложения
...
const
CreateTab = 'CREATE TABLE ';
IDXTab = 'PRIMARY KEY ';
MyTabStruct =
'IDX_TAB DECIMAL(6,0), ' +
'DATE_ DATE, ' +
'FLD_1 CHARACTER(20), ' +
'FLD_2 DECIMAL(7,2), ' +
'FLD_3 BOOLEAN, ' +
'FLD_4 BLOB(1,1), ' +
'FLD_5 BLOB(1,2), ' +
'FLD_6 BLOB(1,3), ' +
'FLD_7 BLOB(1,4), ' +
'FLD_8 BLOB(1,5) ';
...
// создание таблицы без индекса
procedure TForm1.Button1Click(Sender: TObject);
begin
if CreateTable('"MYTAB.DBF"', MyTabStruct, '') then
...
// выполняем дальнейшие операции
else
...
end;
// создание таблицы с индексом
procedure TForm1.Button2Click(Sender: TObject);
begin
if CreateTable('"MYTAB.DBF"', MyTabStruct, IDXTab + ' (IDX_TAB)') then
...
// выполняем дальнейшие операции
else
...
end;
function TForm1.CreateTable(TabName, TabStruct, TabIDX: string): boolean;
var
qyTable: TQuery;
begin
result := true;
qyTable := TQuery.Create(Self);
with qyTable do
try
try
SQL.Clear;
SQL.Add(CreateTab + TabName + '(' + TabStruct + TabIDX + ')');
Prepare;
// ExecSQL, а не Open. Иначе ... облом
ExecSQL;
except
// Обработка ошибок открытия таблицы Возможности обработчика можно расширить.
Exception.Create('Ошибка открытия таблицы');
result := false;
end;
finally
Close;
end;
end;
|
Как создать таблицу базы данных, не используя Database Desktop 5.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses DB, DBTables;
procedure TForm1.Button1Click(Sender: TObject);
begin
with TTable.Create(Self) do
begin // create TTable object
DatabaseName := 'c:\temp'; // point to directory or alias
TableName := 'FOO'; // give table a name
TableType := ttParadox; // make a Paradox table
with FieldDefs do
begin
Add('Age', ftInteger, 0, True); // add an integer field
Add('Name', ftString, 25, False); // add a string field
Add('Weight', ftFloat, 0, False); // add a floating-point field
end;
{ create a primary index on the Age field... }
IndexDefs.Add('', 'Age', [ixPrimary, ixUnique]);
CreateTable; // create the table
end;
end;
end.
Создавать таблицы такой же структуры.
| Автор: Nomadic |
| В 1995 году на компьютерной выставке CeBIT в Ганновере во время доклада Билла Гейтса в зале поднимали плакат "Alt+F4". |
Удобней всего, например, так.
with bmovMyBatchMove do begin Mode := bmCopy; RecordCount := 1; Execute;R Destination.Delete; end; |
Решалась же эта проблема следующим способом:
procedure CopyStruct(SrcTable, DestTable: TTable; cpyFields: array of string);
var
i: Integer;
bActive: Boolean;
SrcDatabase, DestDatabase: TDatabase;
iSrcMemSize, iDestMemSize: Integer;
pSrcFldDes: PFldDesc;
CrtTableDesc: CRTblDesc;
bNeedAllFields: Boolean;
begin
SrcDatabase := Session.OpenDatabase(SrcTable.DatabaseName);
try
DestDatabase := Session.OpenDatabase(DestTable.DatabaseName);
try
bActive := SrcTable.Active;
SrcTable.FieldDefs.Update;
iSrcMemSize := SrcTable.FieldDefs.Count * SizeOf(FLDDesc);
pSrcFldDes := AllocMem(iSrcMemSize);
if pSrcFldDes = nil then
begin
raise EOutOfMemory.Create('Не хватает памяти!');
end;
try
SrcTable.Open;
Check(DbiGetFieldDescs(SrcTable.Handle, pSrcFldDes));
SrcTable.Active := bActive;
FillChar(CrtTableDesc, SizeOf(CrtTableDesc), 0);
with CrtTableDesc do
begin
StrPcopy(szTblName, DestTable.TableName);
StrPcopy(szTblType, 'DBASE');
if (Length(cpyFields[0]) = 0) or (cpyFields[0] = '*') then
begin
bNeedAllFields := True;
SrcTable.FieldDefs.Update;
iFldCount := SrcTable.FieldDefs.Count;
end
else
begin
bNeedAllFields := False;
iFldCount := High(cpyFields) + 1;
end;
iDestMemSize := iFldCount * Sizeof(FLDDesc);
CrtTableDesc.pFLDDesc := AllocMem(iDestMemSize);
if CrtTableDesc.pFLDDesc = nil then
begin
raise EOutOfMemory.Create('Не хватает памяти!');
end;
end;
try
if bNeedAllFields then
begin
for i := 0 to CrtTableDesc.iFldCount - 1 do
begin
Move(PFieldDescList(pSrcFldDes)^[i],
PFieldDescList(CrtTableDesc.pFLDDesc)^[i], SizeOf(FldDesc));
end;
end
else
begin
for i := 0 to CrtTableDesc.iFldCount - 1 do
begin
Move(PFieldDescList(pSrcFldDes)^[SrcTable.FieldDefs.Find(cpyFields[i]).FieldNo - 1],
PFieldDescList(CrtTableDesc.pFLDDesc)^[i], SizeOf(FldDesc));
end;
end;
Check(DbiCreateTable(DestDatabase.Handle, True, CrtTableDesc));
finally
FreeMem(CrtTableDesc.pFLDDesc, iDestMemSize);
end;
finally
FreeMem(pSrcFldDes, iSrcMemSize);
end;
finally
Session.CloseDatabase(DestDatabase);
end;
finally
Session.CloseDatabase(SrcDatabase);
end;
end;
|
Динамическое создание таблицы и полей во время выполнения программы.
Delphi в режиме разработки позволяет быстро добавлять и настраивать в вашем проекте компоненты для работы с базами данных, но есть ситуации, когда вам нужно создавать и конфигурировать объекты во время выполнения программы. Например, во время выполнения программы вам может понадобиться добавить колонку с вычисляемым полем (используя алгоритмы пользователя). Поэтому вопрос: как, не используя среды разработки, Инспектора Объектов и редактора TFields, создавать и сконфигурировать TField и другие компоненты для связки данных? В следующем примере показано динамическое создание TTable, таблицы базы данных в связке с TTable, TFieldDefs, TFields, вычисляемых полей и подключение обработчика для события OnCalc. Для начала выберите пункт New Application меню File. Будет создан новый проект с пустой формой, на которой мы и будет создавать на лету наши компоненты.В секцию interface вашего модуля формы добавьте, как показано ниже, объявление обработчика события OnCalcFields и поля TaxAmount. Позже мы создадим TTable и назначим этот обработчик событию TTable OnCalcFields, который позволит при чтении каждой записи вызывать событие OnCalcFields, которое, в свою очередь, выполнит нашу процедуру TaxAmountCalc.
type
TForm1 = class(TForm)
procedure TaxAmountCalc(DataSet: TDataset);
private
TaxAmount: TFloatField;
end;
|
В секции implementation создайте обработчик события OnCalc как показано ниже:
procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
Dataset['TaxAmount'] := Dataset['ItemsTotal'] *
(Dataset['TaxRate'] / 100);
end;
|
Создайте обработчик формы OnCreate как показано ниже (для получения дополнительной информации о создании обработчиков событий обратитесь к Delphi Users Guide, Chapter 4 "Working With Code").
procedure TForm1.FormCreate(Sender: TObject);
var
MyTable: TTable;
MyDataSource: TDataSource;
MyGrid: TDBGrid;
begin
{ Создаем компонент TTable -- связанная
таблица базы данных будет создана ниже. }
MyTable := TTable.Create(Self);
with MyTable do
begin
{ Определяем основную базу данных и таблицу.
Примечание: Test.DB пока не существует. }
DatabaseName := 'DBDemos';
TableName := 'Test.DB';
{ Назначаем TaxAmountCalc обработчиком события,
чтобы использовать его при наступлении события
OnCalcFields в MyTable. }
OnCalcFields := TaxAmountCalc;
{ Создаем и добавляем определения полей к массиву TTable
FieldDefs, затем создаем TField с использованием
информации из определения поля. }
with FieldDefs do
begin
Add('ItemsTotal', ftCurrency, 0, false);
FieldDefs[0].CreateField(MyTable);
Add('TaxRate', ftFloat, 0, false);
FieldDefs[1].CreateField(MyTable);
TFloatField(Fields[1]).DisplayFormat := '##.0%';
{ Создаем вычисляемое TField, назначаем свойства,
и добавляем поле к массиву определений MyTable. }
TaxAmount := TFloatField.Create(MyTable);
with TaxAmount do
begin
FieldName := 'TaxAmount';
Calculated := True;
Currency := True;
DataSet := MyTable;
Name := MyTable.Name + FieldName;
MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
end;
end;
{ Создаем в базе данных новую таблицу,
используя в качестве основы MyTable. }
MyTable.CreateTable;
end;
{ Создаем компонент TDataSource
и назначаем его MyTable. }
MyDataSource := TDataSource.Create(Self);
MyDataSource.DataSet := MyTable;
{ Создаем табличную сетку, отображаем
на форме, и назначаем MyDataSource для
получения доступа к данным из MyTable. }
MyGrid := TDBGrid.Create(Self);
with MyGrid do
begin
Parent := Self;
Align := alClient;
DataSource := MyDataSource;
end;
{ Запускаем нашу конструкцию! }
MyTable.Active := True;
Caption := 'Новая таблица ' + MyTable.TableName;
end;
|
Ниже приведен полный исходный код проекта:
unit gridcalc;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, Grids, DBGrids, ExtCtrls, DBCtrls, DB,
DBTables, StdCtrls;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure TaxAmountCalc(DataSet: TDataset);
private
TaxAmount: TFloatField;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
Dataset['TaxAmount'] := Dataset['ItemsTotal'] *
(Dataset['TaxRate'] / 100);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
MyTable: TTable;
MyDataSource: TDataSource;
MyGrid: TDBGrid;
begin
MyTable := TTable.Create(Self);
with MyTable do
begin
DatabaseName := 'DBDemos';
TableName := 'Test.DB';
OnCalcFields := TaxAmountCalc;
with FieldDefs do
begin
Add('ItemsTotal', ftCurrency, 0, false);
FieldDefs[0].CreateField(MyTable);
Add('TaxRate', ftFloat, 0, false);
FieldDefs[1].CreateField(MyTable);
TFloatField(Fields[1]).DisplayFormat := '##.0%';
TaxAmount := TFloatField.Create(MyTable);
with TaxAmount do
begin
FieldName := 'TaxAmount';
Calculated := True;
Currency := True;
DataSet := MyTable;
Name := MyTable.Name + FieldName;
MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
end;
end;
MyTable.CreateTable;
end;
MyDataSource := TDataSource.Create(Self);
MyDataSource.DataSet := MyTable;
MyGrid := TDBGrid.Create(Self);
with MyGrid do
begin
Parent := Self;
Align := alClient;
DataSource := MyDataSource;
end;
MyTable.Active := True;
Caption := 'Новая таблица ' + MyTable.TableName;
end;
end.
|
Создание таблицы в модуле.
Объект TTable может быть создан с владельцем, а может и без оного. Поскольку вы объявляете его локально в процедуре, то владелец в этом случае не требуется. Если владелец не задан, то забота об освобождении объекта ложится на вас. В противном случае объект освобождается владельцем всякий раз, когда освобождается сам владелец. Имеет смысл? Чтобы создать таблицу без владельца, сделайте следующее:
procedure CreateATableInAUnit;
var
myTable: TTable;
begin
myTable := TTable.Create(nil);
try
myTable.DatabaseName := 'MyDB';
myTable.TableName := 'MyTable.db';
mytable.IndexName := 'MyIndex';
myTable.Open;
{другой код}
finally
myTable.Free;
end;
end;
|
Создание компонента TTable без формы.
Действительно, любой компонент можно создать и без (вне) формы или любого другого дочернего компонента. Для этого я использую параметр nil:
FSession := TSession.Create(nil); FDatabase := TDatabase.Create(nil); FSession.SessionName := 'DBSession' FDatabase.Connected := False; FDatabase.AliasName := Database; FDatabase.DatabaseName := USER_DATABASE; FDatabase.SessionName := FSession.SessionName; FUserTBL := TTable.Create(nil); FUserTBL.DatabaseName := FDatabase.DatabaseName; FUserTBL.SessionName := FSession.SessionName; FUserTBL.TableName := USERTBL; FUserTBL.IndexName := USERSpIndex; FUserSource := TDataSource.Create(nil); FUserSource.DataSet := FUserTBL; |
Создание компонента TTable без формы 2.
Вы можете использовать TTable, не размещая компонент на форме:
procedure TForm1.TotalPopulation: double;
var
Tbl: TTable;
begin
Result := 0;
Tbl := TTable.Create(nil);
try
tbl.DatabaseName := 'DBDEMOS';
tbl.TableName := 'COUNTRY';
Tbl.Open;
tbl.First;
while not Tbl.EOF do
begin
Result := Result + Tbl.FieldByName('Population').AsFloat;
Tbl.Next;
end;
Tbl.Close;
finally
Tbl.Free;
end;
end;
|
Создание компонента TTable без формы 3.
Для создания таблицы программным способом вы должны сделать приблизительно следующее:
with Table1 do
begin
Close;
TableName := 'test.db';
TableType := ttParadox;
DatabaseName := 'Sample';
FieldDefs.Clear;
{FldName,FldType,FldLength,Required}
FieldDefs.Add('Field1',ftString,10,false);
...
{ Создание первичного индекса }
IndexDefs.Add('','Field1',[ixPrimary]);
CreateTable;
end;
|
Создание компонента TTable без формы 4.
Я привожу некоторый код, касающийся описываемой проблемы: он работал, когда я использовал его в большом приложении. Я не знаю специфического метода создания компонента TTable вне родителей, поэтому я пошел путем создания своего класса от TTable во время инициализации модуля. Удобство такого подхода объясняется наличием под рукой всегда готового к работе экземпляра класса, стоит всего-лишь добавить модуль к вашему приложению. Конечно, новый класс не должен иметь одиноко выглядящую процедуру со странной технологией фильтрации данных :=))), да и не помешала бы публикация нескольких событий, но этот пример призван все-го лишь продемонстрировать иной подход к решаемой задаче.
unit Unit2;
interface
uses db, DBTables, dialogs;
type
fake = class(Ttable)
procedure fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);
end;
var
MyTable: fake;
implementation
procedure fake.fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);
begin
showmessage('Здравствуй, Вася');
end;
initialization
MyTable := fake.create(nil);
with Mytable do
begin
DataBaseName := 'dbdemos';
TableName := 'biolife';
OnFilterRecord := MyTable.fakeFilterRecord;
Filtered := true;
active := true;
end;
{проверка получением неких данных...}
showmessage(MyTable.fields[1].asstring);
finalization
{Важно! MyTable не имеет родителя, - уничтожаем объект сами,
иначе память не высвобождается...}
MyTable.free;
end.
|
Создание таблицы с автоинкрементальным полем.
Допустим у вас имеется форма с кнопкой. Щелчок на кнопке с помощью DbiCreateTable должен создать таблицу Paradox с автоинкрементальным (приращиваемым) полем.
unit Autoinc;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, DBTables, DB, ExtCtrls, DBCtrls, Grids, DBGrids, StdCtrls,
DbiTypes, DbiErrs, DBIProcs;
const
szTblName = 'CR8PXTBL'; { Имя создаваемой таблицы. }
szTblType = szPARADOX; { Используемый тип таблицы. }
{ При создании таблицы используется полное описание поля }
const
fldDes: array[0..1] of FLDDesc = (
({ Поле 1 - AUTOINC }
iFldNum: 1; { Номер поля }
szName: 'AUTOINC'; { Имя поля }
iFldType: fldINT32; { Тип поля }
iSubType: fldstAUTOINC; { Подтип поля }
iUnits1: 0; { Размер поля }
iUnits2: 0; { Десятичный порядок следования ( 0 ) }
iOffset: 0; { Смещение в записи ( 0 ) }
iLen: 0; { Длина в байтах ( 0 ) }
iNullOffset: 0; { Для Null-битов ( 0 ) }
efldvVchk: fldvNOCHECKS; { Проверка корректности ( 0 ) }
efldrRights: fldrREADWRITE { Права }
),
({ Поле 2 - ALPHA }
iFldNum: 2; szName: 'ALPHA';
iFldType: fldZSTRING; iSubType: fldUNKNOWN;
iUnits1: 10; iUnits2: 0;
iOffset: 0; iLen: 0;
iNullOffset: 0; efldvVchk: fldvNOCHECKS;
efldrRights: fldrREADWRITE
));
type
TForm1 = class(TForm)
Button1: TButton;
Database1: TDatabase;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
TblDesc: CRTblDesc;
uNumFields: Integer;
Rslt: DbiResult;
ErrorString: array[0..dbiMaxMsgLen] of Char;
begin
FillChar(TblDesc, sizeof(CRTblDesc), #0);
lStrCpy(TblDesc.szTblName, szTblName);
lStrCpy(TblDesc.szTblType, szTblType);
uNumFields := trunc(sizeof(fldDes) / sizeof(fldDes[0]));
TblDesc.iFldCount := uNumFields;
TblDesc.pfldDesc := @fldDes;
Rslt := DbiCreateTable(Database1.Handle, TRUE, TblDesc);
if Rslt <> dbiErr_None then
begin
DbiGetErrorString(Rslt, ErrorString);
MessageDlg(StrPas(ErrorString), mtWarning, [mbOk], 0);
end;
end;
end.
|
Создание таблицы программным путем.
Автор: Цымбал Виталий WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание таблицы программным путем
Function CreateTable(liTableType:Integer;lsTableName:AnsiString;lsFields:AnsiString):BOOLEAN;
liTableType
Value Meaning
0 ttDefault (Default) Determine table type based on file extension for the table.
1 ttParadox Table is a Paradox table.
2 ttDBase Table is a dBASE table.
3 ttFoxPro Table is a FoxPro table.
4 ttASCII Table is a text file with comma-delimited, quoted strings for each field
If liTableType is set to 0(ttDefault), the lsTableName extension determines the table type:
Extension Meaning
DB or none Paradox table
DBF dBASE table
TXT ASCII table
ATTENTION!!
lsFields
‘Name1;DataType1;Size1;Precision1;Requered1;Name2;DataType2;Size2;
Precision2;Requered2;…;…;…;…;…; NameN;DataTypeN;SizeN;PrecisionN;RequeredN’
1.Name : string;
2.DataType : TFieldType:
Value Description
ftUnknown Unknown or undetermined
ftString Character or string field
ftSmallint 16-bit integer field
ftInteger 32-bit integer field
ftWord 16-bit unsigned integer field
ftBoolean Boolean field
ftFloat Floating-point numeric field
ftCurrency Money field
ftBCD Binary-Coded Decimal field
ftDate Date field
ftTime Time field
ftDateTime Date and time field
ftBytes Fixed number of bytes (binary storage)
ftVarBytes Variable number of bytes (binary storage)
ftAutoInc Auto-incrementing 32-bit integer counter field
ftBlob Binary Large OBject field
ftMemo Text memo field
ftGraphic Bitmap field
ftFmtMemo Formatted text memo field
ftParadoxOle Paradox OLE field
ftDBaseOle dBASE OLE field
ftTypedBinary Typed binary field
ftCursor Output cursor from an Oracle stored procedure (TParam only)
ftFixedChar Fixed character field
ftWideString Wide string field
ftLargeInt Large integer field
ftADT Abstract Data Type field
ftArray Array field
ftReference REF field
ftDataSet DataSet field
ftOraBlob BLOB fields in Oracle 8 tables
ftOraClob CLOB fields in Oracle 8 tables
ftVariant Data of unknown or undetermined type
ftInterface References to interfaces (IUnknown)
ftIDispatch References to IDispatch interfaces
ftGuid globally unique identifier (GUID) values
3. Size : integer
4. Precision : integer;
- for DataType ftBCD only
5. Requered : Boolean
Value – [true;false]
Example
CreateTable(1,'c:\base1','CODE;ftString;60;0;;NAME;ftString;100;0;true;COUNT;
ftInteger;;;;SUM;ftBCD;10;2;false;DATE;ftDate;;;')
Зависимости: Windows, Messages, SysUtils, Classes, Db, DBTables
Автор: Цымбал Виталий Викторович, victor@ab-system.com, Львов
Copyright: Собственная разработка
Дата: 16 августа 2002 г.
***************************************************** }
function TForm1.CreateTable(liTableType: Integer; lsTableName: AnsiString;
lsFields: AnsiString): BOOLEAN;
var
TType, S, lSTR: AnsiString;
i: integer;
lSize: boolean;
FTable: TTable;
begin
try
Result := True;
i := 0;
lSTR := lsFields;
while Pos(';', lSTR) > 0 do
begin
lSTR[Pos(';', lSTR)] := '0';
i := i + 1;
end;
i := i + 1;
// проверка на количество разделителей ';' в описании полей - должно быть
// кратно 5
if (int(i / 5)) <> (i / 5) then
begin
ShowMessage('Ошибка!' + #13 +
'Неверное количество параметров в строке с данными про поля таблицы');
Result := False;
end;
// создание объекта - таблица
FTable := TTable.Create(nil);
with FTable do
begin
Active := False;
// задание типа таблицы в числовом выражении
case liTableType of
0: TableType := ttDefault;
1: TableType := ttParadox;
2: TableType := ttDBase;
3: TableType := ttFoxPro;
4: TableType := ttASCII;
else
begin
ShowMessage('Ошибка!' + #13 +
'Неверно задан тип тиблицы (возможны значения 0-4)');
Result := False;
end;
end;
// ввод имени таблицы с полным путем
TableName := lsTableName;
FieldDefs.Clear;
while Pos(';', lsFields) > 0 do
begin
with FieldDefs do
begin
S := copy(lsFields, 1, Pos(';', lsFields) - 1);
with AddFieldDef do
begin
// анализ и разбивка строки с данными про поля таблицы
system.delete(lsFields, 1, Pos(';', lsFields));
Name := S;
S := copy(lsFields, 1, Pos(';', lsFields) - 1);
lSize := True;
if (S = 'ftUnknown') then
begin
DataType := ftUnknown;
lSize := False;
end;
if (S = 'ftString') then
DataType := ftString;
if (S = 'ftBCD') then
DataType := ftBCD;
if (S = 'ftBytes') then
DataType := ftBytes;
if (S = 'ftVarBytes') then
DataType := ftVarBytes;
if (S = 'ftBlob') then
DataType := ftBlob;
if (S = 'ftMemo') then
DataType := ftMemo;
if (S = 'ftFmtMemo') then
DataType := ftFmtMemo;
if (S = 'ftSmallint') then
begin
DataType := ftSmallint;
lSize := False;
end;
if (S = 'ftInteger') then
begin
DataType := ftInteger;
lSize := False;
end;
if (S = 'ftBoolean') then
DataType := ftBoolean;
if (S = 'ftFloat') then
begin
DataType := ftFloat;
lSize := False;
end;
if (S = 'ftCurrency') then
begin
DataType := ftCurrency;
lSize := False;
end;
if (S = 'ftTime') then
begin
DataType := ftTime;
lSize := False;
end;
if (S = 'ftDate') then
begin
DataType := ftDate;
lSize := False;
end;
if (S = 'ftDateTime') then
begin
DataType := ftDateTime;
lSize := False;
end;
if (S = 'ftAutoInc') then
begin
DataType := ftAutoInc;
lSize := False;
end;
if (S = 'ftGraphic') then
DataType := ftGraphic;
if (S = 'ftParadoxOle') then
DataType := ftParadoxOle;
if (S = 'ftDBaseOle') then
DataType := ftDBaseOle;
if (S = 'ftTypedBinary') then
DataType := ftTypedBinary;
if (S = 'ftCursor') then
begin
DataType := ftCursor;
lSize := False;
end;
if (S = 'ftFixedChar') then
DataType := ftFixedChar;
if (S = 'ftWideString') then
DataType := ftWideString;
if (S = 'ftLargeint') then
DataType := ftLargeint;
if (S = 'ftADT') then
DataType := ftADT;
if (S = 'ftArray') then
DataType := ftArray;
if (S = 'ftReference') then
begin
DataType := ftReference;
lSize := False;
end;
if (S = 'ftDataSet') then
begin
DataType := ftDataSet;
lSize := False;
end;
if (S = 'ftOraBlob') then
DataType := ftOraBlob;
if (S = 'ftVariant') then
DataType := ftVariant;
if (S = 'ftInterface') then
DataType := ftInterface;
if (S = 'ftIDispatch') then
DataType := ftIDispatch;
if (S = 'ftGuid') then
DataType := ftGuid;
if (S = 'ftBoolean') then
begin
DataType := ftBoolean;
lSize := False;
end;
if (S = 'ftWord') then
begin
DataType := ftWord;
lSize := False;
end;
TType := S;
system.delete(lsFields, 1, Pos(';', lsFields));
S := copy(lsFields, 1, Pos(';', lsFields) - 1);
// Precision(Точность) поддерживает только тип BCD
if lSize then
if S <> '' then
begin
if TType = 'ftBCD' then
Precision := StrToInt(S)
else
Size := StrToInt(S);
end;
system.delete(lsFields, 1, Pos(';', lsFields));
S := copy(lsFields, 1, Pos(';', lsFields) - 1);
if (S <> '') and (TType = 'ftBCD') then
Size := StrToInt(S); //!!!
system.delete(lsFields, 1, Pos(';', lsFields));
if Pos(';', lsFields) > 0 then
begin
S := copy(lsFields, 1, Pos(';', lsFields) - 1);
system.delete(lsFields, 1, Pos(';', lsFields));
end
else
S := lsFields;
if (S <> '') then
if (UPPERCASE(s) = 'TRUE') then
Required := True;
end;
end;
end;
//создание таблицы с заданными параметрами
CreateTable;
// уничтожение объекта - таблица
FTable.Free
end;
if Result = True then
ShowMessage('Таблица создана успешно')
except
ShowMessage('Ошибка при создании таблицы');
end;
end;
end;
Пример использования:
CreateTable(1, 'c:\base1', 'CODE;ftString;60;0;;NAME;ftString;100;0;true;COUNT;ftInteger;;;;SUM;ftBCD;10;2;false;DATE;ftDate;;;')
Как создать временный Canvas.
Создайте Bitmap, и воспользуйтесь свойством холста TBitmap-а, чтобы рисовать на нём. Следующий пример создаёт Bitmap, рисует на его canvas-е, рисует canvas на форме, а затем освобождает bitmap.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var bm: TBitmap; begin bm := TBitmap.Create; bm.Width := 100; bm.Height := 100; bm.Canvas.Brush.Color := clRed; bm.Canvas.FillRect(Rect(0, 0, 100, 100)); bm.Canvas.MoveTo(0, 0); bm.Canvas.LineTo(100, 100); Form1.Canvas.StretchDraw(Form1.ClientRect, Bm); bm.Free; end; |
При попытке создать объект класса TPrinter я получаю exception.
В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости, так как обьект класса TPrinter (называемый Printer) автоматически создается при использовании модуля Printers.
uses
Printers;
procedure TForm1.Button1Click(Sender: TObject);
begin
Printer.BeginDoc;
Printer.Canvas.TextOut(100, 100,
'Delphi World is the biggest source code collection!');
Printer.EndDoc;
end;
|
Создание UDF для InterBase.
Пример библиотеки:
library nikelutils
uses SysUtils, Classes;
function MaxInt(var Int1, Int2: Integer): Integer;
far cdecl export;
begin
if (Int1 > Int2) then
Result := Int1
else
Result := Int2;
end;
function MinInt(var Int1, Int2: Integer): Integer;
far cdecl export;
begin
if (Int1 < Int2) then
Result := Int1
else
Result := Int2;
end;
exports
MaxInt;
MinInt;
begin
end.
|
А это пишим в базе:
DECLARE EXTERNAL FUNCTION MAXINT INTEGER, INTEGER RETURNS INTEGER BY VALUE ENTRY_POINT "MaxInt" MODULE_NAME "nikelutils.dll"; DECLARE EXTERNAL FUNCTION MININT INTEGER, INTEGER RETURNS INTEGER BY VALUE ENTRY_POINT "MinInt" MODULE_NAME "nikelutils.dll"; |
Создание уникального поля.
Procedure TableNewRecord(FieldName: String;
Var DataSet: TDataSet);
Var
NumRec: Integer;
bm: TBookmark;
Begin
with DataSet do
begin
NumRec := Succ(RecordCount);
if State = dsInsert then
Post;
bm := GetBookMark;
DisableControls;
while Locate(FieldName, NumRec, []) and (NumRec > 0) do
Dec(NumRec);
if NumRec = 0 then
begin
NumRec := RecordCount;
while Locate(FieldName, NumRec, []) do
Inc(NumRec);
end;
GotoBookmark(bm);
FreeBookmark(bm);
Edit;
FieldByName(FieldName).AsInteger := NumRec;
Post;
EnableControls;
end;
End;
|
Создание уникального поля 2.
Автор: Serg Вот мой вариант получения очередного уникального (возрастающего) ID По полю FieldName строится уникальный индексЗаодно скажу, что использование AutoInc не есть мудрое решение. А если надо пересобрать таблицы ?
{ Get max key value}
function quGetMaxID_(tbName,FieldName: String): LongInt;
begin
with TQuery.Create(nil) do
try
DatabaseName := DBname;
SQL.Add('SELECT MAX('+FieldName+') FROM ' + QuotedStr(tbName));
Open;
result := Fields[0].AsInteger + 1;
finally
Close;
Free;
end;
end;
{ insert new record and return new ID value}
function quInsertBlankSQL_(tbName,fName: string; var id: Longint): boolean;
var
i: integer;
begin
Result := False;
for i:=1 to RepeateAccess do
begin
id := quGetMaxID_(tbName,fName);
Result := quInsertKeySQL_(tbName,fName,id);
if Result then
Break;
end;
end;
{ Insert record for ID}
function quInsertKeySQL_(tbName, KeyField: string;
KeyValue: Longint): boolean;
var
i: integer;
str: string;
begin
Result := False;
str := 'INSERT INTO '+tbName+' ('+ KeyField + ')'+
' VALUES ('+IntToStr(KeyValue)+')';
for i:=1 to gRptAccess do
begin
Result := quExecuteSQL_(str);
if Result then
Break;
end;
end;
function quExecuteSQL_(SQLstring: string): boolean;
begin
with quCreateTmp_(SQLstring) do
begin
try
ExecSQL;
Result := True;
except
on E: Exception do
begin
Result := False;
end;
end;
Free;
end;
end;
function quCreateTmp_(SQLstring: string): TQuery;
begin
Result:= TQuery.Create(nil);
with Result do
begin
DatabaseName := DBname;
SQL.Text := SQLString;
end;
end;
|
Создание и использование 256-цветной палитры.
Автор: Bob TellerВот пример того, как можно создать и использовать палитру для 256-цветных изображений. Вам, вероятно, необходимо использовать API функции SelectPalette и RealizePalette, в зависимости от того как вы хотите использовать ваше изображение.
procedure TfrmMain.MakePalette(forBitMap: TBitMap);
var
pNewPal: PLogPalette;
lSize: LongInt;
nCntr: Byte;
begin
lSize := SizeOf(TLogPalette) +
SizeOf(TPaletteEntry) * 256;
try
GetMem(pNewPal, lSize);
pNewPal^.palNumEntries := 256;
pNewPal^.palVersion := $300;
{$R-} {выключаем контроль допустимого диапазона}
{создаем данные палитры...}
for nCntr := 0 to 254 do
begin
pNewPal^.palPalEntry[nCntr].peRed := nCntr + 20;
pNewPal^.palPalEntry[nCntr].peGreen := nCntr + 20;
pNewPal^.palPalEntry[nCntr].peBlue := nCntr + 20;
pNewPal^.palPalEntry[nCntr].peFlags := pc_nocollapse;
end;
{$R+} {включаем контроль допустимого диапазона}
{удаляем старый hPal; предохраняемся от утечки памяти}
DeleteObject(hPal);
{создаем новую палитру на основе новых значений}
hPal := CreatePalette(pNewPal^);
{назначаем новую палитру}
forBitMap.Palette := hPal;
finally
FreeMem(pNewPal, lSize);
end;
end;
|
Создание формы переменного типа.
Автор: Mike OrrissКак насчет этого? (допустим что str содержит 'TForm2' и т.п.)?
procedure TForm1.Button1Click(Sender: TObject);
begin
with TFormClass(FindClass(str)).Create(Application) do
try
ShowModal;
finally
Free;
end;
end;
initialization
RegisterClasses([TForm2,TForm3,TForm4]);
end.
|
Как сделать WebBrowser средствами Delphi 5.
| Автор: Лозовюк Александр WEB-сайт: http://search3i.al.ru/ |
| Мы с ней попробовали все ласки, все скорости и все позы. ...Потом она ушла в офф-лайн. |
Читая и перечитывая вопросы и ответы на Круглом столе сайта Королевство Дельфи я все время натыкался на вопросы о компоненте TWebBrowser. Сначала я думал, что все просто, но когда самому понадобилось написать приложение с использованием TwebBrowser… оказалось, что не все так просто!
Эта статья не претендует на исчерпывающие руководство по написанию браузера в Delphi 5 - скорее всего она будет со временем дополняться и исправляться. Я постарался обобщить в одном работающем примере решения большинства вопросов, заданных на этом сайте (признаюсь, там были и мои). Также выражаю большую признательность Елене Филлиповой за исчерпывающие ответы на некоторые из них, и всему Королевству за столь хороший и полезный сайт.
Компонент TWebBrowser в Delphi 4 нужно было специально инсталлировать как Active X компонент. В 5-й версии нам пошли навстречу, и он сразу есть на вкладке Internet. Не буду останавливаться на особенностях интерфейса программы - он очень прост (надеюсь, не очень) и не вызовет трудностей.
Рассмотрим некоторые свойства и функции TwebBrowser.
procedure GoBack; procedure GoForward; procedure GoHome; procedure GoSearch; procedure Refresh; procedure Stop; procedure Quit;Названия этих процедур говорят сами за себя, а позволяют они осуществить управление просмотром - перейти по истории просмотра вперед, назад, перейти на страницу, установленную как домашняя, открыть страницу поиска, обновить текущую страницу, остановить загрузку страницы, выйти.
Последняя команда самая интересная - в Help написано, что использовать ее не надо. Она завершает работу IE и очищает окно. Но я проверял - вроде вреда от ее использования не наблюдалось.
Далее идет целая группа процедур:
procedure Navigate(const URL: WideString); overload; procedure Navigate(const URL: WideString; var Flags: OleVariant); overload; procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: OleVariant); overload; procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant); overload; procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant); overload;Все они предназначены для указания того, какая и как страница должна отображаться в браузере. В простейшем случае можно использовать первую процедуру.
Procedure Navigate(const URL: WideString);Например так:
WebBrowser1.Navigate(' http://delphi.vitpc.com/');
Или.
WebBrowser1.Navigate(' http://delphi.vitpc.com/',empty,empty,empty,empty).
Для значения Flag определены такие константы:
NavOpenInNewWindow 1 Открывает URL в новом окне браузера.
NavNoHistory 2 Не заносит адрес в список History.
NavNoReadFromCache 4 Не использует сохраненную в кеше страницу, а загружает с сервера.
NavNoWriteToCache 8 Не записывает страницу в дисковый кеш.
NavAllowAutosearch 16 Если броузер не может найти указанный домен, он передает его в поисковый механизм.
Все, это можно также вручную установить в настройках браузера.
TargetFrameName указывает имя фрейма, куда надо загрузить страницу. Если присвоить NULL страница просто загрузиться в текущее окно.
PostData - указывает на данные, которые нужно отослать, используя метод HTTP POST. Если установить в NULL, процедура Navigate будет использовать метод HTTP GET.
Следующая довольно интересная и полезная процедура.
Procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT); overload;Позволяет осуществить управление браузером и вызывать различные дополнительные функции - печать, сохранение и др. Использует IoleCommandTarget интерфейс для управления браузером.
CmdID - задает команду, которую нужно выполнить. Может принимать следующие значения:
OLECMDID_OPEN, OLECMDID_NEW, OLECMDID_SAVE, OLECMDID_SAVEAS, OLECMDID_SAVECOPYAS, OLECMDID_PRINT, OLECMDID_PRINTPREVIEW, OLECMDID_PAGESETUP, OLECMDID_SPELL, OLECMDID_PROPERTIES, OLECMDID_CUT, OLECMDID_COPY, OLECMDID_PASTE, OLECMDID_PASTESPECIAL, OLECMDID_UNDO, OLECMDID_REDO, OLECMDID_SELECTALL, OLECMDID_CLEARSELECTION, OLECMDID_ZOOM, OLECMDID_GETZOOMRANGE, OLECMDID_UPDATECOMMANDS, OLECMDID_REFRESH, OLECMDID_STOP, OLECMDID_HIDETOOLBARS, OLECMDID_SETPROGRESSMAX , OLECMDID_SETPROGRESSPOS, OLECMDID_SETPROGRESSTEXT, OLECMDID_SETTITLE, OLECMDID_SETDOWNLOADSTATE, OLECMDID_STOPDOWNLOAD, OLECMDID_FIND, OLECMDID_ONTOOLBARACTIVATED, OLECMDID_DELETE, OLECMDID_HTTPEQUIV, OLECMDID_ENABLE_INTERACTION, OLECMDID_HTTPEQUIV_DONE, OLECMDID_ONUNLOAD, OLECMDID_PROPERTYBAG2, OLECMDID_PREREFRESHЕсли присмотреться, то можно увидеть, что некоторые из них дублируються процедурами Stop, Refresh и др. Но большенство очень даже нужные.
Cmdexecopt - указывает дополнительно, как команда должна исполняться. Может принимать значения:
OLECMDEXECOPT_DODEFAULT 0 Команда исполняеться так, как принято по умолчанию.
OLECMDEXECOPT_PROMPTUSER 1 Перед выполнением выводиться окно диалога или дополнительных настроек.
OLECMDEXECOPT_DONTPROMPTUSER 2 Не задаеться никаких вопросов.
OLECMDEXECOPT_SHOWHELP 3 Выводиться справка по запрошеному действии, но сама команда не выполняеться. Удобно для вызова из вашего приложения справки по IE.
Вызивать эту комманду желательно и даже нужно в блоке.
Try.WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
Except. End;Эта команда вызивает диалоговое окно печати документа. Если же опустить try…except, то при нажатии "Отмена" в этом окне будет сгенерировано уведомление об ошибке типа:
Raised exception class EOleException with message "Невозможно установить свойство coISpan. Недопустимое значения свойства. Требуется ввести значение от 1 до 1000". Теперь поговорим о свойствах.PopupMenu; Как оконный элемент управления, TwebBrowser поддерживает всплывающие меню. НО! Ваше меню будет появляться только пока в браузер не загружена страница. Дальше - только меню IE.
В Конференции предложили такой вариант для запрета появления стандартного меню.
...
private
{ Private declarations }
procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;
public
{ Public declarations }
end;
...
...
procedure TForm1.WMMouseActivate(var Msg: TMessage);
begin
try
inherited;
// right mouse button
if Msg.LParamHi = 516 then
Msg.Result:= MA_NOACTIVATEANDEAT;
// insert code here for show own context menu
except
end;
end;
|
Property OffLine : WordBool; Позволяет загружать документы из локального кеша - если присвоить True.
Property LocationURL: WideString; Позначено как "только для чтения" и содержит URL ресурса, загруженого в браузер.
Теперь события.
Среди самых важных/нужных есть:
OnDownloadBegin OnDownloadComplete OnBeforeNavigate2 OnNewWindow2 OnNavigateComplete2 OnDocumentCompleteOnDownloadBegin - происходит, когда вы, наберя URL, хотите перейти по нему. Тут можно задать например анимацию или ProgressBar для индикации процесса загрузки страницы ( совмесно с OnProgressChange).
OnDownloadComplete, OnDownloadComplete, OnNavigateComplete2 - происходит, когда страница закончила грузиться.
Правда, здесь есть много нюансов при загрузке страниц с графикой и фреймами - для каждого загружаемого элемента будут генерироваться новые события начала/окончания загрузки, а кроме того, если отключить загрузку рисунков/анимации/видео, так вообще некоторые из них не будут происходить! Так что пользоваться ими нужно осторожно.
OnBeforeNavigate2 - происходит когда вы переходите по щелчку на гиперссылке из основной страницы, загруженной в браузер. Сюда можно писать код, который например, анализирует - куда пользователь переходит, и соответственно, что-то делать. Или запретить открывание новых окно, или открывать свои окна (типа сделать TtabbedNotebook c IE на каждой странице).
OnNewWindow2 - происходит, когда открывается новое окно браузера.
Я, конечно, много чего упустил - например, работу с интерфейсами, доступ к тегам страницы - но надеюсь, эта статья и пример помогут вам сделать работоспособный браузер для дальнейших эксперементов. Успехов!
http://www.matrix-wb.h1.ru/ - Новое поколение выбирает... MatrixWB. Скачать проект (откомпилировано в Delphi 5): Исходники + Exe-файл DemoWB.zip (190 K) Только исходники DemoWB_pas.zip (3 K)Создание WebSnap-сервера.
| Два сисадмина: - Мне вчера чувак сервер сломал - Он, что хакер? - Нет, он м#дак! |
WebSnap представляет собой набор компонент, появившийся в Delphi 6 Enterprise и предназначенный для разработки Web-серверных приложений в RAD-среде. В настоящей статье дано краткое описание создания WebSnap-сервера, поддерживающего полный интерфейс редактирования и просмотра для простого набора данных, и включающий поддержку графических полей. Хотя данный WebSnap-сервер является "простым", т.к. не требует написания кода, он, тем не менее, поддерживает полный набор функциональных возможностей для модификации таблиц базы данных с помощью браузера.
Итак, начнем
Сначала следует вызвать новую панель инструментов WebSnap, с помощью которой будет значительно удобнее создавать WebSnap-приложение. Это можно сделать, щелкнув правой кнопкой мыши по панелям инструментов в интегрированной среде разработки (IDE) Delphi 6 Enterprise и выбрав панель инструментов "Internet". После этого, на экране отобразится следующее:
Первый значок (изображение руки, держащей глобус) используется для создания нового WebSnap-приложения. Если щелкнуть по нему мышью, то на экране отобразится мастер WebSnap. Теперь зададим имя для нашей главной страницы. Кроме того, следует создать приложение Web App Debugger (Отладчик Web-приложений), которое позволит использовать специальный Web-сервер (написанный в Delphi), поставляемый вместе с Delphi 6 Pro и Enterprise. Назовем данный сервер BasicDemo.
После нажатия кнопки OK на экране отобразится стандартная форма Delphi (позволяющая узнать, запущен ли Web-сервер), а также WebModule, включающий компоненты, которые будут использоваться главной страницей. Компоненты, входящие в данный Web-модуль, используются для обработки запросов главной страницы и диспетчеризации действий, запрашиваемых браузером клиента, когда пользователь щелкает мышью по определенным ссылкам или кнопкам.
Создание модуля данных
Теперь создадим модуль данных WebSnap, который можно использовать для публикации информации из набора данных (или нескольких наборов данных, как в нашем случае). WebDataModule можно создать, щелкнув по третьей кнопке (набор данных на фоне глобуса) на панели инструментов WebSnap. После этого поместим компонент TClientDataSet из закладки Data Access в палитре компонентов, и свяжем его с MyBase XML DataSet-версией хорошо известной надежной таблицы Paradox Biolife.db, которая содержит графическое поле и поле комментария, а также числовые и текстовые поля, которые можно публиковать и редактировать с использованием WebSnap.
Поддержка stateless-серверов
После задания имени файла ClientDataSet следует перейти к древовидному представлению (Object Treeview) объектов, раскрыть ClientDataset, щелкнуть мышью по Fields, а затем, щелкнув правой кнопкой мыши, добавить все поля в древовидную структуру. Так как WebSnap используется для построения stateless-серверов, работающих с базами данных, мы должны указать первичный ключ, позволяющий набору данных активизировать навигацию по запросу клиента и манипуляцию данными. WebSnap проделает все это автоматически после того, как мы зададим первичный ключ. В данном случае, используем в качестве первичного ключа Species No. Сначала следует выбрать его в Object Treeview:
Затем необходимо модифицировать свойство ProviderFlags в Object Inspector (инспектор объектов), установив pfInKey на True, чтобы указать, что Species No является первичным ключом для данного набора данных.
Если у Вас нет этого набора данных, можете проделать те же операции с Paradox-таблицей, используя BDE. Единственное отличие заключается в том, что Вам придется явно разместить компонент сессии BDE, установить его свойство AutoSessionName на True, а для указания на таблицу DBDEMOS biolife.db использовать компонент TTable. Все остальные действия должны быть выполнены без изменения.
Отображение данных в браузере
После установки первичного ключа для набора данных, мы можем выбрать DataSetAdapter из представленной на следующем рисунке палитры компонентов WebSnap:
И установить DataSetAdapter на DataModule. DataModule должен принять вид, подобный представленному на рисунке:
Затем, используя Object Inspector, следует присоединить адаптер к набору данных. На приведенном ниже рисунке показан Object Inspector, поддерживающий in-line-расширение ссылок на компоненты. Обратите внимание на то, что свойства набора данных выделены разным цветом и представлены с отступом от левого края в Object Inspector.
Следующий шаг не является обязательным; я включил его просто для большей ясности. Вернемся к Object Treeview, раскроем свойства адаптера и добавим все адаптеры команд и адаптеры полей в набор данных. Обратите внимание на поддержку всех стандартных операций с набором данных (навигация и модификация набора данных). Адаптеры полей обеспечат автоматическую поддержку как отображения, так и редактирования данных в любом наборе данных, включая BLOB-поля, содержащие текст или графику.
Создание WEB-приложений в среде Delphi.
| Приз эксгибиционисту от баннерообменной сети: 100000 показов! |
Эпоха 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. Вы получите знакомый со школьной скамьи, текст обычной паскалевской программы:
program primer;
{$APPTYPE CONSOLE}
uses SysUtils;
begin
// Insert user code here
end.
|
Далее, еще проще. Организуем вывод кода HTML с помощью команды writeln.
writeln ('CONTENT-TYPE: TEXT/HTML');
writeln;
writeln ('<html>');
writeln ('<head>');
writeln ('<meta HTTP-EQUIV="Content-Type" Content="text-html; charset=windows-1251">');
writeln ('<title>Delphi the best facility for making web-publications!</title>');
writeln ('</head>');
writeln ('<body bgcolor="white">');
writeln ('Hello, world!');
writeln ('</body>');
writeln ('</html>');
|
Обратите внимание на строку CONTENT-TYPE: TEXT/HTML, которая определяет описание последующего содержимого, а именно кода HTML. После CONTENT-TYPE: TEXT/HTML, необходимо вывести пустую строку иначе броузер может выдать сообщение об ошибке.
Теперь, когда приложение закончено, осталось его скомпилировать и проверить. Для проверки работоспособности программы вам понадобиться веб-сервер. Можно особо не утруждаться, подойдет любой, даже стандартный домашний веб-сервер от Microsoft. Приложение надо будет разместить в папке публикаций сервера (обычно это - C:\Inetpub\ wwwroot) и запустить сам сервер. Теперь, если вы перейдете по адресу http://localhost/primer.exe в броузере, вы должны увидеть результат действия данной программы - строку Hello, world! Вот и всё, простейшее web-приложение на Delphi готово.
Передача параметров
На самом деле нам бы вряд ли понадобилось Delphi, для создания подобных программ. Конечно, можно генерировать страницы исходя из различных условий, но вопрос в том, как данные условия передать программе. И здесь оказывается не всё так сложно, достаточно вспомнить передачу параметров приложению с помощью командной строки и поступить соответствующе. Хотя это разумеется хитрость. Это для приложения Delphi, мы оперируем командной строкой, для пользователя же это адресная строка в броузере, то есть url.
Попробуем на примере. Необходимо создать приложение, которое выдает различную информацию (к примеру, время, дату или то и другое вместе) в зависимости от параметров указанных в адресной строке броузера. Как известно, за данные в параметрах отвечают такие функции как ParamCount и ParamStr. Их то мы и будем использовать.
program CgiDate;
{$APPTYPE CONSOLE}
uses SysUtils;
begin
writeln ('CONTENT-TYPE: TEXT/HTML');
writeln;
writeln ('<HTML><HEAD>');
writeln ('<TITLE>Cgidate</TITLE>');
writeln ('</HEAD><BODY>>');
writeln ('<H1>Пример передачи параметров</Н1>');
writeln ('<HR>');
writeln ('<H4>
if ParamCount >0 then
begin
if ParamStr (1) = 'date' then
writeln (FormatDateTime('"Сегодня " dddd, mmmm d, yyyy', Now))
else
if ParamStr (1) = 'time' then
writeln (FormatDateTime('"Время" hh:mm:ss AM/PM', Now))
else
if ParamStr (1) = 'both' then
writeln (FormatDateTime('"Сегодня " dddd, mmmm d, yyyy,'
+ '"<p> и время" hh:mm:ss AM/PM', Now))
else
writeln ('Ошибка! Неверный параметр: ' + ParamStr (1) + '.')
end
else
writeln ('Параметр отсутствует.');
writeln ('</BODY></HTML>');
end.
|
Не правда ли просто? Теперь, если в адресной строке броузера вы наберете, например http://localhost/cgidate/exe?time, будет сгенерирована страница отображающая текущее время, http://localhost/cgidate/exe?date - соответственно дата, а при передачи параметра both - текущая дата и время. В случае если никакой из параметров передан не был или он был ошибочен - возникнет сообщение об этом.
Данные адреса и параметры можно непосредственно указать в коде HTML и генерировать необходимые изменения на странице либо другие страницы переходя по соответствующим ссылкам.
Следует обратить внимание на то, как передавать данные через url. Знак вопроса отделяет параметр от адреса файла, с помощью знака равенства web-приложению передается значение данного параметра. Так как в адресной строке нельзя использовать пробел, он заменяется на шестнадцатеричный код в таблице ASCII, то есть %20.
Но на самом деле, если некие данные передаться от пользователя web-приложению, то обычно для этого используют формы, а не url (хотя одно другому не мешает). Попробуем и мы создать приложение, которое бы получала данные от пользователя, занесенные им в форму.
Для начала естественно нужно создать сам код HTML в котором бы присутствовала форма с полями ввода, кнопкой отправки и прочими необходимыми атрибутами. При этом form action должен содержать адрес программы, которая будет получать данные. Значение method может быть равно как GET, так и POST. На самом деле GET - это и есть передача параметров через url, добавляя их к адресной строке, так как POST передает их приложению посредством стандартного потока ввода. Какой из них лучше и удобней решать вам, но чаще всего метод GET использует именно для генерации страниц (достаточно взглянуть на url который возникает при работе на поисковых серверах), так как второй для передачи данных, отображать которые в адресной строке было бы весьма накладно.
Затем необходимо создать приложение, которое бы адекватно смогло воспринять все эти данные со стороны пользователя. В случае если данные передавались с помощью метода GET проблем не будет - можно действовать как в предыдущем примере. Если же приложение получает данные от пользователя с помощью POST, всё несколько иначе.
Необходимо будет считывать данные из переменной окружения, а для этого мы естественно должны знать данные переменные.
Гюльчитай, открой личико
Нет в мире тайн. Особенно их мало у пользователя от web-приложения. И если мы не знаем о пользователе кое-что личное, все прочее, броузеры с легкостью отдают web-серверу, нисколько не заботясь о приватности и желаниях того самого пользователя. Это конечно не хорошо для пользователя, но хорошо для разработчика web-приложения, поскольку для него знания - великая вещь.
Итак, данные от пользователя web-приложению, можно передать через переменные окружения. Вот список наиболее часто употребляемых:
GATEWAY_INTERFACE Поддерживаемая версия CGI. REQUEST_METHOD Метод запроса, может быть как GET так и POST. HTTP_REFERER Адрес страницы (url), активирующей текущее приложение на web-сервере. PATH_INFO Путь переданный приложению расположенный между именем приложения и строкой запроса. QUERY_STRING Строка запроса, если метод - GET, добавляеться к url. REMOTE_HOST Имя хоста удаленного пользователя. REMOTE_USER Имя удаленного пользователя. REMOTE_IDENT IP-адрес удаленного пользователя. HTTP_USER_AGENT Имя и версия броузера удаленного пользователя.С помощью данных переменных можно получить исчерпывающею информацию о пользователе и передаваемых данных для верного проектирования вашего web-приложения. Конечно, этого хватит в том случае, если вы не собираетесь подобно Большому Брату следить за каждым телодвижением пользователя.
Но вернемся к поставленной задаче - передаче данных приложению от пользователя через форму. Данные, которые передаться через QUERY_STRING в приложение с помощью метода POST достаточно просто извлечь для использования.
Ниже листинг программы, выдающий список некоторых переменных окружения и их значения. Узнайте кое-что о своем броузере и web-сервере.
program CgiVars;
{$APPTYPE CONSOLE}
uses Windows;
соnst
VarList: array [1..17] of string [30] =
('SERVER_NAME', 'SERVER_PROTOCOL',
'SERVER_PORT', 'SERVER_SOFTWARE',
'GATEWAY_INTERFACE', 'REQUEST_METHOD',
'PATH_TRANSLATED', 'HTTP_REFERER',
'SCRIPT_NAME', 'PATH_INFO',
'QUERY_STRING', 'HTTP_ACCEPT',
'REMOTE_HOST', 'REMOTE_USER',
'REMOTE_ADDR', 'REMOTE_IDENT',
'HTTP_USER_AGENT');
var
I: Integer;
ReqVar: string;
VarValue: array [0..200] of Char;
begin
writeln('Content type: text/html');
writeln;
writeln('<HTML><HEAD>');
writeln('<TITLE>CGI Variables</TITLE>');
writeln('</HEAD><BODY>');
writeln('<H1>CGI Variables</H1>');
writeln('<HR><PRE>');
for I := Low (VarList) to High (VarList) do
begin
ReqVar := VarList[I];
if (GetEnvironmentVariable (PChar(ReqVar),
VarValue, 200) > 0) then
else
VarValue := '';
writeln (VarList[I] + ' = ' + VarValue);
end;
writeln('</PRE></BODY></HTML>');
end.
|
За кадром
В этой статье мы не коснулись другой и уж наверняка более обширной и сложной темы, как создание ISAPI-приложений на Delphi. Вышеприведенные способы создания приложений годны лишь в том случае, если вам необходимо быстрое, компактное и не слишком сложное web-приложение. Если же вам необходим, к примеру, доступ к базам данным, то подобный путь неприемлем.
Для создания полномасштабных приложений для интернета, в Delphi существует специальный помощник - Web Server Application. С его помощью можно создать.
Приложение генерируемое динамические web-страницы, основанные на CGI, NSAPI или ISAPI. Единственное накладываемое ограничение - непосредственно web-сервер должен работать на базе Windows.
Одним из главных преимуществ создания подобных приложений именно в среде Delphi является то, что вы продолжаете работать с визуальными компонентами - это значительно проще, чем создание приложений в других средах - возможность ошибки в больших проектах, где используется визуальное проектирование меньше, чем в тех, где всё описывается исключительно кодом. Кроме того средства создания web-приложений позволяют импортировать уже существующие приложения в интернет-среду, что согласитесь немаловажно. Пока, конечно, Delphi не обладает большим набором компонентов для web-приложений, но видимо уже следующая версия этой среды обзаведется необходимыми. Но и сейчас Delphi можно считать достаточно удобным инструментом для создания приложений взаимодействующих с интернетом.
Создание WEB-сервера.
| Женщины как веб-сервера: 400 Bad Request - свидание без букета 401 Unauthorized - замужем 402 Payment Required - ужин при свечах 403 Forbidden - руки прочь! 404 Not Found - сегодня я гуляю с подругами 405 Method Not Allowed - Не-е, не с зади... 406 Method Not Acceptable - ...только не сосать! 407 Proxy Auth. Required - надо спросить маму 408 Request Timeout - знаешь колько ты уже не звонил? 409 Conflict - что это там была, за блондинка вчера? 410 Document Removed - хочу развода 411 Lenght Required - что? это ты называешь длинным? 412 Precondition Failed - что? у тебя нет презерватива? 413 Request Entity Too Large - Такой не влезит! 415 Unsupported Media Type - нее, вчетвером не интерестно. 500 Internal Server Error - месячные 501 Not Implemented - ещё никогда не пробовала 502 Bad Gateway - ...фу, солёно! 503 Service Unavailable - голова болит 504 Gateway Timeout - это уже всё? |
В последнее время возможность управления приложением при помощи WEB интерфейса становится все более популярной. Лично я применил возможность удаленного управления в ряде своих программ, и это существенно упростило их сопровождение в условиях большой организации. Delphi содержит достаточно мощные компоненты, позволяющие легко организовывать соединения по протоколу TCP/IP. Это компоненты TServerSocket и TClientSocket. Для организации WEB сервера нам потребуется только TServerSocket. Для доступа к нашему серверу применим порт с номером 5000 (напоминаю, что порты с номерами меньше 1024 могут использоваться только по назначению и есть опасность, что на Вашей машине будет установлено некоторое приложение, использующее стандартный порт HTTP 80). При этом URL будет выглядеть как machine:5000/path при доступе из сети или 127.0.0.1:5000/path при доступе с локального хоста. Следует сразу поговорить о двух тонкостях, не имеющих прямого отношения к написанию WEB сервера.
Два приложения на одном компьютере не могут одновременно использовать один и тот-же порт. Поэтому следует выносить номер порта в настройки программы и (или) предусматривать механизм автоматического выбора одного из альтернативных портов на случай, если основной уже занят. Следствием из несоблюдения пункта 1 является невозможность запуска двух копий одной программы без принятия соответствующих мер Программа может быть запущена на компьютере, не настроенном на работу с сетью. Попытка использования компонента TServerSocket в этом случае приведет к ошибкам, которые могут помешать нормальному запуску программы.Решением всех этих проблем может послужить следующий совет: никогда не ставьте свойство Active:= true; во время дизайна !! Активируйте компонент TServerSocket при старте программы в конструкции try ... except; Итак, мы поговорили об общих вопросах. Теперь следует поговорить о протоколе HTTP.
Протокол HTTP - краткая справочная информация. Обмен по протоколу HTTP производится в т.н. транзакциях, которые состоят из трех шагов.
Установка соединения. Производится по инициативе клиента и для этого необходимо знать порт, по которому работает сервер. Запрос клиента. Клиент передает серверу HTTP запрос (содержащий HTTP метод, идентификатор ресурса и версию протокола) + дополнительную информацию. Пример типового запроса "GET /book/index.htm HTTP/1.0". Запрос как правило завершается пустой строкой и обязательным CRLF. Вот полный пример запроса IE5 (перехваченный кстати при помощи примера 2):
GET /btn7.gif HTTP/1.1 Accept: */* Referer: http://127.0.0.1:5000/ Accept-Language: ru Accept-Encoding: gzip, deflate User-Agent: Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt) Host: 127.0.0.1:5000 Connection: Keep-Alive |
Классы кодов ответа HTTP. Как говорилось ранее, код ответа представляет собой трехзначное число. Коды сгруппированы в пять категорий, категория определяется первой цифрой.
1** Информационная. На данный момент зарезервирована 2** Успешно. Сообщает об успешном выполнении запроса 3** Перенаправление. Указывает клиенту, что для выполнения запроса необходимы дополнительные действия 4** Ошибка клиента. Сообщает клиенту о том, что запрос неполный или содержит синтаксические ошибки. Кроме того, ошибки этой категории возникают, если запрошенный ресурс не найден или недоступен 5** Ошибка сервера. Возникает, если сервер перегружен, недоступен или в работе сервера возникли какие либо ошибкиНаибольший интерес представляют собой следующие коды (они наиболее распространены).
200 ОК 201 Успешная команда POST 202 Запрос принят 203 Запрос GET либо HEAD выполнен 204 Запрос выполнен, но нет содержимого 300 Ресурс обнаружен в нескольких местах 301 Ресурс удален навсегда 302 Ресурс временно удален 304 Ресурс изменен 400 Плохой запрос от клиента 401 Неавторизованный запрос 402 Необходима оплата за запрос 403 Доступ к ресурсу запрещен 404 Ресурс не найден 405 Метод неприменим для данного ресурса 406 Недопустимый тип ресурса 410 Ресурс недоступен 500 Внутренняя ошибка сервера 501 Метод не выполнен 502 Перегрузка сервера или неисправный шлюз 503 Сервер недоступен или таймаут шлюзаМетоды протокола HTTP
Данная статья не преследует цель описать подробность протокола HTTP, но для понимания принципов работы примера рассмотрим несколько основных методов:
Метод GET
Метод GET является самым часто используемым и предназначен для получения информации от сервера. В качестве информации может выступать файл или результаты работы какого либо процесса, например CGI. Метод GET может дополняться условием при помощи параметра If-Modified-Since в запросе - в том случае результат передается только если ресурс имеет дату модификации, большую указанной в If-Modified-Since. Кроме запроса метод GET может применяться для передаче небольших объемов данных в виде параметров.
Метод HEAD
Метод HEAD полностью аналогичен методу GET, но в ответ сервер передает только заголовок (но не передает данные).
Метод POST
Метод POST применяется для передачи серверу данных.
Метод PUT
Метод PUT предназначен для сохранения данных, переданных после заголовка запроса, под именем, указанным в запросе.
Метод DELETE
Метод DELETE используется для удаления ресурсов с указанным в запросе именем.
Итак, мы поговорили о теории (причем это не теория, а краткий ликбез). Найти более подробное описание достаточно легко, есть масса сайтов, специализирующихся на подобной документации. Однако лучше всего почитать стандарты RFC (в частности, документ RFC2068).
Я не хочу приводить здесь сами исходные тексты - страничка получится очень большой, поэтому остальная часть стальи в виде двух хорошо продокументированных проекта лежит в архивах:
Пример 1. Простейший Web сервер - база для управления программой через WEB. В примере номер 1 мы рассмотрим создание простейший WEB сервер. В ответ на любой запрос он выдает одну и туже страничку с информацией о клиенте и формой, демонстрирующей передачу запросов серверу по методу GET. Данный пример может служить прототипом для систем удаленного управления/администрирования с WEB интерфейсом.
Пример 2. Обычный Web сервер - база для разработки своих серверов. В этом примере рассмотрен полнофункциональный сервер. У него определяется директорий, в котором будут храниться файлы и он может возвращать их по запросам клиентской программы. Я ради эксперимента разместил на нем свой сайт по Delphi (с которого Вы сейчас читаете эту статью), и он прекрасно открылся при помощи IE. Единственный огрех - периодически вылетала ошибка socket error 10054, связанная с тем, что IE брал странички из кеша и рвал соединение в процессе их передачи.
Создать из Delphi документ Word, работа с текстом.
| Ищу поклонников Microsoft. Найду - убью. |
Для создания документа Microsoft Word из Delphi нужно создать переменную, ассоциированную с Word. Если Word еще не открыт, его нужно открыть. После этого с ним можно работать примерно как в Бейсике, для изучения которого я в Word-е создаю макросы и изучаю их код.
uses ComObj;
procedure TForm1.Button1Click(Sender: TObject);
var
MSWord: Variant;
begin
try
MsWord := GetActiveOleObject('Word.Application');
except
try
MsWord := CreateOleObject('Word.Application');
MsWord.Visible := True;
except
Exception.Create('Error');
end;
end;
MSWord.Documents.Add;
MSWord.Selection.Font.Size := 12;
MSWord.Selection.TypeText('Текст');
MSWord.Selection.Font.Bold := true;
MSWord.Selection.TypeText(#13#10'new');
MSWord.ActiveDocument.SaveAs('C:\ex.doc');
end;
|
Например:
var range1, range2, range3, a, b : OleVariant;
...
range1:=WordDocument1.Range;
a:=5;
b:=15;
range2:=WordDocument1.Range(a,b);
range3:=WordDocument1.Range(a);
|
Первый наш объект включает в себя весь текст документа, у второго мы ограничили пределы 5-м и 15-м символами, третий представляет из себя весь последующий текст документа, начиная с 5-го символа. Объект имеет несколько полезных методов, например, с его помощью можем добавить текст в документ:
range2.InsertAfter('MS Word');
|
Это мы вставили текст после выделенного Range. Точно также можем вставить текст и перед ним, для этого служит метод InsertBefore(). Текст, заключенный в объекте Range, можем получить так:
WordDocument1.Range(a,b).Text; |
Кроме того, с помощью Range можем изменить шрифт в пределах объекта. Пример:
a:=5; b:=15; WordDocument1.Range(a,b).Font.Bold:=1; WordDocument1.Range(a,b).Font.Size:=14; WordDocument1.Range(a,b).Font.Color:=clRed; |
Если хотим отменить выделение жирным шрифтом, присваиваем 0. Аналогично можно сделать шрифт курсивом, подчеркнутым - наберите WordDocument1.Range.Font., и среда сама подскажет, какие могут быть варианты. Методы Select, Cut, Copy и Paste работают как в обычном тексте. С помощью Paste можем на место выбранного Range вставить не только строки, но и рисунок, находящийся в буфере обмена.
WordDocument1.Range(a,b).Select; WordDocument1.Range(a,b).Cut; WordDocument1.Range(a,b).Copy; WordDocument1.Range(a,b).Paste; |
С помощью Range можем найти в документе нужную строку. Пусть в тексте содержится слово " picture" . Например, нам на его место надо будет вставить рисунок.
var a, b, vstart, vend: OleVariant; j, ilengy: Integer; ... ilengy:=Length(WordDocument1.Range.Text); for j:=0 to ilengy-8 do begin a:=j; b:=j+7; if WordDocument1.Range(a,b).Text='picture' then begin vstart:=j; vend:=j+7; end; end; WordDocument1.Range(vstart,vend).Select; |
Теперь про Selection, представляющий из себя выделенный фрагмент документа. Если выделения нет, это текущая позиция курсора в документе. С его помощью можем вставить что-либо на место выделенного фрагмента, сделать выравнивание, изменить шрифт. Он также имеет методы InsertAfter() и InsertBefore():
WordApplication1.Selection.InsertAfter(" text1" );
WordApplication1.Selection.InsertBefore(" text2" );
|
Форматирование выделенного текста происходит аналогично Range, например:
WordApplication1.Selection.Font.Bold:=1; WordApplication1.Selection.Font.Size:=16; WordApplication1.Selection.Font.Color:=clGreen; |
Для выравнивания проще воспользоваться компонентом WordParagraphFormat. Сначала только нужно " подключить" его к выделенному фрагменту текста:
WordParagraphFormat1.ConnectTo(WordApplication1.Selection.ParagraphFormat); WordParagraphFormat1.Alignment:=wdAlignParagraphCenter; |
Значения его свойства Alignment может принимать значения wdAlignParagraphCenter, wdAlignParagraphLeft, wdAlignParagraphRight, смысл которых очевиден. Имеются и методы Cut, Copy и Paste, которые в пояснениях вряд ли нуждаются:
WordApplication1.Selection.Cut; WordApplication1.Selection.Copy; WordApplication1.Selection.Paste; |
Убираем выделение с помощью метода Collapse. При этом необходимо указать, в какую сторону сместится курсор, будет ли он до ранее выделенного фрагмента или после:
var vcol: OleVariant; ... vcol:=wdCollapseStart; WordApplication1.Selection.Collapse(vcol); |
При этом выделение пропадет, а курсор займет позицию перед фрагментом текста. Если присвоить переменной значение wdCollapseEnd, то курсор переместится назад. Можно просто поставить в скобках " пустышку" :
WordApplication1.Selection.Collapse(EmptyParam); |
Тогда свертывание выделения производится по умолчанию, к началу выделенного текста.
Создание документов Word.
Я обнаружил, что следующий код работает хорошо в связке Delphi -> Word 97 (с использованием поля "Закладки" в Word):
..
implementation
uses OleAuto;
..
var
V: Variant;
..
V := 0; // не забудьте инициализировать переменную
..
..// другие функции
if V = 0 then
begin
V := CreateOLEObject('Word.Application');
V.WordBasic.AppShow;
end;
// данный пример показывает технологию заполнения полей
// некой закладки в "стандартном письме" с помощью запроса,
// выполненного прежде в модуле данных pnm_data (OK,
// надо было бы использовать блок with...!)
V.WordBasic.Fileopen('Имя вашего документа Word');
V.WordBasic.EditBookmark('Заголовок', 0, 0, 0, 1);
V.WordBasic.Insert(Title);
V.WordBasic.EditBookmark('Имя', 0, 0, 0, 1);
V.WordBasic.Insert(FirstName + ' ');
V.WordBasic.EditBookmark('Фамилия', 0, 0, 0, 1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Fam_Name.AsString + ' ');
V.WordBasic.EditBookmark('Адрес1', 0, 0, 0, 1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Address1.AsString + ' ');
V.WordBasic.EditBookmark('Адрес2', 0, 0, 0, 1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Address2.AsString + ' ');
V.WordBasic.EditBookmark('АдресЗ', 0, 0, 0, 1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Address3.AsString + ' ');
V.WordBasic.EditBookmark('Заголовок1', 0, 0, 0, 1);
V.WordBasic.Insert(Title);
V.WordBasic.EditBookmark('Фамилия1', 0, 0, 0, 1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Fam_Name.AsString + ' ');
{Вы могли бы также использовать команду V.WordBasic.PrintDefault,
если вы хотите напечатать ваш документ... и множество других команд,
типа сохранения, смены шрифта и т.д.}
//....другое
|
Создание компонента.
Разработка собственных компонентов
Если вас не устраивают стандартные компоненты, поставляемые вместе с Delphi, значит, вам пора попробовать себя в создtании своих собственных. Сначала мы начнем с простых и постепенно перейдем к более сложным. И так, начнем.
Перед созданием своего компонента важно правильно выбрать для него предка. Кто же может быть предком для вашего компонента? Как правило, используются в виде предков TComponent, TControl, TWinControl, TGraphicControl, TCustomXXXXXX, а также все компоненты палитры компонентов. Возьмем для примера компонент TOpenDialog, который находится на странице Dialogs палитры компонентов. Он хорошо справляется со своей задачей, но у него есть одно маленькое неудобство. Каждый раз, когда его используешь необходимо каждый раз изменять значение свойства Options. И причем это, как правило, одни и те же действия.
OpenDialog1.Options := OpenDialog1.Options + [ofFileMustExist, ofPathMustExist]; |
Чтобы файл, который мы пытаемся открыть с помощью этого диалогового окна, действительно существовал на диске.
Задание для себя мы уже выбрали, осталось за малым - создать компонент. Заготовку для компонента создаем, выбирая из меню команду Component/New Component... и в диалоговом окне выбираем.
Ancestor type: TOpenDialog Class Name: TOurOpenDialog Palette Page: Our TestНажали Ok и у нас появился шаблон нашего будущего компонента.
Переопределяем конструктор у этого компонента, т.е. в секции public вставляем строку:
constructor Create(AOwner: TComponent); override; |
Нажатие на этой строке Ctrl + Shift + C создает шаблон для этого метода, внутри которого мы вставляем такие строки:
{Вызываем унаследованный конструктор}
inherited Create(AOwner);
{Выполняем необходимые нам действия}
Options := Options + [ofFileMustExist, ofPathMustExist];
|
Установка созданного компонента Component/Install Component...
Install Into New Package Package file name: C:\Program Files\Borland\Delphi4\Lib\OurTest.dpk Package description: Our tested packageВам не нравится, что у нашего компонента иконка такая же как у стандартного? Тогда создадим для него свою собственную. Для этого нам необходимо вызвать Tools/Image Editor. Создаем новый *.dcr файл. Вставляем в него рисунок Resource/New/Bitmap. Устанавливаем размер картинки 24x24 точек. А дальше - ваше творчество... Обратите внимание: цвет точек, совпадающий с цветом точки в левом нижнем углу рисунка, будет считаться ПРОЗРАЧНЫМ!
После того как вы создали свой рисунок, переименуйте его из Bitmap1 в TOurOpenDialog и сохраните файл с именем OurOpenDialog.dcr. Удалите компонент из пакета и установите его снова (только в этом случае добавится и ссылка на *.dcr файл).
Compile, Install и удачи!
Создание многомерного массива.
Автор: Steve Schafer
type
PRow = ^TRow;
TRow = array[0..16379] of Single;
PMat = ^TMat;
TMat = array[0..16379] of PRow;
var
Mat: PMat;
X, Y, Xmax, Ymax: Integer;
begin
Write('Задайте размер массива: ');
ReadLn(Xmax, Ymax);
if (Xmax <= 0) or (Xmax > 16380) or (Ymax <= 0) or (Ymax > 16380) then
begin
WriteLn('Неверный диапазон. Не могу продолжить.');
Exit;
end;
GetMem(Mat, Xmax * SizeOf(PRow));
for X := 0 to Xmax - 1 do
begin
GetMem(Mat[X], Ymax * SizeOf(Single));
for Y := 0 to Ymax - 1 do
Mat^[X]^[Y] := 0.0;
end;
WriteLn('Массив инициализирован и готов к работе.');
WriteLn('Но эта программа закончила свою работу.');
end.
|
Кросс-таблица через pivot-таблицу.
Автор: John Crowley Мне нужна помощь по реализации запроса кросс-таблицы в Delphi. У кого-нибудь имеется соответствующий опыт? Использовать pivot-таблицу должен все тот-же общий механизм (относительно к любой базе данных SQL). Предположим, что у нас есть данные продаж в таблице с полями Store, Product, Month, Sales, и вам необходимо отображать данные по продуктам за каждый месяц. (Примем, что поле 'month' для простоты имеет значения 1..12.) Оригинальные данные примера: Store Product Month Sales
#1 Toys 1 100
#2 Toys 1 68
#1 Toys 2 150
#1 Books 1 75
...
Желаемый отчет должен выглядеть похожим на этот:
Product January February March .....
Toys 168 150
Books 75 .....
Установите pivot-таблицу с именем tblPivot и 12 строками: pvtMonth pvtJan pvtFeb pvtMar pvtApr ....
1 1 0 0 0 ....
2 0 1 0 0
3 0 0 1 0
4 0 0 0 1
.....
Теперь запрос, выполненный в виде:
select Product, January=sum(Sales*pvtJan),
February=sum(Sales*pvtFeb),
March=sum(Sales*pvtMar),
April=sum(Sales*pvtApr),...
where Month = pvtMonth
group by Product
даст вам информацию, опубликованную выше.
Поскольку pivot-таблица имеет только 12 строк, большинство SQL-движков сохранят результат в кэшовой памяти, так что скорость выполнения запроса весьма велика.
CrtSock - модуль для работы с сокетами в Delphi32.
Поддерживает TCP и UDP пакеты. Не использует winsock.pas, поскольку обращается непосредственно к wsock32.dll. Набор функций позволяет разрабатывать как клиентские, так и серверные приложения. Перечень включенных в модуль функций:
// Server side :
// - start a server
// - wait for a client
function StartServer(Port:word):integer;
function WaitClient(Server:integer):integer;
function WaitClientEx(Server:integer; var ip:string):integer;
// Client side :
// - call a server
function CallServer(Server:string;Port:word):integer;
// Both side :
// - Assign CRT Sockets
// - Disconnect server
procedure AssignCrtSock(Socket:integer;
Var Input,Output:TextFile);
procedure Disconnect(Socket:integer);
// BroadCasting (UDP)
function StartBroadCast(Port:word):integer;
function SendBroadCast(Server:integer;
Port:word; s:string):integer;
function SendBroadCastTo(Server:integer;
Port:word;
ip,s:string):integer;
function ReadBroadCast(Server:integer; Port:word):string;
function ReadBroadCastEx(Server:integer;
Port:word;
var ip:string):string;
// BlockRead
function SockAvail(Socket:integer):integer;
function DataAvail(Var F:TextFile):integer;
Function BlockReadsock(Var F:TextFile;
var s:string):boolean;
Function send(socket:integer;
data:pointer;
datalen,
flags:integer):integer; stdcall; far;
Function recv(socket:integer;
data:pchar;
datalen,
flags:integer):integer; stdcall; far;
|
Скачать исходник: crtsock.zip (22k).
Использовать модуль CRT в Delphi.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{$IfDef VER130}
{$Define NEW_STYLES}
{$EndIf}
{$IfDef VER140}
{$Define NEW_STYLES}
{$EndIf}
{..$Define HARD_CRT} {Redirect STD_...}
{..$Define CRT_EVENT} {CTRL-C,...}
{$Define MOUSE_IS_USED} {Handle mouse or not}
{..$Define OneByOne} {Block or byte style write}
unit CRT32;
Interface
{$IfDef Win32}
Const
{ CRT modes of original CRT unit }
BW40 = 0; { 40x25 B/W on Color Adapter }
CO40 = 1; { 40x25 Color on Color Adapter }
BW80 = 2; { 80x25 B/W on Color Adapter }
CO80 = 3; { 80x25 Color on Color Adapter }
Mono = 7; { 80x25 on Monochrome Adapter }
Font8x8 = 256;{ Add-in for ROM font }
{ Mode constants for 3.0 compatibility of original CRT unit }
C40 = CO40;
C80 = CO80;
{ Foreground and background color constants of original CRT unit }
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown 6;
LightGray = 7;
{ Foreground color constants of original CRT unit }
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{ Add-in for blinking of original CRT unit }
Blink = 128;
{ }
{ New constans there are not in original CRT unit }
{ }
MouseLeftButton = 1;
MouseRightButton = 2;
MouseCenterButton = 4;
var
{ Interface variables of original CRT unit }
CheckBreak: Boolean; { Enable Ctrl-Break }
CheckEOF: Boolean; { Enable Ctrl-Z }
DirectVideo: Boolean; { Enable direct video addressing }
CheckSnow: Boolean; { Enable snow filtering }
LastMode: Word; { Current text mode }
TextAttr: Byte; { Current text attribute }
WindMin: Word; { Window upper left coordinates }
WindMax: Word; { Window lower right coordinates }
{ }
{ New variables there are not in original CRT unit }
{ }
MouseInstalled: boolean;
MousePressedButtons: word;
{ Interface functions & procedures of original CRT unit }
procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: char;
procedure TextMode(Mode: Integer);
procedure Window(X1, Y1, X2, Y2: Byte);
procedure GotoXY(X, Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Word);
procedure Sound(Hz: Word);
procedure NoSound;
{ New functions & procedures there are not in original CRT unit }
procedure FillerScreen(FillChar: Char);
procedure FlushInputBuffer;
function GetCursor: Word;
procedure SetCursor(NewCursor: Word);
function MouseKeyPressed: Boolean;
procedure MouseGotoXY(X, Y: Integer);
function MouseWhereY: Integer;
function MouseWhereX: Integer;
procedure MouseShowCursor;
procedure MouseHideCursor;
{ These functions & procedures are for inside use only }
function MouseReset: Boolean;
procedure WriteChrXY(X, Y: Byte; Chr: char);
procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
procedure OverwriteChrXY(X, Y: Byte; Chr: char);
{$EndIf Win32}
implementation
{$IfDef Win32}
uses Windows, SysUtils;
type
POpenText = ^TOpenText;
TOpenText = function(var F: Text; Mode: Word): Integer; far;
var
IsWinNT: boolean;
PtrOpenText: POpenText;
hConsoleInput: THandle;
hConsoleOutput: THandle;
ConsoleScreenRect: TSmallRect;
StartAttr: word;
LastX, LastY: byte;
SoundDuration: integer;
SoundFrequency: integer;
OldCP: integer;
MouseRowWidth, MouseColWidth: word;
MousePosX, MousePosY: smallInt;
MouseButtonPressed: boolean;
MouseEventTime: TDateTime;
{ }
{ This function handles the Write and WriteLn commands }
{ }
function TextOut(var F: Text): Integer; far;
{$IfDef OneByOne}
var
dwSize: DWORD;
{$EndIf}
begin
with TTExtRec(F) do
begin
if BufPos > 0 then
begin
LastX := WhereX;
LastY := WhereY;
{$IfDef OneByOne}
dwSize := 0;
while (dwSize < BufPos) do
begin
WriteChrXY(LastX, LastY, BufPtr[dwSize]);
Inc(dwSize);
end;
{$Else}
WriteStrXY(LastX, LastY, BufPtr, BufPos);
FillChar(BufPtr^, BufPos + 1, #0);
{$EndIf}
BufPos := 0;
end;
end;
Result := 0;
end;
{ }
{ This function handles the exchanging of Input or Output }
{ }
function OpenText(var F: Text; Mode: Word): Integer; far;
var
OpenResult: integer;
begin
OpenResult := 102; { Text not assigned }
if Assigned(PtrOpenText) then
begin
TTextRec(F).OpenFunc := PtrOpenText;
OpenResult := PtrOpenText^(F, Mode);
if OpenResult = 0 then
begin
if Mode = fmInput then
hConsoleInput := TTextRec(F).Handle
else
begin
hConsoleOutput := TTextRec(F).Handle;
TTextRec(Output).InOutFunc := @TextOut;
TTextRec(Output).FlushFunc := @TextOut;
end;
end;
end;
Result := OpenResult;
end;
{ }
{ Fills the current window with special character }
{ }
procedure FillerScreen(FillChar: Char);
var
Coord: TCoord;
dwSize, dwCount: DWORD;
Y: integer;
begin
Coord.X := ConsoleScreenRect.Left;
dwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
for Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do
begin
Coord.Y := Y;
FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount);
end;
GotoXY(1,1);
end;
{ }
{ Write one character at the X,Y position }
{ }
procedure WriteChrXY(X, Y: Byte; Chr: char);
var
Coord: TCoord;
dwSize, dwCount: DWORD;
begin
LastX := X;
LastY := Y;
case Chr of
#13: LastX := 1;
#10:
begin
LastX := 1;
Inc(LastY);
end;
else
begin
Coord.X := LastX - 1 + ConsoleScreenRect.Left;
Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
dwSize := 1;
FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
Inc(LastX);
end;
end;
if (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then
begin
LastX := 1;
Inc(LastY);
end;
if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
begin
Dec(LastY);
GotoXY(1,1);
DelLine;
end;
GotoXY(LastX, LastY);
end;
{ }
{ Write string into the X,Y position }
{ }
(* !!! The WriteConsoleOutput does not write into the last line !!!
Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer );
{$IfDef OneByOne}
Var
dwCount: integer;
{$Else}
Type
PBuffer= ^TBuffer;
TBUffer= packed array [0..16384] of TCharInfo;
Var
I: integer;
dwCount: DWORD;
WidthHeight,Coord: TCoord;
hTempConsoleOutput: THandle;
SecurityAttributes: TSecurityAttributes;
Buffer: PBuffer;
DestinationScreenRect,SourceScreenRect: TSmallRect;
{$EndIf}
Begin
If dwSize>0 Then Begin
{$IfDef OneByOne}
LastX:=X;
LastY:=Y;
dwCount:=0;
While dwCount < dwSize Do Begin
WriteChrXY(LastX,LastY,Str[dwCount]);
Inc(dwCount);
End;
{$Else}
SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD);
SecurityAttributes.lpSecurityDescriptor:=NIL;
SecurityAttributes.bInheritHandle:=TRUE;
hTempConsoleOutput:=CreateConsoleScreenBuffer(
GENERIC_READ OR GENERIC_WRITE,
FILE_SHARE_READ OR FILE_SHARE_WRITE,
@SecurityAttributes,
CONSOLE_TEXTMODE_BUFFER,
NIL
);
If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin
WidthHeight.X:=dwSize;
WidthHeight.Y:=1;
End Else Begin
WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1;
WidthHeight.Y:=dwSize DIV WidthHeight.X;
If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y);
End;
SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight);
DestinationScreenRect.Left:=0;
DestinationScreenRect.Top:=0;
DestinationScreenRect.Right:=WidthHeight.X-1;
DestinationScreenRect.Bottom:=WidthHeight.Y-1;
SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect);
Coord.X:=0;
For I:=1 To WidthHeight.Y Do Begin
Coord.Y:=I-0;
FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount);
FillConsoleOutputCharacter(hTempConsoleOutput,' ' ,WidthHeight.X,Coord,dwCount);
End;
WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL);
{ }
New(Buffer);
Coord.X:= 0;
Coord.Y:= 0;
SourceScreenRect.Left:=0;
SourceScreenRect.Top:=0;
SourceScreenRect.Right:=WidthHeight.X-1;
SourceScreenRect.Bottom:=WidthHeight.Y-1;
ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect);
Coord.X:=X-1;
Coord.Y:=Y-1;
DestinationScreenRect:=ConsoleScreenRect;
WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect);
GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1);
Dispose(Buffer);
{ }
CloseHandle(hTempConsoleOutput);
{$EndIf}
End;
End;
*)
procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
{$IfDef OneByOne}
var
dwCount: integer;
{$Else}
var
I: integer;
LineSize, dwCharCount, dwCount, dwWait: DWORD;
WidthHeight: TCoord;
OneLine: packed array [0..131] of char;
Line, TempStr: PChar;
procedure NewLine;
begin
LastX := 1;
Inc(LastY);
if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
begin
Dec(LastY);
GotoXY(1,1);
DelLine;
end;
GotoXY(LastX, LastY);
end;
{$EndIf}
begin
if dwSize > 0 then
begin
{$IfDef OneByOne}
LastX := X;
LastY := Y;
dwCount := 0;
while dwCount < dwSize do
begin
WriteChrXY(LastX, LastY, Str[dwCount]);
Inc(dwCount);
end;
{$Else}
LastX := X;
LastY := Y;
GotoXY(LastX, LastY);
dwWait := dwSize;
TempStr := Str;
while (dwWait > 0) and (Pos(#13#10,StrPas(TempStr))= 1) do
begin
Dec(dwWait, 2);
Inc(TempStr, 2);
NewLine;
end;
while (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do
begin
Dec(dwWait);
Inc(TempStr);
NewLine;
end;
if dwWait > 0 then
begin
if dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then
begin
WidthHeight.X := dwSize + LastX - 1;
WidthHeight.Y := 1;
end
else
begin
WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
WidthHeight.Y := dwSize div WidthHeight.X;
if (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y);
end;
for I := 1 to WidthHeight.Y do
begin
FillChar(OneLine, SizeOf(OneLine), #0);
Line := @OneLine;
LineSize := WidthHeight.X - LastX + 1;
if LineSize > dwWait then LineSize := dwWait;
Dec(dwWait, LineSize);
StrLCopy(Line, TempStr, LineSize);
Inc(TempStr, LineSize);
dwCharCount := Pos(#13#10,StrPas(Line));
if dwCharCount > 0 then
begin
OneLine[dwCharCount - 1] := #0;
OneLine[dwCharCount] := #0;
WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
Inc(Line, dwCharCount + 1);
NewLine;
LineSize := LineSize - (dwCharCount + 1);
end
else
begin
dwCharCount := Pos(#10, StrPas(Line));
if dwCharCount > 0 then
begin
OneLine[dwCharCount - 1] := #0;
WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
Inc(Line, dwCharCount);
NewLine;
LineSize := LineSize - dwCharCount;
end;
end;
if LineSize <> 0 then
begin
WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil);
end;
if dwWait > 0 then
begin
NewLine;
end;
end;
end;
{$EndIf}
end;
end;
{ }
{ Empty the buffer }
{ }
procedure FlushInputBuffer;
begin
FlushConsoleInputBuffer(hConsoleInput);
end;
{ }
{ Get size of current cursor }
{ }
function GetCursor: Word;
var
CCI: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(hConsoleOutput, CCI);
GetCursor := CCI.dwSize;
end;
{ }
{ Set size of current cursor }
{ }
procedure SetCursor(NewCursor: Word);
var
CCI: TConsoleCursorInfo;
begin
if NewCursor = $0000 then
begin
CCI.dwSize := GetCursor;
CCI.bVisible := False;
end
else
begin
CCI.dwSize := NewCursor;
CCI.bVisible := True;
end;
SetConsoleCursorInfo(hConsoleOutput, CCI);
end;
{ }
{ --- Begin of Interface functions & procedures of original CRT unit --- }
procedure AssignCrt(var F: Text);
begin
Assign(F, '');
TTextRec(F).OpenFunc := @OpenText;
end;
function KeyPressed: Boolean;
var
NumberOfEvents: DWORD;
NumRead: DWORD;
InputRec: TInputRecord;
Pressed: boolean;
begin
Pressed := False;
GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);
if NumberOfEvents > 0 then
begin
if PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then
begin
if (InputRec.EventType = KEY_EVENT) and
(InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then
begin
Pressed := True;
{$IfDef MOUSE_IS_USED}
MouseButtonPressed := False;
{$EndIf}
end
else
begin
{$IfDef MOUSE_IS_USED}
if (InputRec.EventType = _MOUSE_EVENT) then
begin
with InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do
begin
MousePosX := dwMousePosition.X;
MousePosY := dwMousePosition.Y;
if dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then
begin
MouseEventTime := Now;
MouseButtonPressed := True;
{If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}
{End;}
end;
end;
end;
ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
{$Else}
ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
{$EndIf}
end;
end;
end;
Result := Pressed;
end;
function ReadKey: char;
var
NumRead: DWORD;
InputRec: TInputRecord;
begin
repeat
repeat
until KeyPressed;
ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0;
Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar;
end;
procedure TextMode(Mode: Integer);
begin
end;
procedure Window(X1, Y1, X2, Y2: Byte);
begin
ConsoleScreenRect.Left := X1 - 1;
ConsoleScreenRect.Top := Y1 - 1;
ConsoleScreenRect.Right := X2 - 1;
ConsoleScreenRect.Bottom := Y2 - 1;
WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left;
WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right;
{$IfDef WindowFrameToo}
SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect);
{$EndIf}
GotoXY(1,1);
end;
procedure GotoXY(X, Y: Byte);
var
Coord: TCoord;
begin
Coord.X := X - 1 + ConsoleScreenRect.Left;
Coord.Y := Y - 1 + ConsoleScreenRect.Top;
if not SetConsoleCursorPosition(hConsoleOutput, Coord) then
begin
GotoXY(1, 1);
DelLine;
end;
end;
function WhereX: Byte;
var
CBI: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left;
end;
function WhereY: Byte;
var
CBI: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top;
end;
procedure ClrScr;
begin
FillerScreen(' ');
end;
procedure ClrEol;
var
Coord: TCoord;
dwSize, dwCount: DWORD;
begin
Coord.X := WhereX - 1 + ConsoleScreenRect.Left;
Coord.Y := WhereY - 1 + ConsoleScreenRect.Top;
dwSize := ConsoleScreenRect.Right - Coord.X + 1;
FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount);
end;
procedure InsLine;
var
SourceScreenRect: TSmallRect;
Coord: TCoord;
CI: TCharInfo;
dwSize, dwCount: DWORD;
begin
SourceScreenRect := ConsoleScreenRect;
SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top;
SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1;
CI.AsciiChar := ' ';
CI.Attributes := TextAttr;
Coord.X := SourceScreenRect.Left;
Coord.Y := SourceScreenRect.Top + 1;
dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
Dec(Coord.Y);
FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
end;
procedure DelLine;
var
SourceScreenRect: TSmallRect;
Coord: TCoord;
CI: TCharinfo;
dwSize, dwCount: DWORD;
begin
SourceScreenRect := ConsoleScreenRect;
SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top;
CI.AsciiChar := ' ';
CI.Attributes := TextAttr;
Coord.X := SourceScreenRect.Left;
Coord.Y := SourceScreenRect.Top - 1;
dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
end;
procedure TextColor(Color: Byte);
begin
LastMode := TextAttr;
TextAttr := (Color and $0F) or (TextAttr and $F0);
SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;
procedure TextBackground(Color: Byte);
begin
LastMode := TextAttr;
TextAttr := (Color shl 4) or (TextAttr and $0F);
SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;
procedure LowVideo;
begin
LastMode := TextAttr;
TextAttr := TextAttr and $F7;
SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;
procedure HighVideo;
begin
LastMode := TextAttr;
TextAttr := TextAttr or $08;
SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;
procedure NormVideo;
begin
LastMode := TextAttr;
TextAttr := StartAttr;
SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;
procedure Delay(MS: Word);
{
Const
Magic= $80000000;
var
StartMS,CurMS,DeltaMS: DWORD;
}
begin
Windows.SleepEx(MS, False); // Windows.Sleep(MS);
{
StartMS:= GetTickCount;
Repeat
CurMS:= GetTickCount;
If CurMS >= StartMS Then
DeltaMS:= CurMS - StartMS
Else DeltaMS := (CurMS + Magic) - (StartMS - Magic);
Until MS<DeltaMS;
}
end;
procedure Sound(Hz: Word);
begin
{SetSoundIOPermissionMap(LocalIOPermission_ON);}
SoundFrequency := Hz;
if IsWinNT then
begin
Windows.Beep(SoundFrequency, SoundDuration)
end
else
begin
asm
mov BX,Hz
cmp BX,0
jz @2
mov AX,$34DD
mov DX,$0012
cmp DX,BX
jnb @2
div BX
mov BX,AX
{ Sound is On ? }
in Al,$61
test Al,$03
jnz @1
{ Set Sound On }
or Al,03
out $61,Al
{ Timer Command }
mov Al,$B6
out $43,Al
{ Set Frequency }
@1: mov Al,Bl
out $42,Al
mov Al,Bh
out $42,Al
@2:
end;
end;
end;
procedure NoSound;
begin
if IsWinNT then
begin
Windows.Beep(SoundFrequency, 0);
end
else
begin
asm
{ Set Sound On }
in Al,$61
and Al,$FC
out $61,Al
end;
end;
{SetSoundIOPermissionMap(LocalIOPermission_OFF);}
end;
{ --- End of Interface functions & procedures of original CRT unit --- }
{ }
procedure OverwriteChrXY(X, Y: Byte; Chr: char);
var
Coord: TCoord;
dwSize, dwCount: DWORD;
begin
LastX := X;
LastY := Y;
Coord.X := LastX - 1 + ConsoleScreenRect.Left;
Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
dwSize := 1;
FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
GotoXY(LastX, LastY);
end;
{ -------------------------------------------------- }
{ Console Event Handler }
{ }
{$IfDef CRT_EVENT}
function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far;
var
S: {$IfDef Win32}ShortString{$Else}String{$EndIf};
Message: PChar;
begin
case CtrlType of
CTRL_C_EVENT: S := 'CTRL_C_EVENT';
CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
else
S := 'UNKNOWN_EVENT';
end;
S := S + ' detected, but not handled.';
Message := @S;
Inc(Message);
MessageBox(0, Message, 'Win32 Console', MB_OK);
Result := True;
end;
{$EndIf}
function MouseReset: Boolean;
begin
MouseColWidth := 1;
MouseRowWidth := 1;
Result := True;
end;
procedure MouseShowCursor;
const
ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
var
cMode: DWORD;
begin
GetConsoleMode(hConsoleInput, cMode);
if (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then
begin
cMode := cMode or ShowMouseConsoleMode;
SetConsoleMode(hConsoleInput, cMode);
end;
end;
procedure MouseHideCursor;
const
ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
var
cMode: DWORD;
begin
GetConsoleMode(hConsoleInput, cMode);
if (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then
begin
cMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode);
SetConsoleMode(hConsoleInput, cMode);
end;
end;
function MouseKeyPressed: Boolean;
{$IfDef MOUSE_IS_USED}
const
MouseDeltaTime = 200;
var
ActualTime: TDateTime;
HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word;
MSecTimeA, MSecTimeM: longInt;
MSecDelta: longInt;
{$EndIf}
begin
MousePressedButtons := 0;
{$IfDef MOUSE_IS_USED}
Result := False;
if MouseButtonPressed then
begin
ActualTime := NOW;
DecodeTime(ActualTime, HourA, MinA, SecA, MSecA);
DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM);
MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA;
MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM;
MSecDelta := Abs(MSecTimeM - MSecTimeA);
if (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then
begin
MousePressedButtons := MouseLeftButton;
MouseButtonPressed := False;
Result := True;
end;
end;
{$Else}
Result := False;
{$EndIf}
end;
procedure MouseGotoXY(X, Y: Integer);
begin
{$IfDef MOUSE_IS_USED}
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,
X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo());
MousePosY := (Y - 1) * MouseRowWidth;
MousePosX := (X - 1) * MouseColWidth;
{$EndIf}
end;
function MouseWhereY: Integer;
{$IfDef MOUSE_IS_USED}
{Var
lppt, lpptBuf: TMouseMovePoint;}
{$EndIf}
begin
{$IfDef MOUSE_IS_USED}
{GetMouseMovePoints(
SizeOf(TMouseMovePoint), lppt, lpptBuf,
7,GMMP_USE_DRIVER_POINTS
);
Result:=lpptBuf.Y DIV MouseRowWidth;}
Result := (MousePosY div MouseRowWidth) + 1;
{$Else}
Result := -1;
{$EndIf}
end;
function MouseWhereX: Integer;
{$IfDef MOUSE_IS_USED}
{Var
lppt, lpptBuf: TMouseMovePoint;}
{$EndIf}
begin
{$IfDef MOUSE_IS_USED}
{GetMouseMovePoints(
SizeOf(TMouseMovePoint), lppt, lpptBuf,
7,GMMP_USE_DRIVER_POINTS
);
Result:=lpptBuf.X DIV MouseColWidth;}
Result := (MousePosX div MouseColWidth) + 1;
{$Else}
Result := -1;
{$EndIf}
end;
{ }
procedure Init;
const
ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT;
ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT;
var
cMode: DWORD;
Coord: TCoord;
OSVersion: TOSVersionInfo;
CBI: TConsoleScreenBufferInfo;
begin
OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(OSVersion);
if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then
IsWinNT := True
else
IsWinNT := False;
PtrOpenText := TTextRec(Output).OpenFunc;
{$IfDef HARD_CRT}
AllocConsole;
Reset(Input);
hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
TTextRec(Input).Handle := hConsoleInput;
ReWrite(Output);
hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
TTextRec(Output).Handle := hConsoleOutput;
{$Else}
Reset(Input);
hConsoleInput := TTextRec(Input).Handle;
ReWrite(Output);
hConsoleOutput := TTextRec(Output).Handle;
{$EndIf}
GetConsoleMode(hConsoleInput, cMode);
if (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then
begin
cMode := cMode or ExtInpConsoleMode;
SetConsoleMode(hConsoleInput, cMode);
end;
TTextRec(Output).InOutFunc := @TextOut;
TTextRec(Output).FlushFunc := @TextOut;
GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
GetConsoleMode(hConsoleOutput, cMode);
if (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then
begin
cMode := cMode or ExtOutConsoleMode;
SetConsoleMode(hConsoleOutput, cMode);
end;
TextAttr := CBI.wAttributes;
StartAttr := CBI.wAttributes;
LastMode := CBI.wAttributes;
Coord.X := CBI.srWindow.Left;
Coord.Y := CBI.srWindow.Top;
WindMin := (Coord.Y shl 8) or Coord.X;
Coord.X := CBI.srWindow.Right;
Coord.Y := CBI.srWindow.Bottom;
WindMax := (Coord.Y shl 8) or Coord.X;
ConsoleScreenRect := CBI.srWindow;
SoundDuration := -1;
OldCp := GetConsoleOutputCP;
SetConsoleOutputCP(1250);
{$IfDef CRT_EVENT}
SetConsoleCtrlHandler(@ConsoleEventProc, True);
{$EndIf}
{$IfDef MOUSE_IS_USED}
SetCapture(hConsoleInput);
KeyPressed;
{$EndIf}
MouseInstalled := MouseReset;
Window(1,1,80,25);
ClrScr;
end;
{ }
procedure Done;
begin
{$IfDef CRT_EVENT}
SetConsoleCtrlHandler(@ConsoleEventProc, False);
{$EndIf}
SetConsoleOutputCP(OldCP);
TextAttr := StartAttr;
SetConsoleTextAttribute(hConsoleOutput, TextAttr);
ClrScr;
FlushInputBuffer;
{$IfDef HARD_CRT}
TTextRec(Input).Mode := fmClosed;
TTextRec(Output).Mode := fmClosed;
FreeConsole;
{$Else}
Close(Input);
Close(Output);
{$EndIf}
end;
initialization
Init;
finalization
Done;
{$Endif win32}
end.
Как реализовать методы криптографической защиты информации.
Автор: Павел Продолжим рассказ (см. прошлые выпуски рассылки или на сайте www.realcoding.net)о криптографических возможностях Windows. В арсенале защиты должны быть не только методы, обеспечивающие секретность передачи информации (о них мы говорили в первой части статьи). Не менее важными инструментами безопасности являются процедуры, позволяющие убедиться в целости и аутентичности данных. Кроме того, необходимо решать проблемы безопасного хранения и распределения ключей. Проблема распределения ключей В прошлый раз при помощи CryptoAPI мы решали такую "классическую" задачу как шифрование на основе пароля. Напомним, что пароль использовался для создания ключа шифрования какого-либо симметричного алгоритма. В таком случае расшифровать файл может лишь тот, кто знает пароль. А значит, для обеспечения конфиденциальности нужно держать пароль в строжайшем секрете - желательно, чтобы его знали лишь отправитель и получатель информации. (А еще лучше, если отправитель и получатель - одно и то же лицо.) Предположим, что отправитель и получатель при личной встрече договорились использовать для конфиденциальной переписки определенный пароль. Но если они будут шифровать все свои сообщения одним и тем же ключом, то возможный противник, перехватив корреспонденцию, будеть иметь хорошие шансы взломать шифр: при современных методах криптоанализа наличие нескольких шифртекстов, полученных путем использования одного и того же ключа, почти гарантирует успешный результат. Поэтому при использовании симметричных алгоритмов шифрования настоятельно рекомендуется не применять один и тот же ключ дважды! Однако помнить отдельный пароль для каждого зашифрованного сообщения - задача достаточно трудоемкая. А для корреспондентов, не имеющих возможности встретиться лично для согласования ключей шифрования, конфиденциальный обмен сообщениями вообще становится недоступным. Такая практическая трудность называется проблемой распределения ключей. Спасительный способ, позволяющий шифровать сообщения, обмениваясь ключами по открытым каналам связи, был придуман в середине 70-х годов прошлого столетия, а в начале восьмидесятых появился первый реализующий его алгоритм - RSA. Теперь пользователь может сгенерировать два связанных между собой ключа - ключевую пару. Один из этих ключей по несекретным каналам рассылается всем, с кем пользователь хотел бы обмениваться конфиденциальными сообщениями . Этот ключ называют открытым (англ. public key). Зная открытый ключ пользователя, можно зашифровать адресованное ему сообщение, но вот расшифровать его позволяет лишь вторая часть ключевой пары - закрытый ключ (private key). При этом открытый ключ не дает "практической" возможности вычислить закрытый: такая задача, хоть и разрешима в принципе, но при достаточно большом размере ключа требует многих лет машинного времени. Для сохранения конфиденциальности получателю необходимо лишь хранить в строгом секрете свой закрытый ключ, а отправителю - убедиться, что имеющийся у него открытый ключ действительно принадлежит адресату. Так как для шифрования и расшифровки используются различные ключи, алгоритмы такого рода назвали асимметричными. Наиболее существенным их недостатком является низкая производительность - они примерно в 100 раз медленнее симметричных алгоритмов. Поэтому были созданы криптографические схемы, использующие преимущества как симметричных, так и асимметричных алгоритмов для шифрования файла или сообщения используется быстрый симметричный алгоритм, причем ключ шифрования генерируется случайным образом с обеспечением "хороших" статистических свойств; небольшой по размерам симметричный ключ шифрования шифруется при помощи асимметричного алгоритма с использованием открытого ключа адресата и в зашифрованном виде пересылается вместе с сообщением; получив сообщение, адресат своим закрытым ключом расшифровывает симметричный ключ, а с его помощью - и само сообщение. Описанная схема реализована и в CryptoAPI. Целостность и аутентичность информации Как удостовериться в том, что пришедшее сообщение действительно отправлено тем, чье имя стоит в графе "отправитель"? Асимметричные схемы шифрования дают нам элегантный способ аутентификации. Если отправитель зашифрует сообщение своим закрытым ключом, то успешное расшифровывание убедит получателя в том, что послать корреспонденцию мог только хозяин ключевой пары, и никто иной (рис. 3). При этом расшифровку может выполнить любой, кто имеет открытый ключ отправителя. Ведь наша цель - не конфиденциальность, а аутентификация. Чтобы избежать шифрования всего сообщения при помощи асимметричных алгоритмов, используют хеширование: вычисляется хеш-значение исходного сообщения, и только эта короткая последовательность байтов шифруется закрытым ключом отправителя. Результат представляет собой электронную цифровую подпись. Добавление такой подписи к сообщению позволяет установить: аутентичность сообщения - создать подпись на основе закрытого ключа мог только его хозяин; целостность данных - легко вычислить хеш-значение полученного сообщения и сравнить его с тем, которое хранится в подписи: если значения совпадают, значит, сообщение не было изменено злоумышленником после того, как отправитель его подписал. Таким образом, асимметричные алгоритмы позволяют решить две непростые задачи: обмена ключами шифрования по открытым каналам связи и подписи сообщения. Чтобы воспользоваться этими возможностями, нужно сгенерировать и сохранить две ключевые пары - для обмена ключами и для подписей. В этом нам поможет CryptoAPI. Контейнеры ключей Каждый криптопровайдер располагает базой данных, в которой хранятся долговременные ключи пользователей. База данных содержит один или более контейнеров ключей . Пользователь может создать несколько контейнеров с различными именами (именем контейнера по умолчанию является имя пользователя в системе). Подключение к контейнеру производится одновременно с получением контекста криптопровайдера при вызове функции CryptAcquireContext - имя контейнера ключей передается функции вторым ее аргументом. Если второй аргумент содержит пустой указатель (nil), то используется имя по умолчанию, т. е. имя пользователя. В том случае, если доступ к контейнеру не нужен, можно передать в последнем аргументе функции флаг CRYPT_VERIFYCONTEXT; при необходимости создать новый контейнер используется флаг CRYPT_NEWKEYSET; а для удаления существующего контейнера вместе с хранящимися в нем ключами - CRYPT_DELETEKEYSET. Каждый контейнер может содержать, как минимум, две ключевые пары - ключ обмена ключами и ключ подписи. Ключи, используемые для шифрования симметричными алгоритмами, не сохраняются. Как мы уже говорили, такие ключи не рекомендуется применять более одного раза, поэтому их называют сеансовыми (англ. session key). Создание ключевых пар После создания контейнера ключей необходимо сгенерировать ключевые пары обмена ключами и подписи. Эту работу в CryptoAPI выполняет функция CryptGenKey (провайдер, алгоритм, флаги, ключ): провайдер - дескриптор криптопровайдера, полученный в результате обращения к функции CryptAcquireContext; алгоритм - указывает, какому алгоритму шифрования будет соответствовать создаваемый ключ. Информация об алгоритме, таким образом, является частью описания ключа. Каждый криптопровайдер использует для обмена ключами и подписи строго определенные алгоритмы. Так, провайдеры типа PROV_RSA_FULL, к которым относится и Microsoft Base Cryptographic Provider, реализуют алгоритм RSA. Но при генерации ключей знать это не обязательно: достаточно указать, какой ключ мы собираемся создать - обмена ключами или подписи. Для этого используются мнемонические константы AT_KEYEXCHANGE и AT_SIGNATURE; флаги - при создании асимметричных ключей управляет их размером. Используемый нами криптопровайдер позволяет генерировать ключ обмена ключами длиной от 384 до 512 бит**, а ключ подписи - от 512 до 16384 бит. Чем больше длина ключа, тем выше его надежность, поэтому трудно найти причины для использования ключа обмена ключами длиной менее 512 бит, а длину ключа подписи не рекомендуется делать меньше 1024 бит**. По умолчанию криптопровайдер создает оба ключа длиной 512 бит. Необходимую длину ключа можно передать в старшем слове параметра флаги; ключ - в случае успешного завершения функции в этот параметр заносится дескриптор созданного ключа.Рассмотрим пример создания ключевых пар при помощи формы, показанной на рис. 5. В поле "Контейнер" можно указать имя контейнера ключей; если оставить это поле пустым, будет использован контейнер по умолчанию. Назначение остальных элементов управления должно быть интуитивно понятным. После генерации ключа в memo-поле выводится отчет о его параметрах. Для этого используется функция CryptGetKeyParam (ключ, параметр, буфер, размер, флаги). Чтобы получить информацию о требуемом параметре, нужно через второй аргумент функции передать соответствующую константу: KP_ALGID - идентификатор алгоритма, KP_KEYLEN - размер ключа, и т. д. Ниже приведен текст процедуры генерации ключей без операторов обработки ошибок:
procedure TGenerateForm.OKBtnClick(Sender: TObject);
var
cont: PChar;
err: string;
hProv: HCRYPTPROV;
KeyExchKey, SignKey: HCRYPTKEY;
flag, keyLen: DWORD;
begin
{если ни один ключ не выбран - выход}
if not (KEKCheckBox.Checked or SKCheckBox.Checked) then
exit;
{"считываем" имя контейнера}
if length(ContainerEdit.Text) = 0 then
cont := nil
else
begin
err := ContainerEdit.Text;
cont := StrAlloc(length(err) + 1);
StrPCopy(cont, err);
end;
CryptAcquireContext(@hProv, cont, nil, PROV_RSA_FULL, 0);
{генерация ключа обмена ключами (Key Exchange Key)}
if KEKCheckBox.Checked then
begin
{"считываем" длину ключа и помещаем ее в
старшее слово параметра ФЛАГИ}
keyLen := strtoint(KeyExchLenEdit.text);
flag := keyLen shl 16;
if not CryptGenKey(hProv, AT_KEYEXCHANGE, flag, @KeyExchKey) then
begin
?обработка ошибок?
end
else
begin
ReportMemo.Lines.Add('');
ReportMemo.Lines.Add('Создан ключ обмена ключами:');
flag := 4;
if not CryptGetKeyParam(KeyExchKey, KP_KEYLEN, @keyLen, @flag, 0) then
begin
?обработка ошибок?
end
else
ReportMemo.Lines.Add(' длина ключа - ' + inttostr(keyLen));
flag := 4;
if not CryptGetKeyParam(KeyExchKey, KP_ALGID, @keyLen, @flag, 0) then
begin
?обработка ошибок?
end
else
ReportMemo.Lines.Add(' алгоритм - ' + algIDtostr(keyLen));
{функция algIDtostr здесь не приводится. Она состоит из единственного
оператора case, отображающего целый идентификатор алгоритма в строку}
end;
end;
{генерация ключа подписи (Signature Key)}
if SKCheckBox.Checked then
begin
?выполняется аналогично генерации ключа обмена ключами?
end;
CryptReleaseContext(hProv, 0);
end;
Обмен ключами
Теперь мы располагаем набором ключей, однако все они останутся мертвым грузом, до тех пор пока мы не получим возможности обмена с другими пользователями открытыми ключами. Для этого необходимо извлечь их из базы данных ключей и записать в файл, который можно будет передать своим корреспондентам. При экспорте данные ключа сохраняются в одном из трех возможных форматов:
PUBLICKEYBLOB - используется для сохранения открытых ключей. Поскольку открытые ключи не являются секретными, они сохраняются в незашифрованном виде; PRIVATEKEYBLOB - используется для сохранения ключевой пары целиком (открытого и закрытого ключей). Эти данные являются в высшей степени секретными, поэтому сохраняются в зашифрованном виде, причем для шифрования используется сеансовый ключ (и, соответственно, симметричный алгоритм); SIMPLEBLOB - используется для сохранения сеансовых ключей. Для обеспечения секретности данные ключа шифруются с использованием открытого ключа получателя сообщения. Экспорт ключей в CryptoAPI выполняется функцией CryptExportKey (экспортируемый ключ, ключ адресата, формат, флаги, буфер, размер буфера): экспортируемый ключ - дескриптор нужного ключа;Ключ адресата - в случае сохранения открытого ключа должен быть равен нулю (данные не шифруются);
формат - указывается один из возможных форматов экспорта (PUBLICKEYBLOB, PRIVATEKEYBLOB, SIMPLEBLOB); флаги - зарезервирован на будущее (должен быть равен нулю); буфер - содержит адрес буфера, в который будет записан ключевой BLOB (Binary Large OBject - большой двоичный объект); размер буфера - при вызове функции в этой переменной должен находиться доступный размер буфера, а по окончании работы в нее записывается количество экспортируемых данных. Если размер буфера заранее не известен, то функцию нужно вызвать с параметром буфер, равным пустому указателю, тогда размер буфера будет вычислен и занесен в переменную размер буфера. Экспорт ключевой пары целиком, включая и закрытый ключ, может понадобиться для того, чтобы иметь возможность подписывать документы на различных компьютерах (например, дома и на работе), или для сохранения страховочной копии. В этом случае нужно создать ключ шифрования на основании пароля (см. "К+П", ? 10/2002) и передать дескриптор этого ключа в качестве второго параметра функции CryptExportKey. Запросить у криптопровайдера дескриптор самого' экспортируемого ключа позволяет функция CryptGetUserKey (провайдер, описание ключа, дескриптор ключа). Описание ключа - это либо AT_KEYEXCHANGE, либо AT_SIGNATURE.Ниже приведены наиболее важные фрагменты программы:
procedure TExportForm.OKBtnClick(Sender: TObject);
var
cont: PChar;
err: string;
hProv: HCRYPTPROV;
key, expKey: HCRYPTKEY;
pbuf: PBYTE;
buflen: DWORD;
f: file;
hash: HCRYPTHASH;
begin
{если ни один ключ не выбран - выход}
if not (KEKCheckBox.Checked or SKCheckBox.Checked) then
exit;
{если нужен пароль, т.е. экспортируется ключевая пара целиком}
if PasswEdit.Enabled and (PasswEdit.Text <> Passw2Edit.Text) then
begin
MessageDlg('Ошибка при вводе пароля! Повторите ввод.', mtError, [mbOK], 0);
exit;
end;
:
"считываем" имя контейнера и подключаемся к криптопровайдеру
:
если нужен ключ шифрования - создаем его на основании пароля
:
{ключ обмена ключами}
if KEKCheckBox.Checked then
repeat
{получаем дескриптор ключа}
CryptGetUserKey(hProv, AT_KEYEXCHANGE, @key);
{пытаемся определить размер буфера для экспорта ключа}
if (WhatRadioGroup.ItemIndex = 0) then
CryptExportKey(key, 0, PUBLICKEYBLOB, 0, nil, @bufLen)
else
CryptExportKey(key, expKey, PRIVATEKEYBLOB, 0, nil, @bufLen);
GetMem(pbuf, bufLen);
{экспортируем данные}
if (WhatRadioGroup.ItemIndex = 0) then
CryptExportKey(key, 0, PUBLICKEYBLOB, 0, pbuf, @bufLen)
else
CryptExportKey(key, expKey, PRIVATEKEYBLOB, 0, pbuf, @bufLen);
{освобождаем дескриптор ключа обмена ключами
(сам ключ при этом не уничтожается)}
CryptDestroyKey(key);
SaveDialog1.Title := 'Укажите файл для сохранения ключа обмена ключами';
if SaveDialog1.Execute then
begin
AssignFile(f, SaveDialog1.FileName);
rewrite(f, 1);
BlockWrite(f, pbuf^, bufLen);
CloseFile(f);
MessageDlg('Ключ обмена ключами успешно сохранен', mtInformation,
[mbOK], 0);
end;
until true; {KeyExchange}
{ключ подписи}
if SKCheckBox.Checked then
repeat
?аналогично ключу обмена ключами?
until true; {Signature}
:
если создавался ключ на основании пароля - уничтожаем его,
после чего освобождаем контекст криптопровайдера
:
end;
Экспортированные таким образом открытые части ключей понадобятся нам для проверки подписи и расшифровки сеансового ключа.
Импорт ключевых пар во вновь созданный контейнер - это самостоятельная процедура. Необходимо запросить у пользователя название контейнера и пароль, подключиться к провайдеру, создать на основании пароля ключ, считать из файла импортируемые данные в буфер, после чего воспользоваться функцией CryptImportKey (провайдер, буфер, длина буфера, ключ для расшифровки, флаги, импортируемый ключ). Если нужно обеспечить возможность экспорта импортируемой ключевой пары впоследствии, то в параметре флаги необходимо передать значение CRYPT_EXPORTABLE; в противном случае вызов для данной ключевой пары функции CryptExportKey приведет к ошибке.
Мы уже обсуждали, что при работе с асимметричными алгоритмами важно убедиться, что открытый ключ действительно принадлежит тому, кого вы считаете его хозяином, и не был подменен злоумышленником. Простейшим способом обеспечить аутентичность ключа является побайтная сверка с оригиналом, хранящимся у его хозяина. Для этого можно просто позволить пользователю просмотреть экспортированные данные в шестнадцатеричном виде - например, открыть файл, в который был записан открытый ключ, и вывести его содержимое в окно просмотра.
Электронная цифровая подпись
Для создания электронной цифровой подписи необходимо вычислить хеш заданного файла и зашифровать этот "цифровой отпечаток сообщения" своим закрытым ключом - "подписать". Чтобы подпись впоследствии можно было проверить, необходимо указать, какой алгоритм хеширования использовался при ее создании. Поэтому подписанное сообщение должно иметь структуру.
Подписать вычисленный хеш в CryptoAPI позволяет функция CryptSignHash (хеш, описание ключа, комментарий, флаги, подпись, длина подписи). Вторым параметром может быть либо AT_KEYEXCHANGE, либо AT_SIGNATURE (в нашем случае логичнее использовать ключ подписи). Третий параметр в целях безопасности настоятельно рекомендуется оставлять пустым (nil). Флаги в настоящее время также не используются - на месте этого аргумента должен быть нуль. Готовую электронную подпись функция запишет в буфер, адрес которого содержится в предпоследнем параметре, последний же параметр будет содержать длину подписи в байтах.
procedure TSigningForm.SignBtnClick(Sender: TObject);
var
cont: PChar;
err: string;
hProv: HCRYPTPROV;
key: HCRYPTKEY;
alg: ALG_ID;
hash: HCRYPTHASH;
infile, outfile: file;
size: DWORD;
buf: array[0..511] of byte;
signature: PBYTE;
begin
{проверка существования выбранного файла}
if not FileExists(DataNameEdit.Text) then
begin
MessageDlg('Неверное имя файла!', mtError, [mbOK], 0);
exit;
end;
AssignFile(infile, DataNameEdit.Text);
:
"считываем" имя контейнера и подключаемся к нему
:
case HashRadioGroup.ItemIndex of
0: alg := CALG_MD5;
1: alg := CALG_SHA;
end;
CryptCreateHash(hProv, alg, 0, 0, @hash);
SaveDialog1.Title := 'Задайте имя файла для хранения подписанных данных';
if SaveDialog1.Execute then
begin
AssignFile(outfile, SaveDialog1.FileName);
rewrite(outfile, 1);
{записываем в файл идентификатор алгоритма хеширования}
BlockWrite(outfile, alg, 4);
reset(infile, 1);
size := FileSize(infile);
{записываем размер подписываемых данных}
BlockWrite(outfile, size, 4);
{пишем сами данные и вычисляем хеш:}
while not eof(infile) do
begin
BlockRead(infile, buf, 512, size);
BlockWrite(outFile, buf, size);
CryptHashData(hash, @buf, size, 0);
end;
CloseFile(infile);
{выясняем размер подписи}
CryptSignHash(hash, AT_SIGNATURE, nil, 0, nil, @size);
{создаем подпись}
GetMem(signature, size);
CryptSignHash(hash, AT_SIGNATURE, nil, 0, signature, @size);
BlockWrite(outfile, size, 4);
BlockWrite(outfile, signature^, size);
CloseFile(outfile);
end;
:
уничтожаем хеш - объект и освобождаем контекст
:
end;
Чтобы проверить правильность подписи, получатель подписанного сообщения должен иметь файл с открытым ключом подписи отправителя. В процессе проверки подписи этот ключ импортируется внутрь криптопровайдера. Проверка выполняется функцией CryptVerifySignature (хеш, подпись, длина подписи, открытый ключ, комментарий, флаги). О последних двух аргументах можно сказать то же, что и о параметрах комментарий и флаги функции CryptSignHash, назначение же остальных должно быть понятно. Если подпись верна, функция возвращает true. Значение false в качестве результата может свидетельствовать либо о возникновении ошибки в процессе проверки, либо о том, что подпись оказалась неверной. В последнем случае функция GetLastError вернет ошибку NTE_BAD_SIGNATURE. Для примера приведем наиболее значимые фрагменты программы проверки подписи:
procedure TMainForm.VerifyItemClick(Sender: TObject);
var
err: string;
hProv: HCRYPTPROV;
key: HCRYPTKEY;
alg: ALG_ID;
hash: HCRYPTHASH;
infile: file;
size, test, textsize: DWORD;
buf: PBYTE;
signature, signkey: PBYTE;
begin
:
получаем контекст криптопровайдера
:
OpenDialog1.Title := 'Укажите файл с подписанными данными';
if OpenDialog1.Execute then
begin
AssignFile(infile, OpenDialog1.FileName);
reset(infile, 1);
{считываем идентификатор алгоритма хеширования}
BlockRead(infile, alg, 4);
{считываем размер подписанных данных и сами данные}
BlockRead(infile, textsize, 4);
GetMem(buf, textsize);
BlockRead(infile, buf^, textsize, test);
if test < textsize then
begin
MessageDlg('Неверный формат файла! Процесс прерван.', mtError, [mbOK], 0);
exit;
end;
{считываем размер подписи и саму подпись}
BlockRead(infile, test, 4);
GetMem(signature, test);
BlockRead(infile, signature^, test);
CloseFile(infile);
end
else
exit;
:
создаем хеш - объект и хешируем данные
:
OpenDialog1.Title := 'Укажите файл с открытым ключом подписи';
if OpenDialog1.Execute then
begin
AssignFile(infile, OpenDialog1.FileName);
reset(infile, 1);
size := FileSize(infile);
GetMem(signkey, size);
BlockRead(infile, signkey^, size);
CloseFile(infile);
end
else
exit;
{импортируем открытый ключ подписи отправителя}
CryptImportKey(hProv, signkey, size, 0, 0, @key);
FreeMem(signkey, size);
{проверяем подпись}
if CryptVerifySignature(hash, signature, test, key, nil, 0) then
begin
MessageDlg('Подпись верна.', mtInformation, [mbOK], 0);
{сохраняем подписанные данные}
SaveDialog1.Title := 'Укажите имя файла для сохранения данных';
if SaveDialog1.Execute then
begin
AssignFile(infile, SaveDialog1.FileName);
rewrite(infile, 1);
BlockWrite(infile, buf^, textsize);
CloseFile(infile);
end;
end
else
begin
case int64(GetLastError) of
NTE_BAD_SIGNATURE: err := 'Подпись неверна!';
{обработка других ошибок}
else
err := 'Ошибка при проверке подписи: Unknown error';
end;
MessageDlg(err, mtError, [mbOK], 0);
end;
:
уничтожаем хеш - объект и импортированный ключ
и освобождаем контекст криптопровайдера
:
end;
Методы криптографической защиты информации Windows.
Оформил: DeeCo
Мы вступили в цифровой век. На смену бумажным документам пришли электронные, а личные контакты все чаще уступают место переписке по e-mail. Поэтому «шпионские штучки» вроде паролей и шифровок становятся все более привычными и необходимыми инструментами безопасности.
Криптографические возможности Windows.
Сразу договоримся, что никакая система защиты информации не может быть абсолютно надежной. Речь может идти лишь о некоторой степени надежности и рисках, связанных со взломом защиты. Поэтому с практической точки зрения есть смысл оценить важность данных и экономно подстелить соломку на случай неудачи. В наших приложениях, например, мы выдаем кредит доверия операционной системе Windows, несмотря на закрытость ее кода.
Итак, ОС мы доверяем. Чтобы криптозащиту нельзя было «обойти» с другой стороны — к примеру, перехватить из незащищенной области памяти секретные пароли — криптографические функции должны быть частью операционной системы. В семействе Windows, начиная с Windows 95, обеспечивается реализация шифрования, генерации ключей, создания и проверки цифровых подписей и других криптографических задач. Эти функции необходимы для работы операционной системы, однако ими может воспользоваться и любая прикладная программа — для этого программисту достаточно обратиться к нужной подпрограмме так, как предписывает криптографический интерфейс прикладных программ (CryptoAPI).
Разумеется, по мере совершенствования Windows расширялся и состав ее криптографической подсистемы. Помимо базовых операций, в настоящее время в CryptoAPI 2.0 поддерживается работа с сертификатами, шифрованными сообщениями в формате PKCS #7 и пр.
Описание функций CryptoAPI, помимо специальных книг, можно найти в MSDN Library, или в CD-версии, в файле crypto.chm.
Взаимодействие с CryptoAPI.
Функции CryptoAPI можно вызвать из программы, написанной на любимом многими (в том числе и авторами) языке С++. Тем не менее, Pascal де-факто признан стандартом в области обучения программированию. (Не будем спорить о том, хорошо это или плохо, чтобы не ввязываться в драку, пусть даже и виртуальную.) Кроме того, в ряде отечественных компаний Delphi является базовым средством разработки. Поэтому все примеры были реализованы в среде Delphi. Хотя в качестве инструмента можно было бы выбрать и MS Visual C++.
Код функций криптографической подсистемы содержится в нескольких динамически загружаемых библиотеках Windows (advapi32.dll, crypt32.dll). Для обращения к такой функции из прикладной программы на Object Pascal следует объявить ее как внешнюю. Заголовок функции в интерфейсной части модуля будет выглядеть, например, так:
function CryptAcquireContext( phPROV: PHCRYPTPROV; pszContainer: LPCTSTR; pszProvider: LPCTSTR; dwProvType: DWORD; dwFlags: DWORD): BOOL; stdcall;
А в исполняемой части вместо тела функции нужно вписать директиву extern с указанием библиотеки, в которой содержится функция, и, возможно, ее имени в этой библиотеке (если оно отличается от имени функции в создаваемом модуле), например:
function CryptAcquireContext; external ‘advapi32.dll’ name 'CryptAcquireContextA';
Таким образом, имея описание функций CryptoAPI, можно собрать заголовки функций в отдельном модуле, который будет обеспечивать взаимодействие прикладной программы с криптографической подсистемой. Разумеется, такая работа была проделана программистами Microsoft, и соответствующий заголовочный файл (wincrypt.h) был включен в поставку MS Visual C++. К счастью, появилась и Delphi-версия (wcrypt2.pas). Ее можно найти здесь. Подключив модуль к проекту, вы сможете использовать не только функции CryptoAPI, но и мнемонические константы режимов, идентификаторы алгоритмов и прочих параметров, необходимых на практике.
И последнее замечание перед тем, как опробовать CryptoAPI в деле. Ряд функций был реализован только в Windows 2000. Но и на старушку Windows 98 можно найти управу: при установке Internet Explorer 5 интересующие нас библиотеки обновляются, позволяя использовать новейшие криптографические возможности. Нужно лишь задать для Delphi-проекта параметр условной компиляции NT5, после чего вызовы функций, появившихся лишь в Windows 2000, будут нормально работать.
Знакомство с криптопровайдерами.
Функции CryptoAPI обеспечивают прикладным программам доступ к криптографическим возможностям Windows. Однако они являются лишь «передаточным звеном» в сложной цепи обработки информации. Основную работу выполняют скрытые от глаз программиста функции, входящие в специализированные программные (или программно-аппаратные) модули — провайдеры (поставщики) криптографических услуг (CSP — Cryptographic Service Providers), или криптопровайдерыПрограммная часть криптопровайдера представляет собой dll-файл, подписанный Microsoft; периодически Windows проверяет цифровую подпись, что исключает возможность подмены криптопровайдера.
Криптопровайдеры отличаются друг от друга:
составом функций (например, некоторые криптопровайдеры не выполняют шифрование данных, ограничиваясь созданием и проверкой цифровых подписей); требованиями к оборудованию (специализированные криптопровайдеры могут требовать устройства для работы со смарт-картами для выполнения аутентификации пользователя); алгоритмами, осуществляющими базовые действия (создание ключей, хеширование и пр.).По составу функций и обеспечивающих их алгоритмов криптопровайдеры подразделяются на типы. Например, любой CSP типа PROV_RSA_FULL поддерживает как шифрование, так и цифровые подписи, использует для обмена ключами и создания подписей алгоритм RSA, для шифрования — алгоритмы RC2 и RC4, а для хеширования — MD5 и SHA.
В зависимости от версии операционной системы состав установленных криптопровайдеров может существенно изменяться. Однако на любом компьютере с Windows можно найти Microsoft Base Cryptographic Provider, относящийся к уже известному нам типу PROV_RSA_FULL. Именно с этим провайдером по умолчанию будут взаимодействовать все программы.
Использование криптографических возможностей Windows напоминает работу программы с графическим устройством. Криптопровайдер подобен графическому драйверу: он может обеспечивать взаимодействие программного обеспечения с оборудованием (устройство чтения смарт-карт, аппаратные датчики случайных чисел и пр.). Для вывода информации на графическое устройство приложение не должно непосредственно обращаться к драйверу — вместо этого нужно получить у системы контекст устройства, посредством которого и осуществляются все операции. Это позволяет прикладному программисту использовать графическое устройство, ничего не зная о его аппаратной реализации. Точно так же для использования криптографических функций приложение обращается к криптопровайдеру не напрямую, а через CryptoAPI. При этом вначале необходимо запросить у системы контекст криптопровайдера.
Первым делом, хотя бы из любопытства, выясним, какие же криптопровайдеры установлены в системе. Для этого нам понадобятся четыре функции CryptoAPI (выходные параметры выделены жирным шрифтом, а входные — курсивом):
CryptEnumProviders (i, резерв, флаги, тип, имя, длина_имени) — возвращает имя и тип i-го по порядку криптопровайдера в системе (нумерация начинается с нуля); CryptAcquireContext (провайдер, контейнер, имя, тип, флаги) — выполняет подключение к криптопровайдеру с заданным типом и именем и возвращает его дескриптор (контекст). При подключении мы будем передавать функции флаг CRYPT_VERIFYCONTEXT, служащий для получения контекста без подключения к контейнеру ключей; CryptGetProvParam (провайдер, параметр, данные, размер_данных, флаги) — возвращает значение указанного параметра провайдера, например, версии (второй параметр при вызове функции — PP_VERSION), типа реализации (программный, аппаратный, смешанный — PP_IMPTYPE), поддерживаемых алгоритмов (PP_ENUMALGS). Список поддерживаемых алгоритмов при помощи этой функции может быть получен следующим образом: при одном вызове функции возвращается информация об одном алгоритме; при первом вызове функции следует передать значение флага CRYPT_FIRST, а при последующих флаг должен быть равен 0; CryptReleaseContext (провайдер, флаги) — освобождает дескриптор криптопровайдера.Каждая из этих функций, как и большинство других функций CryptoAPI, возвращает логическое значение, равное true, в случае успешного завершения, и false — если возникли ошибки. Код ошибки может быть получен при помощи функции GetLastError. Возможные значения кодов ошибки приведены в упоминавшейся выше документации. Например, при вызове функции CryptGetProvParam для получения версии провайдера следует учесть возможность возникновения ошибок следующим образом:
if not CryptGetProvParam(hProv, PP_VERSION, (@vers), @DataLen, 0) then
begin
case int64(GetLastError) of
ERROR_INVALID_HANDLE: err := 'ERROR_INVALID_HANDLE';
ERROR_INVALID_PARAMETER: err := 'ERROR_INVALID_PARAMETER';
ERROR_MORE_DATA: err := 'ERROR_MORE_DATA';
ERROR_NO_MORE_ITEMS: err := 'ERROR_NO_MORE_ITEMS';
NTE_BAD_FLAGS: err := 'NTE_BAD_FLAGS';
NTE_BAD_TYPE: err := 'NTE_BAD_TYPE';
NTE_BAD_UID: err := 'NTE_BAD_UID';
else
err := 'Unknown error';
end;
MessageDlg('Error of CryptGetProvParam: ' + err, mtError, [mbOK], 0);
exit
end;
Текст процедуры, выводящей в Memo-поле FileMemo формы информацию об установленных в системе криптопровайдерах, приведен ниже. Предполагается, что процедура вызывается при выборе соответствующего элемента в главном меню формы. Для краткости в тексте программы опущены фрагменты, выполняющие обработку ошибок.
type
algInfo = record
algID: ALG_ID;
dwBits: DWORD;
dwNameLen: DWORD;
szName: array[0..100] of char;
end;
{вспомогательная функция, преобразующая тип провайдера в строку}
function ProvTypeToStr(provType: DWORD): string;
begin
case provType of
PROV_RSA_FULL: ProvTypeToStr := 'RSA full provider';
PROV_RSA_SIG: ProvTypeToStr := 'RSA signature provider';
PROV_DSS: ProvTypeToStr := 'DSS provider';
PROV_DSS_DH: ProvTypeToStr := 'DSS and Diffie-Hellman provider';
PROV_FORTEZZA: ProvTypeToStr := 'Fortezza provider';
PROV_MS_EXCHANGE: ProvTypeToStr := 'MS Exchange provider';
PROV_RSA_SCHANNEL: ProvTypeToStr := 'RSA secure channel provider';
PROV_SSL: ProvTypeToStr := 'SSL provider';
else
ProvTypeToStr := 'Unknown provider';
end;
end;
{вспомогательная функция, преобразующая тип реализации в строку}
function ImpTypeToStr(it: DWORD): string;
begin
case it of
CRYPT_IMPL_HARDWARE: ImpTypeToStr := 'аппаратный';
CRYPT_IMPL_SOFTWARE: ImpTypeToStr := 'программный';
CRYPT_IMPL_MIXED: ImpTypeToStr := 'смешанный';
CRYPT_IMPL_UNKNOWN: ImpTypeToStr := 'неизвестен';
else
ImpTypeToStr := 'неверное значение';
end;
end;
{процедура вывода информации о криптопровайдерах}
procedure TMainForm.InfoItemClick(Sender: TObject);
var
i: DWORD;
dwProvType, cbName, DataLen: DWORD;
provName: array[0..200] of char;
vers: array[0..3] of byte;
impType: DWORD;
ai: algInfo;
err: string;
begin
i := 0;
FileMemo.Clear;
while (CryptEnumProviders(i, nil, 0, {проверяем наличие еще одного}
@dwProvType, nil, @cbName)) do
begin
if CryptEnumProviders(i, nil, 0, {получаем имя CSP}
@dwProvType, @provName, @cbName) then
begin
FileMemo.Lines.Add('Криптопровайдер: ' + provName);
FileMemo.Lines.Add('Тип: ' + IntToStr(dwProvType) + ' - ' +
ProvTypeToStr(dwProvType));
if not CryptAcquireContext(@hProv, nil, provName, dwProvType,
CRYPT_VERIFYCONTEXT) then
begin
{обработка ошибок}
end;
DataLen := 4;
if not CryptGetProvParam(hProv, PP_VERSION, (@vers), @DataLen, 0) then
begin
{обработка ошибок}
end;
FileMemo.Lines.Add('Версия: ' + chr(vers[1] + ) + '.' + chr(vers[0] + ));
if not CryptGetProvParam(hProv, PP_IMPTYPE, @impType, @DataLen, 0) then
begin
{обработка ошибок}
end;
FileMemo.Lines.Add('Тип реализации: ' + ImpTypeToStr(impType));
FileMemo.Lines.Add('Поддерживает алгоритмы:');
DataLen := sizeof(ai);
if not CryptGetProvParam(hProv, PP_ENUMALGS, @ai, @DataLen, CRYPT_FIRST)
then
begin
{обработка ошибок}
end;
with ai do
FileMemo.Lines.Add(szName + #9 + 'длина ключа - ' + IntToStr(dwBits) +
' бит' + #9 + 'ID: ' + IntToStr(AlgID));
DataLen := sizeof(ai);
while CryptGetProvParam(hProv, PP_ENUMALGS, @ai, @DataLen, 0) do
begin
with ai do
FileMemo.Lines.Add(szName + #9 + 'длина ключа - '
+ IntToStr(dwBits) + ' бит' + #9 + 'ID: ' + IntToStr(AlgID));
DataLen := sizeof(ai);
end;
FileMemo.Lines.Add('');
CryptReleaseContext(hProv, 0);
end;
inc(i);
end;
end;
На рис. 2 показан пример отчета, выдаваемого приведенным выше кодом, выполненным в среде Windows 98.
Шифрование с использованием паролей.
После того как мы узнали кое-что о структуре CryptoAPI, можно воспользоваться ею в практических целях. Пожалуй, самым ожидаемым действием криптографической подсистемы является шифрование файлов — так, чтобы лишь пользователь, знающий определенный пароль, мог получить к ним доступ.
Для шифрования данных в CryptoAPI применяются симметричные алгоритмы. Симметричность означает, что для шифрования и расшифровки данных используется один и тот же ключ, известный как шифрующей, так и расшифровывающей стороне. При этом плохо выбранный ключ шифрования может дать противнику возможность взломать шифр. Поэтому одной из функций криптографической подсистемы должна быть генерация «хороших» ключей либо случайным образом, либо на основании некоторой информации, предоставляемой пользователем, например пароля.
В случае создания ключа на основании пароля должно выполняться следующее обязательное условие: при многократном повторении процедуры генерации ключа на одном и том же пароле должны получаться идентичные ключи. Ключ шифрования имеет, как правило, строго определенную длину, определяемую используемым алгоритмом, а длина пароля может быть произвольной. Даже интуитивно понятно, что для однозначной генерации ключей нужно привести разнообразные пароли к некоторой единой форме. Это достигается с помощью хеширования.
Хешированием (от англ. hash — разрезать, крошить, перемешивать) называется преобразование строки произвольной длины в битовую последовательность фиксированной длины (хеш-значение, или просто хеш) с обеспечением следующих условий:
по хеш-значению невозможно восстановить исходное сообщение; практически невозможно найти еще один текст, дающий такой же хеш, как и наперед заданное сообщение; практически невозможно найти два различных текста, дающих одинаковые хеш-значения (такие ситуации называют коллизиями).При соблюдении приведенных условий хеш-значение служит компактным цифровым отпечатком (дайджестом) сообщения. Существует множество алгоритмов хеширования. CryptoAPI поддерживает, например, алгоритмы MD5 (MD — Message Digest) и SHA (Secure Hash Algorithm).
Итак, чтобы создать ключ шифрования на основании пароля, нам нужно вначале получить хеш этого пароля. Для этого следует создать с помощью CryptoAPI хеш-объект, воспользовавшись функцией CryptCreateHash (провайдер, ID_алгоритма, ключ, флаги, хеш), которой нужно передать дескриптор криптопровайдера (полученный с помощью CryptAcquireContext) и идентификатор алгоритма хеширования (остальные параметры могут быть нулями). В результате мы получим дескриптор хеш-объекта. Этот объект можно представить себе как черный ящик, который принимает любые данные и «перемалывает» их, сохраняя внутри себя лишь хеш-значение. Подать данные на вход хеш-объекта позволяет функция CryptHashData (дескриптор, данные, размер_данных, флаги).
Непосредственно создание ключа выполняет функция CryptDeriveKey (провайдер, ID_алгоритма, хеш-объект, флаги, ключ), которая принимает хеш-объект в качестве исходных данных и строит подходящий ключ для алгоритма шифрования, заданного своим ID. Результатом будет дескриптор ключа, который можно использовать для шифрования (рис. 3).
Следует обратить внимание, что при работе с CryptoAPI мы все время имеем дело не с самими объектами или их адресами, а с дескрипторами — целыми числами, характеризующими положение объекта во внутренних таблицах криптопровайдера. Сами таблицы располагаются в защищенной области памяти, так что программы-«шпионы» не могут получить к ним доступ.
Алгоритмы шифрования, поддерживаемые CryptoAPI, можно разделить на блочные и поточные: первые обрабатывают данные относительно большими по размеру блоками (например, 64, 128 битов или более), а вторые — побитно (теоретически, на практике же — побайтно). Если размер данных, подлежащих шифрованию, не кратен размеру блока, то последний, неполный блок данных, будет дополнен необходимым количеством случайных битов, в результате чего размер зашифрованной информации может несколько увеличиться. Разумеется, при использовании поточных шифров размер данных при шифровании остается неизменным.
Шифрование выполняется функцией CryptEncrypt (ключ, хеш, финал, флаги, данные, рамер_данных, размер_буфера):
через параметр ключ передается дескриптор ключа шифрования; параметр хеш используется, если одновременно с шифрованием нужно вычислить хеш-значение шифруемого текста; параметр финал равен true, если шифруемый блок текста — последний или единственный (шифрование можно осуществлять частями, вызывая функцию CryptEncrypt несколько раз); значение флага должно быть нулевым; параметр данные представляет собой адрес буфера, в котором при вызове функции находится исходный текст, а по завершению работы функции — зашифрованный; следующий параметр, соответственно, описывает размер входных/выходных данных, последний параметр задает размер буфера — если в результате шифрования зашифрованный текст не уместится в буфере, возникнет ошибка.Для расшифровки данных используется функция CryptDecrypt (ключ, хеш, финал, флаги, данные, рамер_данных), отличающаяся от шифрующей функции только тем, что размер буфера указывать не следует: поскольку размер данных при расшифровке может только уменьшиться, отведенного под них буфера наверняка будет достаточно.
Приведем лишь фрагменты программы, реализующей шифрование файла с использованием заданного пароля, опустив громоздкие проверки успешности выполнения криптографических операций (что в реальной программе делать крайне нежелательно).
{«описание» используемых переменных}
hProv: HCRYPTPROV;
hash: HCRYPTHASH;
password: string;
key: HCRYPTKEY;
plaintext, ciphertext: string;
inFile, outFile: file;
data: PByte;
l: DWORD;
{получаем контекст криптопровайдера}
CryptAcquireContext(@hProv, nil, nil, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT);
{создаем хеш-объект}
CryptCreateHash(hProv, CALG_SHA, 0, 0, @hash);
{хешируем пароль}
CryptHashData(hash, @password[1], length(password), 0);
{создаем ключ на основании пароля для потокового шифра RC4}
CryptDeriveKey(hProv, CALG_RC4, hash, 0, @key);
{уничтожаем хеш-объект}
CryptDestroyHash(hash);
{открываем файлы}
AssignFile(inFile, plaintext);
AssignFile(outFile, ciphertext);
reset(inFile, 1);
rewrite(outFile, 1);
{выделяем место для буфера}
GetMem(data, 512);
{шифруем данные}
while not eof(inFile) do
begin
BlockRead(inFile, data^, 512, l);
CryptEncrypt(key, 0, eof(inFile), 0, data, @l, l);
BlockWrite(outFile, data^, l);
end;
{освобождаем место и закрываем файлы}
FreeMem(data, 512);
CloseFile(inFile);
CloseFile(outFile);
{освобождаем контекст криптопровайдера}
CryptReleaseContext(hProv, 0);
Конечно, шифрование вами всех файлов одним и тем же паролем облегчает «противнику» задачу их расшифровки, запоминание огромного числа паролей сильно усложняет жизнь, а их записывание в незашифрованном виде создает опасность раскрытия всей системы. CryptoAPI может предложить на этот случай ряд решений. О них поговорим в следующий раз.
Методы криптографической защиты информации Windows 2.
Оформил: DeeCo
Продолжим** рассказ о криптографических возможностях Windows. В арсенале защиты должны быть не только методы, обеспечивающие секретность передачи информации (о них мы говорили в первой части статьи). Не менее важными инструментами безопасности являются процедуры, позволяющие убедиться в целости и аутентичности данных. Кроме того, необходимо решать проблемы безопасного хранения и распределения ключей.
Проблема распределения ключей.
В прошлый раз при помощи CryptoAPI мы решали такую "классическую" задачу как шифрование на основе пароля. Напомним, что пароль использовался для создания ключа шифрования какого-либо симметричного алгоритма. В таком случае расшифровать файл может лишь тот, кто знает пароль. А значит, для обеспечения конфиденциальности нужно держать пароль в строжайшем секрете - желательно, чтобы его знали лишь отправитель и получатель информации. (А еще лучше, если отправитель и получатель - одно и то же лицо.).
Предположим, что отправитель и получатель при личной встрече договорились использовать для конфиденциальной переписки определенный пароль. Но если они будут шифровать все свои сообщения одним и тем же ключом, то возможный противник, перехватив корреспонденцию, будеть иметь хорошие шансы взломать шифр: при современных методах криптоанализа наличие нескольких шифртекстов, полученных путем использования одного и того же ключа, почти гарантирует успешный результат. Поэтому при использовании симметричных алгоритмов шифрования настоятельно рекомендуется не применять один и тот же ключ дважды!
Однако помнить отдельный пароль для каждого зашифрованного сообщения - задача достаточно трудоемкая. А для корреспондентов, не имеющих возможности встретиться лично для согласования ключей шифрования, конфиденциальный обмен сообщениями вообще становится недоступным. Такая практическая трудность называется проблемой распределения ключей.
Спасительный способ, позволяющий шифровать сообщения, обмениваясь ключами по открытым каналам связи, был придуман в середине 70-х годов прошлого столетия, а в начале восьмидесятых появился первый реализующий его алгоритм - RSA. Теперь пользователь может сгенерировать два связанных между собой ключа - ключевую пару. Один из этих ключей по несекретным каналам рассылается всем, с кем пользователь хотел бы обмениваться конфиденциальными сообщениями. Этот ключ называют открытым (англ. public key). Зная открытый ключ пользователя, можно зашифровать адресованное ему сообщение, но вот расшифровать его позволяет лишь вторая часть ключевой пары - закрытый ключ (private key). При этом открытый ключ не дает "практической" возможности вычислить закрытый: такая задача, хоть и разрешима в принципе, но при достаточно большом размере ключа требует многих лет машинного времени. Для сохранения конфиденциальности получателю необходимо лишь хранить в строгом секрете свой закрытый ключ, а отправителю - убедиться, что имеющийся у него открытый ключ действительно принадлежит адресату.
Так как для шифрования и расшифровки используются различные ключи, алгоритмы такого рода назвали асимметричными. Наиболее существенным их недостатком является низкая производительность - они примерно в 100 раз медленнее симметричных алгоритмов. Поэтому были созданы криптографические схемы, использующие преимущества как симметричных, так и асимметричных алгоритмов:
для шифрования файла или сообщения используется быстрый симметричный алгоритм, причем ключ шифрования генерируется случайным образом с обеспечением "хороших" статистических свойств; небольшой по размерам симметричный ключ шифрования шифруется при помощи асимметричного алгоритма с использованием открытого ключа адресата и в зашифрованном виде пересылается вместе с сообщением; получив сообщение, адресат своим закрытым ключом расшифровывает симметричный ключ, а с его помощью - и само сообщение.Описанная схема реализована и в CryptoAPI.
Целостность и аутентичность информации.
Как удостовериться в том, что пришедшее сообщение действительно отправлено тем, чье имя стоит в графе "отправитель"? Асимметричные схемы шифрования дают нам элегантный способ аутентификации. Если отправитель зашифрует сообщение своим закрытым ключом, то успешное расшифровывание убедит получателя в том, что послать корреспонденцию мог только хозяин ключевой пары, и никто иной. При этом расшифровку может выполнить любой, кто имеет открытый ключ отправителя. Ведь наша цель - не конфиденциальность, а аутентификация.
Чтобы избежать шифрования всего сообщения при помощи асимметричных алгоритмов, используют хеширование: вычисляется хеш-значение исходного сообщения, и только эта короткая последовательность байтов шифруется закрытым ключом отправителя. Результат представляет собой электронную цифровую подпись. Добавление такой подписи к сообщению позволяет установить:
аутентичность сообщения - создать подпись на основе закрытого ключа мог только его хозяин; целостность данных - легко вычислить хеш-значение полученного сообщения и сравнить его с тем, которое хранится в подписи: если значения совпадают, значит, сообщение не было изменено злоумышленником после того, как отправитель его подписал.Таким образом, асимметричные алгоритмы позволяют решить две непростые задачи: обмена ключами шифрования по открытым каналам связи и подписи сообщения. Чтобы воспользоваться этими возможностями, нужно сгенерировать и сохранить две ключевые пары - для обмена ключами и для подписей. В этом нам поможет CryptoAPI.
Контейнеры ключей.
Каждый криптопровайдер располагает базой данных, в которой хранятся долговременные ключи пользователей. База данных содержит один или более контейнеров ключе. Пользователь может создать несколько контейнеров с различными именами (именем контейнера по умолчанию является имя пользователя в системе).
Подключение к контейнеру производится одновременно с получением контекста криптопровайдера при вызове функции CryptAcquireContext - имя контейнера ключей передается функции вторым ее аргументом. Если второй аргумент содержит пустой указатель (nil), то используется имя по умолчанию, т. е. имя пользователя. В том случае, если доступ к контейнеру не нужен, можно передать в последнем аргументе функции флаг CRYPT_VERIFYCONTEXT; при необходимости создать новый контейнер используется флаг CRYPT_NEWKEYSET; а для удаления существующего контейнера вместе с хранящимися в нем ключами - CRYPT_DELETEKEYSET.
Каждый контейнер может содержать, как минимум, две ключевые пары - ключ обмена ключами и ключ подписи. Ключи, используемые для шифрования симметричными алгоритмами, не сохраняются. Как мы уже говорили, такие ключи не рекомендуется применять более одного раза, поэтому их называют сеансовыми (англ. session key).
Создание ключевых пар.
После создания контейнера ключей необходимо сгенерировать ключевые пары обмена ключами и подписи. Эту работу в CryptoAPI выполняет функция CryptGenKey (провайдер, алгоритм, флаги, ключ):
провайдер - дескриптор криптопровайдера, полученный в результате обращения к функции CryptAcquireContext; алгоритм - указывает, какому алгоритму шифрования будет соответствовать создаваемый ключ. Информация об алгоритме, таким образом, является частью описания ключа. Каждый криптопровайдер использует для обмена ключами и подписи строго определенные алгоритмы. Так, провайдеры типа PROV_RSA_FULL, к которым относится и Microsoft Base Cryptographic Provider, реализуют алгоритм RSA. Но при генерации ключей знать это не обязательно: достаточно указать, какой ключ мы собираемся создать - обмена ключами или подписи. Для этого используются мнемонические константы AT_KEYEXCHANGE и AT_SIGNATURE; флаги - при создании асимметричных ключей управляет их размером. Используемый нами криптопровайдер позволяет генерировать ключ обмена ключами длиной от 384 до 512 бит**, а ключ подписи - от 512 до 16384 бит. Чем больше длина ключа, тем выше его надежность, поэтому трудно найти причины для использования ключа обмена ключами длиной менее 512 бит, а длину ключа подписи не рекомендуется делать меньше 1024 бит**. По умолчанию криптопровайдер создает оба ключа длиной 512 бит. Необходимую длину ключа можно передать в старшем слове параметра флаги; ключ - в случае успешного завершения функции в этот параметр заносится дескриптор созданного ключа.Рассмотрим пример создания ключевых пар при помощи формы. В поле "Контейнер" можно указать имя контейнера ключей; если оставить это поле пустым, будет использован контейнер по умолчанию. Назначение остальных элементов управления должно быть интуитивно понятным. После генерации ключа в memo-поле выводится отчет о его параметрах. Для этого используется функция CryptGetKeyParam (ключ, параметр, буфер, размер, флаги). Чтобы получить информацию о требуемом параметре, нужно через второй аргумент функции передать соответствующую константу: KP_ALGID - идентификатор алгоритма, KP_KEYLEN - размер ключа, и т. д. Ниже приведен текст процедуры генерации ключей без операторов обработки ошибок:
procedure TGenerateForm.OKBtnClick(Sender: TObject);
var
cont: PChar;
err: string;
hProv: HCRYPTPROV;
KeyExchKey, SignKey: HCRYPTKEY;
flag, keyLen: DWORD;
begin
{если ни один ключ не выбран - выход}
if not (KEKCheckBox.Checked or SKCheckBox.Checked) then
exit;
{"считываем" имя контейнера}
if length(ContainerEdit.Text) = 0 then
cont := nil
else
begin
err := ContainerEdit.Text;
cont := StrAlloc(length(err) + 1);
StrPCopy(cont, err);
end;
CryptAcquireContext(@hProv, cont, nil, PROV_RSA_FULL, 0);
{генерация ключа обмена ключами (Key Exchange Key)}
if KEKCheckBox.Checked then
begin
{"считываем" длину ключа и помещаем ее в
старшее слово параметра ФЛАГИ}
keyLen := strtoint(KeyExchLenEdit.text);
flag := keyLen shl 16;
if not CryptGenKey(hProv, AT_KEYEXCHANGE, flag, @KeyExchKey) then
begin
јобработка ошибокј
end
else
begin
ReportMemo.Lines.Add('');
ReportMemo.Lines.Add('Создан ключ обмена ключами:');
flag := 4;
if not CryptGetKeyParam(KeyExchKey, KP_KEYLEN, @keyLen, @flag, 0) then
begin
јобработка ошибокј
end
else
ReportMemo.Lines.Add(' длина ключа - ' + inttostr(keyLen));
flag := 4;
if not CryptGetKeyParam(KeyExchKey, KP_ALGID, @keyLen, @flag, 0) then
begin
јобработка ошибокј
end
else
ReportMemo.Lines.Add(' алгоритм - ' + algIDtostr(keyLen));
{функция algIDtostr здесь не приводится. Она состоит из единственного
оператора case, отображающего целый идентификатор алгоритма в строку}
end;
end;
{генерация ключа подписи (Signature Key)}
if SKCheckBox.Checked then
begin
јвыполняется аналогично генерации ключа обмена ключамиј
end;
CryptReleaseContext(hProv, 0);
end;
Обмен ключами.
Теперь мы располагаем набором ключей, однако все они останутся мертвым грузом, до тех пор пока мы не получим возможности обмена с другими пользователями открытыми ключами. Для этого необходимо извлечь их из базы данных ключей и записать в файл, который можно будет передать своим корреспондентам. При экспорте данные ключа сохраняются в одном из трех возможных форматов:
PUBLICKEYBLOB - используется для сохранения открытых ключей. Поскольку открытые ключи не являются секретными, они сохраняются в незашифрованном виде; PRIVATEKEYBLOB - используется для сохранения ключевой пары целиком (открытого и закрытого ключей). Эти данные являются в высшей степени секретными, поэтому сохраняются в зашифрованном виде, причем для шифрования используется сеансовый ключ (и, соответственно, симметричный алгоритм); SIMPLEBLOB - используется для сохранения сеансовых ключей. Для обеспечения секретности данные ключа шифруются с использованием открытого ключа получателя сообщения.Экспорт ключей в CryptoAPI выполняется функцией CryptExportKey (экспортируемый ключ, ключ адресата, формат, флаги, буфер, размер буфера):
экспортируемый ключ - дескриптор нужного ключа; ключ адресата - в случае сохранения открытого ключа должен быть равен нулю (данные не шифруются); формат - указывается один из возможных форматов экспорта (PUBLICKEYBLOB, PRIVATEKEYBLOB, SIMPLEBLOB); флаги - зарезервирован на будущее (должен быть равен нулю); буфер - содержит адрес буфера, в который будет записан ключевой BLOB (Binary Large OBject - большой двоичный объект); размер буфера - при вызове функции в этой переменной должен находиться доступный размер буфера, а по окончании работы в нее записывается количество экспортируемых данных. Если размер буфера заранее не известен, то функцию нужно вызвать с параметром буфер, равным пустому указателю, тогда размер буфера будет вычислен и занесен в переменную размер буфера.Экспорт ключевой пары целиком, включая и закрытый ключ, может понадобиться для того, чтобы иметь возможность подписывать документы на различных компьютерах (например, дома и на работе), или для сохранения страховочной копии. В этом случае нужно создать ключ шифрования на основании пароля (см. "К+П", № 10/2002) и передать дескриптор этого ключа в качестве второго параметра функции CryptExportKey.
Запросить у криптопровайдера дескриптор самого' экспортируемого ключа позволяет функция CryptGetUserKey (провайдер, описание ключа, дескриптор ключа). Описание ключа - это либо AT_KEYEXCHANGE, либо AT_SIGNATURE.
Экспорт асимметричных ключей во всем возможном многообразии можно осуществить при помощи формы.
Ниже приведены наиболее важные фрагменты программы:
procedure TExportForm.OKBtnClick(Sender: TObject);
var
cont: PChar;
err: string;
hProv: HCRYPTPROV;
key, expKey: HCRYPTKEY;
pbuf: PBYTE;
buflen: DWORD;
f: file;
hash: HCRYPTHASH;
begin
{если ни один ключ не выбран - выход}
if not (KEKCheckBox.Checked or SKCheckBox.Checked) then
exit;
{если нужен пароль, т.е. экспортируется ключевая пара целиком}
if PasswEdit.Enabled and (PasswEdit.Text < > Passw2Edit.Text) then
begin
MessageDlg('Ошибка при вводе пароля! Повторите ввод.', mtError, [mbOK], 0);
exit;
end;
…
"считываем" имя контейнера и подключаемся к криптопровайдеру
…
если нужен ключ шифрования - создаем его на основании пароля
…
{ключ обмена ключами}
if KEKCheckBox.Checked then
repeat
{получаем дескриптор ключа}
CryptGetUserKey(hProv, AT_KEYEXCHANGE, @key);
{пытаемся определить размер буфера для экспорта ключа}
if (WhatRadioGroup.ItemIndex = 0) then
CryptExportKey(key, 0, PUBLICKEYBLOB, 0, nil, @bufLen)
else
CryptExportKey(key, expKey, PRIVATEKEYBLOB, 0, nil, @bufLen);
GetMem(pbuf, bufLen);
{экспортируем данные}
if (WhatRadioGroup.ItemIndex = 0) then
CryptExportKey(key, 0, PUBLICKEYBLOB, 0, pbuf, @bufLen)
else
CryptExportKey(key, expKey, PRIVATEKEYBLOB, 0, pbuf, @bufLen);
{освобождаем дескриптор ключа обмена ключами
(сам ключ при этом не уничтожается)}
CryptDestroyKey(key);
SaveDialog1.Title := 'Укажите файл для сохранения ключа обмена ключами';
if SaveDialog1.Execute then
begin
AssignFile(f, SaveDialog1.FileName);
rewrite(f, 1);
BlockWrite(f, pbuf^, bufLen);
CloseFile(f);
MessageDlg('Ключ обмена ключами успешно сохранен', mtInformation, [mbOK],
0);
end;
until true; {KeyExchange}
{ключ подписи}
if SKCheckBox.Checked then
repeat
јаналогично ключу обмена ключамиј
until true; {Signature}
end;
…
если создавался ключ на основании пароля - уничтожаем его,
после чего освобождаем контекст криптопровайдера
…
Экспортированные таким образом открытые части ключей понадобятся нам для проверки подписи и расшифровки сеансового ключа.
Импорт ключевых пар во вновь созданный контейнер - это самостоятельная процедура. Необходимо запросить у пользователя название контейнера и пароль, подключиться к провайдеру, создать на основании пароля ключ, считать из файла импортируемые данные в буфер, после чего воспользоваться функцией CryptImportKey (провайдер, буфер, длина буфера, ключ для расшифровки, флаги, импортируемый ключ). Если нужно обеспечить возможность экспорта импортируемой ключевой пары впоследствии, то в параметре флаги необходимо передать значение CRYPT_EXPORTABLE; в противном случае вызов для данной ключевой пары функции CryptExportKey приведет к ошибке.
Мы уже обсуждали, что при работе с асимметричными алгоритмами важно убедиться, что открытый ключ действительно принадлежит тому, кого вы считаете его хозяином, и не был подменен злоумышленником. Простейшим способом обеспечить аутентичность ключа является побайтная сверка с оригиналом, хранящимся у его хозяина. Для этого можно просто позволить пользователю просмотреть экспортированные данные в шестнадцатеричном виде - например, открыть файл, в который был записан открытый ключ, и вывести его содержимое в окно просмотра.
Электронная цифровая подпись.
Для создания электронной цифровой подписи необходимо вычислить хеш заданного файла и зашифровать этот "цифровой отпечаток сообщения" своим закрытым ключом - "подписать". Чтобы подпись впоследствии можно было проверить, необходимо указать, какой алгоритм хеширования использовался при ее создании. Поэтому подписанное сообщение должно иметь структуру.
Подписать вычисленный хеш в CryptoAPI позволяет функция CryptSignHash (хеш, описание ключа, комментарий, флаги, подпись, длина подписи). Вторым параметром может быть либо AT_KEYEXCHANGE, либо AT_SIGNATURE (в нашем случае логичнее использовать ключ подписи). Третий параметр в целях безопасности настоятельно рекомендуется оставлять пустым (nil). Флаги в настоящее время также не используются - на месте этого аргумента должен быть нуль. Готовую электронную подпись функция запишет в буфер, адрес которого содержится в предпоследнем параметре, последний же параметр будет содержать длину подписи в байтах.
procedure TSigningForm.SignBtnClick(Sender: TObject);
var
cont: PChar;
err: string;
hProv: HCRYPTPROV;
key: HCRYPTKEY;
alg: ALG_ID;
hash: HCRYPTHASH;
infile, outfile: file;
size: DWORD;
buf: array[0..511] of byte;
signature: PBYTE;
begin
{проверка существования выбранного файла}
if not FileExists(DataNameEdit.Text) then
begin
MessageDlg('Неверное имя файла!', mtError, [mbOK], 0);
exit;
end;
AssignFile(infile, DataNameEdit.Text);
…
"считываем" имя контейнера и подключаемся к нему
…
case HashRadioGroup.ItemIndex of
0: alg := CALG_MD5;
1: alg := CALG_SHA;
end;
CryptCreateHash(hProv, alg, 0, 0, @hash);
SaveDialog1.Title := 'Задайте имя файла для хранения подписанных данных';
if SaveDialog1.Execute then
begin
AssignFile(outfile, SaveDialog1.FileName);
rewrite(outfile, 1);
{записываем в файл идентификатор алгоритма хеширования}
BlockWrite(outfile, alg, 4);
reset(infile, 1);
size := FileSize(infile);
{записываем размер подписываемых данных}
BlockWrite(outfile, size, 4);
{пишем сами данные и вычисляем хеш:}
while not eof(infile) do
begin
BlockRead(infile, buf, 512, size);
BlockWrite(outFile, buf, size);
CryptHashData(hash, @buf, size, 0);
end;
CloseFile(infile);
{выясняем размер подписи}
CryptSignHash(hash, AT_SIGNATURE, nil, 0, nil, @size);
{создаем подпись}
GetMem(signature, size);
CryptSignHash(hash, AT_SIGNATURE, nil, 0, signature, @size);
BlockWrite(outfile, size, 4);
BlockWrite(outfile, signature^, size);
CloseFile(outfile);
end;
…
уничтожаем хеш - объект и освобождаем контекст
…
end;
Чтобы проверить правильность подписи, получатель подписанного сообщения должен иметь файл с открытым ключом подписи отправителя. В процессе проверки подписи этот ключ импортируется внутрь криптопровайдера. Проверка выполняется функцией CryptVerifySignature (хеш, подпись, длина подписи, открытый ключ, комментарий, флаги). О последних двух аргументах можно сказать то же, что и о параметрах комментарий и флаги функции CryptSignHash, назначение же остальных должно быть понятно. Если подпись верна, функция возвращает true. Значение false в качестве результата может свидетельствовать либо о возникновении ошибки в процессе проверки, либо о том, что подпись оказалась неверной. В последнем случае функция GetLastError вернет ошибку NTE_BAD_SIGNATURE. Для примера приведем наиболее значимые фрагменты программы проверки подписи:
procedure TMainForm.VerifyItemClick(Sender: TObject);
var
err: string;
hProv: HCRYPTPROV;
key: HCRYPTKEY;
alg: ALG_ID;
hash: HCRYPTHASH;
infile: file;
size, test, textsize: DWORD;
buf: PBYTE;
signature, signkey: PBYTE;
begin
…
получаем контекст криптопровайдера
…
OpenDialog1.Title := 'Укажите файл с подписанными данными';
if OpenDialog1.Execute then
begin
AssignFile(infile, OpenDialog1.FileName);
reset(infile, 1);
{считываем идентификатор алгоритма хеширования}
BlockRead(infile, alg, 4);
{считываем размер подписанных данных и сами данные}
BlockRead(infile, textsize, 4);
GetMem(buf, textsize);
BlockRead(infile, buf^, textsize, test);
if test <
textsize then
begin
MessageDlg('Неверный формат файла! Процесс прерван.', mtError, [mbOK], 0);
exit;
end;
{считываем размер подписи и саму подпись}
BlockRead(infile, test, 4);
GetMem(signature, test);
BlockRead(infile, signature^, test);
CloseFile(infile);
end
else
exit;
…
создаем хеш - объект и хешируем данные
…
OpenDialog1.Title := 'Укажите файл с открытым ключом подписи';
if OpenDialog1.Execute then
begin
AssignFile(infile, OpenDialog1.FileName);
reset(infile, 1);
size := FileSize(infile);
GetMem(signkey, size);
BlockRead(infile, signkey^, size);
CloseFile(infile);
end
else
exit;
{импортируем открытый ключ подписи отправителя}
CryptImportKey(hProv, signkey, size, 0, 0, @key);
FreeMem(signkey, size);
{проверяем подпись}
if CryptVerifySignature(hash, signature, test, key, nil, 0) then
begin
MessageDlg('Подпись верна.', mtInformation, [mbOK], 0);
{сохраняем подписанные данные}
SaveDialog1.Title := 'Укажите имя файла для сохранения данных';
if SaveDialog1.Execute then
begin
AssignFile(infile, SaveDialog1.FileName);
rewrite(infile, 1);
BlockWrite(infile, buf^, textsize);
CloseFile(infile);
end;
end
else
begin
case int64(GetLastError) of
NTE_BAD_SIGNATURE: err := 'Подпись неверна!';
{обработка других ошибок}
else
err := 'Ошибка при проверке подписи: Unknown error';
end;
MessageDlg(err, mtError, [mbOK], 0);
end;
…
уничтожаем хеш - объект и импортированный ключ
и освобождаем контекст криптопровайдера
…
end;
CryptoAPI для шифрования файлов случайными ключами.
Оформил: DeeCo
Для конфиденциального обмена информацией с корреспондентом в любой точке земного шара приходится использовать целый арсенал современных криптографических инструментов: симметричные и асимметричные алгоритмы шифрования, механизмы генерирования криптографических ключей и случайных последовательностей, специфические режимы работы шифров и пр. Рассмотрим реализацию этих инструментов в CryptoAPI и воспользуемся ими для шифрования файла случайным ключом.
Цифровые конверты.
Асимметричные алгоритмы позволяют легко обменяться ключами шифрования по открытому каналу связи - но работают слишком медленно. Симметричные алгоритмы работают быстро - но для обмена ключами требуют наличия защищенного канала связи и, к тому же, нуждаются в частой смене ключей. Поэтому в современных криптосистемах используются сильные стороны обоих подходов. Так, для шифрования сообщения используется симметричный алгоритм со случайным ключом шифрования, действующим только в пределах одного сеанса,- сеансовым ключом. Чтобы впоследствии сообщение могло быть расшифровано, сеансовый ключ подвергается шифрованию асимметричным алгоритмом с использованием открытого ключа получателя сообщения. Зашифрованный таким образом сеансовый ключ сохраняется вместе с сообщением, образуя цифровой конверт. При необходимости цифровой конверт может содержать сеансовый ключ в нескольких экземплярах - зашифрованный открытыми ключами различных получателей.
Создание сеансовых ключей.
CryptoAPI позволяет генерировать сеансовые ключи случайным образом - эту работу выполняет функция CryptGenKey, о которой шла речь в предыдущей статье. Однако при использовании этой возможности за пределами США и Канады приходится учитывать американские ограничения на экспорт средств "сильной криптографии". В частности, до января 2000 года был запрещен экспорт программного обеспечения для шифрования с использованием ключей длиной более 40 бит. Этим объясняется разработка Microsoft двух версий своего криптопровайдера - базовой и расширенной. Базовая версия предназначалась на экспорт и поддерживала симметричные ключи длиной 40 бит; расширенная же версия (Microsoft Enhanced Cryptographic Provider) работала с "полной" длиной ключа (128 бит). Поскольку алгоритм шифрования, как правило, требует использования ключа строго определенной длины, недостающее количество битв в урезанном "экспортном" ключе могло быть заполнено либо нулями, либо случайными данными, которые предлагалось передавать открыто.
В криптографической практике внесение в состав ключа определенной части несекретных данных, которые сменяются несколько раз в ходе обработки исходного или шифр-текста, используется для того, чтобы воспрепятствовать взлому шифра атакой "по словарю". В английской терминологии такие вставки называются salt values: их назначение - "подсолить" ключ (с учетом нашей ментальности можно перевести как "насолить" противнику). Поскольку этот термин используется и в CryptoAPI, будем употреблять его в транслитерированном виде - солт-значения.
Итак, CryptoAPI, в экспортном исполнении практически вынуждает нас использовать солт-значения, составляющие бОльшую часть ключа - 88 бит из 128-ми для симметричных алгоритмов в RC2; и RC4. Конечно, при такой эффективной длине ключа криптозащита не может считаться достаточно надежной. В реальной ситуации выход один - воспользоваться криптопровайдером, не ограничивающим длину ключа. Обладатели Windows XP могут прибегнуть к услугам расширенных версий провайдера Microsoft (Enhanced или Strong). Пользователям более старых версий Windows, по-видимому, придется воспользоваться продуктами сторонних разработчиков. Например, свои версии криптопровайдеров предлагают российская компания "Крипто-Про" и шведская "StreamSec". В Украине, насколько известно авторам, разработкой национального провайдера криптографических услуг занимается коллектив харьковских ученых под руководством профессора Горбенко, однако до широкого внедрения дело пока не дошло. Тем не менее, благодаря архитектуре CryptoAPI, прикладные программы могут разрабатываться и отлаживаться и с базовым провайдером Microsoft - так как интерфейс взаимодействия остается неизменным. Поэтому вернемся к обсуждению создания случайных сеансовых ключей.
Солт может быть сгенерирован вместе с ключом: для этого нужно в качестве флага передать функции CryptGenKey (или CryptDeriveKey) константу CRYPT_CREATE_SALT. Правда, при сохранении ключа (с помощью функции CryptExportKey) система уже не заботится о солт-значении, перекладывая ответственность на прикладную программу. Таким образом, корректная процедура создания и сохранения симметричного ключа предполагает:
1. при создании ключа функции CryptGenKey передается значение флага CRYPT_EXPORTABLE or CRYPT_CREATE_SALT;
2. с помощью функции CryptGetKeyParam с параметром KP_SALT сгенерированное солт-значение сохраняется в буфере;
3. ключ в зашифрованном виде сохраняется в буфере при помощи функции CryptExportKey, которой передается открытый ключ обмена ключами адресата;
4. зашифрованные ключевые данные сохраняются или передаются адресату вместе с экспортированным на втором шаге солт-значением.
С другой стороны, солт-значение может быть сгенерировано и отдельно от ключа. Для этого используется функция CryptGenRandom (провайдер, длина, буфер). Здесь параметр длина задает размер генерируемой случайной последовательности в байтах, а последний аргумент задает адрес буфера, в который будет записан результат. Полученное таким образом солт-значение может быть внесено в ключ с помощью функции CryptSetKeyParam (ключ, параметр, данные, флаги). Ей вторым аргументом нужно передать KP_SALT, а третьим - адрес буфера, содержащего сгенерированную последовательность. (Последний аргумент функции зарезервирован на будущее и должен быть равен нулю.).
Блочные шифры.
Блочные шифры считаются более надежными, нежели поточные, поскольку каждый блок текста подвергается сложным преобразованиям. Тем не менее, одних только этих преобразований оказывается недостаточно для обеспечения должного уровня безопасности - важно, каким образом они применяются к исходному тексту в процессе шифрования.
Наиболее простой и интуитивно понятный способ состоит в том, чтобы разбить исходный текст на блоки соответствующего размера, а затем отдельно каждый блок подвергнуть шифрующему преобразованию. Такой режим использования блочных шифров называют электронной кодовой книгой (ECB - electronic codebook). Его главный недостаток состоит в том, что одинаковые блоки исходного текста при шифровании дадут одинаковые же блоки шифр-текста - а это может существенно облегчить противнику задачу взлома. Поэтому режим ECB не рекомендуется использовать при шифровании текстов, по длине превышающих один блок - в таких случаях лучше воспользоваться одним из режимов, связывающих различные блоки между собой. По умолчанию в CryptoAPI блочные шифры используются в режиме сцепления блоков шифр-текста (CBC - cipher block chaining). В этом режиме при шифровании очередной блок исходного текста вначале комбинируется с предыдущим блоком шифр-текста (при помощи побитового исключающего ИЛИ), а затем полученная последовательность битов поступает на вход блочного шифра. Образующийся на выходе блок шифр-текста используется для шифрования следующего блока. Самый первый блок исходного текста также должен быть скомбинирован с некоторой последовательностью битов, но "предыдущего блока шифр-текста" еще нет; поэтому режимы шифрования с обратной связью требуют использования еще одного параметра - он называется инициализирующим вектором (IV - initialization vector).
Инициализирующий вектор должен генерироваться отдельно с помощью уже известной нам функции CryptGenRandom и, как и солт-значение, передаваться вместе с ключом в открытом виде. Размер IV равен длине блока шифра. Например, для алгоритма RC2, поддерживаемого базовым криптопровайдером Microsoft, размер блока составляет 64 бита (8 байтов).
От слов - к делу.
Настало время применить все сказанное на практике, создав приложение, предназначенное для шифрования и расшифровки файлов с использованием случайных сеансовых ключей. Для успешной работы программы нужно создать на компьютере собственный ключевой контейнер, экспортировать из него открытый ключ обмена ключами и обменяться открытыми ключами с адресатом. Все эти операции подробно обсуждались в предыдущей статье. В простейшем случае "отправитель" сообщения может являться и "получателем" - тогда нужно просто экспортировать свой открытый ключ обмена ключами и сохранить его в каком-нибудь файле на диске.
Шифруемый файл помещается в цифровой конверт. Как мы знаем, вместе с ключом необходимо сохранить солт-значение, а при использовании блочного шифра - еще и инициализирующий вектор. В соответствии с этим наш цифровой конверт будет иметь структуру.
Приведем основные фрагменты процедуры, осуществляющей шифрование и расшифровку файла (обработка ошибок опущена):
procedure TMainForm.BitBtn1Click(Sender: TObject);
var
hProv: HCRYPTPROV;
KeyExchKey, SessionKey: HCRYPTKEY;
flag, keyLen: DWORD;
infile, outfile: file;
tmp: PBYTE;
buf: array[0..511] of byte;
alg: ALG_ID;
stream: boolean;
begin
…
подключение к криптопровайдеру
…
if ActionRadioGroup.ItemIndex = 0 {шифрование} then
begin
OpenDlg.Title := 'Укажите файл для шифрования';
if OpenDlg.Execute then
AssignFile(infile, OpenDlg.FileName)
else
exit;
OpenDlg.Title := 'Укажите файл с открытым ключом обмена ключами получателя';
if OpenDlg.Execute then
begin
AssignFile(outfile, OpenDlg.FileName);
reset(outfile, 1);
keyLen := FileSize(outfile);
GetMem(tmp, keyLen);
BlockRead(outfile, tmp^, keyLen);
CloseFile(outfile);
end
else
exit;
CryptImportKey(hProv, tmp, keyLen, 0, 0, @KeyExchKey);
FreeMem(tmp, keyLen);
SaveDlg.Title := 'Задайте имя файла для зашифрованных данных';
if SaveDlg.Execute then
AssignFile(outfile, SaveDlg.FileName)
else
exit;
rewrite(outfile, 1);
case AlgRadioGroup.ItemIndex of {установка алгоритма шифрования}
0:
begin
alg := CALG_RC2; {алгоритм RC2}
stream := false; {блочный шифр}
end;
1:
begin
alg := CALG_RC4; {алгоритм RC4}
stream := true; {поточный шифр}
end;
end;
CryptGenKey(hProv, alg, CRYPT_EXPORTABLE or CRYPT_CREATE_SALT, @SessionKey);
{создание сеансового ключа}
keyLen := 128; {размер буфера "с запасом"}
GetMem(tmp, keyLen);
CryptExportKey(SessionKey, KeyExchKey, SIMPLEBLOB, 0, tmp, @keyLen);
BlockWrite(outfile, keyLen, 4); {запись в файл размера ключа}
BlockWrite(outfile, tmp^, keyLen); {и самого зашифрованного ключа}
CryptDestroyKey(KeyExchKey);
keyLen := 512; {размер буфера "с запасом"}
CryptGetKeyParam(SessionKey, KP_SALT, @buf, @keyLen, 0);
BlockWrite(outfile, keyLen, 4); {запись в файл размера солта}
BlockWrite(outfile, buf, keyLen); {и самого солт-значения}
if not stream then {если шифр - блочный}
begin
//генерируем IV
keyLen := 512; {размер буфера "с запасом"}
// запрос IV ради выяснения его размера
CryptGetKeyParam(SessionKey, KP_IV, @buf, @keyLen, 0);
CryptGenRandom(hProv, keyLen, @buf); {генерация IV}
CryptSetKeyParam(SessionKey, KP_IV, @buf, 0);
BlockWrite(outfile, keyLen, 4); {запись в файл размера IV}
BlockWrite(outfile, buf, keyLen); {и самого IV}
end;
reset(infile, 1);
while not eof(infile) do
begin {собственно шифрование и запись в файл}
BlockRead(infile, buf, 496, keyLen);
CryptEncrypt(SessionKey, 0, eof(infile), 0, @buf, @keyLen, 512);
BlockWrite(outfile, buf, keyLen);
end;
CloseFile(infile);
CloseFile(outfile);
CryptDestroyKey(SessionKey);
end
else {расшифровывание}
begin {получаем дескриптор своего ключа обмена ключами}
CryptGetUserKey(hProv, AT_KEYEXCHANGE, @KeyExchKey);
OpenDlg.Title := 'Укажите файл с зашифрованными данными';
if OpenDlg.Execute then
AssignFile(infile, OpenDlg.FileName)
else
exit;
reset(infile, 1);
BlockRead(infile, keyLen, 4); {читаем размер ключа}
GetMem(tmp, keyLen);
BlockRead(infile, tmp^, keyLen); {читаем сам ключ}
CryptImportKey(hProv, tmp, keyLen, KeyExchKey, 0, @SessionKey);
FreeMem(tmp, keyLen);
CryptDestroyKey(KeyExchKey);
BlockRead(infile, keyLen, 4); {читаем солт-значение}
BlockRead(infile, buf, keyLen);
CryptSetKeyParam(SessionKey, KP_SALT, @buf, 0);
keyLen := 4; {выясняем алгоритм шифрования}
CryptGetKeyParam(SessionKey, KP_ALGID, @alg, @keyLen, 0);
case alg of
CALG_RC2: stream := false;
CALG_RC4: stream := true;
end;
if not stream then {если шифр - блочный}
begin
//читаем и устанавливаем IV
BlockRead(infile, keyLen, 4);
BlockRead(infile, buf, keyLen);
CryptSetKeyParam(SessionKey, KP_IV, @buf, 0);
end;
SaveDlg.Title := 'Задайте имя файла для расшифрованных данных';
if SaveDlg.Execute then
begin
AssignFile(outfile, SaveDlg.FileName);
rewrite(outfile, 1);
while not eof(infile) do
begin {собственно расшифровывание}
BlockRead(infile, buf, 512, keyLen);
CryptDecrypt(SessionKey, 0, eof(infile), 0, @buf, @keyLen);
BlockWrite(outfile, buf, keyLen);
end;
CloseFile(outfile);
end;
CloseFile(infile);
CryptDestroyKey(SessionKey);
end;
CryptReleaseContext(hProv, 0);
end;
В рассмотренной нами процедуре обмена шифрованными сообщениями остается одно слабое звено - обмен открытыми ключами. Ведь при этом мы не обеспечиваем подлинность полученного ключа - во время пересылки его может подменить злоумышленник. CryptoAPI для решения этой проблемы предполагает использование сертификатов. Но об этом - в следующий раз.
Алгоритм шифрование XOR.
| Призвали как-то одного волосатого админа в армию служить, на границу. Поставили его в дозор. Вдруг админ слышит шаги... - Стой! Пароль!.. ответ из темноты: - Владивосток... - Логин... - ?!.. |
program Crypt;
{$APPTYPE CONSOLE}
uses Windows;
var
key, text, longkey, result : string;
i : integer;
toto, c : char;
F : TextFile;
begin
writeln('Enter the key:');
readln(key);
writeln('Enter the text:');
readln(text);
for i := 0 to (length(text) div length(key)) do
longkey := longkey + key;
for i := 1 to length(text) do
begin
// XOR алгоритм
toto := chr((ord(text[i]) xor ord(longkey[i])));
result := result + toto;
end;
writeln('The crypted text is:');
writeln(result);
write('Should i save it to result.txt ?');
read(c);
if c in ['Y','y'] then
begin
AssignFile(F,'result.txt');
Rewrite(F);
Writeln(F,result);
CloseFile(F);
end;
end.
|
Алгоритм LZ-78.
| 1999 год. По Интернету объявлен конкурс на лучшего хакера. Поступает 200 заявок на участие. Жюри объявляет бой между всеми "до первой ошибки". В процессе боя участники начинают выбывать. Потом в координационном центре начинают раздаваться звонки и грустный голос из трубки сообщает от имени всех кроме одного участника, называя их ники и пасворды, что мол, та и так, я сдаюсь. В итоге все начинают думать, что "самый крутой хакер" взломал пароли всех участников. Ему сообщают о победе, и спрашивают: - Как ему удалось так быстро добиться победы? Он и ответил: - Извините, но мне просто было лень 199 раз ошибаться. |
Однако классический алгоритм Хаффмана обладает рядом недостатков. Во-первых, распаковщику для корректной работы необходима таблица кодов для символов, которую упаковщик строит в процессе сжатия. Следовательно, ее необходимо добавлять к сжатым данным, тем самым увеличивая размер заархивированного файла. Во-вторых, требуется два просмотра сжимаемого файла: первый для построения требуемой таблицы, а второй уже для сжатия. Избавиться от этих недостатков позволяет алгоритм адаптивного кодирования все по тому же Хаффману. Но о нем (если вас это заинтересует) мы поговорим позже.
В данной же статье мы рассмотрим идею, лежащую в основе алгоритмов семейства LZ-78 (L и Z - первые буквы фамилий Лемпеля и Зива, разработчиков первого LZ-алгоритма, 78 - год публикации) на примере широко известного алгоритма LZW (Лемпеля-Зива-Уэлча). Методы данного семейства относятся к словарным методам, в основе работы которых лежит принцип "повторения старого". Эти методы выделяют во входных данных повторяющиеся строки и заменяют их определенными кодами. Упомянутый же метод Хаффмана относится к статистическим методам, работающим по принципу "сокращения частого".
Итак, приступаем. Что нам понадобится для работы? Во-первых, данные, которые мы будем сжимать. Во-вторых, нам понадобится словарь, в котором мы будем хранить закодированные строки. Размер словаря выбирают равным целой степени двойки, обычно используют словари размером от 210 до 214 гнезд. В гнезда словаря мы будем заносить повторяющиеся строки, причем по номеру гнезда мы сразу сможем определить код данной строки (он будет равен номеру гнезда минус 1). Сразу отметим, что, хотя число кодов у нас равно размеру словаря, но для кодирования повторяющихся строк мы будем использовать на два кода меньше, поскольку последние два кода мы зарезервируем для служебных целей (о них поговорим чуть позже). После выбора размера словаря нам необходимо перед непосредственно архивированием провести инициализацию словаря, занеся в его первые гнезда все односимвольные строки. Их количество зависит от типа входных данных. В самом общем случае будут заполнены первые 256 гнезд словаря (т. е. в него мы занесем всю стандартную таблицу ASCII-символов). Но если известна особенность входных данных, предполагающая ограничение диапазона возможных символов, то количество инициализируемых гнезд может быть уменьшено.
Переходим теперь непосредственно к сжатию. Будем читать по одному символу входных данных, добавляя их в конец строки S (изначально пустой). При этом после каждого добавления будем проверять, есть ли полученная строка S в нашем словаре. В случае, если такая строка в словаре уже присутствует, то мы продолжим чтение входных данных. В противном случае (строки нет в словаре) выполняем следующие действия. Строку S можно представить в виде S'c, где c - последний добавленный символ, а S' - предшествующая ему строка, уже содержащаяся в словаре. Тогда в архив мы записываем код, соответствующий строке S', а в следующее пустое гнездо словаря добавляем строку S. После чего оставляем в строке S только последний прочитанный символ c и продолжаем процесс чтения входных данных.
Вот, в принципе, и весь алгоритм LZW. Упомянем еще о некоторых важных моментах. Если вы помните, мы зарезервировали два кода для служебных целей. Речь сейчас пойдет именно о них. Первый из этих кодов будем использовать в качестве признака завершения сжатия. При упаковке нескольких файлов в один архив необходимо по окончанию сжатия каждого файла записать данный код (иначе как распаковщик узнает, где заканчивается один файл и начинается другой?). Второй код - это код очистки словаря. Какого бы размера вы не взяли словарь, все равно найдутся такие данные, при сжатии которых словарь будет полностью заполнен в процессе архивирования. В этом случае можно либо "заморозить словарь" (т. е. прекратить добавлять в него новые строки), либо очистить его (записав в архив код очистки), причем можно очистить словарь как полностью (т. е. привести его в проинициализированное состояние), либо частично.
По такому принципу работает упаковщик. Вкратце опишем алгоритм работы распаковщика. После инициализации словаря (процессы инициализации у упаковщика и распаковщика должны быть полностью идентичны!) читается первый код из сжатых данных, и соответствующая ему строка выводится в разархивируемый файл. Следующие действия повторяются циклически до тех пор, пока не будет встречен признак завершения сжатия. Сохраняем прочитанный код как "старый". Читаем следующий код. Если такой код уже есть в словаре, то мы в разархивируемый файл выводим строку S, соответствующую этому коду, а в словарь добавляем строку вида S'K, где S' - это строка старого кода, а K - первый символ строки S. Если же в словаре прочитанного кода еще нет, то мы в разархивируемый файл выводим строку S'K' (K' - первый символ S') и эту же строку добавляем в словарь.
Ну ладно, хватит теории. Теория без практики мертва. Поэтому давайте рассмотрим на простеньком примере, как же работает алгоритм LZW. Возьмем, к примеру, текст "Мама мыла раму. Раму мыла мама". Словарь инициализируем всеми символами ASCII-таблицы, так что кодом для символа будет его порядковый номер в этой таблице.
Процесс сжатия представим таблицей (в третьем столбце в скобках указан номер гнезда, соответствующий строке S):
| Прочитанный символ. | Строка S. | Строка в словаре. | Пишем в архив. | Добавляем строку с кодом. |
| 'М' | 'М' | Есть (140). | ||
| 'а' | 'Ма' | Нет. | 140. | 'Ма' 256. |
| 'м' | 'ам' | Нет. | 160. | 'ам' 257. |
| 'а' | 'ма' | Нет. | 172. | 'ма' 258. |
| ' ' | 'а ' | Нет. | 160. | 'а ' 259. |
| 'м' | ' м' | Нет. | 32. | 'м' 260. |
| 'ы' | 'мы' | Нет. | 172. | 'мы' 261. |
| 'л' | 'ыл' | Нет. | 235. | 'ыл' 262. |
| 'а' | 'ла' | Нет. | 171. | 'ла' 263. |
| ' ' | 'а ' | Есть (259). | ||
| 'р' | 'а р' | Нет. | 259. | 'а р' 264. |
| 'а' | 'ра' | Нет. | 224. | 'ра' 265. |
| 'м' | 'ам' | Есть (257). | ||
| 'у' | 'аму' | Нет. | 257. | 'аму' 266. |
| '.' | 'у.' | Нет. | 227. | 'у.' 267. |
| ' ' | '. ' | Нет. | 46. | '. ' 268. |
| 'Р' | ' Р' | Нет. | 32. | ' Р' 269. |
| 'а' | 'Ра' | Нет. | 144. | 'Ра' 270. |
| 'м' | 'ам' | Есть (257). | ||
| 'у' | 'аму' | Есть (266). | ||
| ' ' | 'аму ' | Нет. | 266. | 'аму ' 271. |
| 'м' | ' м' | Есть (260). | ||
| 'ы' | ' мы' | Нет. | 260. | ' мы' 272. |
| 'л' | 'ыл' | Есть (262). | ||
| 'а' | 'ыла' | Нет. | 262. | 'ыла' 273. |
| ' ' | 'а ' | Есть (259). | ||
| 'м' | 'а м' | Нет. | 259. | 'а м' 274. |
| 'а' | 'ма' | Есть (258). | ||
| 'м' | 'мам' | Нет. | 258. | 'мам' 275. |
| 'а' | 'ма' | Есть (258). | ||
| '.' | 'ма.' | Нет. | 258. | 'ма.' 276. |
| Конец данных. | . | 46. |
И еще несколько слов. Во-первых, как можно заметить, строки, хранимые в словаре, обладают определенной особенностью: если в словаре есть строка S длины N, то должны быть также и строки длины 1, 2, ... , k, ... , N-1, состоящие из k первых символов строки S (таким образом, словарь у нас обладает свойством префиксности). Что же из этого следует? Во-первых, в словаре можно хранить строку S не полностью, а как указатель на строку, состоящую из первых N-1 символа строки S плюс последний символ, обеспечивающий ее уникальность. Во-вторых, данная особенность влияет на поиск строки в словаре. Так что когда мы ищем в словаре строку S длины N, то нам нет необходимости просматривать весь словарь. Мы начнем наш поиск со следующего за содержащим строку S' гнезда. Во-вторых, мы не сказали ни слова о размере нашего словаря. Давайте посмотрим, какие бы результаты сжатия у нас получились, если бы размер словаря был равен 1024 (210, 10-битовый код) или 8192 (212, 12-битовый код) гнезд. Длина нашего примера - 31 символ. Так как каждый символ кодируется 8 битами, то исходный текст должен был занимать 31*8=241 бит. В архив мы записали 23 кода (22 кода для строк, последний - признак окончания сжатия). Таким образом, в первом случае размер архива у нас будет 23*10=230 бит, а во втором - 23*12=276 бит. Что же получается - в первом случае мы действительно сжали текст, а во втором, наоборот, увеличили? Да, возможно и такое. Однако из этого не следует, что словарь нужно брать меньшего размера. Просто текст, взятый нами для примера, имел небольшую длину, да и повторяющиеся строки встречались не так уж и часто. Естественно, на больших объемах данных алгоритм все таки сожмет их.
Вот, в принципе, и все, что касается метода LZW. Отличие других методов семейства LZ-78 (среди них - MW, AP, Y) заключается в способе добавления новых строк в словарь. В частности, метод MW добавляет в словарь не строку S, как метод LZW, а конкатенацию строк S' и P' (S' - это подстрока строки S, уже имеющаяся в словаре, а P' - аналогичная строка для предыдущего добавления в словарь). Метод AP добавляет в словарь уже не одну строку, а множество строк AP(P',S'), т. е. все префиксы строки P'S'.
Crystal Reports 8.0 через API.
Автор: Андрей Зубарев Специально для Королевства Delphi ВступлениеCrystal Reports (далее как CR) на сегодняшний день является лидирующим пакетом для разработки отчетности в крупных компаниях. Для доступа к отчетам компания Seagate предоставляет несколько вариантов:
Элемент управления Crystal ActiveX Компонент Report Designer Component Компоненты VCL сторонних разработчиков. Automation Server Вызовы API реализуются через Report Engine API (далее RE).По моему мнению, лучшим является доступ посредством API функций, т.к.:
вы полностью контролируете все, что происходит. узнаете, как все это работает. не зависите от фирмы разработчика компонент и их версий. не платите денег (хотя этот момент расплывчат J). В 90% случаев необходимо только вывести отчет и передать входящие параметры, т.е. вы получаете "тонкое" приложения на основе своих же наработок, что согласитесь, греет душу программиста. Предполагается, что читатель знаком с работой в Crystal Reports и понимает концепцию разработки отчетов в данной среде.Необходимые файлы
Библиотека [crpe32.dll] содержит интерфейс вызовов API функций. Модуль [uCrystalApi.pas] с описаниями API функций. Он был подправлен мной, так как было несколько синтаксических ошибок. Для работы примера необходим источник данных, в качестве которого используется демонстрационная БД MS Access 2000 [source_db.mdb]. В качестве драйвера связи используется OLE DB для MS Jet 4.0. БД должна находиться в той же папке, где и пример отчета. Если вы хотите распространять ваше приложение с отчетами, тогда ознакомьтесь с содержимым файла [crpe32.dep], который содержит список необходимых файлов для работы RE. Пример реализован на Delphi 6.0. Программируем Первым надо "запустить машину" CR, посредством вызова функции PEOpenEngine для инициализации механизма отчетов. Надо заметить, что вызов данной функции справедлив только для одного потока.Теперь можно и начать подготовку отчета для вывода. Вызов PEOpenPrintJob дает нам дескриптор задачи (отчета), который необходимо передавать в другие функции.
// Синтаксис функции
PEOpenPrintJob(PathToReport: PChar): SmallInt;
{
где,
PathToReport - путь к файлу отчета.
Результат функции - дескриптор полученной задачи.
Пример:
FHandleJob := PEOpenPrintJob(PChar(edtPathReport.Text));
}
|
Далее необходимо сказать системе, куда выводить отчет: в окно предварительного просмотра (…ToWindow) или на принтер (…ToPrinter).
// Синтаксис функций:
PEOutputToWindow(printJob : Smallint; title: PChar;
left: Integer; top: Integer;
width: Integer; height: Integer;
style: DWord;
parentWindow : HWnd): Bool;
PEOutputToPrinter(printJob: Word;
nCopies: Integer)): Bool;
{
где,
printJob - дескриптор задачи
title - заголовок окна
left, top, width, height - координаты окна
style - стиль окна (типа WS_VSCROLL, WS_VISIBLE и т.д.)
parentWindow - дескриптор окна в котором будет окно отчета.
nCopies - количество копий.
Пример:
Result:= PEOutputToWindow(FHandleJob,
PChar(TForm(Self).Caption),
0, 0, 0, 0, 0, FWindow);
}
|
Подготовив механизм вывода отправляем отчет для вывода функцией PEStartPrintJob.
// Синтаксис функции:
function PEStartPrintJob(printJob: Word;
waitUntilDone: Bool): Bool;
{
где,
printJob - дескриптор задачи.
WaitUntilDone - зарезервирован. Всегда должен быть True.
Пример:
PEStartPrintJob(FHandleJob, True);
}
|
После отправки отчета, если не надо производить с ним операций, закрываем задание функцией PEClosePrintJob.
// Синтаксис функции:
function PEClosePrintJob (printJob: Word): Bool;
{
где,
printJob - дескриптор задачи.
Пример:
PEClosePrintJob(FHandleJob);
}
|
В итоге получается схема вызовов:
PEOpenEngine
|
PEOpenPrintJob
|
PEOutputToWindow
|
PEStartPrintJob
|
PEClosePrintJob
|
PECloseEngine
Пример просмотра отчета
Ниже приведен код процедуры для просмотра отчета из примера.
procedure TFrmMain.btnReportPreviewClick(Sender: TObject);
var
// Дескриптор окна в котором производится просмотр отчета
FWindow: THandle;
// Информация об источнике данных.
// См. раздел "Получение параметров и свойств источника"
lt: PELogOnInfo;
begin
// В зависимости от флага устанавливаем дескриптор окна.
// При нуле, отчет будет показан в независимом внешнем окне.
if chkWindow.Checked then
FWindow := 0
else
FWindow := pnlPreview.Handle;
// Открываем отчет и получаем дескриптор задачи.
FHandleJob := PEOpenPrintJob(PChar(edtPathReport.Text));
// Получение параметров источника данных отчета.
FillChar(lt, SizeOf(PELogOnInfo), 0);
lt.StructSize := SizeOf(PELogOnInfo);
PEGetNthTableLogOnInfo(FHandleJob, 0, lt);
// Устанавливаем новые параметры источника данных отчета.
StrPCopy(@lt.ServerName, ExtractFilePath(edtPathReport.Text) +
'source_db.mdb');
PESetNthTableLogOnInfo(FHandleJob, 0, lt, False);
// Настраиваем окно вывода.
PEOutputToWindow(FHandleJob, PChar(TForm(Self).Caption), 0, 0, 0, 0, 0,
FWindow);
// Выводим отчет.
PEStartPrintJob(FHandleJob, True);
// Закрываем дескриптор задания.
PEClosePrintJob(FHandleJob);
end;
|
Получение свойств через функцию довольно просто. Описываем структуру данных, передаем дескриптор задачи и порядковый номер таблицы. После вызова функции получаем заполненную структуру параметров.
// Синтаксис функции:
function PEGetNthTableLogOnInfo
(printJob: Word;
tableN: Integer;
var logOnInfo: PELogOnInfo): Bool;
{
где,
printJob - дескриптор задачи.
tableN - номер таблицы.
location - струкура со свойствами источника.
Пример:
PEGetNthTableLogOnInfo(FHandleJob, 0, lt);
}
|
Структура PELogOnInfo содержит свойства источника. Перед ее передачей в функцию обязательно заполните поле StructSize. Например:
// Чистим структуру. FillChar(lt, SizeOf(PELogOnInfo), 0); // Заполняем поле размера. lt.StructSize := SizeOf(PELogOnInfo); // Вызываем функцию для таблицы с порядковым номером 0 (ноль) PEGetNthTableLogOnInfo(FHandleJob, 0, lt); |
Описание структуры:
type
PELogonServerType = array[0..PE_SERVERNAME_LEN - 1] of Сhаг;
PELogonDBType = array[0..PE_DATABASENAME_LEN - 1] of Сhаг;
PELogonUserType = array[0..PE_USERID_LEN - 1] of Сhаг;
PELogonPassType = array[0..PE_PASSWORD_LEN - 1] of Сhаг;
PELogOnInfo = record
StructSize: Word;
ServerName: PELogonServerType;
DatabaseName: PELogonDbType;
UserId: PELogonUserType;
Password: PELogonPassType;
end;
{
где,
StructSize - размер структуры.Заполняется обязательно.
ServerName - имя сервера или путь к файлу БД.
DatabaseName - имя БД.
UserId - пользователь.
Password - пароль пользователя.
}
|
Функция установки параметров PESetNthTableLogOnInfo аналогично предыдущей (в смысле параметров, а действует наоборот - устанавливает новые свойства источника). У данной функции есть один дополнительный логический параметр propagateAcrossTables, который указывает как обработать информацию из структуры PELogOnInfo. Если значение параметра TRUE, тогда свойства из структуры применяются для всех таблиц в отчете, иначе только для таблицы с с номером tableN. Например:
// Скопировать в поле ServerName путь к БД отчета. StrPCopy(@lt.ServerName, ExtractFilePath(edtPathReport.Text) + 'source_db.mdb'); // Установить параметры для таблицы 0 и только для нее. PESetNthTableLogOnInfo(FHandleJob, 0, lt, False); |
Функция PEGetNParameterFields имеет только один параметр - дескриптор задачи, в результате возвращается количество параметров. В примере показано как работать с параметрами:
var
ParameterInfo: PEParameterFieldInfo;
ValueInfo: PEValueInfo;
...
// Получить количество параметров.
CountParams := PEGetNParameterFields(FHandleJob);
if CountParams <> -1 then
begin
for i := 0 to CountParams - 1 do
begin
// Запросить информацию о параметре i.
PEGetNthParameterField(FHandleJob, i, ParameterInfo);
ValueInfo.ValueType := ParameterInfo.valueType;
// Получить значение параметра.
PEConvertPFInfoToVInfo(@ParameterInfo.DefaultValue,
ValueInfo.ValueType,
ValueInfo);
...
end;
end;
|
Описания структур довольно большие, поэтому я опишу только те поля которые используются в примере.
ParameterInfo.Name // - имя параметра. ParameterInfo.ValueType // - тип данных параметра. ParameterInfo.DefaultValue // - значение по умолчанию. |
В будущем я надеюсь развить тему CR более углубленно, но это зависит от интереса читателей и наличия времени :-).
Импорт CSV ASCII.
Автор: Dave
unit Cdbascii;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, DbiErrs, DbiTypes, DbiProcs, DB, DBTables;
type
TAsciiDelimTable = class(TTable)
private
{ Private declarations }
fQuote: Char;
fDelim: Char;
protected
{ Protected declarations }
function CreateHandle: HDBICur; override;
procedure SetQuote(newValue: Char);
procedure SetDelim(newValue: Char);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{ Эти свойства не должны больше публиковаться }
property IndexFieldNames;
property IndexName;
property MasterFields;
property MasterSource;
property UpdateMode;
published
{ Published declarations }
property Quote: Char read fQuote write setQuote default '"';
property Delim: Char read fDelim write setDelim default ',';
end;
procedure Register;
implementation
uses DBConsts;
procedure Register;
begin
RegisterComponents('Data Access', [TAsciiDelimTable]);
end;
constructor TAsciiDelimTable.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Exclusive := True;
TableType := ttASCII;
fQuote := '"';
fDelim := ',';
end;
destructor TAsciiDelimTable.Destroy;
begin
inherited Destroy;
end;
{ Рабочий код }
function CheckOpen(Status: DBIResult): Boolean;
begin
case Status of
DBIERR_NONE:
Result := True;
DBIERR_NOTSUFFTABLERIGHTS:
begin
if not Session.GetPassword then
DbiError(Status);
Result := False;
end;
else
DbiError(Status);
end;
end;
function TAsciiDelimTable.CreateHandle: HDBICur;
const
OpenModes: array[Boolean] of DbiOpenMode = (dbiReadWrite, dbiReadOnly);
ShareModes: array[Boolean] of DbiShareMode = (dbiOpenShared, dbiOpenExcl);
var
STableName: array[0..SizeOf(TFileName) - 1] of Char;
SDriverType: array[0..12] of Char;
begin
if TableName = '' then
DBError(SNoTableName);
AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1);
StrPCopy(SDriverType, 'ASCIIDRV-' + Quote + '-' + Delim);
Result := nil;
while not CheckOpen(DbiOpenTable(DBHandle, STableName, SDriverType,
nil, nil, 0, OpenModes[ReadOnly], ShareModes[Exclusive],
xltField, False, nil, Result)) do {Повтор}
;
end;
procedure TAsciiDelimTable.SetQuote(newValue: Char);
begin
if Active then
{ DBError(SInvalidBatchMove); };
fQuote := newValue;
end;
procedure TAsciiDelimTable.SetDelim(newValue: Char);
begin
if Active then
{ DBError(SInvalidBatchMove); };
fDelim := newValue;
end;
end.
|
Быстрая обработка CSV файла.
| На борту самолета: - Здравствуйте, дамы и господа, - говорит командир экипажа. - Мы благодарим вас за то, что вы выбрали нашу авиакомпанию для первого полета в первый день нового 2000 года. Мы находимся на высоте 3 тыс. футов, наша скорость... вау!... ох, блин!... вот фак!... Извините за неудобства, которые вы испытываете, находясь вниз головой, надеюсь, все были пристегнуты. Есть ли среди пассажиров на борту программист? |
Классы Tstrings/TStringlist имеют свойство commatext, которое автоматически разделяет строки, содержащие разделители, на отдельные части. Пример показывает как считать CSV файл. В Конечном итоге, автоматически разделённые строки содержатся в TStringlist.
var
ts: tstringlist;
S: string;
Tf: Textfile;
begin
Ts := Tstringlist.create;
Assignfile(tf, 'filename');
Reset(tf);
while not eof(tf) do
begin
Readln(tf,S);
Ts.CommaText := S;
//ProcessLine;
end;
closefile(tf);
ts.free;
end;
|
Так же операцию можно производить в обратном порядке.
Свойство Commatext поддерживает разделители как в виде запятых, так и двойных кавычек: 1,2,3,4 и "1","2","3","4".
Например, строка вида "1","2,3","4" будет разделена на три элемента, которые заключены в кавычки (средняя запятая будет проигнорирована). Чтобы включить кавычку в конечный результ, нужно поставить две кавычки подряд: "1",""2" (результат будет 1 и "2 ).
Конвертировать CSV файл в XML.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
> I am trying to write an application that converts a CSV(or similar)it to > an XML one.The application looks for a character(the comma - - or anything > else specified in an Edit box - -), adds a starting and ending tag to the > line, and writes the line to the new XML file. in the end I should get an > XML file with the various elements.
{Your task has a number of subtasks.
The first is parsing the input file into lines. You can leave that to a
Tstringlist, if the files you need to handle are not in the
multimegabyte size range. If they are you would be best served by using
the good old Pascal Textfile routines, where a simple ReadLn( filevar, S
) gets you a line.
The second is parsing a line into its elements, based on a separator
character between the elements. This is also not so difficult to do,
especially if you don't need to deal with quoted elements that may
contain the separator. Search the newsgroup archives for "SplitString"
for an example. Tstringlist.Delimitedtext may be of use here, but be
warned that it considers any character <= #32 as a separator *in
addition* to what you define as Delimiter. It can deal with quoted
elements, though.
The second subtask would end with a TStringlist instance containing the
elements to store into the XML file for one line of the input file. This
is the input for the third task: to create a first-level XML element
containing the data. To write valid XML you need not only deal with
proper nesting of XML tags, you also have to properly represent some
characters that have special meaning in XML ('<' and '&' for instance).
I can recommend Berend de Boers xml_generator class
http://www.pobox.com/~berend/delphi for this task, it deals with all the
nastiness behind the scenes and produces syntactically correct XML
without the overhead of a DOM model implementation.
There is something else you need: a list of column names, one name for
each "column" in your XML file. These names will become the node names
for the subnodes of the produced XML. Depending on your input files you
may be able to get these names from the first line (which often is a
header line giving the column names).
Here is sketch (untested!) of the conversion routine: }
type
{: Callback for CSVToXML. If given the callback will be called
after each processed line.
@Param currentline is the 0-based number of the processed line
@Param totallines is the total number of lines. This may be a
raw estimate if the file is not completly loaded in memory.
@Returns true to continue processing, false to stop it. }
TProgressNotification =
function(currentline, totallines: Integer): Boolean of object;
{-- CSVToXML ----------------------------------------------------------}
{: Convert a delimiter-separated file of data to XML
@Param csvfilename is the file to convert
@Param xmlfilename is the xml file to create
@Param aSeparator is the separator for the data
@Param aRootNodeName is the name to use for the root node of the XML
file.
@Param columnnames is an optional list of column names to use as subnode
names. If this parameter is nil the first line of the data file must
contain a header line with the names to use.
@Param onProgress is an optional callback to call afte each processed
line.
@Precondition csvfilename exists
}{ Created 17.3.2003 by P. Below
-----------------------------------------------------------------------}
procedure CSVToXML(const csvfilename, xmlfilename: string;
const aSeparator: Char;
const aRootNodeName: string;
const columnnames: TStrings = nil;
const onProgress: TProgressNotification = nil);
function DoProgress(currentline, totallines: Integer): Boolean;
begin
if Assigned(onProgress) then
Result := onProgress(currentline, totallines)
else
Result := true;
end;
procedure WriteDataline(const line: string; header: TStringlist; xml: TXMLGenerator);
var
elements: TStringlist;
i, max: Integer;
begin
elements := TStringlist.Create;
try
elements.Delimiter := aSeparator;
elements.Delimitedtext := line;
if elements.count > header.count then
max := header.count
else
max := elements.count;
for i := 0 to max - 1 do begin
xml.StartTag(header[i]);
xml.AddData(elements[i]);
xml.StopTag;
end; { For }
finally
elements.Free;
end;
end;
procedure WriteData(data: TStringlist; xml: TXMLGenerator);
var
header: TStringlist;
firstline: Integer;
i: Integer;
begin
header := Tstringlist.Create;
try
firstline := 0;
if assigned(columnnames) then
header.Assign(columnnames)
else begin
header.Delimiter := aSeparator;
header.DelimitedText := data[0];
firstline := 1;
end; { Else }
for i := firstline to data.count - 1 do begin
WriteDataline(data[i], header, xml);
if not DoProgress(i, data.count) then
Break;
end; { For }
finally
header.Free;
end;
end;
procedure SaveStringToFile(const S, filename: string);
var
fs: TFilestream;
begin
fs := TFileStream.Create(filename, fmCreate);
try
if Length(S) > 0 then
fs.WriteBuffer(S[1], Length(S));
finally
fs.free
end;
end; { SaveStringToFile }
var
xml: TXMLGenerator; // from xml_generator unit by Berend de Boers
datafile: Tstringlist;
begin { CSVToXML }
if not FileExists(csvfilename) then
raise Exception.CreateFmt('Input file %s not found', [csvfilename]);
datafile := Tstringlist.Create;
try
datafile.LoadfromFile(csvfilename);
xml := TXMLGenerator.CreateWithEncoding(16 * 1024, encISO_8859_1);
try
xml.StartTag(aRootNodeName);
if datafile.count > 0 then
WriteData(datafile, xml);
xml.StopTag;
SaveStringToFile(xml.AsLatin1, xmlfilename);
finally
xml.Free;
end;
finally
datafile.free;
end;
end; { CSVToXML }
Симулировать нажатие клавиш для копии и вставки из буфера.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
//Ctrl+C, Strg+C:
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);
keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), 0, 0);
keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0)
//Ctrl+V, Strg+V:
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);
keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), 0, 0);
keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0)
Денежное поле редактирования.
| Приходит программист в библиотеку и говорит: - Позовите мне архивариуса! Мне надо его спросить! - Я его отправил в архив. Могу я вам помочь? - Разархивируйте его, он мне срочно нужен! |
unit CurrEdit;
interface
uses
SysUtils,
WinTypes,
WinProcs,
Messages,
Classes,
Graphics,
Controls,
Menus,
Forms,
Dialogs,
StdCtrls;
type
TCurrencyEdit = class(TCustomMemo)
private
DispFormat: string;
FieldValue: Extended;
procedure SetFormat(A: string);
procedure SetFieldValue(A: Extended);
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure FormatText;
procedure UnFormatText;
protected
procedure KeyPress(var Key: Char); override;
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
published
property Alignment default taRightJustify;
property AutoSize default True;
property BorderStyle;
property Color;
property Ctl3D;
property DisplayFormat: string read DispFormat write SetFormat;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property Value: Extended read FieldValue write SetFieldValue;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Additional', [TCurrencyEdit]);
end;
constructor TCurrencyEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoSize := True;
Alignment := taRightJustify;
Width := 121;
Height := 25;
DispFormat := '$,0.00;($,0.00)';
FieldValue := 0.0;
AutoSelect := False;
WantReturns := False;
WordWrap := False;
FormatText;
end;
procedure TCurrencyEdit.SetFormat(A: string);
begin
if DispFormat <> A then
begin
DispFormat := A;
FormatText;
end;
end;
procedure TCurrencyEdit.SetFieldValue(A: Extended);
begin
if FieldValue <> A then
begin
FieldValue := A;
FormatText;
end;
end;
procedure TCurrencyEdit.UnFormatText;
var
TmpText: string;
Tmp: Byte;
IsNeg: Boolean;
begin
IsNeg := (Pos('-', Text) > 0) or (Pos('(', Text) > 0);
TmpText := '';
for Tmp := 1 to Length(Text) do
if Text[Tmp] in ['0'..'9', '.'] then
TmpText := TmpText + Text[Tmp];
try
FieldValue := StrToFloat(TmpText);
if IsNeg then
FieldValue := -FieldValue;
except
MessageBeep(mb_IconAsterisk);
end;
end;
procedure TCurrencyEdit.FormatText;
begin
Text := FormatFloat(DispFormat, FieldValue);
end;
procedure TCurrencyEdit.CMEnter(var Message: TCMEnter);
begin
SelectAll;
inherited;
end;
procedure TCurrencyEdit.CMExit(var Message: TCMExit);
begin
UnformatText;
FormatText;
inherited;
end;
procedure TCurrencyEdit.KeyPress(var Key: Char);
begin
if not (Key in ['0'..'9', '.', '-']) then
Key := #0;
inherited KeyPress(Key);
end;
procedure TCurrencyEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
case Alignment of
taLeftJustify: Params.Style := Params.Style or ES_LEFT and not ES_MULTILINE;
taRightJustify: Params.Style := Params.Style or ES_RIGHT and not
ES_MULTILINE;
taCenter: Params.Style := Params.Style or ES_CENTER and not ES_MULTILINE;
end;
end;
end.
|
Как узнать имя файла текущего процесса.
Для этого существует функция GetModuleFileName, которая возвращает имя файла текущего процесса.
function GetModName: string;
var
fName: string;
nsize: cardinal;
begin
nsize := 128;
SetLength(fName, nsize);
SetLength(fName,
GetModuleFileName(
hinstance,
pchar(fName),
nsize));
Result := fName;
end;
|
Текущий модуль и проект.
Автор: Dr. Bob Компонент во время проектирования может знать имена текущих модулей и имя проекта. Все это можно получить с помощью ToolServices (см. файл TOOLINTF.PAS) Имя текущего проекта можно получить с помощью вызова GetProjectName, список модулей/форм - с помощью функции GetUnitCount, которая возвратит количество модулей и затем с помощью GetUnitName(i) мы можем получить имя каждого модуля (также и с формами).Вот примерный образец кода (получение и запись имен всех модулей/форм в StringGrid и имени проекта в Label):
procedure TInformationFrm.FormActivate(Sender: TObject);
{ необходимо: StringGrid1 (2 колонки, масса строк), Label1, Label2 }
var
i, j: Integer;
Tmp: string;
begin
StringGrid1.Cells[0, 0] := 'модулей:';
StringGrid1.Cells[1, 0] := 'форм:';
if ToolServices <> nil then
with ToolServices do
begin
Label1.Caption := ExtractFileName(GetProjectName); { простое имя }
Label2.Caption := GetProjectName; { полное правильное имя пути }
for i := 0 to GetUnitCount do
begin
Tmp := ExtractFileName(GetUnitName(i));
StringGrid1.Cells[0, i + 1] := Tmp;
Tmp := ChangeFileExt(Tmp, '.DFM');
for j := 0 to GetFormCount do
if ExtractFileName(GetFormName(j)) = Tmp then
StringGrid1.Cells[1, i + 1] := Tmp
end;
end;
end;
|
Включить изображение курсора в снимок экрана.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// 1. Get the handle to the current mouse-cursor and its position
function GetCursorInfo2: TCursorInfo;
var
hWindow: HWND;
pt: TPoint;
pIconInfo: TIconInfo;
dwThreadID, dwCurrentThreadID: DWORD;
begin
Result.hCursor := 0;
ZeroMemory(@Result, SizeOf(Result));
// Find out which window owns the cursor
if GetCursorPos(pt) then
begin
Result.ptScreenPos := pt;
hWindow := WindowFromPoint(pt);
if IsWindow(hWindow) then
begin
// Get the thread ID for the cursor owner.
dwThreadID := GetWindowThreadProcessId(hWindow, nil);
// Get the thread ID for the current thread
dwCurrentThreadID := GetCurrentThreadId;
// If the cursor owner is not us then we must attach to
// the other thread in so that we can use GetCursor() to
// return the correct hCursor
if (dwCurrentThreadID <> dwThreadID) then
begin
if AttachThreadInput(dwCurrentThreadID, dwThreadID, True) then
begin
// Get the handle to the cursor
Result.hCursor := GetCursor;
AttachThreadInput(dwCurrentThreadID, dwThreadID, False);
end;
end
else
begin
Result.hCursor := GetCursor;
end;
end;
end;
end;
// 2. Capture the screen
function CaptureScreen: TBitmap;
var
DC: HDC;
ABitmap: TBitmap;
MyCursor: TIcon;
CursorInfo: TCursorInfo;
IconInfo: TIconInfo;
begin
// Capture the Desktop screen
DC := GetDC(GetDesktopWindow);
ABitmap := TBitmap.Create;
try
ABitmap.Width := GetDeviceCaps(DC, HORZRES);
ABitmap.Height := GetDeviceCaps(DC, VERTRES);
// BitBlt on our bitmap
BitBlt(ABitmap.Canvas.Handle,
0,
0,
ABitmap.Width,
ABitmap.Height,
DC,
0,
0,
SRCCOPY);
// Create temp. Icon
MyCursor := TIcon.Create;
try
// Retrieve Cursor info
CursorInfo := GetCursorInfo2;
if CursorInfo.hCursor <> 0 then
begin
MyCursor.Handle := CursorInfo.hCursor;
// Get Hotspot information
GetIconInfo(CursorInfo.hCursor, IconInfo);
// Draw the Cursor on our bitmap
ABitmap.Canvas.Draw(CursorInfo.ptScreenPos.X - IconInfo.xHotspot,
CursorInfo.ptScreenPos.Y - IconInfo.yHotspot, MyCursor);
end;
finally
// Clean up
MyCursor.ReleaseHandle;
MyCursor.Free;
end;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
Result := ABitmap;
end;
// Example: Capture the screen and include the cursor.
// Show the Screenshot in Image1
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Assign(CaptureScreen);
end;
Создание курсора с процентом выполнения.
Автор: Роман Василенко WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание курсора с процентом выполнения
Функция возвращает хэндл на созданный курсор Windows (hcursor, hicon)
с процентным соотношением, указанным в min,max и pos.
Своего рода ProgressBar, но только зашитый в курсор.
Зависимости: Windows, SysUtils, Graphics, Classes
Автор: Роман Василенко, romix@nm.ru, Пятигорск
Copyright: Василенко Роман
Дата: 07 мая 2002 г.
***************************************************** }
//Используемые модули
uses Windows, SysUtils, Graphics, Classes;
//Сама функция
function create_prc_cursor(min, max, pos: integer): hicon;
var
cwidth, cheight: integer;
ii: iconinfo;
bmc, bmm: tbitmap;
icon: hicon;
tw: integer;
tx: string;
function int_percent(umin, umax, upos, uabs: integer): integer;
begin
result := 0;
if umax < umin then
exit;
if upos < umin then
exit;
if upos > umax then
begin
result := 100;
exit;
end;
if (umin = upos) and (umax = upos) then
begin
result := 100;
exit;
end;
result := round((upos - umin) / ((umax - umin) / uabs));
end;
function create_curspace: tbitmap;
begin
result := tbitmap.create;
result.pixelformat := pf4bit;
result.width := cwidth;
result.height := cheight;
end;
begin
cwidth := getsystemmetrics(sm_cxcursor);
cheight := getsystemmetrics(sm_cycursor);
bmc := create_curspace;
bmm := create_curspace;
with bmm.Canvas do
begin
brush.color := clwhite;
FillRect(rect(0, 0, bmm.width, bmm.height));
brush.color := clblack;
fillrect(rect(0, bmm.height - 8, bmm.width, bmm.height));
brush.color := clwhite;
framerect(rect(0, bmm.height - 8, bmm.width, bmm.height));
end;
with bmc.canvas do
begin
brush.color := clblack;
FillRect(rect(0, 0, bmc.width, bmc.height));
brush.color := clwhite;
fillrect(rect(1 + int_percent(min, max, pos, bmc.width - 2), bmm.height - 7,
bmc.width - 1, bmc.height - 1));
brush.color := clwhite;
framerect(rect(0, bmc.height - 8, bmc.width, bmc.height));
end;
tx := inttostr(int_percent(min, max, pos, 100)) + '%';
with bmm.canvas do
begin
font.Size := 8;
font.style := [fsbold];
font.color := clwhite;
brush.color := clwhite;
tw := textwidth(tx);
textout((cwidth - tw) div 2, 8, tx);
end;
with bmc.canvas do
begin
font.Size := 8;
font.style := [fsbold];
font.color := clwhite;
brush.color := clblack;
textout((cwidth - tw) div 2, 8, tx);
end;
ii.fIcon := false;
ii.hbmColor := bmc.Handle;
ii.hbmMask := bmm.handle;
ii.xHotspot := 0;
ii.yHotspot := 0;
icon := createiconindirect(ii);
result := copyicon(icon);
destroyicon(icon);
bmc.free;
bmm.Free;
end;
Пример использования:
... screen.cursors[1] := create_prc_cursor(0, 100, 25); screen.cursor := crnone; screen.cursor := 1; ...
Как поместить курсор мышки в нужное место на форме.
uses Windows; procedure PlaceMyMouse(Sender: TForm; X, Y: word); var MyPoint: TPoint; begin MyPoint := Sender.ClientToScreen(Point(X, Y)); SetCursorPos(MyPoint.X, MyPoint.Y); end; |
Определить текущий трэк на CD.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// This will show current track and time.
// Zeigt den aktuellen CD-Track und Zeit an.
uses
MMSystem;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Trk, Min, Sec: Word;
begin
with MediaPlayer1 do
begin
Trk := MCI_TMSF_TRACK(Position);
Min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position);
label1.Caption := Format('%.2d', [Trk]);
Label2.Caption := Format('%.2d:%.2d', [Min, Sec]);
end;
end;
Отслеживать имя текущего компонента.
| - Что общего между Женщиной и Windows? - И с тем, и с другим приходится трахаться. - А в чем различие? - С Женщиной, приятней. Но с Windоws'ом зато без проблем. Нет месячных перерывов и жалоб на головную боль. |
unit FCForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, StdCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
StatusBar1: TStatusBar;
public
procedure CmFocusChanged (var Msg: TCmFocusChanged);
message cm_FocusChanged;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CmFocusChanged (var Msg: TCmFocusChanged);
begin
StatusBar1.SimpleText := Msg.Sender.Name;
end;
end.
|
Загрузить исходный код проекта.
Узнать текущую раскладку клавиатуры в любом активном окне.
Автор: KosilkA WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Узнать текущую раскладку клавиатуры в любом активном окне
возвращает числовое значение соответственно установленной раскладке
Зависимости: windows
Автор: KosilkA, gloom@imail.ru, Koenigsberg
Copyright: delphi help и немного усердия :-)
Дата: 4 декабря 2003 г.
***************************************************** }
if GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, nil)) = 67699721 then
//раскладка английская
else
//раскладка НЕанглийская, например 68748313 соответствует русской
Как можно узнать количество цветов текущего режима.
Автор: Олег КулабуховGetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) * GetDeviceCaps(Form1.Canvas.Handle, PLANES)Для получения общего количества битов, используемых для получения цвета используются следующие значения.
1 = 2 colors bpp 4 = 16 colors bpp 8 = 256 colors bpp 15 = 32768 colors (возвращает 16 на большинстве драйверов) bpp 16 = 65535 colors bpp 24 = 16,777,216 colors bpp 32 = 16,777,216 colors (то же, что и 24) bppВы можете использовать:
NumberOfColors := (1 shl (GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) * GetDeviceCaps(Form1.Canvas.Handle, PLANES));
Для подсчета общего количества используемых цветов.
Получить имя текущего пользователя.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetCurrentUserName: string; const cnMaxUserNameLen = 254; var sUserName: string; dwUserNameLen: DWORD; begin dwUserNameLen := cnMaxUserNameLen - 1; SetLength(sUserName, cnMaxUserNameLen); GetUserName(PChar(sUserName), dwUserNameLen); SetLength(sUserName, dwUserNameLen); Result := sUserName; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(GetCurrentUserName); end;
Получить имя текущего пользователя 2.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetCurrentUserName(var CurrentUserName: string): Boolean;
var
BufferSize: DWORD;
pUser: PChar;
begin
BufferSize := 0;
GetUserName(nil, BufferSize);
pUser := StrAlloc(BufferSize);
try
Result := GetUserName(pUser, BufferSize);
CurrentUserName := StrPas(pUser);
finally
StrDispose(pUser);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
CurrentUserName: string;
begin
GetCurrentUserName(CurrentUserName);
Label1.Caption := CurrentUserName;
end;
{*********************************************}
{
Windows NT/2000/XP:
The GetUserNameEx function retrieves the name of the user or other
security principal associated with the calling thread.
You can specify the format of the returned name.
If the thread is impersonating a client, GetUserNameEx
returns the name of the client.
}
const
NameUnknown = 0; // Unknown name type.
NameFullyQualifiedDN = 1; // Fully qualified distinguished name
NameSamCompatible = 2; // Windows NT® 4.0 account name
NameDisplay = 3; // A "friendly" display name
NameUniqueId = 6; // GUID string that the IIDFromString function returns
NameCanonical = 7; // Complete canonical name
NameUserPrincipal = 8; // User principal name
NameCanonicalEx = 9;
NameServicePrincipal = 10; // Generalized service principal name
DNSDomainName = 11; // DNS domain name, plus the user name
procedure GetUserNameEx(NameFormat: DWORD;
lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
external 'secur32.dll' Name 'GetUserNameExA';
function LoggedOnUserNameEx(fFormat: DWORD): string;
var
UserName: array[0..250] of char;
Size: DWORD;
begin
Size := 250;
GetUserNameEx(fFormat, @UserName, @Size);
Result := UserName;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := LoggedOnUserNameEx(NameSamCompatible);
end;
Исследование CuteFTP v3.0.15 beta или красота BitHacka.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Инструменты: 1) SoftIce 2) HView 3) Spy 4) Немного знаний RE и сообразительности. Вот попался мне этот дистрибутивчик, который, якобы, уже был кракнут, т.е. в нём был ключевой файл, зарегенный на некоего "Ledy-2000", но, как позже выяснилось, этот билт - бетта и там проверка на ключевой файл есть и в меню О программе он пишет - зарегенно, но вот баннер не исчезает! И занимает половину рабочего окна и тянет картинки с завидным упорством. Как оказалось, в этой бете баннер будет всегда, на то она и бета :) Прийдётся "Устранять это недоразумение" (c) Др. Голова Первым делом я вспомнил, что где-то видел тутор el-f'a по поводу исследования похожей программы NetAnts v1.23 с похожим баннером и похожей advert.dll :) Ну я достал его и внимательно изучил. При помощи утилиты Spy я узнал размеры баннерного окна: 468 / 62 Первым делом я пытался отследить создание окон и узнать их размеры: bpx CreateWindowExA do "? *(ebp-18)" при этом высвечивается высота окна. Но! "моей" высоты там не было, а может и была :) вобщем, я решил делать как el-f, я открыл прогу в HVIEW, нажал 2 раза F7 - это поиск по ассемблерной комманде, ввёл "push 3E" (3E = 62)! Т.е. я искал место создания окна и такое вхождение было единственным::0044BEB5 90 nop :0044BEB6 90 nop :0044BEB7 90 nop :0044BEB8 90 nop :0044BEB9 90 nop :0044BEBA 90 nop :0044BEBB 90 nop :0044BEBC 90 nop :0044BEBD 90 nop :0044BEBE 90 nop :0044BEBF 90 nop :0044BEC0 8B442408 mov eax, dword ptr [esp+08] :0044BEC4 56 push esi :0044BEC5 052CFEFFFF add eax, FFFFFE2C :0044BECA 6A40 push 00000040 :0044BECC 99 cdq :0044BECD 2BC2 sub eax, edx :0044BECF 6A3E push 0000003E <--вот оно!!! :0044BED1 8BF1 mov esi, ecx :0044BED3 68D4010000 push 000001D4 :0044BED8 D1F8 sar eax, 1 :0044BEDA 6A00 push 00000000 :0044BEDC 50 push eax :0044BEDD 68E8644C00 push 004C64E8 :0044BEE2 8D8E88000000 lea ecx, dword ptr [esi+00000088] :0044BEE8 E8E1470200 call 004706CE :0044BEED 8BCE mov ecx, esi :0044BEEF E8C3160200 call 0046D5B7 :0044BEF4 5E pop esi :0044BEF5 C20C00 ret 000Cкак видите, вначале куча нопов, неспроста это, ох неспроста :) Я, как и el-f заменил push 3E на push 00 и окно исчезло, значит это нужное место, но программа продолжала качать из интернета всякие картинки, хоть их и не видно! Я посмотрел чуть ниже и увидел подозрительный код:
:0044BEF8 90 nop :0044BEF9 90 nop :0044BEFA 90 nop :0044BEFB 90 nop :0044BEFC 90 nop :0044BEFD 90 nop :0044BEFE 90 nop :0044BEFF 90 nop :0044BF00 8B442404 mov eax, dword ptr [esp+04] :0044BF04 83EC10 sub esp, 00000010 :0044BF07 56 push esi :0044BF08 8BF1 mov esi, ecx :0044BF0A 50 push eax :0044BF0B E8991E0300 call 0047DDA9 :0044BF10 83F8FF cmp eax, FFFFFFFF <--чего-то сравниваем :0044BF13 7509 jne 0044BF1E <--прыжок на процедуру, больно похожую на загрузку картинки :0044BF15 0BC0 or eax, eax :0044BF17 5E pop esi :0044BF18 83C410 add esp, 00000010 :0044BF1B C20400 ret 0004Опять куча нопов (может пытаются запутать адрес вызова???) По адресу 0044BF13 я заменил jne 0044BF1E на jne 0044BF15, чтобы прыгать не на процедуру загрузки окна, а на следующую строку и запуситл прогу: Никакого окна не осталось! Но осталось родительское окно баннера (сам баннер состоял из 2ух окон: одно родительское, а во втором сам баннер). Нужно теперь убрать родительское окно, а все окна снизу подтянуть до упора под тулбар! Я долго промучался с этим и обнаружил такую вещь: если в Spy сделать окно с баннером Visible=false, то при изменении размеров главного окна окно с баннером исчезает, а все нижние окна САМИ поддтягиваются под самый тулбар! Это значит, что программа сначала узнает размеры окна с баннером, а затем на основе этого "строит" остальные окна, а у el-f'a просто прибавлялось смещение окна и все! Тут можно было бы написать простую консольную программу, которая бы при старте CuteFTP находила бы окно с баннером и делала бы его невидимым и сама бы изменяла размер главного окна, чтобы изменения вступили в силу. Но, я решил встроить в cutftp32.exe небольшую функцию, которая бы делала окно с баннером невидимым: я ставлю брекпоинт
bpx GetWindowRect do "p ret"это функция, получающая инфу об окне! вываливаюсь тут:
:0046F280 8D45F0 lea eax, dword ptr [ebp-10] :0046F283 50 push eax <--адрес, куда сохранять инфу об окне :0046F284 53 push ebx <--передаём Handle окна :0046F285 FF15C8D64900 Call USER32.GetWindowRect <--получаем о нём инфу :0046F28B 8B35F8D54900 mov esi, dword ptr [0049D5F8]Это место вызывается много раз, так как окон много, теперь нам нужно отследить окно с баннером и сделать его невидимым. Почитав немного "Windows API Reference" я узнал, что высота окна при вызове GetWindowRect будет сохраняться по адресу (esp+48). Теперь нужно найти в программе свободное место (обычно это где-то в районе ресурсов), и вписать туда код, который будет проверять, чтобы в (esp+48) было 3F (размер окна с баннером) и если размер окна равен 3F, то делаем его невидимым. Я нашёл много пустого места по адресу 00506876 делаем так: по адресу 0046F28B делаем безусловный переход на пустое место (00506876) по адресу 00506876 пишем нужный нам код, где предпоследней коммандой должна быть затёртая mov esi, dword ptr [0049D5F8] а последней командой должна быть jmp 0046F290 Итак, по адресу 0046F285 делаем так:
:0046F285 Call USER32.GetWindowRect :0046F28B jmp 00506876 :0046F290 nopноп появился потому что на команду jmp ушло на 1 байт меньше, чем было. а по адресу пустого места (00506876) пишем такой код:
00506881: 8B442448 mov eax,[esp+00048] <--записываем в eax длинну окна 00506885: 83F83F cmp eax,03F <--если это не окно с баннером 00506888: 7509 jne 000506893 <--то прыгаем на выход 0050688A: 6A00 push 000 <--если это окно с баннером, то сохраняем параметр Visible = False 0050688C: 53 push ebx <--и Handle окна 0050688D: FF157CD44900 call User32!ShowWindow <--и вызваем функцию ShowWindow 00506893: 8B35F8D54900 mov esi,ScreenToClient <--восстанавливаем затёртую строку 00506899: E9F289F6FF jmp 00046F290 <--возвращаемсятеперь пробуем запустить программу и видим, что больше окна с баннером нет, а все остальные окна подтянуты до тулбара!!! УрА! ВсЁ! Исследовал и наваял туториал: vallkor //PTDS e-mail: vallkor@chat.ru Page : http://vallkor.chat.ru
Как сделать так, чтобы работали команды Cut, Copy в WebBrowsere.
| Будущий сайт компании Yahoo! в домене Европейского Союза: www.yahoo.eu |
Вам нужно добавить следующие строки в начало unit:
initialization OleInitialize(nil); finalization OleUninitialize; |
Это не ошибка. Информацию по данному вопросу можно найти на сайте Microsoft KnowledgeBase статья Q168777. Приведённый ниже код, устраняет данную проблему:
...
var
Form1: TForm1;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
SaveMessageHandler: TMessageEvent;
...
implementation
...
procedure TForm1.FormActivate(Sender: TObject);
begin
SaveMessageHandler := Application.OnMessage;
Application.OnMessage := MyMessageHandler;
end;
procedure TForm1.FormDeactivate(Sender: TObject);
begin
Application.OnMessage := SaveMessageHandler;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Application.OnMessage := SaveMessageHandler;
FOleInPlaceActiveObject := nil;
end;
procedure TForm1.MyMessageHandler(var Msg: TMsg; var Handled: Boolean);
var
iOIPAO: IOleInPlaceActiveObject;
Dispatch: IDispatch;
begin
{ exit if we don't get back a webbrowser object }
if WebBrowser = nil then
begin
Handled := False;
Exit;
end;
Handled:=(IsDialogMessage(WebBrowser.Handle, Msg) = True);
if (Handled) and (not WebBrowser.Busy) then
begin
if FOleInPlaceActiveObject = nil then
begin
Dispatch := WebBrowser.Application;
if Dispatch <> nil then
begin
Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
if iOIPAO <> nil then
FOleInPlaceActiveObject := iOIPAO;
end;
end;
if FOleInPlaceActiveObject <> nil then
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
((Msg.wParam = VK_BACK) or (Msg.wParam = VK_LEFT) or (Msg.wParam = VK_RIGHT)) then
//nothing - do not pass on Backspace, Left or Right arrows
else
FOleInPlaceActiveObject.TranslateAccelerator(Msg);
end;
end;
|
Кириллица в параметрах CGI-запроса.
| WWW - уникальное явление из мира насекомых. Пауки, чтобы завлечь муху в сеть, рисуют красивые картинки и пишут тексты на HTML. |
http://site/cgi-bin/reg.pl?user=Вася Пупкин
а вот так:
http://site/cgi-bin/reg.pl?user=%C2%E0%F1%FF+%CF%F3%EF%EA%E8%ED
Решить проблему перекодировки туда и обратно может компонент TNMURL.
DK: Дополнительную информацию про кодирование URL'ов, можно прочитать в RFC1738.
Транслитерация кириллицы в латынь.
Автор: Дмитриев Сергей WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Транслитерация кириллицы в латынь
Преобразование строки вида 'Транслитерация' в 'Transliteratsiya' по правилам ГОСТа
Зависимости: System
Автор: Дмитриев Сергей, sergeante@mail.ru, ICQ:93240449, Мурманск
Copyright: Дмитриев С.А., 2002
Дата: 18 декабря 2002 г.
***************************************************** }
function TranslitRus2Lat(const Str: string): string;
const
RArrayL = 'абвгдеёжзийклмнопрстуфхцчшщьыъэюя';
RArrayU = 'АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЬЫЪЭЮЯ';
colChar = 33;
arr: array[1..2, 1..ColChar] of string =
(('a', 'b', 'v', 'g', 'd', 'e', 'yo', 'zh', 'z', 'i', 'y',
'k', 'l', 'm', 'n', 'o', 'p', 'r', 's', 't', 'u', 'f',
'kh', 'ts', 'ch', 'sh', 'shch', '''', 'y', '''', 'e', 'yu', 'ya'),
('A', 'B', 'V', 'G', 'D', 'E', 'Yo', 'Zh', 'Z', 'I', 'Y',
'K', 'L', 'M', 'N', 'O', 'P', 'R', 'S', 'T', 'U', 'F',
'Kh', 'Ts', 'Ch', 'Sh', 'Shch', '''', 'Y', '''', 'E', 'Yu', 'Ya'));
var
i: Integer;
LenS: Integer;
p: integer;
d: byte;
begin
result := '';
LenS := length(str);
for i := 1 to lenS do
begin
d := 1;
p := pos(str[i], RArrayL);
if p = 0 then
begin
p := pos(str[i], RArrayU);
d := 2
end;
if p <> 0 then
result := result + arr[d, p]
else
result := result + str[i]; //если не русская буква, то берем исходную
end;
end;
Соответствие типов С и Delphi.
Автор: http://www.swissdelphicenter.ch
C Type | Pascal | Description
----------------------------------------------
LPSTR PAnsiChar; String >pointer
LPCSTR PAnsiChar; String >pointer
DWORD Integer; Whole numbers
BOOL LongBool; Boolean values
PBOOL ^BOOL; Pointer to a Boolean value
Pbyte ^Byte; Pointer to a byte value
PINT ^Integer; Pointer to an integer value
Psingle ^Single; Pointer to a single (floating point) value
PWORD ^Word; Pointer to a 16-bit value
PDWORD ^DWORD; Pointer to a 32-bit value
LPDWORD PDWORD; Pointer to a 32-bit value
UCHAR Byte; 8-bit values (can represent characters)
PUCHAR ^Byte; Pointer to 8-bit values
SHORT Smallint; 16-bit whole numbers
UINT Integer; 32-bit whole numbers. Traditionally,
this was used to represent unsigned integers,
but Object Pascal does not have a true
unsigned integer data type.
PUINT ^UINT; Pointer to 32-bit whole numbers
ULONG Longint; 32-bit whole numbers. Traditionally,
this was used to represent unsigned integers,
but Object Pascal does not have a true
unsigned integer data type.
PULONG ^ULONG; Pointer to 32-bit whole numbers
PLongint ^Longint; Pointer to 32-bit values
PInteger ^Integer; Pointer to 32-bit values
PSmallInt ^Smallint; Pointer to 16-bit values
PDouble ^Double; Pointer to double (floating point) values
LCID DWORD; A local identifier
LANGID Word; A language identifier
THandle Integer; An object handle. Many Windows API functions return a value
of type THandle, which identobject ifies that object within
Windows'internal object tracking tables.
PHandle ^THandle; A pointer to a handle
WPARAM Longint; A 32-bit message parameter. Under earlier versions of Windows,
this was a 16-bit data type.
LPARAM Longint; A 32-bit message parameter
LRESULT Longint; A 32-bit function return value
HWND Integer; A handle to a window. All windowed controls, child windows,
main windows, etc., have a corresponding window handle that
identifies them within Windows'internal tracking tables.
HHOOK Integer; A handle to an installed Windows system hook
ATOM Word; An index into the local or global atom table for a string
HGLOBAL THandle; A handle identifying a globally allocated dynamic memory object.
Under 32-bit Windows, there is no distinction between globally
and locally allocated memory.
HLOCAL THandle; A handle identifying a locally allocated dynamic memory object.
Under 32-bit Windows, there is no distinction between globally
and locally allocated memory.
FARPROC Pointer; A pointer to a procedure, usually used as a parameter type in
functions that require a callback function
HGDIOBJ Integer; A handle to a GDI object. Pens, device contexts, brushes, etc.,
all have a handle of this type that identifies them within
Windows'internal tracking tables.
HBITMAP Integer; A handle to a Windows bitmap object
HBRUSH Integer; A handle to a Windows brush object
HDC Integer; A handle to a device context
HENHMETAFILE Integer; A handle to a Windows enhanced metafile object
HFONT Integer; A handle to a Windows logical font object
HICON Integer; A handle to a Windows icon object
HMENU Integer; A handle to a Windows menu object
HMETAFILE Integer; A handle to a Windows metafile object
HINST Integer; A handle to an instance object
HMODULE HINST; A handle to a module
HPALETTE Integer; A handle to a Windows color palette
HPEN Integer; A handle to a Windows pen object
HRGN Integer; A handle to a Windows region object
HRSRC Integer; A handle to a Windows resource object
HKL Integer; A handle to a keyboard layout
HFILE Integer; A handle to an open file
HCURSOR HICON; A handle to a Windows mouse cursor object
COLORREF DWORD; A Windows color reference value, containing values
for the red, green, and of ;bsp;blue components of a color
Delphi2 и COM объекты.
Автор: Mike Scott ...я обращался к справке MS Help, но и там я не нашел как работать с объектами COM в Delphi. Работать с COM-объектами в Delphi очень просто, поскольку объекты Delphi имеют ту же структуру, что и объекты COM. Единственное различие заключается в том, что в определении COM имеется три метода для изменения состояния COM объекта: QueryInterface, AddRef и Release.Теперь для того, чтобы иметь доступ к COM объекту из другого приложения или DLL, вам необходимо написать в Delphi объявление виртуального абстрактного класса, являющегося потомком IUnknown (в котором объявлены QueryInterface, AddRef и Release). В этом классе для COM объекта вы добавляете методы, объявленные в заголовочном файле C, в том же порядке следования. В этом случае вы запрашиваете интерфейс IShellLink, определенный в SHLOBJ.C и один из интерфейсов, предоставляемых Delphi 2, с помощью которого вы сможете реализовать свой собственный. Это может выглядеть приблизительно так:
type IShellLink = class( IUnknown ) function GetPath( pszFile : PChar ; cchMaxPath : integer ; pfd : PWIN32_FIND_DATA ; fFlags : cardinal ) : HResult ; virtual ; stdcall ; abstract ; // ... и т.д.. end ; |
Вы можете создавать экземпляр IShellLink, используя CoCreateInstance и передавая CLSID для IShellLink. Затем вы можете вызывать методы IShellLink, как, например, GetPath. Описание механизма работы может занять не одну статью, но реализованная в Delphi высокоуровневая инкапсуляция делает жизнь программиста намного легче, без необходимости залезать в столь глубокие дебри данной технологии. Особо любознательным я предлагаю преобрести "Programmer's Guide to Microsoft Windows 95", содержащую примеры (к сожалению, на C), лежащие в плоскости нашей темы.
Изменение системного времени из Delphi2.
| Программист: - Сегодня у сына день рождения. - И сколько ему исполняется? - 1024 дня. |
Можно. Попробуйте следующий код:
Procedure settime(hour, min, sec, hundreths : byte); assembler; asm mov ch, hour mov cl, min mov dh, sec mov dl, hundreths mov ah, $2d int $21 end; Procedure setdate(Year : word; Month, Day : byte); assembler; asm mov cx, year mov dh, month mov dl, day mov ah, $2b int $21 end; |
Ошибка RichEdit в Delphi2 под NT4.
| Электронные мозги могут ошибаться горазда точнее. |
Я протестировал исправленный код на большинстве платформ, в том числе на NT 4.0 и Win95, и, кажется, все работает как положено. На самом деле это легко исправить, только нужно знать где...
{
Существует проблема совместимости при вызове оригинального метода RichEdit.Print
под NT 4.0. Исключительная ситуация EDivByZero происходит из-за того,
что свойство Printer.Handle вне блока BeginDoc/EndDoc под NT 4.0
возвращает дескриптор информационного контекста (Information Context - IC) вместо
дескриптора контекста устройства (Device Context - DC). EM_FORMATRANGE пытается
использовать этот IC вместо реального DC принтера, вызывая этим исключительную
ситуацию. Если свойство Handle акцептуется ПОСЛЕ BeginDoc, дескриптор контекста
устройства возвращает истину, что и было мною исправлено в коде. Я оставил на
том же месте в коде оригинальное месторасположение вызова BeginDoc, при этом
сделав соответствующий комментарий для указания на внесенные изменения.
}
procedure TCustomRichEdit.Print(const Caption: string);
var
Range: TFormatRange;
LastChar, MaxLen, LogX, LogY: Integer;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
with Printer, Range do
begin
LogX := GetDeviceCaps(Handle, LOGPIXELSX);
LogY := GetDeviceCaps(Handle, LOGPIXELSY);
// Спозиционированный вызов BeginDoc для обеспечения
// совместимости под NT 4.0 и Win95
BeginDoc;
hdc := Handle;
hdcTarget := hdc;
if IsRectEmpty(PageRect) then
begin
rc.right := PageWidth * 1440 div LogX;
rc.bottom := PageHeight * 1440 div LogY;
end
else
begin
rc.left := PageRect.Left * 1440 div LogX;
rc.top := PageRect.Top * 1440 div LogY;
rc.right := PageRect.Right * 1440 div LogX;
rc.bottom := PageRect.Bottom * 1440 div LogY;
end;
rcPage := rc;
Title := Caption;
// Оригинальная позиция BeginDoc
{ BeginDoc; }
LastChar := 0;
MaxLen := GetTextLen;
chrg.cpMax := -1;
repeat
chrg.cpMin := LastChar;
LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, Longint(@Range));
if (LastChar < MaxLen) and (LastChar <> -1) then
NewPage;
until (LastChar >= MaxLen) or (LastChar = -1);
EndDoc;
end;
SendMessage(Handle, EM_FORMATRANGE, 0, 0);
end;
|
Адаптация RxLib для Delphi5.
Оформил: DeeCo Автор: Дмитрий Полщанов.
Вместо предисловия Хочется отметить, что, несмотря на заголовок, статья посвящена гораздо более глубокой теме, нежели модификация компонентов RxLibrary. На этом конкретном примере авторы статьи показывают, как именно решаются подобные проблемы в принципе. Статья написана очень грамотно и будет интересна многим программистам. Данная статья публикуется с согласия авторов RXLibrary. Для всех, кого интересует развитие этой библиотеки, сообщаем, что авторы собираются поддерживать ее и дальше, и в настоящее время практически закончена работа над версией для Delphi 5. Версия RX для Delphi5 будет доступна на сайте http://rx.demo.ru/ в ближайшее время.Лена Филиппова.
Введение.
Долгожданная пятая версия Delphi, обрадовав своим появлением на свет всех своих поклонников, к сожалению, многих разочаровала. Практически по одной единственной причине - проекты, сделанные (или начатые) в предыдущей версии, не поддаются перекомпиляции. Проблема кроется в большом количестве изменений в новой версии библиотеки VCL. Inprise предоставил документацию об изменениях, предложил пути переделки таковых проектов. Но что делать с библиотеками компонентов от сторонних производителей? Ждать, пока авторы предоставят upgrade? Копаться в чужих текстах самостоятельно? А если текстов нет? Ну, здесь уж точно, никто, кроме авторов не поможет. Стоит ли говорить о всемирной популярности библиотекиRхLiь? Редкий программист на Делфи обходится без этих замечательных компонентов. И… о горе! Библиотека RxLib, как и все прочие, не поддалась перекомпиляции "с налету". А непомерно огромное количество ошибок, выдаваемое компилятором, при самостоятельных попытках адаптации, остановило на этом пути десятки пытавшихся. Хотя были и победители! («Вьетнамци николы нэ здаються!» :)) Данной статьей мы желаем показать (на примере RxLib) как возможно преодолеть подобные трудности, какие подходы для этого могут быть использованы. Мы не претендуем на «конечную истину» в наших решениях - это не единственно возможное, и, может быть, не самое лучшее. У одного из нас при написании этой статьи использовался Delphi 5 Evaluation без исходных текстов VCL, в которые можно было бы подсмотреть реализацию некоторых участков библиотеки, и со справкой, являющейся переходной между Delphi4 и Delphi5, в которой также отсутствовала достоверная информация по ряду моментов. Но наши решения и наши методы работают, и они сослужили добрую службу многим, кто ими воспользовался. Наша статья рассчитана, в первую очередь, на тех начинающих (или продолжающих) программистов, которым не хватает опыта (или смелости?) внесения изменений в чужой исходный текст большого размера, и в то же время на тех, кто имеет желание научится разбираться в таких проблемах. Мы предлагаем им проделать этот путь вместе с нами и надеемся, что в процессе адаптации они приобретут этот опыт и избавятся от боязни «чужих» текстов. Такой опыт несомненно пригодится им в дальнейшей работе.Общие замечания.
Ликвидацию ошибок мы производили по мере их поступления в процессе компиляции. Однако это не значит, что в тексте они описаны в том же порядке (так как в процессе составления текста по сделанным записям вполне возможно, что часть описаний ликвидации ошибок изменили свои местоположения. Местами мы так же сгруппировали ошибки по типам, так как одна и та же ошибка возникала переодически в разных модулях и описание борьбы с ней было бы скучно читать и, тем более, писать). В данной статье мы остановимся на всех возникших в процессе адаптации ошибках, и попытаемся описать найденные нами способы их ликвидации. В основу адаптационной версии легла последняя доступная версия библиотеки RxLib - 2.6 + имеющиеся на текущий момент авторские fiх'ы (RX260FIX.ZIP). Порядок установки библиотеки остался прежним. Он описан авторами в Readme.txt в разделе Install for Delphi 4. Именно этот порядок инсталляции и нужно использовать. В статье мы обделили вниманием постоянно вылетающую ошибку, связанную с изменениями файлов dfm, возникающую при попытке Delphi прорисовать форму компилированного модуля, на форме которого присутствуют еще не проинсталлированные в среде компоненты RxLib. В случаях возникновения подобной ошибки предлагается просто игнорировать ее. Порой это утомительно, но ничего не поделаешь… В качестве альтернативы можно предложить компиляцию из командной строки, но большинство разработчиков в настоящее время считает это пещерным веком (хотя у компиляции из командной строки есть свои плюсы, например - скорость и меньшие требования к памяти). Остается лишь заметить, что после ликвидации всех ошибок желательно заново перекомпилировать все пакеты. Не забудьте также поместить пакеты времени выполнения по пути, прописанным в переменной окружения PATH. Для программистов рекомендуется использовать каталог Windows\System32, но у вас могут быть свои взгляды на это дело… За основу желательно брать RxLib версии 2.6 + имеющиеся на текущий момент авторские fiх'ы (RX260FIX.ZIP).Модули пакетов rxctl4, rxdb4, dclrx4, dclrxdb4.
Далеко не все проекты могут быть или должны быть перекомпилированы новым компилятором, поэтому необходимо предусмотреть возможность одновременного использования пакетов runtime RxLib как адаптированной и не адаптированной версий. Известно, что по именам пакетов Delphi строит файлы bpl, являющимися на самом деле dll, которые могут быть вызваны пользовательскими программами. Поэтому достаточно переименовать модули пакетов (файлы с расширением bpk), и компилятор создаст новые, отличные по имени от неадаптированной версии, файлы соответствующих пакетов. Желательно это сделать с самого начала. Более того, рекомендуется откопировать файлы библиотеки в другой каталог и работать с ними, а для того, чтобы всегда можно было вернуться на шаг назад, после каждого исправленного модуля желательно архивировать копию файлов. Модули пакетов rxctl4, rxdb4, dclrx4, dclrxdb4 переименовываем соответственно в rxctl5, rxdb5, dclrx5, dclrxdb5. Так же заменяем во всех переименованных модулях в секции requires все 4 на 5. (При использовании официальной версии, Delphi сделает часть этой работы сама при открытии основного модуля пакета в IDE. Однако Delphi исправляет только ссылки на пакеты VCL, входящие в стандартную поставку. Нам же необходимо поменять еще и ссылки на пакеты RxLib.)Например, было.
requires VclDb40, VclMid40, rxctl4, Vclbde40;стало
requires VclDb50, VclMid50, rxctl5, Vclbde50;
Модуль Rx.inc.
В этом модуле содержится описание некоторых констант, обеспечивающих корректную обработку версий библиотеки и среды. Если версия библиотеки у нас не изменилась, то версия среды функционирования уже другая. Для обработки таких вещей Delphi вводит константу с именем VERXXX, где XXX - номер версии IDE. Для D5 константа версии - VER130. Эта константа немного нечитаема, поэтому в RxLib вводится ее своего рода дубликат RX_DX - где X - номер версии IDE. Сейчас в этом файле инициализируется константа RX_D4 (вообще говоря, должна инициализироваться, но так как номер версии компилятора сменился, то эта константа является неопределенной). По этой традиции мы добавляем константу RX_D5 сразу после {$IFDEF VER120} .. {$ENDIF}, учитывая, что номер версии компилятора VER130:
{$IFDEF VER130} {Borland Delphi 5.0 }
{$DEFINE RX_D3}
{$DEFINE RX_D4}
{$DEFINE RX_D5}
{$ENDIF}
Номер версии компилятора может быть найден несколькими путями. Во-первых, порыться в справке. Во-вторых, методом проб и ошибок - делаем пустой проект, в нем пишем такой текст
procedure Tform1.FormCreate(Sender: Tobject);
var
{$IFDEF VER130}
a: Integer;
{$ENDIF}
begin
a := 0;
end;
и потом перебираем цифры в константе, пока не добьемся компиляции. Цифры могут быть только больше 120, так как 120 - уже относится к Delphi4. Вряд ли Inprise будет уменьшать эти цифры или увеличивать сразу намного. Если внимательно просмотреть файл Rx.inc, то можно увидеть аналогию: VER80 - Delphi1 VER90 - Delphi2 VER100 - Delphi3 VER110 - C + +Builder 3 VER120 - Delphi4Ну, а Delphi5 может быть либо VER130, либо VER140 (если учесть появление C++ Builder 4). Поэтому вариантов для перебора не так уж и много. На тот случай, если константа VER130 оказалась неопределенной (по каким-либо причинам), желательно исправить следующий далее по тексту вложенный IFDEF на такой
{$IFNDEF VER80} { Delphi 1.0 }
{$IFNDEF VER90} { Delphi 2.0 }
{$IFNDEF VER93} { C++Builder 1.0 }
{$DEFINE RX_D3} { Delphi 3.0 or higher }
{$IFNDEF VER100}
{$DEFINE RX_V110} { C++Builder 3.0 or higher }
{$IFNDEF VER110}
{$DEFINE RX_D4} { Delphi 4.0 or higher}
// Добавлено
{$IFNDEF VER120}
{$DEFINE RX_D5} { Delphi 5.0 or higher}
{$ENDIF}
// конец добавления
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
Этот участок кода, если хорошенько вдуматься, обеспечивает определение константы RX_D5 в условиях компиляции в будущей версии IDE (скажем, в Delphi6). В этом случае библиотека должна уметь вести себя так же, как и в версии на номер ниже (пока что это смелое предположение в случае RxLib не срабатывало никогда - при переходах D1/D2, D2/D3, D3/D4, но в этом ее авторы не виноваты - всегда что-то менялось в VCL и в корне, - однако… это все же хорошая методика!)
Исправив данный модуль, архивируем библиотеку и пытаемся откомпилировать ее. Сразу натыкаемся на ошибку, гласящую о том, что оказывается неопределенной константа SdelphiKey. Ищем модуль где она расположена. Можно использовать любые средства поиска (от встроенных в Delphi, до внешних, или встроенных в OS). Нас интересует ее определение, поэтому необходимая строка поиска - «SdelphiKey = » и ищем все файлы, в которые эта строка входит. Таким образом находим модуль RxConst. Если бы эта константа не входила бы в RxLib, то можно было бы поискать ее в любом файле *.pas, *.inc (допустим в каталоге Source или вообще на всех локальных дисках). Однако в большинстве случаев с достаточной большой вероятностью можно предполагать какой областью диска можно ограничится для поиска. В том случае, если необходимый файл оказывается не найденным можно расширить область поиска или изменить строку поиска. Если и в этом случае нужное место не найдено, можно искать уже не только файлы *.pas, *.inc но и добавить к ним *.dcu, *.bpl, *.dpc или вообще *.*.
RxConst.pas.
В модуле RxConst.pas, видя как это было сделано авторами для Delph4, перед implementation добавляем строку для ключа реестра Delphi, соответствующей версии D5:
{$IFDEF VER130}
const
SDelphiKey = 'Software\Borland\Delphi\5.0';
{$ENDIF}
Архивируем файлы и пытаемся компилировать. Дальше мы наталкиваемся на череду ошибок о несоответствии формальных и фактических параметров при вызове некоторых функций. Идем на место ближайшей ошибки, встаем на ошибочный вызов и, используя магическую комбинацию ctrl+shift+пробел получаем в подсказке типы ожидаемых параметров. Замечем, что там где подставляется переменная типа TComponentList на самом деле ожидается TDesignerSelectionList. C помощью описанной выше методики, находим модуль, в котором описана TDesignerSelectionList - это Contnrs. Добаляем его в строку uses. Во всех этих местах меняем соответствующий тип. При этом, чтобы уж во всем следовать хорошим традициям RxLib, мы не делаем замену текста, а вводим альтернативу с использованием описанной нами константы RX_D5. Для этого мы в секции var таких функций заменяем, допустим (в процедуре TSpeedbarEditor.SelectButton модуля SbEdit) FCompList: TComponentList на
{$IFDEF RX_D5}
FCompList: TDesignerSelectionList;
{$ELSE}
FCompList: TComponentList;
{$ENDIF}
А в реализации функций соответствующие места изменяем по той же технологии - там где было FCompList := TComponentList.Create пишем
{$IFDEF RX_D5}
FCompList := TDesignerSelectionList.Create;
{$ELSE}
FCompList := TComponentList.Create;
{$ENDIF}
Такие изменения потребуются сделать во всех функциях и процедурах, на которые проругается компилятор. Это в модулях PgMngrEd.pas, SbEdit.pas, TimLstEd.pas и RxCtlReg.pas. Произведя изменения в каждом модуле, архивируем всю библиотеку. По завершению работы с данной ошибкой, наталкиваемся на новую - опять несоответствие типа, но теперь уже в модуле BDEUtils.
Модуль BDEUtils.pas.
Описанным выше методом с магической комбинацией ctrl+shift+пробел узнаем, что в D5 введен тип TDatabaseLogin вместо TLoginEvent. В связи с этим нужно изменить в разделе interface описание функции
function LoginToDatabase(Database: TDatabase; OnLogin:
{$IFDEF RX_D5}
TDatabaseLoginEvent
{$ELSE}
TLoginEvent
{$ENDIF}): Boolean;
и повторить его в разделе implementation. Изменение тела функции не требуется.
В разделе implementation этого модуля функция GetNativeHandle требует изменения тела (D5 не имеет функции DBError, во всяком случае я не нашел ни ее, ни ее замены. Поэтому (исходя из ее функциональности) просто ставим там выброс исключения)
{$IFDEF RX_D5}
else
raise EDBEngineError.Create(SLocalDatabase);
{$ELSE}
else
DBError(SLocalDatabase);
{$ENDIF}
Вместо выброса исключения можно использовать функцию DBIError. Опять архивируем и перекомпилируем библиотеку.
Модуль DBFilter.pas.
Оказывается (магическая комбинация ctrl+shift+пробел), что в функции TRxDBFilter.CreateExprFilter имеется ошибка - функция DbiAddFilter поменяла тип формального параметра при своем вызове. Исправляем этот факт (самое простое что можно сделать - это попытаться привести имеющуюся переменную к требуемому типу. Это может не пройти, но если не пройдет - тогда и будем думать…):
function TRxDBFilter.CreateExprFilter: hDBIFilter;
begin
Result := nil;
if (FFilter.Count > 0) then
if BuildTree then
try
Check(DbiAddFilter((FDatalink.DataSet as TBDEDataSet).Handle,
Longint(Self), FPriority, False,
{$IFDEF RX_D5}pCANExpr({$ENDIF}
TExprParser(FParser).FilterData
{$IFDEF RX_D5}){$ENDIF},
nil, Result));
FDataHandle := TBDEDataSet(FDatalink.DataSet).Handle;
finally
DestroyTree;
end;
end;
Пытаемся снова перекомпилировать библиотеку. Наталкиваемся на уже известную ошибку с несоответствием формальных и фактических параметров в модуле DBFilter. Оказывается, в D5 введен новый тип TFieldMap. Появляется он в единственном месте - при вызове TExprParser.Create в функции TRxDBFilter.BuildTree модуля DBFilter.pas В этом месте пишем:
FParser := TExprParser.Create(FDataLink.DataSet, Expr,
TFilterOptions(FOptions){$IFDEF RX_D4}, [], '', nil{$ENDIF}
{$IFDEF RX_D5}, FldTypeMap{$ENDIF});
Идея данного изменения была получена одним из нас при анализе конструктора TExprParser (модуль DBCommon). Естественно, что для введения таких изменений необходимо иметь исходный текст VCL. В случае его отсутствия (по каким-либо причинам) здесь можно было бы поставить выброс исключения (для того, чтобы данный участок кода себя как-то проявил при работе, а не просто ничего не делал). Функциональности от такого изменения немного, но это лучше, чем ничего.
Архивируем и перекомпилируем библиотеку. Исправляем уже известные ошибки.
Модуль LoginDlg.pas.
Раздел implementation в функции TDBLoginDialog.OkBtnClick следует заменить тип переменной в секции var:
{$IFDEF RX_D5}
SaveLogin: TDatabaseLoginEvent;
{$ELSE}
SaveLogin: TLoginEvent;
{$ENDIF}
Архивируем и перекомпилируем библиотеку.
Модуль RxRichEd.pas.
В RxLib при работе с D5 оказывается выброшенным описание типа TCharFormat2. Путем долгих поисков файла, в котором описывался бы этот тип, узнаем, что ни в одном *.pas, *.dcu его нет, но *.bpl он уже присутствует. Это кажется странным... Но ничего страшного в этом нет. Путем анализа кода выясняем, что эта структура должна входить в WinAPI. А там традиционно переназначение одного типа другому (по тому, как это делали авторы RxLib для Delphi3, это видно невооруженным взглядом). Поэтому, следуя таким традициям и определив доступность в данном месте типа TCharFormat2A, вставляем в начало раздела interface строки:
{$IFDEF RX_D5}
type
TCharFormat2 = TCharFormat2A;
{$ENDIF}
сразу после строки type
TRichEditVersion = 1..3 или uses.
Архивируем и перекомпилируем библиотеку. И наталкиваемся на следующую ошибку.
Модуль RxMemDS.pas.
В D5 у TDataset пропали функции BCDToCurr, CurrToBCD. В связи с этим у всех наследников этога класса недействительной является директива override. Если залезть в Help, то там можно прочитать следующие строки: The global FMTBCDToCurr and CurrToFMTBCD routines have been replaced by the new BCDToCurr and CurrToBCD routines (and the corresponding protected methods on TDataSet have been replaced by the protected and undocumented DataConvert method). Но в RxLib-то они есть!!! Чтобы они там и оставались мы просто убираем директиву override в соответствующих местах для класса TrxMemoryData. Это в описании функций
function BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean;
{$IFNDEF RX_D5} override;
{$ENDIF}
function CurrToBCD(const Curr: Currency; BCD: Pointer;
Precision, Decimals: Integer): Boolean;
{$IFNDEF RX_D5} override;
{$ENDIF}
В принципе, можно было бы просто удалить эти функции из библиотеки. Но мы условились только добавлять, а не удалять…
Архивируем и перекомпилируем библиотеку. И наталкиваемся на следующую ошибку.
Модуль SelDSFrm.pas.
В D5 исчезла функция ShowDatasetDesigner. Она встречается в модуле SelDSFrm.pas в процедуре TMemDataSetEditor.ExecuteVerb. Ее прямую замену не удалось найти. Однако если заменить соответсвующее место на
{$IFDEF RX_D5}
Designer.Edit(GetIComponent);
{$ELSE}
ShowDatasetDesigner(Designer, TDataSet(Component));
{$ENDIF}
то вроде бы работает. По крайней мере ошибок в последствии мы обнаружили (у одного из нас один из проектов работает с TMemDataset, и в новой версии пока без глюков). Строка uses (неважно какого раздела. рекомендуется implementation, но можно и interface) для этого модуля должна быть также изменена - в нее нужно добывать модуль DsnDbCst. Этот модуль был найден описанным выше методом контекстного поиска.
uses{$IFDEF WIN32}Windows, {$ELSE}WinProcs, WinTypes, {$ENDIF}SysUtils,
Messages, Classes, Graphics, Controls, Forms, Dialogs, DB, StdCtrls,
DsgnIntf, RxDsgn{$IFDEF RX_D5}, DsnDbCst{$ENDIF};
Архивируем и перекомпилируем библиотеку. И вроде бы все.
По переписке мы обнаружили еще одно решение - заменить вызов ShowDatasetDesigner на ShowFieldsEditor.
Заключение.
Теперь, после успешной инсталляции, начинаем компилировать все доступные проекты, использующие RxLib. У нас остались только ошибки RunTime, но они могут проявится лишь в тех случаях, когда… (даже не знаем, когда - одному богу известно!). Однако, по переписке с другими людьми, так же имевшими опыт подобной адаптации, мы узнали, что ряд мест в библиотеке работает неправильно в Delphi5. Вы можете сразу натолкнуться на них, а можете не встретиться с ними никогда (а это достаточно долго). Так, метод класса TownerDrawComboBox (модуль RxCombos.pas), предка T{Color|Font}ComboBox'ов, содержал вызов процедуры ResetItemHeight, которая, содержит строку "inherited ItemHeight := H;", вызывающую зацикливание в D5 и, как следствие, переполнение стека. Эту строку следует удалить, тем более что и без нее все прекрасно работает. Таким образом, для устранения таких неприятностей, как невозможность откомпилировать что-то в новой версии компилятора нами были использованы следующие методы: 1. Контекстный поиск строки в файлах *.pas, *.inc, *.dcu, *.bpl, *.*. Этот поиск нужно использовать с «головой». То есть, на этом можно потерять достаточно много времени, если задать слишком широкую область поиска или слишком общую маску. 2. Магическую комбинацию ctrl+shift+пробел. Очень ценное введение, появившееся еще в Delphi4. Мы используем его всегда и во всех разработках. 3. Принцип разумной достаточности. Не нужно чего-то придумывать, если простое приведение типа является достаточным. Если мы не знаем на что что-то заменить, но знаем что это что-то должно делать, ищем что-нибудь другое, что делает то-же самое. 4. Принцип аналогии. Если что-то делается, это должно делаться однообразно. Кстати, хороший стиль программирования основывается на однообразии методов, описаний, способа кодирования и т.д. Человек, который сначала пишет CloseWindowEx, потом closewindowex, а потом CloseWindowSex, при этом постоянно меняя ширину отступов и т.п - не имеет хорошего стиля программирования, потому что не имеет стиля вообще. Но это - тема отдельной статьи… 5. Пошаговая компиляция с архивированием исходных модулей.Благодарности.
Мы выражаем глубокую признательность Елене Филипповой за идею написания данной статьи, сделавшей возможность знакомства ее авторов. Также мы благодарны Алексею Вуколову за интерес, проявленный к нашей статье и Александру Петину, идеи которого в некоторых местах мы позаимствовали.Delphi7 Studio для облегчения миграции к платформе DotNet.
Оформил: DeeCo
Qui non proficit, deficit. Теряет тот, кто не идет вперед Итак, перед нами очередная версия знаменитого продукта фирмы Borland — Delphi 7 Studio, о выходе которого было сообщено в пресс-релизе компании от 6 августа 2002 года. Новая версия Delphi позиционируется как первый независимый инструмент для облегчения миграции к платформе .Net и, будучи доступна с лета 2002 года, поставляется в четырех редакциях: Architect, Enterprise, Professional и Personal. В шестой версии, как вы помните, отсутствовала редакция Architect, да и само понятие «Studio» (студии). Также нужно заметить, что, хотя Delphi несколько «потяжелела» и изменился перечень поддерживаемых операционных систем, системные требования Delphi 6 и Delphi 7 версий Enterprise, в основном, остались прежними (см. табл. 1). Для версии Architect, которая является самой полной и дорогой (99) редакцией, требования к ПК выше — для полной установки ей требуется 540 Мб пространства на жестком диске. Цены на «стандартные» версии, по сравнению с Delphi 6, не изменились: Enterprise стоит 99, Professional — 9 и Personal — . Какие же новые возможности были включены в Delphi 7 Studio? Рассмотрим их по порядку. Среда разработки Изменения, затронувшие IDE, коснулись палитры компонент, достройщика кода, отладчика и настроек редактора кода. В палитре компонент появились следующие закладки: новая версия закладки System только для CLX-приложений, закладки Indy Intercepts и Indy I/O Handlers, содержащие компоненты с поддержкой протоколов интернет с открытым исходным кодом (редакции Professional и Enterprise). Для разработки веб-приложений — новые закладки IW Standard, IW Data, IW Client Side, и IW Control с компонентами IntraWeb, а также новая закладка Rave с компонентами генерации отчетов. Кроме того, если закладка содержит компоненты, для доступа к которым необходима горизонтальная прокрутка, то теперь добраться до них можно и с помощью ниспадающего меню. Достройщик кода (code completion) теперь работает быстрее и позволяет перейти к объявлениям элементов через их список путем нажатия клавиши и клика мышью на любом идентификаторе в списке. Появился новый достройщик HTML-кода, который автоматически отображает нужные HTML-элементы и атрибуты в редакторе кода (для редакций Professional и Enterprise). Для удобства работы через меню Tools р Editor Options р Code Insight можно настроить цвета, используемые достройщиком кода. Также необходимо отметить возможность написания собственных менеджеров завершения кода. Окно просмотра сообщений отладчика (Watch List) обзавелось множеством закладок для облегчения процесса отлова ошибок. Каждую закладку можно настроить — отображать ее или спрятать. Диалоговое окно Run Parameters теперь имеет новую настройку: рабочий каталог (Working Directory), указав который, можно настроить каталог, используемый для отладки. Из Project Manager можно компилировать лишь часть проектов в группе, щелкнув правой кнопкой по проекту и выбрав пункты меню Make All from Here или Build All from Here, а в окне просмотра сообщений (Message view) появилось множество закладок для отображения разных типов сообщений (Build, Search, и т. д.) В окне, доступном через меню View р Component List, можно выбирать несколько компонент с помощью клавиши . Окно настроек редактора кода, доступное через меню Tools р Editor Options р Source Options, позволяет устанавливать различные настройки для языков Pascal, C++, C#, HTML, XML, контролировать отображение знаков пробела и табуляции, редактировать шаблоны кода. Окно, доступное через меню Tools р Editor Options р Color, имеет две новые настройки: цвет символа (Foreground Color) и цвет фона (Background Color) — вместо цветовой сетки для настройки цвета в редакторе кода. Веб-технологии В седьмую версию Delphi вошел набор компонент IntraWeb от AtoZed Software, который может быть использован для написания приложений веб-сервера с использованием стандартного инструментария разработки форм. IntraWeb также годится для разработки страниц Web Broker и WebSnap приложений. Полная версия IntraWeb входит в состав редакции Delphi Enterprise. Delphi также поддерживает Apache 2 — как целевой тип для Web Broker, WebSnap и SOAP. В то же время Borland не рекомендует использовать Win-CGI для приложений веб-сервера или веб-сервисов. Вместо этого рекомендуется использовать CGI, ISAPI/NSAPI, или Apache. Веб-сервисы Появился новый UDDI (Universal Description, Discovery, and Integration) браузер у волшебника импорта WSDL, который позволяет сканировать реестр UDDI для поиска веб-сервиса и импорта адреса WSDL документа. Сам реестр UDDI является базой данных, в которой регистрируются компании, поставляющие веб-сервисы. Новые классы и интерфейсы позволяют читать или вставлять заголовки в SOAP-конверты, пересылающие сообщения между клиентом и сервером. Приложения веб-сервисов (как клиентов, так и серверов) теперь в состоянии обрабатывать вложения. Вложения (наследники класса TSOAPAttachment) отсылаются вместе с закодированными сообщениями SOAP как часть составной формы. Когда приложение получает сообщение с вложением, оно сохраняет вложение во временном файле, доступном вашей программе. Новые события, обрабатываемые компонентом THTTPReqResp, позволят вам перехватывать сообщения HTTP до их отсылки и отслеживать ход получения или отсылки длинных сообщений. В классе THTTPSoapPascalInvoker доступны сообщения, которые позволят написать код, исполняемый до или после того, как объект класса осуществит вызов запрашиваемого метода. Интерфейс IOPConvert получил новое свойство Encoding, что позволяет указать набор символов для использования в сообщениях, передаваемых между клиентом поставщиком веб-сервиса. Базы данных Обновлены драйвера dbExpress для Informix SE, Oracle 9i, DB2 7.2, InterBase 6.5 и MySQL 3.23.49. Новый драйвер поставляется и для MS SQL Server 2000. А вот SQL Links Borland не рекомендует использовать, более того — работа над усовершенствованием SQL Links прекращается. Сообщается также, что эта технология не будет поставляться вместе с Delphi после 2002 года. В виде замены рекомендовано использовать dbExpress для доступа к базам данных SQL серверов. Прекращена также поддержка CORBA-соединений компонентами DataSnap. Библиотека компонент Приложения, написанные с использованием VCL, теперь включают компоненты, поддерживающие библиотеку элементов управления Windows шестой версии. Поэтому приложение будет автоматически использовать новые элементы управления Windows в ОС Windows XP, если найдет подходящий файл-манифест. Новый модуль DBClientActns включает три новых компонента для работы с клиентскими наборами данных: TClientDataSetApply, TclientDataSetUndo и TClientDataSetRevert. Закладка dbExpress включает новый компонент TSimpleDataSet для использования с простыми, двухуровневыми приложениями баз данных (TSimpleDataSet заменил собой TSQLClientDataSet). Обновлена закладка Dialogs на палитре компонент — добавлен TPageSetupDialog для представления стандартного диалогового окна Windows настройки параметров страницы. На закладку Additional добавлены компоненты TXPColorMap, TstandardColorMap и TtwilightColorMap для окраски меню и панелей инструментов. У VCL-версии компонента TCustomForm добавились два новых свойства: ScreenSnap и SnapBuffer, контролирующие «прилипание» окна к краям экрана. Компонент TCustomComboBoxEx получил новое свойство AutoCompleteOptions, которое позволяет откликаться на ввод пользователя. Библиотека времени выполнения Модуль Classes содержит новый класс-исключение EFileStreamError. Классы EFCreateError и EFOpenError являются наследниками этого класса. Поскольку конструктор этого класса принимает имя файла как параметр, то в сообщении об исключительной ситуации можно видеть имя файла, в котором она произошла. Класс TStrings также обладет теперь двумя новыми свойствами: ValueFromIndex и NameValueSeparator. В модуле StrUtils также произошли определенные изменения, касающиеся работы с многобайтными наборами символов. Ранее функции LeftStr, RightStr и MidStr принимали параметр типа AnsiString и возвращали значение того же типа, не поддерживая многобайтные наборы символов. Теперь каждая из этих функций заменена парой перегруженных функций, одна из которых работает с типом AnsiString, а другая — с типом WideString. Также в модуль добавлена новая функция для поиска в строке, именуемая PosEx. В модуле SysUtils функции, работающие над форматированием и разбором чисел, валют и значений типа дата и время, заменены на безопасные при работе с нитями. Модуль VarCmplx содержит новые функции VarComplexLog2, VarComplexLog10, VarComplexLogN, VarComplexTimesImaginary и VarComplexTimesReal. В модуль Variants добавлены функции VarIsError и VarAsError. Исключение EVariantError теперь является родительским классом для более тщательно разработанных классов-исключений, которые используются в коде с использованием переменных типа variant. Компилятор Компилятор Delphi поддерживает три дополнительных предупреждения: Unsafe_Type, Unsafe_Code и Unsafe_Cast. Эти предупреждения по умолчанию отключены, однако их можно задействовать с помощью директив компилятора {$WARN UNSAFE_CODE ON}, команды компилятора командной строки (dcc32 -W+UNSAFE_CODE), или посредством среды разработки, воспользовавшись меню Project р Options р Compiler Messages. Эта особенность должна помочь вам портировать код в окружение управляемого выполнения платформы Microsoft .NET. В этом окружении «unsafe» значит, что действия, выполняемые программой, не могут быть проверены во время анализа, осуществляемого Just In Time (JIT) компилятором. Такой код представляется небезопасным. Примером такого кода могут послужить операции с указателями. Поддержка Rave Reports (для редакции Professional и Enterprise) Вместе с Delphi теперь поставляется набор компонент для генерации отчетов Rave Reports фирмы Nevrona. Полное его название — Rave 4.0 Borland Edition (BE). Включает 19 компонентов, содержащих более 500 методов, свойств и событий. Компоненты компилируются в ехе-файл приложения и не требуют для работы никаких дополнительных файлов. В генератор отчетов включена поддержка графики, выравнивания и переноса текста, точное позиционирование страницы, конфигурирование принтера, управление шрифтами, полнофункциональный предпросмотр. Rave 4.0 BE справляется и с отчетами вида master-detail, письмами, счетами и т. д. Поддержка ModelMaker (для редакции Professional и Enterprise) ModelMaker призван помочь упростить дизайн, разработку и поддержку классов и интерфейсов. ModelMaker также включает инструменты для создания диаграмм в стиле UML (Unified Modeling Language), которые могут быть использованы для создания и модификации исходного кода проекта. Отмечу, что версия Delphi Enterprise включает полноценную версию ModelMaker, а Delphi Professional — лишь 30-дневную пробную версию, хотя функциональность обоих версий одинакова. Заключение Несмотря на множество нововведений в этой версии Borland Delphi, можно отметить, как минимум, три важные тенденции. Первая — сворачивание собственных технологий, таких как Borland Database Engine (BDE) и SQL Links. Кажется вероятным отказ от набора компонент Quick Reports, успешно поставлявшихся с несколькими последними версиями Delphi. Вторая — ставшая уже традиционной поддержка написания приложений для Linux. Третья — на мой взгляд, более важная — постепенный отход ведущих средств разработки от платформы Win32 и их миграция в сторону платформы .Net. И хотя, как сказано в пресс-релизе Borland, за одну ночь новая платформа не изменит технологию разработки и распространения приложений, однако платформа .Net — следующая, эволюционная ступень Windows, приход которой неизбежен. Принимая во внимание тот факт, что разработчики в основной своей массе люди инертные, а также то, что на изучение новых технологий необходимо довольно много времени и средств, Borland сделала ставку на необходимость эволюционного развития Delphi и, на мой взгляд, не ошиблась. Включение в эту версию подсказок и предупреждений компилятора, касающихся совместимости с Microsoft .Net, возможности импорта узлов (assembly) .Net в Delphi и экспорта COM объектов в приложения .Net, подтверждает сказанное выше. Полноценная же поддержка этой многообещающей платформы наверняка будет реализована в следующей версии Delphi — Delphi .Net, которую и будем с нетерпением ждать.Как создать таблицу в MS Access при помощи DAO.
1. Объявляем переменные:
var access, db, td, recordset: Variant; |
2. объявляем массив констант соответствия типов данных (между полями в Delphi и типами полей DAO).
arrMDBTypes: array[TFieldType] of Integer =
({dbText} 10 {ftUnknown},
{dbText} 10 {ftString},
{dbInteger} 3 {ftSmallint},
{dbLong} 4 {ftInteger},
{dbInteger} 3 {ftWord},
{dbBoolean} 1 {ftBoolean},
{dbDouble} 7 {ftFloat},
{dbCurrency} 5 {ftCurrency},
{dbDouble} 7 {ftBCD},
{dbDate} 8 {ftDate},
{dbTime} 22 {ftTime},
{dbDate} 8 {ftDateTime},
{dbLongBinary} 11 {ftBytes},
{dbLongBinary} 11 {ftVarBytes},
{dbInteger} 3 {ftAutoInc},
{dbLongBinary} 11 {ftBlob},
{dbMemo} 12 {ftMemo},
{dbLongBinary} 11 {ftGraphic},
{dbMemo} 12 {ftFmtMemo},
{dbLongBinary} 11 {ftParadoxOle},
{dbLongBinary} 11 {ftDBaseOle},
{dbBinary} 9 {ftTypedBinary},
{dbText} 10 {ftCursor}
{$IFDEF VER120}
,
{dbText} 10 {ftFixedChar},
{dbText} 10 {ftWideString},
{dbBigInt} 16 {ftLargeint},
{dbText} 10 {ftADT},
{dbText} 10 {ftArray},
{dbText} 10 {ftReference},
{dbText} 10 {ftDataSet}
{$ELSE}
{$IFDEF VER125}
,
{dbText} 10 {ftFixedChar},
{dbText} 10 {ftWideString},
{dbBigInt} 16 {ftLargeint},
{dbText} 10 {ftADT},
{dbText} 10 {ftArray},
{dbText} 10 {ftReference},
{dbText} 10 {ftDataSet}
{$ELSE}
{$ ,
{dbText} 10 {ftFixedChar},
{dbText} 10 {ftWideString},
{dbBigInt} 16 {ftLargeint},
{dbText} 10 {ftADT},
{dbText} 10 {ftArray},
{dbText} 10 {ftReference},
{dbText} 10 {ftDataSet},
{dbLongBinary} 11 {ftOraBlob},
{dbLongBinary} 11 {ftOraClob},
{dbText} 10 {ftVariant},
{dbText} 10 {ftInterface},
{dbText} 10 {ftIDispatch},
{dbGUID} 15 {ftGuid}
{$ENDIF}
{$ENDIF}
{$ENDIF}
);
|
// 3. загружаем DAO:
try
access := GetActiveOleObject('DAO.DBEngine.35');
except
access := CreateOleObject('DAO.DBEngine.35');
end;
// 4. открываем базу данных
try
db := access.OpenDatabase(yourDatabaseName);
except
exit
end;
// 5. созда¸м новую таблицу в открытой базе данных
td := db.CreateTableDef(yourTableName, 0, '', '');
// 6. добавляем в таблицу поле с описаниями
td.Fields.Append(td.CreateField(strFieldName,
arrMDBTypes[intDataType], Size));
// например,
td.Fields.Append(td.CreateField('ID', arrMDBTypes[intDataType], Size));
td.Fields.Append(td.CreateField('NAME', arrMDBTypes[intDataType], Size));
// 7. добавляем таблицу в список таблиц
db.TableDefs.Append(td);
// 8. открываем созданную таблицу
recordset := db.OpenTable(yourTableName, 0);
// 9. добавляем новую запись в открытую таблицу
recordset.AddNew;
// 10. изменяем значения поля
curField := recordset.Fields[0].Value := 1;
curField := recordset.Fields[1].Value := 'First record';
// 11. помещаем новую запись в базу
recordset.Update(dbUpdateRegular, False);
// где
const
dbUpdateRegular = 1;
// 12. закрываем recordset
recordset.Close;
// 13. закрываем базу данных
db.Close;
// 14. освобождаем экземпляр DAO
access := UnAssigned;
|
Database Desktop показывает содержимое таблиц шрифтом без русских букв.
| Вопрос в кроссворде: - Язык програмирования из трех букв. Ответ: - c++ |
Для DBD 5.0 в файл c:\windows\pdoxwin.ini вставить в секцию:
[Properties] SystemFont=Arial Cyr |
Если файла не существует, то его надо создать, если секции не существует, то ее надо создать.
Для DBD 7.0 нужно исправить реестр - ключ:
HKCU\Software\Borland\DBD\7.0\ Preferences\Properties\SystemFont="Arial Cyr" |
Модуль данных для каждого MDIChild.
| Автор: Pat Ritchey |
| Встречаются два программиста. - Хочешь, новый анекдот про Билла Гейтса расскажу? - Давай! - Приходит утром слуга к БГ, а тот умер! - А дальше? - Ну, дальше я не запомнил... Ho какое начало! |
С помощью Репозитория создайте "standard MDI application" (стандартное MDI-приложение), в котором модуль TMDICHild будет похож на приведенный ниже. Добавленные строки имеют комментарий {!}. Хитрости спрятаны в конструкторе create и задании другого порядка следования операторов.
unit Childwin;
interface
uses Windows, Classes, Graphics, Forms, Controls,
ExtCtrls, DBCtrls, StdCtrls, Mask, Grids, DBGrids,
DataM; {!} // Модуль TDataModule1
type
TMDIChild = class(TForm)
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
DBEdit1: TDBEdit;
DBEdit2: TDBEdit;
DBNavigator1: TDBNavigator;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
{!} DM: TDataModule1;
{!} constructor Create(AOwner: TComponent); override;
end;
implementation
{$IFDEF XOXOXOX} // DataM должен находиться в секции interface. Необходимо для среды
uses DataM; // времени проектирования. Определение "XOXOXOX" подразумевает,
{$ENDIF} // что это никогда не будет определено, но чтобы компилятор видел это.
{$R *.DFM}
{!} constructor TMDIChild.Create;
{!}
begin
{!} DM := TDataModule1.Create(Application);
{!} inherited Create(AOwner);
{!} DM.Name := '';
{!}
end;
procedure TMDIChild.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
end.
|
Borland DataSnap против Microsoft ADO.NET.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
Borland DataSnap vs Microsof ADO.NET ==================================== Delphi 7 and .NET Framework 1.1 A comparison between the tools provided by these two technologies for building data aware applications. Data access technologies: ========================= Everybody knows that Borland DataSnap provides four data access technologies. While ADO.NET is a data access technology, it provides four embedded data access technologies. Third party companies provide data access technologies for both. *** Borland DataSnap *** - Borland Database Engine (BDE) - dbExpress (DBX) - InterBase Express (IBX) - Activex Data Objects (ADO) - Third party *** Microsoft ADO.NET *** - SQL for MS SQL Server - OleDb - ODBC - Oracle - Third party Provide/Resolve =============== Both uses a provide/resolve mechanism. You first provide data to a component which holds data in memory in a disconnected fashion. Changes to this data are hold in memory too. Then you apply this changes to the underlying database. So what you need is... Components to establish a connection: ------------------------------------- This components let you establish a connection with a database and manage transactions. *** Borland DataSnap *** - Session and Database - SQLConnection - IBDatabase and IBTransaction - ADOConnection - Third party *** Microsoft ADO.NET *** - SQLConnection - OleDbConnection - ODBCConnection - OracleConnection - Third party Borland DataSnap connection components have many similarities between them but they all are different. All Microsoft ADO.NET connection components implements the same interface. Components to obtain data: -------------------------- This components let you obtain a data set form a database through one of the connection components. *** Borland DataSnap *** - Table, Query, StoredProc - SQLTable, SQLQuery, SQLStoredProc, SQLDataSet - IBTable, IBQuery, IBStoredProc, IBDataSet - ADOTable, ADOQuery, ADOStoredProc, ADODataSet - Third party *** Microsoft ADO.NET *** - SQLCommand, SQLDataReader - OleDbCommand, OleDbDataReader - ODBCCommand, OleDbDataReader - OracleCommand, OracleDataReader - Third party Borland DataSnap components used to obtain data have many similarities between them but they all are different. All Microsoft ADO.NET components used to obtain data implements the same interface. While some of the Borland DataSnap components used to obtain data let you obtain a read-write, bi-directional data sets, all Microsoft components used to obtain data provide read-only, forward-only data sets. Components to provide data and resolve changes: ----------------------------------------------- This components do two main things: provide data and resolve changes. While Borland DataSnap component can perform it in a connected and disconnected fashion, Microsoft ADO.NET component can perform it only in a disconnected fashion. *** Borland DataSnap *** - DataSetProvider Provide: - Connect it to a DataSet and it provides data to a ClientDataSet. The DataSet must implements IProviderSupport interface. - If the connected DataSet is a master DataSet it recognize the master/detail relationship and provide data treating master record and its detail records as a unit. Resolve: - It generates SQL statements on the fly using information form the connected DataSet, even if you use JOINs. - It treats master and details as a unit and generates transactions for updating master and details in the same transaction and updates data in the correct order (for inserts, first master and then details; for deletes, first details and then master). - It lets you configure how SQL statement should be generated. - It manages concurrency. *** Microsoft ADO.NET *** - DataAdapter Provide: - You use a DataAdapter to fill a DataSet with records. It could use embedded Command components or it could be connected to your Command components. - DataAdapter does not recognize master/detail relationships. You need to use one DataAdapter for each table. Resolve: - It generates SQL statements on the fly using information from the SELECT statement, but only for single tables. - You must use one DataAdapter for each table so it updates only one table. - It does not let you configure how SQL statement should be generated. - It manages concurrency. Components to hold data and changes in memory: ---------------------------------------------- This components hold data and changes to that data in memory. Both can save its data to a file on disk and resolve updates later. *** Borland DataSnap *** - ClientDataSet - It is aware of the DataSetProvider so they work together to apply updates and reconcile update errors. - Details are an extra field of the master. If you modify details you also modify the master. - It provides functionality to obtain details and BLOBs on demand. *** Microsoft ADO.NET *** - DataSet - It doesn't aware of the DataAdapter so they don't work synchronized and it doesn''t know about update errors. - Has a collection of tables and relations between this tables. If you modify details you don''t modify the master. - It doesn''t provide functionality to obtain details and BLOBs on demand. Conclusions =========== Borland DataSnap is a mature technology while Microsoft ADO.NET is an emerging, new technology with an excellent starting point. You can accomplish the same task with both technologies but you need to code a lot more with Microsoft ADO.NET. With DataSetProvider and ClientDataSet from Borland DataSnap you get more than with DataAdapter and DataSet from Microsoft ADO.NET. Pablo ReyesОтследить изменение данных.
Автор: Nomadic Предположим, что пользователь изменил строковое поле в Null. Как тогда я в обработчике OnUpdateData смогу определить, изменилось ли это поле на строку Null, или поле просто не было изменено?Используйте свойство NewValue класса TField при чтении второй записи (той, которая содержит изменения). Если возвращаемое значение (variant) пусто или не назначено, тогда поле не было модифицировано. Здесь немного иллюстрирующего кода:
var
NewVal: Variant;
begin
NewVal := DataSet.FieldByName('MyStrField').NewValue;
if VarIsEmpty(NewVal) then
ShowMessage('Field was not edited')
else if VarIsNull(NewVal) then
ShowMessage('Field was blanked out')
else
ShowMessage('New Field Value: ' + String(NewVal));
end;
|
Если Вы взглянете на исходники формы RecError (в репозитории), то Вы увидите, как она использует эту информацию для вывода строки '' при показе ошибок синхронизации данных. На сервере Вы добавляете ограничения уровня записи, используя свойство Constraints Вашего TQuery/TTable или ограничения уровня поля, используя постоянные обьекты TField (с помощью FieldsEditor либо на CustomConstraint, либо ImportedConstraint). Если Вы используете ограничения уровня поля, они вступают в силу, когда данныеотправляются в поле (например, когда Вы уходите из органа управления, связанного с этим полем (типа TDBEdit)).
Компоненты для облегчения работы с типовыми операциями поиска, выбора и фильтрации данных.
Оформил: DeeCo
Автор: Андрей Камбалов.
Набор компонент писался для облегчения работы с типовыми операциями поиска, выбора и фильтрации данных. TAkLstData предназначена для вывода и выбора данных из набора данных в виде списка. Имеется возможность фильтрации этого списка. Множественный выбор. TAkTreeData предназначена для вывода и выбора данных из набора данных. Данные представлены в виде дерева. Существует возможность множественного выбора. TAkFilterData позволяет в диалоге задать условия отбора данных используемые в TQuery в разделе WHERE. TEditDataForm позволяет получать данные (строка, дата, число) А-ля редактор свойств параметра ключа в реестре. TAkFindGrid позволяет искать данные в DBGrid. Rомпоненты оттестированы для Delphi 5 и необходимо наличие библиотеки RxLib. Имеется краткая помощь и демо.Скачать компоненты: AkComp.zip (107K).
Изменение данных в Delphi 2 (BDE).
Автор: Rob Edgar ...из исходного кода VCL я обнаружил, что при назначении значения DB-полю, имеющему строковый тип, значение "проходит" через функцию ANSItoNative, что может привести к изменению (порче) ASCII-данных. Вот так... Как 16-, так и 32-битные версии IDAPI.CFG устанавливаются с драйвером языка Paradox 'ascii'. Я создал простое приложение, записывающее в db-поле значения ASCII в диапазоне 0-255 и затем проверяющее их на предмет появившихся различий..... различия между 16- и 32-битной версией не так велики... для примера... в первых 130 значениях получается следующее преобразование:16-бит: 21->182 22->167 31->33 130->128 32-бит: 130->128Очевидно достаточно просто "исправить" 32-битные приложения, чтобы добиться такого же результата, что и получаемые 16-битными приложениями, НО я не уверен что решив проблему на моем PC, я решу ее у остальных пользователей, поскольку могут отличаться установки, драйверы языка... и пр. После того как я проверил все возможные варианты, я составил таблицу и занес туда пять возможных значений, которые могут отличаться под Delphi2 и Delphi1:
Значение ASCII Delphi1 Delphi2
21 182 21
22 167 22
33 31 33
132 102 132
255 121 255
Хранение данных в EXE-файле.
Автор: Peter BelowВы можете включить любой тип данных как RCDATA или пользовательских тип ресурса. Это очень просто. Данный совет покажет вам общую технику создания такого ресурса.
Type
TStrItem = String[39]; { 39 символов + байт длины -> 40 байтов }
TDataArray = Array [0..7, 0..24] of TStrItem;
Const
Data: TDataArray = (
('..', ...., '..' ), { 25 строк на строку }
... { 8 таких строк }
('..', ...., '..' )); { 25 строк на строку }
|
Данные размещаются в вашем сегменте данных и занимают в нем 8K. Если это слишком много для вашего приложения, поместите реальные данные в ресурс RCDATA. Следующие шаги демонстрируют данный подход. Создайте небольшую безоконную программку, объявляющую типизированную константу как показано выше, и запишите результат в файл на локальный диск:
program MakeData;
type
TStrItem = string[39]; { 39 символов + байт длины -> 40 байтов }
TDataArray = array[0..7, 0..24] of TStrItem;
const
Data: TDataArray = (
('..', ...., '..'), { 25 строк на строку }
... { 8 таких строк }
('..', ...., '..')); { 25 строк на строку }
var
F: file of TDataArray;
begin
Assign(F, 'data.dat');
Rewrite(F);
Write(F, Data);
Close(F);
end.
|
DATAARRAY RCDATA "data.dat"Сохраните это, откройте сессию DOS, перейдите в каталог где вы сохранили data.rc (там же, где и data.dat!) и выполните следующую команду:
brcc data.rc (brcc32 для Delphi 2.0)
Теперь вы имеете файл data.res, который можете подключить к своему Delphi-проекту. Во время выполнения приложения вы можете генерировать указатель на данные этого ресурса и иметь к ним доступ, что и требовалось.
{ в секции interface модуля }
type
TStrItem = string[39]; { 39 символов + байт длины -> 40 байтов }
TDataArray = array[0..7, 0..24] of TStrItem;
PDataArray = ^TDataArray;
const
pData: PDataArray = nil; { в Delphi 2.0 используем Var }
implementation
{$R DATA.RES}
procedure LoadDataResource;
var
dHandle: THandle;
begin
{ pData := Nil; если pData - Var }
dHandle := FindResource(hInstance, 'DATAARRAY', RT_RCDATA);
if dHandle <> 0 then
begin
dhandle := LoadResource(hInstance, dHandle);
if dHandle <> 0 then
pData := LockResource(dHandle);
end;
if pData = nil then
{ неудача, получаем сообщение об ошибке с помощью
WinProcs.MessageBox, без помощи VCL, поскольку здесь код
выполняется как часть инициализации программы и VCL
возможно еще не инициализирован! }
end;
initialization
LoadDataResource;
end.
|
Теперь вы можете ссылаться на элементы массива с помощью синтаксиса pData^[i,j].
Передача в Word данных и формирование таблицы.
Время теряется на переключение проццесов. Чем больше таблица тем хуже. Каждая клетка таблицы это переключение. Сформируйте стороку данных передайте Word (один процесс) затем конвертируйте текст в таблицу (второй процесс) Ниже приведе текст рабочей процедуры, написанны на Delphi 6.0 для компонентов Офиса 97. Успешно работает и с 2000.
procedure Spisok_Sotrudnikov2(Name: String);
var
{Объявление переменных, для передачи их в качестве формальных параметров в}
{ сервер автоматизации}
Shablon,FileName,Tempo,Separator,NumColumns:OleVariant;
i,k : Integer;
MyRange : Range; {Область документа}
Tabl : Table; {Одна таблица}
Pars : Paragraphs; {Массив параграфов}
Par : Paragraph; {Один параграф}
S : Array[1..9] of String;
Text : WideString;
Text1: String;
begin
Screen.Cursor:=crHourGlass;
{Оформление бегущей линейки}
Otchet_Spisok_Sotrudnikov.BitBtn1.Visible:=False;
Otchet_Spisok_Sotrudnikov.Gauge1.Visible:=True;
{Определяем файл шаблона документа и файл для сохранения результата}
Shablon:=ExtractFilePath(Application.EXEName)+'Spisok.Doc';
FileName:=ExtractFilePath(Application.EXEName)+'Spisok_Sotrudnikov1.DOC';
{Открываем шаблон документа}
Otchet_Spisok_Sotrudnikov.WordApplication1.Documents.Open(Shablon,EmptyParam
,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam);
{Связываем компоненту с существующим интерфейсом}
Otchet_Spisok_Sotrudnikov.WordDocument1.ConnectKind:=ckAttachToInterface;
Otchet_Spisok_Sotrudnikov.WordDocument1.ConnectTo(Otchet_Spisok_Sotrudnikov.
WordApplication1.ActiveDocument);
{Обязательно отключить проверки орфографии и граматики в Word}
Otchet_Spisok_Sotrudnikov.WordApplication1.Options.CheckSpellingAsYouType:=f
alse;
Otchet_Spisok_Sotrudnikov.WordApplication1.Options.CheckGrammarAsYouType:=fa
lse;
{Опредеоляем область документа}
MyRange:=Otchet_Spisok_Sotrudnikov.WordDocument1.Range(EmptyParam,EmptyParam
);
Tempo:=MyRange;
{Оформляем заголовок}
Pars:=Otchet_Spisok_Sotrudnikov.WordDocument1.Paragraphs;
Par:=Pars.Add(Tempo);
Par.Alignment:=wdAlignParagraphCenter; {Выравнивание параграфа}
Par.Range.Font.Bold:=1; {Шрифт жирный}
Par.Range.Font.Size:=14; {Размер шрифта}
Par.Range.Font.ColorIndex:=1; {Цвет шрифта зеленый}
Par.Range.InsertBefore(Name);
Tempo:=Par.Range.Get_End_; {Определяем конец области}
MyRange:=Otchet_Spisok_Sotrudnikov.WordDocument1.Range(Tempo);
{Формирование данных}
DataModule1.IBQuery2.Open;
DataModule1.IBQuery2.FetchAll;
i:=DataModule1.IBQuery2.RecordCount;
Otchet_Spisok_Sotrudnikov.Gauge1.MaxValue:=i;
Text:='? п/п@Фамилия, Имя, Отчество@Должность@Табельный номер@';
for k:=1 to i do begin
Text1:='';
Text1:=Text1+IntToStr(k)+'@';
Text:=Text+Text1;
if not DataModule1.IBQuery2.FieldByName('FML').IsNull then
S[1]:=DataModule1.IBQuery2.FieldByName('FML').Value;
if not DataModule1.IBQuery2.FieldByName('IME').IsNull then
S[2]:=DataModule1.IBQuery2.FieldByName('IME').Value;
if not DataModule1.IBQuery2.FieldByName('OTC').IsNull then
S[3]:=DataModule1.IBQuery2.FieldByName('OTC').Value;
Text1:=S[1]+' '+S[2]+' '+S[3]+'@';
Text:=Text+Text1;
S[1]:=' ';S[2]:=' ';S[3]:=' ';S[4]:=' ';S[5]:=' ';
S[6]:=' ';S[7]:=' ';S[8]:=' ';S[9]:=' ';
if not DataModule1.IBQuery2.FieldByName('NPZ').IsNull then
S[1]:=DataModule1.IBQuery2.FieldByName('NPZ').Value;
if not DataModule1.IBQuery2.FieldByName('NSP').IsNull then
S[2]:=DataModule1.IBQuery2.FieldByName('NSP').Value;
Text1:=S[1]+' '+S[2]+'@';
Text:=Text+Text1;
S[1]:=' ';S[2]:=' ';S[3]:=' ';S[4]:=' ';S[5]:=' ';
S[6]:=' ';S[7]:=' ';S[8]:=' ';S[9]:=' ';
if not DataModule1.IBQuery2.FieldByName('NNN').IsNull then
S[1]:=DataModule1.IBQuery2.FieldByName('NNN').Value;
Text1:=S[1]+'@';
Text:=Text+Text1;
S[1]:=' ';S[2]:=' ';S[3]:=' ';S[4]:=' ';S[5]:=' ';
S[6]:=' ';S[7]:=' ';S[8]:=' ';S[9]:=' ';
Otchet_Spisok_Sotrudnikov.Gauge1.Progress:=k;
DataModule1.IBQuery2.Next;
end;
{Передаем строку текста в Word}
Tempo:=MyRange;
Par:=Pars.Add(Tempo);
Par.Range.InsertBefore(Text);
{Конвертируем текст в таблицу}
Separator:='@';
NumColumns:=4;
MyRange.ConvertToTable(Separator,EmptyParam,NumColumns,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam);
{Связываем переменную и таблицу, а затем меняем размер столбцов и
выравнивание}
Tabl:=Otchet_Spisok_Sotrudnikov.WordDocument1.Range.Tables.Item(1);
Tabl.Columns.Item(1).SetWidth(30,wdAdjustNone);
Tabl.Columns.Item(2).SetWidth(250,wdAdjustNone);
Tabl.Columns.Item(3).SetWidth(250,wdAdjustNone);
Tabl.Columns.Item(4).SetWidth(200,wdAdjustNone);
Tabl.Range.Paragraphs.Format.Alignment:=wdAlignParagraphCenter;
Tabl.Range.Cells.VerticalAlignment:=wdAlignParagraphCenter;
Tempo:=Par.Range.Get_End_; {Определяем конец области}
MyRange:=Otchet_Spisok_Sotrudnikov.WordDocument1.Range(Tempo);
{Сохранение документа и отображение его в OLE контейнере (предварительный
просмотр)}
Otchet_Spisok_Sotrudnikov.WordDocument1.SaveAs(FileName);
Otchet_Spisok_Sotrudnikov.WordDocument1.Close;
{Включить проверки в Word}
Otchet_Spisok_Sotrudnikov.WordApplication1.Options.CheckSpellingAsYouType:=T
rue;
Otchet_Spisok_Sotrudnikov.WordApplication1.Options.CheckGrammarAsYouType:=Tr
ue;
Screen.Cursor:=crDefault;
Otchet_Spisok_Sotrudnikov.Gauge1.Visible:=False;
Otchet_Spisok_Sotrudnikov.BitBtn1.Visible:=True;
Otchet_Spisok_Sotrudnikov.OleContainer1.CreateLinkToFile(FileName,false);
Otchet_Spisok_Sotrudnikov.OleContainer1.Refresh;
end;
|
Функция DateSer.
Привет, я хочу в качестве совета поделиться функцией DateSer, которую я написал перед этим на VB. Данная функция весьма полезна но, к сожалению, ее нет в Delphi. Применяется она так:
DecodeDate(Date,y,m,d); NewDate:=DateSer(y-4,m+254,d+1234); |
Или приблизительно так....
function DateSer(y, m, d: Integer): TDateTime;
const
mj: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31,
31, 30, 31, 30, 31);
var
add: Integer;
begin
while (true) do
begin
y := y + (m - 1) div 12;
m := (m - 1) mod 12 + 1;
if m <= 0 then
begin
Inc(m, 12);
Dec(y);
end;
if ((y mod 4 = 0) and
((y mod 100 <> 0) or (y mod 400 = 0)))
and (m = 2) then
add := 1 //дополнительный день в феврале
else
add := 0;
if (d > 0) and (d <= (mj[m] + add)) then
break;
if d > 0 then
begin
Dec(d, mj[m] + add);
Inc(m);
end
else
begin
Inc(d, mj[m] + add);
Dec(m);
end;
end;
Result := EncodeDate(y, m, d);
end;
|
Организация цикла между двумя датами.
| Звонок в службу технической поддержки: -Как узнать есть ли у меня "WinCih"? -Переведите дату на 26 апреля... |
Для организации цикла от StartDate до StopDate, просто напишите:
trunc(StartDate) to trunc(StopDate) |
Частичный показ DateTime.
| Автор: Mike Orriss |
| Звонок из одной Московской организации в Новосибирскую: - Пожалуйста, через два часа перешлите такой-то файл по электронной почте! - А через два часа - это по вашему или по нашему времени? |
При отображении TDateTimeField в DBGrid с форматированием hh:mm (для показа только времени), любая попытка изменения времени приводит (при передаче данных) к ошибке примерно такого содержания: "'07:00 is not a valid DateTime" (07:00 - неверный DateTime). Я хотел бы посылать данные приблизительно в таком виде "trunc(oldDateTimevalue)+strtoTime(displaytext)".
Следующий обработчик события TDateTimeField OnSetText не слишком элегантен, но он работает!
procedure TForm1.Table1Date1SetText(Sender: TField; const Text: String);
var
d: TDateTime;
t: string;
begin
t := Text;
with Sender as TDateTimeField do
begin
if IsNull then
d := SysUtils.Date
else
d := AsDateTime;
AsDateTime := StrToDateTime(Copy(DateToStr(d),1,8)+' '+t);
end;
end;
|
Здесь мы исходим из предположения, что у вас имеется маска редактирования, допускающая формат hh:mm или hh:mm:ss.
Формат даты.
| Format complete... И жадно облизнуться... |
У меня есть неотложная задача: в настоящее время я разрабатываю проект, где я должен проверять достоверность введенных дат с применением маски __/__/____, например 12/12/1997.
Некоторое время назад я делал простой шифратор/дешифратор дат, проверяющий достоверность даты. Код приведен ниже.
function CheckDateFormat(SDate: string): string;
var
IDateChar: string;
x, y: integer;
begin
IDateChar := '.,\/';
for y := 1 to length(IDateChar) do
begin
x := pos(IDateChar[y], SDate);
while x > 0 do
begin
Delete(SDate, x, 1);
Insert('-', SDate, x);
x := pos(IDateChar[y], SDate);
end;
end;
CheckDateFormat := SDate;
end;
function DateEncode(SDate: string): longint;
var
year, month, day: longint;
wy, wm, wd: longint;
Dummy: TDateTime;
Check: integer;
begin
DateEncode := -1;
SDate := CheckDateFormat(SDate);
Val(Copy(SDate, 1, pos('-', SDate) - 1), day, check);
Delete(Sdate, 1, pos('-', SDate));
Val(Copy(SDate, 1, pos('-', SDate) - 1), month, check);
Delete(SDate, 1, pos('-', SDate));
Val(SDate, year, check);
wy := year;
wm := month;
wd := day;
try
Dummy := EncodeDate(wy, wm, wd);
except
year := 0;
month := 0;
day := 0;
end;
DateEncode := (year * 10000) + (month * 100) + day;
end;
|
Автоматический формат даты в компоненте Edit.
| Маугли подходит к компьютеру: - Мы с тобой одного формата, ты и я! |
procedure TForm1.Edit1Exit(Sender: TObject);
begin
if Edit1.Text <> '' then
begin
try
StrToDate(Edit1.Text);
except
Edit1.SetFocus;
MessageBeep(0);
raise Exception.Create('"' + Edit1.Text
+ '" - некорректная дата');
end {try};
Edit1.Text := DateToStr(StrToDate(Edit1.Text));
end {if};
end;
|
Список объектов класса TDate.
unit Dates;
interface
uses
SysUtils, Classes;
type
TDate = class (TComponent)
private
FMonth, FDay, FYear: Integer;
FOnChange: TNotifyEvent;
protected
function DaysInMonth: Integer;
procedure SetMonth (Value: Integer);
procedure SetYear (Value: Integer);
procedure SetDay (Value: Integer);
procedure DoChange; virtual;
public
constructor Create (AOwner: TComponent); override;
constructor Init (m, d, y: Integer);
procedure SetValue (m, d, y: Integer);
function LeapYear: Boolean;
procedure Increase;
procedure Decrease;
procedure Add (NumberOfDays: Integer);
procedure Subtract (NumberOfDays: Integer);
function GetText: string;
// properties:
property Text: string read GetText;
published
property Day: Integer read FDay write SetDay;
property Month: Integer read FMonth write SetMonth;
property Year: Integer read FYear write SetYear;
// event:
property OnChange: TNotifyEvent
read FonChange write FOnChange;
end;
// dates exception
type
EDateOutOfRange = class (Exception);
procedure Register;
implementation
constructor TDate.Create (AOwner: TComponent);
var
Y, D, M: Word;
begin
inherited Create (AOwner);
// today...
DecodeDate (Now, Y, M, D);
FYear := Y;
FMonth := M;
FDay := D;
end;
constructor TDate.Init (m, d, y: Integer);
begin
SetValue (m, d, y);
end;
procedure TDate.DoChange;
begin
if Assigned (FOnChange) then
FOnChange (self);
end;
procedure TDate.SetValue (m, d, y: Integer);
var
OldY, OldM: Integer;
begin
// store the old value
OldY := FYear;
OldM := FMonth;
// assing the new value
try
FYear := y;
// check the ranges
SetMonth (m);
SetDay (d);
DoChange;
except
on EDateOutOfRange do
begin
// reset the values
FYear := OldY;
FMonth := OldM;
// let the error show up
raise;
end;
end;
end;
procedure TDate.SetMonth (Value: Integer);
begin
if (Value >= 1) and (Value <= 12) then
begin
FMonth := Value;
DoChange;
end
else
raise EDateOutOfRange.Create ('Month out of range');
end;
procedure TDate.SetYear (Value: Integer);
begin
FYear := Value;
DoChange;
end;
procedure TDate.SetDay (Value: Integer);
begin
if (Value >= 1) and (Value <= DaysInMonth) then
begin
FDay := Value;
DoChange;
end
else
raise EDateOutOfRange.Create ('Day out of range');
end;
function TDate.LeapYear: Boolean;
begin
// compute leap years, considering "exceptions"
if (FYear mod 4 <> 0) then
LeapYear := False
else if (FYear mod 100 <> 0) then
LeapYear := True
else if (FYear mod 400 <> 0) then
LeapYear := False
else
LeapYear := True;
end;
function TDate.DaysInMonth: Integer;
begin
case FMonth of
1, 3, 5, 7, 8, 10, 12:
DaysInMonth := 31;
4, 6, 9, 11:
DaysInMonth := 30;
2:
if (LeapYear) then
DaysInMonth := 29
else
DaysInMonth := 28;
else
// if the month is not correct
DaysInMonth := 0;
end;
end;
procedure TDate.Increase;
begin
// if this day is not the last of the month
if FDay < DaysInMonth then
Inc (FDay) // increase the value by 1
else
// if it is not in December
if FMonth < 12 then
begin
// Day 1 of next month
Inc (FMonth);
FDay := 1;
end
else
begin
// else it is next year New Year's Day
Inc (FYear);
FMonth := 1;
FDay := 1;
end;
DoChange;
end;
// exactly the reverse of the Increase method
procedure TDate.Decrease;
begin
if FDay > 1 then
Dec (FDay) // decrease the value by 1
else
// it is the first of a month
if FMonth > 1 then
begin
// assign last day of previous month
Dec (FMonth);
FDay := DaysInMOnth;
end
else
// it is the first of January
begin
// assign last day of previous year
Dec (FYear);
FMonth := 12;
FDay := DaysInMOnth;
end;
DoChange;
end;
function TDate.GetText: string;
begin
GetText := Format ('%s %d, %d',
[LongMonthNames[Month], Day, Year]);
end;
procedure TDate.Add (NumberOfDays: Integer);
var
N: Integer;
begin
// increase the day n times
for N := 1 to NumberOfDays do
Increase;
end;
procedure TDate.Subtract (NumberOfDays: Integer);
var
N: Integer;
begin
// decrease the day n times
for N := 1 to NumberOfDays do
Decrease;
end;
procedure Register;
begin
RegisterComponents ('Md3', [TDate]);
end;
end.
|
unit DateL;
interface
uses
Classes, Dates;
type
// inheritance based
TDateListI = class (TList)
protected
procedure Put(Index: Integer; Item: TDate);
function Get (Index: Integer): TDate;
public
procedure Add (Obj: TDate);
property Items[Index: Integer]: TDate
read Get write Put; default;
end;
// wrapper based
TDateListW = class(TObject)
private
FList: TList;
function Get(Index: Integer): TDate;
procedure Put(Index: Integer; Item: TDate);
function GetCount: Integer;
public
constructor Create;
destructor Destroy; override;
function Add(Item: TDate): Integer;
function Equals(List: TDateListW): Boolean;
property Count: Integer read GetCount;
property Items[Index: Integer]: TDate
read Get write Put; default;
end;
implementation
// inherited version
procedure TDateListI.Add (Obj: TDate);
begin
inherited Add (Obj)
end;
procedure TDateListI.Put(Index: Integer; Item: TDate);
begin
inherited Put (Index, Item)
end;
function TDateListI.Get (Index: Integer): TDate;
begin
Result := inherited Get (Index);
end;
// embedded version
constructor TDateListW.Create;
begin
inherited Create;
FList := TList.Create;
end;
destructor TDateListW.Destroy;
begin
FList.Free;
inherited Destroy;
end;
function TDateListW.Get(Index: Integer): TDate;
begin
Result := FList[Index];
end;
procedure TDateListW.Put(Index: Integer; Item: TDate);
begin
FList[Index] := Item;
end;
function TDateListW.GetCount: Integer;
begin
Result := FList.Count;
end;
function TDateListW.Add(Item: TDate): Integer;
begin
Result := FList.Add(Item);
end;
function TDateListW.Equals(List: TDateListW): Boolean;
var
I: Integer;
begin
Result := False;
if List.Count <> FList.Count then Exit;
for I := 0 to List.Count - 1 do
if List[I] <> FList[I] then
Exit;
Result := True;
end;
end.
|
unit DateForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DateL;
type
TForm1 = class(TForm)
ButtonAddDates: TButton;
ButtonAddButton: TButton;
ListBox1: TListBox;
ComboBox1: TComboBox;
ButtonAddPointer: TButton;
procedure ButtonAddDatesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ButtonAddButtonClick(Sender: TObject);
procedure ButtonAddPointerClick(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
ListI: TDateListI;
ListW: TDateListW;
public
procedure UpdateList;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
Dates;
procedure TForm1.ButtonAddDatesClick(Sender: TObject);
var
I: Integer;
Date: TDate;
begin
Randomize;
for I := 1 to 10 do
begin
Date := TDate.Init (
1 + Random (12),
1 + Random (28), // required to be safe
1900 + Random (200));
ListI.Add (Date);
end;
for I := 1 to 10 do
begin
Date := TDate.Init (
1 + Random (12),
1 + Random (28), // required to be safe
1900 + Random (200));
ListW.Add (Date);
end;
UpdateList;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ListI := TDateListI.Create;
ListW := TDateListW.Create;
ComboBox1.ItemIndex := 0;
end;
procedure TForm1.ButtonAddButtonClick(Sender: TObject);
begin
ListW.Add (TDate(Sender));
TList(ListI).Add (Sender);
UpdateList;
end;
procedure TForm1.ButtonAddPointerClick(Sender: TObject);
var
P: Pointer;
begin
P := @Form1;
ListW.Add (P);
ListI.Add (P);
UpdateList;
end;
procedure TForm1.UpdateList;
var
I: Integer;
begin
ListBox1.Clear;
try
if ComboBox1.ItemIndex = 0 then
for I := 0 to ListI.Count - 1 do
Listbox1.Items.Add (
ListI [I].GetText)
else
for I := 0 to ListW.Count - 1 do
Listbox1.Items.Add (
ListW [I].GetText);
except
on E:Exception do
Listbox1.Items.Add ('Error: ' +
E.MEssage);
end;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
UpdateList;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
I: Integer;
begin
// remove objects from lists
for I := 0 to ListW.Count - 1 do
ListW [I].Free;
for I := 0 to ListI.Count - 1 do
ListI [I].Free;
end;
end.
|
Загрузить весь проект
Преобразование даты в строку для SQL-сервера.
Автор: Сергей WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Преобразование даты в строку для SQL-сервера
Преобразование даты в строку для SQL-сервера
Зависимости: ???
Автор: Сергей, nfkazak@inbox.ru, Краснодар
Copyright: VIP BANK
Дата: 11 сентября 2002 г.
***************************************************** }
function SQL_Date_String(Date: TDateTime): string;
var
OldFormat: string;
ResultStr: string;
begin
if Date > 0 then
begin
OldFormat := ShortDateFormat;
ShortDateFormat := 'mm/dd/yyyy';
ResultStr := DateToStr(Date);
ShortDateFormat := OldFormat;
ResultStr[3] := '/';
ResultStr[6] := '/';
Result := '''' + ResultStr + '''';
end
else
Result := '';
end;
Преобразование даты типа TDateTime в дату прописью.
Автор: LexusR WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> преобразование даты типа TDateTime в дату прописью
преобразование даты типа TDateTime в дату прописью
типа : "четырнадцатое ноября две тысячи третьего года"
Зависимости: Windows,SysUtils
Автор: LexusR, ICQ:41627622, Novosibirsk
Copyright: LexusR
Дата: 12 декабря 2003 г.
***************************************************** }
const
MonthNames: array[1..12] of string = ('января', 'февраля', 'марта', 'апреля',
'мая', 'июня', 'июля', 'августа', 'сентября', 'октября', 'ноября',
'декабря');
NamesOfThousand0: array[1..2] of string = ('тысячного', 'двухтысячного');
NamesOfThousand: array[1..2] of string = ('одна тысяча', 'две тысячи');
NamesOfHandreds0: array[1..9] of string = ('сотого', 'двухсотого',
'трехсотого',
'четырехсотого', 'пятисотого', 'шестисотого', 'семисотого',
'восьмисотого', 'девятисотого');
NamesOfHandreds: array[1..9] of string('сто', 'двести', 'триста', 'четыреста',
'пятьсот', 'шестьсот', 'семьсот', 'восемьсот', 'девятьсот');
NamesOfTens00: array[1..3] of string('десятое', 'двадцатое', 'тридцатое');
NamesOfTens0: array[1..9] of string('десятого', 'двадцатого',
'тридцатого', 'сорокового', 'пятидесятого', 'шестидесятого',
'семидесятого', 'восьмидесятого', 'девяностого');
NamesOfTens: array[2..9] of string = ('двадцать', 'тридцать', 'сорок',
'пятьдесят', 'шестьдесят', 'семьдесят', 'восемьдесят', 'девяносто');
NamesOfFistTen0: array[1..9] of string = ('одинадцатое', 'двенадцатое',
'тринадцатое', 'четырнадцатое', 'пятнадцатое', 'шестнадцатое',
'семнадцатое',
'восемьнадцатое', 'девятнадцатое');
NamesOfFistTen: array[1..9] of string = ('одинадцатого', 'двенадцатого',
'тринадцатого', 'четырнадцатого', 'пятнадцатого', 'шестнадцатого',
'семнадцатого', 'восемьнадцатого', 'девятнадцатого');
NamesOfUnits0: array[1..9] of string = ('первое', 'второе', 'третье',
'четвертое', 'пятое', 'шестое', 'седьмое', 'восьмое', 'девятое');
NamesOfUnits: array[1..9] of string = ('первого', 'второго', 'третьего',
'четвертого', 'пятого', 'шестого', 'седьмого', 'восьмого', 'девятого');
function ConvertDateToString(Date: TDateTime): string;
var
year, month, day: word;
th, hn, tn, un: word;
begin
DecodeDate(Date, year, month, day);
// разбираем число
tn := day div 10;
un := day mod 10;
if un = 0 then
result := NamesOfTens00[tn]
else if tn = 0 then
result := NamesOfUnits0[un]
else if tn = 1 then
result := NamesOfFistTen0[un]
else
result := NamesOfTens[tn] + ' ' + NamesOfUnits0[un];
// разбираем месяц
result := result + ' ' + MonthNames[month];
// разбираем год
th := year div 1000;
hn := year mod 1000 div 100;
tn := year mod 1000 mod 100 div 10;
un := year mod 1000 mod 100 mod 10;
if ((hn = 0) and (tn = 0) and (un = 0)) then
begin
result := result + ' ' + NamesOfThousand0[th] + ' года';
exit;
end
else
result := result + ' ' + NamesOfThousand[th];
if hn > 0 then
begin
if ((tn = 0) and (un = 0)) then
begin
result := result + ' ' + NamesOfHandreds0[hn] + ' года';
exit;
end
else
result := result + ' ' + NamesOfHandreds[hn];
end;
if un = 0 then
result := result + ' ' + NamesOfTens0[tn]
else if tn = 0 then
result := result + ' ' + NamesOfUnits[un]
else if tn = 1 then
result := result + ' ' + NamesOfFistTen[un]
else
result := result + ' ' + NamesOfTens[tn] + ' ' + NamesOfUnits[un];
result := result + ' года'
end;
Дни недели.
unit datefunc;
interface
function checkdate(date: string): boolean;
function Date2julian(date: string): longint;
function Julian2date(julian: longint): string;
function DayOfTheWeek(date: string): string;
function idag: string;
implementation
uses
sysutils;
function idag(): string;
{Получает текущую дату и возвращает ее в формате YYYYMMDD для использования
другими функциями данного молуля.}
var
Year, Month, Day: Word;
begin
DecodeDate(Now, Year, Month, Day);
result := IntToStr(year) + IntToStr(Month) + IntToStr(day);
end;
function Date2julian(date: string): longint;
{Получает дату в формате YYYYMMDD.
Если у вас другой формат,
в первую очередь преобразуйте его.}
var
month, day, year: integer;
ta, tb, tc: longint;
begin
month := strtoint(copy(date, 5, 2));
day := strtoint(copy(date, 7, 2));
year := strtoint(copy(date, 1, 4));
if month > 2 then
month := month - 3
else
begin
month := month + 9;
year := year - 1;
end;
ta := 146097 * (year div 100) div 4;
tb := 1461 * (year mod 100) div 4;
tc := (153 * month + 2) div 5 + day + 1721119;
result := ta + tb + tc
end;
function mdy2date(month, day, year: integer): string;
var
y, m, d: string;
begin
y := '000' + inttostr(year);
y := copy(y, length(y) - 3, 4);
m := '0' + inttostr(month);
m := copy(m, length(m) - 1, 2);
d := '0' + inttostr(day);
d := copy(d, length(d) - 1, 2);
result := y + m + d;
end;
function Julian2date(julian: longint): string;
{Получает значение и возвращает дату в формате YYYYMMDD}
var
x, y, d, m: longint;
month, day, year: integer;
begin
x := 4 * julian - 6884477;
y := (x div 146097) * 100;
d := (x mod 146097) div 4;
x := 4 * d + 3;
y := (x div 1461) + y;
d := (x mod 1461) div 4 + 1;
x := 5 * d - 3;
m := x div 153 + 1;
d := (x mod 153) div 5 + 1;
if m < 11 then
month := m + 2
else
month := m - 10;
day := d;
year := y + m div 11;
result := mdy2date(month, day, year);
end;
function checkdate(date: string): boolean;
{Дата должна быть в формате YYYYMMDD.}
var
julian: longint;
test: string;
begin
{Сначала преобразовываем строку в юлианский формат даты.
Это позволит получить необходимое значение.}
julian := Date2julian(date);
{Затем преобразовываем полученную величину в дату.
Это всегда будет правильной датой. Для проверки делаем обратное преобразование.
Результат проверки передаем как выходной параметр функции.}
test := Julian2date(julian);
if date = test then
result := true
else
result := false;
end;
function DayOfTheWeek(date: string): string;
{Получаем дату в формате YYYYMMDD
и возвращаем день недели.}
var
julian: longint;
begin
julian := (Date2julian(date)) mod 7;
case julian of
0: result := 'Понедельник';
1: result := 'Вторник';
2: result := 'Среда';
3: result := 'Четверг';
4: result := 'Пятница';
5: result := 'Суббота';
6: result := 'Воскресенье';
end;
end;
end.
|
Тем не менее, начиная со второй версии, Delphi содержат в своем арсенале замечательную функцию DayOfWeek, возвращающую целочисленный результат в диапазоне от 1 до 7. Вот пример кода, присланный Андреем Ивановым:
uses SysUtils;
...
function TForm1.DayOfWeekRus(S: TDateTime): string;
begin
case DayOfWeek(S) of
1: Result := 'Воскресенье';
2: Result := 'Понедельник';
3: Result := 'Вторник';
4: Result := 'Среда';
5: Result := 'Четверг';
6: Result := 'Пятница';
7: Result := 'Суббота';
end;
end;
|
Получить номер дня в году.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetDays(ADate: TDate): Extended;
var
FirstOfYear: TDateTime;
begin
FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yyyy', now)) - 1, 12, 31);
Result := ADate - FirstOfYear;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := 'Today is the ' + FloatToStr(GetDays(Date)) + '. day of the year';
end;
Почему DB2 ругается на Create Trigger.
| Автор: Nomadic |
| Приходит программер в магазин: - У ваз майонезз езззь? - Езььь. - Рулезззь! |
Я тут писал по поводу того, что у меня не работали триггеры. Все дело оказалось в правиле написания команды "create trigger". Если все остальные команды корректно воспринимаются на любом регистре, то эта - только набранная одними большими буквами.
Как заставить работать DB2 через протокол IPX.
| Автор: Nomadic |
| Подождите, идет подготовка к зависанию компьютера... |
|------------------------------------------------------------------ |db2 update dbm cfg using fileserver objectname dbserver |------------------------------------------------------------------где - <NWSERVER> - имя сервера; выполнить командный файл DBIPXSET.CMD; перестартовать сервер базы данных; создать командный файл DBIPXREG.CMD следующего вида:
|---------------------------------------------------------------- |db2 register nwbindery user |----------------------------------------------------------------где - <USERNAME> - имя пользователя, обладающего правами администратора на сервере <NWSERVER> ; выполнить командный файл DBIPXREG.CMD; ответить на запрос пароля.1.1.2. WINDOWS - клиент установить WINDOWS 3.1 или WfWG 3.11; установить клиента NETWARE от версии 4.х; при установке влючить поддержку WINDOWS; установить клиента DB2 для WINDOWS; используя программу Client Setup описать новый узел - сервер базы данных :
Name - <любое имя> Protocol - IPX/SPX File server - <NWSERVER> Object name - dbserverописать базу данных и разрешить доступ к ней через ODBC.1.2. Конфигурация для доступа через прямую адресацию 1.2.1. DB2 Сервер см. п 1.1.1; найти в директории x:\sqllib\misc программу DB2IPXAD.EXE и выполнить ее; записать полученный адрес;1.2.2. WINDOWS - клиент см. п. 1.1.2. (первые три шага); используя программу Client Setup описать новый узел - сервер базы данных :
Name - <любое имя> Protocol - IPX/SPX File server - * Object name - <адрес полученный от DB2IPXAD.EXE>описать базу данных и разрешить доступ к ней через ODBC.
DBase и особые случаи BDE.
| Ну и запросы у вас - сказала база данных и повисла. |
if (( Pos('(',cTagExp) + Pos('+',cTagExp) ) > 0 ) then
Table1.AddIndex( cTagName, cTagExp, [ixExpression]) // <- ixExpression - _литерал_
else
Table1.AddIndex( cTagName, cTagExp, []);
|
with Table1 do StrPCopy( TName, TableName ); Result := DBIPackTable( DbHandle, Handle, TName, szDBASE, TRUE ); |
DbiSetProp( hDBIObj(Table1.Handle), curSOFTDELETEON, LongInt(bValue)); |
DbiSetProp( hDBIObj(Table1.Handle), curINEXACTON, LongInt(bValue)); |
Текущий номер записи набора данных.
{Извлекает физический номер записи xBase. Требует наличие модулей
DBITYPES, DBIPROCS, и DBIERRS в списке используемых модулей.
Функция требует на входе один аргумент типа TTable (например, Table1).}
function Form1.Recno(oTable: TTable): Longint;
var
rError: DBIResult;
rRecProp: RECprops;
szErrMsg: DBIMSG;
begin
Result := 0;
try
oTable.UpdateCursorPos;
rError := DbiGetRecord(oTable.Handle, dbiNOLOCK, nil, @rRecProp);
if rError = DBIERR_NONE then
Result := rRecProp.iPhyRecNum
else
case rError of
DBIERR_BOF: Result := 1;
DBIERR_EOF: Result := oTable.RecordCount + 1;
else
begin
DbiGetErrorString(rError, szErrMsg);
ShowMessage(StrPas(szErrMsg));
end;
end;
except
on E: EDBEngineError do
ShowMessage(E.Message);
end;
end;
|
Показ меток удаленных записей в dBASE-файлах.
Для начала вы должны включить SoftDeletes, после чего вы сможете просматривать записи, помеченные к удалению. В противном случае, вы их не увидите. По умолчанию, для файлов DBF, SoftDeletes установлен в False. Вот логика работы:
procedure TForm1.Button1Click(Sender: TObject);
var
B: BOOL;
W: Word;
begin
Check(DbiSetProp(hDBIObj(Table1.Handle), curSOFTDELETEON,
longint(True)));
{ Проверяем, что это работает }
Check(DbiGetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, @B,
sizeof(B), W));
if B = False then
Label2.Caption := 'Не помечена'
else
Label2.Caption := 'Помечена';
end;
|
Когда указатель на запись указывает на запись, которую вы хотите удалить, используйте следующую логику:
Table1.UpdateCursorPos; Check(DbiUndeleteRecord(Table1.Handle)); |
Ну и, наконец, чтобы все работало, поместите модули DBIPROCS и DBITYPES с список USES.
Удалить индекс для dBase.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function UnCheckIndex(FileDbf: string): Boolean;
var
Dbf: file;
Car: Char;
begin
Result := T;
AssignFile(Dbf, FileDbf);
Car := #0;
{$I-}
Reset(Dbf, 1);
if not ErrorIO(FileDbf, IoResult) then
begin
Seek(Dbf, 28);
{Flag's position}
if not ErrorIO(FileDbf, IoResult) then
BlockWrite(Dbf, Car, 1, Num_R)
else
Result := F;
CloseFile(Dbf);
if ErrorIO(FileDbf, IoResult) then
Result := F;
end
else
Result := F;
{$I+}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if UnCheckIndex('MyBase.dbf') then
ShowMessage('Flag removed');
end;
DBASE - Индексы выражений.
Введение Индексы для таблиц dBASE могут базироваться на значениях из отдельной области, нередактируемых данных, или на основе выражений. Индексы выражений, уникальные для индексов dBASE, могут формироваться на основе нескольких полей, измененных значений полей или их комбинаций. Выражение для dBASE-индекса создаются с использованием dBASE-функций и синтаксиса для конкатенации нескольких полей или изменения значений поля для полей, включенных в выражения индекса. В конце данного совета включены два небольших раздела, описывающих механику создания индексов выражений dBASE, один относится к утилите Database Desktop, другой - к приложениям Delphi. Индексные выражения на основе множества полей Функции dBASE доступны для применения в Delphi или Database Desktop для ускоренного использования в выражениях индекса, и затем только в связи с индексами dBASE. То есть, вы не сможете использовать функции dBASE или синтаксис для создания выражения индекса для таблицы Paradox или Local InterBase Server (LIBS). Функции dBASE не могут использоваться при программировании в Delphi. Они доступны только для выражений индесов dBASE. Синтаксис и функции dBASE, которые могут быть использованы для выражений индексов, "расположены" в библиотечном файле Borland Database Engine (BDE) IDDBAS01.DLL. При создании индекса dBASE, который должен базироваться на двух или более полях таблицы, для которой он создается, два или более поля конкатенируются (связываются вместе) в величине, которая в некоторой степени похожа на Delphi тип String, с использованием синтакса Delphi: оператор "+". Например, выражению необходимо создать индекс, который должен базироваться в первую очередь на основе поля LastName, а затем на основе поля FirstName:LastName + FirstNameВ отличие от самого dBASE, такие индексы, основанные на нескольких полях, ограничены использованием таких же полей в таблице. dBASE допускает создание индексов, основанных на нескольких полях, содержищихся в другой таблице. Это позволяет во время создания индекса иметь открытую только "другую" таблицу или использовать таблицу, содержащую индекс. У индексов с несколькими полями для других типов таблиц (например, Paradox и InterBase), используемые поля должны быть разделены точкой с запятой (;), как показано ниже:
LastName;FirstNameВ выражениях индекса dBASE, в которых конкатенируются несколько полей, фактическое выражение должно выглядеть следующим образом:
LastName + FirstNameПри создании индексных выражений, которые конкатенируют два и более поля, все включенные поля должны иметь одинаковый тип. К тому же, если они должны конкатенироваться, вместо складывания, то все поля должны иметь тип String. Например, для двух целочисленных полей, Value1 и Value2, выражение индекса...
Value1 + Value2...не вызовет ошибку. Но в этом случае произойдет конкатенация двух значений полей и они суммируются. Таким образом, если Value1 для данной записи содержало 4, а Value2 - 5, результирующий индексный узел будет целой величиной 9, а не строковой конкантенацией "45". Если поля, включенные в выражение индекса, имеют не строковый тип, они должны быть преобразованы. Вот некоторые функции dBASE, преобразовывающие различные типы данных к строковому типу для использования в выражениях индекса: STR( [, [, ]]) Преобразовывает dBASE-тип Float или Numeric в Character (String) DTOS() Преобразовывает значение Date к Character, формат YYYYMMDD MLINE(, ) Извлекает отдельную строку из Memo-поля как значение Character Другое ограничение при создании индексов путем конкантенации нескольких полей - максимально допустимая длина индексной величины. Величина, возвращаемая индексным значением, не может превышать 100 символов. Это предел длины значения, возвращаемого выражением, не длина самого выражения. Например, вы не можете создать индекс путем конкантенации двух полей, если они оба имееют длину 255 символов. Индексные выражения на основе модификации значений полей Дополнительно к созданию индексов, основанных на конкатенации значений двух и более полей, также возможно создать индекс, основанный на модификации значений полей. Примером этого может служить создание индекса на основе первых трех символов поля типа String, года и месяца поля с типом Date, индекс с использованием конкантенации полей с типами String и Date, где значение поля типа String отсортировано по возрастающей, а поле, имеющим тип Date - по убывающей, и даже создание индекса на основе поля с логическим типом. Создание индексов на основе модификации значений полей требует, по крайней мере, практическое знание функций dBASE и синтаксиса, поскольку данная технология использует dBASE, а не функции и синтаксис Delphi. Функция dBASE SUBSTR() извлекает подстроку из поля типа String. Delphi-эквивалент данной dBASE-функции - Copy. Но только dBASE функция SUBSTR() может применяться при создании индексного выражения dBASE. Использование фунций dBASE в индексных выражениях dBASE заключается в простом включении в индексное выражение функции, использование в функциях dBASE-синтаксиса и имени (имен) поля (полей), использующихся в функциях. Например, индексное выражение на основе трех последних символов значения поля типа String с именем Code, имеющим длину 20 символов выглядит так:
RIGHT(Code, 3)Важно соблюдение следующего правила: конструкции индексных выражений dBASE, модифицирующих значения полей, должны возвращать величину с "последовательной длиной" для каждой записи таблицы, т.е. результат не должен содержать граничных пробелов. Например, функция dBASE TRIM() удаляет граничные пробелы (ASCII код 32) из значения поля типа String. Если это было использовано вместе с конкантенацией двух полей, имеющих тип String, где поле не имеет постоянной длины для разных записей, длина результирующего значения будет различная для всех записей. В свете этого рассмотрим следующий пример: построим индексное выражение на основе конкантенации полей LastName и FirstName field, где функция TRIM() применена к полю LastName:
TRIM(LastName) + FirstNameДанное выражение не возратит значения "последовательной длины" для всех записей. Если поля LastName и FirstName содержали значения...
LastName FirstName -------- --------- Smith Jonas Wesson Nancy...то результат использования индексного выражения может быть таким:
SmithJonas WessonNancyКак вы можете наблюдать, длина значения первого поля равна 10 символов, тогда как второго - 11 символов. Узлы индекса для данного индексного выражения должны базироваться на значении поля первой ненумерованной записи. Следовательно, результат выражения индекса для каждого узла должен быть равен 10 символов. В нашем примере результат вычисления для второй записи округляется до "WessonNanc". Все это приводит к тому, что поиск, основанный на поиске полных значений в полях, окончится неудачей. Решение это дилеммы кроется в не использовании функции TRIM(), а в использовании полной длины значений поля LastName, включая граничные пробелы. В индексах, которые используют функции IIF() для установления порядка одного поля или другого, основанных на сравнении логических выражений в IIF(), если два поля имеют различную длину, более короткое поле должно быть заполнено пробелами до длины большей области. Для примера, создавая индекс с использованием функции IIF(), и индексируя поля Company или Name, базирующийся на поле Category, и где поле Company длиной 40 символов, а поле Name длиной 25 симловов, поле Name необходимо дополнять 15-ю пробелами; например, с помощью dBASE-функции SPACE(). Выражение индекса в этом случае будет таким:
IIF(Category = "B", Company, Name + SPACE(15))Поиск и выражения индексов dBASE Выражения индексов dBASE являются исключениями из правил в том, как они обрабатываются Delphi и BDE, по сравнению с обработкой индексов таблиц другого типа, также основанных на множестве полей. Это вынуждает вынести dBASE-индексы в отдельный класс. Обработка таких индексов в Delphi и BDE отличается от обработки индексов для других типов таблиц. Одно из самых существенных различий заключается в том, что не все поисковые инструменты, основанные на индексах и использующие синтаксис Delphi, могут использовать выражения индексов dBASE. FindKey, FindNearest и GotoKey методы компонента TTable не годятся для работы с выражениями индексов. При попытке использования FindKey вы получите сообщение об ошибке: "Field index out of range." (Индекс поля за границами диапазона). При попытке использования метода GotoKey может произойти та же ошибка, или табличный курсор может остаться на месте (визуально искомая величина не найдена). С выражениями индексов может использоваться только метод GotoNearest. Но даже GotoNearest может не работать с некоторыми индексными выражениями. Только с помощью эксперимента можно установить - работает ли метод GotoNearest с данным индексным выражением. Фильтрация индексных выражений dBASE Как и основанный на индексах поиск, индексные выражения dBASE при использовании фильтров Delphi также имеют некоторые исключения. С активным индексным выражением метод SetRange компонента TTable приводит к следующей ошибке: "Field index out of range." (Индекс поля за границами диапазона). Тем не менее, с тем же активным индексным выражением методы SetRangeStart и SetRangeEnd успешно фильтруют набор данных.
Например, выражение индекса с конкантенацией поля LastName и активного FirstName, в приведенном ниже коде, использующем метод FindKey (предполагающий фильтрацию тех записей, где первый символ поля LastName содержит "S"), "вылетит" с ошибкой:
begin Table1.SetRange(['S'], ['Szzz']) end; |
Код, приведенный ниже, использует то же активное выражение индекса, но используемый фильтр поля LastName правильно отфильтрует данные, и не вызовет ошибки:
begin
with Table1 do
begin
SetRangeStart;
FieldByName('LastName').AsString := 'S';
SetRangeEnd;
FieldByName('LastName').AsString := 'Szzz';
ApplyRange;
end;
end;
|
Name + STR(OrdDate - {12/31/3099}, 10, 0)
Сортировка поля типа Character по-возрастающей и поля типа Numeric (или Float) по-убывающей
C полем типа Character и именем Company, и полем типа Numeric и именем Amount (поле Amount имеет длину 9 цифр с двумя цифрами после десятичной запятой):
Company + STR(Amount - 999999.99, 9, 2)Сортировка логического поля Для того, чтобы записи со значением True располагались впереди записей со значением False в логическом поле с именем Paid, выполните следующее:
IIF(Paid, "A", "Z")Два поля с типом Numeric (или Float) Предположим, у нас имеется два поля типа Numeric с пятью и двумя десятичными разрядами, первое поле с именем Price, второе - Quantity:
STR(Price, 5, 2) + STR(Quantity, 5, 2)Сортировка одного из двух полей в зависимости от выполнения логического условия Сортировка имен месяцев в поле, имеющим тип Character Предположим, поле содержит имена месяцев на английском языке ("Jan," "Feb" и т.д.), и его необходимо расположить в соответствующем порядке (имя поля M):
IIF(M="Jan", 1, IIF(M="Feb", 2, IIF(M="Mar", 3, IIF(M="Apr", 4, IIF(M="May", 5, IIF(M="Jun", 6, IIF(M="Jul", 7, IIF(M="Aug", 8, IIF(M="Sep", 9, IIF(M="Oct", 10, IIF(M="Nov", 11, 12)))))))))))(Вышеприведенный код - единственная строка кода, разбирая на несколько из-за ограничений ширины страницы.) Сортировка по первой строке Memo-поля Для Memo-поля с именем Notes:
MLINE(Notes, 1)Сортировка по средним трем символам в девятисимвольном поле типа long Для девятисимвольного поля типа long с именем StockNo:
SUBSTR(StockNo, 4, 3)Создание индексных выражений dBASE в Database Desktop В утилите Database Desktop, индексы могут создаваться как для новой таблицы (во время ее создания), так и для существующей, путем ее реструктуризации. В обоих случаях используется диалог "Define Index", использующийся для создания одного или более индексов таблицы. Для вывода диалога создания индекса ("Create Index") во время создания новой таблицы, в диалоге создания dBASE таблицы ("Create dBASE Table") (показ структуры), выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define". Чтобы вывести диалог создания индекса ("Create Index") при создании индекса для существующей таблицы, выберите Utilities|Restructure, выберите файл с таблицей в диалоге выбора файла ("Select File"), и в диалоге реструктуризации таблицы dBASE ("Restructure dBASE Table") (показ структуры таблицы) выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define". Только в диалоге создания индекса ("Create Index"), выражения индекса могут создаваться щелчком на кнопке "Expression Index" (индеск выражения) и вводом выражения в поле редактирования "Expression Index". Для ассистирования данного процесса, вы можете дважды щелкнуть на имени поля с списке полей, после чего имя поля будет помещено в область редактирования "Index Expression" в текущей точке ввода (позиция курсора). Как только нужное выражение составлено, нажмите кнопку OK. Введите имя нового индексного тэга в поле редактирования "Index Tag Name" (имя индексного тэга") в диалоге "Save Index As" (сохранить индекс как...) и нажмите "OK". (Помните, имена тэгов индексов dBASE не могут превышать десяти символов и должны соблюдать соглашения об именах dBASE.) Создание индексных выражений dBASE в приложениях Delphi dBASE-индексы могут создаваться программным путем в Delphi-приложениях как для новой таблицы (метод CreateTable компонента TTable), так и для существующей.
Для создания индекса как части новой таблицы, необходимо вызваться метод Add свойства IndexDefs компонента TTable. В нашем случае необходимо включить в набор флажков индекса флажок ixExpression. Данный флажок уникален для индексов таблиц dBASE, и может использоваться только с индексными выражениями dBASE. Для примера:
with Table1 do
begin
Active := False;
DatabaseName := 'Delphi_Demos';
TableName := 'CustInfo';
TableType := ttdBASE;
with FieldDefs do
begin
Clear;
Add('LastName', ftString, 30, False);
Add('FirstName', ftString, 20, False);
end;
with IndexDefs do
begin
Clear;
Add('FullName', 'LastName + FirstName', [ixExpression]);
end;
CreateTable;
end;
|
Добавление индекса к существующей таблицы осуществляется вызовом метода AddIndex компонента TTable. Кроме того, флажки индекса должны включать в себя значение TIndexOptions ixExpression.
Table1.AddIndex('FullName', 'LastName + FirstName', [ixExpression]);
|
Для создания индексных выражений dBASE могут использоваться только функции и синтакс, относящиеся к обработке данных. Тем не менее, полный список и описание данных функций выходит за рамки данного совета. Для получения дополнительной информации о dBASE-функциях обработки данных, обратитесь к руководству "dBASE Language Reference" или книгам и справочникам по dBASE третьих фирм.
Формат и размер dBase-поля.
Автор: Eryk Bottomley Во время выполнения программы мне необходимо получать размеры и десятичные порядки полей таблицы DBase.Следующий код иллюстрирует необходимые вызовы BDE:
procedure GetdBaseFieldTypes(t: TTable; var l: TStringList);
var
pF: pFLDDesc;
cProps: CURProps;
p: pFLDDesc;
i: Byte;
w: Word;
s: string;
oldmode: LongInt;
begin
Check(DbiGetCursorProps(t.Handle, cProps));
Check(DbiGetProp(hDBIObj(t.Handle), curXLTMODE, oldmode, SizeOf(LongInt), w));
Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, LongInt(xltNONE)));
try
if MaxAvail < (cProps.iFields * SizeOf(FLDDesc)) then
raise EOutofMemory.Create('Недостаточно памяти для процесса');
GetMem(pF, (cProps.iFields * SizeOf(FLDDesc)));
Check(DbiGetFieldDescs(t.Handle, pF));
p := pF;
for i := 1 to cProps.iFields do
begin
with p^ do
begin
s := IntToStr(iFldNum) + ' : ' + StrPas(szName) + ' : ';
case iFldType of
fldDBCHAR:
begin { Char string, строка символов }
s := s + 'CHARACTER(' + IntToStr(iUnits1) + ')';
end;
fldDBNUM:
begin { Number, число }
s := s + 'NUMBER(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) +
')';
end;
fldDBMEMO:
begin { Memo (blob), МЕМО-BLOB-поле }
s := s + 'MEMO';
end;
fldDBBOOL:
begin { Logical, лочическая величина }
s := s + 'LOGICAL';
end;
fldDBDATE:
begin { Date, поле даты }
s := s + 'DATE';
end;
fldDBFLOAT:
begin { Float, числа с плавающей точкой }
s := s + 'FLOAT(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) +
')';
end;
fldDBLOCK:
begin { Логический тип LOCKINFO }
s := s + 'LOCKINFO';
end;
fldDBOLEBLOB:
begin { OLE object (blob), OLE-объект, BLOB-поле }
s := s + 'OLE';
end;
fldDBBINARY:
begin { Binary data (blob), двоичные данные, BLOB-поле }
s := s + 'BINARY';
end;
else
s := s + 'НЕИЗВЕСТНО';
end;
end;
l.Add(s);
Inc(p);
end;
finally
Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, oldmode));
FreeMem(pF, (cProps.iFields * SizeOf(FLDDesc)));
end;
end;
|
Определение номера записи в таблице dBASE.
Таблицы dBASE применяют довольно статическую систему нумерации записей. Номер записи для данной записи (извините за тавтологию) отражает физическую позицию в табличном файле. Эти номера записей не изменяются вследствие фильтрации, упорядочивания данных или сортировки. К примеру, первая запись, хранящаяся в .DBF файле, будет иметь номер записи 1. Возможно, после некоторого упорядочивания индекса, запись будет последней из 100 записей. В этом случае запись должна оставаться с тем же номером, а не номером 100, отражающим новую позицию в сортированном наборе данных. Это противоречит таблицам Paradox, где соблюдается последовательная нумерация. Последовательная нумерация Paradox похожа на нумерацию записей dBASE, за исключением большей гибкости и отражению в номере записи ее текущей позиции в наборе данных. То есть, запись может не всегда иметь номер, установленный для нее фильтром набора данных, уменьшившим общее число записей, или при активном индексе, из-за чего может измениться отображаемый порядок записи. В приложениях для работы с базами данных, созданных с помощью Delphi и Borland Database Engine (BDE), DB-компонентами не предусмотрено извлечение и определение записи таблицы dBASE. Такая операция, тем не менее, возможна с помощью вызова из вашего приложения функций BDE. Существует несколько функций BDE, возвращающих информацию о текущей записи dBASE, например, ее номер. На самом деле, любая функция, заполняющая структуру BDE pRECProps, вполне достаточна. Например, функции BDE DbiGetRecord, DbiGetNextRecord и DbiGetPriorRecord. Естественно, только первая из них реально позволяет получить информацию о текущей записи. Две других перемещают при вводе указатель на запись, подобно методам Next и Prior компонентов TTable и TQuery. Структура pRECProps состоит из следующих полей: iSeqNum: тип LongInt; определяет текущий номер записи (относительно набора данных, включая фильтрацию и сортировку индекса); используется, если тип таблицы поддерживает последовательную нумерацию (только Paradox). iPhyRecNum: тип LongInt; определяет номер записи; используется, если тип таблицы поддерживает физические номера записи (только dBASE). bRecChanged: тип Boolean; в настоящее время не используется. bSeqNumChanged: тип Boolean; в настоящее время не используется. bDeleteFlag: тип Boolean; указывает на удаленную запись; используется, если тип таблицы поддерживает "мягкое" удаление (только dBASE).Одна из этих BDE-функций может быть вызвана из вашего приложения для заполнения данной структуры, из которой затем может быть извлечен физический номер записи. Ниже - пример использования для этой цели функции DbiGetRecord.
function RecNo(ATable: TTable): LongInt;
var
R: RECProps;
rslt: DbiResult;
Error: array[0..255] of Char;
begin
ATable.UpdateCursorPos;
rslt := DbiGetRecord(ATable.Handle, dbiNoLock, nil, @R);
if rslt = DBIERR_NONE then
Result := R.iPhyRecNum
else
begin
DbiGetErrorString(rslt, Error);
ShowMessage(StrPas(Error));
Result := -1;
end;
end;
|
Если вызов DbiGetRecord был успешным, физический номер записи из поля iPhyRecNum структуры pRECProps сохраняется в переменной Result, которая является возвращаемой функцией величиной. Чтобы указать на то, что функция потерпела неудачу (т.е., вызов фунции DbiGetRecord окончился неудачно), вместо номера записи возвращается отрицательная величина. Значение ее может быть произвольным (отрицательная величина совместимого типа) и отдается на усмотрение программисту.
Восстановление записи dBase.
Автор: Loren ScottПосле удаления записи из таблицы (dBase), возможно ли ее восстановить? Какие идеи?
function GetTableCursor(oTable: TTable): hDBICur; var szTable: array[0..78] of Char; begin StrPCopy(szTable, oTable.TableName); DbiGetCursorForTable(oTable.DBHandle, szTable, nil, Result); end; function dbRecall(oTable: TTable): DBIResult; begin Result := DbiUndeleteRecord(GetTableCursor(oTable))); end; |
Предположим, у вас на форме имеется кнопка (с именем 'butRecall'), восстанавливающая текущую отображаемую (или позиционируемую курсором) запись, данный код, будучи расположенный в обработчике события кнопки OnClick (вместе с опубликованным выше кодом), это демонстрирует (продвигаясь в наших предположених дальше, имя вашего объекта TTable - Table1 и имя текущей формы - Form1):
procedure TForm1.butRecallClick(Sender : TObject);
begin
if dbRecall( Table1 ) <> DBIERR_NONE then
ShowMessage( 'Не могу восстановить запись!' );
end;
|
Различные цвета строк в DBCtrlGrid.
| Ученый-компьютерщики решили облегчить жизнь юзеров и создали ракету системы "Земля - Провайдер". |
Используйте событие drawColumnCell. И не забудьте выставить defautlDrawing в False.
procedure TMain.ProjectGridDrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
projectGrid.canvas.brush.color := clWindow;
projectGrid.canvas.fillRect(rect);
if gdSelected in state then
begin
projectGrid.canvas.brush.color := clHighlight;
if fsBold in projectGrid.canvas.font.style then
begin
projectGrid.canvas.font.color := clHighlightText;
projectGrid.canvas.font.style := [fsBold];
end
else
projectGrid.canvas.font.color := clHighlightText;
end
else if gdFocused in state then
begin
projectGrid.canvas.brush.color := clWindow;
if fsBold in projectGrid.canvas.font.style then
begin
projectGrid.canvas.font.color := clWindowText;
projectGrid.canvas.font.style := [fsBold];
end
else
projectGrid.canvas.font.color := clWindowText;
end
else if gdFixed in state then
begin
projectGrid.canvas.brush.color := clHighlight;
if fsBold in projectGrid.canvas.font.style then
begin
projectGrid.canvas.font.color := clHighlightText;
projectGrid.canvas.font.style := [fsBold];
end
else
projectGrid.canvas.font.color := clHighlightText;
end;
with globalDataModule.qProjects do
begin
// тестовая запись. Устанавливаем свойства для перекрытия заданных по умолчанию;
if fieldByName('EST_COMPL_DATE').asDateTime < date then
projectgrid.Canvas.font.color := clRed;
if compareStr(fieldByName('STAT_CODE').asString, 'HD') = 0 then
projectgrid.Canvas.font.color := clOlive;
if (compareStr(fieldByName('CHANGED').asString, 'Y') = 0) and
(fieldByName('ASSIGN_EMP_ID').asInteger = userRecord.UserId) then
projectgrid.Canvas.font.style := [fsBold];
end;
projectGrid.canvas.textOut(rect.left + 2, rect.top + 2, column.field.text);
end;
|
Insert и Override с помощью DBEdit.
| Автор: Denis Sarrazin |
| Попал програмист в ад. Прошло несколько дней. Дьявол звонит Богу: - Забери от меня, Христа ради, этого идиота. Он мне всех чертей вилами переколол, а теперь бегает ищет выход на второй уровень. |
Сначала я добавляю к моей форме свойство (и соответствующие переменные и процедуры), наподобие этому:
private FinsertMode: boolean; procedure SetInsertMode(value: boolean); public property insertMode: boolean read FinsertMode write SetInsertMode; |
В обработчике создания события формы я инициализирую его:
procedure TForm1.FormCreate(Sender: TObject);
begin
{инициализация}
insertMode := True;
end;
|
Также для этого свойства я создаю процедуру SetInsertMode, которая с помощью TPanel с именем Panel1 извещает пользователя о текущем режиме работы:
procedure TForm1.SetInsertMode(value: boolean); begin FinsertMode := value; if FinsertMode then Panel1.Caption := 'ВСТАВКА' else Panel1.Caption := 'ПЕРЕЗАПИСЬ'; end; |
Затем я добавляю три обработчика событий (OnKeyDown, OnKeyPress, OnEnter) для каждого моего DBEdit (можно при наличии нескольких компонентов создать один общий обработчик для всех):
procedure TForm1.DBEditKeyDown(Sender: TObject; var Key: Word; Shift:
TShiftState);
begin
if (Key = VK_INSERT) then
insertMode := not insertMode;
end;
procedure TForm1.DBEditKeyPress(Sender: TObject; var Key: Char);
begin
if (not insertMode) and (Sender is TDBEdit) then
(Sender as TDBEdit).SelLength := 1
else
(Sender as TDBEdit).SelLength := 0;
end;
procedure TForm1.DBEditEnter(Sender: TObject);
begin
insertMode := True;
end;
|
Банзай! Похоже это работает, хотя я и не имел достаточного времени протестировать это. Естественно, вы можете изменить это по просьбе вашего заказчика (например, я всегда сбрасывал режим во вставку при перемещении к другому компоненту DBEedit). Все вышесказанное должно также работать без проблем и с компонентами Edit.
Исправление DBEdit MaxLength.
| Автор: Reinhard Kalinke |
| Аксиомы: 1. Купи Pentium IV и увидишь, что REBOOT там намного быстрее. 2. У программ нет глюков. Они просто содержат неизвестные тебе функции. 3. Лучший метод сжатия файлов: DEL *.* - 100% сжатие. 4. Пентиум III - это такая новая модель процессоров, делающая ошибки в 10 раз быстрее. 5. Секрет Windows: Запусти на Пентиуме эмулятор PC XT. 6. Компьютер - это устройство, созданное для скоростного создания и автоматизации ошибок. 7. E-mail, возвращенный отправителю, означает несоответствие напряжений в Сети. 8. Компьютеры делают очень быстро и аккуратно стандартные ошибки. |
По-моему, это является следствием этого кода в TDBEdit.DataChange (DBCTRLS.PAS):
if FDataLink.Field <> nil then
begin
...
if FDataLink.Field.DataType = ftString then
MaxLength := FDataLink.Field.Size
else
MaxLength := 0;
...
end else
begin
...
MaxLength := 0;
...
end;
|
Похоже все будет работать, если вы измените строку.
MaxLength := 0; |
На.
MaxLength := inherited MaxLength; |
Если вы хотите использовать MaxLength с StringField, изменений необходимо сделать немного больше:
...
if (FDataLink.Field.DataType = ftString)
and (inherited MaxLength = 0) then
MaxLength := FDataLink.Field.Size
else
MaxLength := inherited MaxLength;
...
|
Или использовать что-то типа EditMask...
Особенности использования BLOB полей в dbExpress на примере MySQL.
Автор: Андрей Пащенко Специально для Королевства Delphi Использовать новые компоненты dbExpress удобно. Однако прилагательное «новые» приносит не только радость… Решение возникающих проблем бывает затягивается на долгие часы и дни. На помощь Internet увы надеяться не приходится, т.к. информации по dbExpress там ни так много. Одна из этих проблем – работа с BLOB полями. Использовать нативный SQL для работы с BLOB не всегда возможно, поэтому нужно применять другие, альтернативные способы.Для работы с BLOB полями в Delphi имеется несколько классов:
TBlobStream; TClientBlobStream; TBlobField; TGraphicField; TMemoField; Также сюда можно отнести функцию TCustomClientDataSet.CreateBlobStream, но она реализована посредством класса TClientBlobStream. Классы TGraphicField и TMemoField являются производными от TBlobField. TBlobStream не подходит для работы с dbExpress, а применяется только при манипулировании данным через BDE. Таким образом для работы с BLOB-полями через dbExpress остаются два ключевых класса: TBlobField и TClientBlobStream. Следовательно возможно два, принципиально различных, варианта доступа к BLOB-полям: через потоки и через свойства объекта. Как указано в справочной системе при работе с BLOB-полями вообще и dbExpress в частности достаточно удобными оказываются переменные типа String. Действительно, максимальный размер данных хранимых в переменных данного типа составляет 2 Гб, что равняется максимальному размеру BLOB-поля в MySQL (3.23.47). Строки достаточно удобны для работы с потоками, а также существует достаточно много функций для работы с ними. Проблем при работе с BLOB-полями также существует две: чтение данных и их запись. Рассмотрим каждый из возможных вариантов. Проблема №1. Чтение данных из BLOB-поля Для работы с BLOB-полями необходимо присвоить свойству TCustomClientDataSet.FetchOnDemand значение True, а также необходимо внимательно изучить свойство Options параметр poFetchBlobsOnDemand. Данные настройки нужны для того, чтобы получать данные из BLOB-поля в клиентское приложение. Загрузить данные можно используя метод FetchBlobs.Использование потоков
{описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TStream;
Memo: TMemo;
{--------------------------------------}
begin
{делаем нужную запись активной, например, методом Locate.}
Stream := qrProba.CreateBlobStream(qrProba.FieldByName('BlobF'), bmRead);
try
Image.Picture.Bitmap.LoadFromStream(Stream); {если это картинка}
{Memo.Lines.LoadFromStream(Stream); - если это текст}
finally
Stream.Free;
end;
end;
|
Использование свойства TDataSet.FieldValues.
{описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TStream;
Memo: TMemo;
{----------------------------------}
begin
{делаем нужную запись активной, например, методом Locate.}
Memo.Lines.Text := qrProba['BLOBF'];
end;
|
Использование свойства TBlobField.Value.
{описание типов переменных}
Memo: TMemo;
BLOBField: TBlobField;
{----------------------------------}
begin
{делаем нужную запись активной, например, методом Locate.}
Memo.Lines.Text := BlobField.Value; { можно так}
Memo.Lines.Text := BlobField.AsString; { а можно и так}
Memo.Lines.Text := BlobField.AsVariant; { это третий способ}
end;
|
Если необходимо обработать новую запись, то поток необходимо создавать заново. Естественно нужно не забывать своевременно уничтожать созданные потоки.
{ описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TClientBlobStream;
Memo: TMemo;
{--------------------------------------}
begin
{делаем нужную запись активной, например, методом Locate.}
qrProba.Edit;
qrProba.FetchBlobs;
Stream := TClientBlobStream.Create(TBlobField(qrProba.FieldByName('BlobF')),
bmReadWrite);
Stream.Position := 0;
Stream.Clear;
Image.Picture.Bitmap.SaveToStream(Stream);
qrProba.Post;
qrProba.ApplyUpdates(0);
Stream.Free;
end;
|
По непонятным причинам данный код не работает. Точнее данные в Stream передаются, но в базу не записываются. При этом никаких ошибок не выдается (может это bug, а может что-то в данном коде не учтено). В связи с этим, если необходимо использование потоков, следует создать промежуточный поток, затем загрузить в него данные, а потом эти данные перебросить в строковую переменную, которую в дальнейшем занести в базу. Этот способ не является самым оптимальным, но работает безотказно.
BLOBField: TBlobField;
Stream1: TMemoryStream;
d: Char;
i: Integer;
s: string;
{------------------}
begin
Stream1 := TMemoryStream.Create;
Stream.Clear;
Image.Picture.Bitmap.SaveToStream(Stream1);
Stream1.Position := 0;
for i := 1 to Stream1.Size do
begin
Stream1.Read(d, 1);
s := s + d;
end;
BlobField.DataSet.Edit;
BlobField.AsString := s;
BlobField.DataSet.Post;
TSQLClientDataSet(BlobField.DataSet).ApplyUpdates(0);
Stream1.Free;
end;
|
Использование свойства TDataSet.FieldValues.
{описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TStream;
Memo: TMemo;
{----------------------------------}
begin
{делаем нужную запись активной, например, методом Locate.}
qrProba.Edit;
qrProba['BLOBF'] := Memo.Lines.Text;
qrProba.Post;
qrProba.ApplyUpdates(0);
end;
|
Использование свойства TBlobField.Value.
{описание типов переменных}
Memo: TMemo;
BLOBField: TBlobField;
{----------------------------------}
begin
{делаем нужную запись активной, например, методом Locate.}
BlobDield.DataSet.Edit;
BlobField.Value := Memo.Lines.Text;
BlobField.DataSet.Post;
TSQLClientDataSet(BlobField.DataSet).ApplyUpdates(0);
end;
|
«И зачем все это!?», – спросит внимательный читатель, – «Ведь в начале статьи написано, что данные BLOB-поля неплохо представляются в виде String. Почему просто не записать SQL запрос UPDATE mytable SET blobf=’s’ WHERE id=1, где s – строковая переменная, которая может содержать, какие угодно данные?». Действительно, в определенных ситуациях такое решение пригодно, но предположим, что в данной переменной содержится символ { ? } , тогда сервер посчитает ее концом присваемого значения и возникнет ошибка. При использовании вышеописанных способов такого не происходит. Конечно, для исключения подобных ситуаций можно проводить предварительную обработку переменной для замены «запрещенных» символов на другие, но это дополнительная работа. В любом случае, главное: «ВОЗМОЖНОСТЬ ВЫБОРА. Выбора решения поставленной задачи».
Создание DBExpress-Connection в Run-Time.
procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
var
Connection: TSQLConnection;
DataSet: TSQLDataSet;
begin
Connection := TSQLConnection.Create(nil);
with Connection do
begin
ConnectionName := 'VCLScanner';
DriverName := 'INTERBASE';
LibraryName := 'dbexpint.dll';
VendorLib := 'GDS32.DLL';
GetDriverFunc := 'getSQLDriverINTERBASE';
Params.Add('User_Name=SYSDBA');
Params.Add('Password=masterkey');
Params.Add('Database=milo2:D:\frank\webservices\umlbank.gdb');
LoginPrompt := False;
Open;
end;
DataSet := TSQLDataSet.Create(nil);
with DataSet do
begin
SQLConnection := Connection;
CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
[Email, FirstN, LastN]);
try
ExecSQL;
except
end;
end;
Connection.Close;
DataSet.Free;
Connection.Free;
end;
|
Развертывание приложения, использующего dbExpress, на примере Delphi6.
Автор: Андрей Пащенко Специально для Королевства Delphi Начиная с Delphi 6 в палитре компонентов появилась новая закладка dbExpress. В настоящее время данные "кирпичики" широко используются в приложения для доступа к различным базам данных. Однако развернув готовое приложение на компьютере, без установленной Delphi, разработчик недоумевает о неработоспособности приложения. Возникает резонный вопрос: ЧТО ДЕЛАТЬ? Согласно справочной системе Delphi корректную работу вашего приложения в операционной системе Windows можно обеспечить двумя способами: в виде одного exe файла, либо используя дополнительные DLL библиотеки. Первый способ - единый exe файл Все что необходимо сделать для нормальной работы вашего приложения это добавить в оператор USES ссылку на три DCU файла, находящихся в директории Lib (по умолчанию C:\Program Files\Borland\Delphi6\Lib\). Первый файл имеет имя Crtl. Ссылку на него необходимо добавлять всегда, когда в приложении используется dbExpress и планируется обойтись без дополнительных DLL. Если в программе используются классы TSQLClientDataSet, TClientDataSet или их потомки, возникает необходимость добавления ссылки на файл MidasLib.В зависимости от используемого SQL сервера в оператор USES необходимо добавить:
для MySQL - dbExpMy (в случае установленного Service Pack 2 - dbExpMySQL); для InterBase - dbExpInt; для Oracle - dbExpOra; для DB2 - dbExpDb2 Второй способ - применение дополнительных DLL. Работу механизма dbExpress в программе выполняют две библиотеки. Их имена совпадают с именами DCU файлов. При наличии в устанавливаемом приложении классов TSQLClientDataSet, TClientDataSet или их потомков необходимо наличие файла Midas.dll.Вторая DLL обеспечивает связь с конкретным SQL сервером:
для MySQL - dbexpmy.dll (в случае установленного Service Pack 2 - dbExpMySQL.dll); для InterBase - dbexpint.dll; для Oracle - dbExpOra.dll; для DB2 - dbExpDb2.dll Все дополнительные библиотеки должны находится либо в директории вашей программы, либо в директориях указанных в переменной PATH. Например: C:\Windows\SYSTEM\ или C:\Winnt\SYSTEM32\ Независимо от выбранного способа вам вероятно потребуется и дополнительная DLL для доступа к серверу, которую можно найти в дистрибутиве используемого вами SQL сервера (например для MySQL это файл libmySQL.dll). Что же выбрать? В череде экспериментов in vitro (т.е. в искусственных условиях) были выявлены только два различия. Различие №1. Размеры распространяемого приложения. Если вы обходитесь без дополнительных DLL библиотек, то ваш exe файл увеличивается в размере. Приложение для тестов: Тестовый пример состоял из формы на которой размещены два не визуальных компонента: TSQLConnection, TSQLClientDataSet. Компоненты настроены для работы с SQL сервером MySQL. Все настройки компиляции установлены по умолчанию. Размер EXE файла без дополнительных DLL больше после компилирования на 245248 байта (239,5 Кб). В то же время суммарный размер одного приложения без дополнительных DLL меньше на 140800 байта (137,5 Кб) (табл. 1).Таблица 1. Размеры распространяемых файлов для приложения использующего dbExpress для доступа к SQL серверу.
| Тип файла |
Размер файлов необходимых для приложения без дополнительных DLL(байты) |
Размер файлов необходимых для приложения с дополнительными DLL(байты) |
Исполняемый файл |
985600 |
740352 |
Дополнительные DLL |
для MySQL - dbexpmysql.dll |
- |
92160 |
Midas.dll |
- |
293888 |
ИТОГО |
985600 |
1126400 |
|
Скачать MidasReg.zip (1.4K).
DBFSeek и DBFLocate.
Автор: Tom Надежней и намного быстрее (если вы ищите отдельные записи) выполнить поиск строки с помощью Seek (если найдена первая запись), или выполнить Locate (индекс не требуется)Например.
Table1.UpdateCursorPos;
if DBFSeek( Table1, xVal1 ) then {_не_ delphi-функция - смотри ниже}
begin
if DBFLocate( Table1, 'CUSTNAME', xVal2 ) then {_не_ delphi-функция - модификация из faq}
begin
//... делаем все, что необходимо
end;
end;
|
{============================================================
{ DBFSeek
{ поиск величины с использованием индекса - простой путь
{============================================================}
function DBFSeek(const Table1: TTable; const sValue: string): boolean;
var
sExpValue: DBIKEYEXP;
bmPos: TBookMark;
nOrder: integer;
begin
Result := False;
with Table1 do
begin
if (Active) and (Length(IndexName) > 0) then
begin
bmPos := GetBookMark;
DisableControls;
StrPCopy(sExpValue, sValue);
if (DbiGetRecordForKey(Handle, True, 0, strlen(sExpValue), @sExpValue, nil)
= DBIERR_NONE) then
Result := True
else
GotoBookMark(bmPos);
FreeBookMark(bmPos);
EnableControls;
end;
end;
end;
{==================================================================================
{ DBFLocate
{ поиск величины, не связанный с ключевым полем
{ замена из faq, теперь акцептует fieldname, величина может быть частичной
{================================================================================}
function DBFLocate(const Table1: TTable; const sFld, sValue: string): boolean;
var
bmPos: TBookMark;
bFound: boolean;
len: integer;
begin
Result := False;
if (not StrEmpty(sValue)) and (not StrEmpty(sFld)) then
begin
with Table1 do
begin
DisableControls;
bFound := False;
bmPos := GetBookMark;
len := Length(sValue);
First;
while not EOF do
begin
if FieldByName(sFld).AsString <> sValue then
Next
else
begin
Result := True;
bFound := True;
Break;
end;
end;
if (not bFound) then
GotoBookMark(bmPos);
FreeBookMark(bmPos);
EnableControls;
end;
end;
end;
|
Таблицы dBASE. Структура .DBF-файла.
Иногда возникает необходимость поработать с таблицей dBASE напрямую, без Borland Database Engine (BDE). К примеру, если .DBT-файл (содержащий MEMO-данные) для данной таблицы безвозвратно потерян, .DBF-файл становится абсолютно непригодным, поскольку байт в заголовке .DBF-файла указывает, что таблица должна содержать соответствующий MEMO-файл. Решение этой проблемы потребует обнуление этого байта, для того чтобы таблица не указывала на сопутствующий MEMO-файл. Или, если Вам захотелось написать собственную программу для работы с данными. Ниже приводяся структуры .DBF-файлов для таблиц dBASE. Представлены структуры файлов для различных версий dBASE: dBASE III PLUS 1.1, dBASE IV 2.0, dBASE 5.0 под DOS и dBASE 5.0 для Windows.Структура заголовка файла данных для таблицы dBASE III PLUS.
| Заголовок табличного файла | ||
| 0 | 1-й байт | Определение наличия MEMO-файла в таблице dBASE III PLUS (03h без MEMO-файла (.DBT-файл;) 83h с MEMO-файлом). |
| 1-3 | 3 байта | Дата последнего обновления в формате YYMMDD |
| 4-7 | 32-битное число | Количество записей в таблице |
| 8-9 | 16-битное число | Количество байтов, занимаемых заголовком |
| 10-11 | 16-битное число | Количество байтов, занимаемых записью |
| 12-14 | 3 байта | Зарезервированная область |
| 15-27 | 13 байт | Зарезервировано для сетевой версии dBASE III PLUS |
| 28-31 | 4 байта | Зарезервированная область |
| 32-n | 32 байта | Массив с описаниями полей (структура каждого такого описания показана ниже) |
| n+1 | 1 байт | Хранится значение 0Dh, выполняющее роль терминатора описаний полей |
N - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.
| Описание поля таблицы | ||
| 0-10 | 11 байт | Имя поля в ASCII (заполнено нулями). |
| 11 | 1 байт | Тип поля в ASCII (C, D, L, M или N) |
| 12-15 | 4 байта | Адрес данных поля (ссылка на память, а не на диск) |
| 16 | 1 байт | Размер поля в бинарном формате |
| 17 | 1 байт | Порядковый номер поля в бинарном формате |
| 18-19 | 2 байта | Зарезервировано для сетевой версии dBASE III PLUS |
| 20 | 1 байт | ID рабочей области |
| 21-22 | 2 байта | Зарезервировано для сетевой версии dBASE III PLUS |
| 23 | 1 байт | Флаг установки поля |
| 24-31 | 1 байт | Зарезервированная область |
Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah). Вы можете ввести данные в кодовой странице OEM как показано ниже.
| Допустимый тип данных таблиц dBASE | |
| C (Символы) | Все символы кодовой страницы OEM |
| D (Дата) | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD) |
| N (Числовой) | - . 0 1 2 3 4 5 6 7 8 9 |
| L (Логический) | ? Y y N n T t F f (? - не инициализировано) |
| M (Мемо) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока) |
Структура заголовка файла данных для таблицы dBASE IV 2.0.
| Структура файла | ||
| 0 | 1-й байт | Контроль файла dBASE IV: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV, биты 4-6 - наличие SQL-таблицы, бит 7 - наличие любого MEMO-файла (или dBASE III Plus, или dBASE IV) |
| 1-3 | 3 байта | Дата последнего обновления в формате YYMMDD |
| 4-7 | 32-битное число | Количество записей в таблице |
| 8-9 | 16-битное число | Количество байтов, занимаемых заголовком |
| 10-11 | 16-битное число | Количество байтов, занимаемых записью |
| 12-13 | 2 байта | Зарезервированная область, заполнена нулями |
| 14 | 1 байт | Флаг, указывающий на наличие незавершенной транзакции |
| 15 | 1 байт | Флаг кодировки |
| 16-27 | 12 байт | Зарезервированная область для многопользовательского использования dBASE IV |
| 28 | 1 байт | Флаг наличия MDX-файла: 01H - файл присутствует, 00H - файл отсутствует |
| 29 | 1 байт | ID драйвера языка |
| 30-31 | 2 байта | Зарезервированная область, заполнена нулями |
| 32-n* | по 32 байта | Массив с описаниями полей (структура каждого такого описания показана ниже) |
| n+1 | 1 байт | 0DH в качестве терминатора |
N - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.
| Описание поля таблицы | ||
| 0-10 | 11 байт | Имя поля в ASCII (заполнено нулями). |
| 11 | 1 байт | Тип поля в ASCII (C, D, F, L, M или N) |
| 12-15 | 4 байта | Зарезервированная область |
| 16 | 1 байт | Размер поля в бинарном формате |
| 17 | 1 байт | Порядковый номер поля в бинарном формате |
| 18-19 | 2 байта | Зарезервированная область |
| 20 | 1 байт | ID рабочей области |
| 21-30 | 10 байт | Зарезервированная область |
| 31 | 1 байт | Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H - нет. |
Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah).
| Допустимый тип данных таблиц dBASE | ||
| C | Символы | Все символы кодовой страницы OEM |
| D | Дата | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD) |
| F | Бинарные числа с плавающей точкой | - . 0 1 2 3 4 5 6 7 8 9 |
| N | Десятичное преобразование бинарных чисел | - . 0 1 2 3 4 5 6 7 8 9 |
| L | Логический | ? Y y N n T t F f (? - не инициализировано) |
| M | Мемо | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока) |
Структура заголовка файла данных для таблицы dBASE 5.0 под DOS.
| Заголовок табличного файла | ||
| 0 | 1-й байт | Контроль файла dBASE под Windows: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV или dBASE под Windows, биты 4-6 - наличие dBASE IV SQL-таблицы, бит 7 - наличие любого .DBT MEMO-файла (MEMO-файл таблицы dBASE III Plus, dBASE IV или dBASE под Windows) |
| 1-3 | 3 байта | Дата последнего обновления в формате YYMMDD |
| 4-7 | 32-битное число | Количество записей в таблице |
| 8-9 | 16-битное число | Количество байтов, занимаемых заголовком |
| 10-11 | 16-битное число | Количество байтов, занимаемых записью |
| 12-13 | 2 байта | Зарезервированная область, заполнена нулями |
| 14 | 1 байт | Флаг, указывающий на наличие незавершенной транзакции |
| 15 | 1 байт | Флаг кодировки |
| 16-27 | 12 байт | Зарезервированная область для многопользовательского использования |
| 28 | 1 байт | Флаг наличия MDX-файла: 01H - файл присутствует, 00H - файл отсутствует |
| 29 | 1 байт | ID драйвера языка |
| 30-31 | 2 байта | Зарезервированная область, заполнена нулями |
| 32-n* | по 32 байта | Массив с описаниями полей (структура каждого такого описания показана ниже) |
| n+1 | 1 байт | 0DH в качестве терминатора |
N - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.
| Описание поля таблицы | ||
| 0-10 | 11 байт | Имя поля в ASCII (заполнено нулями). |
| 11 | 1 байт | Тип поля в ASCII (B, C, D, F, G, L, M или N) |
| 12-15 | 4 байта | Зарезервированная область |
| 16 | 1 байт | Размер поля в бинарном формате |
| 17 | 1 байт | Порядковый номер поля в бинарном формате |
| 18-19 | 2 байта | Зарезервированная область |
| 20 | 1 байт | ID рабочей области |
| 21-30 | 10 байт | Зарезервированная область |
| 31 | 1 байт | Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H - нет. |
Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah). Вы можете ввести данные в кодовой странице OEM как показано ниже.
| Допустимый тип данных таблиц dBASE | |
| C (Символы) | Все символы кодовой страницы OEM |
| D (Дата) | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD) |
| F (Бинарные числа с плавающей точкой) | - . 0 1 2 3 4 5 6 7 8 9 |
| N (Числовой) | - . 0 1 2 3 4 5 6 7 8 9 |
| L (Логический) | ? Y y N n T t F f (? - не инициализировано) |
| M (Мемо) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока) |
Структура заголовка файла данных для таблицы dBASE 5.0 под Windows.
| Заголовок табличного файла | ||
| 0 | 1-й байт | Контроль файла dBASE под Windows: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV или dBASE под Windows, биты 4-6 - наличие dBASE IV SQL-таблицы, бит 7 - наличие любого .DBT MEMO-файла (MEMO-файл таблицы dBASE III Plus, dBASE IV или dBASE под Windows) |
| 1-3 | 3 байта | Дата последнего обновления в формате YYMMDD |
| 4-7 | 32-битное число | Количество записей в таблице |
| 8-9 | 16-битное число | Количество байтов, занимаемых заголовком |
| 10-11 | 16-битное число | Количество байтов, занимаемых записью |
| 12-13 | 2 байта | Зарезервированная область, заполнена нулями |
| 14 | 1 байт | Флаг, указывающий на наличие незавершенной транзакции dBASE IV |
| 15 | 1 байт | Флаг кодировки таблицы dBASE IV |
| 16-27 | 12 байт | Зарезервированная область для многопользовательского использования |
| 28 | 1 байт | Флаг наличия MDX-файла: 01H - файл для данной таблицы присутствует, 00H - файл отсутствует |
| 29 | 1 байт | ID драйвера языка |
| 30-31 | 2 байта | Зарезервированная область, заполнена нулями |
| 32-n | по 32 байта | Массив с описаниями полей (структура данного массива показана ниже) |
| n+1 | 1 байт | 0DH в качестве терминатора |
N - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.
| Описание поля таблицы | ||
| 0-10 | 11 байт | Имя поля в ASCII (заполнено нулями). |
| 11 | 1 байт | Тип поля в ASCII (B, C, D, F, G, L, M или N) |
| 12-15 | 4 байта | Зарезервированная область |
| 16 | 1 байт | Размер поля в бинарном формате |
| 17 | 1 байт | Порядковый номер поля в бинарном формате |
| 18-19 | 2 байта | Зарезервированная область |
| 20 | 1 байт | ID рабочей области |
| 21-30 | 10 байт | Зарезервированная область |
| 31 | 1 байт | Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H - нет. |
Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah). Вы можете ввести данные в кодовой странице OEM как показано ниже.
| Допустимый тип данных таблиц dBASE | |
| B (Бинарный) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока). |
| C (Символы) | Все символы кодовой страницы OEM |
| D (Дата) | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD) |
| G (Общий) | Все символы кодовой страницы OEM или OLE (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока). |
| N (Числовой) | - . 0 1 2 3 4 5 6 7 8 9 |
| L (Логический) | ? Y y N n T t F f (? - не инициализировано) |
| M (Мемо) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока) |
Предупреждение: У Вас есть право использовать данную техническую информацию с продуктом фирмы Borland только лишь в случае, когда это не противоречит Лицензионному соглашению, поставляемую с программным продуктом.
Индекс в другом каталоге.
Автор: SergПодскажите как работать c dbf под Delphi, когда индексы расположены в другом каталоге?
Vnhead_Cdx := TStringList.Create;
Vnhead_Cdx.Add('c:\parus\bumi1\idx\vnhead.cdx');
Vnhead.IndexFiles := Vnhead_Cdx;
// при это сам dbf находится в c:\parus\bumi1\dbf
|
Как перекинуть все данные из DBF в DB.
Есть такая утилита, к делфям в комплекте идет. DataPump называется. Перекинет тебе все, что надо, индексы создаст, но свою .db заранее не создавай, пусть она создаст. Если надо будет, потом изменишь структуру.
DBGrid и Memo-поля.
| Если ваш холодильник управляется системой windows95/98, то вам следует быть внимательным: 1)Установка и удаление новых продуктов не всегда происходит корректно, для безопасности следует отформатировать морозилку перед инсталяцией ещё не замороженных продуктов! 2)Несанкционированный доступ ваших соседей к вашему холодильнику может быть пресечён установкой пароля. В случае, если вы забыли пароль рекомендуется вызвать слесаря-сантехника для удаленного доступа через заднюю стенку аппарата... 3)Вообще, причин, по которым вы не сможете насладиться вкусом ваших продуктов очень много! (Заметьте, холодильних WinFroze позволяет наслаждаться ВИДОМ продукта в любое время, имея прозрачную дверцу). |
В обработчик события GetText TMemoField поместите следующую строку:
Text := GrabMemoAsString(TMemoField(Sender)); |
И поместите следующую функцию так, чтобы к ней можно было свободно обратиться:
function GrabMemoAsString(TheField: TMemoField): string;
begin
if TheField.IsNull then
Result := ''
else
with TBlobStream.Create(TheField, bmRead) do
begin
if Size >= 255 then
begin
Read(Result[1], 255);
Result[0] := #255;
end
else
begin
Read(Result[1], Size);
Result[0] := Chr(Size);
end;
Free;
while Pos(#10, Result) > 0 do
Result[Pos(#10, Result)] := ' ';
while Pos(#13, Result) > 0 do
Result[Pos(#13, Result)] := ' ';
end;
end;
|
Шапка в TDBGrid.
| Автор: Andre |
| Посылает жена мужа-программера за продуктами на рынок и говорит: - Значит так: купишь хлеба, молока, сметаны, яиц, картошки и лука. А чтобы быстрее было, встанешь в одну очередь, займешь там место и отойдешь, потом в другую и т д... Бедный программер занял место в одной очереди, в другой. Купил яйца, бросился покупать картошку, пока покупал хлеб - забыл свое место в очереди за луком. Полез - по репе дали. Купил молока - рассыпал картошку и уронил хлеб. Поскользнулся на картошке, упал - пакет молока выронил на землю, тот взорвался. Всех молоком облило. Опять бедняга по морде получил. В процессе драки ударили по авоське с яйцами. Те разбились и вытекли прямо программеру на костюм. И вот сидит он на земле весь в синяках, яйцах, молоке и картошке, чешет репу и думает: - Б@#! А фигово пока у меня реализована многозадачность... |
Уже реализовано в виде вот этого компонента.
unit bdbgrid;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, DBGrids, Math;
type
TOnDrawTitleEvent = procedure(ACol: integer; ARect: TRect; var TitleText:
string) of object;
TBitDBGrid = class(TDBGrid)
private
FBitmapBrowse: TBitmap;
FBitmapEdit: TBitmap;
FBitmapInsert: TBitmap;
FBitmapFill: TBitmap;
FRealTitleFont: TFont;
FOnDrawTitle: TOnDrawTitleEvent;
FResizeFlag: boolean;
{ Private declarations }
procedure SetRealTitleFont(Value: TFont);
procedure UpdateTitlesHeight;
protected
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState:
TGridDrawState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{ Public declarations }
published
property OnDrawTitle: TOnDrawTitleEvent read FOnDrawTitle write
FOnDrawTitle;
property RealTitleFont: TFont read FRealTitleFont write SetRealTitleFont;
{ Published declarations }
end;
procedure Register;
implementation
var
DrawBitmap: TBitmap;
function Max(X, Y: Integer): Integer;
begin
Result := Y;
if X > Y then
Result := X;
end;
procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text:
string; Alignment: TAlignment);
// © Borland function :)
const
AlignFlags: array[TAlignment] of Integer =
(DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
var
B, R: TRect;
I, Left: Integer;
begin
with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
begin { brush origin tics in painting / scrolling. }
Width := Max(Width, Right - Left);
Height := Max(Height, Bottom - Top);
R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
B := Rect(0, 0, Right - Left, Bottom - Top);
end;
with DrawBitmap.Canvas do
begin
DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect);
Font := ACanvas.Font;
Font.Color := ACanvas.Font.Color;
Brush := ACanvas.Brush;
SetBkMode(Handle, TRANSPARENT);
DrawText(Handle, PChar(Text), Length(Text), R,
AlignFlags[Alignment]);
end;
ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
end;
constructor TBitDBGrid.Create(AOwner: TComponent);
begin
inherited Create(Aowner);
FRealTitleFont := TFont.Create;
FResizeFlag := false;
end;
destructor TBitDBGrid.Destroy;
begin
FRealTitleFont.Free;
inherited Destroy;
end;
procedure TBitDBGrid.UpdateTitlesHeight;
var
Loop: integer;
MaxTextHeight: integer;
RRect: TRect;
begin
MaxTextHeight := 0;
for loop := 0 to Columns.Count - 1 do
begin
RRect := CellRect(0, 0);
RRect.Right := Columns[Loop].Width;
RRect.Left := 0;
Canvas.Font := RealTitleFont;
MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle,
PChar(Columns[Loop].Title.Caption),
Length(Columns[Loop].Title.Caption), RRect,
DT_CALCRECT + DT_WORDBREAK)
);
end;
if TitleFont.Height <> -MaxTextHeight then
TitleFont.Height := -MaxTextHeight;
end;
procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
Integer);
begin
if MouseCoord(X, Y).Y = 0 then
FResizeFlag := true;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if FResizeFlag then
begin
FResizeFlag := false;
UpdateTitlesHeight;
end;
end;
procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState:
TGridDrawState);
var
Indicator: TBitmap;
TitleText: string;
Al: TAlignment;
begin
if not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options) and (ACol
<> 0))) then
inherited DrawCell(ACol, ARow, ARect, AState)
else
begin
if DefaultDrawing then
begin
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT);
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT);
InflateRect(ARect, -1, -1);
Canvas.Brush.Color := FixedColor;
Canvas.FillRect(ARect);
end;
TitleText := Columns[ACol - 1].Title.Caption;
if Assigned(OnDrawTitle) then
OnDrawTitle(ACol, ARect, TitleText);
if DefaultDrawing and (TitleText <> '') then
begin
Canvas.Brush.Style := bsClear;
Canvas.Font := RealTitleFont;
if ACol > 0 then
Al := Columns[ACol - 1].Title.Alignment
else
Al := Columns[0].Title.DefaultAlignment;
WriteText(Canvas, ARect, 2, 2, TitleText, Al);
end;
end;
end;
procedure TBitDBGrid.SetRealTitleFont(Value: TFont);
begin
FRealTitleFont.Assign(Value);
Repaint;
end;
procedure Register;
begin
RegisterComponents('Andre VCL', [TBitDBGrid]);
end;
initialization
DrawBitmap := TBitmap.Create;
finalization
DrawBitmap.Free;
end.
|
Фокус для конкретной ячейки TDBGrid.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
begin
with TStringGrid(DBGrid1) do
begin
Row := 2; // Row - Zeile
Col := 5; // Column - Spalte
SetFocus;
end;
end;
Позиция ячейки в TDBGrid.
| В 8 классе я впервые сконектился с девушкой на 9600бод. В 11 классе я сконектился с девушкой стандарта V90-60-90 на 56700, но стоило мне это 200 долларов за ночной анлимитед. На 2 курсе института я решил завести себе выделенную девушку. На 3 курсе я узнал от друзей, что пропускная способность моей девушки 2Мб/с, и к ней подключен не только я. На 5 курсе я хакнул многих девушек нашего курса. На 6-ом меня поймали два грузина, после этого я стал сисопом. После того как я стал сисопом, я попал на зону, где меня сделали администратором и меня хакали все кому не лень. После этого я не смог конектиться с девушкой даже на 2400. В 30 лет я пристрастился к ИЕЧ, через него поймал win95CIH и нашел успокоение 26 апреля 1999г. |
В TCustomGrid определен метод CellRect, который, к сожалению, защищен. Это означает, что даный метод доступен только для TCustomGrid и его наследников. Но все-таки существует немного мудреное решение вызова данного метода:
type
TMyDBGrid = class(TDBGrid)
public
function CellRect(ACol, ARow: Longint): TRect;
end;
function TMyDBGrid.CellRect(ACol, ARow: Longint): TRect;
begin
Result := inherited CellRect(ACol, ARow);
end;
|
Вы можете сделать приведение типа вашего DBGrid к TMyDBGrid (это возможно, поскольку CellRect статический метод) и вызвать CellRect:
Rectangle := TMyDBGrid(SomeDBGrid).CellRect(SomeColumn, SomeRow);
procedure TfmLoadIn.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
const
Disp = 2; //Правильно выравниваем компонент
begin
inherited;
if (gdFocused in State) then
begin
if (Column.FieldName = 'TYPEDescription') then
begin
dlTYPEDescription.Left := Rect.Left + DBGrid1.Left + Disp;
dlTYPEDescription.Top := Rect.Top + DBGrid1.top + Disp;
dlTYPEDescription.Width := Rect.Right - Rect.Left;
dlTYPEDescription.Height := Rect.Bottom - Rect.Top;
dlTYPEDescription.Visible := True;
end;
end;
end;
|
Как сделать, чтобы необходимая ячейка DBGrid получила фокус ввода.
| Автор: MsGuns |
| Геймер с женой на машине чудом избежали автомобильной аварии. Отделались незначительными повреждениями и легким испугом. Геймер, с облегчением вздыхая: - С 90 % жизни переходим на следующий уровень... |
Для установки в ПОЛЕ, связанное с гридом, используется метод TField.FocusControl.
DBGrid с цветными ячейками.
| Один кибернетик создал машину для предсказания будущего. Задал ей простой вопрос: - Что я буду делать через час? Машина работала трое суток и выдала: - Будешь сидеть у монитора и ждать моего ответа. |
Единственный код расположился в обработчике события OnDrawColumnCell компонента DBGrid и выглядел он так:
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect:
TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
holdColor: TColor;
begin
holdColor := DBGrid1.Canvas.Brush.Color; {сохраняем оригинальный цвет}
{"раскрашиваем" ячейки только для поля EmpNo}
if Column.FieldName = 'EmpNo' then
if (Column.Field.AsInteger mod 2 <> 0) then
begin
DBGrid1.Canvas.Brush.Color := clGreen;
DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);
DBGrid1.Canvas.Brush.Color := holdColor;
end;
end;
|
В данном случае мы использовали метод DefaultDrawColumnCell компонента TCustomDBGrid, являющегося родителем для TDBGrid. Он раскрасил зеленым цветом нечетные ячейки поля EmpNo.
DBGrid с цветными ячейками 2.
| - А чё UNIX, чё UNIX? - возмущался Вывоуз, - Малыш Билли ещё на Васике лопал, когда она уже была. Старушенция дряхлая! - Ты бабушку не трогай! - серьёзно обиделся товарищ Команд ком, - Она тебе, глюкало переросток, ещё фору даст!!! - но, подумав, товарищ Ком помрачнел и добавил: - Вот только какого демона она на мою территрию лезет! И сплюнул: - Оболочка дешевая. |
Обработайте событие OnDrawDataCell. Вот пример, который использует демонстрационную таблицу COUNTRY и рисует текст красным цветом во всех строках, содержащих страны с населением свыше 10 миллионов человек:
begin
if Table1.FieldByName('Population').AsFloat < 10000000 then
DBGrid1.Canvas.Font.Color := clRed;
dbGrid1.DefaultDrawDataCell(Rect,Field,State);
end;
|
DBGrid с цветными ячейками 3.
| Автор: Neil Rubenking |
| На борту самолета: - Здравствуйте, дамы и господа, - говорит командир экипажа. - Мы благодарим вас за то, что вы выбрали нашу авиакомпанию для первого полета в первый день нового 2000 года. Мы находимся на высоте 3 тыс. футов, наша скорость... вау!... ох, блин!... вот фак!... Извините за неудобства, которые вы испытываете, находясь вниз головой, надеюсь, все были пристегнуты. Есть ли среди пассажиров на борту программист? |
C цветом ячейки DBGrid не так все просто, ведь в Delphi 1.0 разукрасить ячейку можно в обработчике события OnDrawDataCell, тогда как в Delphi 2.0 вам придется прибегнуть к событию OnDrawColumnCell. Для того чтобы создать код, который бы работал в ОБОИХ версих Delphi, вам необходимо прибегнуть к механизму условной компиляции, с помощью которого вы можете СКРЫТЬ обработчик OnDrawColumnCell в Delphi 1.0 и ВКЛЮЧИТЬ его в Delphi 2.0. Вот пример, в котором все ячейки строки рисуются красным, если колонка 'Preferred' содержит 'True':
...
private
{ Private declarations }
{$IFDEF Win32}
procedure DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
{$ENDIF}
procedure DrawField(const Value: string; const Rect: TRect;
vCanvas: TCanvas; vFont: TFont; vAlignment: TAlignment);
...
procedure TForm1.DrawField(const Value: string; const Rect: TRect;
vCanvas: TCanvas; vFont: TFont; vAlignment: TAlignment);
var
X: Integer;
begin
vCanvas.Font := vFont;
vCanvas.Font.Color := clRed;
vCanvas.Font.Style := vCanvas.Font.Style + [fsUnderline];
case vAlignment of
taRightJustify:
begin
SetTextAlign(vCanvas.Handle, TA_RIGHT);
X := Rect.Right - 2;
end;
taLeftJustify:
begin
SetTextAlign(vCanvas.Handle, TA_LEFT);
X := Rect.Left + 2;
end;
taCenter:
begin
SetTextAlign(vCanvas.Handle, TA_CENTER);
X := (Rect.Right + Rect.Left) div 2;
end;
end;
vCanvas.TextRect(Rect, X, Rect.Top + 2, Value);
SetTextAlign(vCanvas.Handle, TA_LEFT);
end;
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect:
TRect; Field: TField; State: TGridDrawState);
begin
with Sender as TDBGrid, DataSource.DataSet do
begin
if FieldByName('Preferred').AsString <> 'True' then
Exit;
DrawField(Field.DisplayText, Rect, Canvas, Canvas.Font,
Field.Alignment);
end;
end;
{$IFDEF Win32}
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
with Sender as TDBGrid, DataSource.DataSet do
begin
if FieldByName('Preferred').AsString <> 'True' then
Exit;
DrawField(Column.Field.DisplayText, Rect, Canvas,
Column.Font, Column.Alignment);
end;
end;
{$ENDIF}
procedure TForm1.FormCreate(Sender: TObject);
begin
{$IFDEF Win32}
DBGrid1.OnDrawDataCell := nil;
DBGrid1.OnDrawColumnCell := DBGrid1DrawColumnCell;
{$ENDIF}
end;
|
Как заставить DBGrid сортировать данные по щелчку на заголовке столбца.
| Автор: Nomadic |
| Песня о зависшем Windows: Кликну, а в ответ - тишина. |
Кусочек кода, чтобы повесить на clickable столбец RxGrid, показывающий RxQuery с определенным макросом %Order. Работать не будет (без модулей), но в качестве идеи может быть полезен.
unit vgRXutil;
interface
uses
SysUtils, Classes, DB, DBTables, rxLookup, RxQuery;
{ TrxDBLookup }
procedure RefreshRXLookup(Lookup: TrxLookupControl);
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
{ TRxQuery }
{ Applicatable to SQL's without SELECT * syntax }
{ Inserts FieldName into first position in '%Order' macro and refreshes query }
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
{ Sets '%Order' macro, if defined, and refreshes query }
procedure InsertOrderBy(Query: TRxQuery; NewOrder: string);
{ Converts list of order fields if defined and refreshes query }
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
implementation
uses
vgUtils, vgDBUtl, vgBDEUtl;
{ TrxDBLookup refresh }
type
TRXLookupControlHack = class(TrxLookupControl)
property DataSource;
property LookupSource;
property Value;
property EmptyValue;
end;
procedure RefreshRXLookup(Lookup: TrxLookupControl);
var
SaveField: string;
begin
with TRXLookupControlHack(Lookup) do
begin
SaveField := DataField;
DataField := '';
DataField := SaveField;
end;
end;
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
var
SaveField: string;
begin
with TRXLookupControlHack(Lookup) do
begin
SaveField := LookupDisplay;
LookupDisplay := '';
LookupDisplay := SaveField;
end;
end;
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
begin
with TRXLookupControlHack(Lookup) do
try
if Value <> EmptyValue then
Result := StrToInt(Value)
else
Result := 0;
except
Result := 0;
end;
end;
procedure InsertOrderBy(Query: TRxQuery; NewOrder: string);
var
Param: TParam;
OldActive: Boolean;
OldOrder: string;
Bmk: TPKBookMark;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) then
Exit;
OldOrder := Param.AsString;
if OldOrder <> NewOrder then
begin
OldActive := Query.Active;
if OldActive then
Bmk := GetPKBookmark(Query, '');
try
Query.Close;
Param.AsString := NewOrder;
try
Query.Prepare;
except
Param.AsString := OldOrder;
end;
Query.Active := OldActive;
if OldActive then
SetToPKBookMark(Query, Bmk);
finally
if OldActive then
FreePKBookmark(Bmk);
end;
end;
end;
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
var
NewOrderFields: TStrings;
procedure AddOrderField(S: string);
begin
if NewOrderFields.IndexOf(S) < 0 then
NewOrderFields.Add(S);
end;
var
I, J: Integer;
Field: TField;
FieldDef: TFieldDef;
S: string;
begin
NewOrderFields := TStringList.Create;
with Query do
try
for I := 0 to OrderFields.Count - 1 do
begin
S := OrderFields[I];
Field := FindField(S);
if Assigned(Field) and (Field.FieldNo > 0) then
AddOrderField(IntToStr(Field.FieldNo))
else
try
J := StrToInt(S);
if J < FieldDefs.Count then
AddOrderField(IntToStr(J));
except
end;
end;
OrderFields.Assign(NewOrderFields);
finally
NewOrderFields.Free;
end;
end;
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
var
Param: TParam;
Tmp, OldOrder, NewOrder: string;
I: Integer;
C: Char;
TmpField: TField;
OrderFields: TStrings;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) or Field.Calculated or Field.Lookup then
Exit;
OldOrder := Param.AsString;
I := 0;
Tmp := '';
OrderFields := TStringList.Create;
try
OrderFields.Ad(Field.FieldName);
while I < Length(OldOrder) do
begin
Inc(I);
C := OldOrder[I];
if C in FieldNameChars then
Tmp := Tmp + C;
if (not (C in FieldNameChars) or (I = Length(OldOrder))) and (Tmp <> '')
then
begin
TmpField := Field.DataSet.FindField(Tmp);
if OrderFields.IndexOf(Tmp) < 0 then
OrderFields.Add(Tmp);
Tmp := '';
end;
end;
UpdateOrderFields(Query, OrderFields);
NewOrder := OrderFields[0];
for I := 1 to OrderFields.Count - 1 do
NewOrder := NewOrder + ', ' + OrderFields[1];
finally
OrderFields.Free;
end;
InsertOrderBy(Query, NewOrder);
end;
end.
|
Текущая строка и поле в DBGrid.
| - Друг, дай взаймы сколько сможешь. - А нафига тебе? - Окно на работе разбил. - И что? - Заставили возместить стоимость... - Сколько? - Штука баксов. - ?!! И что же это за окно такое? - Да Девяносто Восьмое, на экране было. Я, блин, не выдержал и вместе с монитором и компом впридачу разбил... |
unit dbcolform;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
Label1: TLabel;
procedure DBGrid1ColEnter(Sender: TObject);
procedure DataSource1DataChange(Sender: TObject; Field: TField);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TFake = class (TDBGrid);
procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
Label1.Caption := Format (
'Column: %2d; Row: %2d',
[TFake (DbGrid1).Col,
TFake (DbGrid1).Row]);
end;
procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField);
begin
DBGrid1ColEnter (sender);
end;
end.
|
Загрузить весь проект
DbGrid со свойствами Col и Row.
| Идет Иванушка-дурачек по полю и видит коровью морду. RC5-64 подумал Иванушка. Идет дальше и дедка-пастуха видит - Daniel Baker - подумал Иванушка. Увидел частокол с кольями на равном растоянии друг от друга... не успел ничего подумать, как пастух пробурчал: - Ага OGR has started!! |
{
Код улучшенного TDBGrid, имеющего свойства Col,
Row и Canvas и метод CellRect. Это чрезвычайно
полезно в случае, если вы, к примеру, хотите
получить выпадающий список на месте редактируемой
пользователем ячейки.
}
unit VUBComps;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, DBGrids, DB, Menus;
type
TDBGridVUB = class(TDBGrid)
private
{ Private declarations }
protected
{ Protected declarations }
public
property Canvas;
function CellRect(ACol, ARow: Longint): TRect;
property Col;
property Row;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('VUBudget', [TDBGridVUB]);
end;
function TDBGridVUB.CellRect(ACol, ARow: Longint): TRect;
begin
Result := inherited CellRect(ACol, ARow);
end;
end.
|
Как выделить цветом текущую строку в TDBGrid.
| Люди в мире делятся на две группы: те, кто не знают Билла Гейтса и те, кто его ненавидят! |
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect:
TRect;
Field: TField; State: TGridDrawState);
begin
if gdFocused in State then
with (Sender as TDBGrid).Canvas do
begin
Brush.Color := clRed;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, Field.AsString);
end;
end;
|
DBGrid CutToClipboard.
| Автор: Kurt Barthelmess |
| После смерти Моисей, Эйнштейн и Билл Гейтс каждый в свое время попали в рай. Бог каждого спрашивает: - Что бы Вы хотели меня спросить? Моисей: - Я бы хотел узнать, как правильно исполнять Твою волю. Эйнштейн: - Я бы хотел узнать законы, по которым Ты построил мир. Билл Гейтс: - Какого фига ты расселся на моем месте? |
Да, но вы можете сделать это обманным путем. Попробуйте так:
procedure TForm1.Paste1Click(Sender: TObject); begin SendMessage(GetFocus, WM_PASTE, 0, 0); end; procedure TForm1.Copy1Click(Sender: TObject); begin SendMessage(GetFocus, WM_COPY, 0, 0); end; |
Эти методы привязаны к вашим пунктам меню. Они посылают сообщение окну с текущим фокусом. Если это элемент управления TInPlaceEdit, то мы добились того, чего хотели.
DBGrid DefaultDrawDataCell.
| Корреспондент: - Билл Гейтс, Почему Вы решили оставить ТАКОЙ пост и начать новую трудовую деятельность? - А надоело руководить, пора начать такой вид деятельности, который бы смог и меня прокормить и мою семью! |
Вот пример его использования:
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject;
const Rect: TRect; Field: TField; State: TGridDrawState);
begin
with Sender as TDBGrid do
begin
Canvas.Font.Color := clRed;
DefaultDrawDataCell(Rect, Field, State);
end;
end;
|
Как программно перевести DBGrid в режим редактирования.
| Решили Винду под банкомат поставить. Поставили - работает. Вставили кредитку. Появилось сообщение: Введите Ваш пин-код. Ввели. Дальше сообщение: Сохранить пароль при следующих входах? - Да/Нет (Не предлагать больше сохранять никакие пароли) |
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
h : THandle;
begin
Application.ProcessMessages;
DbGrid1.SetFocus;
DbGrid1.EditorMode := true;
Application.ProcessMessages;
h:= Windows.GetFocus;
SendMessage(h, EM_SETSEL, 2, 2);
end;
|
Экспортировать TDBGrid в Excel без использования OLE.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Exporting a DBGrid to excel without OLE
I develop software and about 95% of my work deals with databases.
I enjoied the advantages of using Microsoft Excel in my projects
in order to make reports but recently I decided to convert myself
to the free OpenOffice suite.
I faced with the problem of exporting data to Excel without having
Office installed on my computer.
The first solution was to create directly an Excel format compatible file:
this solution is about 50 times faster than the OLE solution but there
is a problem: the output file is not compatible with OpenOffice.
I wanted a solution which was compatible with each "DataSet";
at the same time I wanted to export only the dataset data present in
a DBGrid and not all the "DataSet".
Finally I obtained this solution which satisfied my requirements.
I hope that it will be usefull for you too.
First of all you must import the ADOX type library
which will be used to create the Excel file and its
internal structure: in the Delphi IDE:
1)Project->Import Type Library:
2)Select "Microsoft ADO Ext. for DDL and Security"
3)Uncheck "Generate component wrapper" at the bottom
4)Rename the class names (TTable, TColumn, TIndex, TKey, TGroup, TUser, TCatalog) in
(TXTable, TXColumn, TXIndex, TXKey, TXGroup, TXUser, TXCatalog)
in order to avoid conflicts with the already present TTable component.
5)Select the Unit dir name and press "Create Unit".
It will be created a file named AOX_TLB.
Include ADOX_TLB in the "uses" directive inside the file in which you want
to use ADOX functionality.
That is all. Let's go now with the implementation:
}
unit DBGridExportToExcel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;
type TScrollEvents = class
BeforeScroll_Event: TDataSetNotifyEvent;
AfterScroll_Event: TDataSetNotifyEvent;
AutoCalcFields_Property: Boolean;
end;
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
implementation
//Support procedures: I made that in order to increase speed in
//the process of scanning large amounts
//of records in a dataset
//we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
//"AfterScroll" events and the "AutoCalcFields" property.
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
begin
with DataSet do
begin
DisableControls;
ScrollEvents := TScrollEvents.Create();
with ScrollEvents do
begin
BeforeScroll_Event := BeforeScroll;
AfterScroll_Event := AfterScroll;
AutoCalcFields_Property := AutoCalcFields;
BeforeScroll := nil;
AfterScroll := nil;
AutoCalcFields := False;
end;
end;
end;
//we make a call to the "EnableControls" procedure and then restore
// the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
begin
with DataSet do
begin
EnableControls;
with ScrollEvents do
begin
BeforeScroll := BeforeScroll_Event;
AfterScroll := AfterScroll_Event;
AutoCalcFields := AutoCalcFields_Property;
end;
end;
end;
//This is the procedure which make the work:
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
var
cat: _Catalog;
tbl: _Table;
col: _Column;
i: integer;
ADOConnection: TADOConnection;
ADOQuery: TADOQuery;
ScrollEvents: TScrollEvents;
SavePlace: TBookmark;
begin
//
//WorkBook creation (database)
cat := CoCatalog.Create;
cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
//WorkSheet creation (table)
tbl := CoTable.Create;
tbl.Set_Name(SheetName);
//Columns creation (fields)
DBGrid.DataSource.DataSet.First;
with DBGrid.Columns do
begin
for i := 0 to Count - 1 do
if Items[i].Visible then
begin
col := nil;
col := CoColumn.Create;
with col do
begin
Set_Name(Items[i].Title.Caption);
Set_Type_(adVarWChar);
end;
//add column to table
tbl.Columns.Append(col, adVarWChar, 20);
end;
end;
//add table to database
cat.Tables.Append(tbl);
col := nil;
tbl := nil;
cat := nil;
//exporting
ADOConnection := TADOConnection.Create(nil);
ADOConnection.LoginPrompt := False;
ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';
ADOQuery := TADOQuery.Create(nil);
ADOQuery.Connection := ADOConnection;
ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
ADOQuery.Open;
DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
SavePlace := DBGrid.DataSource.DataSet.GetBookmark;
try
with DBGrid.DataSource.DataSet do
begin
First;
while not Eof do
begin
ADOQuery.Append;
with DBGrid.Columns do
begin
ADOQuery.Edit;
for i := 0 to Count - 1 do
if Items[i].Visible then
begin
ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString;
end;
ADOQuery.Post;
end;
Next;
end;
end;
finally
DBGrid.DataSource.DataSet.GotoBookmark(SavePlace);
DBGrid.DataSource.DataSet.FreeBookmark(SavePlace);
EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
ADOQuery.Close;
ADOConnection.Close;
ADOQuery.Free;
ADOConnection.Free;
end;
end;
end.
Как экспортировать содержимое DBGrid в Excel или ClipBoard.
| КОГДА при виде трупа ваша первая мысля - обыскать. Когда вас ВСЕГДА окружают пять верных рузей. Когда вы ВЕЗДЕ таскаете за собой пыльный мешок с надписью "инвентарь". И наконец когда вы ВСЮДУ ищите неприятности - значит вам ДАВНО пора бросать играть в БАЛДУРС ГЕЙТ! |
// ЗАМЕЧАНИЕ: этот метод должен включать COMObj, Excel97 units
// ОБНОВЛЕНИЕ: если Вы используете Delphi 4, то замените xlWBatWorkSheet на 1 (один)
//-----------------------------------------------------------
// если toExcel = false, то экспортируем содержимое dbgrid в Clipboard
// если toExcel = true, то экспортируем содержимое dbgrid в Microsoft Excel
//-----------------------------------------------------------
procedure ExportDBGrid(toExcel: Boolean);
var
bm: TBookmark;
col, row: Integer;
sline: string;
mem: TMemo;
ExcelApp: Variant;
begin
Screen.Cursor := crHourglass;
DBGrid1.DataSource.DataSet.DisableControls;
bm := DBGrid1.DataSource.DataSet.GetBookmark;
DBGrid1.DataSource.DataSet.First;
// создаём объект Excel
if toExcel then
begin
ExcelApp := CreateOleObject('Excel.Application');
ExcelApp.WorkBooks.Add(xlWBatWorkSheet);
ExcelApp.WorkBooks[1].WorkSheets[1].name := 'Grid Data';
end;
// Сперва отправляем данные в memo
// работает быстрее, чем отправлять их напрямую в Excel
mem := TMemo.Create(Self);
mem.Visible := false;
mem.Parent := MainForm;
mem.Clear;
sline := '';
// добавляем информацию для имён колонок
for col := 0 to DBGrid1.FieldCount-1 do
sline := sline + DBGrid1.Fields[col].DisplayLabel + #9;
mem.Lines.Add(sline);
// получаем данные из memo
for row := 0 to DBGrid1.DataSource.DataSet.RecordCount-1 do
begin
sline := '';
for col := 0 to DBGrid1.FieldCount-1 do
sline := sline + DBGrid1.Fields[col].AsString + #9;
mem.Lines.Add(sline);
DBGrid1.DataSource.DataSet.Next;
end;
// копируем данные в clipboard
mem.SelectAll;
mem.CopyToClipboard;
// если необходимо, то отправляем их в Excel
// если нет, то они уже в буфере обмена
if toExcel then
begin
ExcelApp.Workbooks[1].WorkSheets['Grid Data'].Paste;
ExcelApp.Visible := true;
end;
FreeAndNil(ExcelApp);
DBGrid1.DataSource.DataSet.GotoBookmark(bm);
DBGrid1.DataSource.DataSet.FreeBookmark(bm);
DBGrid1.DataSource.DataSet.EnableControls;
Screen.Cursor := crDefault;
end;
|
DbGrid и множественный выбор.
| Разговор ламера (Л) с программером (П): П: - Ну как, в этом чате дырок много? Л: - Да, я уже с двумя познакомился! |
Свойство SelectedRows является объектом, имеющим тип TBookmarkList. Его свойства и методы описаны ниже.
// property SelectedRows: TBookmarkList read FBookmarks;
// TBookmarkList = class
// public
{* Метод Clear освобождает все выбранные в DBGrid записи *}
// procedure Clear;
{* Метод Delete удаляет все выбранные строки из набора данных *}
// procedure Delete;
{* Метод Find определяет наличие закладки в выбранном списке. *}
// function Find(const Item: TBookmarkStr;
// var Index: Integer): Boolean;
{* Метод IndexOf возвращает индекс закладки, расположенной в свойстве Items. *}
// function IndexOf(const Item: TBookmarkStr): Integer;
{* Метод Refresh возвращает логическую величину, уведомляющую о том, ч
то в то время, пока в табличной сетке была выбрана запись, были добавлены
(удалены) какие-то данные. Метод Refresh может быть использован для
обновления списка выбранных записей для уменьшения возможности получения
удаленной записи. *}
// function Refresh: Boolean; True = orphans found
{* Свойство Count возвращает количество выбранных в настоящий
момент элементов в DBGrid *}
// property Count: Integer read GetCount;
{* Свойство CurrentRowSelected содержит логическую величину,
зависящую от того, выбрана текущая строка или нет. *}
// property CurrentRowSelected: Boolean
// read GetCurrentRowSelected
// write SetCurrentRowSelected;
{* Свойство Items - TStringList TBookmarkStr *}
// property Items[Index: Integer]: TBookmarkStr
// read GetItem; default;
// end;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
Table1: TTable;
DBGrid1: TDBGrid;
Count: TButton;
Selected: TButton;
Clear: TButton;
Delete: TButton;
Select: TButton;
GetBookMark: TButton;
Find: TButton;
FreeBookmark: TButton;
DataSource1: TDataSource;
procedure CountClick(Sender: TObject);
procedure SelectedClick(Sender: TObject);
procedure ClearClick(Sender: TObject);
procedure DeleteClick(Sender: TObject);
procedure SelectClick(Sender: TObject);
procedure GetBookMarkClick(Sender: TObject);
procedure FindClick(Sender: TObject);
procedure FreeBookmarkClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Bookmark1: TBookmark;
z: Integer;
implementation
{$R *.DFM}
//Пример использования свойства Count
procedure TForm1.CountClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.Count > 0 then
begin
showmessage(inttostr(DBgrid1.SelectedRows.Count));
end;
end;
//Пример использования свойства CurrentRowSelected
procedure TForm1.SelectedClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.CurrentRowSelected then
showmessage('Выбрана');
end;
//Пример использования метода Clear
procedure TForm1.ClearClick(Sender: TObject);
begin
dbgrid1.SelectedRows.Clear;
end;
//Пример использования метода Delete
procedure TForm1.DeleteClick(Sender: TObject);
begin
DBgrid1.SelectedRows.Delete;
end;
{*
Данные пример проходит в цикле все выбранные
записи табличной сетки и отображает второе
поле набора данных.
Метод DisableControls используется в случае,
когда необходимо запретить обновление DBGrid
при изменении набора данных. Последняя позиция
набора данных сохраняется как TBookmark.
Метод IndexOf вызывается при необходимости
проверить существование закладки.
Решение использовать метод IndexOf, а не
Refresh, должно приниматься исходя из
специфики приложения.
*}
procedure TForm1.SelectClick(Sender: TObject);
var
x: word;
TempBookmark: TBookMark;
begin
DBGrid1.Datasource.Dataset.DisableControls;
with DBgrid1.SelectedRows do
if Count > 0 then
begin
TempBookmark := DBGrid1.Datasource.Dataset.GetBookmark;
for x := 0 to Count - 1 do
begin
if IndexOf(Items[x]) > -1 then
begin
DBGrid1.Datasource.Dataset.Bookmark := Items[x];
showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
end;
end;
end;
DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.EnableControls;
end;
{*
Данный пример позволит вам установить закладку и
затем найти ее в списке выбранных записей
компонента DBGrid.
*}
//Устанавливаем закдадку
procedure TForm1.GetBookMarkClick(Sender: TObject);
begin
Bookmark1 := DBGrid1.Datasource.Dataset.GetBookmark;
end;
//Освобождаем закладку
procedure TForm1.FreeBookmarkClick(Sender: TObject);
begin
if assigned(Bookmark1) then
begin
DBGrid1.Datasource.Dataset.FreeBookmark(Bookmark1);
Bookmark1 := nil;
end;
end;
//Испольуем метод Find для установления позиции
//записи-закладки в списке выбранных записей компонента DBGrid
procedure TForm1.FindClick(Sender: TObject);
begin
if assigned(Bookmark1) then
begin
if DBGrid1.SelectedRows.Find(TBookMarkStr(Bookmark1), z) then
showmessage(inttostr(z));
end;
end;
end.
|
Как в TDBGrid узнать над каким полем висит мышь.
| Автор: Бурундук |
| Лежат как то системщик с подругою в постели, вот только что у них всё закончилось ... Она его ласково так спрашивает: - Милый, Save of changes, Yes or Not? |
var ScrPt, GrdPt: TPoint; Cell: TGridCoord; begin ScrPt := Mouse.CursorPos; GrdPt := DBGrid.ScreenToClient(ScrPt); Cell := DBGrid.MouseCoord(GrdPt.X, GrdPt.Y); // Col := Cell.X; // Row := Cell.Y; end; |
...
FieldText: string;
DLink: TDataLink;
OldActiveRec: Integer;
...
Cell := DBGrid.MouseCoord(GrdPt.X, GrdPt.Y);
FieldText := '';
DLink := THackDBGrid(DBGrid).DataLink;
if Assigned(DLink) then
begin
if (Cell.X < = 0)or(Cell.Y < = 0) then Exit;
OldActiveRec := DLink.ActiveRecord;
try
DLink.ActiveRecord := Cell.Y-1{TitleOffset};
FieldText := DBGrid.Columns[Cell.X-1{IndicatorOffset}].Field.Text;
finally
DLink.ActiveRecord := OldActiveRec;
end;
end;
|
Перемещение колонок в TDBGrid.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
THackAccess = class(TCustomGrid);
{
THackAccess Is needed because TCustomGrid.MoveColumn is
protected and you can't access it directly.
THackAccess Braucht man, da TCustomGrid.MoveColumn in der
Protected-Sektion steht und nicht direkt darauf zugegriffen werden kann.
}
// In the implementation-Section:
procedure MoveDBGridColumns(DBGrid: TDBGrid; FromColumn, ToColumn: Integer);
begin
THackAccess(DBGrid).MoveColumn(FromColumn, ToColumn);
end;
{Example/ Beispiel}
procedure TForm1.Button1Click(Sender: TObject);
begin
MoveDBGridColumns(DBGrid1, 1, 2)
end;
Использование опции MultiSelect в DBGRID.
| Если вы с первого раза сумели написать программу, в которой компилятор не нашел ни одной ошибки, сообщите об этом системному программисту, он исправит ошибки в компиляторе. |
Есть пример в Delphi Technical Information... Его можно посмотреть здесь.
{*
Данный пример позволяет производить множественный выбор записей
в табличной сетке и отображать второе поле
набора данных.
Метод DisableControls применяется для того, чтобы
DBGrid не обновлялся во время изменения набора данных.
Последняя позиция набора данных сохраняется как
TBookmark.
Метод IndexOf вызывается для проверки
существования закладки.
Решение использовать метод IndexOf, а не метод
Refresh должно определяться
спецификой приложения.
*}
procedure TForm1.SelectClick(Sender: TObject);
var
x: word;
TempBookmark: TBookMark;
begin
DBGrid1.Datasource.Dataset.DisableControls;
with DBgrid1.SelectedRows do
if Count <> 0 then
begin
TempBookmark := DBGrid1.Datasource.Dataset.GetBookmark;
for x := 0 to Count - 1 do
begin
if IndexOf(Items[x]) > -1 then
begin
DBGrid1.Datasource.Dataset.Bookmark := Items[x];
showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
end;
end;
end;
DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.EnableControls;
end;
|
Как отучить TDBGrid от автодобавления новой записи.
| Внимание! Осторожно - вирус! Если вы получите по почте мессадж, где в качестве subject стоит "повестка", а отправителем числится "военкомат", ни в коем случае не открывайте его. Немедленно делетируйте его вместе с конвертом. Внутри него может оказаться опаснейший вирус, полностью лишающий вас возможности работать на вашем компьютере. Форвардируйте это сообщение всем, с кем вы ведете переписку. |
Добавьте в обработчик события вашего TTable "BeforeInsert" следующую строку:
procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset); begin Abort; // <<---эту строчку end; |
Осуществляем перехват нажатия клавиши и проверку на конец файла (end-of-file):
procedure TForm8.DBGrid1KeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (Key = VK_DOWN) then
begin
TTable1.DisableControls;
TTable1Next;
if TTable1.EOF then
Key := 0
else
TTable1.Prior;
TTable1.EnableControls;
end;
end;
|
Как в TDBGrid разрешить только операции UPDATE записей.
| Автор: Nomadic |
| Когда я выключаю комп я постоянно думаю над вопросом computer шут или даун?... |
А я делаю так. На DataSource, к которому прицеплен Grid, вешаю обработчик на событие OnStateChange. Ниже текст типичного обратчика.
if DBGrid1.DataSource.DataSet.State in [dsEdit, dsInsert] then DBGrid1.Options := DBGrid1.Options + goRowSelect else DBGrid1.Options := DBGrid1.Options - goRowSelect; |
Лучше использовать конструкцию "State in dsEditModes".
Замечательные возможности DBGrid.
| Стоят старая и молодая проститутки на боевом посту. Старая все объясняет: к кому подходить, к кому не надо... На рассвете вдруг из дверей офиса нетвердой походкой выходит мужик, волосы взъерошены, глаза красные... Молодая: - Ой, что это с ним? Старая: - Не обращай внимания. Это свой, программист. Тоже всю ночь тр@хался. |
Нередко при разработке приложений, использующих табличный вывод данных, требуется отобразить те или иные строки таблиц нестандартным образом, например, с целью привлечения внимания пользователя к этим строкам. В данной статье содержатся некоторые советы, касающиеся нестандартного отображения данных в компоненте TDBGrid.
Как изменить цвет строки в TDBGrid
Предположим, нам требуется изменить атрибуты текста и фона строки в компоненте TDBGrid, если значение какого-либо поля удовлетворяет заранее заданному условию. Для этой цели принято использовать обработчик события OnDrawColumnCell этого компонента. Отметим, что возможности, предоставляемые при его использовании, весьма разнообразны.
Рассмотрим простейшее приложение с TDBGrid, содержащее один компонент TTable, один компонент TDataSource и один компонент TDBGrid: Установим значения их свойств в соответствии с приведенной ниже таблицей:
| Компонент | Свойство | Значение |
| Table1 | DatabaseName | BCDEMOS (или DBDEMOS) |
| TableName | events.db | |
| Active | true | |
| DataSource1 | DataSet | Table1 |
| DBGrid1 | DataSource | DataSource1 |
Обычно для перерисовки изображения в ячейках используется метод OnDrawColumnCell.
Его параметр Rect – структура, описывающая занимаемый ячейкой прямоугольник; параметр Column - колонка DBGrid, в которой следует изменить способ рисования изображения. Для вывода текста используется метод TextOut свойства Canvas компонента TDBGrid.
Предположим, нам нужно изменить цвет текста и фона строки в зависимости от значения какого-либо поля (например, VenueNo). Создадим обработчик события OnDrawColumnCell компонента DBGrid1.
В случае Delphi соответствующий код имеет вид:
procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if Table1.FieldByName('VenueNo').Value = 1 then
with DBGrid1.Canvas do
begin
Brush.Color := clGreen;
Font.Color := clWhite;
FillRect(Rect);
TectOut(Rect.Left + 2, Rect.Top + 2, Column.Field.Text);
end;
end;
|
В результате на этапе выполнения при отображении строк, в которых значение поля VenueNo равно 1, фон ячеек будет окрашен в зеленый цвет, а текст выведен белым цветом.
При выводе выделенных строк все данные в ячейках оказались выровненными по левому краю. Если мы хотим более корректно отобразить выравнивание текста в колонке, следует слегка модифицировать наш код, учитывая значение свойства Alignment текущей (то есть рисуемой в данный момент) колонки:
Соответствующий код для Delphi имеет вид:
procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if Table1.FieldByName('VenueNo').Value = 1 then
with DBGrid1.Canvas do
begin
Brush.Color := clGreen;
Font.Color := clWhite;
FillRect(Rect);
if Column.Alignment = taRightJustify then
TectOut(Rect.Right - 2 - TectWidth(Column.Field.Text),
Rect.Top+2, Column.Field.Text)
else
TectOut(Rect.Left + 2, Rect.Top + 2, Column.Field.Text);
end;
end;
|
В этом случае выравнивание текста в колонках совпадает с выравниванием столбцов.
Отметим, что величина смещения (в данном случае два пиксела), вообще говоря, зависит от гарнитуры и размера шрифта, используемого в данной колонке, и должна подбираться индивидуально.
Если необходимо отобразить нестандартным образом не всю строку, а только некоторые ячейки, следует проанализировать имя поля, отображаемого в данной колонке, как в приведенном ниже обработчике событий.
Соответствующий код для Delphi имеет вид:
procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if (Table1.FieldByName('VenueNo').Value = 1) and (Column.FieldName = 'VenueNo') then
with DBGrid1.Canvas do
begin
Brush.Color := clGreen;
Font.Color := clWhite;
FillRect(Rect);
if Column.Alignment = taRightJustify then
TectOut(Rect.Right - 2 - TectWidth(Column.Field.Text),
Rect.Top + 2, Column.Field.Text)
else
TectOut(Rect.Left + 2, Rect.Top + 2, Column.Field.Text);
end;
end;
|
В результате выделенными оказываются только ячейки, для которых выполняются выбранные нами условия:
Как заменить данные в столбце компонента TDBGrid
Нередко в колонке DBGrid нужно вывести не реальное значение, хранящееся в поле соответствующей таблицы, а другие данные, соответствующие имеющимся (например, символьную строку вместо ее числового кода). В этом случае также используется метод TextOut свойства Canvas компонента TDBGrid:
Соответствующий код для Delphi имеет вид:
procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if Column.FieldName = 'VenueNo' then
with DBGrid1.Canvas do
begin
Brush.Color := clWhite;
FillRect(Rect);
if Table.FieldByName('VanueNo').Value = 1 then
begin
Font.Color := clRed;
TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('our vanue'),
Rect.Top + 2, 'our vanue');
end
else
TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('other vanue'),
Rect.Top + 2, 'other vanue');
end;
end;
|
Еще один пример – использование значков из шрифтов Windings или Webdings в качестве подставляемой строки.
Соответствующий код для Delphi имеет вид:
procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if Column.FieldName = 'VenueNo' then
with DBGrid1.Canvas do
begin
Brush.Color := clWhite;
FillRect(Rect);
Font.name := 'Windings';
Font.Size := -14;
if Table.FieldByName('VanueNo').Value = 1 then
begin
Font.Color := clRed;
TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('J'),
Rect.Top + 2, 'J');
end
else
TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('F'),
Rect.Top + 2, 'F');
end;
end;
|
Как поместить графическое изображение в TDBGrid
Использование свойства Canvas компонента TDBGrid в методе OnDrawColumnCell позволяет не только выводить в ячейке текст методом TextOut, но и размещать в ячейках графические изображения. В этом случае используется метод Draw свойства Canvas.
Модифицируем наш пример, добавив в форму компонент TImageList и поместив в него несколько изображений.
Модифицируем код нашего приложения:
Соответствующий код для Delphi имеет вид:
procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
Im1: TBitmap;
begin
Im1 := TBitmap.Create;
if Column.FieldName = 'VenueNo' then
with DBGrid1.Canvas do
begin
Brush.Color := clWhite;
FillRect(Rect);
if Table.FieldByName('VanueNo').Value = 1 then
ImageList1.GetBitmap(0, Im1)
else
ImageList1.GetBitmap(2, Im1);
Draw(round((Rect.Left + Rect.Right - Im1.Width) / 2), Rect.Top, Im1);
end;
end;
|
Теперь в TDBGrid в колонке VenueNo находятся графические изображения.
Инструменты для печати TDBGrid.
Оформил: DeeCo
В этом обзоре рассматриваются компоненты, позволяющие быстро (без применения специальных генераторов отчетов) распечатать содержимое ТDВGrid'а.Примечание: Во внимание не принимались особые "навороченные" Grid'ы (например компоненты EhLib v.1.56 ( сайт Torry) , ExDBGrid (сайт DelphiCity) и многие другие) , которые в частности могут печатать сами себя. Нужен был именно компонент-связка, который печатает содержимое для любого наследника TDBGrid.
Использовались три компонента с сервера www.torry.ru. Раздел VCL страница Grids -> Other и страница Print Vcl -> Print Tools. Все компоненты тестировались в одинаковых условиях: Windows NT + Delphi 5 Название Print DBGrid v.1.0 URL Раздел VCL страница Grids -> Other http://www.torry.ru/gridsother.htm http://www.torry.ru/vcl/grids/other/oddataprn.zip Распространение ShareWare, с исходными кодами IDE Delphi 3 ; У меня работал в Delphi 5.ТDаtаРгintег.
Компонент ТDаtаРгintег настраивается на TDataSource. Несмотря на то, что в описании от автора обещается печать набора данных ("Well here is a component that will print a DBGrid with any data in it. " ), никакой связки с визуальными компонентами не предлагается. Собственно и в названии компонента видно, что печататься будут данные, а не Grid. Так оно все и получилось :о) Оформление печати: Вывод стандартного диалога (PrintDialog - настройка и выбор принтера) регулируется свойством PrintDialog:Boolean; Основные детали отчета: заголовки колонок(Header) и сами данные (Body); В качестве дополнительных деталей отчета предлагается Title(String) и Script(TStringList);Общий формат отчета:
Title Script1 Script2 ... ScriptN HeaderColumn1 HeaderColumn2 ... Column1Record1 Column1Record2 ... ... ... Column1RecordM Column1RecordM ...Никакой сетки не подразумевается. Для всех элементов отчета (Header, Body, Title и Script) в отдельности настраиваются шрифты; По желанию может автоматически выводится в шапке время печати(TimeStamp) и номер страницы. Сами значения Title и Script задаются в run-time, при печати данных: DataPrinter.Print( Title , Scipts );К недостаткам можно отнести следующее: Хотя автор и обещает, что печататься будут "любые данные" ("...with any data in it"), при печати memo-полей длина текста ограничена свойством DisplayWidth соответствующего поля и одной строкой, что несколько неудобно. И вывести на печать изображение из поля, содержащего графику мне тоже не удалось. С точки зрения оформления - отсутствует возможность печати сетки. Но может это и не есть недостаток.
В качестве резюме:
Компонент очень прост в использовании. Наличие исходных текстов дает возможность довольно легко добавить в отчет некоторые детали оформления. Так что для простых по функциональности и внешнему виду "быстрых" отчетов этот компонент подходит очень хорошо. Название LPTGrd / LPTBGrd v.1.0 URL Раздел VCL страница Print VCL -> Print Tools http://www.torry.ru/printtools.htm http://www.torry.ru/vcl/print/printtools/lptgrd.zip Распространение Коммерческий; Trial (work while IDE is running) IDE Delphi 1,2,3 ; У меня работал в Delphi 5 Довольно интересный компонент. Настраивается на TDBGrid.
Предлагается режим Preview(свойство Destination), правда без реализации функции zoom. Можно изменять параметры сетки (настраивать толщину и наличие горизнтальных и/или вертикальных линеек сетки). Можно отдельно настроить цвета фона для заголовков колоноки для details (самих данных отчета). В качестве дополнительных деталей отчета можно использовать Header, PageFooterCenter, PageFooterLeft и PageFooterRight. Для каждого элемента отчета (включая заголовки колонок и их содержимое) можно отдельно настраивать шрифты. Нормально печатается графика. Можно начинать печать не с первой страницы. По желанию - вызывать (или не вызывать) стандартный Print Dialog для выбора принтера и настройки параметров печати.
Поля типа memo печатаются в одной строке, но назвать это недостатком нельзя, так как автор обещал напечатать TDBGrid, он и печатается :о)
Но вот что мне показалось не совсем корректным в этом компоненте:
Несколько экспериментов с разными данными для этого компонента показали, что хотя и обещается печать грида, но для вывода названий полей используется поле TField.DisplayLabel и для ширины колонки отчета поле TField.DisplayWidth.
Логичнее (и удобнее !) было бы использовать в качестве названия колонки именно Columns.Title.Caption, а для ширины колонки Columns.Width. Вот тогда печатался бы как раз тот обещанный TDBGrid, который можно перестроить в run-time и напечатать так, как он и выглядит.
И еще, при использовании деталей PageFooterCenter, PageFooterLeft и PageFooterRight надо быть осторожнее, так как никаких ограничений на их ширину нет и никакого взаимодействия (внутренних проверок) между ними тоже нет. То есть, задав значения этих полей очень длинными, можно получить некрасивую картину из наложенных друг на друга строк.
Резюме: В общем, очень удобный компонент, с множеством настроек, что дает довольно хорошую возможность для оформления отчета.
Название QRByDataSet and TQRByGrid v.1.00 URL Раздел VCL страница Report -> Report Tools http://www.torry.ru/reportdesigners.htm http://www.torry.ru/vcl/reports/reportdesigners/reportds.zip Распространение Свободный, с исходными кодами IDE Delphi 3,4,5 ; Поначалу меня порадовали эти компоненты. Довольно просты в применении и работают аккуратно. Как видно из названия один настраивается на TDataSet, другой на TDBGrid. Для их использования обязательно должен быть установлен QuickReport, для формирования отчета для печати используется именно он. Так как QuickReport есть в стандартной поставке Delphi, то недостатком это считать нельзя. Зато можно легко пользоваться режимом Preview с возможностью выбора и настройки принтера, ну и так далее.
К недостаткам можно отнести следующее: Внешний вид отчета "зашит" в самом коде компонентов и никаких вариантов настройки оформления не предлагается.
Выбор цветовой гаммы и шрифтов заботливо взяли на себя разработчики :о)
С точки зрения простоты настройки лучше бы было устроить некую систему умолчаний, но все же разрешить самому программисту решить, как именно должен выглядеть его, пусть и очень простенький, отчет.
Компоненты берут заголовки для стобцов отчета из полей DisplayLabel. Это естественно для печати TDataSet, но почему же и при печати TDGgid названия заголовков тоже берутся оттуда, а не их полей Columns.Title.Caption? Если уж обещать напечатать RDBGrid, то на бумаге он должен быть очень похож на то, что видно на экране.
Не печатаются (просто игнорируются) поля типа Blob , ни memo-текст, ни графика.
И тем не менее компоненты очень просты в использовании, практически не требуют никаких настроек и для "быстрого" и простого отчета вполне годятся.
Название
Print Record v.1.0
URL Раздел VCL страница Print VCL -> Print Tools
http://www.torry.ru/printtools.htm
http://www.torry.ru/vcl/print/printtools/printrec.zip
Распространение Свободный, исходные коды IDE Delphi 2,3 ; У меня работал в Delphi 5
Этот компонент функционально довольно сильно отличается от предыдущих, но мне он понравился и я решила включить его в это обозрение ( вдруг кому-то понадобится именно такой вариант печати из Grid'а).
Так вот, компонент TPrintRecord печатает только одну, текущую запись того набора данных, который Вы ему укажете. Настраивается на TDataSource
В качестве дополнительных деталей отчета предлагается многострочный Header(TStringList), для которого можно отдельно настроить шрифт. В заголовке можно добавить картинку (например логотип).
Общий формат отчета таков:
<картинка>Header header ... и так несколько строк Название поля №1: Содержание поля... ... ... Название поля №n: Содержание поля...В качестве резюме:
Если строка набора данных представляет собой нечто вроде "личного дела" или "учетной карточки" и т.д., то такой вариант печати довольно удобен. Ну а наличие исходных кодов дает полный простор для самовыражения и вариантов его реализации. К сожалению не нашлось такого компонента, применение которого бы полностью решило поставленную задачу, без переделки его исходного кода.Содержание.
- Пример отсылки письма используя COM объект Outlook.
- Пример программирования com портов.
- Асинхронный режим чтения из Com-порта.
- Слияние двух бинарных файлов.
- Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE.
- Конфликт имен параметров.
- Как законнектиться через Dial-Up соединение по умолчанию.
- Консольные приложения в Delphi.
- Как можно гарантированно очистить экран в консольном приложении.
- Как в консольном приложении можно задать цвет текста, вывести текст в нужном месте.
- Переключение консольного приложения в полный экран.
- Запуск программ с передачей консольного ввода и чтением вывода.
- Как переназначить вывод в файл для консольной программы, запускаемой по CreateProcess.
- Как вывести результат работы консоли в Memo.
- Как консольное приложение может узнать, что Винды завершаются.
- Консольная программа – перевод фунтов в килограммы.
- Как сделать, чтобы в DBGrid вместо цифр были соответствующие константы.
- Что я получаю от наличия ConstraintBroker.
- Как ограничить длину текста, вводимого в TEdit, так чтобы ширина текста не превышала ширину ТЕditа.
- Ограничение размеров окна.
- Использовать консоль в неконсольном приложении.
- Контролы в WinXP выглядят как в WinXP.
- Сворачивание компонентов на форме.
- Размещать свои элементы управления в диалоге печати.
- Использование клавиш для управления компонентами.
- Контролировать Excel, используя OLE.
- Изображение контрола сохранить в файл.
- Управлять сервисом на другом компьютере в W2k.
- Получить заголовок элемента управления под мышкой.
- Функция вычисления контрольной суммы.
- Получить активный элемент управления под курсором мышки.
- Преобразуем доменное имя в IP-адрес.
- Преобразование цвета RGB в HLS.
- Преобразование в EBCDIC.
- Конвертируем таблицу в Excel c использованием TExcelApplication.
- Сделать картинке 2D свертку.
- Координаты курсора в Memo.
- Координаты курсора в Memo 2.
- Как поместить прозрачную фоновую картинку на компонент CoolBar.
- Координатная сетка.
- Сделать немерцающей анимацию при помощи CopyRect.
- Скопировать все файлы вместе с подкаталогами.
- Скопировать, удалить, вставить в TWebBrowser.
- Копирование директорий и удаление директорий в корзину.
- Скопировать, удалить, переместить всю директорию.
- Копирование содержимого директории, вместе с поддиректориями.
- Как скопировать директорию с файлами.
- Копирование файлов.
- Скопировать файлы с диалогом анимации.
- Функция, которая устанавливает дату одного файла, равную дате другого файла.
- Копируем файл в буфер обмена.
- Копируем файл с индикатором процесса.
- Скопировать файл с заполнением своего ProgressBara.
- Как скопировать картинку в буфер обмена.
- Изменить режим копирования изображения.
- Копировать и вставлять TreeNode.
- Копирование записи в пределах одной и той же таблицы.
- Копирование записи из одной таблицы в другую.
- Копирование экрана.
- Копирование экрана 2.
- Копирование содержимого экрана на форму.
- Как скопировать структуру таблицы.
- Копирование текста DBMemo.
- Копирование в буфер обмена.
- Копировать векторное изображение.
- Как скопировать самого себя.
- CORBA клиент-сервер.
- CORBA - Архитектура распределенных объектов.
- CORBA клиент – Java Server.
- Корпоративное WEB-приложение 1.
- Корпоративное WEB-приложение 2.
- Корректное закрытие базы данных приложением Delphi.
- Как правильно соединяться с базой данных под Personal Oracle.
- Корректная функция возведения в степень.
- Корректное округление чисел.
- Как реализовать визуальный отсчет времени.
- Как узнать число кадров AVI файла, и выяснить как долго будет проигрываться этот файл.
- Сколько файлов есть в определённой папке.
- Найти количество дескрипторов форм, используемых вашим приложением.
- Подсчитать количество вхождений подстроки в строке.
- Алгоритм подсчёта времени, которое ушло на какую-либо операцию.
- Найти количество вхождений подстроки в строку.
- Подсчет количества слов в строке.
- Самый быстрый способ определить частоту проца.
- Извлечь информацию о процессоре.
- Работа с портами микропроцессора.
- Как получить информацию о загрузке процессора.
- Показывает загруженость процессора.
- Три примера крэка программ.
- Взлом программ это просто - электронная кулинарная книга.
- Алгоритм действий при взломе ShareWare программы, защищённой паролем.
- Пример вычисления контрольной суммы (CRC32).
- Расчёт контрольной суммы файла CRC-32 (Доработано).
- CreateProcess, который возвращает консольный вывод.
- Как использовать CreateWindow(Ex).
- Программное создание базы данных Access (DAO DBEngine).
- Создание ODBC драйвера для MSAccess.
- Программное создание таблиц и ключей (первичных и вторичных) для БД Access.
- Как программно создать Alias.
- Как программно создать Alias 2.
- Создание алиасов.
- Создание псевдонима базы данных с указанием пути к каталогу с базой.
- Как создать все поддиректории за один проход.
- Создание и удаление полей во время выполнения программы.
- Создание и использование интерфейса.
- Создание объектов любого типа.
- Создание Active Server Page (ASP) приложений в Delphi.
- Создание autoincrement поля.
- Создание банковского ключа.
- Создание больших массивов.
- Создание пустого wav-файла.
- Создаём заблокированный файл.
- Браузер своими руками.
- Создание CGI счётчика в Delphi.
- Как написать собственный класс.
- Как реализовать правильный выпадающий контрол (Combo).
- Создать компонент любого класса.
- Создание модуля компонента.
- Мастер создания компонент.
- Создание консольного приложения.
- Создание консольных приложений.
- Как создавать не квадратные формы и контролы.
- Создание кросс-таблицы.
- Как создать dBASE таблицу во время выполнения.
- Создание указанного пути.
- Как создать новый DSN из программы.
- Создание DTD для объекта (XML).
- Создать динамический массив.
- Создаём Excel файл без OLE.
- Динамическое создание полей.
- Динамическое создание полей 2.
- Пример создания FileListBox.
- Пример создания FileListBox 2.
- Создание TList со списком файлов, отсортированных по дате.
- Проблема получения времени создания файла.
- Создание фона на форме.
- Как создать новую форму, которая бы не отбирала фокус у существующей.
- Можно ли создать форму, которая получает дополнительные параметры в методе Сгеаtе.
- Создание таблицы FOXPRO.
- Создание игры Пятнашки.
- Создание карты в игре методом спрайтов.
- Создаем гипер-ссылку в Delphi.
- Создание ловушек (Hook) в Delphi.
- Как создать простейший эксперт.
- Как создать свой пункт меню в Дельфи IDE.
- Создание уникального табличного индекса.
- Как проиндексировать программно базу.
- Создание индексного файла из Delphi.
- Программно создать ярлык.
- Программно создать ярлык 2.
- Программно создать ярлык 3.
- Юнит для создания ярлыков без использования модулей ShlObj и ComObj.
- Как открыть диалог создания ярлыка.
- Создать ярлык на рабочем столе.
- Как создать поле Lookup во время выполнения приложения.
- Создание множества экземпляров.
- Создать мультимедийный таймер.
- Создать, изменить и удалить TrayIcon.
- Создание новой MS Access базы данных.
- Как создать таблицу.
- Создание нового WAV-файла.
- Создание страниц компонента Notebook во время работы приложения.
- Создание объектных переменных.
- Создать ярлык объекта в любой папке.
- Пример создания 3D движка.
- Как в Oracle создать sequence с некоторого номера.
- Как создать каретку своей собственной формы.
- Как создать собственное Hint-окно.
- Код создания палитры.
- Для создания панелей в двумя полосами слева, которые можно двигать.
- Создание потомка от класса зарегистрированного в Delphi.
- Создание таблицы Paradox.
- Принцип создания плагинов в Delphi.
- Создание PolyPolygon используя массив точек.
- Создание pop-up меню своего компонента и кое-что еще о классе TComponentExpert.
- Как динамически создавать пункты подменю в PopupMenu.
- Создание редактора свойства.
- Как создать регион (HRNG) по маске.
- Создание RES-файла с помощью BRCC.EXE.
- Как создать вычисляемые поля во время исполнения программы.
- Создание индекса во время выполнения программы.
- Создание таблицы по образу и подобию.
- Создаём Screen Saver.
- Написание сервисов Windows NT на WinAPI.
- Создание заставки.
- Конструирование Splitter.
- Написание хранителя экрана.
- Создаём SystemDSN при помощи Delphi.
- Создание ярлыков на рабочем столе, старт меню, панели быстрого запуска.
- Как создать таблицу базы данных, не используя Database Desktop.
- Как создать таблицу базы данных, не используя Database Desktop 2.
- Как создать таблицу базы данных, не используя Database Desktop 3.
- Как создать таблицу базы данных, не используя Database Desktop 4.
- Как создать таблицу базы данных, не используя Database Desktop 5.
- Создавать таблицы такой же структуры.
- Динамическое создание таблицы и полей во время выполнения программы.
- Создание таблицы в модуле.
- Создание компонента TTable без формы.
- Создание компонента TTable без формы 2.
- Создание компонента TTable без формы 3.
- Создание компонента TTable без формы 4.
- Создание таблицы с автоинкрементальным полем.
- Создание таблицы программным путем.
- Как создать временный Canvas.
- При попытке создать объект класса TPrinter я получаю exception.
- Создание UDF для InterBase.
- Создание уникального поля.
- Создание уникального поля 2.
- Создание и использование 256-цветной палитры.
- Создание формы переменного типа.
- Как сделать WebBrowser средствами Delphi 5.
- Создание WebSnap-сервера.
- Создание WEB-приложений в среде Delphi.
- Создание WEB-сервера.
- Создать из Delphi документ Word, работа с текстом.
- Создание документов Word.
- Создание компонента.
- Создание многомерного массива.
- Кросс-таблица через pivot-таблицу.
- CrtSock - модуль для работы с сокетами в Delphi32.
- Использовать модуль CRT в Delphi.
- Как реализовать методы криптографической защиты информации.
- Методы криптографической защиты информации Windows.
- Методы криптографической защиты информации Windows 2.
- CryptoAPI для шифрования файлов случайными ключами.
- Алгоритм шифрование XOR.
- Алгоритм LZ-78.
- Crystal Reports 8.0 через API.
- Импорт CSV ASCII.
- Быстрая обработка CSV файла.
- Конвертировать CSV файл в XML.
- Симулировать нажатие клавиш для копии и вставки из буфера.
- Денежное поле редактирования.
- Как узнать имя файла текущего процесса.
- Текущий модуль и проект.
- Включить изображение курсора в снимок экрана.
- Создание курсора с процентом выполнения.
- Как поместить курсор мышки в нужное место на форме.
- Определить текущий трэк на CD.
- Отслеживать имя текущего компонента.
- Узнать текущую раскладку клавиатуры в любом активном окне.
- Как можно узнать количество цветов текущего режима.
- Получить имя текущего пользователя.
- Получить имя текущего пользователя 2.
- Исследование CuteFTP v3.0.15 beta или красота BitHacka.
- Как сделать так, чтобы работали команды Cut, Copy в WebBrowsere.
- Кириллица в параметрах CGI-запроса.
- Транслитерация кириллицы в латынь.
- Соответствие типов С и Delphi.
- Delphi2 и COM объекты.
- Изменение системного времени из Delphi2.
- Ошибка RichEdit в Delphi2 под NT4.
- Адаптация RxLib для Delphi5.
- Delphi7 Studio для облегчения миграции к платформе DotNet.
- Как создать таблицу в MS Access при помощи DAO.
- Database Desktop показывает содержимое таблиц шрифтом без русских букв.
- Модуль данных для каждого MDIChild.
- Borland DataSnap против Microsoft ADO.NET.
- Отследить изменение данных.
- Компоненты для облегчения работы с типовыми операциями поиска, выбора и фильтрации данных.
- Изменение данных в Delphi 2 (BDE).
- Хранение данных в EXE-файле.
- Передача в Word данных и формирование таблицы.
- Функция DateSer.
- Организация цикла между двумя датами.
- Частичный показ DateTime.
- Формат даты.
- Автоматический формат даты в компоненте Edit.
- Список объектов класса TDate.
- Преобразование даты в строку для SQL-сервера.
- Преобразование даты типа TDateTime в дату прописью.
- Дни недели.
- Получить номер дня в году.
- Почему DB2 ругается на Create Trigger.
- Как заставить работать DB2 через протокол IPX.
- DBase и особые случаи BDE.
- Текущий номер записи набора данных.
- Показ меток удаленных записей в dBASE-файлах.
- Удалить индекс для dBase.
- DBASE - Индексы выражений.
- Формат и размер dBase-поля.
- Определение номера записи в таблице dBASE.
- Восстановление записи dBase.
- Различные цвета строк в DBCtrlGrid.
- Insert и Override с помощью DBEdit.
- Исправление DBEdit MaxLength.
- Особенности использования BLOB полей в dbExpress на примере MySQL.
- Создание DBExpress-Connection в Run-Time.
- Развертывание приложения, использующего dbExpress, на примере Delphi6.
- DBFSeek и DBFLocate.
- Таблицы dBASE. Структура .DBF-файла.
- Индекс в другом каталоге.
- Как перекинуть все данные из DBF в DB.
- DBGrid и Memo-поля.
- Шапка в TDBGrid.
- Фокус для конкретной ячейки TDBGrid.
- Позиция ячейки в TDBGrid.
- Как сделать, чтобы необходимая ячейка DBGrid получила фокус ввода.
- DBGrid с цветными ячейками.
- DBGrid с цветными ячейками 2.
- DBGrid с цветными ячейками 3.
- Как заставить DBGrid сортировать данные по щелчку на заголовке столбца.
- Текущая строка и поле в DBGrid.
- DbGrid со свойствами Col и Row.
- Как выделить цветом текущую строку в TDBGrid.
- DBGrid CutToClipboard.
- DBGrid DefaultDrawDataCell.
- Как программно перевести DBGrid в режим редактирования.
- Экспортировать TDBGrid в Excel без использования OLE.
- Как экспортировать содержимое DBGrid в Excel или ClipBoard.
- DbGrid и множественный выбор.
- Как в TDBGrid узнать над каким полем висит мышь.
- Перемещение колонок в TDBGrid.
- Использование опции MultiSelect в DBGRID.
- Как отучить TDBGrid от автодобавления новой записи.
- Как в TDBGrid разрешить только операции UPDATE записей.
- Замечательные возможности DBGrid.
- Инструменты для печати TDBGrid.