Delphi.int.ru Expert
Сообщество программистов: общение, помощь, обмен опытом
(текущая версия системы: 2.34+; последнее обновление: 29.02.2008)

Последние новости

Архив: вопросы и ответы

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

Статистика по выпуску:

Кол-во вопросов: 15
Кол-ответов: 35
Баллы за ответы: 95

Вопрос # 356

Здравствуйте господа эксперты.
Подскажите пожалуйста как мне узнать загрузку процессора в ХР.
Заранее благодарю.

Вопрос задал: Яковлев Николай Сергеевич (статус: Посетитель)
Вопрос отправлен: 26 февраля 2007, 08:29 (эксперты)
Всего ответов: 2

1. Отвечает эксперт: Роман

Здравствуйте, Яковлев Николай Сергеевич!Вот адрес: http://delphiworld.narod.ru/base/loading_processor.html.И тутже http://delphiworld.narod.ru/_os_.html ещё много ответов на разные вопросы.

Ответ отправил: Роман (статус: 5-ый класс)
Ответ отправлен: 26 февраля 2007, 10:36
Оценка за ответ: 5

2. Отвечает эксперт: Федоров Роман Сергеевич

Для NT, 2000, XP

const
SystemBasicInformation = 0;
SystemPerformanceInformation = 2;
SystemTimeInformation = 3;

type
TPDWord = ^DWORD;

TSystem_Basic_Information = packed record
dwUnknown1: DWORD;
uKeMaximumIncrement: ULONG;
uPageSize: ULONG;
uMmNumberOfPhysicalPages: ULONG;
uMmLowestPhysicalPage: ULONG;
uMmHighestPhysicalPage: ULONG;
uAllocationGranularity: ULONG;
pLowestUserAddress: Pointer;
pMmHighestUserAddress: Pointer;
uKeActiveProcessors: ULONG;
bKeNumberProcessors: byte;
bUnknown2: byte;
wUnknown3: word;
end;

type
TSystem_Performance_Information = packed record
liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}
dwSpare: array[0..75] of DWORD;
end;

type
TSystem_Time_Information = packed record
liKeBootTime: LARGE_INTEGER;
liKeSystemTime: LARGE_INTEGER;
liExpTimeZoneBias: LARGE_INTEGER;
uCurrentTimeZoneId: ULONG;
dwReserved: DWORD;
end;

var
NtQuerySystemInformation: function(infoClass: DWORD;
buffer: Pointer;
bufSize: DWORD;
returnSize: TPDword): DWORD; stdcall = nil;

liOldIdleTime: LARGE_INTEGER = ();
liOldSystemTime: LARGE_INTEGER = ();

function Li2Double(x: LARGE_INTEGER): Double;
begin
Result := x.HighPart * 4.294967296E9 + x.LowPart
end;

procedure GetCPUUsage;
var
SysBaseInfo: TSystem_Basic_Information;
SysPerfInfo: TSystem_Performance_Information;
SysTimeInfo: TSystem_Time_Information;
status: Longint; {long}
dbSystemTime: Double;
dbIdleTime: Double;

bLoopAborted: boolean;

begin
if @NtQuerySystemInformation = nil then
NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'),
'NtQuerySystemInformation');

// get number of processors in the system

status := NtQuerySystemInformation(SystemBasicInformation, @SysBaseInfo,
SizeOf(SysBaseInfo), nil);
if status <> 0 then
Exit;

// Show some information
with SysBaseInfo do
begin
ShowMessage(
Format('uKeMaximumIncrement: %d'#13'uPageSize: %d'#13 +
'uMmNumberOfPhysicalPages: %d' + #13 + 'uMmLowestPhysicalPage: %d' + #13 +
'uMmHighestPhysicalPage: %d' + #13 + 'uAllocationGranularity: %d'#13 +
'uKeActiveProcessors: %d'#13'bKeNumberProcessors: %d' ,
[uKeMaximumIncrement, uPageSize, uMmNumberOfPhysicalPages,
uMmLowestPhysicalPage, uMmHighestPhysicalPage, uAllocationGranularity,
uKeActiveProcessors, bKeNumberProcessors]));
end;

bLoopAborted := False;

while not bLoopAborted do
begin

// get new system time
status := NtQuerySystemInformation(SystemTimeInformation, @SysTimeInfo,
SizeOf(SysTimeInfo), 0);
if status <> 0 then
Exit;

// get new CPU's idle time
status := NtQuerySystemInformation(SystemPerformanceInformation,
@SysPerfInfo, SizeOf(SysPerfInfo), nil);
if status <> 0 then
Exit;

// if it's a first call - skip it
if (liOldIdleTime.QuadPart <> 0) then
begin

// CurrentValue = NewValue - OldValue
dbIdleTime := Li2Double(SysPerfInfo.liIdleTime) -
Li2Double(liOldIdleTime);
dbSystemTime := Li2Double(SysTimeInfo.liKeSystemTime) -
Li2Double(liOldSystemTime);

// CurrentCpuIdle = IdleTime / SystemTime
dbIdleTime := dbIdleTime / dbSystemTime;

// CurrentCpuUsage% = 100 - (CurrentCpuIdle * 100) / NumberOfProcessors
dbIdleTime := 100.0 - dbIdleTime * 100.0 / SysBaseInfo.bKeNumberProcessors
+ 0.5;

// Show Percentage
Form1.Label1.Caption := FormatFloat('CPU Usage: 0.0 %', dbIdleTime);

Application.ProcessMessages;

// Abort if user pressed ESC or Application is terminated
bLoopAborted := (GetKeyState(VK_ESCAPE) and 128 = 128) or
Application.Terminated;

end;

// store new CPU's idle and system time
liOldIdleTime := SysPerfInfo.liIdleTime;
liOldSystemTime := SysTimeInfo.liKeSystemTime;

// wait one second
Sleep(1000);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
GetCPUUsage
end;

Ответ отправил: Федоров Роман Сергеевич (статус: 2-ой класс)
Ответ отправлен: 26 февраля 2007, 12:30
Оценка за ответ: 5

Вопрос # 357

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

Вопрос задал: NickStNew (статус: Посетитель)
Вопрос отправлен: 26 февраля 2007, 13:59 (эксперты)
Всего ответов: 3

1. Отвечает эксперт: Вадим К

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

Ответ отправил: Вадим К (статус: Кандидат наук)
Ответ отправлен: 26 февраля 2007, 14:24
Оценка за ответ: 4
Комментарий: Index подсвеченной строки получается, но только если выбрать style="csOwnerDrawFixed" или csOwnerDawVariable. При этом не работает редактирование в строке ввода

2. Отвечает эксперт: Новаковский Юрий Аврамович

Здравствуйте, NickStNew!
Попробуйте так:см приложение.
Через таймер, запуск таймера когда ComboBox получает фокус и останов когда ComboBox его теряет. Interval = 100.
Если пользователь ничего не выбрал остается тот индекс который был до получения фокуса.
Удачи!

Ответ отправил: Новаковский Юрий Аврамович (статус: 4-ый класс)
Ответ отправлен: 26 февраля 2007, 17:23
Оценка за ответ: 5
Комментарий: Спасибо, все работает

3. Отвечает эксперт: Шарайчук Сергій Олександрович

Здравствуйте, NickStNew!
Попробу написать код для событея ONChange, а Index получить попробуй следуйщим способом:
i:=ComboBox1.item.itemindex

Ответ отправил: Шарайчук Сергій Олександрович (статус: 1-ый класс)
Ответ отправлен: 26 февраля 2007, 20:17
Оценка за ответ: 3
Комментарий: К сожелению ответ неточен. Событие OnChange при перемещении курсора (и подсвеченной строки) по выпавшему списку компонента TComboBox не вызывается

Вопрос # 358

У меня проблема, хочу зделать програму, которая реагируєт на копирование, тойсть например если её скопировали 1 раз она делает одно, 2 раза - другое, 3 раза совсем иное. Одним словом потавить счотчик на копирование! ПОМОГИТЕ ПОЖАЛУСТА!!!!

Вопрос задал: Шарайчук Сергій Олександрович (статус: 1-ый класс)
Вопрос отправлен: 26 февраля 2007, 21:49 (эксперты)
Всего ответов: 3; сообщений в мини-форуме вопроса: 2

1. Отвечает эксперт: Роман

Здравствуйте, Шарайчук Сергій Олександрович!Странная какая-то идея...Попробуйте поискать чего-нибудь на http://www.delphikingdom.com/ там есть материаль о защите программ от копирования и взлома.Только не ясно, а где хранить информацию о кол-ве копирований,если во внешнем файле то какой в этом смысл...Да и откуда прога копироваться будет(?) с CD? Незнаю,разве что защищать её по ключевой дискете и запретить ей копироваться без неё и всё это дело шифровать...или электронным ключём на МК...Всёравно ломанут,да и стоит ли оно того...а цена...Вобщем:http://www.delphikingdom.com/ ...И кстати зачем всё это,смысл то в чём???

