How can I upload data using ftp, http, or a socket from a spreadsheet with VBA for Microsoft Office?
I have an Excel spreadsheet, and I want to put a button on it, so users will be able to upload their data to an http/ftp server, or send the data to the server using a socket directly. I have noticed that some people creates an ftp script to do. F开发者_JS百科irst of all, I'm not sure that everybody has ftp on their Windows machine, and secondly, I would prefer to use a method that allows me to better monitor the progress of the upload. For example, I want to know if the user id/password failed, if the transmission completed successfully, of if there were any other kind of errors with the receiving server. Thank you.
I've written a FTP class for use in VBA, which uses the Windows API functions to transfer a file:
Option Explicit
' die wichtigsten Funktionen und Typen aus dem WinInet-API
Private Const MAX_PATH = 260
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_FLAG_ASYNC = &H10000000
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_SERVICE_FTP = 1
Private Const FTP_TRANSFER_TYPE_BINARY As Long = 2
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As Currency
ftLastAccessTime As Currency
ftLastWriteTime As Currency
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Long, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (ByRef lpdwError As Long, ByVal lpszBuffer As String, ByRef lpdwBufferLength As Long) As Boolean
Private Declare Function FtpPutFile Lib "WinInet" Alias "FtpPutFileA" (ByVal hFtp As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpGetFile Lib "WinInet" Alias "FtpGetFileA" (ByVal hFtp As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpDeleteFile Lib "WinInet" Alias "FtpDeleteFileA" (ByVal hFtp As Long, ByVal lpszKillFile As String) As Long
Private Declare Function FtpCreateDirectory Lib "WinInet" Alias "FtpCreateDirectoryA" (ByVal hFtp As Long, ByVal lpszNewDir As String) As Long
Private Declare Function FtpGetCurrentDirectory Lib "WinInet" Alias "FtpGetCurrentDirectoryA" (ByVal hFtp As Long, lpszDirectory As String, ByVal BuffLength As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "WinInet" Alias "FtpSetCurrentDirectoryA" (ByVal hFtp As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpRemoveDirectory Lib "WinInet" Alias "FtpRemoveDirectoryA" (ByVal hFtp As Long, ByVal lpszKillDir As String) As Long
Private Declare Function FtpFindFirstFile Lib "WinInet" Alias "FtpFindFirstFileA" (ByVal hFtp As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpRenameFile Lib "WinInet" Alias "FtpRenameFileA" (ByVal hFtp As Long, ByVal lpszCurFile As String, ByVal lpszNewFile As String) As Long
Private Declare Function GetLastError Lib "kernel" () As Integer
' Member der Klasse
Private m_hConnect As Long
Private m_hFtp As Long
Private Sub Class_Initialize()
m_hConnect = 0
m_hFtp = 0
End Sub
Private Sub Class_Terminate()
Disconnect
End Sub
Public Sub Connect(server As String, user As String, pwd As String)
m_hConnect = InternetOpen("Microsoft Excel", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0) 'INTERNET_FLAG_ASYNC)
If m_hConnect = 0 Then
Err.Raise vbObjectError + 1, , "Verbindung konnte nicht hergestellt werden! Fehler " + CStr(GetLastError)
Exit Sub
End If
m_hFtp = InternetConnect(m_hConnect, server, INTERNET_DEFAULT_FTP_PORT, user, pwd, INTERNET_SERVICE_FTP, 0, 0)
If m_hFtp = 0 Then
Err.Raise vbObjectError + 1, , "Verbindung konnte nicht hergestellt werden! Fehler " + CStr(GetLastError)
Exit Sub
End If
End Sub
Public Sub Disconnect()
If m_hConnect <> 0 Then
InternetCloseHandle m_hConnect
m_hFtp = 0
m_hConnect = 0
End If
End Sub
Public Sub ChangeDir(RemoteDirectory As String)
Dim ret As Long
ret = FtpSetCurrentDirectory(m_hFtp, RemoteDirectory)
If ret = 0 Then
MsgBox CStr(Err.LastDllError)
Err.Raise vbObjectError + 1, , LastError()
End If
End Sub
Public Function CurrentDir() As String
Dim ret As String
ret = Space(1024)
FtpGetCurrentDirectory m_hFtp, ret, 1023
CurrentDir = ret
End Function
Public Sub PutFile(LocalFilename As String, RemoteFilename As String)
If FtpPutFile(m_hFtp, LocalFilename, RemoteFilename, FTP_TRANSFER_TYPE_BINARY, 0) = 0 Then
Err.Raise vbObjectError + 1, , LastError
End If
End Sub
Private Function LastError() As String
Dim ret As String
Dim nErr As Long
ret = Space(1024)
InternetGetLastResponseInfo nErr, ret, 1024
LastError = ret
End Function
Use it like this:
Dim ftp As New CFtp
ftp.Connect GetVar("SERVER"), GetVar("USER"), GetVar("PASS")
ftp.PutFile FILENAME, "/httpdocs/ang.html"
ftp.Disconnect
Not sure if you'd want to deal with the Microsoft Internet Transfer Control (msinet.ocx) but it's an option that would provide you the control you wanted. Here is a link to a good resource to get you started: http://officeone.mvps.org/vba/ftp_upload_file.html
This simple ftp file upload code (adapted it from a code found on the internet) worked well for me in a VBA excel project without having to deal with the MSINET issue :
Don't forget to:
- reference "Microsoft Internet Controls" for your project
- Put the declaration statements at the top of the module
Declare PtrSafe 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
Declare PtrSafe 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 PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Declare PtrSafe Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
ByVal hConnect As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, _
ByVal dwFlags As Long, _
ByRef dwContext As Long) As Boolean
Sub simpleFtpFileUpload()
Internet_OK = InternetOpen("", 1, "", "", 0)
If Internet_OK Then
FTP_OK = InternetConnect(Internet_OK, "ftp", INTERNET_DEFAULT_FTP_PORT, "user", "password", 1, 0, 0)
If FtpSetCurrentDirectory(FTP_OK, "/") Then
success = FtpPutFile(FTP_OK, ThisWorkbook.Path & "\sourceFile", "transferedFile", FTP_TRANSFER_TYPE_BINARY, 0)
End If
End If
If success Then
Debug.Print "ftp success ;)"
Else
Debug.Print "ftp failure :("
End If
End Sub
With Office 64 bit around, you should use conditional compilation and Declare PtrSafe Function ... and for pointer parameters use LongPtr instead of Long for the 64 bit version.
E.g.
#If Win64 Then
Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As LongPtr, 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 LongPtr
#Else
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
#End If
精彩评论