unit Unit1;
interface
uses
Windows,
Forms,
Classes,
SysUtils,
Controls,
StdCtrls,
ActiveX,
ComLib,
OleCtrls,
ComObj,
MSScriptControl_TLB,
ShellAPI;
const
MIN_EVENT = 100;
{$EXTERNALSYM MIN_EVENT}
BEGIN_SYSTEM_CHANGE = 100;
{$EXTERNALSYM BEGIN_SYSTEM_CHANGE}
END_SYSTEM_CHANGE = 101;
{$EXTERNALSYM END_SYSTEM_CHANGE}
BEGIN_NESTED_SYSTEM_CHANGE = 102;
// for Whistler only - use this to prevent nested restore pts
{$EXTERNALSYM BEGIN_NESTED_SYSTEM_CHANGE}
END_NESTED_SYSTEM_CHANGE = 103;
// for Whistler only - use this to prevent nested restore pts
{$EXTERNALSYM END_NESTED_SYSTEM_CHANGE}
MAX_EVENT = 103;
{$EXTERNALSYM MAX_EVENT}
//
// Type of Restore Points
//
MIN_RPT = 0;
{$EXTERNALSYM MIN_RPT}
APPLICATION_INSTALL = 0;
{$EXTERNALSYM APPLICATION_INSTALL}
APPLICATION_UNINSTALL = 1;
{$EXTERNALSYM APPLICATION_UNINSTALL}
DESKTOP_SETTING = 2;
// Not implemented
{$EXTERNALSYM DESKTOP_SETTING}
ACCESSIBILITY_SETTING = 3;
// Not implemented
{$EXTERNALSYM ACCESSIBILITY_SETTING}
OE_SETTING = 4;
// Not implemented
{$EXTERNALSYM OE_SETTING}
APPLICATION_RUN = 5;
// Not implemented
{$EXTERNALSYM APPLICATION_RUN}
RESTORE = 6;
{$EXTERNALSYM RESTORE}
CHECKPOINT = 7;
{$EXTERNALSYM CHECKPOINT}
WINDOWS_SHUTDOWN = 8;
// Not implemented
{$EXTERNALSYM WINDOWS_SHUTDOWN}
WINDOWS_BOOT = 9;
// Not implemented
{$EXTERNALSYM WINDOWS_BOOT}
DEVICE_DRIVER_INSTALL = 10;
{$EXTERNALSYM DEVICE_DRIVER_INSTALL}
FIRSTRUN = 11;
{$EXTERNALSYM FIRSTRUN}
MODIFY_SETTINGS = 12;
{$EXTERNALSYM MODIFY_SETTINGS}
CANCELLED_OPERATION = 13;
// Only valid for END_SYSTEM_CHANGE
{$EXTERNALSYM CANCELLED_OPERATION}
BACKUP_RECOVERY = 14;
{$EXTERNALSYM BACKUP_RECOVERY}
MAX_RPT = 14;
{$EXTERNALSYM MAX_RPT}
MAX_DESC = 64;
{$EXTERNALSYM MAX_DESC}
MAX_DESC_W = 256;
// longer for Whistler
type
TForm1 =
class(TForm)
Button1: TButton;
Button2: TButton;
Memo1: TMemo;
Button3: TButton;
ScriptControl1: TScriptControl;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure log(s:
string);
function CreateRestorePointVB(sName:
string):boolean;
function CreateRestorePointSR(s:
string): boolean;
function CreateRestorePointOLE(s:
string): boolean;
end;
function ChangeFSRedirection(bDisable: Boolean): Boolean;
type
// Restore point information
PRESTOREPTINFOA = ^_RESTOREPTINFOA;
_RESTOREPTINFOA =
packed record
dwEventType: DWORD;
// Type of Event - Begin or End
dwRestorePtType: DWORD;
// Type of Restore Point - App install/uninstall
llSequenceNumber: INT64;
// Sequence Number - 0 for begin
szDescription:
array [0..MAX_DESC]
of CHAR;
// Description - Name of Application / Operation
end;
RESTOREPOINTINFO = _RESTOREPTINFOA;
PRESTOREPOINTINFOA = ^_RESTOREPTINFOA;
// Status returned by System Restore
PSMGRSTATUS = ^_SMGRSTATUS;
_SMGRSTATUS =
packed record
nStatus: DWORD;
// Status returned by State Manager Process
llSequenceNumber: INT64;
// Sequence Number for the restore point
end;
STATEMGRSTATUS = _SMGRSTATUS;
PSTATEMGRSTATUS = ^_SMGRSTATUS;
TSetRestorePoint =
Function(pRestorePtSpec: PRESTOREPOINTINFOA; pSMgrStatus: PSTATEMGRSTATUS): Bool;
stdcall;
var
hSrClientDLL : THandle;
FSetRestorePoint : TSetRestorePoint;
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.log(s:
string);
begin
Memo1.Lines.Add(s);
end;
function ChangeFSRedirection(bDisable: Boolean): Boolean;
type
TWow64DisableWow64FsRedirection =
Function(
Var Wow64FsEnableRedirection: LongBool): LongBool;
StdCall;
TWow64EnableWow64FsRedirection =
Function(
var Wow64FsEnableRedirection: LongBool): LongBool;
StdCall;
var
hHandle: THandle;
Wow64DisableWow64FsRedirection: TWow64DisableWow64FsRedirection;
Wow64EnableWow64FsRedirection: TWow64EnableWow64FsRedirection;
Wow64FsEnableRedirection: LongBool;
begin
Result := false;
try
hHandle := GetModuleHandle('
kernel32.dll');
@Wow64EnableWow64FsRedirection := GetProcAddress(hHandle, '
Wow64EnableWow64FsRedirection');
@Wow64DisableWow64FsRedirection := GetProcAddress(hHandle, '
Wow64DisableWow64FsRedirection');
if bDisable
then
begin
if (hHandle <> 0)
and (@Wow64DisableWow64FsRedirection <>
nil)
then
begin
Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);
Result := True;
end;
end else
begin
if (hHandle <> 0)
and (@Wow64EnableWow64FsRedirection <>
nil)
then
begin
Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);
Result := True;
end;
end;
Except
end;
end;
function TForm1.CreateRestorePointVB(sName:
string):boolean;
var
sr: OLEVAriant;
sSystemRestoreStatus:
string;
begin
Result := False;
sSystemRestoreStatus := '
System Restore status: not available';
try
ScriptControl1.Language := '
VBScript';
sr := ScriptControl1.Eval('
getobject("winmgmts:\\.\root\default:Systemrestore")');
if sr.CreateRestorePoint(sName, 0, 100) = 0
then
begin
log('
CreateRestorePointVB SUCCESS');
Result := True;
log('
New Restore Point successfully created my method 2');
end else
begin
log('
CreateRestorePointVB FAILURE')
end;
except
on e:
exception do
begin
log('
CreateRestorePointVB EXCEPT');
log(e.
Message);
Exit;
end;
end;
end;
function TForm1.CreateRestorePointOLE(s:
string): boolean;
const
WbemUser = '
';
WbemPassword = '
';
WbemComputer = '
localhost';
var
RestorePtSpec: RESTOREPOINTINFO;
SMgrStatus: STATEMGRSTATUS;
r: Integer;
FSWbemLocator: OLEVariant;
FWMIService: OLEVariant;
FWbemObjectSet: OLEVariant;
begin
Result := False;
try
FSWbemLocator := CreateOleObject('
WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer(WbemComputer, '
root\DEFAULT', WbemUser, WbemPassword);
FWbemObjectSet := FWMIService.Get('
SystemRestore');
r := FWbemObjectSet.CreateRestorePoint(s, APPLICATION_INSTALL, BEGIN_SYSTEM_CHANGE);
if r = 0
then
begin
log('
New Restore Point successfully created.');
Result := True;
end else
log( '
Error: ' + IntToStr(r));
except
on E: EOleException
do
log(Format('
EOleException %s %x', [E.
Message, E.ErrorCode]));
on E:
Exception do
log(E.Classname + '
: ' + E.
Message);
end;
end;
function TForm1.CreateRestorePointSR(s:
string): boolean;
var
RestorePtSpec: RESTOREPOINTINFO;
SMgrStatus: STATEMGRSTATUS;
begin
Result := False;
try
CoInitializeEx(0, COINIT_MULTITHREADED);
InitializeCOMSecurity(0, 2);
if not assigned(FSetRestorePoint)
then
begin
log('
opening SrClient.dll');
hSrClientDLL := LoadLibrary('
SrClient.dll');
if hSrClientDLL = 0
then
begin
log('
load error');
Exit;
end;
@FSetRestorePoint := GetProcAddress(hSrClientDLL, '
SRSetRestorePointA');
if not assigned(FSetRestorePoint)
then
begin
log('
function error');
Exit;
end;
end;
RestorePtSpec.dwEventType := BEGIN_SYSTEM_CHANGE;
RestorePtSpec.dwRestorePtType := APPLICATION_INSTALL;
RestorePtSpec.llSequenceNumber := 0;
copymemory(@RestorePtSpec.szDescription[low(RestorePtSpec.szDescription)],@s[1],sizeof(RestorePtSpec.szDescription));
if FSetRestorePoint(@RestorePtSpec, @SMgrStatus)
then
begin
Result := True;
end;
finally;
CoUninitialize;
if hSrClientDLL > 0
then FreeLibrary(hSrClientDLL);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
log('
Creating restore point by method 1');
if CreateRestorePointSR('
Test1 Restore Point '+timetostr(now))
then log('
method 1 success')
else log( '
method 1 error');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
log('
Creating restore point by method 2');
if CreateRestorePointVB('
Test2 Restore Point '+timetostr(now))
then log('
method 2 success')
else log( '
method 2 error');
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
log('
Creating restore point by method 3');
if CreateRestorePointOLE('
Test3 Restore Point'+timetostr(now))
then log('
method 3 success')
else log( '
method 3 error');
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
ChangeFSRedirection(True);
ShellExecute(0, '
open', '
rstrui.exe', '
',
nil, SW_SHOWNORMAL);
ChangeFSRedirection(False);
end;
(*
initialization
CoInitializeEx(0, COINIT_MULTITHREADED);
finalization
CoUninitialize;
*)
end.