'取得ftp当前的目录的名字
Public Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Boolean
'lpszCurrentDirectory--存放目录名字的字符串
'lpdwCurrentDirectory--目录名字字符串的字节数
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function CreateFTPDirectory(ByVal VirtrueName As String, ByVal LocalPath As String) As Boolean
Dim ExistFTP As Boolean
Dim ServerObj As Object
Dim VirtrueDirObj As Object
Dim MyVirtrueDir As Object
ExistFTP = False
CreateFTPDirectory = False
On Error GoTo ErrFTP
If CheckExistIIS Then
Set ServerObj = GetObject("IIS://LocalHost/MSFTPSVC/1/ROOT")
For Each MyVirtrueDir In ServerObj
If UCase(MyVirtrueDir.Class) = UCase("IIsFtpVirtualDir") Then
If UCase(MyVirtrueDir.Name) = UCase(Trim(VirtrueName)) Then
ExistFTP = True
End If
End If
Next
If ExistFTP Then
Set VirtrueDirObj = ServerObj.GetObject("IIsFtpVirtualDir", VirtrueName)
Else
Set VirtrueDirObj = ServerObj.Create("IIsFtpVirtualDir", VirtrueName)
End If
VirtrueDirObj.Path = LocalPath
VirtrueDirObj.AccessRead = True
VirtrueDirObj.AccessWrite = True
VirtrueDirObj.SetInfo
Set ServerObj = Nothing
Set VirtrueDirObj = Nothing
End If
CreateFTPDirectory = True
Exit Function
ErrFTP:
Call WriteLog("clsServer", "CreateFTPDirectory", Err.Description)
MsgBox "Error: " & Err.Description, vbCritical, "Create FTP Directory Error"
Err.Clear
End Function
Public Function DeleteFTPDirectory(ByVal VirtrueName As String) As Boolean
Dim ServerObj As Object
Dim MyVirtrueDir As Object
DeleteFTPDirectory = False
On Error GoTo ErrFTP
If CheckExistIIS Then
Set ServerObj = GetObject("IIS://LocalHost/MSFTPSVC/1/ROOT")
For Each MyVirtrueDir In ServerObj
If UCase(MyVirtrueDir.Class) = UCase("IIsFtpVirtualDir") Then
If UCase(MyVirtrueDir.Name) = UCase(Trim(VirtrueName)) Then
ServerObj.Delete "IIsObject", VirtrueName
End If
End If
Next
Set ServerObj = Nothing
End If
DeleteFTPDirectory = True
Exit Function
ErrFTP:
Call WriteLog("clsServer", "DeleteFTPDirectory", Err.Description)
MsgBox "Error: " & Err.Description, vbCritical, "Delete FTP Directory Error"
Err.Clear
End Function
Private Function CheckExistIIS() As Boolean
Dim SysDir As String, IISStartPath As String
Dim FTP As Object, WWW As Object
On Error GoTo CheckErr
Set WWW = GetObject("IIS://LocalHost/W3SVC")
Set FTP = GetObject("IIS://LocalHost/MSFTPSVC")
If Not (IsObject(FTP) And IsObject(WWW)) Then
MsgBox "Not exist the service of WEB.", vbInformation, "Information"
CheckExistIIS = False
Else
SysDir = Space(127)
GetSystemDirectory SysDir, Len(SysDir)
SysDir = Left(SysDir, InStr(1, SysDir, Chr(0)) - 1)
IISStartPath = SysDir & "\iisreset.exe /start"
If Shell(IISStartPath, vbHide) = 0 Then
CheckExistIIS = False
MsgBox "Can not start the service."
Else
CheckExistIIS = True
End If
End If
Set FTP = Nothing
Set WWW = Nothing
Exit Function
CheckErr:
Call WriteLog("clsServer", "CheckExistIIS", Err.Description)
MsgBox Err.Description
CheckExistIIS = False
Err.Clear
End Function
to online(龙卷风V2.0--再战江湖)
代码调试通过,创建目录没有问题,不过还有一个问题没解决.
我每次上传文件的时候要检测一下是否有要上传的目录,如果没有就创建,
现在还是不能判断目录是否存在(因为第一次创建目录成功之后,后面创建都会返回创建失败的),是否有判断目录存在的API函数?谢谢!
如果是api
'打开一个根据连接类型的Internet连接
Public Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
'hInternetSession--函数InternetOpen()打开Internet对话返回的值
'sServerName--要连接的服务器的名称或IP
'nServerPort--该连接的Internet端口
'sUsername--登录的用户帐号
'sPassword--登录的口令
'lService--要连接的服务器类型(这里是连接FTP服务器,连接的类型为常数INTERNET_SERVICE_FTP)
'连接Internet服务的常数
Public Const INTERNET_SERVICE_FTP = 1
Public Const INTERNET_SERVICE_GOPHER = 2
Public Const INTERNET_SERVICE_HTTP = 3
'在ftp服务器上创建目录
Public Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
'lpszDirectory--包含要创建目录的字符串,可以是一个相对路径或绝对路径
'根据打开internet连接的函数internetopen()返回的句柄,用户名,口令
'打开与ftp服务器的连接
hConnection = InternetConnect(hOpen, txtServer.Text, Port, _
strUser, strPassword, INTERNET_SERVICE_FTP, nFlag, 0)
If hConnection = 0 Then
'与ftp服务器的连接失败,显示连接错误信息
Else
'与FTP服务器的连接成功,设置各个控件的Enabled属性
end if
Dim strTemp As String
strTemp = InputBox("请输入要创建的文件夹的名字" & vbCrLf & _
"当前FTP服务器的路径是:", "FTP客户端程序")
If strTemp <> "" Then
Dim bMake As Boolean
'在FTP服务器当前的目录下创建文件夹
bMake = FtpCreateDirectory(hConnection, strTemp)
'创建目录文件夹成功返回值bMake为TRUE
If bMake Then
MsgBox "文件夹创建成功!"
Else
MsgBox "目录创建失败!"
End If
End If
Public Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
...............
Set ftpserverif = GetObject("IIS://" & ComputerName & "/MSFTPSVC/" & I & "/Root/" & Dirname)
If Err.Number = -2147024893 Then
Set virtualdir = ftpServer.Create("IISFTPVirtualDir", Dirname)
virtualdir.path = Realpath
Select Case limitset
Case 1: virtualdir.AccessRead = True
virtualdir.accesswrite = False
Case 2: virtualdir.accesswrite = True
virtualdir.AccessRead = False
Case 3:
virtualdir.AccessRead = True
virtualdir.accesswrite = True
Case Else:
MsgBox "错误的参数!"
CreateVirFTPDir = False
Set ftpServer = Nothing
Set ftpservice = Nothing
Set virtualdir = Nothing
Exit Function
End Select
virtualdir.SetInfo
'创建成功
CreateVirFTPDir = True
Set ftpServer = Nothing
Set ftpserverif = Nothing
Set virtualdir = Nothing
Exit Function
End If
............