(************************************************************************
*    This File is Part of the AHM Triton Tools                          *
*    for Borland Delphi and C++ Builder.                                *
*************************************************************************
* Copyright © 1995-1999 Alexander H. Mehlhorn (AHM) and Tritontools.com *
* All Rights reserved.                                                  *
*                                                                       *
*    For more Information contact us at                                 *
*    E-Mail : support@tritontools.com                                   *
*    URL : http://www.tritontools.com                                   *
*                                                                       *
*    AHM is copyright by Alexander H. Mehlhorn                          *
*    All Parts of this Collection were developed,                       *
*    designed and implemented by AHM                                    *
*                                                                       *
*    Under no Circumstances may you distribute this file                *
*    in this or any other format. This File is supplied                 *
*    as Evaluation of Source only. No Delphi Components may be developed*
*    using extracts or subsets of this code without expressed permission*
*    by AHM.                                                            *
*                                                                       *
*************************************************************************)
unit AHMTShellLinks;
interface
{$I AHM.INC}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ShlObj,ActiveX, ComObj,Menus,AHMSystemClass,AHMSystemConst,ShellApi;
type
  TAHMShellRoots=(aUserDefined,cDesktop,cInternet,cPrograms,cControls,cPrinters,cPersonal,cFavourites,cStartup,
    cRecent,cSendTo,cBitBucket,cStartMenu,cDesktopDirectory,cDrives,cNetwork,
    cNethood,cFonts,cTemplates,cCommonStartMenu,cCommonPrograms,cCommomStartup,
    cCommonDesktopDirectory,cAppData,cPrintHood,cAltStartup,cCommonAltStartup,
    cCommonFavourites,cInternetCache,cCookies,cHistory);
  TAHMShellLinks = class;
  TAHMShortCuts = class;
  TAHMShortCut = class;
  TAHMShortCutDetails = class(TPersistent)
  private
    FDescription: String;
    FParameters: String;
    FTargetFile: String;
    FStartupDir: String;
    FIconFile: TFileName;
    FShortCutKey: TShortCut;
    FStartupState: TWindowState;
    FIconIndex: Integer;
    FOwner : TAHMShortCut;
  protected
  public
    Function Install : Boolean;
    Function Import(const ShortCutShortCutName : String) : Boolean;
    constructor Create(AOwner: TAHMShortCut);
  published
    property Parameters : String read FParameters write FParameters;
    property Description : String read FDescription write FDescription;
    property IconFile : TFileName read FIconFile write FIconFile;
    property IconIndex : Integer read FIconIndex write FIconIndex default 0;
    property TargetFile : String read FTargetFile write FTargetFile;
    property StartupDir : String read FStartupDir write FStartupDir;
    property ShortCutKey : TShortCut read FShortCutKey write FShortCutKey default 0;
    property StartupState : TWindowState read FStartupState write FStartupState default wsNormal;
  end;
  TAHMShortCut = class(TCollectionItem)
  private
    FShortCutName: String;
    FPath: String;
    FPathtype: TAHMShellRoots;
    FProperties: TAHMShortCutDetails;
    FAutoInstall: Boolean;
    FAHMShellLinks : TAHMShellLinks;
    FPathExtra: String;
    procedure SetShortCutName(const Value: String);
    procedure SetPath(const Value: String);
    procedure SetPathType(const Value: TAHMShellRoots);
    Function IsUserDefined : Boolean;
    procedure SetPathExtra(const Value: String);
    function GetIcon: TIcon;
  protected
    function GetDisplayName: string; override;
  public
    destructor Destroy; override;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property Owner : TAHMShellLinks read FAHMShellLinks;
    property DisplayName : String read GetDisplayName;
    property Icon : TIcon read GetIcon;
  published
    property AutoInstall : Boolean read FAutoInstall write FAutoInstall default False;
    property ShortCutName : String read FShortCutName write SetShortCutName;
    property PathType : TAHMShellRoots read FPathtype write SetPathType default aUserDefined;
    property PathExtra : String read FPathExtra write SetPathExtra;
    property Path : String read FPath write SetPath stored IsUserDefined;
    property Properties : TAHMShortCutDetails read FProperties write FProperties;
  end;
  TAHMShortCuts = class(TCollection)
  private
    FAHMShellLinks : TAHMShellLinks;
    function GetAHMShortCut(Index: Integer): TAHMShortCut;
    procedure SetAHMShortCut(Index: Integer; Value: TAHMShortCut);
  protected
    function GetOwner : TPersistent; override;
  public
    constructor Create(AOwner: TAHMShellLinks);
    function Add : TAHMShortCut;
   Function Delete(Index :Integer) :Boolean;
    property Owner : TAHMShellLinks read FAHMShellLinks;
    property Items[Index: Integer]: TAHMShortCut
             read GetAHMShortCut write SetAHMShortCut; default;
  end;
  TAHMShellLinks = class(TAHMSystemsComponent)
  private
    FAHMShortCuts : TAHMShortCuts;
    procedure SetAHMShortCuts(Value: TAHMShortCuts);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
    Function Install(Index : Integer) : Boolean;
    Function Import(ShortCutFile : String) : Boolean;
    destructor Destroy; override;
  published
    property ShortCuts : TAHMShortCuts read FAHMShortCuts write SetAHMShortCuts;
  end;

