如何用Delphi设计内存优化程序(0分)

<<电脑商情报>>稿件
如何用Delphi设计内存优化程序
---兼谈程序设计分析
陈经韬

电脑启动一段时间后,因为运行了很多程序,整台电脑速度会越来越慢.为什么呢?原来很多程序运行的时候需要占用很多内存.即使程序退出后仍然无法完全释放的.那么如何找回丢失的内存呢?现在有很多这类程序,比如说<<Windows优化大师>>就带了一个<<Windows内存整理>>工具.我手头上的是V1.1版本.
程序设计会写代码很重要.程序设计思路更重要.程序设计分析别人的思路然后归自己所有更更重要.我希望通过这篇文章让大家掌握如何分析别人的思路,这样比单纯公布思路有价值的多.
先把话题扯远一点.木马冰河大家应该听说过吧.它的配置就很值得我们学习.一般这类软件的原理是这样的:客户端程序把信息写进服务端,服务端第一次运行的时候从自己身上读取出来保存到注册表或者INI文件里面.这样做的好处在于方便远程更新的时候直接修改注册表即可.这样做也有个致命BUG,就是别人用注册表监视器之类很容易就发现,这样一来别人就很容易知道接收者的信箱了.怎么办呢?冰河原来是采用把信息写进自己里面.但是自己怎么写进自己里面呢?我们分析一下就知道答案了.
首先,第一步先修改注册表:在HKEY_CURRENT_USER/Software/Microsoft/Windows/CurrentVersion/Policies/WinoldApp下新建一个双字节类型的键名为Disabled键值为1的新键,其作用是禁止运行DOS程序(包括批处理文件).当然你也可以用超级兔子之类的程序来修改.第二步:配置服务端种子，我们选择安装在<TEMP>目录下(原因:文件比<windows>、<system>下都要少)，把<TEMP>目录下尽量清空，以便于我们下一步分析。
第三步：运行服务端，用客户端成功连接后远程修改配置,系统会弹出一个窗口:本次操作受限制.第四步：打开<TEMP>目录，发现除了服务端文件外，多了两个文件：NewFile.exe和sysclr.bat。击右键查看属性可以看出NewFile.exe跟服务端文件大小一样，从而知道它是服务端的备份。打开sysclr.bat，内容如下:
@echo off
:loop
del c:/windows/TEMP/NewFile.exe
if exist c:/windows/TEMP/NewFile.exe goto loop
del %0
得出结论了吧原来它采用的方法是先把自己拷贝为一个备份,然后对备份文件进行配置,最后用备份覆盖自己.我曾经就此写过一个演示程序http://www.138soft.com/htm/selfmodif.exe.那么说这个跟本文有什么关系呢?呵呵,我们用上面的方法来跟踪分析一下<<Windows优化大师>>的内存优化程序是怎么编写的.
运行<<Windows内存整理>>,然后设置释放628KB内存碎片.点"整理",这时候打开进程管理器,发现系统启动了Wscript.exe程序.这个是Windows自身带的一个运行脚本的程序.当内存碎片整理完毕后,这个程序也随之退出了.我们再打开<TEMP>目录,重复上面步骤,发现整理内存的时候出现了一个memory.vbs文件.当内存碎片整理完毕后这个文件也消失了.我们用记事本打开它,内容如下:Mystring = Space(628000).把它拷贝到桌面然后运行它,效果跟运行<<Windows内存整理>>是一样的.
通过上面分析我们完全可以写出一个一模一样的程序来了.现在就动手吧!
运行Delphi,新建一个工程,往窗口放上两个Label,一个TrackBar1,一个Timer和一个Button.全部代码如下:
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, ComCtrls, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
TrackBar1: TTrackBar;
Label1: TLabel;
Label2: TLabel;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
procedure GetMemoryInfo;
function GetTempDir: string;
function CreateVbsFile(FileName:String;iKB:integer):boolean;
function WinExecAndWait32(FileName: string; Visibility: Integer): Boolean;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
function TForm1.WinExecAndWait32(FileName: string; Visibility: Integer): Boolean; //运行一个程序并等待其关闭
var
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
GetDir(0, WorkDir);
FillChar(StartupInfo, Sizeof(StartupInfo), #0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
PChar(FileName), { pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
True, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
PChar(WorkDir), { pointer to current directory name, PChar}
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) { pointer to PROCESS_INF }
then
Result := False {-1}
else
begin
Application.ProcessMessages;
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
CloseHandle(ProcessInfo.hProcess); { to prevent memory leaks }
CloseHandle(ProcessInfo.hThread);
Result := true;
end;
end;
function TForm1.GetTempDir: string;//取得临时目录的路径
var
Buffer: array[0..1023] of Char;
begin
SetString(Result, Buffer, GetTempPath(SizeOf(Buffer), Buffer));
end;
function TForm1.CreateVbsFile(FileName:String;iKB:integer):boolean;//创建一个VBS文件
var
MyList:TStringList;
begin
Result:=False;
if FileExists(FileName) then DeleteFile(FileName);
MyList:=TStringList.Create;
try
MyList.Clear;
MyList.Add('Mystring = Space('+IntToStr(iKB)+'000)');
MyList.SaveToFile(FileName);
finally
MyList.Free;
end;
Result:=True;
end;
procedure TForm1.GetMemoryInfo;//获取内存信息
var
MemStatus: TMEMORYSTATUS; //定义内存结构变量
All,CanUse:integer;
begin
MemStatus.dwLength :=sizeof(TMEMORYSTATUS);
GlobalMemoryStatus(MemStatus); //返回内存使用信息
All:=MemStatus.dwTotalPhys div 1024;
CanUse:=MemStatus.dwAvailPhys div 1024;
Label1.Caption :='共有内存:'+IntToStr(All)+'KB 可用内存:'+IntToStr(CanUse)+'KB'; //将内存信息显示出来
TrackBar1.Min:=1;
TrackBar1.Max:=All; //最大值赋给TrackBar1
end;
procedure TForm1.Button1Click(Sender: TObject);
var
StrFileName,StrCommand:String;
begin
StrFileName:=GetTempDir+'memory.vbs';
StrCommand:='Wscript.exe '+StrFileName;
if CreateVbsFile(StrFileName,TrackBar1.Position) then
if WinExecAndWait32(StrCommand,SW_HIDE) then
Application.MessageBox('整理内存碎片完毕!','Windows内存整理',MB_ICONINFORMATION+MB_OK)
else Application.MessageBox('创建线程失败!','Windows内存整理',MB_ICONERROR+MB_OK)
else Application.MessageBox('创建文件失败!','Windows内存整理',MB_ICONERROR+MB_OK);
if FileExists(StrFileName) then DeleteFile(StrFileName);
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Label2.Caption:='整理时释放'+IntToStr(TrackBar1.Position)+'KB的内存碎片';
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
GetMemoryInfo;//定时刷新
end;

end.
-----------------------------------------------------------------------------------------------------
★作者:

陈经韬

430074湖北省武汉市武昌民院路湖北经济管理大学计算机系(本)9801班
Home:http://lovejintao.126.com
E-Mail: Lovejingtao@21cn.com　
　

©CopyRight 2000-2003

收藏！谢谢！！

TO:jingtao
新年好。
上文内存优化，实质上是利用 Windows 系统本身的一个内存回收机制。其实不需要使
用 vbs 做一个中间脚本的吧。系统在没有内存请求的情况下，不对系统堆作清理和重排。
所以我认为，给 Windows 系统做内存优化，实际上只是提前对内存作一个堆清理，从本质
上并没有优化。真正的优化，应该是 Microsoft 的高速缓存清除机制和 Norton 的内存碎
片重排方法，不知道有没有这方面的资料。

up

这种整理不用也罢。

小雨哥:
新年好!
此文的确不是真正的方法.只不过在于说明如何分析别人的程序思路而已,
但不是说别人的就是最好的.对吗?
请看我的主页更新记录
2002年9月14日.<<如何用Delphi设计内存优化程序---兼谈程序设计分析>>配套代码.真正的内存碎片整理代码,不是我写的.还有我收集整理的Delphi教程.


(*
Memdefrag : Main unit for the memory defragmenter
Copyright (C) 2000 Yohanes Nugroho

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

Yohanes Nugroho (yohanes_n@hotmail.com)
Kp Areman RT 09/08 No 71
Ds Tugu Cimanggis
Bogor 16951
Indonesia


*)
unit memdefrag;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, Menus, ExtCtrls, StdCtrls, Registry, Defrag, Gauges,
shellapi;
const MyWM_NotifyIcon = $1982;

type
TForm1 = class(TForm)
MemBar: TProgressBar;
MemLevel: TTrackBar;
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
Option1: TMenuItem;
Memori1: TMenuItem;
Info1: TMenuItem;
Defrag1: TMenuItem;
Help1: TMenuItem;
About1: TMenuItem;
Timer1: TTimer;
LInfo: TLabel;
Button1: TButton;
Label1: TLabel;
LCPUStat: TLabel;
Label3: TLabel;
LMemInfo: TLabel;
Button2: TButton;
Pie: TGauge;
procedure Info1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure MemLevelChange(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Option1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
protected
procedure minimise(var msg: TMessage); message WM_SYSCOMMAND;
procedure TaskBarHandler(var msg: TMessage); message MyWM_NotifyIcon;
end;


var
Form1: TForm1;
Totalmem : longint; //total memory dalam satuan megabyte
Tr : TRegistry;
tnid : TNotifyIconData;
lastdefrag : longint;
isFirst : boolean;

implementation

uses info, option, about;

{$R *.DFM}

procedure TForm1.Info1Click(Sender: TObject);
begin
Form2.showmodal;
showwindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.minimise(var msg: TMessage);
begin
case msg.WParam of
SC_CLOSE : close;
SC_MINIMIZE :
begin
showwindow(Application.Handle, SW_HIDE);
showwindow(Form1.Handle, SW_HIDE);
end;
else
DefWindowProc(Form1.Handle, msg.msg, msg.WParam, msg.LParam);
end;
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.FormCreate(Sender: TObject);
var ms : TMemoryStatus;
trg : tregistry;
i : integer;
begin
LastDefrag:=GetTickCount;
tnid.cbSize := sizeof(TNotifyIconData);
tnid.Wnd := Form1.handle;
tnid.uID := $2111;
tnid.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
tnid.uCallbackMessage := MYWM_NOTIFYICON;
tnid.hIcon := Application.Icon.Handle;
Shell_NotifyIcon(NIM_ADD, @tnid);
ms.dwLength:=sizeof(ms);
GlobalMemoryStatus(ms);
TotalMem:=(ms.dwTotalPhys shr 20) + 1;
MemLevel.Max:=Totalmem;
MemBar.Max:=TotalMem*2;
Tr:=Tregistry.create;
tr.RootKey:=HKEY_DYN_DATA;
tr.OpenKey('PerfStats/StatData',false);
pie.Visible:=false;
trg:=tregistry.create;
with trg do
begin
RootKey:=HKEY_CURRENT_USER;
OpenKey(KeyName, true);
i:=ReadInteger('MemToFree');
if (i<MemLevel.Min) or (i>MemLevel.Max) then
begin
i:=MemLevel.Max shr 2;
WriteInteger('MemToFree', i);
end;
MemLevel.Position:=i;
closekey;
free;
end;
LInfo.Caption:=Format(
'Defragmen RAM sebanyak %d Mb', [MemLevel.Position]);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var ms : TMemoryStatus;
l : longint;
s:string;
begin
ms.dwLength:=sizeof(ms);
GlobalMemoryStatus(ms);
MemBar.Position:=ms.dwAvailPhys shr 19;
s:=Format('%d/%d',[ms.dwAvailPhys, ms.dwTotalPhys]);
LMemInfo.Caption:=s;

tr.ReadBinaryData('KERNEL/CPUUsage',l, sizeof(l));
LCPUStat.Caption:=Format('%d %%', [l]);
s:='Memori bebas/Total '+s;
lstrcpy(tnid.szTip, pchar(s));
Shell_NotifyIcon(NIM_Modify, @tnid);
if option.AutoDefrag then
begin
if (option.CPULimit=0) or (l<option.CPULimit) then
begin
if (GetTickCount-lastdefrag)<5000 then exit;
if (membar.position shr 1)<option.MemLimit then
begin
button2click(self);
LastDefrag:=GetTickCount;
end;
end;
end;

end;

procedure TForm1.MemLevelChange(Sender: TObject);
begin
LInfo.Caption:=Format(
'Defragmen RAM sebanyak %d Mb', [MemLevel.Position]);
end;

procedure idle;
begin
Application.processMessages;
Form1.Pie.progress:=Form1.Pie.progress+1;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
timer1.Enabled:=false;
Button2.Enabled:=false;
pie.Visible:=true;
pie.MaxValue:=memlevel.position*2;
Defragmem(memlevel.position,idle);
pie.Visible:=false;
Button2.Enabled:=true;
timer1.Enabled:=true;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Shell_NotifyIcon(NIM_DELETE, @tnid);
end;

procedure TForm1.Option1Click(Sender: TObject);
begin
Form3.ShowModal;
showwindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.About1Click(Sender: TObject);
begin
Form4.showmodal;
showwindow(Application.Handle, SW_HIDE);
end;


procedure Tform1.TaskBarHandler(var msg: TMessage);
begin
case msg.LParamLo of
WM_LBUTTONDOWN :
begin
if not IsWindowVisible(form1.handle)
then showWindow(form1.handle, sw_show);
end;
end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
showwindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
trg : tregistry;
begin
trg:=tregistry.create;
with trg do
begin
RootKey:=HKEY_CURRENT_USER;
OpenKey(KeyName, true);
WriteInteger('MemToFree',MemLevel.Position);
closekey;
free;
end;
tr.closeKey;
tr.Free;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
if IsFirst and option.MinOnLoad then
begin
hide;
IsFirst:=false;
end;
end;

begin
isFirst:=true;
end.

(*
DEFRAG.PAS : Unit used to defrag the Ms-Windows memory
Copyright (C) 2000 Yohanes Nugroho

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

Yohanes Nugroho (yohanes_n@hotmail.com)
Kp Areman RT 09/08 No 71
Ds Tugu Cimanggis
Bogor 16951
Indonesia


*)

unit defrag;

interface
uses Windows;
type proc = procedure;
var bussy : boolean;
//limit dalam satuan megabyte
procedure defragmem(limit : integer; x: proc);


implementation


procedure defragmem(limit : integer; x: proc);
var tab : array [0..1024] of pointer;
i : integer;
p : pointer;
lim : integer;
begin
if bussy then exit;
bussy:=true;
lim:=limit;
if lim>1024 then lim:=1024;
for i:=0 to lim do tab :=nil;
for i:=0 to lim-1 do
begin
p:=VirtualAlloc(nil, 1024*1024, MEM_COMMIT,
PAGE_READWRITE + PAGE_NOCACHE);
tab:=p;
asm
pushad
pushfd
mov edi, p
mov ecx, 1024*1024/4
xor eax, eax
cld
repz stosd
popfd
popad
end;
if assigned(x) then x;
end;
for i:=0 to lim-1 do
begin
VirtualFree(Tab, 0, MEM_RELEASE);
if assigned(x) then x;
end;
bussy:=false;
end;

begin
bussy:=false;
end.

这个才是真正的整理.

我手头有MemBoost的源码, 需要可以发邮件tseug@263.net

多谢，多谢！

接受答案了.