建立虚拟目录的一个"小"问题?

Question

问题:
  通过如下代码建立名为fire的虚拟目录，要求是其属性中：有应用程序名为“fire”，执行许可为“脚本和可执行程序”，应用程序保护为“中（共用的）”，路径指定。
代码中用到了SUIPACK4(网上下载的美化控件)中的suimessagedialog（功能相当与SHOWMESSAGE），代码如下：
procedure TForm1.Button1Click(Sender: TObject);
var
  RegODBC:TRegistry;
  registerTemp : TRegistry;
  SysPath: array [0..255] of char;
begin
  RegODBC:=TRegistry.create;     //访问注册表
  RegODBC.RootKey:=HKEY_LOCAL_MACHINE;
  RegODBC.OpenKey('\SYSTEM\ControlSet001\Services\W3SVC\Parameters\Virtual Roots',True);
  getsystemdirectory(SysPath,255);
  if regodbc.ValueExists('/fire') then
    begin
      suimessage1.Text:='本机WEB已存在名为fire的虚拟目录。'+#13#10+'请将此fire删除或重命名。';
        suimessage1.IconType:=suistop;
        suimessage1.ButtonCount:=1;
        suimessage1.Caption:='错误';
        if suimessage1.ShowModal=mrok then
          winexec(pchar(SysPath+'\inetsrv\inetmgr.exe'),sw_shownormal);
       exit;
    end
  else
    begin
  registerTemp := TRegistry.Create; //建立一个Registry实例
  with registerTemp do
    begin
      RootKey:=HKEY_LOCAL_MACHINE;//设置根键值为HKEY_LOCAL_MACHINE//找到或创建\SYSTEM\ControlSet001\Services\W3SVC\Parameters\Virtual Roots,写入IIS配置信息
     if OpenKey('\SYSTEM\ControlSet001\Services\W3SVC\Parameters\Virtual Roots',True) then
       begin
         WriteString('/fire','E:\fire,,205');
       end
     else//创建键值失败
       begin
          suimessage1.Text:='IIS配置失败，本程序即将关闭。'+#13#10+'关闭后请先检查Internet服务管理器，排除错误或安装后再运行本程序。';
          suimessage1.IconType:=suistop;
          suimessage1.ButtonCount:=1;
          suimessage1.Caption:='错误';
        if suimessage1.ShowModal=mrok then
           application.Terminate ;
       end;
     CloseKey;
    Free;
  end;    
    end;
  RegODBC.Free;
 end;    执行后，当时在Internet信息服务中，不可见fire的虚拟目录，重启后可见，但并不能满足我的全部要求（第一个要求，应用程序名为“fire”，没有建立，进入Internet信息服务fire属性后，点击“创建”后就可满足我的全部要求），现求教如何让代码一步实现呢？
    代码所建立的虚拟目录的图标不是正式的虚拟目录的图标，但通过手动点击“创建”后，其图标即为虚拟目录的正式图标。

Answer 1

我想可能是这行WriteString('/fire','E:\fire,,205'); 中的参数设置吧!

Answer 2

