COMPOSANT : TDBPLINKMAKER CREEZ DES .LNK

{
################################################################################
# DBPLINKMAKER                                                                 #
################################################################################
#                                                                              #
# VERSION       : 1.0                                                          #
# FICHIERS      : dbpLinkMaker.pas,.dcu,.dcr,.bmp,ReadMe.htm                   #
# AUTEUR        : Julio P. (Diabloporc)                                        #
# CREATION      : 02 sep 2006                                                  #
# MODIFIEE      : 02 sep 2006                                                  #
# SITE WEB      : http://diabloporc.free.fr                                    #
# MAIL          : juliobox@free.fr                                             #
# LEGAL         : Free sous Licence GNU/GPL                                    #
# INFOS         : Retrouvez moi sur www.delphifr.com : "JulioDelphi"           #
#                 Lisez le ReadMe.htm !                                        #
#                                                                              #
################################################################################
}
unit dbpLinkMaker;

interface

uses
  Menus, Windows, SysUtils, Classes, Registry, ComObj, ActiveX, ShlObj;

type
  TShellDir = (sdMenuDemarrer, sdMenuDemarrage, sdMenuProgrammes, sdMesDocuments, sdBureau, sdOnlySubDir);

  TCreation = class(TPersistent)
  private
    FCreateDir: Boolean;
    FShellDir: TShellDir;
    FSubdir: String;
    procedure SetSubDir(Value: String);
  public
  published
    property CreateDir: Boolean read FCreateDir write FCreateDir;
    property ShellDir: TShellDir read FShellDir write FShellDir;
    property SubDir: String read FSubDir write SetSubdir;
  end;

  TTypeFenetre = (tfNormale, tfAgrandie, tfReduite);

  TdbpLinkMaker = class(TComponent)
  private
    FAbout:          String;
    FCreation:       TCreation;
    FLinkFileName:   String;
    FLinkFileTarget: String;
    FIcoFileName:    String;
    FIcoFileNb:      Integer;
    FParams:         String;
    FLaunchDir:      String;
    FCommentaires:   String;
//    FSHortCut:       String;
    FTypeFenetre:    TTypeFenetre;
    procedure FSetAbout(const s: string);
//    procedure FSetShortCut(s: string);
//    function  FGetShortCut: string;
  protected
    { Déclarations protégées }
  public
    constructor Create(aOwner: TComponent); override;
    destructor  Destroy; override;

    procedure Execute;
  published
    property About:              String read       FAbout write          FSetAbout;
    property ACreerDans:         TCreation read    FCreation write       FCreation;
    property Commentaires:       String read       FCommentaires write   FCommentaires;
    property DossierDeLancement: String read       FLaunchDir write      FLaunchDir;
    property FichierACreer:      String read       FLinkFileName write   FLinkFileName;
    property FichierALinker:     String read       FLinkFileTarget write FLinkFileTarget;
    property FichierIcone:       String read       FIcoFileName write    FIcoFileName;
    property FichierIconeNb:     Integer read      FIcoFileNb write      FIcoFileNb;
    property Parametres:         String read       FParams write         FParams;
//    property ShortCut:           String read       FGetShortCut write    FSetShortCut;
    property TypeFenetre:        TTypeFenetre read FTypeFenetre write    FTypeFenetre;
  end;

procedure Register;

implementation

{$R dbpLinkMaker.dcr}

procedure TCreation.SetSubDir(Value: String);
begin
  if (FSubDir <> Value) and (Value <> '') then
   begin
    IncludeTrailingPathDelimiter(Value);
    FSubDir := Value;
   end;
end;

constructor TdbpLinkMaker.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FCreation           := TCreation.Create;
  FCreation.CreateDir := True;
  FLinkFileName       := 'Nouveau Lien';
  fAbout              := 'v1.0 par Julio P. (Diabloporc)';
end;

destructor TdbpLinkMaker.Destroy;
begin
  FCreation.Free;
  inherited Destroy;
end;

procedure TdbpLinkMaker.FSetAbout(const s: string);
begin
//
end;
{
function TdbpLinkMaker.FGetShortCut : string;
begin
 result := FShortCut;
end;

procedure TdbpLinkMaker.FSetShortCut(s : string);
begin
 FShortCut := s;
end;
}
procedure TdbpLinkMaker.Execute;
var
  ShellObj: IUnknown;
  ShellLnk: IShellLink;
  PersistFile: IPersistFile;
  FileName: WideString;

  Reg: TRegistry;
  RegStr: String;
  i: Integer;
begin
  Reg := TRegistry.Create;
  with Reg do
   try
     RootKey := HKEY_CURRENT_USER;
     OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', True);
     case FCreation.FShellDir of
       sdMenuDemarrer:    RegStr := 'Start Menu';
       sdMenuDemarrage:   RegStr := 'Startup';
       sdMenuProgrammes:  RegStr := 'Programs';
       sdMesDocuments:    RegStr := 'Personal';
       sdBureau:          RegStr := 'Desktop';
       else               RegStr := '';
      end;
     if RegStr<>'' then
      RegStr  := IncludeTrailingPathDelimiter(ReadString(RegStr)) + IncludeTrailingPathDelimiter(FCreation.FSubDir)
     else
      RegStr  := IncludeTrailingPathDelimiter(FCreation.FSubDir);
   except
   end;
  Reg.Free;

  if FCreation.FCreateDir then ForceDirectories(RegStr);

  ShellObj    := CreateComObject(CLSID_ShellLink);
  ShellLnk    := ShellObj as IShellLink;
  PersistFile := ShellObj as IPersistFile;

  with ShellLnk do
   begin
    case FTypeFenetre of
      tfAgrandie: i := sw_ShowMaximized;
      tfReduite:  i := sw_ShowMinNoActive;
      else        i := sw_ShowNormal;
    end;
    SetArguments(PChar(FParams));
    SetDescription(PChar(FCommentaires));
    SetPath(PChar(FLinkFileTarget));
    SetWorkingDirectory(PChar(FLaunchDir));
    SetShowCmd(i);
//SetHotkey(TextToShortCut(FShortCut));
    if fIcoFileName <> '' then
     SetIconLocation(PChar(fIcoFileName),fIcoFileNb);
   end;

  FileName := RegStr + FLinkFileName + '.lnk';
  PersistFile.Save(PWChar(FileName), False);
end;

procedure Register;
begin
  RegisterComponents('Diabloporc', [TdbpLinkMaker]);
end;

end.

Télécharger le zip