» Вопросы по Delphi (все версии) - часть 4

Aleksoid1978

Цитата:

Прикол такой - этот метод спокойно работает в ХП СП3, в 7 7127 ... но не пашет в Висте СП2. Почему такое - непонятно.

есть подозрение - маниакальный UAC у висты.

ShIvADeSt

Выключен и работаю под "настоящим" Админом

Aleksoid1978

Цитата:

Выключен и работаю под "настоящим" Админом

Попробуй под вистой вот такой код
SetThreadExecutionState(ES_CONTINUOUS | ES_SYSTEM_REQUIRED | ES_AWAYMODE_REQUIRED)

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

Что я неправильно делаю?

Aladdinych

Цитата:

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

Как ты думаешь - тут есть телепаты? Либо код, либо ошибка в 15 строке второго модуля.

Из основной формы:
Данные по хостам сидят в таблице RxMemoryData1
[more]

Код:
procedure Tmainform.FormActivate(Sender: TObject);
var
i,rc: integer;
ss: string;
ishape: TShape;
itrds: TProces;
begin
....

if RxMemoryData1.RecordCount>0 then
begin
listi:=TList.Create;
ltrds:=TList.Create;
RxMemoryData1.First;
lc:=RxMemoryData1.RecordCount;
for i:=0 to lc-1 do
begin

ishape:=TShape.Create(self);
with ishape do
begin
Parent:=mainform;
Width:=i20;
Height:=20t;
Left:=image1.Left+RxMemoryData1XPos.AsInteger;
Top:=image1.Top+RxMemoryData1YPos.AsInteger;
Brush.Color:=clRed;
Brush.Style:=bsSolid;
Shape:=stCircle;
end;
listi.Add(ishape);

itrds:=TProces.Create(false, i, RxMemoryData1IPAddress.AsString, timeout, ishape);
with itrds do
begin
FreeOnTerminate:=false;
Priority:=tpLower;
end;
ltrds.Add(itrds);
RxMemoryData1.Next;
end;
end;

end;



procedure Tmainform.FormClose(Sender: TObject; var Action: TCloseAction);
var
ishape: TShape;
itrds: TProces;
i: integer;
begin
for i:=0 to lc-1 do
begin
itrds:=TProces(ltrds[i]);
itrds.Terminate;
itrds.WaitFor;
ishape:=TShape(listi[i]);
ishape.Destroy;
itrds.Destroy;
end;
RxMemoryData1.Close;
if listi<>nil then
listi.Destroy;
if ltrds<>nil then
ltrds.Destroy;
end;

Теперь модуль uthreads

unit uthreads;

interface

uses
Classes, IdIcmpClient, IdComponent, extCtrls, QGraphics, sysutils, QForms;

type
TProces = class(TThread)
private
idx: integer;
ft: boolean;
fp: boolean;
prezult: TReplyStatusTypes;
icmp: TIdIcmpClient;
itimer: TTimer;
ind: TShape;
procedure ITimerTimer(Sender: TObject);
procedure IcmpReply(ASender: TComponent;
const AReplyStatus: TReplyStatus);
procedure showpings;
{ Private declarations }
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean; aidx: integer; host: string; timeout: integer; aind: TShape);
end;


implementation

uses main;

constructor TProces.Create(Createsuspended: boolean; aidx: integer; host: string; timeout: integer; aind: TShape);
begin
inherited Create(createsuspended);
idx:=aidx;
ft:=true;
fp:=true;
prezult:=rsTimeout;
ind:=aind;
itimer:=TTimer.Create(nil);
itimer.OnTimer:=ITimerTimer;
itimer.Enabled:=false;
itimer.Interval:=timeout+50;
icmp:=TIdIcmpClient.Create(nil);
icmp.OnReply:=IcmpReply;
icmp.ReceiveTimeout:=timeout;
icmp.Host:=host;
icmp.Port:=0;
icmp.Protocol:=1;
icmp.Tag:=aidx;
end;


procedure TProces.Execute;
begin
while not (Terminated or Application.Terminated) do
begin
itimer.Enabled:=true;
if ft and fp then
begin
ft:=false;
fp:=false;
icmp.Ping('',0);
end;
synchronize(showpings);
sleep(50);
end;
end;


procedure TProces.ITimerTimer(Sender: TObject);
begin
ft:=true;
end;

procedure TProces.IcmpReply(ASender: TComponent;
const AReplyStatus: TReplyStatus);
begin
prezult:=AReplyStatus.ReplyStatusType;
end;

procedure Tproces.showpings;
begin
if (prezult=rsEcho) then
ind.Brush.Color:=clLime
else
ind.Brush.Color:=clRed;
fp:=true;
end;

end.

Aladdinych

Цитата:

По количеству хостов создаю соответствующее количество потоков.

Ндас посмотрел твой код - бредовый мягко сказать. Тут надо вначале матчасть учить, а потом такие вещи писать. Первая ошибка из-за которой все грабли - у тебя создается много потоков, а переменная под них одна. Что там творится в памяти - хз. По хорошему надо массив из TProcess использовать. Тогда что то дельное будет возможно. Для начала кстати убери все TShape все пинги, просто заставь свои потоки что то делать правильно без ошибок (например каждый поток пусть считает какой нить ряд первый 1+1+1+1... второй 2+2+2+2+... третий 3+3+3+3...) - это нужно чтобы удостовериться, что потоки реально работают правильно. Как только этого добьешься - перейдем к пингам. Кстати - сделай отдельную тему или найди старую (уже была тема насчет пингов поищи только). Там и будем вести исследования. Так как тема все таки специфичная - не совсем типовая задача, что потоки, что пинги