implementation
const
  AHMCSIDL_DESKTOP                       = $0000;
  AHMCSIDL_PROGRAMS                      = $0002;
  AHMCSIDL_CONTROLS                      = $0003;
  AHMCSIDL_PRINTERS                      = $0004;
  AHMCSIDL_PERSONAL                      = $0005;
  AHMCSIDL_FAVORITES                     = $0006;
  AHMCSIDL_STARTUP                       = $0007;
  AHMCSIDL_RECENT                        = $0008;
  AHMCSIDL_SENDTO                        = $0009;
  AHMCSIDL_BITBUCKET                     = $000a;
  AHMCSIDL_STARTMENU                     = $000b;
  AHMCSIDL_DESKTOPDIRECTORY              = $0010;
  AHMCSIDL_DRIVES                        = $0011;
  AHMCSIDL_NETWORK                       = $0012;
  AHMCSIDL_NETHOOD                       = $0013;
  AHMCSIDL_FONTS                         = $0014;
  AHMCSIDL_TEMPLATES                     = $0015;
  AHMCSIDL_COMMON_STARTMENU              = $0016;
  AHMCSIDL_COMMON_PROGRAMS               = $0017;
  AHMCSIDL_COMMON_STARTUP                = $0018;
  AHMCSIDL_COMMON_DESKTOPDIRECTORY       = $0019;
  AHMCSIDL_APPDATA                       = $001a;
  AHMCSIDL_PRINTHOOD                     = $001b;
  AHMCSIDL_ALTSTARTUP                = $001d;
  AHMCSIDL_COMMON_ALTSTARTUP         = $001e;
  AHMCSIDL_COMMON_FAVORITES          = $001f;
  AHMCSIDL_INTERNET_CACHE            = $0020;
  AHMCSIDL_INTERNET                      = $0001;
  AHMCSIDL_COOKIES                   = $0021;
  AHMCSIDL_HISTORY                   = $0022;
type
   PFNGetSpecialFolder = ^TFNGetSpecialFolder;
   TFNGetSpecialFolder = function(hwndOwner: HWND; lpszPath: PChar;nFolder: Integer; fCreate: BOOL): BOOL; stdcall;
Var
   AHMGetSpecialFolder : TFNGetSpecialFolder = nil;
function SHGetSpecialFolderPath(hwndOwner: HWND; lpszPath: PChar;nFolder: Integer; fCreate: BOOL): BOOL;
Var BinModule : HModule;
begin
  Result := False;
  BinModule := LoadLibrary(PChar(ahmscshell32));
  if BinModule<>0 then
  begin
    if @AHMGetSpecialFolder = nil then @AHMGetSpecialFolder := GetProcAddress(BinModule,PChar('SHGetSpecialFolderPathA'));
    if @AHMGetSpecialFolder <> nil then
    Result := AHMGetSpecialFolder(hwndOwner,lpszPath,nFolder,fCreate);
  end;
  if BinModule <> 0 then FreeLibrary(BinModule);
