mirror-github-bspeice/apophysis7x
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ADMIN: migration complete

Browse Source 
git-svn-id: https://svn.code.sf.net/p/apophysis7x/svn/trunk@1 a5d1c0f9-a0e9-45c6-87dd-9d276e40c949
This commit is contained in:
xyrus02
2013-07-28 08:58:33 +00:00
commit 95a2f54683
258 changed files with 175238 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
Windows7/DelphiVersions.inc Normal file
View File

@ -0,0 +1,34 @@
{$IFDEF VER150}
{$DEFINE Delphi7}
{$DEFINE Delphi7_UP}
{$ENDIF}
{$IFDEF VER170}
{$DEFINE Delphi2005}
{$DEFINE Delphi7_UP}
{$DEFINE Delphi2005_UP}
{$ENDIF}
{$IFDEF VER180}
{$DEFINE Delphi2006}
{$DEFINE Delphi7_UP}
{$DEFINE Delphi2005_UP}
{$DEFINE Delphi2006_UP}
{$ENDIF}
{$IFDEF VER185}
{$DEFINE Delphi2007}
{$DEFINE Delphi7_UP}
{$DEFINE Delphi2005_UP}
{$DEFINE Delphi2006_UP}
{$DEFINE Delphi2007_UP}
{$ENDIF}
{$IFDEF VER200}
{$DEFINE Delphi2009}
{$DEFINE Delphi7_UP}
{$DEFINE Delphi2005_UP}
{$DEFINE Delphi2006_UP}
{$DEFINE Delphi2007_UP}
{$DEFINE Delphi2009_UP}
{$ENDIF}

32
Windows7/dwCustomDestinationList.pas Normal file
View File

@ -0,0 +1,32 @@
unit dwCustomDestinationList;
interface
uses
Windows,
dwObjectArray;
const
CLSID_CustomDestinationList: TGUID = '{77f10cf0-3db5-4966-b520-b7c54fd35ed6}';
const
KDC_FREQUENT = $01;
KDC_RECENT = $02;
type
ICustomDestinationList = interface
['{6332debf-87b5-4670-90c0-5e57b408a49e}']
procedure SetAppID(pszAppID: LPWSTR); safecall;
function BeginList(out pcMaxSlots: UINT; riid: PGUID): IObjectArray; safecall;
procedure AppendCategory(pszCategory: LPWSTR; poa: IObjectArray); safecall;
procedure AppendKnownCategory(Category: Integer); safecall;
procedure AddUserTasks(poa: IUnknown); safecall;
procedure CommitList(); safecall;
function GetRemovedDestinations(riid: PGUID): IUnknown; safecall;
procedure DeleteList(pszAppID:LPWSTR); safecall;
procedure AbortList(); safecall;
end;
implementation
end.

725
Windows7/dwJumpLists.pas Normal file
View File