ShIvADeSt
Хотел помочь RS85, но даже подуматьне мог, что он выложил код.
Я думал он фрагментом кода идею излагает. Видно у Вас огромный опыт телепатического общения. Искриний респект!

Народ, подскажите, а то сам чето догнать не могу :

Есть такая виндовая апишная функция : ChangeDisplaySettingsEx, вот ее описание :

function ChangeDisplaySettingsEx(lpszDeviceName: PWideChar; var lpDevMode: TDeviceMode; wnd: HWND; dwFlags: DWORD; lParam: Pointer): Longint; stdcall;

Вот например так она вызывается :

ChangeDisplaySettingsEx( PChar('\\.\DISPLAY2'), lDevMode, 0, CDS_UPDATEREGISTRY, 0);

все хорошо, все работает.

Но мне надо вызвать вот так, это пример из сишного кода :

ChangeDisplaySettingsEx(NULL, NULL, NULL, 0, NULL).

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

Кто че скажет по этому поводу ???

Aleksoid1978
Могу посоветовать только одно: обявите функцию еще раз, но таким образом:
Код: function ChangeDisplaySettingsEx(lpszDeviceName: PChar; lpDevMode: PDeviceMode;
wnd: HWND; dwFlags: DWORD; lParam: Pointer): Longint; stdcall;
external user32 name 'ChangeDisplaySettingsExA';

Aleksoid1978

Цитата:

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

гугль иногда юзаем вот что нашел, человек пишет что ему подошло


Код:
...
interface
...
{$EXTERNALSYM ChangeDisplaySettingsEx}
function ChangeDisplaySettingsEx(lpszDeviceName: PChar; lpDevMode: PDeviceMode; // <--
wnd: HWND; dwFlags: DWORD; lParam: Pointer): Longint; stdcall;
implementation
function ChangeDisplaySettingsEx; external user32 name 'ChangeDisplaySettingsExA';


ChangeDisplaySettingsEx('', PDeviceMode(nil)^, 0, 0, nil); // вызов

ShIvADeSt
Для етот вызов:
Код: ChangeDisplaySettingsEx('', PDeviceMode(nil)^, 0, 0, nil);

Mandor Sawall

Цитата:

Для етот вызов:
Код:
ChangeDisplaySettingsEx('', PDeviceMode(nil)^, 0, 0, nil);
не нужно преопределять функцию; все проходит и так.

скорее всего не надо, я просто нашел ответ в таком виде

Mandor Sawall

Да - все отлично работает и так,

Цитата:

ChangeDisplaySettingsEx('', PDeviceMode(nil)^, 0, 0, nil);

без переопределния. Но я раньше уже переопредил

Народ подскажите что небудь!

Delphi сервисы не запускаются, отлично работают в XP,но не работают в Win2003 Server.
В чем может быть причина? может кто встречался с таким?

P.S. Сервисы писал как созданием мастера, так и на чистом API...результат одинаковый...
компилировал 7 версией дельфи...

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

Подскажите, что-то туплю:
создаю тип
Код:
TTextFile = class(TObject)
...
FHandle: THandle;
...
public
constructor Create(const FileName:string);
...
implementation
constructor TTextFile.Create(const FileName:string);
begin
FHandle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,OPEN_ALWAYS, 0, 0);
..

YarGen
inherited?

стоп...
PrnName
а это что за порнуха?

akaGM

Цитата:

стоп...
PrnName
а это что за порнуха?

уже подправил
а про inherited подробнее?

YarGen
Гм...
ты свой первый класс создаёшь?

Код: constructor TTextFile.Create(filename: string);
begin
inherited; //краткая запись вызова конструктора родителя вместо TObject.Create;
какие-то действия...
...
end;

YarGen

Цитата:

а про inherited подробнее?

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

Код: Var
T2 = class(T1)

procedure T2.XXX(A, B: Integer);
begin
inherited;
***
end;

akaGM
просто inherited без указания метода не пропускает "Incompatible types" ,
inherited Create; не помогает.

YarGen
у TObject конструктор без параметров...
inherited Create; должно работать
ну напиши
TObject.Create;

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

давай кусок кода:
Код: TTextFile = class(TObject)
public
constructor Create(const FileName:string);
end;

implementation
constructor TTextFile.Create(const FileName:string);
begin
end;

YarGen
Все работает:

Код:
TTextFile = class(TObject)
private
FHandle: THandle;
public
constructor Create(const FileName:string);
end;

implementation

constructor TTextFile.Create(const FileName: string);
begin
inherited Create;
FHandle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil,OPEN_ALWAYS, 0, 0);
end;

YarGen
inherited в зависимости от набора/отсутсвия параметров может писатся так:
inherited;
или
inherited ИмяМетода;
или
inherited ИмяМетода(параметры);
или
Result := inherited...;
В двух словах все объяснили, но из уважения к окружающим можно было и пару абзацев умной книшки или спавочника почитать...

V1s1ter
с этим то понятно, этот код работает и без inherited ...
что-то в основном коде, буду копать дальше.
Всем спасибо, вопрос закрыт.

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

Я понимаю что сырая еще, но не на столько же - веть regedit отлично туда пишет.

P.S. - все вопрос снят, проблема была немного в другом.

CreateRemoteThread постоянное возникновение ошибки
Sorry, уже решена проблема

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

fcdobpiy, попробуй лочить компоненты
Edit->Locak Controls

Не у кого не возникло мыслей по поводу: как значку программы в Трее выставить свойство "Отображать" вместо по умолчанию "Скрывать неактивные"? Речь идёт о скрытии значков в Трее.