unit1.pas

整理内存碎片程序,介绍获取内存信息等操作

unit Unit1;

interface

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

type
  TForm1 = class(TForm)

    Label1: TLabel;
    Button1: TButton;
    Timer1: TTimer;
    TrackBar1: TTrackBar;
    procedure Button1Click(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.Timer1Timer(Sender: TObject);
begin
  GetMemoryInfo; //定时刷新
end;

end.