Prizes & Awards
My Profile
Active Members
TodayLast 7 Days
more...
|
 New Feature: Community Sites:
Create your own .NET community website and start earning from Google AdSense !
It's Free !
|
Create virtual Directory in IIS programmatically
Posted Date: 24 Mar 2006 Resource Type: Articles Category: .NET Framework
|
Posted By: Abhishek Arya Member Level: Diamond
Rating:  Points: 10
|
Introduction
This type of problem i faced when i was working with of of my client. He want something like this. On button click even than they want one virtual directory to be created at iis and then they just copy the files in that directory.
This is quite easy as it looks like. This can help you to create a virtual directory in iis at just button click. You can give your own path where do you want to create a folder.
Here is the code which help you out
Sample Code
Option Explicit
Private mstrVirtualDirectoryName As String
Private mstrPhysicalDirectoryName As String
Private mstrApplicationOwner As String
Private mstrLastError As String
Private mboolAllowScriptsToRun As Boolean
Private mboolRunApplicationInProcess As Boolean
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CreateDirectory Lib "kernel32" _
Alias "CreateDirectoryA" _
(ByVal lpPathName As String, _
lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function CopyFile Lib "kernel32" _
Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Private Const MAX_COMPUTERNAME As Long = 15
Private Declare Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" _
(ByVal lpBuffer As String, _
nSize As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" _
(ByVal lpString As Long) As Long
Public Property Get RunApplicationInProcess() As Boolean
RunApplicationInProcess = mboolRunApplicationInProcess
End Property
Public Property Let RunApplicationInProcess(ByVal boolRunApplicationInProcess As Boolean)
mboolRunApplicationInProcess = boolRunApplicationInProcess
End Property
Private Function CreateNestedFoldersByPath(ByVal _
completeDirectory As String) As Integer
'creates nested directories on the drive
'included in the path by parsing the final
'directory string into a directory array,
'and looping through each to create the final path.
'The path could be passed to this method as a
'pre-filled array, reducing the code.
Dim r As Long
Dim SA As SECURITY_ATTRIBUTES
Dim drivePart As String
Dim newDirectory As String
Dim item As String
Dim sfolders() As String
Dim pos As Integer
Dim x As Integer
'must have a trailing slash for
'the GetPart routine below
If Right$(completeDirectory, 1) <> "\" Then
completeDirectory = completeDirectory & "\"
End If
'if there is a drive in the string, get it
'else, just use nothing - assumes current drive
pos = InStr(completeDirectory, ":")
If pos Then
drivePart = GetPart(completeDirectory, "\")
Else: drivePart = ""
End If
'now get the rest of the items that
'make up the string
Do Until completeDirectory = ""
'strip off one item (i.e. "Files\")
item = GetPart(completeDirectory, "\")
'add it to an array for later use, and
'if this is the first item (x=0),
'append the drivepart
ReDim Preserve sfolders(0 To x) As String
If x = 0 Then item = drivePart & item
sfolders(x) = item
'increment the array counter
x = x + 1
Loop
'Now create the directories.
'Because the first directory is
'0 in the array, reinitialize x to -1
x = -1
Do
x = x + 1
'just keep appending the folders in the
'array to newDirectory. When x=0 ,
'newDirectory is "", so the
'newDirectory gets assigned drive:\firstfolder.
'Subsequent loops adds the next member of the
'array to the path, forming a fully qualified
'path to the new directory.
newDirectory = newDirectory & sfolders(x)
'the only member of the SA type needed (on
'a win95/98 system at least)
SA.nLength = LenB(SA)
Call CreateDirectory(newDirectory, SA)
Loop Until x = UBound(sfolders)
'done. Return x, but add 1 for the 0-based array.
CreateNestedFoldersByPath = x + 1
End Function
Private Function GetPart(startStrg As String, delimiter As String) As String
'takes a string separated by "delimiter",
'splits off 1 item, and shortens the string
'so that the next item is ready for removal.
Dim c As Integer
Dim item As String
c = 1
Do
If Mid$(startStrg, c, 1) = delimiter Then
item = Mid$(startStrg, 1, c)
startStrg = Mid$(startStrg, c + 1, Len(startStrg))
GetPart = item
Exit Function
End If
c = c + 1
Loop
End Function
Public Function Create() As Boolean
Dim objIIS As Object 'ADSI IIS Object
Dim objVirtualDirectory As Object 'ADSI IIS Virtual Directory Object
Dim strACLCommand As String 'Command Line string to set ACLs
On Error GoTo errHandle
'Does this IIS application already exist in the metabase?
On Error Resume Next
Set objIIS = GetObject("IIS://localhost/W3SVC/1/Root/" & mstrVirtualDirectoryName)
If Err.Number = 0 Then
mstrLastError = "An application with this name already exists"
GoTo exitPoint
End If
Set objIIS = Nothing
On Error GoTo 0
'Create the IIS application
Set objIIS = GetObject("IIS://localhost/W3SVC/1/Root")
'Test to see if the folder exists in the filesystem.
'If not, create it
If Not FolderExists(mstrPhysicalDirectoryName) Then
CreateNestedFoldersByPath mstrPhysicalDirectoryName
End If
'Create the folder in the filesystem
Set objVirtualDirectory = objIIS.Create("IISWebVirtualDir", mstrVirtualDirectoryName)
objVirtualDirectory.AccessScript = IIf(mboolAllowScriptsToRun, "True", "False") 'bolScriptPermissions
objVirtualDirectory.Path = mstrPhysicalDirectoryName
objVirtualDirectory.SetInfo
objVirtualDirectory.AppCreate mboolRunApplicationInProcess
'Set Change Permissions for the developer using CACLS.exe
strACLCommand = "cmd /c echo y| CACLS "
strACLCommand = strACLCommand & mstrPhysicalDirectoryName
strACLCommand = strACLCommand & " /E /G " & mstrApplicationOwner & ":C"
Shell strACLCommand, vbHide
Create = True
exitPoint:
Set objVirtualDirectory = Nothing
Exit Function
errHandle:
mstrLastError = "Unexpected error occured in CreateVirtualDirectory" & vbCrLf & GetVBError()
GoTo exitPoint
End Function
Private Function GetVBError() As String
Dim szMsg As String
szMsg = "Error # : " & Err.Number
szMsg = szMsg & vbTab & "Description : " & Err.Description
szMsg = szMsg & vbTab & "Source : " & Err.Source
If Err.LastDllError <> 0 Then
szMsg = szMsg & vbTab & "DLL Error : " & Err.LastDllError
End If
GetVBError = szMsg
End Function
Private Function FolderExists(ByVal sFolder As String) As Boolean
Dim hFile As Long
Dim WFD As WIN32_FIND_DATA
'remove training slash before verifying
sFolder = UnQualifyPath(sFolder)
'call the API pasing the folder
hFile = FindFirstFile(sFolder, WFD)
'if a valid file handle was returned,
'and the directory attribute is set
'the folder exists
FolderExists = (hFile <> INVALID_HANDLE_VALUE) And _
(WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY)
'clean up
Call FindClose(hFile)
End Function
Private Function UnQualifyPath(ByVal sFolder As String) As String
'trim and remove any trailing slash
sFolder = Trim$(sFolder)
If Right$(sFolder, 1) = "\" Then
UnQualifyPath = Left$(sFolder, Len(sFolder) - 1)
Else: UnQualifyPath = sFolder
End If
End Function
Public Property Get AllowScriptsToRun() As Boolean
AllowScriptsToRun = mboolAllowScriptsToRun
End Property
Public Property Let AllowScriptsToRun(ByVal boolAllowScriptsToRun As Boolean)
mboolAllowScriptsToRun = boolAllowScriptsToRun
End Property
Public Property Get LastError() As String
LastError = mstrLastError
End Property
Public Property Let LastError(ByVal strLastError As String)
mstrLastError = strLastError
End Property
Public Property Get ApplicationOwner() As String
ApplicationOwner = mstrApplicationOwner
End Property
Public Property Let ApplicationOwner(ByVal strOwner As String)
mstrApplicationOwner = strOwner
End Property
Public Property Get PhysicalDirectoryName() As String
PhysicalDirectoryName = mstrPhysicalDirectoryName
End Property
Public Property Let PhysicalDirectoryName(ByVal strPhysicalDirectoryName As String)
mstrPhysicalDirectoryName = strPhysicalDirectoryName
End Property
Public Property Get VirtualDirectoryName() As String
VirtualDirectoryName = mstrVirtualDirectoryName
End Property
Public Property Let VirtualDirectoryName(ByVal strVirtualDirectoryName As String)
mstrVirtualDirectoryName = strVirtualDirectoryName
End Property
Private Sub Class_Initialize()
mboolRunApplicationInProcess = True
mboolAllowScriptsToRun = True
mstrApplicationOwner = "IUSR_" & GetLocalComputerName()
End Sub
Private Function GetLocalComputerName() As String
Dim tmp As String
'return the name of the computer
tmp = Space$(MAX_COMPUTERNAME)
If GetComputerName(tmp, Len(tmp)) <> 0 Then
GetLocalComputerName = TrimNull(tmp)
End If
End Function
Private Function TrimNull(startstr As String) As String
TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
End Function
Summary
This will work good and easy . Just a copy paste and you will come up a good feature to your application
|
Responses
|
No responses found. Be the first to respond and make money from revenue sharing program.
|
|