Ответ отправил: Роман (статус: 5-ый класс)
Ответ отправлен: 26 февраля 2007, 23:01

2. Отвечает эксперт: Вадим К

Спешу вас разочаровать, но такое практически невозможно. Если программа не запускается, то она не сможет выполнить никакого кода. В своё время группа программистов разработала большой проект по защите музыкальных дисков от копирования. Были вложены немеряные деньги. И перед окончательным выходом в свет защиту ломанули. Причём банально. Защита полагалась на то, что у пользователя включен автозапуск компакта. Стартовала маленькая прога, которая потом препятствовала копированию музыки. Но скажите, чем отличается копирование музыки на другой носитель от её воспроизведения с программной точки зрения? ничем! В любом случае её нужно вначале считать. А как вы могли догадаться, ломанули её зажатым Shift'ом. Мальчика назвали немеряным хакером и долго охотились за ним.
Это был лирический отступ.
Но если ваша программа устанавливается либо вы первоначально настраиваете её сами, то тут есть один обходной манёвр. Либо написать драйверок, который будет сидеть в памяти и перехватывать все копирования и смотреть, не моё ли - очень сложно сделать на делфи (да, да на 3 делфи можно драйвера компилить, на старших - нет) да и систему будет тормозить (ну антивирь почти:))
Либо сделать привязку к железу. И если при запуске не совпадает номер - увеличиваем счётчик. Но если с проги сняли 2 копии, то каждая с них будет жить отдельной жизнью.
Хотя есть идея. Вносим в программу код, на который явно будет ругаться антивирус (аля FORMAT C: и так далее) но этот код выполнятся не будет. Дальше при настройке указываем антивирю, что каталог с прогой не трогать. всё.

Ответ отправил: Вадим К (статус: Кандидат наук)
Ответ отправлен: 26 февраля 2007, 23:31

3. Отвечает эксперт: Федоров Роман Сергеевич

Здравствуйте, Шарайчук Сергій Олександрович!
Есть еще одна идейка, но она актуальна в том случае если вашу прогу копируют а потом запускают. Суть такова:
1)При запуске вашегл exe программа создает в том же каталоге еще один exe (который является совершенно другой программой) и запускает его.
2)Далее созданный exe ждет заверщения вашей программы и после этого записывает в конец файла информацию о текущем положении на диске и номер копии.
3)Далее я смутно представляю как это все будет выглядеть но суть такова, при запуске вы должны будете проверять записанную строку с текущим местоположением, в случае несовпадения счстаете программу скопированной и выполняете ......, незабывайте о создании второго exe (который будет опять заность информацию о месте хранения, также вы должны передавать ему ифу о том что вас уже скопировали, иначе вы несможете определить сколько раз ее копировали).

Ответ отправил: Федоров Роман Сергеевич (статус: 2-ой класс)
Ответ отправлен: 27 февраля 2007, 09:43

Вопрос # 359

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

Вопрос задал: Knjazev (статус: 3-ий класс)
Вопрос отправлен: 27 февраля 2007, 06:04 (эксперты)
Всего ответов: 1; сообщений в мини-форуме вопроса: 2

1. Отвечает эксперт: Вадим К

Написать можно. Ваша формулировка насколько расплывачаста, что я даже не могу сказать, что же конкретно вы хотите сделать. Поэтому никаких точных указаний как/почём немогу. А написать можно всё, главное желание.

Ответ отправил: Вадим К (статус: Кандидат наук)
Ответ отправлен: 27 февраля 2007, 13:51

Вопрос # 360

Kak sdelat 4toby info v BD Acces mojno bylo videt tolko 4erez mou progu. sdelan 4/z ADO

Вопрос задал: Сагынов Байсак Найсабекович (статус: Посетитель)
Вопрос отправлен: 27 февраля 2007, 12:51 (эксперты)
Всего ответов: 4; сообщений в мини-форуме вопроса: 1

1. Отвечает эксперт: Помфюк Владимир Степанович

Здравствуйте, Сагынов Байсак Найсабекович!
Шифруйте информацию, ключ держите в программе.

Ответ отправил: Помфюк Владимир Степанович (статус: Абитуриент)
Ответ отправлен: 27 февраля 2007, 12:58

2. Отвечает эксперт: Косолапов Дмитрий Юрьевич

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

Ответ отправил: Косолапов Дмитрий Юрьевич (статус: 6-ой класс)
Ответ отправлен: 27 февраля 2007, 13:10

3. Отвечает эксперт: Alex Van Glukhman

Здравствуйте, Сагынов Байсак Найсабекович!

1.Ну наверное либо в Access либо при создании БД динамически необходимо установить логины и пароли для доступа к БД. Это один вариант. На самом деле защита несерьёзная, т.к. любая програмка типа Office Password Recovery вытащит пароли.
2.Более надёжное средство - в проге создать процедуру кодирования БД. При выходе из приложения файл БД кодируется при входе декодируется. Вариант более устойчив, но здесь файл БД в открытом виде доступен при работе с прогой.
3.Наконец 3 способ. Трудоёмкий, но в плане безопасности наиболее надёжный. Вся информация записываемая в БД хранится в виде строк. ADO реализуется через TADOQuery, перед записью данные кодируются. При обращении к данным соответственно раскодируются. Соответственно выплывает недостаток. Большая по объёму БД будет долго обрабатываться.
Удачи

Ответ отправил: Alex Van Glukhman (статус: 7-ой класс)
Ответ отправлен: 27 февраля 2007, 15:42

4. Отвечает эксперт: Федоров Роман Сергеевич

Здравствуйте, Сагынов Байсак Найсабекович!
Ставьте пароль на базу данных и используйте его в программе при подключении к BD.

Ответ отправил: Федоров Роман Сергеевич (статус: 2-ой класс)
Ответ отправлен: 27 февраля 2007, 20:44

Вопрос # 363

Как сделать, чтобы галочки ставились в CheckListBox не только при нажатии на область пометки, но и при нажатии на название элемента?
======================================
Что напрашивалось сразу - я написал обработчик событий на OnClick и вроде заработало, но после этого при нажатии на область пометки - галочка появляется и сразу исчезает! Забавно так))) Прилагаю обработчик! Может както его модифицировать?

Приложение:
procedure TOtchForm3.CheckListBox1Click(Sender: TObject); begin CheckListBox1.Checked[CheckListBox1.ItemIndex]:= not CheckListBox1.Checked[CheckListBox1.ItemIndex]; end;

Вопрос задал: RedMask (статус: Посетитель)
Вопрос отправлен: 28 февраля 2007, 10:34 (эксперты)
Всего ответов: 4; сообщений в мини-форуме вопроса: 5

1. Отвечает эксперт: Иусов Сергей Ник.

Здравствуйте, RedMask!
Забавный обработчик, думаю он войдет в анналы истори :)))

Попробуй так:

PS: Не проверял, могут быть ошибки в синтаксисе :)

Приложение:
procedure TOtchForm3.CheckListBox1Click(Sender: TObject); var mes:string; begin if (Sender as TCheckListBox).Checked[(Sender as TCheckListBox).ItemIndex] then mes:=' checked' else mes:=' unchecked'; ShowMessage('Item: "'+(Sender as TCheckListBox).Items[(Sender as TCheckListBox).ItemIndex]+mes); end;

Ответ отправил: Иусов Сергей Ник. (статус: 3-ий класс)
Ответ отправлен: 28 февраля 2007, 10:56
Оценка за ответ: 4
Комментарий: Ну не знаю, в чём я не правильно задал вопрос %))

2. Отвечает эксперт: Роман

Здравствуйте, RedMask!Вот работающий код.Нужно для проверки использовать State которое имеет 3 состояния:cbUnchecked-выключен,cbChecked-включен,cbGray-серое состояние.

Приложение:
procedure TForm1.CheckListBox1Click(Sender: TObject); begin if (Sender as TCheckListBox).State[(Sender as TCheckListBox).ItemIndex]=cbChecked then (Sender as TCheckListBox).Checked[(Sender as TCheckListBox).ItemIndex]:=false else (Sender as TCheckListBox).Checked[(Sender as TCheckListBox).ItemIndex]:=true; end;

Ответ отправил: Роман (статус: 5-ый класс)
Ответ отправлен: 28 февраля 2007, 11:41
Оценка за ответ: 4
Комментарий: Работает, если в OnClickCheck поставить abort =)

3. Отвечает эксперт: Николай Рубан

Единственное что могу еще дополнительно порекомендовать, так это просто пропишите в оба обработчика (Click и ClickCheck) одинаковые действия...

Смотрите приложение.
Удачи!!!