end;



const
  AHMShellRoots: array[TAHMShellRoots] of Integer=(-200,
AHMCSIDL_DESKTOP,AHMCSIDL_INTERNET,AHMCSIDL_PROGRAMS,AHMCSIDL_CONTROLS,AHMCSIDL_PRINTERS,AHMCSIDL_PERSONAL,
AHMCSIDL_FAVORITES,AHMCSIDL_STARTUP,AHMCSIDL_RECENT,AHMCSIDL_SENDTO,AHMCSIDL_BITBUCKET,AHMCSIDL_STARTMENU,
AHMCSIDL_DESKTOPDIRECTORY,AHMCSIDL_DRIVES,AHMCSIDL_NETWORK,AHMCSIDL_NETHOOD,AHMCSIDL_FONTS,AHMCSIDL_TEMPLATES,
AHMCSIDL_COMMON_STARTMENU,AHMCSIDL_COMMON_PROGRAMS,AHMCSIDL_COMMON_STARTUP,AHMCSIDL_COMMON_DESKTOPDIRECTORY,
AHMCSIDL_APPDATA,AHMCSIDL_PRINTHOOD,AHMCSIDL_ALTSTARTUP,AHMCSIDL_COMMON_ALTSTARTUP,AHMCSIDL_COMMON_FAVORITES,
AHMCSIDL_INTERNET_CACHE,AHMCSIDL_COOKIES,AHMCSIDL_HISTORY);


{ TAHMShortCutDetails }

function AHMExtractIcon(const ShortCutName: string; Id: Integer): TIcon;
var S: array[0..255] of char;
    IconHandle: HIcon;
    Index: Word;
begin
  Result := TIcon.Create;
  try
    StrPLCopy(S, ShortCutName, SizeOf(S) - 1);
    IconHandle := ExtractIcon(hInstance, S, Id);
    if IconHandle > 2 then
    begin
      Index := Id;
      IconHandle := ExtractAssociatedIcon(hInstance, S, Index);
    end;
    if IconHandle < 2 then
    begin
      Result.Free;
      Result := nil;
    end else Result.Handle := IconHandle;
  except
    begin
      Result.Free;
      raise;
    end;
  end;
end;


constructor TAHMShortCutDetails.Create(AOwner: TAHMShortCut);
begin
  inherited Create;
  FOwner:=AOwner;
  FStartupState := wsNormal;
  FShortCutKey:=0;
end;

function TAHMShortCutDetails.Import(const ShortCutShortCutName: String): Boolean;
var
  FString: array [0..255] of Char;
  FInteger: Integer;
  FShellLink: IUnknown;
  FIShellLink: IShellLink;
  PFile : IPersistFile;
  Data: TWin32FindData;
  pwHotKey: word;
begin
  result:=True;
  FShellLink := CreateComObject(CLSID_ShellLink);
  FIShellLink := FShellLink as IShellLink;
  PFile := FShellLink as IPersistFile;
  if PFile.Load(PWChar(WideString(ShortCutShortCutName)), STGM_READ) <> S_OK then exit;
  FOwner.FShortCutName:=ExtractFileName(ShortCutShortCutName);
  FOwner.FPath:=ExtractFilePath(ShortCutShortCutName);
  FillChar(FString,SizeOf(FString),0);
  FIShellLink.GetArguments(FString,SizeOf(FString));
  FParameters:=FString;
  FillChar(FString,SizeOf(FString),0);
  FIShellLink.GetDescription(FString,SizeOf(FString));
  if FString<>'' then FDescription:=FString else FDescription:=Copy(ExtractFilename(ShortCutShortCutName),1,Pos(ExtractFileExt(ShortCutShortCutName),ExtractFilename(ShortCutShortCutName))-1);
  FIShellLink.GetHotKey(pwHotKey);
  FShortCutKey:=pwHotKey;
  FillChar(FString,SizeOf(FString),0);
  FIShellLink.GetPath(FString,Sizeof(FString),Data,SLGP_UNCPRIORITY);
  FTargetFile:=FString;
  FillChar(FString,SizeOf(FString),0);
  FIShellLink.GetIconLocation(FString,SizeOf(FString),FInteger);
  if FString<>'' then FIconFile:=FString else FIconFile:=FtargetFile;
  FIconIndex:=FInteger;
  FIShellLink.GetShowCmd(FInteger);
  case FInteger of
    SW_SHOWNORMAL: FStartupState := wsNormal;
    SW_MINIMIZE: FStartupState := wsMinimized;
    SW_MAXIMIZE: FStartupState := wsMaximized;
  end;
  FillChar(FString,SizeOf(FString),0);
  FIShellLink.GetWorkingDirectory(FString,Sizeof(FString));
  FStartupDir := FString;