@ -0,0 +1,725 @@
unit dwJumpLists;
interface
{$INCLUDE '..\Packages\DelphiVersions.inc'}
uses
Classes, Contnrs, ShlObj,
{$IFNDEF Delphi2007_Up}
dwShellItem,
{$ENDIF}
dwCustomDestinationList, dwObjectArray;
type
TJumpListKnowCategory = (jlkcFrequent, jlkcRecent);
TJumpListKnowCategories = set of TJumpListKnowCategory;
const
KNOWN_CATEGORIES_DEFAULT: TJumpListKnowCategories = [jlkcFrequent, jlkcRecent];
type
TdwLinkObjectType = (lotShellLink, lotShellItem);
type
TdwLinkObjectItem = class;
TdwLinkObjectList = class;
TdwLinkCategoryItem = class;
TdwLinkCategoryList = class;
TdwJumpLists = class;
TObjectArray = class(TInterfacedObject, IObjectArray)
private
FObjectList: TInterfaceList;
function CreateShellLink(ObjectItem: TdwLinkObjectItem): IShellLinkW;
function CreateShellItem(ObjectItem: TdwLinkObjectItem): IShellItem;
procedure LoadObjectList(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray);
protected
public
constructor Create(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray);
destructor Destroy; override;
function GetAt(uiIndex: Cardinal; riid: PGUID): IUnknown; safecall;
function GetCount: Cardinal; safecall;
end;
TdwShellItem = class(TPersistent)
private
FFilename: WideString;
procedure SetFilename(const Value: WideString);
protected
public
constructor Create;
procedure Assign(Source: TPersistent); override;
published
property Filename: WideString read FFilename write SetFilename;
end;
TdwShellLink = class(TPersistent)
private
FDisplayName: WideString;
FArguments: WideString;
FIconFilename: WideString;
FIconIndex: Integer;
procedure SetArguments(const Value: WideString);
procedure SetDisplayName(const Value: WideString);
procedure SetIconFilename(const Value: WideString);
procedure SetIconIndex(const Value: Integer);
protected
public
constructor Create;
procedure Assign(Source: TPersistent); override;
published
property Arguments: WideString read FArguments write SetArguments;
property DisplayName: WideString read FDisplayName write SetDisplayName;
property IconFilename: WideString read FIconFilename write SetIconFilename;
property IconIndex: Integer read FIconIndex write SetIconIndex;
end;
TdwLinkObjectItem = class(TCollectionItem)
private
FTag: Integer;
FObjectType: TdwLinkObjectType;
FShellItem: TdwShellItem;
FShellLink: TdwShellLink;
procedure SetTag(const Value: Integer);
procedure SetObjectType(const Value: TdwLinkObjectType);
procedure SetShellItem(const Value: TdwShellItem);
procedure SetShellLink(const Value: TdwShellLink);
protected
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
published
property Tag: Integer read FTag write SetTag default 0;
property ObjectType: TdwLinkObjectType read FObjectType write SetObjectType default lotShellItem;
property ShellItem: TdwShellItem read FShellItem write SetShellItem;
property ShellLink: TdwShellLink read FShellLink write SetShellLink;
end;
TdwLinkObjectList = class(TCollection)
private
FOwner: TPersistent;
function GetItem(Index: Integer): TdwLinkObjectItem;
procedure SetItem(Index: Integer; Value: TdwLinkObjectItem);
function GetObjectArray(DeletedObjects: IObjectArray): IObjectArray;
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
public
constructor Create(Owner: TPersistent);
destructor Destroy; override;
function Add: TdwLinkObjectItem;
function AddShellItem(const Filename: WideString): TdwLinkObjectItem;
function AddShellLink(const DisplayName, Arguments: WideString; const IconFilename: WideString = ''; IconIndex: Integer = 0): TdwLinkObjectItem;
function AddItem(Item: TdwLinkObjectItem; Index: Integer): TdwLinkObjectItem;
function Insert(Index: Integer): TdwLinkObjectItem;
property Items[Index: Integer]: TdwLinkObjectItem read GetItem write SetItem; default;
end;
TdwLinkCategoryItem = class(TCollectionItem)
private
FTitle: WideString;
FTag: Integer;
FItems: TdwLinkObjectList;
procedure SetTitle(const Value: WideString);
procedure SetTag(const Value: Integer);
procedure SetItems(const Value: TdwLinkObjectList);
protected
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
published
property Title: WideString read FTitle write SetTitle;
property Tag: Integer read FTag write SetTag default 0;
property Items: TdwLinkObjectList read FItems write SetItems;
end;
TdwLinkCategoryList = class(TCollection)
private
FOwner: TPersistent;
function GetItem(Index: Integer): TdwLinkCategoryItem;
procedure SetItem(Index: Integer; Value: TdwLinkCategoryItem);
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
public
constructor Create(Owner: TPersistent);
destructor Destroy; override;
function Add: TdwLinkCategoryItem;
function AddItem(Item: TdwLinkCategoryItem; Index: Integer): TdwLinkCategoryItem;
function Insert(Index: Integer): TdwLinkCategoryItem;
property Items[Index: Integer]: TdwLinkCategoryItem read GetItem write SetItem; default;
end;
TdwJumpLists = class(TComponent)
private
FDisplayKnowCategories: TJumpListKnowCategories;
FDestinationList: ICustomDestinationList;
FIsSupported: Boolean;
FCategories: TdwLinkCategoryList;
FTasks: TdwLinkObjectList;
FAppID: WideString;
procedure SetDisplayKnowCategories(const Value: TJumpListKnowCategories);
function DoStoreDisplayKnowCategories: Boolean;
procedure SetCategories(const Value: TdwLinkCategoryList);
procedure SetTasks(const Value: TdwLinkObjectList);
procedure SetAppID(const Value: WideString);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetMaxJumpListEntryCount: Integer;
function Commit: Boolean;
property IsSupported: Boolean read FIsSupported;
published
property DisplayKnowCategories: TJumpListKnowCategories read FDisplayKnowCategories write SetDisplayKnowCategories stored DoStoreDisplayKnowCategories;
property Categories: TdwLinkCategoryList read FCategories write SetCategories;
property Tasks: TdwLinkObjectList read FTasks write SetTasks;
property AppID: WideString read FAppID write SetAppID;
end;
implementation
uses
ComObj, ActiveX, SysUtils;
{ TObjectArray }
constructor TObjectArray.Create(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray);
begin
inherited Create;
FObjectList := TInterfaceList.Create;
LoadObjectList(ObjectList, DeletedObjects);
end;
function TObjectArray.CreateShellItem(ObjectItem: TdwLinkObjectItem): IShellItem;
begin
if ObjectItem.FObjectType = lotShellItem then
begin
SHCreateItemFromParsingName(PWideChar(ObjectItem.ShellItem.Filename), nil, StringToGUID(SID_IShellItem), Result);
end
else
begin
Result := nil;
end;
end;
function TObjectArray.CreateShellLink(ObjectItem: TdwLinkObjectItem): IShellLinkW;
var
ShellLink: IShellLinkW;
PPS: IPropertyStore;
K: TPropertyKey;
P: tagPROPVARIANT;
begin
if ObjectItem.FObjectType = lotShellLink then
begin
CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkW, ShellLink);
ShellLink.SetPath(PWideChar(WideString(GetModuleName(HInstance))));
ShellLink.SetArguments(PWideChar(ObjectItem.ShellLink.FArguments));
if ObjectItem.ShellLink.FIconFilename <> '' then
ShellLink.SetIconLocation(PWideChar(ObjectItem.ShellLink.FIconFilename), ObjectItem.ShellLink.FIconIndex)
else
ShellLink.SetIconLocation(PWideChar(WideString(GetModuleName(HInstance))), 0);
PPS := ShellLink as IPropertyStore;
K.fmtid := StringToGUID('{F29F85E0-4FF9-1068-AB91-08002B27B3D9}');
K.pid := 2;
P.vt := VT_LPWSTR;
P.pwszVal := PWideChar(ObjectItem.ShellLink.FDisplayName);
PPS.SetValue(K, P);
PPS.Commit;
Result := ShellLink;
end
else
begin
Result := nil;
end;
end;
destructor TObjectArray.Destroy;
begin
FObjectList.Free;
inherited;
end;
function TObjectArray.GetAt(uiIndex: Cardinal; riid: PGUID): IUnknown;
begin
Result := FObjectList[uiIndex];
end;
function TObjectArray.GetCount: Cardinal;
begin
Result := FObjectList.Count;
end;
procedure TObjectArray.LoadObjectList(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray);
var
I: Integer;
ObjectItem: TdwLinkObjectItem;
begin
for I := 0 to ObjectList.Count - 1 do
begin
ObjectItem := ObjectList.Items[I];
case ObjectItem.FObjectType of
lotShellLink:
begin
FObjectList.Add(CreateShellLink(ObjectItem));
end;
lotShellItem:
begin
FObjectList.Add(CreateShellItem(ObjectItem));
end;
end;
end;
end;
{ TdwShellLink }
procedure TdwShellItem.Assign(Source: TPersistent);
begin
if Source is TdwShellItem then
begin
Self.FFilename := (Source as TdwShellItem).FFilename;
end
else
begin
inherited Assign(Source);
end;
end;
constructor TdwShellItem.Create;
begin
inherited Create;
FFilename := '';
end;
procedure TdwShellItem.SetFilename(const Value: WideString);
begin
FFilename := Value;
end;
{ TdwShellLink }
procedure TdwShellLink.Assign(Source: TPersistent);
begin
if Source is TdwShellLink then
begin
Self.FArguments := (Source as TdwShellLink).FArguments;
Self.FDisplayName := (Source as TdwShellLink).FDisplayName;
Self.FIconFilename := (Source as TdwShellLink).FIconFilename;
Self.FIconIndex := (Source as TdwShellLink).FIconIndex;
end
else
begin
inherited Assign(Source);
end;
end;
constructor TdwShellLink.Create;
begin
inherited Create;
FDisplayName := '';
FArguments := '';
FIconFilename := '';
FIconIndex := 0;
end;
procedure TdwShellLink.SetArguments(const Value: WideString);
begin
FArguments := Value;
end;
procedure TdwShellLink.SetDisplayName(const Value: WideString);
begin
FDisplayName := Value;
end;
procedure TdwShellLink.SetIconFilename(const Value: WideString);
begin
FIconFilename := Value;
end;
procedure TdwShellLink.SetIconIndex(const Value: Integer);
begin
FIconIndex := Value;
end;
{ TdwLinkObjectItem }
procedure TdwLinkObjectItem.Assign(Source: TPersistent);
begin
if Source is TdwLinkObjectItem then
begin
Self.FTag := (Source as TdwLinkObjectItem).FTag;
Self.FObjectType := (Source as TdwLinkObjectItem).FObjectType;
end
else
begin
inherited Assign(Source);
end;
end;
constructor TdwLinkObjectItem.Create(Collection: TCollection);
begin
inherited Create(Collection);
FTag := 0;
FObjectType := lotShellItem;
FShellItem := TdwShellItem.Create();
FShellLink := TdwShellLink.Create();
end;
destructor TdwLinkObjectItem.Destroy;
begin
FShellItem.Free;
FShellLink.Free;
inherited;
end;
procedure TdwLinkObjectItem.SetObjectType(const Value: TdwLinkObjectType);
begin
FObjectType := Value;
end;
procedure TdwLinkObjectItem.SetShellItem(const Value: TdwShellItem);
begin
FShellItem.Assign(Value);
end;
procedure TdwLinkObjectItem.SetShellLink(const Value: TdwShellLink);
begin
FShellLink := Value;
end;
procedure TdwLinkObjectItem.SetTag(const Value: Integer);
begin
FTag := Value;
end;
{ TdwLinkObjectList }
function TdwLinkObjectList.Add: TdwLinkObjectItem;
begin
Result := AddItem(nil, -1);
end;
function TdwLinkObjectList.AddItem(Item: TdwLinkObjectItem; Index: Integer): TdwLinkObjectItem;
begin
if Item = nil then
begin
Result := TdwLinkObjectItem.Create(Self);
end
else
begin
Result := Item;
if Assigned(Item) then
begin
Result.Collection := Self;
if Index < Count then
Index := Count - 1;
Result.Index := Index;
end;
end;
end;
function TdwLinkObjectList.AddShellItem(const Filename: WideString): TdwLinkObjectItem;
begin
Result := Add;
Result.FObjectType := lotShellItem;
Result.ShellItem.FFilename := Filename;
end;
function TdwLinkObjectList.AddShellLink(const DisplayName, Arguments, IconFilename: WideString; IconIndex: Integer): TdwLinkObjectItem;
begin
Result := Add;
Result.FObjectType := lotShellLink;
Result.ShellLink.FDisplayName := DisplayName;
Result.ShellLink.FArguments := Arguments;
Result.ShellLink.FIconFilename := IconFilename;
Result.ShellLink.FIconIndex := IconIndex;
end;
constructor TdwLinkObjectList.Create(Owner: TPersistent);
begin
inherited Create(TdwLinkObjectItem);
FOwner := Owner;
end;
destructor TdwLinkObjectList.Destroy;
begin
inherited;
end;
function TdwLinkObjectList.GetItem(Index: Integer): TdwLinkObjectItem;
begin
Result := TdwLinkObjectItem(inherited GetItem(Index));
end;
function TdwLinkObjectList.GetObjectArray(DeletedObjects: IObjectArray): IObjectArray;
begin
Result := TObjectArray.Create(Self, DeletedObjects) as IObjectArray;
end;
function TdwLinkObjectList.GetOwner: TPersistent;
begin
Result := FOwner;
end;
function TdwLinkObjectList.Insert(Index: Integer): TdwLinkObjectItem;
begin
Result := AddItem(nil, Index);
end;
procedure TdwLinkObjectList.SetItem(Index: Integer; Value: TdwLinkObjectItem);
begin
inherited SetItem(Index, Value);
end;
procedure TdwLinkObjectList.Update(Item: TCollectionItem);
begin
// nothing to do
end;
{ TdwLinkCategoryItem }
procedure TdwLinkCategoryItem.Assign(Source: TPersistent);
begin
if Source is TdwLinkCategoryItem then
begin
Self.FTitle := (Source as TdwLinkCategoryItem).FTitle;
Self.FTag := (Source as TdwLinkCategoryItem).FTag;
end
else
begin
inherited Assign(Source);
end;
end;
constructor TdwLinkCategoryItem.Create(Collection: TCollection);
begin
inherited Create(Collection);
FTitle := '';
FTag := 0;
FItems := TdwLinkObjectList.Create(Self);
end;
destructor TdwLinkCategoryItem.Destroy;
begin
FItems.Free;
inherited Destroy;
end;
procedure TdwLinkCategoryItem.SetItems(const Value: TdwLinkObjectList);
begin
FItems.Assign(Value);
end;
procedure TdwLinkCategoryItem.SetTag(const Value: Integer);
begin
FTag := Value;
end;
procedure TdwLinkCategoryItem.SetTitle(const Value: WideString);
begin
FTitle := Value;
end;
{ TdwLinkCategoryList }
function TdwLinkCategoryList.Add: TdwLinkCategoryItem;
begin
Result := AddItem(nil, -1);
end;
function TdwLinkCategoryList.AddItem(Item: TdwLinkCategoryItem; Index: Integer): TdwLinkCategoryItem;
begin
if Item = nil then
begin
Result := TdwLinkCategoryItem.Create(Self);
end
else
begin
Result := Item;
if Assigned(Item) then
begin
Result.Collection := Self;
if Index < Count then
Index := Count - 1;
Result.Index := Index;
end;
end;
end;
constructor TdwLinkCategoryList.Create(Owner: TPersistent);
begin
inherited Create(TdwLinkCategoryItem);
FOwner := Owner;
end;
destructor TdwLinkCategoryList.Destroy;
begin
inherited Destroy;
end;
function TdwLinkCategoryList.GetItem(Index: Integer): TdwLinkCategoryItem;
begin
Result := TdwLinkCategoryItem(inherited GetItem(Index));
end;
function TdwLinkCategoryList.GetOwner: TPersistent;
begin
Result := FOwner;
end;
function TdwLinkCategoryList.Insert(Index: Integer): TdwLinkCategoryItem;
begin
Result := AddItem(nil, Index);
end;
procedure TdwLinkCategoryList.SetItem(Index: Integer; Value: TdwLinkCategoryItem);
begin
inherited SetItem(Index, Value);
end;
procedure TdwLinkCategoryList.Update(Item: TCollectionItem);
begin
// nothing to do
end;
{ TdwJumpLists }
function TdwJumpLists.Commit: Boolean;
var
MaxSlots: Cardinal;
IdxCat: Integer;
DeletedObjects: IObjectArray;
Category: TdwLinkCategoryItem;
begin
if IsSupported then
try
DeletedObjects := FDestinationList.BeginList(MaxSlots, @IID_IObjectArray);
for IdxCat := 0 to FCategories.Count - 1 do
begin
Category := FCategories.Items[IdxCat];
if Category.Items.Count > 0 then
begin
FDestinationList.AppendCategory(PWideChar(Category.FTitle), Category.Items.GetObjectArray(DeletedObjects));
end;
end;
if FTasks.Count > 0 then
FDestinationList.AddUserTasks(FTasks.GetObjectArray(DeletedObjects));
if jlkcFrequent in FDisplayKnowCategories then
FDestinationList.AppendKnownCategory(KDC_FREQUENT);
if jlkcRecent in FDisplayKnowCategories then
FDestinationList.AppendKnownCategory(KDC_RECENT);
FDestinationList.CommitList;
Result := True;
except
Result := False;
end
else
begin
Result := False;
end;
end;
constructor TdwJumpLists.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if CheckWin32Version(6, 1) then
begin
FDisplayKnowCategories := KNOWN_CATEGORIES_DEFAULT;
FDestinationList := CreateComObject(CLSID_CustomDestinationList) as ICustomDestinationList;
end
else
begin
FDestinationList := nil;
end;
FIsSupported := FDestinationList <> nil;
FCategories := TdwLinkCategoryList.Create(Self);
FTasks := TdwLinkObjectList.Create(Self);
end;
destructor TdwJumpLists.Destroy;
begin
FDestinationList := nil;
FCategories.Free;
FTasks.Free;
inherited Destroy;
end;
function TdwJumpLists.DoStoreDisplayKnowCategories: Boolean;
begin
Result := FDisplayKnowCategories <> KNOWN_CATEGORIES_DEFAULT;
end;
function TdwJumpLists.GetMaxJumpListEntryCount: Integer;
var
Objects: IObjectArray;
MaxSlots: Cardinal;
begin
if not IsSupported then
begin
Result := -1;
end
else
begin
Objects := FDestinationList.BeginList(MaxSlots, @IID_IObjectArray);
FDestinationList.AbortList;
Result := MaxSlots;
end;
end;
procedure TdwJumpLists.SetAppID(const Value: WideString);
begin
FAppID := Value;
FDestinationList.SetAppID(PWideChar(Value));
end;
procedure TdwJumpLists.SetCategories(const Value: TdwLinkCategoryList);
begin
FCategories.Assign(Value);
end;
procedure TdwJumpLists.SetDisplayKnowCategories(const Value: TJumpListKnowCategories);
begin
if FDisplayKnowCategories <> Value then
begin
FDisplayKnowCategories := Value;
end;
end;
procedure TdwJumpLists.SetTasks(const Value: TdwLinkObjectList);
begin
FTasks.Assign(Value);
end;
end.