Приложение:
procedure TForm1.CheckListBox1Click(Sender: TObject); begin if CheckListBox1.Selected[CheckListBox1.ItemIndex] then CheckListBox1.Checked[CheckListBox1.ItemIndex]:= not CheckListBox1.Checked[CheckListBox1.ItemIndex]; end; procedure TForm1.CheckListBox1ClickCheck(Sender: TObject); begin if CheckListBox1.Selected[CheckListBox1.ItemIndex] then CheckListBox1.Checked[CheckListBox1.ItemIndex]:= not CheckListBox1.Checked[CheckListBox1.ItemIndex]; end;

Ответ отправил: Николай Рубан (статус: 8-ой класс)
Ответ отправлен: 28 февраля 2007, 14:10
Оценка за ответ: 5
Комментарий: Я сделал что-то типо этого! Спасибо

4. Отвечает эксперт: Федоров Роман Сергеевич

Здравствуйте, RedMask!
var
Flag: boolean;

procedure TForm1.CheckListBox1Click(Sender: TObject);
begin
if not Flag then
CheckListBox1.Checked[CheckListBox1.ItemIndex]:= not CheckListBox1.Checked[CheckListBox1.ItemIndex];
Flag := False;
end;

procedure TForm1.CheckListBox1ClickCheck(Sender: TObject);
begin
Flag := True;
end;

Ответ отправил: Федоров Роман Сергеевич (статус: 2-ой класс)
Ответ отправлен: 28 февраля 2007, 19:39
Оценка за ответ: 5
Комментарий: Работающий вариант! :-)

Вопрос # 364

У меня появилась таая проблема: есть текст неважно где, в Memo, StringGrid, label, или Edit, мне нужно вывести ево на печать, как ето сделать? Пробовал через PrintDialog так же как и OpenDialog или SaveDialog, диалог принтера роботает, а што делать незнаю, ПОМОГИТЕ ПОЖАЛУСТА! Если знаете помогите розпичатать и диаграму из компонента Cart!!!

Вопрос задал: Шарайчук Сергій Олександрович (статус: 1-ый класс)
Вопрос отправлен: 01 марта 2007, 12:30 (эксперты)
Всего ответов: 3; сообщений в мини-форуме вопроса: 1

1. Отвечает эксперт: Федоров Роман Сергеевич

Здравствуйте, Шарайчук Сергій Олександрович!

Delphi имеет стандартный объект для доступа к принтеру - TPRINTER, находящийся в модуле PRINTERS. В этом модуле имеется переменная Printer:Tpinter, что избавляет от необходимости описывать свою. Он позволяет выводить данные на печать и управлять процессом печати. Правда, в некоторых версиях Delphi1 он имеет "глюк" - не работают функции Draw и StrethDraw. Но эта проблема поправима - можно использовать функции API. Далее приведены основные поля и методы объекта Printers :

PROPERTY

Aborted:boolean - Показывает, что процесс печати прерван
Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта. Он позволяет рисовать на листе бумаге графику, выводить текст ... . Тут есть несколько особенностей, они описаны после описания объекта.
Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером
Handle:HDS - Получить Handle на принтер для использования функций API (см. Далее)
Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait, poLandscape)
PageHeight:integer - Высота листа в пикселах
PageNumber:integer - Номер страницы, увеличивается на 1 при каждом NewPage
PageWidth:integer - Ширина листа в пикселах
PrinterIndex:integer - Номер используемого принтера по списку доступных принтеров Printers
Printers:Tstrings - Список доступных принтеров
Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати
Title:string - Имя документа или приложения. Под этим именем задание на печать регистрируется в диспетчере печати
METODS

AssignPrn(f:TextFile) - Связать текстовый файл с принтером. Далее вывод информации в этот файл приводит к ее печати. Удобно в простейших случаях.
Abort - Сбросить печать
BeginDoc - Начать печать
NewPage - Начать новую страницу
EndDoc - Завершить печать.

Пример :

Приложение:
Procedure TForm1.Button1Click(Sender: TObject); Begin With Printer do Begin // Начало печати BeginDoc; // Задали шрифт Canvas.Font:=label1.font; // Печатаем текст Canvas.TextOut(100,100,'Delphi World - лучше всех !!! :) '); // Конец печати EndDoc; end; end;

Ответ отправил: Федоров Роман Сергеевич (статус: 2-ой класс)
Ответ отправлен: 1 марта 2007, 13:59
Оценка за ответ: 5

2. Отвечает эксперт: Роман

Здравствуйте, Шарайчук Сергій Олександрович!Посмотрите тут:http://delphiworld.narod.ru/_os_.html,должно помочь.

Ответ отправил: Роман (статус: 5-ый класс)
Ответ отправлен: 1 марта 2007, 15:03
Оценка за ответ: 3

3. Отвечает эксперт: Новаковский Юрий Аврамович

Здравствуйте, Шарайчук Сергій Олександрович!
В Delphi печать происходит так: см приложение.

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

Newpage; Посылает на принтер предидущую страницу,
начинает формирование новой страницы- очищает канву принтера, устанавливает позицию пера в 0 0,
увеличивает на 1 счетчик страниц.

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

Удачи!

Приложение:
With Printer do Begin BeginDoc; Canvas.Font:=label1.font; // Задали шрифт Canvas.TextOut(100,100,'Delphi World ); // Рисуем что то на канве принтера ..... ..... ..... Newpage; // печать предидущей страницы // Рисуем что то на канве принтера ..... ..... ..... Newpage; // печать предидущей страницы // Рисуем что то на канве принтера ..... ..... ..... EndDoc; // печать последней страницы end; end;

Ответ отправил: Новаковский Юрий Аврамович (статус: 4-ый класс)
Ответ отправлен: 2 марта 2007, 10:24
Оценка за ответ: 4
Комментарий: Как нарисовать на канве изображение с обекта Chart

Вопрос # 365

Я очень много слішал о книге "Delphi глазами хакера" неподскажете где её можно скачать бесплатно!

Вопрос задал: Шарайчук Сергій Олександрович (статус: 1-ый класс)
Вопрос отправлен: 01 марта 2007, 12:33 (эксперты)
Всего ответов: 4; сообщений в мини-форуме вопроса: 8

1. Отвечает эксперт: Игорь Данилевич

Здравствуйте, Шарайчук Сергій Олександрович!

http://www.noil.pri.ee/downloads/books/DGH.rar

Ответ отправил: Игорь Данилевич (статус: 3-ий класс)
Ответ отправлен: 1 марта 2007, 13:31

2. Отвечает эксперт: mvp

Здравствуйте, Шарайчук Сергій Олександрович!
http://www.programmersclub.ru/files/book_delphi_haker.rar

Ответ отправил: mvp (статус: 4-ый класс)
Ответ отправлен: 1 марта 2007, 13:31
Оценка за ответ: 4

3. Отвечает эксперт: Николай Рубан

Вот рекомендую Вам такую ссылочку:
http://kiev.c-books.info/books/load.php?ty=delphi&lng=RU

Поней Вы найдете искомую книгу, а также эще кучу книг по тематике Delphi.

Удачи!!!

Ответ отправил: Николай Рубан (статус: 8-ой класс)
Ответ отправлен: 1 марта 2007, 13:38
Оценка за ответ: 5

4. Отвечает эксперт: Федоров Роман Сергеевич

Здравствуйте, Шарайчук Сергій Олександрович!
http://programmersclub.ru/bookhaker

Ответ отправил: Федоров Роман Сергеевич (статус: 2-ой класс)
Ответ отправлен: 1 марта 2007, 14:02
Оценка за ответ: 4

Вопрос # 366

Здрасте, уважаемые эксперты!!! Подскажите, возможно-ли на Delhi, а если возможно, то как, сделать обработчик прерывания от LPT и COM портов. Заранее спасибо!!!

Вопрос задал: Цопа Владимир Милузиевич (статус: Посетитель)
Вопрос отправлен: 02 марта 2007, 11:49 (эксперты)
Всего ответов: 2

1. Отвечает эксперт: Вадим К

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

Ответ отправил: Вадим К (статус: Кандидат наук)
Ответ отправлен: 2 марта 2007, 13:47

2. Отвечает эксперт: Роман

Здравствуйте, Цопа Владимир Милузиевич!Как извесно в NT лавочка с прямым доступом к портам была прикрыта,и для работы с COM есть функции winapi,но как мне помнится обслуживание прерываний там не предусмотрено,НО есть реализация в компоненте TBComPort.Там мониторинг состояния линий порта выведен в отдельный поток с генерацией событий;для LPT есть такая штука LptWdmIo - драйвер LPTWDMIO.sys предоставляет пользовательским приложениям возможность управлять параллельными портами ПК.Он поддерживает два вида операций -- чтение из порта и записи в порт.Прерываний там нет,но при необходилости их можно реализовать опять-же отдельным потоком.