end;

function TAHMShortCutDetails.Install: Boolean;
var
  FString: array [0..255] of Char;
  FShellLink: IUnknown;
  FIShellLink: IShellLink;
  PFile: IPersistFile;
  FWString :String;
begin
  result:=True;
  try
    FShellLink := CreateComObject(CLSID_ShellLink);
    FIShellLink := FShellLink as IShellLink;
    PFile := FShellLink as IPersistFile;
    FIShellLink.SetArguments(PChar(FParameters));
    FIShellLink.SetDescription(PChar(FDescription));
    FIShellLink.SetHotKey(FShortCutKey);
    if FIconFile <> '' then FIShellLink.SetIconLocation(PChar(FIconFile),FIconIndex);
    FIShellLink.SetPath(PChar(FTargetFile));
    case FStartupState of
      wsNormal   : FIShellLink.SetShowCmd(SW_SHOWNORMAL);
      wsMinimized: FIShellLink.SetShowCmd(SW_MINIMIZE);
      wsMaximized: FIShellLink.SetShowCmd(SW_MAXIMIZE);
    end;
    if FStartupDir='' then FStartupDir:=ExtractFilePath(FTargetFile);
    FIShellLink.SetWorkingDirectory(PChar(FStartupDir));
    FillChar(FString,SizeOf(FString),0);
    if FOwner.FPathType<>aUserDefined then
      SHGetSpecialFolderPath(Application.Handle,@FString,AHMShellRoots[FOwner.FPathtype],False)
    else StrPCopy(FString,PChar(FOwner.FPath));
    FWString:=String(FString);
    if FWString<>'' then
    if FWString[Length(FWString)]<>'\' then FWString:=FWString+'\'+FOwner.FPathExtra;
    CreateDir(FWString);
    PFile.Save(PWChar(WideString(FWString+FOwner.FShortCutName)),False);
  except

    result:=false;
  end;
end;

{ TAHMShortCut }

constructor TAHMShortCut.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FAHMShellLinks :=(((Collection as TAHMShortCuts).GetOwner) as TAHMShellLinks);
  FProperties:=TAHMShortCutDetails.Create(Self);
  FAutoInstall:=False;
  FPathType:=aUserDefined;
end;

destructor TAHMShortCut.Destroy;
begin
  inherited Destroy;
end;

procedure TAHMShortCut.SetShortCutName(const Value: String);
begin
  if IsUserDefined then
  begin
    FPath:=ExtractFilePath(Value);
    FShortCutName := ChangeFileExt(ExtractFilename(Value),'.lnk');
  end else FShortCutName := ChangeFileExt(ExtractFilename(Value),'.lnk');
end;

procedure TAHMShortCut.SetPath(const Value: String);
begin
  if IsUserDefined then FPath := Value else FPath:='';
end;

procedure TAHMShortCut.SetPathType(const Value: TAHMShellRoots);
begin
  FPathtype := Value;
  SetPath(FPath);
end;

Function TAHMShortCut.IsUserDefined : Boolean;
begin
  result:=(FPathType=aUserDefined);