20
Windows7/dwObjectArray.pas Normal file
View File

@ -0,0 +1,20 @@
unit dwObjectArray;
interface
uses
Windows;
const
IID_IObjectArray: TGUID = '{92CA9DCD-5622-4BBA-A805-5E9F541BD8C9}';
type
IObjectArray = interface
['{92CA9DCD-5622-4BBA-A805-5E9F541BD8C9}']
function GetCount(): UInt; safecall;
function GetAt(uiIndex: UInt; riid: PGUID): IUnknown; safecall;
end;
implementation
end.

116
Windows7/dwOverlayIcon.pas Normal file
View File

@ -0,0 +1,116 @@
unit dwOverlayIcon;
interface
uses
Classes, ImgList,
dwTaskbarComponents;
type
TdwOverlayIcon = class(TdwTaskbarComponent)
private
FImages: TCustomImageList;
FImageIndex: Integer;
FHint: WideString;
procedure SetImages(const Value: TCustomImageList);
procedure SetImageIndex(const Value: Integer);
function DoShowOverlay: Boolean;
procedure SetHint(const Value: WideString);
protected
function DoInitialize: Boolean; override;
procedure DoUpdate; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Images: TCustomImageList read FImages write SetImages;
property ImageIndex: Integer read FImageIndex write SetImageIndex;
property Hint: WideString read FHint write SetHint;
end;
implementation
uses
SysUtils, Graphics;
{ TdwOverlayIcon }
constructor TdwOverlayIcon.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FImages := nil;
FImageIndex := -1;
FHint := '';
end;
destructor TdwOverlayIcon.Destroy;
begin
inherited Destroy;
end;
function TdwOverlayIcon.DoInitialize: Boolean;
begin
Result := DoShowOverlay;
end;
function TdwOverlayIcon.DoShowOverlay: Boolean;
var
Icon: TIcon;
begin
if CheckWin32Version(6, 1) and (TaskbarList3 <> nil) then
begin
if (FImages = nil) or (FImageIndex < 0) or (FImageIndex >= FImages.Count) then
begin
TaskbarList3.SetOverlayIcon(TaskBarEntryHandle, 0, nil);
Result := True;
end
else
begin
Icon := TIcon.Create;
try
FImages.GetIcon(FImageIndex, Icon);
TaskbarList3.SetOverlayIcon(TaskBarEntryHandle, Icon.ReleaseHandle, PWideChar(FHint));
Result := True;
finally
Icon.Free;
end;
end;
end
else
begin
Result := False;
end;
end;
procedure TdwOverlayIcon.DoUpdate;
begin
DoShowOverlay;
end;
procedure TdwOverlayIcon.SetHint(const Value: WideString);
begin
if FHint <> Value then
begin
FHint := Value;
SendUpdateMessage;
end;
end;
procedure TdwOverlayIcon.SetImageIndex(const Value: Integer);
begin
if FImageIndex <> Value then
begin
FImageIndex := Value;
SendUpdateMessage;
end;
end;
procedure TdwOverlayIcon.SetImages(const Value: TCustomImageList);
begin
FImages := Value;
SendUpdateMessage;
end;
end.