Приложение:
// Компонент для обмена данными с внешними устройствами через интерфейс // // RS-232 в асинхронном или синхронном режиме. Разработан на основе // // библиотеки ComPort Library от Dejan Crnila. // // Работает с Delphi 2..7 под Windows 9X/ME/NT4/2K/XP. // // (c) 2001-2006 Брусникин И.В. majar@nm.ru // unit BCPort; interface uses Windows, Messages, SysUtils, Classes; {$B-,H+,X+} {$IFDEF VER140} {$DEFINE D6UP} {$ENDIF} {$IFDEF VER150} {$DEFINE D6UP} {$ENDIF} type TBaudRate = (br110, br300, br600, br1200, br2400, br4800, br9600, br14400, br19200, br38400, br56000, br57600, br115200, br128000, br256000); TByteSize = (bs5, bs6, bs7, bs8); TComErrors = set of (ceFrame, ceRxParity, ceOverrun, ceBreak, ceIO, ceMode, ceRxOver, ceTxFull); TComEvents = set of (evRxChar, evTxEmpty, evRing, evCTS, evDSR, evRLSD, evError, evRx80Full); TComSignals = set of (csCTS, csDSR, csRing, csRLSD); TParity = (paNone, paOdd, paEven, paMark, paSpace); TStopBits = (sb1, sb1_5, sb2); TSyncMethod = (smThreadSync, smWindowSync, smNone); TComSignalEvent = procedure(Sender: TObject; State: Boolean) of object; TComErrorEvent = procedure(Sender: TObject; Errors: TComErrors) of object; TRxCharEvent = procedure(Sender: TObject; Count: Integer) of object; TOperationKind = (okWrite, okRead); TAsync = record Overlapped: TOverlapped; Kind: TOperationKind; Data: Pointer; Size: Integer; end; PAsync = ^TAsync; TBComPort = class; TComThread = class(TThread) private FComPort: TBComPort; FEvents: TComEvents; FStopEvent: THandle; protected procedure DoEvents; procedure Execute; override; procedure SendEvents; procedure Stop; public constructor Create(AComPort: TBComPort); destructor Destroy; override; end; TComTimeouts = class(TPersistent) private FComPort: TBComPort; FReadInterval: Integer; FReadTotalM: Integer; FReadTotalC: Integer; FWriteTotalM: Integer; FWriteTotalC: Integer; procedure SetComPort(const AComPort: TBComPort); procedure SetReadInterval(const Value: Integer); procedure SetReadTotalM(const Value: Integer); procedure SetReadTotalC(const Value: Integer); procedure SetWriteTotalM(const Value: Integer); procedure SetWriteTotalC(const Value: Integer); protected procedure AssignTo(Dest: TPersistent); override; public constructor Create; property ComPort: TBComPort read FComPort; published property ReadInterval: Integer read FReadInterval write SetReadInterval; property ReadTotalMultiplier: Integer read FReadTotalM write SetReadTotalM; property ReadTotalConstant: Integer read FReadTotalC write SetReadTotalC; property WriteTotalMultiplier: Integer read FWriteTotalM write SetWriteTotalM; property WriteTotalConstant: Integer read FWriteTotalC write SetWriteTotalC; end; TBComPort = class(TComponent) private FBaudRate: TBaudRate; FByteSize: TByteSize; FConnected: Boolean; FCTPriority: TThreadPriority; FEvents: TComEvents; FEventThread: TComThread; FHandle: THandle; FInBufSize: Integer; FOutBufSize: Integer; FParity: TParity; FPort: String; FStopBits: TStopBits; FSyncMethod: TSyncMethod; FTimeouts: TComTimeouts; FUpdate: Boolean; FWindow: THandle; FOnCTSChange: TComSignalEvent; FOnDSRChange: TComSignalEvent; FOnError: TComErrorEvent; FOnRing: TNotifyEvent; FOnRLSDChange: TComSignalEvent; FOnRx80Full: TNotifyEvent; FOnRxChar: TRxCharEvent; FOnTxEmpty: TNotifyEvent; procedure CallCTSChange; procedure CallDSRChange; procedure CallError; procedure CallRing; procedure CallRLSDChange; procedure CallRx80Full; procedure CallRxChar; procedure CallTxEmpty; procedure SetBaudRate(const Value: TBaudRate); procedure SetByteSize(const Value: TByteSize); procedure SetCTPriority(const Value: TThreadPriority); procedure SetInBufSize(const Value: Integer); procedure SetOutBufSize(const Value: Integer); procedure SetParity(const Value: TParity); procedure SetPort(const Value: String); procedure SetStopBits(const Value: TStopBits); procedure SetSyncMethod(const Value: TSyncMethod); procedure SetTimeouts(const Value: TComTimeouts); procedure WindowMethod(var Message: TMessage); protected procedure ApplyBuffer; procedure ApplyDCB; procedure ApplyTimeouts; procedure CreateHandle; procedure DestroyHandle; procedure SetupComPort; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure AbortAllAsync; procedure BeginUpdate; procedure ClearBuffer(Input, Output: Boolean); procedure Close; procedure EndUpdate; function InBufCount: Integer; function IsAsyncCompleted(AsyncPtr: PAsync): Boolean; procedure Open; function OutBufCount: Integer; function Read(var Buffer; Count: Integer): Integer; function ReadAsync(var Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; function ReadStr(var Str: string; Count: Integer): Integer; function ReadStrAsync(var Str: string; Count: Integer; var AsyncPtr: PAsync): Integer; procedure SetDTR(State: Boolean); procedure SetRTS(State: Boolean); function Signals: TComSignals; function WaitForAsync(var AsyncPtr: PAsync): Integer; function Write(const Buffer; Count: Integer): Integer; function WriteAsync(const Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; function WriteStr(const Str: string): Integer; function WriteStrAsync(const Str: string; var AsyncPtr: PAsync): Integer; property Connected: Boolean read FConnected; property CTPriority: TThreadPriority read FCTPriority write SetCTPriority; published property BaudRate: TBaudRate read FBaudRate write SetBaudRate; property ByteSize: TByteSize read FByteSize write SetByteSize; property InBufSize: Integer read FInBufSize write SetInBufSize; property OutBufSize: Integer read FOutBufSize write SetOutBufSize; property Parity: TParity read FParity write SetParity; property Port: String read FPort write SetPort; property SyncMethod: TSyncMethod read FSyncMethod write SetSyncMethod; property StopBits: TStopBits read FStopBits write SetStopBits; property Timeouts: TComTimeouts read FTimeouts write SetTimeouts; property OnCTSChange: TComSignalEvent read FOnCTSChange write FOnCTSChange; property OnDSRChange: TComSignalEvent read FOnDSRChange write FOnDSRChange; property OnError: TComErrorEvent read FOnError write FOnError; property OnRing: TNotifyEvent read FOnRing write FOnRing; property OnRLSDChange: TComSignalEvent read FOnRLSDChange write FOnRLSDChange; property OnRx80Full: TNotifyEvent read FOnRx80Full write FOnRx80Full; property OnRxChar: TRxCharEvent read FOnRxChar write FOnRxChar; property OnTxEmpty: TNotifyEvent read FOnTxEmpty write FOnTxEmpty; end; EComPort = class(Exception); procedure InitAsync(var AsyncPtr: PAsync); procedure DoneAsync(var AsyncPtr: PAsync); procedure EnumComPorts(Ports: TStrings); procedure Register; implementation uses Forms; const CM_COMPORT = WM_USER + 1; CEMess: array[1..15] of string = ('Попытка открыть несуществующий COM-порт', 'Порт занят другой программой', 'Ошибка записи в порт', 'Ошибка чтения из порта', 'Недопустимый параметр Async', 'Ошибка функции PurgeComm', 'Не удалось получить статус асинхронной операции', 'Ошибка функции SetCommState', 'Ошибка функции SetCommTimeouts', 'Ошибка функции SetupComm', 'Ошибка функции ClearCommError', 'Ошибка функции GetCommModemStatus', 'Ошибка функции EscapeCommFunction', 'Нельзя менять свойство, пока порт открыт', 'Ошибка обращения к системному реестру'); function EventsToInt(const Events: TComEvents): Integer; begin Result := 0; if evRxChar in Events then Result := Result or EV_RXCHAR; if evTxEmpty in Events then Result := Result or EV_TXEMPTY; if evRing in Events then Result := Result or EV_RING; if evCTS in Events then Result := Result or EV_CTS; if evDSR in Events then Result := Result or EV_DSR; if evRLSD in Events then Result := Result or EV_RLSD; if evError in Events then Result := Result or EV_ERR; if evRx80Full in Events then Result := Result or EV_RX80FULL; end; function IntToEvents(Mask: Integer): TComEvents; begin Result := []; if (EV_RXCHAR and Mask) <> 0 then Result := Result + [evRxChar]; if (EV_TXEMPTY and Mask) <> 0 then Result := Result + [evTxEmpty]; if (EV_RING and Mask) <> 0 then Result := Result + [evRing]; if (EV_CTS and Mask) <> 0 then Result := Result + [evCTS]; if (EV_DSR and Mask) <> 0 then Result := Result + [evDSR]; if (EV_RLSD and Mask) <> 0 then Result := Result + [evRLSD]; if (EV_ERR and Mask) <> 0 then Result := Result + [evError]; if (EV_RX80FULL and Mask) <> 0 then Result := Result + [evRx80Full]; end; { TComThread } constructor TComThread.Create(AComPort: TBComPort); begin inherited Create(True); FStopEvent := CreateEvent(nil, True, False, nil); FComPort := AComPort; Priority := FComPort.CTPriority; SetCommMask(FComPort.FHandle, EventsToInt(FComPort.FEvents)); Resume; end; destructor TComThread.Destroy; begin Stop; inherited Destroy; end; procedure TComThread.Execute; var EventHandles: array[0..1] of THandle; Overlapped: TOverlapped; Signaled, BytesTrans, Mask: DWORD; begin FillChar(Overlapped, SizeOf(Overlapped), 0); Overlapped.hEvent := CreateEvent(nil, True, True, nil); EventHandles[0] := FStopEvent; EventHandles[1] := Overlapped.hEvent; repeat WaitCommEvent(FComPort.FHandle, Mask, @Overlapped); Signaled := WaitForMultipleObjects(2, @EventHandles, False, INFINITE); if (Signaled = WAIT_OBJECT_0 + 1) and GetOverlappedResult(FComPort.FHandle, Overlapped, BytesTrans, False) then begin FEvents := IntToEvents(Mask); case FComPort.SyncMethod of smThreadSync: Synchronize(DoEvents); smWindowSync: SendEvents; smNone : DoEvents; end; end; until Signaled <> (WAIT_OBJECT_0 + 1); SetCommMask(FComPort.FHandle, 0); PurgeComm(FComPort.FHandle, PURGE_TXCLEAR or PURGE_RXCLEAR); CloseHandle(Overlapped.hEvent); CloseHandle(FStopEvent); end; procedure TComThread.Stop; begin SetEvent(FStopEvent); Sleep(0); end; procedure TComThread.SendEvents; begin if evError in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_ERR, 0); if evRxChar in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_RXCHAR, 0); if evTxEmpty in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_TXEMPTY, 0); if evRing in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_RING, 0); if evCTS in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_CTS, 0); if evDSR in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_DSR, 0); if evRing in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_RLSD, 0); if evRx80Full in FEvents then SendMessage(FComPort.FWindow, CM_COMPORT, EV_RX80FULL, 0); end; procedure TComThread.DoEvents; begin if evError in FEvents then FComPort.CallError; if evRxChar in FEvents then FComPort.CallRxChar; if evTxEmpty in FEvents then FComPort.CallTxEmpty; if evRing in FEvents then FComPort.CallRing; if evCTS in FEvents then FComPort.CallCTSChange; if evDSR in FEvents then FComPort.CallDSRChange; if evRLSD in FEvents then FComPort.CallRLSDChange; if evRx80Full in FEvents then FComPort.CallRx80Full; end; { TComTimeouts } constructor TComTimeouts.Create; begin inherited Create; FReadInterval := -1; FWriteTotalM := 100; FWriteTotalC := 1000; end; procedure TComTimeouts.AssignTo(Dest: TPersistent); begin if Dest is TComTimeouts then begin with TComTimeouts(Dest) do begin FReadInterval := Self.ReadInterval; FReadTotalM := Self.ReadTotalMultiplier; FReadTotalC := Self.ReadTotalConstant; FWriteTotalM := Self.WriteTotalMultiplier; FWriteTotalC := Self.WriteTotalConstant; end; end else inherited AssignTo(Dest); end; procedure TComTimeouts.SetComPort(const AComPort: TBComPort); begin FComPort := AComPort; end; procedure TComTimeouts.SetReadInterval(const Value: Integer); begin if Value <> FReadInterval then begin FReadInterval := Value; FComPort.ApplyTimeouts; end; end; procedure TComTimeouts.SetReadTotalC(const Value: Integer); begin if Value <> FReadTotalC then begin FReadTotalC := Value; FComPort.ApplyTimeouts; end; end; procedure TComTimeouts.SetReadTotalM(const Value: Integer); begin if Value <> FReadTotalM then begin FReadTotalM := Value; FComPort.ApplyTimeouts; end; end; procedure TComTimeouts.SetWriteTotalC(const Value: Integer); begin if Value <> FWriteTotalC then begin FWriteTotalC := Value; FComPort.ApplyTimeouts; end; end; procedure TComTimeouts.SetWriteTotalM(const Value: Integer); begin if Value <> FWriteTotalM then begin FWriteTotalM := Value; FComPort.ApplyTimeouts; end; end; { TBComPort } constructor TBComPort.Create(AOwner: TComponent); begin inherited Create(AOwner); FComponentStyle := FComponentStyle - [csInheritable]; FBaudRate := br9600; FByteSize := bs8; FConnected := False; FCTPriority := tpNormal; FEvents := [evRxChar, evTxEmpty, evRing, evCTS, evDSR, evRLSD, evError, evRx80Full]; FHandle := INVALID_HANDLE_VALUE; FInBufSize := 2048; FOutBufSize := 2048; FParity := paNone; FPort := 'COM2'; FStopBits := sb1; FSyncMethod := smThreadSync; FTimeouts := TComTimeouts.Create; FTimeouts.SetComPort(Self); FUpdate := True; end; destructor TBComPort.Destroy; begin Close; FTimeouts.Free; inherited Destroy; end; procedure TBComPort.CreateHandle; begin FHandle := CreateFile(PChar('\.' + FPort), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); if FHandle = INVALID_HANDLE_VALUE then begin if GetLastError = ERROR_FILE_NOT_FOUND then raise EComPort.Create(CEMess[1]) else if GetLastError = ERROR_ACCESS_DENIED then raise EComPort.Create(CEMess[2]); end; end; procedure TBComPort.DestroyHandle; begin if FHandle <> INVALID_HANDLE_VALUE then CloseHandle(FHandle); end; procedure TBComPort.WindowMethod(var Message: TMessage); begin with Message do if Msg = CM_COMPORT then try if InSendMessage then ReplyMessage(0); if FConnected then case wParam of EV_CTS: CallCTSChange; EV_DSR: CallDSRChange; EV_RING: CallRing; EV_RLSD: CallRLSDChange; EV_RX80FULL: CallRx80Full; EV_RXCHAR: CallRxChar; EV_ERR: CallError; EV_TXEMPTY: CallTxEmpty; end; except Application.HandleException(Self); end else Result := DefWindowProc(FWindow, Msg, wParam, lParam); end; procedure TBComPort.BeginUpdate; begin FUpdate := False; end; procedure TBComPort.EndUpdate; begin if not FUpdate then FUpdate := True; SetupComPort; end; procedure TBComPort.Open; begin if not FConnected then begin CreateHandle; FConnected := True; try SetupComPort; except DestroyHandle; FConnected := False; raise; end; if (FSyncMethod = smWindowSync) then {$IFDEF D6UP} {$WARN SYMBOL_DEPRECATED OFF} {$ENDIF} FWindow := AllocateHWnd(WindowMethod); {$IFDEF D6UP} {$WARN SYMBOL_DEPRECATED ON} {$ENDIF} FEventThread := TComThread.Create(Self); end; end; procedure TBComPort.Close; begin if FConnected then begin SetDTR(False); SetRTS(False); AbortAllAsync; FEventThread.Free; if FSyncMethod = smWindowSync then {$IFDEF D6UP} {$WARN SYMBOL_DEPRECATED OFF} {$ENDIF} DeallocateHWnd(FWindow); {$IFDEF D6UP} {$WARN SYMBOL_DEPRECATED ON} {$ENDIF} DestroyHandle; FConnected := False; end; end; procedure TBComPort.ApplyDCB; const CBaudRate: array[TBaudRate] of Integer = (CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200, CBR_128000, CBR_256000); var DCB: TDCB; begin if FConnected and FUpdate then begin FillChar(DCB, SizeOf(TDCB), 0); DCB.DCBlength := SizeOf(TDCB); DCB.BaudRate := CBaudRate[FBaudRate]; DCB.ByteSize := Ord(TByteSize(FByteSize)) + 5; DCB.Flags := 1 or ($30 and (DTR_CONTROL_ENABLE shl 4)) or ($3000 and (RTS_CONTROL_ENABLE shl 12)); if FParity <> paNone then DCB.Flags := DCB.Flags or 2; DCB.Parity := Ord(TParity(FParity)); DCB.StopBits := Ord(TStopBits(FStopBits)); DCB.XonChar := #17; DCB.XoffChar := #19; if not SetCommState(FHandle, DCB) then raise EComPort.Create(CEMess[8]); end; end; procedure TBComPort.ApplyTimeouts; var Timeouts: TCommTimeouts; function MValue(const Value: Integer): DWORD; begin if Value < 0 then Result := MAXDWORD else Result := Value; end; begin if FConnected and FUpdate then begin Timeouts.ReadIntervalTimeout := MValue(FTimeouts.ReadInterval); Timeouts.ReadTotalTimeoutMultiplier := MValue(FTimeouts.ReadTotalMultiplier); Timeouts.ReadTotalTimeoutConstant := MValue(FTimeouts.ReadTotalConstant); Timeouts.WriteTotalTimeoutMultiplier := MValue(FTimeouts.WriteTotalMultiplier); Timeouts.WriteTotalTimeoutConstant := MValue(FTimeouts.WriteTotalConstant); if not SetCommTimeouts(FHandle, Timeouts) then raise EComPort.Create(CEMess[9]); end; end; procedure TBComPort.ApplyBuffer; begin if FConnected and FUpdate then if not SetupComm(FHandle, FInBufSize, FOutBufSize) then raise EComPort.Create(CEMess[10]); end; procedure TBComPort.SetupComPort; begin ApplyBuffer; ApplyDCB; ApplyTimeouts; end; function TBComPort.InBufCount: Integer; var Errors: DWORD; ComStat: TComStat; begin if not ClearCommError(FHandle, Errors, @ComStat) then raise EComPort.Create(CEMess[11]); Result := ComStat.cbInQue; end; function TBComPort.OutBufCount: Integer; var Errors: DWORD; ComStat: TComStat; begin if not ClearCommError(FHandle, Errors, @ComStat) then raise EComPort.Create(CEMess[11]); Result := ComStat.cbOutQue; end; function TBComPort.Signals: TComSignals; var Status: DWORD; begin if not GetCommModemStatus(FHandle, Status) then raise EComPort.Create(CEMess[12]); Result := []; if (MS_CTS_ON and Status) <> 0 then Result := Result + [csCTS]; if (MS_DSR_ON and Status) <> 0 then Result := Result + [csDSR]; if (MS_RING_ON and Status) <> 0 then Result := Result + [csRing]; if (MS_RLSD_ON and Status) <> 0 then Result := Result + [csRLSD]; end; procedure TBComPort.SetDTR(State: Boolean); var Act: DWORD; begin if State then Act := Windows.SETDTR else Act := Windows.CLRDTR; if not EscapeCommFunction(FHandle, Act) then raise EComPort.Create(CEMess[13]); end; procedure TBComPort.SetRTS(State: Boolean); var Act: DWORD; begin if State then Act := Windows.SETRTS else Act := Windows.CLRRTS; if not EscapeCommFunction(FHandle, Act) then raise EComPort.Create(CEMess[13]); end; procedure TBComPort.ClearBuffer(Input, Output: Boolean); var Flag: DWORD; begin Flag := 0; if Input then Flag := PURGE_RXCLEAR; if Output then Flag := Flag or PURGE_TXCLEAR; if not PurgeComm(FHandle, Flag) then raise EComPort.Create(CEMess[6]); end; procedure PrepareAsync(AKind: TOperationKind; const Buffer; Count: Integer; AsyncPtr: PAsync); begin with AsyncPtr^ do begin Kind := AKind; if Data <> nil then FreeMem(Data); GetMem(Data, Count); Move(Buffer, Data^, Count); Size := Count; end; end; function TBComPort.WriteAsync(const Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; var Success: Boolean; BytesTrans: DWORD; begin if AsyncPtr = nil then raise EComPort.Create(CEMess[5]); PrepareAsync(okWrite, Buffer, Count, AsyncPtr); Success := WriteFile(FHandle, Buffer, Count, BytesTrans, @AsyncPtr^.Overlapped) or (GetLastError = ERROR_IO_PENDING); if not Success then raise EComPort.Create(CEMess[3]); Result := BytesTrans; end; function TBComPort.Write(const Buffer; Count: Integer): Integer; var AsyncPtr: PAsync; begin InitAsync(AsyncPtr); try WriteAsync(Buffer, Count, AsyncPtr); Result := WaitForAsync(AsyncPtr); finally DoneAsync(AsyncPtr); end; end; function TBComPort.WriteStrAsync(const Str: string; var AsyncPtr: PAsync): Integer; begin if Length(Str) > 0 then Result := WriteAsync(Str[1], Length(Str), AsyncPtr) else Result := 0; end; function TBComPort.WriteStr(const Str: string): Integer; var AsyncPtr: PAsync; begin InitAsync(AsyncPtr); try WriteStrAsync(Str, AsyncPtr); Result := WaitForAsync(AsyncPtr); finally DoneAsync(AsyncPtr); end; end; function TBComPort.ReadAsync(var Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; var Success: Boolean; BytesTrans: DWORD; begin if AsyncPtr = nil then raise EComPort.Create(CEMess[5]); AsyncPtr^.Kind := okRead; Success := ReadFile(FHandle, Buffer, Count, BytesTrans, @AsyncPtr^.Overlapped) or (GetLastError = ERROR_IO_PENDING); if not Success then raise EComPort.Create(CEMess[4]); Result := BytesTrans; end; function TBComPort.Read(var Buffer; Count: Integer): Integer; var AsyncPtr: PAsync; begin InitAsync(AsyncPtr); try ReadAsync(Buffer, Count, AsyncPtr); Result := WaitForAsync(AsyncPtr); finally DoneAsync(AsyncPtr); end; end; function TBComPort.ReadStrAsync(var Str: string; Count: Integer; var AsyncPtr: PAsync): Integer; begin SetLength(Str, Count); if Count > 0 then Result := ReadAsync(Str[1], Count, AsyncPtr) else Result := 0; end; function TBComPort.ReadStr(var Str: string; Count: Integer): Integer; var AsyncPtr: PAsync; begin InitAsync(AsyncPtr); try ReadStrAsync(Str, Count, AsyncPtr); Result := WaitForAsync(AsyncPtr); SetLength(Str, Result); finally DoneAsync(AsyncPtr); end; end; function ErrorCode(AsyncPtr: PAsync): Integer; begin if AsyncPtr^.Kind = okRead then Result := 4 else Result := 3; end; function TBComPort.WaitForAsync(var AsyncPtr: PAsync): Integer; var BytesTrans, Signaled: DWORD; Success: Boolean; begin if AsyncPtr = nil then raise EComPort.Create(CEMess[5]); Signaled := WaitForSingleObject(AsyncPtr^.Overlapped.hEvent, INFINITE); Success := (Signaled = WAIT_OBJECT_0) and (GetOverlappedResult(FHandle, AsyncPtr^.Overlapped, BytesTrans, False)); if not Success then raise EComPort.Create(CEMess[ErrorCode(AsyncPtr)]); Result := BytesTrans; end; procedure TBComPort.AbortAllAsync; begin if not PurgeComm(FHandle, PURGE_TXABORT or PURGE_RXABORT) then raise EComPort.Create(CEMess[6]); end; function TBComPort.IsAsyncCompleted(AsyncPtr: PAsync): Boolean; var BytesTrans: DWORD; begin if AsyncPtr = nil then raise EComPort.Create(CEMess[5]); Result := GetOverlappedResult(FHandle, AsyncPtr^.Overlapped, BytesTrans, False); if not Result then if (GetLastError <> ERROR_IO_PENDING) and (GetLastError <> ERROR_IO_INCOMPLETE) then raise EComPort.Create(CEMess[7]); end; procedure TBComPort.CallCTSChange; begin if Assigned(FOnCTSChange) then FOnCTSChange(Self, csCTS in Signals); end; procedure TBComPort.CallDSRChange; begin if Assigned(FOnDSRChange) then FOnDSRChange(Self, csDSR in Signals); end; procedure TBComPort.CallRLSDChange; begin if Assigned(FOnRLSDChange) then FOnRLSDChange(Self, csRLSD in Signals); end; procedure TBComPort.CallError; var Errs: TComErrors; Errors: DWORD; ComStat: TComStat; begin if not ClearCommError(FHandle, Errors, @ComStat) then raise EComPort.Create(CEMess[11]); Errs := []; if (CE_FRAME and Errors) <> 0 then Errs := Errs + [ceFrame]; if ((CE_RXPARITY and Errors) <> 0) and (FParity <> paNone) then Errs := Errs + [ceRxParity]; if (CE_OVERRUN and Errors) <> 0 then Errs := Errs + [ceOverrun]; if (CE_RXOVER and Errors) <> 0 then Errs := Errs + [ceRxOver]; if (CE_TXFULL and Errors) <> 0 then Errs := Errs + [ceTxFull]; if (CE_BREAK and Errors) <> 0 then Errs := Errs + [ceBreak]; if (CE_IOE and Errors) <> 0 then Errs := Errs + [ceIO]; if (CE_MODE and Errors) <> 0 then Errs := Errs + [ceMode]; if (Errs <> []) and Assigned(FOnError) then FOnError(Self, Errs); end; procedure TBComPort.CallRing; begin if Assigned(FOnRing) then FOnRing(Self); end; procedure TBComPort.CallRx80Full; begin if Assigned(FOnRx80Full) then FOnRx80Full(Self); end; procedure TBComPort.CallRxChar; var Count: Integer; begin Count := InBufCount; if (Count > 0) and Assigned(FOnRxChar) then FOnRxChar(Self, Count); end; procedure TBComPort.CallTxEmpty; begin if Assigned(FOnTxEmpty) then FOnTxEmpty(Self); end; procedure TBComPort.SetBaudRate(const Value: TBaudRate); begin if Value <> FBaudRate then begin FBaudRate := Value; ApplyDCB; end; end; procedure TBComPort.SetByteSize(const Value: TByteSize); begin if Value <> FByteSize then begin FByteSize := Value; ApplyDCB; end; end; procedure TBComPort.SetParity(const Value: TParity); begin if Value <> FParity then begin FParity := Value; ApplyDCB; end; end; procedure TBComPort.SetPort(const Value: String); begin if FConnected then raise EComPort.Create(CEMess[14]) else if Value <> FPort then FPort := Value; end; procedure TBComPort.SetStopBits(const Value: TStopBits); begin if Value <> FStopBits then begin FStopBits := Value; ApplyDCB; end; end; procedure TBComPort.SetSyncMethod(const Value: TSyncMethod); begin if Value <> FSyncMethod then begin if FConnected then raise EComPort.Create(CEMess[14]) else FSyncMethod := Value; end; end; procedure TBComPort.SetCTPriority(const Value: TThreadPriority); begin if Value <> FCTPriority then begin if FConnected then raise EComPort.Create(CEMess[14]) else FCTPriority := Value; end; end; procedure TBComPort.SetInBufSize(const Value: Integer); begin if Value <> FInBufSize then begin FInBufSize := Value; if (FInBufSize mod 2) = 1 then Dec(FInBufSize); ApplyBuffer; end; end; procedure TBComPort.SetOutBufSize(const Value: Integer); begin if Value <> FOutBufSize then begin FOutBufSize := Value; if (FOutBufSize mod 2) = 1 then Dec(FOutBufSize); ApplyBuffer; end; end; procedure TBComPort.SetTimeouts(const Value: TComTimeouts); begin FTimeouts.Assign(Value); ApplyTimeouts; end; procedure InitAsync(var AsyncPtr: PAsync); begin New(AsyncPtr); with AsyncPtr^ do begin FillChar(Overlapped, SizeOf(TOverlapped), 0); Overlapped.hEvent := CreateEvent(nil, True, True, nil); Data := nil; Size := 0; end; end; procedure DoneAsync(var AsyncPtr: PAsync); begin with AsyncPtr^ do begin CloseHandle(Overlapped.hEvent); if Data <> nil then FreeMem(Data); end; Dispose(AsyncPtr); AsyncPtr := nil; end; procedure EnumComPorts(Ports: TStrings); var KeyHandle: HKEY; ErrCode, Index: Integer; ValueName, Data: String; ValueLen, DataLen, ValueType: DWORD; TmpPorts: TStringList; begin ErrCode := RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWAREDEVICEMAPSERIALCOMM', 0, KEY_READ, KeyHandle); if ErrCode <> ERROR_SUCCESS then raise EComPort.Create(CEMess[15]); TmpPorts := TStringList.Create; try Index := 0; repeat ValueLen := 256; DataLen := 256; SetLength(ValueName, ValueLen); SetLength(Data, DataLen); ErrCode := RegEnumValue(KeyHandle, Index, PChar(ValueName), {$IFDEF VER120} Cardinal(ValueLen), {$ELSE} ValueLen, {$ENDIF} nil, @ValueType, PByte(PChar(Data)), @DataLen); if ErrCode = ERROR_SUCCESS then begin SetLength(Data, DataLen - 1); TmpPorts.Add(Data); Inc(Index); end else if ErrCode <> ERROR_NO_MORE_ITEMS then raise EComPort.Create(CEMess[15]); until (ErrCode <> ERROR_SUCCESS) ; TmpPorts.Sort; Ports.Assign(TmpPorts); finally RegCloseKey(KeyHandle); TmpPorts.Free; end; end; procedure Register; begin RegisterComponents('Samples', [TBComPort]); end; end.