个人收藏的创建虚拟目录程序
 { ****************** }
  { }
  { }
  { zhao zhenhua }
  { }
  { Copyright zhao zhenhua email:[email protected] }
  { }
  { ****************** }  unit MainUnt;  interface  uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, FileCtrl, Buttons,Activeds_TLB;  type
  TIISConfigFrm = class(TForm)
  edtAlias: TEdit;
  Label1: TLabel;
  dlbIIS: TDirectoryListBox;
  dcbIIS: TDriveComboBox;
  Label2: TLabel;
  edtPath: TEdit;
  GroupBox1: TGroupBox;
  cbRead: TCheckBox;
  cbScript: TCheckBox;
  cbExecute: TCheckBox;
  cbWrite: TCheckBox;
  cbBrowse: TCheckBox;
  bbtOK: TBitBtn;
  lblPath: TLabel;
  procedure dlbIISChange(Sender: TObject);
  procedure bbtOKClick(Sender: TObject);  procedure FormCreate(Sender: TObject);
  private
  { Private declarations }
  public
  { Public declarations }
  end;  function ADsGetObject(const PathName: WideString; const GUID:TGUID; out I: IUnknown): HRESULT; stdcall;  var
  IISConfigFrm: TIISConfigFrm;  implementation  {$R *.dfm}  function ADsGetObject;external 'ActiveDS.dll' name 'ADsGetObject';  procedure TIISConfigFrm.dlbIISChange(Sender: TObject);
  begin
  edtPath.Text:=dlbIIS.Directory;
  end;  procedure TIISConfigFrm.bbtOKClick(Sender: TObject);
  var
  I: IADsContainer;
  ADs: IADs;
  begin
  if Length(Trim(edtAlias.Text))=0 then begin
  Application.MessageBox('別名不可以為空！','警告');
  Exit;
  end;  if Length(Trim(edtPath.Text))=0 then begin
  Application.MessageBox('請選定虛擬目錄位置！','警告');
  Exit;
  end;if ADsGetObject('IIS://localhost', IID_IADsContainer, IUnknown(I)) = S_Ok then begin //IIS已經安裝
if ADsGetObject('IIS://localhost/w3svc', IID_IADsContainer, IUnknown(I)) = S_Ok then begin //Web伺服器存在
  ADs := IADs(I.GetObject('IIsWebServer', '1')); //取得服務
  if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then begin //服務支持
  ADs := IADs(I.GetObject('IIsWebVirtualDir', 'Root')); //在Web伺服器的Root下建立虛擬目錄
  if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then begin //服務支持
  try
  ADs := IADs(I.Create('IIsWebVirtualDir', edtAlias.Text)); //建立虛擬目錄，別名為edtAlias.Text
  except
  Application.MessageBox('這個別名已經存在，請選擇另外的別名！','警告');
  Exit;
  end; //try except
  ADs.Put('AccessRead', cbRead.Checked); //設定各參數
  ADs.Put('AccessWrite', cbWrite.Checked);
  ADs.put('AccessScript',cbScript.Checked);
  ADs.Put('AccessExecute',cbExecute.Checked);
  ADs.put('EnableDirBrowsing',cbBrowse.Checked);
  ADs.Put('Path', edtPath.text);
  ADs.Put('DefaultDoc','Default.asp, Default.html, Default.htm, ndex.asp, Index.html, Index.htm, Home.asp, Home.Html, Home.htm');
  ADs.Put('EnableDefaultDoc',True);//允許打開默認文件
  ADs.SetInfo; //保存參數
  Application.MessageBox('您的設定已經保存。','恭喜');
  end;
  end;
  end;
  end else
  Application.MessageBox('您的電腦上沒有安裝IIS或者您無權訪問IIS。','警告');
  end;  procedure TIISConfigFrm.FormCreate(Sender: TObject);
  begin
  edtPath.Text:=dlbIIS.Directory;
  end;  end

Answer 3

这个我也查到过,试过不行,Activeds_TLB找不到!
你的代码你测试通过了吗?

Answer 4

qxj(^-^) :你写的代码所实现的与我的一样，也没有指定应用程序名，需要进入属性后点击落“创建”后才行，你知道怎么解决吗？
ADs.Put('AccessRead', cbRead.Checked); //設定各參數
  ADs.Put('AccessWrite', cbWrite.Checked);
  ADs.put('AccessScript',cbScript.Checked);
  ADs.Put('AccessExecute',cbExecute.Checked);
  ADs.put('EnableDirBrowsing',cbBrowse.Checked);
  ADs.Put('Path', edtPath.text);
  ADs.Put('DefaultDoc','Default.asp, Default.html, Default.htm, ndex.asp, Index.html, Index.htm, Home.asp, Home.Html, Home.htm');
  ADs.Put('EnableDefaultDoc',True)
这里应该还有参数吧，哪里有这方面的资料？