534
Windows7/dwProgressBar.pas Normal file
View File

@ -0,0 +1,534 @@
unit dwProgressBar;
interface
{$INCLUDE 'DelphiVersions.inc'}
uses
SysUtils, Classes, Controls, ComCtrls, Messages, Graphics,
dwTaskbarComponents;
const
ICC_PROGRESS_CLASS = $00000020;
const
PBS_SMOOTH = $01;
PBS_VERTICAL = $04;
PBS_MARQUEE = $08;
PBS_SMOOTHREVERSE = $10;
const
PBM_SETMARQUEE = WM_USER + 10;
PBM_SETSTATE = WM_USER + 16;
PBM_GETSTATE = WM_USER + 17;
const
PBST_NORMAL = $0001;
PBST_ERROR = $0002;
PBST_PAUSED = $0003;
type
TdwProgressBarState = (pbstMarquee = 0, pbstNormal = 1, pbstError = 2, pbstPaused = 3);
TdwProgressBar = class(TdwTaskbarWinControl)
private // CodeGear :: ProgressBar
FMin: Integer;
FMax: Integer;
FPosition: Integer;
FStep: Integer;
FOrientation: TProgressBarOrientation;
FSmooth: Boolean;
FSmoothReverse: Boolean;
FBarColor: TColor;
FBackgroundColor: TColor;
function GetMin: Integer;
function GetMax: Integer;
function GetPosition: Integer;
procedure SetParams(AMin, AMax: Integer);
procedure SetMin(Value: Integer);
procedure SetMax(Value: Integer);
procedure SetPosition(Value: Integer);
procedure SetStep(Value: Integer);
procedure SetOrientation(Value: TProgressBarOrientation);
procedure SetSmooth(Value: Boolean);
procedure SetSmoothReverse(Value: Boolean);
procedure SetBarColor(Value: TColor);
procedure SetBackgroundColor(Value: TColor);
procedure WMEraseBkGnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
private
{$IFDEF Delphi2006_UP}
const LIMIT_16 = 65535;
{$ENDIF}
class procedure ProgressLimitError;
private
FMsgUpdateTaskbar: Cardinal;
FProgressBarState: TdwProgressBarState;
FMarqueeEnabled: Boolean;
FMarqueeInterval: Integer;
FShowInTaskbar: Boolean;
procedure SetProgressBarState(const Value: TdwProgressBarState);
procedure SetMarqueeInterval(const Value: Integer);
procedure SetShowInTaskbar(const Value: Boolean);
procedure SetMarqueeEnabled(const Value: Boolean);
protected // CodeGear :: ProgressBar
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure DestroyWnd; override;
protected
class function GetComCtrlClass: Integer; override;
class function GetComCtrlClassName: PChar; override;
procedure WndProc(var Msg: TMessage); override;
public // CodeGear ProgressBar
constructor Create(AOwner: TComponent); override;
procedure StepIt;
procedure StepBy(Delta: Integer);
published // CodeGear ProgressBar
property Align;
property Anchors;
property BorderWidth;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Hint;
property Constraints;
property Min: Integer read GetMin write SetMin default 0;
property Max: Integer read GetMax write SetMax default 100;
property Orientation: TProgressBarOrientation read FOrientation write SetOrientation default pbHorizontal;
property ParentShowHint;
property PopupMenu;
property Position: Integer read GetPosition write SetPosition default 0;
property Smooth: Boolean read FSmooth write SetSmooth default False;
property SmoothReverse: Boolean read FSmoothReverse write SetSmoothReverse default False;
property Step: Integer read FStep write SetStep default 10;
property BarColor: TColor read FBarColor write SetBarColor default clDefault;
property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clDefault;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
{$IFDEF Delphi2006_UP}
property OnMouseActivate;
property OnMouseEnter;
property OnMouseLeave;
{$ENDIF}
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property DoubleBuffered;
{$IFDEF Delphi2009_Up}
property ParentDoubleBuffered;
{$ENDIF}
published
property ProgressBarState: TdwProgressBarState read FProgressBarState write SetProgressBarState default pbstNormal;
property MarqueeEnabled: Boolean read FMarqueeEnabled write SetMarqueeEnabled default False;
property MarqueeInterval: Integer read FMarqueeInterval write SetMarqueeInterval default 75;
property ShowInTaskbar: Boolean read FShowInTaskbar write SetShowInTaskbar default False;
end;
procedure Register;
implementation
uses
Consts,
Themes, CommCtrl, Windows,
dwTaskbarList;
{$IFNDEF Delphi2006_UP}
const LIMIT_16 = 65535;
{$ENDIF}
procedure Register;
begin
RegisterComponents('Windows 6+', [TdwProgressBar]);
end;
{ TdwProgressBar }
constructor TdwProgressBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 150;
Height := GetSystemMetrics(SM_CYVSCROLL);
FMin := 0;
FMax := 100;
FStep := 10;
FOrientation := pbHorizontal;
FBarColor := clDefault;
FBackgroundColor := clDefault;
FMarqueeInterval := 10;
FSmooth := False;
FSmoothReverse := False;
FMarqueeInterval := 50;
FProgressBarState := pbstNormal;
FShowInTaskbar := False;
FMsgUpdateTaskbar := RegisterWindowMessage('dw.Control.Update.Taskbar');
end;
procedure TdwProgressBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
if FOrientation = pbVertical then
Style := Style or PBS_VERTICAL;
if FSmooth then
Style := Style or PBS_SMOOTH;
if (FProgressBarState = pbstMarquee) and ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) then
Style := Style or PBS_MARQUEE;
if FSmoothReverse and ThemeServices.ThemesEnabled and CheckWin32Version(6, 0) then
Style := Style or PBS_SMOOTHREVERSE;
end;
end;
procedure TdwProgressBar.CreateWnd;
begin
inherited CreateWnd;
if In32BitMode then
begin
SendMessage(Handle, PBM_SETRANGE32, FMin, FMax);
end
else
begin
SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(FMin, FMax));
end;
SendMessage(Handle, PBM_SETSTEP, FStep, 0);
Position := FPosition;
BarColor := FBarColor;
BackgroundColor := FBackgroundColor;
ProgressBarState := FProgressBarState;
if ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) then
begin
if FProgressBarState = pbstMarquee then
SendMessage(Handle, PBM_SETMARQUEE, Integer(BOOL(FMarqueeEnabled)), FMarqueeInterval);
end;
end;
procedure TdwProgressBar.DestroyWnd;
begin
FPosition := Position;
inherited;
end;
class function TdwProgressBar.GetComCtrlClass: Integer;
begin
Result := ICC_PROGRESS_CLASS;
end;
class function TdwProgressBar.GetComCtrlClassName: PChar;
begin
Result := PROGRESS_CLASS;
end;
function TdwProgressBar.GetMax: Integer;
begin
if HandleAllocated and In32BitMode then
Result := SendMessage(Handle, PBM_GETRANGE, 0, 0)
else
Result := FMax;
end;
function TdwProgressBar.GetMin: Integer;
begin
if HandleAllocated and In32BitMode then
Result := SendMessage(Handle, PBM_GETRANGE, 1, 0)
else
Result := FMin;
end;
function TdwProgressBar.GetPosition: Integer;
begin
if HandleAllocated then
begin
if In32BitMode then
Result := SendMessage(Handle, PBM_GETPOS, 0, 0)
else
Result := SendMessage(Handle, PBM_DELTAPOS, 0, 0);
end
else
begin
Result := FPosition;
end;
end;
class procedure TdwProgressBar.ProgressLimitError;
begin
raise Exception.CreateFmt(SOutOfRange, [0, LIMIT_16]);
end;
procedure TdwProgressBar.SetBackgroundColor(Value: TColor);
var
ColorRef: TColorRef;
begin
if FBackgroundColor <> Value then
begin
FBackgroundColor := Value;
if Value = clDefault then
ColorRef := TColorRef($FF000000)
else
ColorRef := TColorRef(ColorToRGB(Color));
if HandleAllocated then
SendMessage(Handle, PBM_SETBKCOLOR, 0, ColorRef);
end;
end;
procedure TdwProgressBar.SetBarColor(Value: TColor);
var
ColorRef: TColorRef;
begin
if FBarColor <> Value then
begin
FBarColor := Value;
if Value = clDefault then
ColorRef := TColorRef($FF000000)
else
ColorRef := TColorRef(ColorToRGB(Color));
if HandleAllocated then
SendMessage(Handle, PBM_SETBARCOLOR, 0, ColorRef);
end;
end;
procedure TdwProgressBar.SetMarqueeEnabled(const Value: Boolean);
begin
if FMarqueeEnabled <> Value then
begin
FMarqueeEnabled := Value;
if (FProgressBarState = pbstMarquee) and ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) and HandleAllocated then
begin
SendMessage(Handle, PBM_SETMARQUEE, Integer(BOOL(FMarqueeEnabled)), FMarqueeInterval);
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end;
end;
end;
procedure TdwProgressBar.SetMarqueeInterval(const Value: Integer);
begin
if FMarqueeInterval <> Value then
begin
FMarqueeInterval := Value;
if (FProgressBarState = pbstMarquee) and ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) and HandleAllocated then
begin
SendMessage(Handle, PBM_SETMARQUEE, Integer(BOOL(FMarqueeEnabled)), FMarqueeInterval);
end;
end;
end;
procedure TdwProgressBar.SetMax(Value: Integer);
begin
if FMax <> Value then
begin
SetParams(FMin, Value);
end;
end;
procedure TdwProgressBar.SetMin(Value: Integer);
begin
if FMin <> Value then
begin
SetParams(Value, FMax);
end;
end;
procedure TdwProgressBar.SetOrientation(Value: TProgressBarOrientation);
begin
if FOrientation <> Value then
begin
FOrientation := Value;
RecreateWnd;
end;
end;
procedure TdwProgressBar.SetParams(AMin, AMax: Integer);
begin
if AMax < AMin then
raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.ClassName]);
if not In32BitMode and ((AMin < 0) or (AMax > LIMIT_16)) then
ProgressLimitError;
if (FMin <> AMin) or (FMax <> AMax) then
begin
if HandleAllocated then
begin
if In32BitMode then
SendMessage(Handle, PBM_SETRANGE32, AMin, AMax)
else
SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(AMin, AMax));
if FMin > FMax then
SendMessage(Handle, PBM_SETPOS, AMin, 0);
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end;
FMin := AMin;
FMax := AMax;
end;
end;
procedure TdwProgressBar.SetPosition(Value: Integer);
begin
if not In32BitMode and ((Value < 0) or (Value > LIMIT_16)) then
ProgressLimitError;
if HandleAllocated then
begin
SendMessage(Handle, PBM_SETPOS, Value, 0);
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end
else
begin
FPosition := Value;
end;
end;
procedure TdwProgressBar.SetProgressBarState(const Value: TdwProgressBarState);
var
DoRecreate: Boolean;
begin
DoRecreate := (FProgressBarState <> Value);
FProgressBarState := Value;
if DoRecreate then
begin
RecreateWnd;
end
else
begin
if CheckWin32Version(6, 0) and HandleAllocated then
SendMessage(Handle, PBM_SETSTATE, Integer(Value), 0);
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end;
end;
procedure TdwProgressBar.SetShowInTaskbar(const Value: Boolean);
begin
if FShowInTaskbar <> Value then
begin
FShowInTaskbar := Value;
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end;
end;
procedure TdwProgressBar.SetSmooth(Value: Boolean);
begin
if FSmooth <> Value then
begin
FSmooth := Value;
RecreateWnd;
end;
end;
procedure TdwProgressBar.SetSmoothReverse(Value: Boolean);
begin
if FSmoothReverse <> Value then
begin
FSmoothReverse := Value;
RecreateWnd;
end;
end;
procedure TdwProgressBar.SetStep(Value: Integer);
begin
if FStep <> Value then
begin
FStep := Value;
if HandleAllocated then
begin
SendMessage(Handle, PBM_SETSTEP, FStep, 0);
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end;
end;
end;
procedure TdwProgressBar.StepBy(Delta: Integer);
begin
if HandleAllocated then
begin
SendMessage(Handle, PBM_DELTAPOS, Delta, 0);
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end;
end;
procedure TdwProgressBar.StepIt;
begin
if HandleAllocated then
begin
SendMessage(Handle, PBM_STEPIT, 0, 0);
PostMessage(Handle, FMsgUpdateTaskbar, 0, 0);
end;
end;
procedure TdwProgressBar.WMEraseBkGnd(var Message: TWMEraseBkgnd);
begin
DefaultHandler(Message);
end;
procedure TdwProgressBar.WndProc(var Msg: TMessage);
var
FormHandle: THandle;
begin
if Msg.Msg = FMsgUpdateTaskbar then
begin
if CheckWin32Version(6, 1) and (TaskbarList3 <> nil) then
begin
FormHandle := TaskBarEntryHandle;
if FormHandle <> INVALID_HANDLE_VALUE then
begin
if ShowInTaskbar then
begin
case FProgressBarState of
pbstMarquee:
begin
TaskbarList3.SetProgressState(FormHandle, TBPF_NORMAL);
if FMarqueeEnabled then
TaskbarList3.SetProgressState(FormHandle, TBPF_INDETERMINATE)
else
TaskbarList3.SetProgressState(FormHandle, TBPF_NOPROGRESS);
end;
pbstNormal: TaskbarList3.SetProgressState(FormHandle, TBPF_NORMAL);
pbstError: TaskbarList3.SetProgressState(FormHandle, TBPF_ERROR);
pbstPaused: TaskbarList3.SetProgressState(FormHandle, TBPF_PAUSED);
end;
if FProgressBarState in [pbstNormal, pbstError, pbstPaused] then
begin
TaskbarList3.SetProgressValue(FormHandle, Position - Min, Max - Min);
end;
end
else
begin
TaskbarList3.SetProgressState(FormHandle, TBPF_NOPROGRESS);
end;
end;
end;
end;
inherited;
end;
end.

