用ASP.NET(VB版)建立WINDOWS 2000 SERVER網站

來源:互聯網
上載者:User
asp.net|server|window|建立|網站 用ASP.NET(VB)建立的WEB網站,我們的調用方式非常簡單:
Dim test As New Class1()
test.CreateWebSit(webname,port, "D:\VB", "localhost")

下面是Class1的代碼,該代碼做的工作就是建立網站,如果有此網站的名稱則自動覆蓋(注意:本類需要引用Actice DS Type Library)
Public Class Class1

用localhost
    '===========================

    Function CreateWebSit(ByVal WWWSiteName As String, _
        ByVal WWWTCPPort As String, _
        ByVal WWWFilesPath As String, _
        ByVal ComputerName As String) As Boolean

        CreateWebSit = True
        Dim TCPPort() As Object
        '建立活動案頭'(IADS)對象。首先要在 VB 中的 'prject'菜單中的'references'中引'用 Active DS 'Type 'library 組件
        Dim WWWServer As ActiveDs.IADs
        Dim WWWService
        Dim WWWVdir, WWWVdir2, WWWVdirRes As ActiveDs.IADs
        Dim i As Integer
        Dim HandleSameCase As Boolean
        '取得W3SVC服務
        WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
        i = 1
        HandleSameCase = True
        On Error GoTo ErrWouldDo
        '在IIS中尋找每一個WEB網站
        For Each WWWServer In WWWService
            WWWServer = Nothing
            WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i)
            'Debug.Print WWWServer.ServerComment
            '如果在安裝時系統中已經有了要加的網站,則要先刪除乾淨
            If UCase(WWWServer.ServerComment) = UCase(WWWSiteName) Then
                WWWService.Delete("IISWebServer", i) '再刪除
                Exit For
            End If
            ReDim TCPPort(1)
            TCPPort(0) = ""
            TCPPort = WWWServer.Serverbindings
            '如果連接埠已經有了則也要先刪除
            If TCPPort(0) = ":" & WWWTCPPort & ":" Then
                WWWService.Delete("IISWebServer", i) '刪除
            Else
                i = i + 1
            End If
        Next
        HandleSameCase = False
CreateSite:
        'MsgBox I
        WWWServer = WWWService.Create("IISWebServer", i)     '建立新網站
        WWWServer.ServerComment = WWWSiteName '佈建網站名
        WWWServer.Serverbindings = ":" & WWWTCPPort & ":" '設定連接埠號碼
        WWWServer.DefaultDoc = "default.asp,index.asp,default.htm,index.htm" '設定預設開機檔案
        WWWServer.AccessScript = True '設定許可權
        WWWServer.AccessRead = True
        WWWServer.SetInfo()

        '建立設定主目錄
        WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i)
        WWWVdir = WWWServer.Create("IISWebVirtualDir", "root")
        WWWVdir.Path = WWWFilesPath '主目錄的實際磁碟路徑
        WWWVdir.SetInfo()
        WWWVdir.AppCreate(True)
        WWWServer.Start() '啟動新網站

        '建立虛擬目錄
        'Set WWWVdirRes = WWWVdir.Create("IISWebVirtualDir", "Resource") '建立虛擬目錄
        'WWWVdirRes.Path = WWWFilesPath + "\Resource"
        'WWWVdirRes.AccessRead = True
        'WWWVdirRes.AccessWrite = True
        'WWWVdirRes.SetInfo

        '下面為自訂IIS Web Server的錯誤資訊,等發生404錯誤時候指定調用網站主目錄下的404.htm頁面顯示

        WWWServer.HttpErrors = "404,0,FILE," + WWWFilesPath + "\404.htm"
        WWWServer.SetInfo()

        CreateWebSit = True

        Exit Function
ErrWouldDo:
        'MsgBox Err.Description
        If (HandleSameCase = True) Then
            GoTo CreateSite
        Else
            MsgBox(Err.Description)
            CreateWebSit = False
            Exit Function
        End If
    End Function

    REM 建立虛擬目錄程式
    'ComputerName       伺服器名(可以為localhost)
    'DirName            要建立的虛擬目錄名
    'LinkAddr           該虛擬目錄的真實路徑
    'WWWSiteName        網站名稱
    Function CreateVirtualDir(ByVal ComputerName As String, _
            ByVal DirName As String, ByVal LinkAddr As String, _
            ByVal WWWSiteName As String) As Boolean

        Dim i As Integer
        CreateVirtualDir = True
        '取得W3SVC服務
        Dim WWWServer As ActiveDs.IADs
        Dim WWWService
        WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
        i = 1
        Dim HandleSameCase As Boolean
        HandleSameCase = True
        Dim temp As Boolean
        temp = False
        For Each WWWServer In WWWService
            WWWServer = Nothing
            WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i)

            If UCase(WWWServer.ServerComment) = UCase(WWWSiteName) Then
                temp = True
                Exit For
            End If

            i = i + 1
        Next

        If Not temp Then
            CreateVirtualDir = False
            Exit Function
        End If

        Dim WWWVirtualDir, WWWIF As ActiveDs.IADs

        WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i & "/Root")

        REM 檢查是否該網站中已有該虛擬目錄
        On Error GoTo ErrHandle
        WWWIF = GetObject("IIS://" & ComputerName & "/W3SVC/" & i & "/Root/" & DirName)
        REM 如果有,則返回False
        If WWWIF.Name <> "" Then
            CreateVirtualDir = False
            Exit Function
        End If

ErrHandle:
        'Debug.Print Err.Number
        If Err.Number = -2147024893 Then
            Err.Clear()
            REM 如果是因為沒有找到該虛擬目錄出錯的話則進行CreateVirtualDir建立虛擬目錄
            GoTo ReturnCreate
        Else
            CreateVirtualDir = False
            Exit Function
        End If


        REM 建立虛擬目錄
ReturnCreate:
        WWWVirtualDir = WWWServer.Create("IISWebVirtualDir", DirName)
        WWWVirtualDir.Path = LinkAddr
        WWWVirtualDir.AccessRead = True
        WWWVirtualDir.AccessScript = True
        WWWVirtualDir.AppCreate(True)
        WWWVirtualDir.SetInfo()

        CreateVirtualDir = True
    End Function

    Function GetDBConnStr(ByVal DBName As String) As String
        Select Case DBName
            Case "friend"
                GetDBConnStr = CStr(GetSetting("HostTask", "DBini", "ConnStr"))
            Case "wuye"
                GetDBConnStr = Replace$(CStr(GetSetting("HostTask", "DBini", "ConnStr")), "friend", "wuye")
            Case Else
                GetDBConnStr = CStr(GetSetting("HostTask", "DBini", "ConnStr"))
        End Select
    End Function


End Class


相關文章

E-Commerce Solutions

Leverage the same tools powering the Alibaba Ecosystem

Learn more >

Apsara Conference 2019

The Rise of Data Intelligence, September 25th - 27th, Hangzhou, China

Learn more >

Alibaba Cloud Free Trial

Learn and experience the power of Alibaba Cloud with a free trial worth $300-1200 USD

Learn more >

聯繫我們

該頁面正文內容均來源於網絡整理,並不代表阿里雲官方的觀點,該頁面所提到的產品和服務也與阿里云無關,如果該頁面內容對您造成了困擾,歡迎寫郵件給我們,收到郵件我們將在5個工作日內處理。

如果您發現本社區中有涉嫌抄襲的內容,歡迎發送郵件至: info-contact@alibabacloud.com 進行舉報並提供相關證據,工作人員會在 5 個工作天內聯絡您,一經查實,本站將立刻刪除涉嫌侵權內容。