unit1.pas

在深度历险网站上发布的所有delphi程序原码。对初学delphi者很有用。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ActiveX, Registry,
  StdCtrls, ExtCtrls, ComCtrls, ShlObj;

type
  TForm1 = class(TForm)
    btnCreateShellLink: TButton;
    cbxFolders: TComboBox;
    Label1: TLabel;
    GroupBox1: TGroupBox;
    Label2: TLabel;
    txtFilePath: TEdit;
    Label3: TLabel;
    txtDescription: TEdit;
    Label4: TLabel;
    txtWorkingDirectory: TEdit;
    Label5: TLabel;
    txtArguments: TEdit;
    btnExit: TButton;
    Bevel1: TBevel;
    GroupBox2: TGroupBox;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    cbxWindowStates: TComboBox;
    txtIconLocation: TEdit;
    HotKey: THotKey;
    procedure FormCreate(Sender: TObject);
    procedure btnExitClick(Sender: TObject);
    procedure btnCreateShellLinkClick(Sender: TObject);
  private
  public
  end;

{$IFNDEF VER130} // Delphi 5 finally added IShellLink declearation
  IShellLink = interface (IUnknown)
    ['{000214EE-0000-0000-C000-000000000046}']
    function GetPath(pszFile: PChar; cchMaxPath: Integer; var pfd: TWin32FindData; fFlags: DWORD): HRESULT; stdcall;
    function GetIDList(ppidl: Pointer): HRESULT; stdcall;
    function SetIDList(const pidl: Pointer): HRESULT; stdcall;
    function GetDescription(pszName: PChar; cchMaxName: Integer): HRESULT; stdcall;
    function SetDescription(const pszName: PChar): HRESULT; stdcall;
    function GetWorkingDirectory(pszDir: PChar; cchMaxPath: Integer): HRESULT; stdcall;
    function SetWorkingDirectory(const pszDir: PChar): HRESULT; stdcall;
    function GetArguments(pszDir: PChar; cchMaxPath: Integer): HRESULT; stdcall;
    function SetArguments(const pszArgs: PChar): HRESULT; stdcall;
    function GetHotkey(pwHotkey: PWORD): HRESULT; stdcall;
    function SetHotkey(wHotkey: Word): HRESULT; stdcall;
    function GetShowCmd(piShowCmd: PInteger): HRESULT; stdcall;
    function SetShowCmd(iShowCmd: Integer): HRESULT; stdcall;
    function GetIconLocation(pszIconPath: PChar; cchIconPath: Integer; piIcon: PInteger): HRESULT; stdcall;
    function SetIconLocation(const pszIconPath: PChar; iIcon: Integer): HRESULT; stdcall;
    function SetRelativePath(const pszPathRel: PChar; dwReserved: DWORD): HRESULT; stdcall;
    function Resolve(Wnd: HWND; fFlags: DWORD): HRESULT; stdcall;
    function SetPath(const pszFile: PChar): HRESULT; stdcall;
  end;
{$ENDIF}

  TShellFolder = (sfDesktop, sfFavorites, sfFonts, sfPersonal, sfPrograms,
    sfRecent, sfSendTo, sfStartMenu, sfStartup, sfTemplates);

const
{$IFNDEF VER130}
  CLSID_ShellLink: TGUID  = '{00021401-0000-0000-C000-000000000046}';
  IID_IShellLink: TGUID   = '{000214EE-0000-0000-C000-000000000046}';
{$ENDIF}
  IID_IPersistFile: TGUID = '{0000010B-0000-0000-C000-000000000046}';

  ShellFolderKeys: array[TShellFolder] of string =
    ('Desktop', 'Favorites', 'Fonts', 'Personal', 'Programs',
    'Recent', 'SendTo', 'Start Menu', 'Startup', 'Templates');

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  SF: TShellFolder;
  ws: TWindowState;
begin
  for SF := Low(ShellFolderKeys) to High(ShellFolderKeys) do
    cbxFolders.Items.Add(ShellFolderKeys[SF]);
  cbxFolders.ItemIndex := 0;

  cbxWindowStates.ItemIndex := 0;
end;

procedure TForm1.btnExitClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCreateShellLinkClick(Sender: TObject);
const
  WindowStates: array[TWindowState] of Integer =
    (SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
var
  Psl      : IShellLink;
  Ppf      : IPersistFile;                  
  sFileName: string;                        
  wFileName: array[0..MAX_PATH] of WideChar;
begin
  if txtFilePath.Text = '' then Exit;
  
  if Failed(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkA, Psl)) then
    raise Exception.Create('Error in create instance');
  
  Psl.SetPath(PChar(txtFilePath.Text));
  Psl.SetDescription(PChar(txtDescription.Text));
  Psl.SetWorkingDirectory(PChar(txtWorkingDirectory.Text));
  Psl.SetArguments(PChar(txtArguments.Text));
  Psl.SetHotkey(HOTKEY.HOTKEY);
  Psl.SetShowCmd(WindowStates[TWindowState(cbxWindowStates.ItemIndex)]);
  Psl.SetIconLocation(PChar(txtIconLocation.Text), 0);

  if Failed(Psl.QueryInterface(IID_IPersistFile, Ppf)) then
    raise Exception.Create('Error in query interface');

  sFileName := ChangeFileExt(ExtractFileName(txtFilePath.Text), '.LNK');
  with TRegIniFile.Create('Software\Microsoft\Windows\CurrentVersion\Explorer') do
    try
      sFileName := ReadString('Shell Folders', ShellFolderKeys[TShellFolder(cbxFolders.ItemIndex)], '') + '\' + sFileName;
    finally
      Free;
    end;

  MultiByteToWideChar(CP_ACP, 0, PChar(sFileName), - 1, wFileName, MAX_PATH);
  if Failed(Ppf.Save(wFileName, True)) then
    raise Exception.Create('Error in save LNK file');
end;

initialization
  CoInitialize(nil);
finalization
  CoUninitialize;
end.