StasS
a écrit:Ce code est en partie récupéré d´un source sur le net et une partie récupéré de mon cerveau (l´utilisation des CommandFTP bien pratique pour modifier les droits sur un fichier par exemple) :
Exemple :
- Code : Tout sélectionner
Dim moFTP As cFTP
Dim returnVal As Variant
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H0
Const INTERNET_FLAG_PASSIVE = &H8000000
Set moFTP = New cFTP
Print "Connection FTP à : MONSERVEUR..."
returnval=moFTP.Connect("MONSERVEUR", "monLogin", "monPassword")
If (returnval = False) Then
Print "ERREUR LORS DE LA CONNEXION A MONSERVEUR"
Exit Sub
End If
returnval=moFTP.PutFile("c:\test.txt", "/home/test.txt", FTP_TRANSFER_TYPE_BINARY)
If (returnval = False) Then
Print "ERREUR LORS DE L´ENVOI DU FICHIER c:\test.txt"
returnval = moFTP.Disconnect()
Exit Sub
End If
returnval=moFTP.FtpCommandSend("SITE CHMOD 777 /home/test.txt")
If (returnval = False) Then
Print "ERREUR LORS DU CHMOD 777"
returnval = moFTP.Disconnect()
Exit Sub
End If
returnval = moFTP.Disconnect()
Print "Fichier envoyé, droits modifiés, connection fermée"
La partie déclaration:
- Code : Tout sélectionner
Private Const MAX_PATH = 260
Private Const vbBinaryCompare=0
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 Const ERROR_NO_MORE_FILES = 18
Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(Byval hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Declare Function NEMProgressBegin Lib "nnotesws.dll" ( Byval wFlags As Integer ) As Long
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
Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(Byval hFtpSession As Long, Byval lpszRemoteFile As String, _
Byval lpszNewFile As String, Byval fFailIfExists As Integer, Byval dwFlagsAndAttributes As Long, _
Byval dwFlags As Long, Byval dwContext As Long) As Integer
Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
(Byval hFtpSession As Long, Byval lpszLocalFile As String, _
Byval lpszRemoteFile As String, _
Byval dwFlags As Long, Byval dwContext As Long) As Integer
Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(Byval hFtpSession As Long, Byval lpszDirectory As String) As Integer
Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(Byval sAgent As String, Byval lAccessType As Long, Byval sProxyName As String, _
Byval sProxyBypass As String, Byval lFlags As Long) As Long
Declare Function FtpCommand Lib "wininet.dll" Alias "FtpCommandA" _
(Byval hConnect As Long, Byval fExpectResponse As Boolean, Byval dwFlags As Long,_
Byval lpszCommand As String, Byval lContext As Long, phFtpCommand As Long) As Boolean
' Use registry access settings.
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
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
Private Const ERROR_INTERNET_EXTENDED_ERROR = 12003
Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" ( _
lpdwError As Long, _
Byval lpszBuffer As String, _
lpdwBufferLength As Long) As Integer
' Type of service to access.
Private Const INTERNET_SERVICE_FTP = 1
'private Const INTERNET_SERVICE_GOPHER = 2
'private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_MULTIPART = &H200000
Declare Function FtpOpenFile Lib "wininet.dll" Alias _
"FtpOpenFileA" (Byval hFtpSession As Long, _
Byval sFileName As String, Byval lAccess As Long, _
Byval lFlags As Long, Byval lContext As Long) As Long
Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (Byval hFtpSession As Long, _
Byval lpszFileName As String) As Integer
Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" _
(Byval hFtpSession As Long,Byval sExistingName As String, Byval sNewName As String) As Integer
' Closes a single Internet handle or a subtree of Internet handles.
Declare Function InternetCloseHandle Lib "wininet.dll" _
(Byval hInet As Long) As Integer
'
' Our Defined Errors
'
%REM
'Public Enum errFtpErrors
errCannotConnect = vbObjectError + 2001
errNoDirChange = vbObjectError + 2002
errCannotRename = vbObjectError + 2003
errCannotDelete = vbObjectError + 2004
errNotConnectedToSite = vbObjectError + 2005
errGetFileError = vbObjectError + 2006
errInvalidProperty = vbObjectError + 2007
errFatal = vbObjectError + 2008
End Enum
%END REM
'
' File Transfer types
'
%REM
Public Enum FileTransferType
ftAscii = FTP_TRANSFER_TYPE_ASCII
ftBinary = FTP_TRANSFER_TYPE_BINARY
End Enum
%END REM
'
' Error messages
'
Private Const ERRCHANGEDIRSTR = "Cannot Change Directory to %s. It either doesn't exist, or is protected"
Private Const ERRCONNECTERROR = "Cannot Connect to %s using User and Password Parameters"
Private Const ERRNOCONNECTION = "Not Connected to FTP Site"
Private Const ERRNODOWNLOAD = "Couldn't Get File %s from Server"
Private Const ERRNORENAME = "Couldn't Rename File %s"
Private Const ERRNODELETE = "Couldn't Delete File %s from Server"
Private Const ERRALREADYCONNECTED = "You cannot change this property while connected to an FTP server"
Private Const ERRFATALERROR = "Cannot get Connection to WinInet.dll !"
'
' Session Identifier to Windows
'
Private Const SESSION = "CGFtp Instance"
Class cFTP
Private temp As Integer
'
' Our INET handle
'
Private mlINetHandle As Long
'
' Our FTP Connection Handle
'
Private mlConnection As Long
'
' Standard FTP properties for this class
'
Private msHostAddress As String
Private msUser As String
Private msPassword As String
Private msDirectory As String
Private Sub Initialise()
'
' Create Internet session handle
'
mlINetHandle = InternetOpen(SESSION, INTERNET_OPEN_TYPE_DIRECT, Null, Null, 0)
mlINetHandle = InternetOpen(SESSION, INTERNET_OPEN_TYPE_DIRECT, Null, Null, 0)
If mlINetHandle = 0 Then
mlConnection = 0
'Err.Raise errFatal, "CGFTP::Class_Initialise", ERRFATALERROR
End If
mlConnection = 0
End Sub
'GET and SET Host #############################################
Public Property Set Host (sHostName As String)
'
' Set the Host Name - only if not connected
'
If mlConnection <> 0 Then
REM Err.Raise errInvalidProperty, "ACNFTP:Host_Let", ERRALREADYCONNECTED
End If
msHostAddress = sHostName
End Property
Public Property Get Host(sHostName As String)
'
' Get Host Name
'
Host = msHostAddress
End Property
'GET and SET User #############################################
Public Property Set User(sUserName As String)
'
' Set the user - only if not connected
'
If mlConnection <> 0 Then
REM Err.Raise errInvalidProperty, "CGFTP::User_Let", ERRALREADYCONNECTED
End If
msUser = sUserName
End Property
Public Property Get User(sUserName As String)
'
' Get the user information
'
User = msUser
End Property
'GET and SET Password #############################################
Public Property Set Password( sPassword As String)
'
' Set the password - only if not connected
'
If mlConnection <> 0 Then
REM Err.Raise errInvalidProperty, "CGFTP::Password_Let", ERRALREADYCONNECTED
End If
msPassword = sPassword
End Property
Public Property Get Password(sPassword As String)
'
' Get the password
'
Password = msPassword
End Property
Public Property Get Directory(sDirectory As String)
'
' Get the directory
'
Directory = msDirectory
End Property
'GET and SET Directory #############################################
Public Property Set Directory(sDirectory As String)
'
' Set the directory - only if connected
'
On Error Goto vbErrorHandler
Dim sError As String
If Not (mlConnection = 0) Then
RemoteChDir sDirectory
msDirectory = sDirectory
Else
On Error Goto 0
REM Err.Raise errNotConnectedToSite, "CGFTP::Directory_Let", ERRNOCONNECTION
End If
Exit Property
vbErrorHandler:
REM Err.Raise errNoDirChange, "CGFTP::Directory[Let]", Err.Description
End Property
'GET and SET Connected #############################################
Public Property Get Connected() As Integer
'
' Are we connected to an FTP Server ? T/F
'
Connected = (mlConnection <> 0)
End Property
Private Sub Terminate()
'
' Kill off any connection
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
End If
'
' Kill off API Handle
'
If mlINetHandle <> 0 Then
InternetCloseHandle mlINetHandle
End If
mlConnection = 0
mlINetHandle = 0
End Sub
Public Function Disconnect() As Integer
'
' Disconnect, only if connected !
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
mlConnection = 0
Else
REM Err.Raise errNotConnectedToSite, "CGFTP::Disconnect", ERRNOCONNECTION
End If
msHostAddress = ""
msUser = ""
msPassword = ""
msDirectory = ""
End Function
Public Function Connect(Host As String, User As String, Password As String) As Integer
'
' Connect to the FTP server
'
On Error Goto vbErrorHandler
Dim sError As String
'
' If we already have a connection then raise an error
'
If mlConnection <> 0 Then
On Error Goto 0
REM Err.Raise errInvalidProperty, "CGFTP::Connect", "You are already connected to FTP Server " & msHostAddress
Exit Function
End If
'
' Overwrite any existing properties if they were supplied in the
' arguments to this method
'
If Len(Host) > 0 Then
msHostAddress = Host
End If
If Len(User) > 0 Then
msUser = User
End If
If Len(Password) > 0 Then
msPassword = Password
End If
'
' Connect !
'
If Len(msHostAddress) = 0 Then
REM Err.Raise errInvalidProperty, "CGFTP::Connect", "No Host Address Specified!"
End If
mlConnection = InternetConnect(mlINetHandle, msHostAddress, INTERNET_INVALID_PORT_NUMBER, _
msUser, msPassword, INTERNET_SERVICE_FTP, 0, 0)
'
' Check for connection errors
'
If mlConnection = 0 Then
'sError = Replace(ERRCONNECTERROR, "%s", msHostAddress)
On Error Goto 0
'sError = sError & chr(10) & chr(13) & GetINETErrorMsg(Err.LastDllError)
REM Err.Raise errCannotConnect, "CGFTP::Connect", sError
End If
Connect = True
Exit Function
vbErrorHandler:
REM Err.Raise Err.Number, "cFTP::Connect", Err.Description
End Function
Public Function GetDirectoryList(Directory As String, FilterString As String) As Variant
'
' Returns a Disconnected record set for the
' directory and filterstring
'
' eg. "/NTFFiles", "*.ntf"
'
On Error Goto vbErrorHandler
Dim oFileColl As Variant
Dim lFind As Long
Dim lLastError As Long
Dim lPtr As Long
Dim pData As WIN32_FIND_DATA
Dim sFilter As String
Dim lError As Long
Dim bRet As Integer
Dim sItemName As String
Dim oRS As Variant
Redim oRS(0)
Dim ElementCount
ElementCount=0
'Dim oRS List As String
'
' Check if already connected, else raise an error
'
If mlConnection = 0 Then
REM Err.Raise errNotConnectedToSite, "CGFTP::GetDirectoryList", ERRNOCONNECTION
End If
'
' Build the disconnected recordset structure.
'
REM Set oRS = New ADOR.Recordset
REM oRS.CursorLocation = adUseClient
REM oRS.Fields.Append "Name", adBSTR
REM oRS.Open
'
' Change directory if required
'
If Len(Directory) > 0 Then
RemoteChDir Directory
End If
pData.cFileName = String$(MAX_PATH, Chr(0))
If Len(FilterString) > 0 Then
sFilter = FilterString
Else
sFilter = "*.*"
End If
'
' Get the first file in the directory
'
lFind = FtpFindFirstFile(mlConnection, sFilter, pData, 0, 0)
REM lLastError = Err.LastDllError
'
' If no files, then return an empty recordset.
'
If lFind = 0 Then
If lLastError = ERROR_NO_MORE_FILES Then
' Empty directory
GetDirectoryList = oRS
Exit Function
Else
On Error Goto 0
REM Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "" & FilterString
End If
Exit Function
End If
'
' Add the first found file into the recordset
'
sItemName = Left$(pData.cFileName, Instr(1, pData.cFileName, Chr(0),vbBinaryCompare) - 1)
oRS(ElementCount)=sItemName
REM oRS.AddNew "Name", sItemName
'
' Get the rest of the files in the list
'
Do
pData.cFileName = String(MAX_PATH,Chr(0))
bRet = InternetFindNextFile(lFind, pData)
'If Not (bRet) Then
If (bRet=0) Then
lLastError = Err
'If lLastError = ERROR_NO_MORE_FILES Then
If lLastError = 0 Then
Exit Do
Else
InternetCloseHandle lFind
On Error Goto 0
Error 1001, "cFTP::GetDirectoryList .. Error looking at directory " & Directory & "" & FilterString
temp=Err
Msgbox "cFTP::GetDirectoryList" & "Error looking at directory " & Directory & "" & FilterString
Exit Function
End If
Else
sItemName = Left$(pData.cFileName, Instr(1, pData.cFileName, Chr(0),vbBinaryCompare) - 1)
ElementCount=ElementCount+1
Redim Preserve oRS(elementCount)
oRS(ElementCount)=sItemName
End If
Loop
'
' Close the 'find' handle
'
InternetCloseHandle lFind
On Error Resume Next
REM oRS.MoveFirst
REM Err.Clear
On Error Goto 0
GetDirectoryList = oRS
Exit Function
vbErrorHandler:
'
' Tidy up & raise an error
'
If lFind <> 0 Then
InternetCloseHandle lFind
End If
REM Set GetDirectoryList = oRS
REM Err.Raise Err.Number, "cFTP::GetDirectoryList", Err.Description
End Function
Private Sub RemoteChDir(Byval sDir As String)
On Error Goto vbErrorHandler
'
' Remote Change Directory Command through WININET
'
Dim sPathFromRoot As String
Dim bRet As Integer
Dim sError As String
'
' Needs standard Unix Convention
'
sDir = Replace(sDir, "", "/")
'
' Check for a connection
'
If mlConnection = 0 Then
On Error Goto 0
REM Err.Raise errNotConnectedToSite, "CGFTP::RemoteChDir", ERRNOCONNECTION
Exit Sub
End If
If Len(sDir) = 0 Then
Exit Sub
Else
sPathFromRoot = sDir
If Len(sPathFromRoot) = 0 Then
sPathFromRoot = "/"
End If
bRet = FtpSetCurrentDirectory(mlConnection, sPathFromRoot)
'
' If we couldn't change directory - raise an error
'
If bRet = False Then
sError = ERRCHANGEDIRSTR
sError = Replace(sError, "%s", sDir)
On Error Goto 0
REM Err.Raise errNoDirChange, "CGFTP::ChangeDirectory", sError
End If
End If
Exit Sub
vbErrorHandler:
REM Err.Raise Err.Number, "cFTP::RemoteChDir", Err.Description
End Sub
Public Function DeleteFile(Byval ExistingName As String) As Integer
Dim bRet As Integer
Dim sError As String
On Error Goto vbErrorHandler
'
' Check for a connection
'
If mlConnection = 0 Then
On Error Goto 0
REM Err.Raise errNotConnectedToSite, "CGFTP::DeleteFile", ERRNOCONNECTION
End If
bRet = FtpDeleteFile(mlConnection, ExistingName)
'
' Raise an error if the file couldn't be deleted
'
If bRet = False Then
sError = ERRNODELETE
sError = Replace(sError, "%s", ExistingName)
On Error Goto 0
REM Err.Raise errCannotDelete, "CGFTP::DeleteFile", sError
End If
DeleteFile = True
Exit Function
vbErrorHandler:
REM Err.Raise Err.Number, "cFTP::DeleteFile", Err.Description
End Function
'Public Function GetFile(Byval ServerFileAndPath As String, Byval DestinationFileAndPath As String, TransferType As FileTransferType) As Integer
Public Function GetFile(Byval ServerFileAndPath As String, Byval DestinationFileAndPath As String, TransferType As Long) As Integer
'
' Get the specified file to the desired location using the specified
' file transfer type
'
Dim bRet As Integer
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error Goto vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error Goto 0
REM Err.Raise errNotConnectedToSite, "CGFTP::GetFile", ERRNOCONNECTION
End If
'
' Get the file
'
bRet = FtpGetFile(mlConnection, ServerFileAndPath, DestinationFileAndPath, False, INTERNET_FLAG_RELOAD, TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error Goto 0
GetFile = False
REM Err.Raise errGetFileError, "CGFTP::GetFile", sError
End If
GetFile = True
Exit Function
vbErrorHandler:
GetFile = False
REM Err.Raise errGetFileError, "cFTP::GetFile", Err.Description
End Function
'Public Function PutFile(Byval LocalFileAndPath As String, Byval ServerFileAndPath As String,TransferType As FileTransferType) As Integer
Public Function PutFile(Byval LocalFileAndPath As String, Byval ServerFileAndPath As String,TransferType As Long) As Integer
Dim bRet As Integer
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error Goto vbErrorHandler
'
' If not connected, raise an error!
'
If mlConnection = 0 Then
On Error Goto 0
REM Err.Raise errNotConnectedToSite, "CGFTP::PutFile", ERRNOCONNECTION
End If
bRet = FtpPutFile(mlConnection, LocalFileAndPath, ServerFileAndPath, _
TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error Goto 0
PutFile = False
REM sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDllError)
REM Err.Raise errCannotRename, "CGFTP::PutFile", sError
End If
PutFile = True
Exit Function
vbErrorHandler:
REM Err.Raise Err.Number, "cFTP::PutFile", Err.Description
End Function
Public Function RenameFile(Byval ExistingName As String, Byval NewName As String) As Integer
Dim bRet As Integer
Dim sError As String
On Error Goto vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error Goto 0
REM Err.Raise errNotConnectedToSite, "CGFTP::RenameFile", ERRNOCONNECTION
End If
bRet = FtpRenameFile(mlConnection, ExistingName, NewName)
'
' Raise an error if we couldn't rename the file (most likely that
' a file with the new name already exists
'
If bRet = False Then
sError = ERRNORENAME
sError = Replace(sError, "%s", ExistingName)
On Error Goto 0
RenameFile = False
REM sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDllError)
REM Err.Raise errCannotRename, "CGFTP::RenameFile", sError
End If
RenameFile = True
Exit Function
vbErrorHandler:
REM Err.Raise Err.Number, "cFTP::RenameFile", Err.Description
End Function
Public Function FtpCommandSend(Byval mlCommandToApply As String) As Boolean
Dim bRet As Integer
Dim sError As String
On Error Goto vbErrorHandler
If mlConnection = 0 Then
On Error Goto 0
REM Err.Raise errNotConnectedToSite, "CGFTP::RenameFile", ERRNOCONNECTION
End If
bRet = FtpCommand(mlConnection, False, FTP_TRANSFER_TYPE_BINARY, mlCommandToApply, 1, 0)
If bRet = False Then
sError = ERRNORENAME
On Error Goto 0
REM sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDllError)
REM Err.Raise errCannotRename, "CGFTP::RenameFile", sError
End If
FtpCommandSend = True
Exit Function
vbErrorHandler:
'Print Err.Raise
REM Err.Raise Err.Number, "cFTP::RenameFile", Err.Description
End Function
Private Function GetINETErrorMsg(Byval ErrNum As Long) As String
Dim lError As Long
Dim lLen As Long
Dim sBuffer As String
'
' Get Extra Info from the WinInet.DLL
'
If ErrNum = ERROR_INTERNET_EXTENDED_ERROR Then
'
' Get Message Size and Number
'
InternetGetLastResponseInfo lError, Null, lLen
sBuffer = String$(lLen + 1, Chr(0))
'
' Get Message
'
InternetGetLastResponseInfo lError, sBuffer, lLen
GetINETErrorMsg = Chr(10) +Chr(13) & sBuffer
End If
End Function
Public Sub new()
Call Me.initialise
End Sub
Public Sub delete()
Call Me.terminate
End Sub
End Class
