| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

затрата памяти

Страницы:   < 1 2 3 >

Romm ©   (2007-04-18 16:39:00) 

Уважаемые мастера, написанная мной программа "висит" в памяти и ждет команды. Только вот на это ожидание затрачивается аж 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.

---

Romm   (2007-04-18 20:25:00) [21]

Еще раз код покажу - я не вижу ошибки...

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.

---

Romm   (2007-04-18 20:20:00) [22]

> {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.
перевидите на русский, люди добрые.

---

{RASkov}   (2007-04-18 20:09:00) [23]

> времени нетуу :((

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

---

Romm   (2007-04-18 20:04:00) [24]

> Начни свой супер сервер с нуля делать

времени нетуу :((
я же ЧеПятал весь код. Ну что там такого сверхЪестейственного?.. :)

---

{RASkov}   (2007-04-18 19:56:00) [25]

> Size:=Str.Size; когда таймер срабатывает второй раз - тут
> ошибка, первый нормально. Когда не указывал размеры bitmap'ки
> - не було такого

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

---

{RASkov}   (2007-04-18 19:53:00) [26]

> > Замени на BitBlt
> как? :))

Типа так:
BitBlt(MyDesk.Bitmap.Canvas.Handle, 0, 0, MyDesk.Bitmap.Width, MyDesk.Bitmap.Height, MyDesk.DeskTopDC, 0, 0, SRCCOPY);
Ты сам когда начнешь думать?

---

Romm   (2007-04-18 19:43:00) [27]

было* :)

---

Romm   (2007-04-18 19:42:00) [28]

Size:=Str.Size;когда таймер срабатывает второй раз - тут ошибка, первый нормально. Когда не указывал размеры bitmap'ки - не було такого

---

Romm   (2007-04-18 19:38:00) [29]

> {RASkov}   (18.04.07 19:18) [28]

спасибо


> {RASkov}   (18.04.07 19:20) [29]

ок :)


> Замени на BitBlt

как? :))

---

{RASkov}   (2007-04-18 19:23:00) [30]

> MyDesk.Bitmap.Canvas. CopyRect(MyDesk.DeskTopRect, MyDesk.DeskTopCanvas, MyDesk.DeskTopRect);

Замени на BitBlt

---

{RASkov}   (2007-04-18 19:20:00) [31]

> Ну и гденить в начале MyDesk.IsCreate:=False;, а в CreateMyDesk;

Не забудь только после создания в CreateMyDesk выставить MyDesk.IsCreate:=True; ;)

---

{RASkov}   (2007-04-18 19:18:00) [32]

Плохо все еще пока.... давай дальше думай... Вот например:
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?

Нет, не нужно.... почитай в хелпе для чего это, но это не удаление рисунка...

---

Romm   (2007-04-18 18:46:00) [33]

> а для чего ты это задумал?

просто метод увидел, решил спросить..


> что ты там наменял в твоем супер незаметном сервере

:) теперь так(только измененный кусок) :)

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 18:39:00) [34]

> а нужно делать Bitmap.FreeImage?

а для чего ты это задумал?

> так пойдет?

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

> if not Createthen

А вот это плохо, Ты что, булевую переменную назвал Create? Исправь... запутаешься.

---

Romm   (2007-04-18 18:31:00) [35]

 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;

---

Romm   (2007-04-18 18:27:00) [36]

>  размеры битмапа

нужно? щас сделаю... а нужно делать Bitmap.FreeImage?

---

{RASkov}   (2007-04-18 18:27:00) [37]

> кстати у тебя они не выставляются.....!

> Bitmap:=TBitmap.Create;
> Bitmap.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);

В итоге мы в Bitmap ничего нихрена не имеем....

---

{RASkov}   (2007-04-18 18:25:00) [38]

> , а высчитывать.. мне же "анимацию" рабочего стола нужно..

> DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);

Собственно это было про DeskTopRect: TRect; что не так страшно.... но тоже можно заранее определить этот Rect и при смене разрешения переопределить его и размеры битмапа(Bitmap:TBitmap), кстати у тебя они не выставляются.....!

---

Romm   (2007-04-18 18:14:00) [39]

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

---

{RASkov}   (2007-04-18 18:07:00) [40]

> var
> DeskTopDC: HDc;
> DeskTopCanvas: TCanvas;
> DeskTopRect: TRect;
> Bitmap:TBitmap;

Вот это вот все из procedure TMainForm.Timer1Timer(Sender: TObject);
не обязательно каждый раз создавать/убивать/высчитыать.....

---

Страницы:   < 1 2 3 >

Наверх