用VB怎么创建虚似目录，怎么把SQL数据导入数据库？？大虾求救！！！

[dengguoyuan]

用VB怎么创建虚似目录，怎么把SQL数据导入数据库？？大虾求救！！！

[nik_Amis]

记得有个对象来着，还是直接写注册表
记不清了，关注一下吧

[zhangwh6882]

虚拟目录
先引入类型库(Project|Import Type Library)adsiis.dll、iisext.dll和activeds.tlb
新建一个单元，声明
unit ActiveDs;
interface
function ADsGetObject(const PathName: WideString; const GUID: TGUID; out I: IUnknown): HRESULT; stdcall;
implementation
function ADsGetObject; external ''activeds.dll'' name ''ADsGetObject'';
end.


方法一(参照C++)、
var
I: IADsContainer;
ADs: IADs;
begin
if ADsGetObject(''IIS://localhost/w3svc'', IID_IADsContainer, IUnknown(I)) = S_Ok then
begin
ADs := IADs(I.GetObject(''IIsWebServer'', ''1''));
ShowMessage(ADs.ADsPath);
if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then
begin
ADs := IADs(I.GetObject(''IIsWebVirtualDir'', ''Root''));
ShowMessage(ADs.ADsPath);
if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then
begin
ADs := IADs(I.Create(''IIsWebVirtualDir'', ''DelphiTest''));
ADs.Put(''AccessRead'', ''True'');
ADs.Put(''Path'', ''c:\Temp'');
ADs.SetInfo;
end;
end;
end;
end;


方法二(使用接口)、
procedure TForm3.BitBtn4Click(Sender: TObject);
var
Disp: IDispatch;
begin
Disp := IISNamespace1.GetObject(''IIsWebService'', ''localhost/w3svc'');
Disp := (Disp as IADsContainer).GetObject(''IIsWebServer'', ''1'');
Disp := (Disp as IADsContainer).GetObject(''IIsWebVirtualDir'', ''Root'');
Disp := (Disp as IADsContainer).Create(''IIsWebVirtualDir'', ''DelphiADSITest'');
(Disp as IADs).Put(''AccessRead'', ''True'');
(Disp as IADs).Put(''Path'', ''c:\ADSITest'');
(Disp as IADs).SetInfo;
end;


方法三(使用Variant，就是类似VB和ASP的方法)、
procedure TForm2.BitBtn1Click(Sender: TObject);
var
WebSite, WebServer, WebRoot, VDir: Variant;
begin
WebSite := CreateOleObject(''IISNamespace'');
WebSite := WebSite.GetObject(''IIsWebService'', ''localhost/w3svc'');
WebServer := WebSite.GetObject(''IIsWebServer'', ''1'');
WebRoot := WebServer.GetObject(''IIsWebVirtualDir'', ''Root'');
VDir := WebRoot.Create(''IIsWebVirtualDir'', ''VariantTest'');
VDir.AccessRead := True;
VDir.Path := ''C:\Test'';
VDir.SetInfo;
end;

[shawls]

[名称] 发布虚拟站点

[数据来源] 未知

[内容简介] 空

[源代码内容]

方法一：
'参数：
' strWebSite 虚拟站点名称
' strFriendlyName 程序名称
' strWebPath 网页文件路径
' strDefaultDoc 默认网站首页

Public Function WebVirtualDir(ByVal strWebSite As String, ByVal strFriendlyName As String, ByVal strWebPath As String, ByVal strDefaultDoc As String) As Boolean
Dim objADSI As Object
Dim objWebVDir As Object

On Error GoTo Lib_Err

Set objADSI = GetObject("IIS://LocalHost/W3SVC/1/Root")
Set objWebVDir = objADSI.Create("IIsWebVirtualDir", strWebSite)
objWebVDir.SetInfo

Set objWebVDir = objADSI.GetObject("IIsWebVirtualDir", strWebSite)
objWebVDir.AppCreate True
objWebVDir.Put "AppFriendlyName", strFriendlyName
objWebVDir.Put "AppRoot", "/LM/W3SVC/1/Root/" & strWebSite
objWebVDir.Put "Path", strWebPath
objWebVDir.Put "AppIsolated", 0
objWebVDir.Put "DefaultDoc", strDefaultDoc
objWebVDir.Put "AccessFlags", 535
objWebVDir.SetInfo

WebVirtualDir = True

Lib_End:
Set objWebVDir = Nothing
Set objADSI = Nothing
Exit Function

Lib_Err:
WebVirtualDir = False
strError = Err.Description
Err.Clear
Resume Lib_End

End Function

方法二：
这是一段VBS脚本，我从LearnBizTalk里面找出来的，用于建立一个IIS虚拟目录。


' Create vdir for IIS

Dim ServObj, VdirObj, TestPath, TestName

' First, open the path to the Web server

Set ServObj = GetObject("IIS://LocalHost/w3svc/1/Root")
PassFail "Open Web server"

' delete old app
Set VdirObj = ServObj.GetObject("IIsWebVirtualDir", "LearnBizTalk")
VdirObj.SetInfo
VdirObj.AppDelete
err.clear

' delete old vdir
ServObj.Delete "IIsWebVirtualDir", "LearnBizTalk"
err.clear

' Second, Create the virtual directory (Vdir) path

Set VdirObj = ServObj.Create("IIsWebVirtualDir", "LearnBizTalk")
VdirObj.SetInfo
PassFail "Create VDir"

' Finally, create a Path variable containing the virtual root path and set the permissions to read, script
VdirObj.AccessRead = True
Testpath = "C:\LearnBizTalk\ASP"
VdirObj.Put "Path", (Testpath)

VdirObj.SetInfo
PassFail "Set VDir Path and permissions"

' create out-of-proc application

vdirObj.AppCreate False
PassFail "Create Web Application"

' Set Friendly Name

TestName = "LearnBizTalk"
vdirObj.Put "AppFriendlyName", (TestName)
VdirObj.SetInfo
PassFail "Set Friendly Name"

Sub PassFail(strScope)
If Err.Number <> 0 Then
Fail strScope & " Error: x" & Hex(Err.Number) & " Description: " & Err.Description & " Source: " & Err.Source
Err.Clear
'Else
'Pass strScope
End If
End Sub

Sub Fail(strScope)
WScript.Echo "[FAIL] " & SetGetEnvVar("PROCESS", "ComputerName", "DEFAULTSERVER", False) & ":" & strScope
MsgBox "Setup did not complete!", 16
WScript.Quit
End Sub


以上代码保存于： SourceCode Explorer(源代码数据库)
复制时间： 2003-1-3 20:00:08
软件版本： 1.0.814
软件作者： Shawls
个人主页： Http://Shawls.Yeah.Net
E-Mail： [e-mail]
QQ： 9181729