111
Windows7/dwShellItem.pas Normal file
View File

@ -0,0 +1,111 @@
unit dwShellItem;
interface
{$INCLUDE '.\..\Packages\DelphiVersions.inc'}
uses
ActiveX, Windows;
const
SID_IShellItem = '{43826d1e-e718-42ee-bc55-a1e261c37bfe}';
SID_IPropertyStore = '{886d8eeb-8cf2-4446-8d02-cdba1dbdcf99}';
type
TIID = TGUID;
IShellItem = interface(IUnknown)
[SID_IShellItem]
function BindToHandler(const pbc: IUnknown; const bhid: TGUID; const riid: TIID; out ppv): HResult; stdcall;
function GetParent(var ppsi: IShellItem): HResult; stdcall;
function GetDisplayName(sigdnName: DWORD; var ppszName: LPWSTR): HResult; stdcall;
function GetAttributes(sfgaoMask: DWORD; var psfgaoAttribs: DWORD): HResult; stdcall;
function Compare(const psi: IShellItem; hint: DWORD; var piOrder: Integer): HResult; stdcall;
end;
_tagpropertykey = packed record
fmtid: TGUID;
pid: DWORD;
end;
PROPERTYKEY = _tagpropertykey;
PPropertyKey = ^TPropertyKey;
TPropertyKey = _tagpropertykey;
IPropertyStore = interface(IUnknown)
[SID_IPropertyStore]
function GetCount(out cProps: DWORD): HResult; stdcall;
function GetAt(iProp: DWORD; out pkey: TPropertyKey): HResult; stdcall;
function GetValue(const key: TPropertyKey; out pv: TPropVariant): HResult; stdcall;
function SetValue(const key: TPropertyKey; const propvar: TPropVariant): HResult; stdcall;
function Commit: HResult; stdcall;
end;
type
PSHItemID = ^TSHItemID;
_SHITEMID = record
cb: Word;
abID: array[0..0] of Byte;
end;
TSHItemID = _SHITEMID;
SHITEMID = _SHITEMID;
PItemIDList = ^TItemIDList;
_ITEMIDLIST = record
mkid: TSHItemID;
end;
TItemIDList = _ITEMIDLIST;
ITEMIDLIST = _ITEMIDLIST;
function SHCreateItemFromIDList(pidl: PItemIDList; const riid: TIID; out ppv): HResult;
function SHCreateItemFromParsingName(pszPath: LPCWSTR; const pbc: IUnknown; const riid: TIID; out ppv): HResult;
implementation
const
shell32 = 'shell32.dll';
var
Shell32Lib: HModule;
_SHCreateItemFromParsingName: function(pszPath: LPCWSTR; const pbc: IUnknown; const riid: TIID; out ppv): HResult; stdcall;
_SHCreateItemFromIDList: function(pidl: PItemIDList; const riid: TIID; out ppv): HResult; stdcall;
procedure InitShlObj; {$IFDEF Delphi2006_Up} inline; {$ENDIF}
begin
Shell32Lib := GetModuleHandle(shell32);
end;
function SHCreateItemFromParsingName(pszPath: LPCWSTR; const pbc: IUnknown; const riid: TIID; out ppv): HResult;
begin
if Assigned(_SHCreateItemFromParsingName) then
Result := _SHCreateItemFromParsingName(pszPath, pbc, riid, ppv)
else
begin
InitShlObj;
Result := E_NOTIMPL;
if Shell32Lib > 0 then
begin
_SHCreateItemFromParsingName := GetProcAddress(Shell32Lib, 'SHCreateItemFromParsingName'); // Do not localize
if Assigned(_SHCreateItemFromParsingName) then
Result := _SHCreateItemFromParsingName(pszPath, pbc, riid, ppv);
end;
end;
end;
function SHCreateItemFromIDList(pidl: PItemIDList; const riid: TIID; out ppv): HResult;
begin
if Assigned(_SHCreateItemFromIDList) then
Result := _SHCreateItemFromIDList(pidl, riid, ppv)
else
begin
InitShlObj;
Result := E_NOTIMPL;
if Shell32Lib > 0 then
begin
_SHCreateItemFromIDList := GetProcAddress(Shell32Lib, 'SHCreateItemFromIDList'); // Do not localize
if Assigned(_SHCreateItemFromIDList) then
Result := _SHCreateItemFromIDList(pidl, riid, ppv);
end;
end;
end;
end.

