shcutf.pas

精彩编程百例51～75 其中有 cpu速度测试 检测声卡 查询内存信息 图像处理技巧 模拟放大镜效果等待

unit ShCutF;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    EditName: TEdit;
    Label1: TLabel;
    GroupBox1: TGroupBox;
    cbDir: TCheckBox;
    cbDesktop: TCheckBox;
    cbStartMenu: TCheckBox;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  ComObj, ActiveX, ShlObj, Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  AnObj: IUnknown;
  ShLink: IShellLink;
  PFile: IPersistFile;
  FileName: string;
  WFileName: WideString;
  Reg: TRegIniFile;
begin
  
  // 访问对象的两个接口
  AnObj := CreateComObject (CLSID_ShellLink);
  ShLink := AnObj as IShellLink;
  PFile := AnObj as IPersistFile;
  // 得到执行程序的完整路径及文件名
  filename:=editname.Text;;
  // 设置连接的方式属性
  ShLink.SetPath (PChar (FileName));
  ShLink.SetWorkingDirectory (PChar (
    ExtractFilePath (FileName)));

  // 存放于当前文件夹
  if cbDir.Checked then
  begin
    // 长字符串
    WFileName := ExtractFilePath (FileName) +
      extractFilename(filename) + '.lnk';
    PFile.Save (PWChar (WFileName), False);
  end;

  // 存放于桌面上
  if cbDesktop.Checked then
  begin
    Reg := TRegIniFile.Create(
      'Software\MicroSoft\Windows\CurrentVersion\Explorer');
    WFileName := Reg.ReadString ('Shell Folders', 'Desktop', '') +
      '\' + extractFilename(filename)+ '.lnk';
    Reg.Free;
    PFile.Save (PWChar (WFileName), False);
  end;

  // 存在开始菜单内
  if cbStartMenu.Checked then
  begin
    Reg := TRegIniFile.Create(
      'Software\MicroSoft\Windows\CurrentVersion\Explorer');
    WFileName := Reg.ReadString ('Shell Folders', 'Start Menu', '') +
      '\' + extractFilename(filename) + '.lnk';
    Reg.Free;
    PFile.Save (PWChar (WFileName), False);
  end;
end;



procedure TForm1.Button2Click(Sender: TObject);
begin
   close;
end;

end.