' Set Constants
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21
Const INTERNET_DEFAULT_HTTP_PORT = 80
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_SERVICE_HTTP = 80
Const INTERNET_FLAG_PASSIVE = &H8000000
Const GENERIC_WRITE = &H40000000
Const GENERIC_READ = &H80000000
Const BUFFER_SIZE = 100
Const PassiveConnection As Boolean = True
Const MAX_PATH = 260
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public 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
' Declare wininet.dll API Functions
Public Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Public Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Boolean
Public Declare Function FtpGetFileSize Lib "wininet.dll" _
(ByVal hFile As Long, ByRef lpdwFileSizeHigh As Long) As Long
Public Declare Function InternetWriteFile Lib "wininet.dll" _
(ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToWite As Long, _
dwNumberOfBytesWritten As Long) As Integer
Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToRead As Long, _
dwNumberOfBytesRead As Long) As Integer
Public Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileA" _
(ByVal hFtpSession As Long, ByVal sBuff As String, ByVal Access As Long, ByVal Flags As Long, ByVal Context As Long) As Long
Public 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 Boolean
Public Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
ByVal lpszFileName As String) As Boolean
Public Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Long
Public 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
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
Public Declare Function FTPGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Declare Function InternetGetLastResponseInfo Lib "wininet.dll" _
Alias "InternetGetLastResponseInfoA" _
(ByRef lpdwError As Long, _
ByVal lpszErrorBuffer As String, _
ByRef lpdwErrorBufferLength As Long) As Boolean
Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Private 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
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As LongFunction FTPList(ByVal HostName As String, ByVal Username As String, ByVal Password As String, ByVal sDir As String) As String()
On Error GoTo Err_Function
Dim sOrgPAth As String
Dim pData As WIN32_FIND_DATA
Dim hFind As Long, lRet As Long
Dim hConnection, hOpen, hFile As Long
Dim sFiles() As String
sPath = String(MAX_PATH, 0)
' Open Internet Connecion
hOpen = InternetOpen("FTP", 1, "", vbNullString, 0)
' Connect to FTP
hConnection = InternetConnect(hOpen, HostName, INTERNET_DEFAULT_FTP_PORT, Username, Password, INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
' Change Directory
Call FtpSetCurrentDirectory(hConnection, sDir)
' get list of directory
Call FtpGetCurrentDirectory(hConnection, sPath, Len(sPath))
pData.cFileName = String(MAX_PATH, 0)
'find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
'if there are files
If hFind <> 0 Then
'set first file
ReDim Preserve sFiles(0)
sFiles(UBound(sFiles)) = left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
'create a buffer
pData.cFileName = String(MAX_PATH, 0)
'find the next file
lRet = InternetFindNextFile(hFind, pData)
'if there's no next file, exit do
If lRet = 0 Then Exit Do
ReDim Preserve sFiles(UBound(sFiles) + 1)
'add additional files
sFiles(UBound(sFiles)) = left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
End If
Exit_Function:
' Close Internet Connection
Call InternetCloseHandle(hOpen)
Call InternetCloseHandle(hConnection)
FTPList = sFiles
Exit Function
Err_Function:
MsgBox "Error in FTPList : " & err.Description
GoTo Exit_Function
End Function Dim myFiles() As String
' get list of files
myFiles = FTPList("127.0.0.1 - FTP Server IP", "MyUserID", "MyPWD", "/my/folder/path/")
[blue]Option Explicit
[green]' Requires references to Microsoft Shell Controls and Automation[/green]
Public Sub Example()
Dim myFolderItem As FolderItem
Dim localfolder As Folder
Dim myShell As New Shell
For Each myFolderItem In ftpList("ftp.microsoft.com/Products/Windows/Windows95/CDRomExtras/OtherUtilities/") [green]'Each item could be a folder or a file[/green]
Debug.Print myFolderItem.Name, myFolderItem.IsFolder [green]' just for fun to illustrate stuff we can do[/green]
If myFolderItem.Name = "olddos.exe" Then
Set localfolder = myShell.Namespace("F:\temp") [green]' or wherever your local folder is[/green]
localfolder.CopyHere myFolderItem [green]' copy the required item[/green]
End If
Next
End Sub
[green]' Returns a FolderItems collection from the FTP server[/green]
Private Function ftpList(strFTPlocation As String, Optional strUser As String, Optional strPassword As String) As FolderItems
Dim myShell As Shell
Dim strConnect As String
Set myShell = New Shell
If strUser <> "" Then strConnect = strUser & ":" & strPassword & "@"
Set ftpList = myShell.Namespace("FTP://" & strConnect & strFTPlocation).Items '("ftp://user:password@ftp.site.com")
End Function[/blue]For i = 0 To UBound(myFiles)
Debug.Print myFiles(i)
NexthOpen = InternetOpen("FTP", 1, "", vbNullString, 0)so poke around with that and see what you get
Not sure how you work that out Mike, i've been using code like that since 2006/7 -> faq705-5904
Sub ShowError()
Dim lErr As Long, sErr As String, lenBuf As Long
'get the required buffer size
InternetGetLastResponseInfo lErr, sErr, lenBuf
'create a buffer
sErr = String(lenBuf, 0)
'retrieve the last response info
InternetGetLastResponseInfo lErr, sErr, lenBuf
'show the last response info
MsgBox "Last Server Response : " + sErr, vbOKOnly + vbCritical
End SubFunction FTPFile(ByVal HostName As String, _
ByVal Username As String, _
ByVal Password As String, _
ByVal LocalFileName As String, _
ByVal RemoteFileName As String, _
ByVal sDir As String, _
ByVal sMode As String) As Boolean
On Error GoTo Err_Function
' Declare variables
Dim hConnection, hOpen, hFile As Long ' Used For Handles
Dim iSize As Long ' Size of file for upload
Dim Retval As Variant ' Used for progress meter
Dim iWritten As Long ' Used by InternetWriteFile to report bytes uploaded
Dim iLoop As Long ' Loop for uploading chuncks
Dim iFile As Integer ' Used for Local file handle
Dim FileData(BUFFER_SIZE - 1) As Byte ' buffer array of BUFFER_SIZE (100) elements 0 to 99
' Open Internet Connecion
hOpen = InternetOpen("FTP", 1, "", vbNullString, 0)
' Connect to FTP
hConnection = InternetConnect(hOpen, HostName, INTERNET_DEFAULT_FTP_PORT, Username, Password, INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
' Change Directory
Call FtpSetCurrentDirectory(hConnection, sDir)
' Open Remote File
hFile = FtpOpenFile(hConnection, RemoteFileName, GENERIC_WRITE, IIf(sMode = "Binary", FTP_TRANSFER_TYPE_BINARY, FTP_TRANSFER_TYPE_ASCII), 0)
' Check for successfull file handle
If hFile = 0 Then
MsgBox "Internet - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
' Set Upload Flag to True
FTPFile = True
' Get next file handle number
iFile = FreeFile
' Open local file
Open LocalFileName For Binary Access Read As iFile
' Set file size
iSize = LOF(iFile)
' Iinitialise progress meter
Retval = SysCmd(acSysCmdInitMeter, "Uploading File (" & RemoteFileName & ")", iSize / 1000)
' Loop file size
For iLoop = 1 To iSize \ BUFFER_SIZE
' Update progress meter
Retval = SysCmd(acSysCmdUpdateMeter, (BUFFER_SIZE * iLoop) / 1000)
'Get file data
Get iFile, , FileData
' Write chunk to FTP checking for success
If InternetWriteFile(hFile, FileData(0), BUFFER_SIZE, iWritten) = 0 Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
Else
' Check buffer was written
If iWritten <> BUFFER_SIZE Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
End If
Next iLoop
' Handle remainder using MOD
' Update progress meter
Retval = SysCmd(acSysCmdUpdateMeter, iSize / 1000)
' Get file data
Get iFile, , FileData
' Write remainder to FTP checking for success
If InternetWriteFile(hFile, FileData(0), iSize Mod BUFFER_SIZE, iWritten) = 0 Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
Else
' Check buffer was written
If iWritten <> iSize Mod BUFFER_SIZE Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
End If
Exit_Function:
' remove progress meter
Retval = SysCmd(acSysCmdRemoveMeter)
'close remote file
Call InternetCloseHandle(hFile)
'close local file
Close iFile
' Close Internet Connection
Call InternetCloseHandle(hOpen)
Call InternetCloseHandle(hConnection)
Exit Function
Err_Function:
MsgBox "Error in FTPFile : " & err.Description
GoTo Exit_Function
End FunctionFunction PutFileUsingFTP(ByVal HostName As String, ByVal UserName As String, ByVal Password As String, ByVal FileToPut As String, ByVal WhereToPut As String) As String()
On Error GoTo Err_Function
Dim sOrgPAth As String
Dim pData As WIN32_FIND_DATA
Dim hFind As Long, lRet As Long
Dim hConnection, hOpen, hFile As Long
' Open Internet Connecion
DisplayMessage "Connecting to domain...."
hOpen = InternetOpen("FTP", 1, "", vbNullString, 0)
' Connect to FTP
hConnection = InternetConnect(hOpen, HostName, INTERNET_DEFAULT_FTP_PORT, UserName, Password, INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
'get file
DisplayMessage "Transferring file...."
Call FtpPutFile(hConnection, FileToPut, WhereToPut, 0, 0)
DisplayMessage "File Transferred file...."
Exit_Function:
' Close Internet Connection
DisplayMessage "Closing connection to domain...."
Call InternetCloseHandle(hOpen)
Call InternetCloseHandle(hConnection)
Exit Function
Err_Function:
MsgBox "Error in GetFile : " & Err.Description
GoTo Exit_Function
End Function' Get next file handle number
iFile = FreeFile
' Open local file
Open LocalFileName For Binary Access Read As iFile
' Set file size
iSize = LOF(iFile)
' Initialise progress meter
Retval = SysCmd(acSysCmdInitMeter, "Uploading File (" & RemoteFileName & ")", iSize / 1000)
' Loop file size
For iLoop = 1 To iSize \ BUFFER_SIZE
' Update progress meter
Retval = SysCmd(acSysCmdUpdateMeter, (BUFFER_SIZE * iLoop) / 1000)
'Get file data
Get iFile, , FileData
' Write chunk to FTP checking for success
If InternetWriteFile(hFile, FileData(0), BUFFER_SIZE, iWritten) = 0 Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
Else
' Check buffer was written
If iWritten <> BUFFER_SIZE Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
End If
Next iLoop
' Handle remainder using MOD
' Update progress meter
Retval = SysCmd(acSysCmdUpdateMeter, iSize / 1000)
' Get file data
Get iFile, , FileData
' Write remainder to FTP checking for success
If InternetWriteFile(hFile, FileData(0), iSize Mod BUFFER_SIZE, iWritten) = 0 Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
Else
' Check buffer was written
If iWritten <> iSize Mod BUFFER_SIZE Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
End If
Exit_Function:
' remove progress meter
Retval = SysCmd(acSysCmdRemoveMeter)' Upload file
If FTPFile("ftp.domain.com", "myUserName", "myPassword", "Full path and Filename of local file","Target Filename without path", "Directory on FTP server", "Upload Mode - Binary or ASCII") Then
MsgBox "Upload - Complete!"
End If
