想把自己的东西整理出来已经很久了,可是一直没有时间,自己的水平又太差,也怕耽误别人的时间,所以至今没写出任何东西出来。可是每次看到别人的文章心里也痒痒,于是找来自发表过的一个帖子,以回馈大家。 { ****************** } { } { } { zhao zhenhua } { } { Copyright zhao zhenhua email:zhao-zhenhua@163.net } { } { ****************** } 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. |