B6 Delphi

Delphi 2010

Windows 7

• Windows 7• Windows Vista• UAC•• Windows 7•••• Direct2D
•
•
•
API

VCL
VCL
Win32 API2

Windows 7

Windows 7• Windows 7• Windows Vista• Vista
• 7

6.0
6.1

– SysUtils.CheckWin32Version(6, 1); //•Windows Vista• Longhorn

• UI

Vista

•
–

•

(DWU)
– DirectX 10.1
– Window
4

Windows 7

Vista

•
•
• Aero••••• Vista•••• DirectAPI
5Windows Vista

UAC• Vista• Xp• Administrators

Administrator• Vista / 7≠ Administrator• Administrators• UAC• manifest
•

• UAC
•

• ShellExecute

runas

• UAC

•
• http://edn.embarcadero.com/jp/article/images/34159/devcamp04_g4.pdf
7

UAC
Delphi 2010

manifest<?xml version="1.0" encoding="UTF-8" standalone="yes"?><assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"><assemblyIdentity
type="win32"
name="CodeGear RAD Studio"
version="14.0.3539.24502"
processorArchitecture="*"/><dependency><dependentAssembly><assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"version="6.0.0.0"
publicKeyToken="6595b64144ccf1df"
language="*"processorArchitecture="*"/></dependentAssembly></dependency><trustInfo xmlns="urn:schemas-microsoft-com:asm.v3"><security><requestedPrivileges>
requestedPrivileges><requestedExecutionLevel
level="asInvoker
level="asInvoker"
asInvoker"
uiAccess="false"/>uiAccess="false"/></requestedPrivileges</requestedPrivileges>
requestedPrivileges></security></trustInfo></assembly>

8

UAC
1.

manifest

manifest.xml<?xml version="1.0" encoding="UTF-8" standalone="yes"?><assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"><assemblyIdentity
type="win32"
name=""
version="1.0.0.0"
processorArchitecture="X86"/><description></description>level

requireAdministrator<dependency><dependentAssembly><assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"version="6.0.0.0"
publicKeyToken="6595b64144ccf1df"
language="*"processorArchitecture="*"/></dependentAssembly></dependency><trustInfo xmlns="urn:schemas-microsoft-com:asm.v2"><security><requestedPrivileges><requestedExecutionLevel level="requireAdministrator" uiAccess="false" /></requestedPrivileges></security></trustInfo></assembly>

9

UAC
2.RC
manifest.rc#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1#define RT_MANIFEST 24
CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "manifest.xml"

3.RC
RES
•%RADStudio%¥5.0¥bin¥brcc32.exe

RC

10

UAC
4.RAD Studio 2010

5.

RES
implementation{$R *.dfm}{$R manifest.res}

6.

11

• Xp

Vista/7•(Roaming)

Xp

Vista / 7

C:¥Documents and Settings

C:¥Users

C:¥Documents and Settings¥¥Application Data

C:¥Users¥¥AppData¥Roaming•• SHGetSpecialFolderLocation API•

12