Ответ отправил: Роман (статус: 5-ый класс)
Ответ отправлен: 2 марта 2007, 14:02
Оценка за ответ: 5
Комментарий: Огромное спасибо за подсказку! В глубине души я подозревал, что проблему нужно решать через потоки. Но так-как "варюсь в собственном соку" (нескем общаться) решил поспрошать у Вас - Экспертов.

Вопрос # 367

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

Вопрос задал: Толков Геннадий Викторович (статус: Посетитель)
Вопрос отправлен: 02 марта 2007, 23:24 (эксперты)
Всего ответов: 3; сообщений в мини-форуме вопроса: 1

1. Отвечает эксперт: Федоров Роман Сергеевич

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

Ответ отправил: Федоров Роман Сергеевич (статус: 2-ой класс)
Ответ отправлен: 2 марта 2007, 23:36
Оценка за ответ: 3

2. Отвечает эксперт: Роман

Здравствуйте, Толков Геннадий Викторович!Вот вам два примера.Первый выводит в ListBox все файлы каталога.Второй - Функция предоставляет Вам каждый раз новое имя файла,а если список файлов исчерпан, начинает перебор снова.Может пригодиться для последовательного воспроизведения файлов.

Приложение:
1.=========================== procedure ListFileDir(Path: string; FileList: TStrings); var SR: TSearchRec; begin if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then begin repeat if (SR.Attr <> faDirectory) then begin FileList.Add(SR.Name); end; until FindNext(SR) <> 0; FindClose(SR); end; end; procedure TForm1.Button1Click(Sender: TObject); begin ListFileDir('C:WINDOWS', ListBox1.Items); end; ================================== 2.============================= function GetNextFileName(Path: string): string; const ListFileName = 'ListFile.lst'; FileMask = '*.*' ; var SearchRec: TSearchRec; begin with TStringList.Create do begin if FileExists(ListFileName) then begin LoadFromFile(ListFileName); end; if FindFirst(IncludeTrailingBackslash(Path) + FileMask, faAnyFile and not faDirectory, SearchRec) = 0 then begin repeat Result := SearchRec.Name; if (FindNext(SearchRec) <> 0) then begin Clear; end; until (IndexOf(Result) = -1); Add(Result); FindClose(SearchRec); end else begin Result := ''; end; SaveToFile(ListFileName); Free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(GetNextFileName('D:Моя музыка')); end; ===================================