end;

function TAHMShortCut.GetDisplayName: string;
begin
  if FShortCutName<>'' then result:=FProperties.FDescription else result:='Windows Shortcut';
end;

function TAHMShortCuts.GetOwner: TPersistent;
begin
  Result := FAHMShellLinks;
end;

procedure TAHMShortCut.Assign(Source: TPersistent);
begin
  if Source is TAHMShortCut then
  begin
    AutoInstall :=TAHMShortCut(Source).AutoInstall;
    ShortCutName :=TAHMShortCut(Source).ShortCutName;
    PathType :=TAHMShortCut(Source).PathType;
    Path  :=TAHMShortCut(Source).Path;
    Properties.Parameters :=TAHMShortCut(Source).Properties.Parameters;
    Properties.Description :=TAHMShortCut(Source).Properties.Description;
    Properties.IconFile :=TAHMShortCut(Source).Properties.IconFile;
    Properties.IconIndex :=TAHMShortCut(Source).Properties.IconIndex;
    Properties.TargetFile :=TAHMShortCut(Source).Properties.TargetFile;
    Properties.StartupDir :=TAHMShortCut(Source).Properties.StartupDir;
    Properties.ShortCutKey :=TAHMShortCut(Source).Properties.ShortCutKey;
    Properties.StartupState :=TAHMShortCut(Source).Properties.StartupState;
    Exit;
  end;
  inherited Assign(Source);
end;

constructor TAHMShortCuts.Create(AOwner: TAHMShellLinks);
begin
  inherited Create(TAHMShortCut);
  FAHMShellLinks := AOwner;
end;

function TAHMShortCuts.Add: TAHMShortCut;
begin
  Result := TAHMShortCut(inherited Add);
end;

function TAHMShortCuts.GetAHMShortCut(Index: Integer): TAHMShortCut;
begin
  Result := TAHMShortCut(inherited GetItem(Index));
end;

procedure TAHMShortCuts.SetAHMShortCut(Index: Integer; Value: TAHMShortCut);
begin
  inherited SetItem(Index, Value);
end;

constructor TAHMShellLinks.Create(AOwner: TComponent);
begin
  inherited create(AOwner);
  FAHMShortCuts:=TAHMShortCuts.Create(self);
end;

destructor TAHMShellLinks.Destroy;
begin
  FAHMShortCuts.Free;
  inherited Destroy;
end;

function TAHMShellLinks.Import(ShortCutFile: String): Boolean;
begin
  if FileExists(ShortCutFile) then
  begin
    with FAHMShortCuts.Add do
    result:=Properties.Import(ShortCutFile)
  end else result:=False;
end;

function TAHMShellLinks.Install(Index: Integer): Boolean;
begin
  if Index<=ShortCuts.Count-1 then
    result:=ShortCuts[Index].Properties.Install
  else result:=false;
end;

procedure TAHMShellLinks.Loaded;
Var I : Integer;
begin
  inherited Loaded;
  If not(csdesigning in Componentstate) then
  For I:=0 to ShortCuts.Count-1 do
    if ShortCuts[I].FAutoInstall then
       ShortCuts[I].Properties.Install;
end;

procedure TAHMShellLinks.SetAHMShortCuts(Value: TAHMShortCuts);
begin
  FAHMShortCuts.Assign(Value);
end;


function TAHMShortCuts.Delete(Index: Integer): Boolean;
begin
  result := true;
  Try
    Items[Index].free;
  Except
    result := false;
    Application.handleexception(self);
  End;
end;

procedure TAHMShortCut.SetPathExtra(const Value: String);
begin
  FPathExtra := Value;
  if Value<>'' then
  begin
    if FPathExtra[1]='\' then Delete(FPathExtra,1,1);
    if FPathExtra[Length(FPathExtra)]<>'\' then FPathExtra:=FPathExtra+'\';
  end;
end;

function TAHMShortCut.GetIcon: TIcon;
begin
  result:=AHMExtractIcon(FProperties.IconFile,FProperties.IconIndex);
end;

end.