259
Windows7/dwTaskbarComponents.pas Normal file
View File

@ -0,0 +1,259 @@
unit dwTaskbarComponents;
interface
{$INCLUDE 'DelphiVersions.inc'}
uses
Classes, Controls, Messages, dwTaskbarList;
procedure InitCommonControls; stdcall;
type
TdwTaskbarWinControl = class(TWinControl)
private
FIn32BitMode: Boolean;
FTaskbarList: ITaskbarList;
FTaskbarList2: ITaskbarList2;
FTaskbarList3: ITaskbarList3;
FTaskBarEntryHandle: THandle;
function GetTaskBarEntryHandle: THandle;
protected
procedure CreateParams(var Params: TCreateParams); override;
property In32BitMode: Boolean read FIn32BitMode;
property TaskbarList: ITaskbarList read FTaskbarList;
property TaskbarList2: ITaskbarList2 read FTaskbarList2;
property TaskbarList3: ITaskbarList3 read FTaskbarList3;
protected
class function GetComCtrlClass: Integer; virtual; abstract;
class function GetComCtrlClassName: PChar; virtual; abstract;
public
constructor Create(AOwner: TComponent); override;
property TaskBarEntryHandle: THandle read GetTaskBarEntryHandle write FTaskBarEntryHandle;
end;
TdwTaskbarComponent = class(TComponent)
private
FHandle: Cardinal;
FMsgAutoInitialize: Cardinal;
FMsgUpdate: Cardinal;
FAutoInitialize: Boolean;
FIsInitialized: Boolean;
FTaskbarList: ITaskbarList;
FTaskbarList2: ITaskbarList2;
FTaskbarList3: ITaskbarList3;
FTaskBarEntryHandle: THandle;
function GetTaskBarEntryHandle: THandle;
protected
procedure CheckInitalization;
procedure SendUpdateMessage;
function DoInitialize: Boolean; virtual;
procedure DoUpdate; virtual;
property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize default True;
property TaskbarList: ITaskbarList read FTaskbarList;
property TaskbarList2: ITaskbarList2 read FTaskbarList2;
property TaskbarList3: ITaskbarList3 read FTaskbarList3;
property Handle: Cardinal read FHandle;
function HandleAllocated: Boolean;
procedure WndProc(var Message: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property TaskBarEntryHandle: THandle read GetTaskBarEntryHandle write FTaskBarEntryHandle;
property IsInitialized: Boolean read FIsInitialized;
end;
implementation
uses
Forms, ComCtrls, Windows, ComObj, SysUtils;
procedure InitCommonControls; stdcall; external comctl32;
{ TdwCommon }
constructor TdwTaskbarWinControl.Create(AOwner: TComponent);
var
Obj: IInterface;
begin
inherited;
FIn32BitMode := InitCommonControl(GetComCtrlClass);
Obj := CreateComObject(CLSID_TaskbarList);
if Obj = nil then
begin
FTaskbarList := nil;
end
else
begin
FTaskbarList := ITaskbarList(Obj);
FTaskbarList.HrInit;
FTaskbarList.QueryInterface(CLSID_TaskbarList2, FTaskbarList2);
FTaskbarList.QueryInterface(CLSID_TaskbarList3, FTaskbarList3);
end;
end;
procedure TdwTaskbarWinControl.CreateParams(var Params: TCreateParams);
begin
if not In32BitMode then
InitCommonControls;
inherited;
CreateSubClass(Params, GetComCtrlClassName);
end;
function TdwTaskbarWinControl.GetTaskBarEntryHandle: THandle;
begin
if FTaskBarEntryHandle <> 0 then
begin
Result := FTaskBarEntryHandle;
end
else
begin
{$IFNDEF Delphi2007_Up}
Result := Application.Handle;
{$ELSE}
if not Application.MainFormOnTaskBar then
begin
Result := Application.Handle;
end
else
begin
Result := Application.MainForm.Handle;
end;
{$ENDIF}
end;
end;
{ TdwCommonComponent }
procedure TdwTaskbarComponent.CheckInitalization;
begin
if FIsInitialized then
raise Exception.Create('Thumbnails are initialized already.');
end;
constructor TdwTaskbarComponent.Create(AOwner: TComponent);
var
Obj: IInterface;
begin
inherited;
Obj := CreateComObject(CLSID_TaskbarList);
if Obj = nil then
begin
FTaskbarList := nil;
end
else
begin
FTaskbarList := ITaskbarList(Obj);
FTaskbarList.HrInit;
FTaskbarList.QueryInterface(CLSID_TaskbarList2, FTaskbarList2);
FTaskbarList.QueryInterface(CLSID_TaskbarList3, FTaskbarList3);
end;
if not (csDesigning in ComponentState) then
begin
FHandle := Classes.AllocateHWnd(WndProc);
end
else
begin
FHandle := 0;
end;
FAutoInitialize := True;
FIsInitialized := False;
FMsgAutoInitialize := RegisterWindowMessage('dw.Component.Taskbar.Thumbnails.Auto.Initialize');
FMsgUpdate := RegisterWindowMessage('dw.Component.Taskbar.Thumbnails.Update');
if HandleAllocated then
PostMessage(Handle, FMsgAutoInitialize, 0, 0);
end;
destructor TdwTaskbarComponent.Destroy;
begin
if HandleAllocated then
begin
Classes.DeallocateHWnd(FHandle);
FHandle := 0;
end;
inherited;
end;
function TdwTaskbarComponent.DoInitialize: Boolean;
begin
Result := True;
end;
procedure TdwTaskbarComponent.DoUpdate;
begin
end;
function TdwTaskbarComponent.GetTaskBarEntryHandle: THandle;
begin
if FTaskBarEntryHandle <> 0 then
begin
Result := FTaskBarEntryHandle;
end
else
begin
{$IFNDEF Delphi2007_Up}
Result := Application.Handle;
{$ELSE}
if not Application.MainFormOnTaskBar then
begin
Result := Application.Handle;
end
else
begin
Result := Application.MainForm.Handle;
end;
{$ENDIF}
end;
end;
function TdwTaskbarComponent.HandleAllocated: Boolean;
begin
Result := FHandle <> 0;
end;
procedure TdwTaskbarComponent.SendUpdateMessage;
begin
if HandleAllocated then
if FIsInitialized then
PostMessage(Handle, FMsgUpdate, 0, 0);
end;
procedure TdwTaskbarComponent.WndProc(var Message: TMessage);
begin
if Message.Msg = FMsgAutoInitialize then
begin
if FAutoInitialize then
begin
FIsInitialized := DoInitialize;
end;
end
else
if Message.Msg = FMsgUpdate then
begin
if FIsInitialized then
DoUpdate;
end;
end;
end.

100
Windows7/dwTaskbarList.pas Normal file
View File

@ -0,0 +1,100 @@
unit dwTaskbarList;
interface
{$INCLUDE 'DelphiVersions.inc'}
uses
Windows;
{$IFNDEF Delphi2007_Up}
type
ULONGLONG = UInt64;
{$ENDIF}
const
CLSID_TaskbarList: TGUID = '{56FDF344-FD6D-11D0-958A-006097C9A090}';
CLSID_TaskbarList2: TGUID = '{602D4995-B13A-429B-A66E-1935E44F4317}';
CLSID_TaskbarList3: TGUID = '{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}';
const
THBF_ENABLED = $0000;
THBF_DISABLED = $0001;
THBF_DISMISSONCLICK = $0002;
THBF_NOBACKGROUND = $0004;
THBF_HIDDEN = $0008;
const
THB_BITMAP = $0001;
THB_ICON = $0002;
THB_TOOLTIP = $0004;
THB_FLAGS = $0008;
const
THBN_CLICKED = $1800;
const
TBPF_NOPROGRESS = $00;
TBPF_INDETERMINATE = $01;
TBPF_NORMAL = $02;
TBPF_ERROR= $04;
TBPF_PAUSED = $08;
const
TBATF_USEMDITHUMBNAIL: DWORD = $00000001;
TBATF_USEMDILIVEPREVIEW: DWORD = $00000002;
const
WM_DWMSENDICONICTHUMBNAIL = $0323;
WM_DWMSENDICONICLIVEPREVIEWBITMAP = $0326;
type
TTipString = array[0..259] of WideChar;
PTipString = ^TTipString;
tagTHUMBBUTTON = packed record
dwMask: DWORD;
iId: UINT;
iBitmap: UINT;
hIcon: HICON;
szTip: TTipString;
dwFlags: DWORD;
end;
THUMBBUTTON = tagTHUMBBUTTON;
THUMBBUTTONLIST = ^THUMBBUTTON;
TThumbButton = THUMBBUTTON;
TThumbButtonList = array of TThumbButton;
type
ITaskbarList = interface
['{56FDF342-FD6D-11D0-958A-006097C9A090}']
procedure HrInit; safecall;
procedure AddTab(hwnd: Cardinal); safecall;
procedure DeleteTab(hwnd: Cardinal); safecall;
procedure ActivateTab(hwnd: Cardinal); safecall;
procedure SetActiveAlt(hwnd: Cardinal); safecall;
end;
ITaskbarList2 = interface(ITaskbarList)
['{602D4995-B13A-429B-A66E-1935E44F4317}']
procedure MarkFullscreenWindow(hwnd: Cardinal; fFullscreen: Bool); safecall;
end;
ITaskbarList3 = interface(ITaskbarList2)
['{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}']
procedure SetProgressValue(hwnd: Cardinal; ullCompleted, ullTotal: ULONGLONG); safecall;
procedure SetProgressState(hwnd: Cardinal; tbpFlags: DWORD); safecall;
procedure RegisterTab(hwndTab: Cardinal; hwndMDI: Cardinal); safecall;
procedure UnregisterTab(hwndTab: Cardinal); safecall;
procedure SetTabOrder(hwndTab: Cardinal; hwndInsertBefore: Cardinal); safecall;
procedure SetTabActive(hwndTab: Cardinal; hwndMDI: Cardinal; tbatFlags: DWORD); safecall;
procedure ThumbBarAddButtons(hwnd: Cardinal; cButtons: UINT; Button: THUMBBUTTONLIST); safecall;
procedure ThumbBarUpdateButtons(hwnd: Cardinal; cButtons: UINT; pButton: THUMBBUTTONLIST); safecall;
procedure ThumbBarSetImageList(hwnd: Cardinal; himl: Cardinal); safecall;
procedure SetOverlayIcon(hwnd: Cardinal; hIcon: HICON; pszDescription: LPCWSTR); safecall;
procedure SetThumbnailTooltip(hwnd: Cardinal; pszTip: LPCWSTR); safecall;
function SetThumbnailClip(hwnd: Cardinal; prcClip: PRect):Cardinal; safecall;
end;
implementation
end.

410
Windows7/dwTaskbarThumbnails.pas Normal file
View File

@ -0,0 +1,410 @@
unit dwTaskbarThumbnails;
interface
uses
Classes, Messages, ImgList, AppEvnts, Windows,
dwTaskbarComponents, dwTaskbarList;
type
TdwTaskbarThumbnails = class;
TdwTaskbarThumbnailList = class;
TdwTaskbarThumbnailItem = class;
TOnThumbnailClick = procedure(Sender: TdwTaskbarThumbnailItem) of object;
TdwTaskbarThumbnailItem = class(TCollectionItem)
private
FImageIndex: Integer;
FHint: WideString;
FEnabled: Boolean;
FShowBorder: Boolean;
FDismissOnClick: Boolean;
FVisible: Boolean;
FTag: Integer;
procedure SetImageIndex(const Value: Integer);
procedure SetHint(const Value: WideString);
procedure SetEnabled(const Value: Boolean);
procedure SetShowBorder(const Value: Boolean);
procedure SetDismissOnClick(const Value: Boolean);
procedure SetVisible(const Value: Boolean);
protected
public
constructor Create(Collection: TCollection); override;
procedure Assign(Source: TPersistent); override;
published
property ImageIndex: Integer read FImageIndex write SetImageIndex;
property Hint: WideString read FHint write SetHint;
property Enabled: Boolean read FEnabled write SetEnabled default True;
property ShowBorder: Boolean read FShowBorder write SetShowBorder default True;
property DismissOnClick: Boolean read FDismissOnClick write SetDismissOnClick default False;
property Visible: Boolean read FVisible write SetVisible default True;
property Tag: Integer read FTag write FTag default 0;
end;
TdwTaskbarThumbnailList = class(TCollection)
private
FTaskbarThumbnails: TdwTaskbarThumbnails;
function GetItem(Index: Integer): TdwTaskbarThumbnailItem;
procedure SetItem(Index: Integer; Value: TdwTaskbarThumbnailItem);
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
public
constructor Create(TaskbarThumbnails: TdwTaskbarThumbnails);
function Add: TdwTaskbarThumbnailItem;
function AddItem(Item: TdwTaskbarThumbnailItem; Index: Integer): TdwTaskbarThumbnailItem;
function Insert(Index: Integer): TdwTaskbarThumbnailItem;
property Items[Index: Integer]: TdwTaskbarThumbnailItem read GetItem write SetItem; default;
end;
TdwTaskbarThumbnails = class(TdwTaskbarComponent)
private
FAppEvents: TApplicationEvents;
FImages: TCustomImageList;
FThumbnails: TdwTaskbarThumbnailList;
FOnThumbnailClick: TOnThumbnailClick;
procedure SetImages(const Value: TCustomImageList);
procedure UpdateThumbnail(Index: Integer);
procedure UpdateThumbnails;
procedure SetThumbnails(const Value: TdwTaskbarThumbnailList);
function GetThumbButtons: TThumbButtonList;
procedure DoAppMessage(var Msg: TMsg; var Handled: Boolean);
protected
function DoInitialize: Boolean; override;
procedure DoUpdate; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ShowThumbnails;
function ClipThumbnail(window:Cardinal; left:integer; right:integer; top:integer; bottom:integer):cardinal;
published
property AutoInitialize;
property Images: TCustomImageList read FImages write SetImages;
property Thumbnails: TdwTaskbarThumbnailList read FThumbnails write SetThumbnails;
property OnThumbnailClick: TOnThumbnailClick read FOnThumbnailClick write FOnThumbnailClick;
end;
implementation
uses
SysUtils, Graphics;
{ TdwTaskbarThumbnailItem }
procedure TdwTaskbarThumbnailItem.Assign(Source: TPersistent);
begin
if Source is TdwTaskbarThumbnailItem then
begin
Self.FImageIndex := (Source as TdwTaskbarThumbnailItem).FImageIndex;
Self.FHint := (Source as TdwTaskbarThumbnailItem).FHint;
Self.FEnabled := (Source as TdwTaskbarThumbnailItem).FEnabled;
Self.FShowBorder := (Source as TdwTaskbarThumbnailItem).FShowBorder;
Self.FDismissOnClick := (Source as TdwTaskbarThumbnailItem).FDismissOnClick;
Self.FVisible := (Source as TdwTaskbarThumbnailItem).FVisible;
Self.FTag := (Source as TdwTaskbarThumbnailItem).FTag;
end
else
begin
inherited Assign(Source);
end;
end;
constructor TdwTaskbarThumbnailItem.Create(Collection: TCollection);
begin
inherited Create(Collection);
FImageIndex := Index;
FHint := '';
FEnabled := True;
FShowBorder := True;
FDismissOnClick := False;
FVisible := True;
FTag := 0;
end;
procedure TdwTaskbarThumbnailItem.SetDismissOnClick(const Value: Boolean);
begin
if FDismissOnClick <> Value then
begin
FDismissOnClick := Value;
Changed(False);
end;
end;
procedure TdwTaskbarThumbnailItem.SetEnabled(const Value: Boolean);
begin
if FEnabled <> Value then
begin
FEnabled := Value;
Changed(False);
end;
end;
procedure TdwTaskbarThumbnailItem.SetHint(const Value: WideString);
begin
if FHint <> Value then
begin
FHint := Value;
Changed(False);
end;
end;
procedure TdwTaskbarThumbnailItem.SetImageIndex(const Value: Integer);
begin
if FImageIndex <> Value then
begin
FImageIndex := Value;
Changed(False);
end;
end;
procedure TdwTaskbarThumbnailItem.SetShowBorder(const Value: Boolean);
begin
if FShowBorder <> Value then
begin
FShowBorder := Value;
Changed(False);
end;
end;
procedure TdwTaskbarThumbnailItem.SetVisible(const Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
Changed(False);
end;
end;
{ TdwTaskbarThumbnailList }
function TdwTaskbarThumbnailList.Add: TdwTaskbarThumbnailItem;
begin
FTaskbarThumbnails.CheckInitalization;
Result := AddItem(nil, -1);
end;
function TdwTaskbarThumbnailList.AddItem(Item: TdwTaskbarThumbnailItem; Index: Integer): TdwTaskbarThumbnailItem;
begin
FTaskbarThumbnails.CheckInitalization;
if Item = nil then
begin
Result := TdwTaskbarThumbnailItem.Create(Self);
end
else
begin
Result := Item;
if Assigned(Item) then
begin
Result.Collection := Self;
if Index < Count then
Index := Count - 1;
Result.Index := Index;
end;
end;
end;
constructor TdwTaskbarThumbnailList.Create(TaskbarThumbnails: TdwTaskbarThumbnails);
begin
inherited Create(TdwTaskbarThumbnailItem);
FTaskbarThumbnails := TaskbarThumbnails;
end;
function TdwTaskbarThumbnailList.GetItem(Index: Integer): TdwTaskbarThumbnailItem;
begin
Result := TdwTaskbarThumbnailItem(inherited GetItem(Index));
end;
function TdwTaskbarThumbnailList.GetOwner: TPersistent;
begin
Result := FTaskbarThumbnails;
end;
function TdwTaskbarThumbnailList.Insert(Index: Integer): TdwTaskbarThumbnailItem;
begin
FTaskbarThumbnails.CheckInitalization;
Result := AddItem(nil, Index);
end;
procedure TdwTaskbarThumbnailList.SetItem(Index: Integer; Value: TdwTaskbarThumbnailItem);
begin
inherited SetItem(Index, Value);
end;
procedure TdwTaskbarThumbnailList.Update(Item: TCollectionItem);
begin
if Item <> nil then
FTaskbarThumbnails.UpdateThumbnail(Item.Index)
else
FTaskbarThumbnails.UpdateThumbnails;
end;
{ TdwTaskbarThumbnails }
constructor TdwTaskbarThumbnails.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FThumbnails := TdwTaskbarThumbnailList.Create(Self);
FAppEvents := TApplicationEvents.Create(Self);
FAppEvents.OnMessage := DoAppMessage;
end;
destructor TdwTaskbarThumbnails.Destroy;
begin
FThumbnails.Free;
FAppEvents.Free;
inherited;
end;
procedure TdwTaskbarThumbnails.DoAppMessage(var Msg: TMsg; var Handled: Boolean);
begin
if Msg.hwnd = TaskBarEntryHandle then
if Msg.message = WM_COMMAND then
if HiWord(Msg.wParam) = THBN_CLICKED then
begin
Handled := True;
if Assigned(FOnThumbnailClick) then
FOnThumbnailClick(FThumbnails[LoWord(Msg.wParam)]);
end;
end;
function TdwTaskbarThumbnails.ClipThumbnail(window:Cardinal; left:integer; right:integer; top:integer; bottom:integer):cardinal;
var
rect:TRect;
rectp:PRect;
begin
//rect:=TRect.Create;
rect.Left := left;
rect.Top := top;
rect.Right := right;
rect.Bottom := bottom;
rectp:=@rect;
if (TaskbarList3<>nil) then
Result := TaskbarList3.SetThumbnailClip(window, rectp)
else
Result := 16777216;
end;
function TdwTaskbarThumbnails.DoInitialize: Boolean;
var
Buttons: TThumbButtonList;
begin
SetLength(Buttons, 0);
if CheckWin32Version(6, 1) and (TaskbarList3 <> nil) then
begin
Buttons := GetThumbButtons;
if TaskbarList3 <> nil then
begin
TaskbarList3.ThumbBarSetImageList(TaskBarEntryHandle, FImages.Handle);
TaskbarList3.ThumbBarAddButtons(TaskBarEntryHandle, Length(Buttons), @Buttons[0]);
Result := True;
end
else
begin
Result := False;
end;
end
else
begin
Result := False;
end;
end;
procedure TdwTaskbarThumbnails.DoUpdate;
var
Buttons: TThumbButtonList;
begin
SetLength(Buttons, 0);
if not IsInitialized then
Exit;
Buttons := GetThumbButtons;
TaskbarList3.ThumbBarSetImageList(TaskBarEntryHandle, FImages.Handle);
TaskbarList3.ThumbBarUpdateButtons(TaskBarEntryHandle, Length(Buttons), @Buttons[0]);
end;
function TdwTaskbarThumbnails.GetThumbButtons: TThumbButtonList;
var
I: Integer;
Thumb: TdwTaskbarThumbnailItem;
begin
if (FThumbnails.Count < 1) or (FThumbnails.Count > 7) then
raise Exception.Create('The thumbnail count must be at least 1 and can be up to 7.');
SetLength(Result, FThumbnails.Count);
for I := 0 to FThumbnails.Count - 1 do
begin
Thumb := FThumbnails[I];
Result[I].dwMask := THB_FLAGS;
Result[I].iId := Thumb.Index;
if FImages <> nil then
if (Thumb.ImageIndex >= 0) and (Thumb.ImageIndex < FImages.Count) then
begin
Result[I].dwMask := Result[I].dwMask or THB_BITMAP;
Result[I].iBitmap := Thumb.ImageIndex;
end;
if Thumb.FHint <> '' then
begin
Result[I].dwMask := Result[I].dwMask or THB_TOOLTIP;
StringToWideChar(Thumb.Hint, Result[I].szTip, Length(Result[I].szTip));
end;
Result[I].dwFlags := 0;
if Thumb.FEnabled then
Result[I].dwFlags := Result[I].dwFlags or THBF_ENABLED
else
Result[I].dwFlags := Result[I].dwFlags or THBF_DISABLED;
if not Thumb.FShowBorder then
Result[I].dwFlags := Result[I].dwFlags or THBF_NOBACKGROUND;
if Thumb.DismissOnClick then
Result[I].dwFlags := Result[I].dwFlags or THBF_DISMISSONCLICK;
if not Thumb.Visible then
Result[I].dwFlags := Result[I].dwFlags or THBF_HIDDEN;
end;
end;
procedure TdwTaskbarThumbnails.SetImages(const Value: TCustomImageList);
begin
FImages := Value;
SendUpdateMessage;
end;
procedure TdwTaskbarThumbnails.SetThumbnails(const Value: TdwTaskbarThumbnailList);
begin
FThumbnails.Assign(Value);
SendUpdateMessage;
end;
procedure TdwTaskbarThumbnails.ShowThumbnails;
begin
CheckInitalization;
DoInitialize;
end;
procedure TdwTaskbarThumbnails.UpdateThumbnail(Index: Integer);
begin
SendUpdateMessage;
end;
procedure TdwTaskbarThumbnails.UpdateThumbnails;
begin
SendUpdateMessage;
end;
end.