Ответ отправил: Роман (статус: 5-ый класс)
Ответ отправлен: 3 марта 2007, 00:34
Оценка за ответ: 5

3. Отвечает эксперт: Дима Гусаков

Здравствуйте, Толков Геннадий Викторович!
Исходник в прикреплённом файле.
К ответу прикреплён файл. Загрузить » (срок хранения: 30 дней с момента отправки ответа)

Приложение:
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Buttons, MPlayer, StdCtrls, ExtCtrls; type TForm1 = class(TForm) ListBox1: TListBox; MediaPlayer1: TMediaPlayer; SpeedButton1: TSpeedButton; Label1: TLabel; Label2: TLabel; Timer1: TTimer; CheckBox1: TCheckBox; procedure PlayList(Path:String); procedure Play; procedure FormCreate(Sender: TObject); procedure ListBox1Click(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); //воспроизведение private { Private declarations } public { Public declarations } end; var Form1: TForm1; cDir: String; min, sec: Integer; //время воспроизведения implementation {$R *.dfm} //формируем список файлов procedure TForm1.PlayList(Path:String); var LpBuf: PChar; sWinDir: String; SearchRec: TSearchRec; //структура SearchRec содержит //информацию о файле, удостоверяющем //условию поиска begin ListBox1.Clear; //сформировать список файлов if FindFirst(Path + '*.mp3', faAnyFile, SearchRec) = 0 then begin ListBox1.Items.Add(SearchRec.Name); while (FindNext(SearchRec) = 0) do ListBox1.Items.Add(SearchRec.Name); end; ListBox1.ItemIndex := 0; //установить указатель на первую строку end; //воспроизвести композицию, название котрой выделено в списке procedure TForm1.Play; begin Label1.Caption := ListBox1.Items[ListBox1.ItemIndex]; MediaPlayer1.FileName := cDir + '' + ListBox1.Items[ListBox1.ItemIndex]; try MediaPlayer1.Open; except on EMCIDeviceError do begin ShowMessage('Ошибка обращения к файлу'); Exit; end; end; MediaPlayer1.Play; min := 0; sec := 0; Timer1.Enabled := True; SpeedButton1.Caption := 'Стоп'; end; procedure TForm1.FormCreate(Sender: TObject); begin GetDir(0,cDir); //каталог с программой PlayList(''); ListBox1.ItemIndex := 0; Label1.Caption := ListBox1.Items[ListBox1.ItemIndex]; end; //щелчок по названию песни procedure TForm1.ListBox1Click(Sender: TObject); begin Label1.Caption := ListBox1.Items[ListBox1.ItemIndex]; Play; end; //щелчок по кнопке Играть procedure TForm1.SpeedButton1Click(Sender: TObject); begin if SpeedButton1.Caption = 'Играть' then begin Play; SpeedButton1.Caption := 'Стоп'; end else begin SpeedButton1.Caption := 'Играть'; MediaPlayer1.Stop; Timer1.Enabled := False; end; end; //сигнал от таймера procedure TForm1.Timer1Timer(Sender: TObject); begin //изменить счетчик времени if sec < 59 then Inc(sec) else begin sec := 0; Inc(min); end; //вывести время воспроизведения Label2.Caption := IntToStr(min) + ':'; if sec < 10 then Label2.Caption := Label2.Caption + '0' + IntToStr(sec) else Label2.Caption := Label2.Caption + IntToStr(sec); //если воспроизведение текущей композиции не завершено if MediaPlayer1.Position < MediaPlayer1.Length then Exit; //воспроизведение текущей композиции закончено Timer1.Enabled := False; MediaPlayer1.Stop; if ListBox1.ItemIndex < ListBox1.Count - 1 then begin ListBox1.ItemIndex := ListBox1.ItemIndex + 1; Play; end; if (ListBox1.ItemIndex = ListBox1.Count - 1) and CheckBox1.Checked = True then begin ListBox1.ItemIndex := 0; Play; end; end; end.