SHGetSpecialFolder
SHGetSpecialFolder
uses
ShlObj, ActiveX;function GetSpecialFolder(const
const iFolder: DWORD): String;
Stringvar
IDL: PItemIDList;
begin
Result := '';SHGetSpecialFolderLocation(
Application.Handle,
iFolder,
IDL);
try
Result := StringOfChar(#0, MAX_PATH);

function GetWindowsDir: String
begin
SetLength(Result, MAX_PATH);
Len :=
ExpandEnvironmentStrings(
PChar('%windir%'),PChar(Result),
Length(Result));
if (Len > 0) then
Result := Copy(Result, 1, Len)
else
Result := '';
end;
end

if (IDL <> nil) and (SHGetPathFromIDList(IDL, PChar(Result))) then
Result := Trim(Result);
finally
CoTaskMemFree(IDL);
end;
end
end;
end
procedure TForm1.FormCreate(Sender: TObject);
begin
Label1.Caption := GetSpecialFolder(CSIDL_APPDATA);
end;
end

CSIDL_APPDATA

13

Windows 7• Windows 7
•
•
•
•
•

•

15

ShlObj.SetCurrentProcessExplicitAppUserModelID(PChar(''));

SetCurrentProcessExplicitAppUserModelID API
ID
procedure TForm1.FormCreate(Sender: TObject);
begin
SetCurrentProcessExplicitAppUserModelID('SERIALGAMES.DevCamp.AppID.1');
end;
end

procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
SetCurrentProcessExplicitAppUserModelID(PChar(IntToStr(Random(100))));
end;
end

16

• AppUserModelID

AppID• CompanyName.ProductName.SubProduct.VersionInformation•

128 byte• AppID

Windows•

AppUserModelID• AppID
API

17

ITaskbarList3※

MSDN

Windows 7

ITaskbarList3

18

procedure TfrmTaskbarSample.SetTaskbarButton;var
TL: ITaskbarList3;
Buttons: array [0.. 1] of TThumbButton;
begin
if
(
Succeeded(
CoCreateInstance(
CLSID_TaskbarList,
nil,
CLSCTX_ALL,
IID_ITaskbarList3,
TL)))
then begin//
with Buttons[0] do begin
dwMask := THB_ICON or THB_TOOLTIP or THB_FLAGS;
iId := 0;
szTip := '';dwFlags := THBF_ENABLED;//
TL.ThumbBarSetImageList(Handle, ImageList1.Handle);
with Buttons[1] do begin
dwMask := THB_BITMAP or THB_TOOLTIP or THB_FLAGS;
iId := 1;
szTip := '';dwFlags := THBF_ENABLED;
iBitmap := 0;
end;
end
//
TL.ThumbBarAddButtons(Handle, Length(Buttons), @Buttons);
end;
end
end;
end

hIcon := LoadSysIcon(IDI_INFORMATION);
end;
end※LoadSysIcon
function TfrmTaskbarSample.LoadSysIcon(const
const iKind: PChar): HICON;
begin
Result :=LoadImage(0, iKind, IMAGE_ICON, 0, 0, LR_DEFAULTSIZE or LR_SHARED);
end;
end

19

procedure TfrmTaskbarSample.WMCommand(var iMsg:
TWMCommand);
begin
inherited;inherited
if (iMsg.NotifyCode = THBN_CLICKED) thencase iMsg.ItemID of0:
ShowMessage('');

1:
ShowMessage('
');
end;
end
end;
end

20

procedure TfrmTaskbarSample.SetOverlayIcon;
var
TL: ITaskbarList3;
begin
if
(
Succeeded(
CoCreateInstance(
CLSID_TaskbarList,
nil,
CLSCTX_ALL,
IID_ITaskbarList3,
TL)
)
)
then
TL.SetOverlayIcon(Handle, LoadSysIcon(IDI_ERROR), 'ERROR
end;
end

');

TL.SetOverlayIcon(Handle, 0, nil);21

procedure TfrmTaskbarSample.InitProgress;
begin
CoCreateInstance(
CLSID_TaskbarList,
nil,
nil
CLSCTX_ALL,
IID_ITaskbarList3,
FTaskbarList);
end;
end

TBPF_NOPROGRESSTBPF_INDETERMINATE
TBPF_NORMALTBPF_ERRORTBPF_PAUSED

procedure TfrmTaskbarSample.SetProgress(const iCompleted: Integer);
begin
FTaskbarList.SetProgressState(Handle, TBPF_NORMAL);
FTaskbarList.SetProgressValue(Handle, iCompleted, 100);end;

procedure TfrmTaskbarSample.PauseProgress;
begin
FTaskbarList.SetProgressState(Handle, TBPF_PAUSED);
end;
end

procedure TfrmTaskbarSample.ErrorProgress;
begin
FTaskbarList.SetProgressState(Handle, TBPF_ERROR);
end;
end

22

※

MSDN

Windows 7

23

•Win32 API.NET Framework 4.0
VCL

……
MSDN

24

API
API
• InitPropVariantFromString• InitPropVariantFromBoolean• PropVariantClear
API
MSDN
InitPropVariantFrom*
Windows 7

propsys.dll 6.0
propsys.dll 7.0

API• InitPropVariantFromString• InitPropVariantFromBoolean

25

API

•
•

InitPropVariantFromString
InitPropVariantFromStringVector
InitPropVariantFromBoolean
InitPropVariantFromBooleanVector

VectorAPI
uPropSysForJumplist.pas

26

uPropSysForJumpList
unit uPropSysForJumpList;

InitPropVariantFrom*
InitPropVariantFrom*interfaceuses
Windows, ActiveX;

API

type
PPWideChar = ^PWideChar;PBOOL = ^BOOL;
TInitPropVariantFromStringVector =function(functionprgsz: PPWideChar;cElems: ULONG;
ppropvar: PPropVariant): HRESULT; stdcall;stdcall
TInitPropVariantFromString =function(function
psz: PWideChar;ppropvar: PPropVariant): HRESULT; stdcall;stdcall
TInitPropVariantFromBooleanVector =function(function
prgf: PBOOL;
cElems: ULONG;
ppropvar: PPropVariant): HRESULT; stdcall;stdcall
TInitPropVariantFromBoolean =function(function
fVal: BOOL;
ppropvar: PPropVariant): HRESULT; stdcall;stdcall
TPropVariantClear = function(pVar:function(pVar PPropVariant): HRESULT;
stdcall;
stdcall27

uPropSysForJumpList
var
InitPropVariantFromStringVector: TInitPropVariantFromStringVector = nil;
nil
InitPropVariantFromString: TInitPropVariantFromString = nil;
nil
InitPropVariantFromBooleanVector: TInitPropVariantFromBooleanVector = nil;
nil
InitPropVariantFromBoolean: TInitPropVariantFromBoolean = nil;
nil
PropVariantClear: TPropVariantClear = nil;
nil

InitPropVariant
PropVariantClear

propsys.dll
ole32.dllfunction PropSysLoaded: Boolean;
implementation
const
CPropSysLib = 'propsys.dll';
COle32Lib = 'Ole32.dll';
var
GPropSysLib: HMODULE = 0;
GOle32Lib: HMODULE = 0;28

uPropSysForJumpList
function _InitPropVariantFromString(
psz: PWideChar;ppropvar: PPropVariant): HRESULT; stdcall;stdcallbegin
Result := ERROR_INVALID_FUNCTION;

InitPropVariantFrom*

if (Assigned(InitPropVariantFromStringVector)) then
Result := InitPropVariantFromStringVector(@psz, 1, ppropvar);
end;
end
function _InitPropVariantFromBoolean(fVal: BOOL;
ppropvar: PPropVariant): HRESULT; stdcall;stdcallbegin
Result := ERROR_INVALID_FUNCTION;
if (Assigned(InitPropVariantFromBooleanVector)) then
Result := InitPropVariantFromBooleanVector(@fVal, 1, ppropvar);
end;
end
function PropSysLoaded: Boolean;
begin
Result :=Assigned(InitPropVariantFromString) andAssigned(InitPropVariantFromBoolean) andAssigned(PropVariantClear);
end;
end

29

uPropSysForJumpList
procedure LoadPropSys;
begin
GPropSysLib := LoadLibrary(CPropSysLib);
if (GPropSysLib <> 0) then begin// InitPropVariantFromString
InitPropVariantFromStringVector :=TInitPropVariantFromStringVector(
GetProcAddress(GPropSysLib, 'InitPropVariantFromStringVector'));

InitPropVariantFrom*

InitPropVariantFromString :=TInitPropVariantFromString(
GetProcAddress(GPropSysLib, 'InitPropVariantFromString'));if (not Assigned(InitPropVariantFromString)) then
InitPropVariantFromString := _InitPropVariantFromString;// InitPropVariantFromBoolean
InitPropVariantFromBooleanVector :=TInitPropVariantFromBooleanVector(
GetProcAddress(GPropSysLib, 'InitPropVariantFromBooleanVector'));
InitPropVariantFromBoolean :=TInitPropVariantFromBoolean(
GetProcAddress(GPropSysLib, 'InitPropVariantFromBoolean'));
if (not Assigned(InitPropVariantFromBoolean)) then
InitPropVariantFromBoolean := _InitPropVariantFromBoolean;
end;
end

30

uPropSysForJumpList
GOle32Lib := LoadLibrary(COle32Lib);

PropVariantClear

if (GOle32Lib <> 0) then begin// PropVariantClear
PropVariantClear :=TPropVariantClear(GetProcAddress(GOle32Lib, 'PropVariantClear'));
end;
end
end;
end
procedure UnloadPropSys;
begin
if (GPropSysLib <> 0) then
FreeLibrary(GPropSysLib);
if (GOle32Lib <> 0) then
FreeLibrary(GOle32Lib);
end;
endinitialization
begin
LoadPropSys;
end;
end
finalization
begin
UnloadPropSys;
end;
end

31

•
•
•
•
•
•
•

PropSys
IDestionationList
AppID
IDestionationList
IObjectCollection
IDestionationList

IShellLink
IShellLink

32

TJumpList
procedure TForm1.Button1Click(Sender: TObject);var
ExeName: String;
Stringbegin
ExeName := Application.ExeName;

AddTaskCreateJumplist

with TJumplist.Create(ExeName) dotry
AddTask(ExeName, 'Test1', '-test1');
AddTask(ExeName, 'Test2', '-test2');
AddTask('', '', '');
AddTask('notepad.exe', 'run notepad', '');CreateJumplist;
finally
Free;
end;
end
end;
end
procedure TForm1.FormCreate(Sender: TObject);
begin
SetCurrentProcessExplicitAppUserModelID(PChar(Application.ExeName));if (ParamStr(1) = '-test1') thenShowMessage('-test1
if (ParamStr(1) = '-test2') thenShowMessage('-test2
end;
end

');

');

33

uJumpList
unit uJumpList;

TJumplist

interface
uses
Classes, ShlObj;
type
TJumplist = classprivate// Variables
FAppID: String;
StringFParams: TStringList;
FCategories: TStringList;// Methods
function AddTasksToList(const
const iCDL: ICustomDestinationList): Boolean;function CreateShellLink(const iExe, iTitle, iArg: String): IShellLink;
function CreateSeparatorLink: IShellLink;
public// Constructor & Destructor
constructor Create(consconstcons iAppID: String);
String reintroduce;
reintroduce
destructor Destroy; override;
override// Taskfunction AddTask(const iExe, iTitle, iArg: String):
Integer;Stringprocedure DeleteTask(const iIndex: Integer);procedure ClearTask;
procedure GetParams(const
const iIndex: integer; var oExe, oTitle, oArg: String);
String// Jumplist
function CreateJumplist: Boolean;function DestroyJumplist: Boolean;
end;
end

34

uJumpList
constructor TJumplist.Create(const
const iAppID: String);
Stringbegin
inherited Create;

AppID

FAppID := iAppID;
FCategories := TStringList.Create;
FParams := TStringList.Create;
end;
end

ShlObjuses
Windows, SysUtils, Ole2, ShellAPI, ActiveX, ObjectArray, PropSys, PropKey,

uPropSysForJumpList;

35

uJumpList
function TJumplist.CreateShellLink(
const iExe, iTitle, iArg: String): IShellLink;
var
HR: HRESULT;
SL: IShellLink;
PS: IPropertyStore;
PropVar: TPropVariant;begin
Result := nil;
HR :=CoCreateInstance(
CLSID_ShellLink,
nil,
CLSCTX_INPROC_SERVER,
IID_IShellLink,SL);
if (Failed(HR)) thenExit;

HR := SL.QueryInterface(IID_IPropertyStore, PS);if (Failed(HR)) thenExit;
HR := InitPropVariantFromString(PChar(iTitle), @PropVar);try
if (Failed(HR)) thenExit;
HR := PS.SetValue(PKEY_Title, PropVar);
if (Failed(HR)) thenExit;
HR := PS.Commit;
if (Failed(HR)) thenExit;
HR := SL.QueryInterface(IID_IShellLink, Result);

HR := SL.SetPath(PChar(iExe));
if (Failed(HR)) thenExit;
HR := SL.SetArguments(PChar(iArg));

if (Failed(HR)) then
Result := nil;
nil
finally
PropVariantClear(@PropVar);
end;
end
end;
end

if (Failed(HR)) then
Exit;

IShellLink

36

uJumpList
function TJumplist.CreateSeparatorLink: IShellLink;
var
PS: IPropertyStore;
HR: HRESULT;PropVar: TPropVariant;begin
Result := nil;
HR :=CoCreateInstance(
CLSID_ShellLink,
nil,
CLSCTX_INPROC_SERVER,
IID_IPropertyStore,PS);

HR := PS.QueryInterface(IID_IShellLink, Result);
if (Failed(HR)) then
Result := nil;
end;
end

IShellLink

if (Failed(HR)) thenExit;
HR := InitPropVariantFromBoolean(True, @PropVar);
if (Failed(HR)) thenExit;
HR := PS.SetValue(PKEY_AppUserModel_IsDestListSeparator, PropVar);
if (Failed(HR)) thenExit;
HR := PS.Commit;
if (Failed(HR)) then
Exit;

37

uJumpList
function TJumplist.AddTasksToList(
const iCDL: ICustomDestinationList): Boolean;var
HR: HRESULT;
OC: IObjectCollection;
OA: IObjectArray;
SL: IShellLink;
i: Integer;
Exe, Title, Arg: String;
Stringbegin
Result := False;
HR :=CoCreateInstance(
CLSID_EnumerableObjectCollection,nil,
CLSCTX_INPROC,
IID_IObjectCollection,OC);

HR := OC.AddObject(SL);if (Failed(HR)) thenContinue;end;
end
HR := OC.QueryInterface(IID_IObjectArray, OA);
if (Failed(HR)) then
Exit;
Result := Succeeded(iCDL.AddUserTasks(OA));
end;
end

ICustomDestinationList
IShellLink

if (Failed(HR)) thenExit;
for i := 0 to FParams.Count - 1 do begin
GetParams(i, Exe, Title, Arg);

GetParams
Arg
Add

FParams

Exe, Title,

FParams

if (Exe <> '') thenSL := CreateShellLink(Exe, Title, Arg)else
SL := CreateSeparatorLink;
if (SL = nil)
nil thenContinue;38

uJumpList
function TJumplist.CreateJumplist: Boolean;var
HR: HRESULT;CDL: ICustomDestinationList;
OARemoved: IObjectArray;
MinSlots: Cardinal;
begin
Result := False;
if (not PropSysLoaded) then
Exit;
HR :=
CoCreateInstance(
CLSID_DestinationList,
nil,
CLSCTX_INPROC_SERVER,
IID_ICustomDestinationList,
CDL);

HR := CDL.SetAppID(PChar(FAppID));
if (Failed(HR)) thenExit;
HR := CDL.BeginList(MinSlots, IID_IObjectArray, OARemoved);
if (Failed(HR)) thenExit;
if (AddTasksToList(CDL)) then
Result := Succeeded(CDL.CommitList)
else
CDL.AbortList;
end;
end

if (Failed(HR)) then
Exit;

39

uJumpList
function TJumplist.DestroyJumplist: Boolean;var
HR: HRESULT;CDL: ICustomDestinationList;
begin
Result := False;
if (not PropSysLoaded) then
Exit;
HR :=
CoCreateInstance(
CLSID_DestinationList,
nil,
CLSCTX_INPROC_SERVER,
IID_ICustomDestinationList,
CDL);
if (Failed(HR)) then
Exit;
Result := Succeeded(CDL.DeleteList(nil));
end;
end

40

• MSDN• Windows7• http://www.microsoft.com/japan/powerpro/developer/default.mspx• Introducing The Taskbar APIs
• http://msdn.microsoft.com/en-us/magazine/dd942846.aspx• MSDN Sample Code• CustomJumpListSample– http://msdn.microsoft.com/en-us/library/dd940352(VS.85).aspx

4142