Форум: "Начинающим";
Текущий архив: 2007.05.13;
Скачать: [xml.tar.bz2];
Вниззатрата памяти Найти похожие ветки
← →
Romm © (2007-04-18 16:39) [0]Уважаемые мастера, написанная мной программа "висит" в памяти и ждет команды. Только вот на это ожидание затрачивается аж 3Мб памяти! О боже для такой-то цели 3Мб... Пожалуйста укажите на слабые места програмы...
Спасиб.
***********unit MainUnit;
interface
uses
Windows, Messages, ShellAPI, SysUtils, Graphics, Forms,
ExtCtrls, ScktComp, Classes;
type
TMainForm = class(TForm)
ServerSocket1: TServerSocket;
Timer1: TTimer;
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
private
public
Str:TMemoryStream;
end;
var
MainForm: TMainForm;
implementation
uses MessageUnit;
{$R *.dfm}
procedure TMainForm.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
Mes:String;
cr:TRect;
h:HWND;
hToken: THandle;
tkp: TTokenPrivileges;
ReturnLength: Cardinal;
begin
Mes:=Socket.ReceiveText;
if Mes="Sleep" then
ShellExecute(Application.Handle,Pchar("Open"),Pchar("rundll32.exe"),Pchar("powrp rof.dll,SetSuspendState"),"",0);//спящий режим
if Mes="Restart" then
ShellExecute(Application.Handle,Pchar("Open"),Pchar("shutdown"),Pchar("-r -t 0"),"",0);//перезагрузка
if Mes="Seance" then
ShellExecute(Application.Handle,Pchar("Open"),Pchar("rundll32.exe"),Pchar("user3 2.dll,LockWorkStation"),"",0);//завершение сеанса
if Copy(Mes,0,3)="Mes" then
begin
MessageForm.Show;
MessageForm.Memo1.Lines.Add("["+TimeToStr(now)+"] Администратор: "+Copy(Mes,4,Length(Mes)-1));
end;
if Mes="Block" then
begin
cr:=Rect(Screen.Width-1,Screen.Height-1,Screen.Width,Screen.Height);
ClipCursor(@cr);
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,1);//Выключение монитора
end;
if Mes="UnBlock" then
begin
cr:=Rect(0,0,Screen.Width,Screen.Height);
ClipCursor(@cr);
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,-1);//Включение монитора
end;
if Mes="Kill" then
begin
h:=GetForegroundWindow;
if h=0 then exit;
SendMessage(h,WM_DESTROY,0,0);
end;
if Mes="PowerOff" then
begin
if OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
LookupPrivilegeValue(nil, "SeShutdownPrivilege",tkp.Privileges[0].Luid);
tkp.PrivilegeCount:=1;
tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
if AdjustTokenPrivileges(hToken, False, tkp, 0, nil, ReturnLength)then
ExitWindowsEx(EWX_SHUTDOWN or EWX_POWEROFF, 0);
end;
end;
if Mes="Vidio" then
begin
Timer1.Enabled:=true;
end;
if Mes="NoVidio" then
begin
Timer1.Enabled:=false;
end;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
ServerSocket1.Active:=false;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
ServerSocket1.Active:=true;
end;
procedure TMainForm.FormPaint(Sender: TObject);
begin
ShowWindow(Application.Handle,SW_HIDE);
ShowWindow(Handle,SW_HIDE);
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
var
DeskTopDC: HDc;
DeskTopCanvas: TCanvas;
DeskTopRect: TRect;
Bitmap:TBitmap;
Size:int64;
begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
Bitmap:=TBitmap.Create;
Bitmap.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);
Str:=TMemoryStream.Create;
Str.Write(Bitmap,sizeof(Bitmap));
Size:=Str.Size;
ServerSocket1.Socket.Connections[0].SendBuf(Size,sizeof(Size));
ServerSocket1.Socket.Connections[0].SendStream(str);
ReleaseDC(GetDeskTopWindow, DeskTopDC);
Bitmap.Free;
DeskTopCanvas.Free;
end;
procedure TMainForm.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Timer1.Enabled:=false;
end;
end.
**********
unit MessageUnit;
interface
uses
Forms, StdCtrls, Classes, Controls;
type
TMessageForm = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MessageForm: TMessageForm;
implementation
{$R *.dfm}
procedure TMessageForm.Button1Click(Sender: TObject);
begin
Close;
end;
end.
← →
Сергей М. © (2007-04-18 16:41) [1]
> для такой-то цели 3Мб
Ну а, будь ты ОС, - сколько б ей "дал" ?)
← →
{RASkov} (2007-04-18 16:43) [2]> [0] Romm © (18.04.07 16:39)
> uses
> Windows, Messages, ShellAPI, SysUtils, Graphics, Forms,
> ExtCtrls, ScktComp, Classes;
А ты и вот это посчитай, и то что в uses у них..., UserGDI... иже ниже...
← →
Romm © (2007-04-18 16:46) [3]
> Сергей М. © (18.04.07 16:41) [1]
> {RASkov} (18.04.07 16:43) [2]
значит не получится из моей проги маленького и незаметного сервера.. :))
Ну а по оптимизации что можно сделать получше? :)
Вот мне это IF не нравятся жутко.. Можно что-нибудь вроде case .. do сделать?
← →
Сергей М. © (2007-04-18 16:50) [4]
> значит не получится из моей проги маленького и незаметного
> сервера
Да уж)
До кулхацкера тебе еще пока как до китая раком)
← →
Romm © (2007-04-18 16:54) [5]
> Сергей М. © (18.04.07 16:50) [4]
во во.. :)) поэтому прошу совета у тех кому как до магазина... :)
← →
Сергей М. © (2007-04-18 16:58) [6]
> Romm © (18.04.07 16:54) [5]
>
>
> у тех кому как до магазина.
Ну а нам, которым до магазина, не понятны твои треволнения по поводу трех задрипаных мегабайт)
Таки не соизволишь ли прокомментировать, чем тебя эти мегабайты взволновали ?)
← →
Desdechado © (2007-04-18 17:01) [7]Чем память измеряешь?
А то ведь диспетчер показывает все, что твоя программа подгрузила (например, системные DLL, даже если не только она и не полностью).
← →
Сергей М. © (2007-04-18 17:01) [8]
> Romm © (18.04.07 16:54) [5]
И давай уже ответь на [1], коль истины жаждешь)...
← →
Romm © (2007-04-18 17:03) [9]ну просто я думал это много для проги, которая ничего не делает :)
А по оптимизации вы, которым до магазина, не подскажите по оптимизации что-нибудь новенького?? :)
Кстати,program Server;
uses
Forms,
Windows,
MainUnit in "MainUnit.pas" {MainForm},
MessageUnit in "MessageUnit.pas" {MessageForm};
{$R *.res}
var
WhEvent:THandle;
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.CreateForm(TMessageForm, MessageForm);
Application.Run;
WhEvent:=CreateEvent(nil,true,false,"et");
while (true) do
begin
WaitForSingleObject(WhEvent,1000);
Application.ProcessMessages
end;
end.
тут я правильно поступил?? Или, нафиг, оставить как дядя Борланд написал?
← →
Сергей М. © (2007-04-18 17:07) [10]
> Romm © (18.04.07 17:03) [9]
> проги, которая ничего не делает
Как это "ничего не делает" ?!
А все что между begin и end программы - это разве "ничегонеделанье" ?!!!
← →
Сергей М. © (2007-04-18 17:12) [11]
> Romm © (18.04.07 17:03) [9]
Я прямо-таки боюсь тебе намекнуть на страшную тайну -
"прога", текст которой имеет видprogram Proga;
begin
end;
тоже, казалось бы, "ничего не делает", но тем не менее занимает несколько десятков дурацких килобайт).. С чего бы это ?)
← →
Romm © (2007-04-18 17:17) [12]
> Сергей М. © (18.04.07 17:12) [11]
Рррр.. ну это ясно, ну да ладно, пусть злой сервер живет как живет.
жду совета по оптимизации :)))
> Desdechado © (18.04.07 17:01) [7]
им и измеряю :))
> Сергей М. © (18.04.07 16:41) [1]
будь я ОС... ну скажем 1500 Кб максимум :)
← →
Плохиш © (2007-04-18 17:28) [13]
> Application.Run;
> WhEvent:=CreateEvent(nil,true,false,"et");
> while (true) do
> begin
> WaitForSingleObject(WhEvent,1000);
> Application.ProcessMessages
> end;
А это чего за херня?
← →
Romm © (2007-04-18 17:32) [14]
> Плохиш © (18.04.07 17:28) [13]
:))
пустое событие. благодаря ему компутер с работающим сервером не ощутит нагрузки... В умной книжке прочитал :))
← →
Romm © (2007-04-18 17:34) [15]
> procedure TMainForm.FormPaint(Sender: TObject);
> begin
> ShowWindow(Application.Handle,SW_HIDE);
> ShowWindow(Handle,SW_HIDE);
> end;
кстати вот так прячу, а она (форма) мигает, когда прячется... как обойти такую подлянку? :)
← →
Плохиш © (2007-04-18 17:47) [16]
> Romm © (18.04.07 17:32) [14]
В следующий раз читай книжку глазами с включённым мозгом. Этот код у тебя ни на какую загрузку не влияет, так как он во время работы программы не выполняется.
← →
Romm © (2007-04-18 17:54) [17]
> Плохиш © (18.04.07 17:47) [16]
ок :))
Мастера, неужели у меня прога грамотно написана!
Покритикуйте основной код немножко :)
← →
Loginov Dmitry © (2007-04-18 18:02) [18]> пустое событие. благодаря ему компутер с работающим сервером
> не ощутит нагрузки... В умной книжке прочитал :))
а про такую "фичу"
WhEvent:=CreateEvent(nil,true,false,"et");
while (true) do
begin
WaitForSingleObject(WhEvent,1000);
Application.ProcessMessages
end;
где прочел?
← →
Romm © (2007-04-18 18:04) [19]
> Loginov Dmitry © (18.04.07 18:02) [18]
там же :) Ну это задержка 1 секунда
ну да ладно, этого гадкого кода в моей проге больше нету.. :))
← →
{RASkov} (2007-04-18 18:07) [20]> var
> DeskTopDC: HDc;
> DeskTopCanvas: TCanvas;
> DeskTopRect: TRect;
> Bitmap:TBitmap;
Вот это вот все изprocedure TMainForm.Timer1Timer(Sender: TObject);
не обязательно каждый раз создавать/убивать/высчитыать.....
← →
Romm © (2007-04-18 18:14) [21]а как же?..
не убивать и создавать каждый раз еще понятно, а высчитывать.. мне же "анимацию" рабочего стола нужно..
← →
{RASkov} (2007-04-18 18:25) [22]> , а высчитывать.. мне же "анимацию" рабочего стола нужно..
>DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
Собственно это было про DeskTopRect: TRect; что не так страшно.... но тоже можно заранее определить этот Rect и при смене разрешения переопределить его и размеры битмапа(Bitmap:TBitmap), кстати у тебя они не выставляются.....!
← →
{RASkov} (2007-04-18 18:27) [23]> кстати у тебя они не выставляются.....!
> Bitmap:=TBitmap.Create;
> Bitmap.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);
В итоге мы в Bitmap ничего нихрена не имеем....
← →
Romm © (2007-04-18 18:27) [24]
> размеры битмапа
нужно? щас сделаю... а нужно делать Bitmap.FreeImage?
← →
Romm © (2007-04-18 18:31) [25]
if not Create then
begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
Bitmap:=TBitmap.Create;
Bitmap.Width:=Screen.Width;
Bitmap.Height:=Screen.Height;
Str:=TMemoryStream.Create;
Create:=true;
end
else
begin
Bitmap.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);
Str.Write(Bitmap,sizeof(Bitmap));
Size:=Str.Size;
ServerSocket1.Socket.Connections[0].SendBuf(Size,sizeof(Size));
ServerSocket1.Socket.Connections[0].SendStream(str);
ReleaseDC(GetDeskTopWindow, DeskTopDC);
end;
так пойдет?
Bitmap.Free
DeskTopCanvas.Free делаю вместе с Timer1.Enable:=false;
← →
{RASkov} (2007-04-18 18:39) [26]> а нужно делать Bitmap.FreeImage?
а для чего ты это задумал?
> так пойдет?
Судя по твоим вопросам, и того куска кода что привел в [25] - ничего тебе не скажу.... не то что не хочу, а незнаю... что ты там наменял в твоем супер незаметном сервере.
> if not Create then
А вот это плохо, Ты что, булевую переменную назвал Create? Исправь... запутаешься.
← →
Romm © (2007-04-18 18:46) [27]
> а для чего ты это задумал?
просто метод увидел, решил спросить..
> что ты там наменял в твоем супер незаметном сервере
:) теперь так(только измененный кусок) :)procedure TMainForm.FormCreate(Sender: TObject);
begin
ServerSocket1.Active:=true;
Create:=false;
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
var
DeskTopDC: HDc;
DeskTopRect: TRect;
Size:int64;
begin
if not Create then
begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
Bitmap:=TBitmap.Create;
Bitmap.Width:=Screen.Width;
Bitmap.Height:=Screen.Height;
Str:=TMemoryStream.Create;
Create:=true;
end
else
begin
Bitmap.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);
Str.Write(Bitmap,sizeof(Bitmap));
Size:=Str.Size;
ServerSocket1.Socket.Connections[0].SendBuf(Size,sizeof(Size));
ServerSocket1.Socket.Connections[0].SendStream(str);
ReleaseDC(GetDeskTopWindow, DeskTopDC);
end;
end;
procedure TMainForm.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Timer1.Enabled:=false;
Create:=false;
Bitmap.Free;
DeskTopCanvas.Free;
end;
ну и
program Server;
uses
Forms,
Windows,
MainUnit in "MainUnit.pas" {MainForm},
MessageUnit in "MessageUnit.pas" {MessageForm};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.CreateForm(TMessageForm, MessageForm);
Application.Run;
end.
← →
{RASkov} (2007-04-18 19:18) [28]Плохо все еще пока.... давай дальше думай... Вот например:
type TMyDesk = record
DeskTopDC: HDc;
BitMap: TBitmap;
DeskTopRect: TRect;
IsCreate: Boolean;
end;
var MyDesk: TMyDesk;
procedure CreateMyDesk;
procedure ReSizeMyDest;
procedure FreeMyDesk;
.............
procedure TMainForm.Timer1Timer(Sender: TObject);
var Size:int64;
begin
if not MyDesk.IsCreate then CreateMyDesk;
MyDesk.Bitmap.Canvas.CopyRect(MyDesk.DeskTopRect, MyDesk.DeskTopCanvas, MyDesk.DeskTopRect);
Str.Write(MyDesk.Bitmap,sizeof(MyDesk.Bitmap));
Size:=Str.Size;
ServerSocket1.Socket.Connections[0].SendBuf(Size,sizeof(Size));
ServerSocket1.Socket.Connections[0].SendStream(str);
end;
Ну и гденить в начале MyDesk.IsCreate:=False;, а в CreateMyDesk; в последнюю очередь вызвать ReSizeMyDest;. И ReSizeMyDest вызывать при необходимости....
Думай.... может даже лучше свой класс вместо рекорда сделать....
> а нужно делать Bitmap.FreeImage?
Нет, не нужно.... почитай в хелпе для чего это, но это не удаление рисунка...
← →
{RASkov} (2007-04-18 19:20) [29]> Ну и гденить в начале MyDesk.IsCreate:=False;, а в CreateMyDesk;
Не забудь только после создания в CreateMyDesk выставить MyDesk.IsCreate:=True; ;)
← →
{RASkov} (2007-04-18 19:23) [30]> MyDesk.Bitmap.Canvas.CopyRect(MyDesk.DeskTopRect, MyDesk.DeskTopCanvas, MyDesk.DeskTopRect);
Замени на BitBlt
← →
Romm © (2007-04-18 19:38) [31]
> {RASkov} (18.04.07 19:18) [28]
спасибо
> {RASkov} (18.04.07 19:20) [29]
ок :)
> Замени на BitBlt
как? :))
← →
Romm © (2007-04-18 19:42) [32]
Size:=Str.Size;
когда таймер срабатывает второй раз - тут ошибка, первый нормально. Когда не указывал размеры bitmap"ки - не було такого
← →
Romm © (2007-04-18 19:43) [33]было* :)
← →
{RASkov} (2007-04-18 19:53) [34]> > Замени на BitBlt
> как? :))
Типа так:BitBlt(MyDesk.Bitmap.Canvas.Handle, 0, 0, MyDesk.Bitmap.Width, MyDesk.Bitmap.Height, MyDesk.DeskTopDC, 0, 0, SRCCOPY);
Ты сам когда начнешь думать?
← →
{RASkov} (2007-04-18 19:56) [35]> Size:=Str.Size; когда таймер срабатывает второй раз - тут
> ошибка, первый нормально. Когда не указывал размеры bitmap"ки
> - не було такого
Начни свой супер сервер с нуля делать... понаворатил там небось уже, сам запутался и других путаешь... Благо кода три с половиной строчки.
← →
Romm © (2007-04-18 20:04) [36]
> Начни свой супер сервер с нуля делать
времени нетуу :((
я же ЧеПятал весь код. Ну что там такого сверхЪестейственного?.. :)
← →
{RASkov} (2007-04-18 20:09) [37]> времени нетуу :((
Если хочешь сделать нормальную прогу - найдешь время, ибо на поиски глюков в глюкавом коде время нужно не меньше.....
← →
Romm © (2007-04-18 20:20) [38]
> {RASkov} (18.04.07 20:09) [37]
я сомневаюсь, что с нуля напишу по другому...
А ошибка тем временем говорит:
Project Server.exe raised exception class EAccessViolation with message "Access violation at address 00000000. Read of adress 00000000". Process stopped. Use Step or Run to continue.
перевидите на русский, люди добрые.
← →
Romm © (2007-04-18 20:25) [39]Еще раз код покажу - я не вижу ошибки...
unit MainUnit;
interface
uses
Windows, Messages, ShellAPI, SysUtils, Graphics, Forms,
ExtCtrls, ScktComp, Classes;
type
TMyDesk=record
Bitmap:TBitmap;
IsCreate:Boolean;
DeskTopRect:TRect;
DeskTopDc:HDc;
end;
TMainForm = class(TForm)
ServerSocket1: TServerSocket;
Timer1: TTimer;
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
private
procedure CreateMyDesk;
procedure FreeMyDesk;
procedure ReSizeMyDesk;
public
Str:TMemoryStream;
end;
var
MainForm: TMainForm;
MyDesk:TMyDesk;
implementation
uses MessageUnit;
{$R *.dfm}
procedure TMainForm.ReSizeMyDesk;
begin
MyDesk.Bitmap.Width:=Screen.Width;
MyDesk.Bitmap.Height:=Screen.Height;
end;
procedure TMainForm.FreeMyDesk;
begin
MyDesk.Bitmap.Free;
Str.Free;
end;
procedure TMainForm.CreateMyDesk;
begin
MyDesk.DeskTopDc := GetWindowDC(GetDeskTopWindow);
MyDesk.DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
MyDesk.Bitmap:=TBitmap.Create;
Str:=TMemoryStream.Create;
MyDesk.IsCreate:=true;
ReSizeMyDesk;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
ServerSocket1.Active:=false;
FreeMyDesk;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
ServerSocket1.Active:=true;
MyDesk.IsCreate:=false;
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
var
Size:int64;
begin
if not MyDesk.IsCreate then
CreateMyDesk
else
begin
BitBlt(MyDesk.Bitmap.Canvas.Handle, 0, 0, MyDesk.Bitmap.Width, MyDesk.Bitmap.Height, MyDesk.DeskTopDC, 0, 0, SRCCOPY);
Str.Write(MyDesk.Bitmap,sizeof(MyDesk.Bitmap));
Size:=Str.Size;//на второй раз тут ошибка (выше написал)
ServerSocket1.Socket.Connections[0].SendBuf(Size,sizeof(Size));
ServerSocket1.Socket.Connections[0].SendStream(str);
ReleaseDC(GetDeskTopWindow, MyDesk.DeskTopDC);
end;
end;
procedure TMainForm.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Timer1.Enabled:=false;
MyDesk.IsCreate:=false;
FreeMyDesk;
end;
end.
← →
Leonid Troyanovsky © (2007-04-18 20:26) [40]
> Romm © (18.04.07 20:20) [38]
> перевидите на русский, люди добрые.
Используй шаг (можно бегом) для продолжения.
Путь длиной в 5000 миль начинается с первого шага.
Да достигнем мы все Дао.
--
Regards, LVT.
Страницы: 1 2 вся ветка
Форум: "Начинающим";
Текущий архив: 2007.05.13;
Скачать: [xml.tar.bz2];
Память: 0.58 MB
Время: 0.043 c