Ответ отправил: Дима Гусаков (статус: 2-ой класс)
Ответ отправлен: 3 марта 2007, 09:23
Оценка за ответ: 5

Вопрос # 368

Приветствую!!!У меня MainMenu.На событие формы OnShow такой текст(работает). Нужно добавить строчек,чтоб при клике по соотв.элементу, форме передавался фокус.

Приложение:
NewItem:= TMenuItem.Create(Form1.N45); NewItem.Caption:=Caption; Form1.N45.Add(NewItem); Form1.N45.Find(Caption).RadioItem:=True;

Вопрос задал: KilkaMS (статус: Посетитель)
Вопрос отправлен: 03 марта 2007, 00:20 (эксперты)
Всего ответов: 1; сообщений в мини-форуме вопроса: 2

1. Отвечает эксперт: min@y™

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

Приложение:
type Form1 = class(TForm); .... protected procedure NewItemClick(Sender: TObject); end; implementation .... procedure TForm1.NewItemClick(Sender: TObject); begin if CanFocus then SetFocus; end; ........ NewItem:= TMenuItem.Create(Form1.N45); NewItem.Caption:=Caption; Form1.N45.Add(NewItem); Form1.N45.Find(Caption).RadioItem:=True; //============= NewItem.OnClick:= NewItemClick;

Ответ отправил: min@y™ (статус: Студент)
Ответ отправлен: 5 марта 2007, 08:37
Оценка за ответ: 5
Комментарий: Это вариант рабосий,но не красивый.Я надеялся еще что-нить узнать.Спасибо за потраченое время.

Вопрос # 369

Здравствуйте эксперты. Назовите, пожалуйста, свойство компонента TChart, которое позволит очистить поле для вывода нового изображения, Series1.Clear мне не подходит, т.к. это стирает линию. И ещё, задали вопрос, который я честно говоря даже не понял: Какими свойствами можно сделать методы компонента TChart активными и видимыми? Думаю, что вы знаете ответ на этот вопрос.

Вопрос задал: Полушин Сергей Анатольевич (статус: Посетитель)
Вопрос отправлен: 03 марта 2007, 20:35 (эксперты)
Всего ответов: 3; сообщений в мини-форуме вопроса: 3

1. Отвечает эксперт: Шарайчук Сергій Олександрович

Всмысле стирает линию, формиру вопросы чотче. Очистить поле опроуй так: Chart1.SeriesList.Series[0].Clear;

Ответ отправил: Шарайчук Сергій Олександрович (статус: 1-ый класс)
Ответ отправлен: 3 марта 2007, 20:52
Оценка за ответ: 3

2. Отвечает эксперт: Вадим К

По поводу второго вопроса телепаты мне подсказали, что это наверное свойства Visible, которое определяет видим/невидим и Enbled - активный/неактивный. Оба свойства буленовские, тоесть пользуемся типа так
Chart1.Visible:=True

Но также возможно, что это и не то. Если в вопросе подразумевалось создание компонент, то что бы свойства компонента были доступны в коде, они должны быть обявлены в секции public. А published раздел делает их ещё видимыми свойства в инспекторе объектов

Ответ отправил: Вадим К (статус: Кандидат наук)
Ответ отправлен: 3 марта 2007, 23:55
Оценка за ответ: 4

3. Отвечает эксперт: Новаковский Юрий Аврамович

Здравствуйте, Полушин Сергей Анатольевич!
Закрасьте канву цветом фона.

Chart1.Canvas.Brush.Color := clWhite;
Chart1.Canvas.FillRect(Rect(0,0,Chart1.Width,Chart1.Height);
Только исчезнет все и линии и оси и все другое.
Оно Вам надо?

Удачи!

Ответ отправил: Новаковский Юрий Аврамович (статус: 4-ый класс)
Ответ отправлен: 5 марта 2007, 12:19

Вопрос # 370

Есть форма, на которой TImage с иконкой 32bpp. Если фон формы сделать прозрачным, то 32-битная тень исчезнет. Как сделать, чтобы форма не отображалась, а изображение (с альфа каналом), которое на ней находится, было видно.

Вопрос задал: Иван-488 (статус: Посетитель)
Вопрос отправлен: 03 марта 2007, 21:35 (эксперты)
Всего ответов: 2; сообщений в мини-форуме вопроса: 4

1. Отвечает эксперт: Бубырь Александр Николаевич

Этот пример делает овальную форму, дальше думаю можно будет разобраться.

Приложение:
var FRgn,ERgn:HRGN; procedure TFormStart.FormCreate(Sender: TObject); begin FRgn:=CreateRectRgn(0,0,Width,Height); ERgn:=CreateEllipticRgn(-20,-45,Width+20,Height+45); CombineRgn(FRgn,FRgn,ERgn,RGN_AND); SetWindowRgn(Handle,FRgn,True); end; procedure TFormStart.FormDestroy(Sender: TObject); begin DeleteObject(FRgn); DeleteObject(ERgn); end;

Ответ отправил: Бубырь Александр Николаевич (статус: 6-ой класс)
Ответ отправлен: 4 марта 2007, 10:03

2. Отвечает эксперт: Роман

Здравствуйте, Иван!Вот вам примерчик.MaskBmp-альфаканал,белый цвет будет прозрачным,и соотверственно в этих местах форма будет прозрачной.

Application.CreateForm(TForm1, Form1);

class procedure MyShowForm;

with Create(Application) do
  try
    ShowModal;
  finally
    Free;
  end;

TAboutBox.MyShowForm;

public
  { Public declarations }
  class procedure MyShowForm(AProductName: string);
 ...
class procedure TAboutBox.MyShowForm(AProductName: string);
begin
  with Create(Application) do
  try
    ProductName.Caption := AProductName;
    ShowModal;
  finally
    Free;
  end;
end;

TAboutBox.MyShowForm('My program');

var
  LazyForm: TLazyForm;

function LazyForm: TLazyForm;

var privateForm:TLazyForm;
 
function LazyForm: TLazyForm;
begin
  if not Assigned (privateForm) then
    privateForm := TLazyForm.Create(Application);
  Result := privateForm;
end;

If ModalResult <> mrOk then Close;
If not (условие проверки правильности) then Action := caNone;

procedure TMainForm.btnCloseFormsClick(Sender: TObject);
var
  i: Integer;
begin
  for i := Screen.FormCount - 1 downto 0 do
  if Screen.Forms[i]<>Application.MainForm then
     Screen.Forms[i].Close;
end;