442
asked on
Sending A report via FTP in a macro
I am using Access97, on windows NT Machine.
Is there a way of sending a report via ftp in a macro. For example, in a macro you can specify to send an object via outlook to a mail recepient.
Is there a way of sending the same report(object) automatically, using VBA or Macro by FTP to a server.
Please provide VBA code where applicable.
Thank you in advance
442
Is there a way of sending a report via ftp in a macro. For example, in a macro you can specify to send an object via outlook to a mail recepient.
Is there a way of sending the same report(object) automatically, using VBA or Macro by FTP to a server.
Please provide VBA code where applicable.
Thank you in advance
442
ASKER
Edited text of question.
You can use the SendObject action to include the specified Microsoft Access datasheet, form, report, or module in an electronic mail message, where it can be viewed and forwarded. You can include objects in Microsoft Excel 97 (*.xls), MS-DOS text (*.txt), rich-text (*.rtf), or HTML (*.html) format in messages for Microsoft Exchange, Microsoft Mail, Microsoft Windows for Workgroups mail, or another electronic mail application that uses the Microsoft Mail Applications Programming Interface (MAPI).
If you have an electronic mail application that uses the Vendor Independent Mail (VIM) protocol and have installed and set up the dynamic-link library (Mapivim.dll) that converts MAPI mail messages to the VIM protocol, you can send Microsoft Access objects to the VIM mail application.
-------------------------- ---------- ---------- ---------- ---------- ---------- ---------- ----------
The SendObject method carries out the SendObject action in Visual Basic. For more information on how the action and its arguments work, see the action topic (above).
Syntax:
DoCmd.SendObject [objecttype][, objectname][, outputformat][, to][, cc][, bcc][, subject][, messagetext][, editmessage][, templatefile]
Argument Description
-------------------------- ---------- -
objecttype One of the following intrinsic constants:
acSendForm
acSendModule
acSendNoObject (default)
acSendQuery
acSendReport
acSendTable
objectname A string expression that's the valid name of an object of the type selected by the objecttype argument. If you want to include the active object in the mail message, specify the object's type with the objecttype argument and leave this argument blank. If you leave both the objecttype and objectname arguments blank (the default constant, acSendNoObject, is assumed for the objecttype argument), Microsoft Access sends a message to the electronic mail application without an included database object.
If you run Visual Basic code containing the SendObject method in a library database, Microsoft Access looks for the object with this name first in the library database, then in the current database.
outputformat One of the following intrinsic constants:
acFormatHTML
acFormatRTF
acFormatTXT
acFormatXLS
If you leave this argument blank, Microsoft Access prompts you for the output format.
to A string expression that lists the recipients whose names you want to put on the To line in the mail message.
Separate the recipient names you specify in this argument and in the cc and bcc arguments with a semicolon (;) or with the list separator set on the Number tab of the Regional Settings Properties dialog box in Windows Control Panel. If the recipient names aren't recognized by the mail application, the message isn't sent.
If you leave this argument blank, Microsoft Access prompts you for the recipients.
cc A string expression that lists the recipients whose names you want to put on the Cc line in the mail message. If you leave this argument blank, the Cc line in the mail message is blank.
bcc A string expression that lists the recipients whose names you want to put on the Bcc line in the mail message. If you leave this argument blank, the Bcc line in the mail message is blank.
subject A string expression containing the text you want to put on the Subject line in the mail message. If you leave this argument blank, the Subject line in the mail message is blank.
messagetext A string expression containing the text you want to include in the body of the mail message, after the object. If you leave this argument blank, the object is all that's included in the body of the mail message.
editmessage Use True (–1) to open the electronic mail application immediately with the message loaded, so the message can be edited. Use False (0) to send the message without editing it. If you leave this argument blank, the default (True) is assumed.
templatefile A string expression that's the full name, including the path, of the file you want to use as a template for an HTML file.
Remarks:
You can leave an optional argument blank in the middle of the syntax, but you must include the argument's comma. If you leave a trailing argument blank, don't use a comma following the last argument you specify.
If you look in the help file under 'SendObject Method, there is a brief example...
Brian
If you have an electronic mail application that uses the Vendor Independent Mail (VIM) protocol and have installed and set up the dynamic-link library (Mapivim.dll) that converts MAPI mail messages to the VIM protocol, you can send Microsoft Access objects to the VIM mail application.
--------------------------
The SendObject method carries out the SendObject action in Visual Basic. For more information on how the action and its arguments work, see the action topic (above).
Syntax:
DoCmd.SendObject [objecttype][, objectname][, outputformat][, to][, cc][, bcc][, subject][, messagetext][, editmessage][, templatefile]
Argument Description
--------------------------
objecttype One of the following intrinsic constants:
acSendForm
acSendModule
acSendNoObject (default)
acSendQuery
acSendReport
acSendTable
objectname A string expression that's the valid name of an object of the type selected by the objecttype argument. If you want to include the active object in the mail message, specify the object's type with the objecttype argument and leave this argument blank. If you leave both the objecttype and objectname arguments blank (the default constant, acSendNoObject, is assumed for the objecttype argument), Microsoft Access sends a message to the electronic mail application without an included database object.
If you run Visual Basic code containing the SendObject method in a library database, Microsoft Access looks for the object with this name first in the library database, then in the current database.
outputformat One of the following intrinsic constants:
acFormatHTML
acFormatRTF
acFormatTXT
acFormatXLS
If you leave this argument blank, Microsoft Access prompts you for the output format.
to A string expression that lists the recipients whose names you want to put on the To line in the mail message.
Separate the recipient names you specify in this argument and in the cc and bcc arguments with a semicolon (;) or with the list separator set on the Number tab of the Regional Settings Properties dialog box in Windows Control Panel. If the recipient names aren't recognized by the mail application, the message isn't sent.
If you leave this argument blank, Microsoft Access prompts you for the recipients.
cc A string expression that lists the recipients whose names you want to put on the Cc line in the mail message. If you leave this argument blank, the Cc line in the mail message is blank.
bcc A string expression that lists the recipients whose names you want to put on the Bcc line in the mail message. If you leave this argument blank, the Bcc line in the mail message is blank.
subject A string expression containing the text you want to put on the Subject line in the mail message. If you leave this argument blank, the Subject line in the mail message is blank.
messagetext A string expression containing the text you want to include in the body of the mail message, after the object. If you leave this argument blank, the object is all that's included in the body of the mail message.
editmessage Use True (–1) to open the electronic mail application immediately with the message loaded, so the message can be edited. Use False (0) to send the message without editing it. If you leave this argument blank, the default (True) is assumed.
templatefile A string expression that's the full name, including the path, of the file you want to use as a template for an HTML file.
Remarks:
You can leave an optional argument blank in the middle of the syntax, but you must include the argument's comma. If you leave a trailing argument blank, don't use a comma following the last argument you specify.
If you look in the help file under 'SendObject Method, there is a brief example...
Brian
Yes, you can automate sending an object via FTP. Unfortunatley I can not give you specifics because I don't currently have access to an FTP server to test it out on.
If you can manually log in to the FTP server and upload the file then you can automate it. Create a text file (Let's call if "script1.ftp") with all of the commands you use to upload the file when you do it manually. Then use Shell "FTP -s:script1.ftp" to get it done.
Maybe this will get you started in the right direction.
If you can manually log in to the FTP server and upload the file then you can automate it. Create a text file (Let's call if "script1.ftp") with all of the commands you use to upload the file when you do it manually. Then use Shell "FTP -s:script1.ftp" to get it done.
Maybe this will get you started in the right direction.
Sub TestFTPUpload()
On Error GoTo ErrHandler
Dim objFTP As InetTransferLib.FTP
Const conTARGET = "ftp://ftp.someserver.com"
Set objFTP = New InetTransferLib.FTP
With objFTP
.FtpURL = conTARGET
.SourceFile = vbNullString
.DestinationFile = "/2/test.txt"
.AutoCreateRemoteDir = True
If Not .IsConnected Then .DialDefaultNumber
.ConnectToFTPHost "username", "password"
.UploadFileToFTPServer
End With
ExitHere:
On Error Resume Next
Set objFTP = Nothing
Call SysCmd(acSysCmdRemoveMeter )
Exit Sub
ErrHandler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, Err.Source
Resume ExitHere
End Sub
Note:
Needs API functions stored in WinInet.dll which is installed by Microsoft Internet Explorer.
On Error GoTo ErrHandler
Dim objFTP As InetTransferLib.FTP
Const conTARGET = "ftp://ftp.someserver.com"
Set objFTP = New InetTransferLib.FTP
With objFTP
.FtpURL = conTARGET
.SourceFile = vbNullString
.DestinationFile = "/2/test.txt"
.AutoCreateRemoteDir = True
If Not .IsConnected Then .DialDefaultNumber
.ConnectToFTPHost "username", "password"
.UploadFileToFTPServer
End With
ExitHere:
On Error Resume Next
Set objFTP = Nothing
Call SysCmd(acSysCmdRemoveMeter
Exit Sub
ErrHandler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, Err.Source
Resume ExitHere
End Sub
Note:
Needs API functions stored in WinInet.dll which is installed by Microsoft Internet Explorer.
Define FTP module as follows:
Option Compare Database
Option Explicit
' FTP Module
Private Type URL_COMPONENTS
dwStructSize As Long
lpszScheme As String
dwSchemeLength As Long
nScheme As Long
lpszHostName As String
dwHostNameLength As Long
nPort As Long
lpszUserName As String
dwUserNameLength As Long
lpszPassword As String
dwPasswordLength As Long
lpszUrlPath As String
dwUrlPathLength As Long
lpszExtraInfo As String
dwExtraInfoLength As Long
End Type
Private mstrURL As String
Private mstrDestination As String
Private mblnConnectState As Boolean
Private mblnOverWrite As Boolean
Private hFile As Long
Private hSession As Long
Private lnghWnd As Long
Private hInet As Long
Private hFTP As Long
Private hURL As Long
Private mlngSize As Long
Private mblnPromptForFile As Boolean
Private mtURLInfo As URL_COMPONENTS
Private mcolRemoteDir As Collection
Private mstrSrcFile As String
Private mblnUpload As Boolean
Private mblnUseProxy As Boolean
Private mblnCreateRemoteDir As Boolean
Private mintErrorTrap As Integer
Private Const mconERR_BAD_URL As Long = vbObjectError + 1000
Private Const mconERR_REQ_FAILED As Long = vbObjectError + 2000
Private Const mconERR_UNKNOWN = vbObjectError + 3000
Private Const mconERR_CONNECTION_FAIL = vbObjectError + 4001
Private Const mconERR_CANNOT_START_TRANS FER = vbObjectError + 5000
Private Const mconERR_WRONG_OPERATION = vbObjectError + 5000
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
Private Const FTP_TRANSFER_TYPE_MASK = FTP_TRANSFER_TYPE_ASCII _
Or FTP_TRANSFER_TYPE_BINARY
Private Const ICU_NO_ENCODE = &H20000000 '// Don't convert unsafe characters to escape sequence
Private Const ICU_DECODE = &H10000000 '//Convert %XX escape sequences to characters
Private Const ICU_NO_META = &H8000000 '//Don't convert .. etc. meta path sequences
Private Const ICU_ENCODE_SPACES_ONLY = &H4000000 '// Encode spaces only
Private Const ICU_BROWSER_MODE = &H2000000
Private Const ICU_ESCAPE = &H80000000 '// (un)escape URL characters
Private Const MAX_CHUNK = 4096
Private Const MAX_PATH = 260
Private Const MAX_BUFFER = 1024
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const CREATE_ALWAYS = 2
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const INTERNET_CONNECTION_MODEM = 1
Private Const INTERNET_CONNECTION_LAN = 2
Private Const INTERNET_CONNECTION_PROXY = 4
Private Const INTERNET_CONNECTION_MODEM_ BUSY = 8
Private Const INTERNET_AUTODIAL_FORCE_ON LINE = 1
Private Const INTERNET_AUTODIAL_FORCE_UN ATTENDED = 2
Private Const INTERNET_FLAG_ASYNC = &H10000000
Private Const INTERNET_FLAG_EXISTING_CON NECT = &H20000000
Private Const INTERNET_FLAG_RAW_DATA = &H40000000
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_DONT_CACHE = &H4000000
Private Const INTERNET_FLAG_MAKE_PERSIST ENT = &H2000000
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_FLAG_NO_CACHE_WRI TE = &H4000000
Private Const INTERNET_FLAG_TRANSFER_BIN ARY = &H2
Private Const INTERNET_SCHEME_UNKNOWN = -1
Private Const INTERNET_OPEN_TYPE_PRECONF IG = 0&
Private Const INTERNET_OPEN_TYPE_DIRECT = 1&
Private Const INTERNET_OPEN_TYPE_PROXY = 3&
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_INVALID_PORT_NUMB ER = 0
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_SERVICE_GOPHER = 2
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_ERROR_BASE = 12000
Private Const ERROR_BAD_PATHNAME = 161
Private Const ERROR_INVALID_PARAMETER = &H87
Private Const ERROR_INTERNET_INVALID_URL = (INTERNET_ERROR_BASE + 5)
Private Const ERROR_INSUFFICIENT_BUFFER = 122
Private Const ERROR_NO_MORE_FILES = 18
Private Declare Function apiFormatMsgLong Lib "kernel32" _
Alias "FormatMessageA" _
(ByVal dwFlags As Long, _
ByVal lpSource As Long, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
Arguments As Long) _
As Long
Private Declare Function apiFtpOpenFile Lib "wininet.dll" _
Alias "FtpOpenFileA" _
(ByVal hFtpSession As Long, ByVal lpszFileName As String, _
ByVal fdwAccess As Long, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function apiFtpCreateDir Lib "wininet" _
Alias "FtpCreateDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) _
As Long
Private Declare Function apiFtpSetCurrentDir Lib "wininet" _
Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Private Declare Function apiFTPPutFile Lib "wininet.dll" _
Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function apiInetCrackUrl Lib "wininet.dll" _
Alias "InternetCrackUrlA" _
(ByVal lpszUrl As String, ByVal dwUrlLength As Long, _
ByVal dwFlags As Long, _
lpUrlComponents As URL_COMPONENTS) As Long
Private Declare Function apiInetCanonicalizeUrl Lib "wininet.dll" _
Alias "InternetCanonicalizeUrlA" _
(ByVal lpszUrl As String, ByVal lpszBuffer As String, _
lpdwBufferLength As Long, ByVal dwFlags As Long) As Long
Private Declare Function apiInetGetConnectedState Lib "wininet.dll" _
Alias "InternetGetConnectedState " _
(ByVal lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiInetReadFile Lib "wininet.dll" _
Alias "InternetReadFile" _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal dwBytesToRead As Long, lpBytesRead As Long) As Long
Private Declare Function apiInetReadFileStr Lib "wininet.dll" _
Alias "InternetReadFile" _
(ByVal hFile As Long, ByVal lpBuffer As String, _
ByVal dwBytesToRead As Long, lpBytesRead As Long) As Long
Private Declare Function apiInetOpenURL Lib "wininet.dll" _
Alias "InternetOpenUrlA" _
(ByVal hInternet As Long, ByVal lpszUrl As String, _
ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function apiInetOpen Lib "wininet.dll" _
Alias "InternetOpenA" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, _
ByVal lpszProxy As String, ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Private Declare Function apiInetCloseHandle Lib "wininet.dll" _
Alias "InternetCloseHandle" _
(ByVal hInet As Long) As Long
Private Declare Function apiInetQueryDataAvailable Lib "wininet.dll" _
Alias "InternetQueryDataAvailabl e" _
(ByVal hFile As Long, lpdwNumberOfBytesAvailable As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function apiInetGetLastResponse Lib "wininet.dll" _
Alias "InternetGetLastResponseIn foA" _
(lpdwError As Long, ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Long
Private Declare Function apiInetConnect Lib "wininet.dll" _
Alias "InternetConnectA" _
(ByVal hInternet As Long, ByVal lpszServerName As String, _
ByVal nServerPort As Integer, ByVal lpszUserName As String, _
ByVal lpszPassword As String, ByVal dwService As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function apiInetAutodial Lib "wininet.dll" _
Alias "InternetAutodial" _
(ByVal dwFlags As Long, ByVal dwReserved As Long) _
As Long
Private Declare Function apiCreateFile Lib "kernel32.dll" _
Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function apiWriteFile Lib "kernel32.dll" _
Alias "WriteFile" _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) _
As Long
Private Declare Function apiReadFile Lib "kernel32" _
Alias "ReadFile" (ByVal hFile As Long, _
lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function apiFlushFileBuffers Lib "kernel32.dll" _
Alias "FlushFileBuffers" _
(ByVal hFile As Long) As Long
Private Declare Function apiCloseHandle Lib "kernel32.dll" _
Alias "CloseHandle" (ByVal hObject As Long) As Long
Private Declare Function apiGetActiveWindow Lib "user32" _
Alias "GetActiveWindow" () As Long
Public Property Let AutoCreateRemoteDir(blnYes No As Boolean)
mblnCreateRemoteDir = blnYesNo
End Property
Private Sub sChangeDir(ByVal strDir As String)
Dim intCount As Integer
Dim strExtract As String
Dim i As Integer
Dim lngRet As Long
Const conERR_COULD_NOT_CHANGE_DI R = vbObjectError + 9999
Const conERR_NO_SUCH_DIR = 12003
intCount = fCountWords(strDir, "/")
If intCount > 0 Then
For i = 2 To intCount - 1 'Last pos must be file, first one always /
strExtract = fGetWord(strDir, i, "/")
If strExtract = vbNullString Then
strExtract = "/"
End If
lngRet = apiFtpSetCurrentDir(hSessi on, strExtract)
If lngRet = 0 Then
If Err.LastDllError = conERR_NO_SUCH_DIR Then
If mblnCreateRemoteDir Then
Call SysCmd(acSysCmdSetStatus, "Creating remote folder '" & strExtract & "'..")
'Create the directory automatically
lngRet = apiFtpCreateDir(hSession, strExtract)
lngRet = apiFtpSetCurrentDir(hSessi on, strExtract)
Else
Err.Raise conERR_COULD_NOT_CHANGE_DI R, _
"FTP", fInetError(Err.LastDllErro r)
End If
End If
End If
Next
End If
End Sub
Public Sub UploadFileToFTPServer()
On Error GoTo ErrHandler
Dim lngRet As Long
Dim abytData() As Long
Dim lngBytesWritten As Long
Dim lngBytesRead As Long
Dim lngTotalBytesWritten As Long
Const conERR_COULD_NOT_TRANSFER_ FILE = vbObjectError + 2215
Call SysCmd(acSysCmdSetStatus, "Changing directories....")
Call sChangeDir(mstrDestination )
Call SysCmd(acSysCmdSetStatus, "Uploading file. Please wait...")
lngRet = apiFTPPutFile(hSession, mstrSrcFile, mstrDestination, _
INTERNET_FLAG_TRANSFER_BIN ARY Or INTERNET_FLAG_NO_CACHE_WRI TE, 0&)
If lngRet = 0 Then Err.Raise conERR_COULD_NOT_TRANSFER_ FILE
Call SysCmd(acSysCmdSetStatus, "Done...")
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdClearStatus )
Exit Sub
ErrHandler:
Select Case Err.Number
Case conERR_COULD_NOT_TRANSFER_ FILE:
Err.Raise conERR_COULD_NOT_TRANSFER_ FILE, "FTP::UploadFileToFTPServer", _
fInetError(Err.LastDllErro r)
Case Else
With Err
.Raise .Number, .Source, fInetError(.LastDllError)
End With
End Select
Resume ExitHere
End Sub
Public Sub ConnectToFTPHost( _
Optional strUserName As String = "anonymous", _
Optional strPassword As String = "homer@doh.com")
On Error GoTo ErrHandler
Dim lngRet As Long
Dim lngLen As Long
Dim strStatus As String
Dim lngFlags As Long
Dim strTmp As String
Dim lngFileMode As Long
If Not fParseURL(mtURLInfo, mstrURL) = False Then
If mtURLInfo.lpszHostName = vbNullString Then
Err.Raise mconERR_BAD_URL
End If
Else
Err.Raise mconERR_UNKNOWN
End If
If mblnUseProxy Then
lngFlags = INTERNET_OPEN_TYPE_PROXY
Else
lngFlags = INTERNET_OPEN_TYPE_PRECONF IG
End If
hInet = apiInetOpen("WinInet-FileT ransferObj ects", _
lngFlags, _
vbNullChar, vbNullChar, 0&)
Call SysCmd(acSysCmdSetStatus, "Connecting to FTP Server '" & mtURLInfo.lpszHostName & "'...")
hSession = apiInetConnect(hInet, mtURLInfo.lpszHostName, _
INTERNET_INVALID_PORT_NUMB ER, _
CStr(strUserName), _
CStr(strPassword), INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, 0&)
If hSession = 0 Then Err.Raise mconERR_CONNECTION_FAIL
If mblnUpload Then
lngFileMode = GENERIC_WRITE
Call SysCmd(acSysCmdSetStatus, "Requesting upload information from server...")
Else
Call SysCmd(acSysCmdSetStatus, "Requesting download information from server...")
lngFileMode = GENERIC_READ
End If
If Not mblnUpload Then
With mtURLInfo
hFTP = apiFtpOpenFile(hSession, .lpszUrlPath, _
lngFileMode, FTP_TRANSFER_TYPE_BINARY Or _
INTERNET_FLAG_DONT_CACHE, 0&)
If hFTP = 0 Then Err.Raise mconERR_CANNOT_START_TRANS FER
lngRet = apiInetQueryDataAvailable( hFTP, mlngSize, 0&, 0&)
If mlngSize = 0 Then mlngSize = 1
End With
End If
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdClearStatus )
Exit Sub
ErrHandler:
Select Case Err.Number
Case mconERR_CANNOT_START_TRANS FER:
Err.Raise mconERR_CANNOT_START_TRANS FER, "FTP::ConnectToFTPHost", _
"Cannot start file transfer from '" & mtURLInfo.lpszHostName & "'."
Case mconERR_CONNECTION_FAIL:
Err.Raise mconERR_CONNECTION_FAIL, "FTP::ConnectToFTPHost", _
"Couldn't connect to server '" & mtURLInfo.lpszHostName & "'."
Case mconERR_BAD_URL:
Err.Raise mconERR_BAD_URL, "FTP::ConnectToFTPHost", _
"Bad URL. " & vbCrLf & mstrURL & vbCrLf & _
"Please verify the hyperlink and try again."
Case mconERR_UNKNOWN:
Err.Raise mconERR_UNKNOWN, "FTP::ConnectToFTPHost", _
"An unknown error occurred."
Case Else:
Err.Raise Err.Number, Err.Source, Err.Description
End Select
Resume ExitHere
End Sub
Public Sub WriteFTPDataToFile()
On Error GoTo ErrHandler
Dim lngRet As Long
Dim lngBytesRead As Long
Dim lngFlags As Long
Dim lngBytesWritten As Long
Dim lngTotalBytesWritten As Long
Dim abytData() As Byte
Dim strHost As String
Dim strFile As String
Dim strDir As String
Const conERR_GENERIC = vbObjectError + 100
Const conFILE_EXISTS = vbObjectError + 200
If mblnUpload Then Err.Raise mconERR_WRONG_OPERATION
If (Me.FileExists And Not mblnOverWrite) Or mblnPromptForFile Then
If lnghWnd = 0 Then lnghWnd = apiGetActiveWindow()
mstrDestination = fGetNewFileName("Please select a" _
& " new name for the destination file.", lnghWnd, False)
If mstrDestination = vbNullString Then Err.Raise _
conERR_GENERIC
End If
Call SysCmd(acSysCmdInitMeter, "Downloading file '" & mtURLInfo.lpszUrlPath & "'...", 100)
'Create the destination file
hFile = apiCreateFile(mstrDestinat ion, _
GENERIC_READ Or GENERIC_WRITE, _
0&, 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
If hFile = INVALID_HANDLE_VALUE Then Err.Raise conERR_GENERIC
'Read in MAX_CHUNK Chunk
Do
ReDim abytData(MAX_CHUNK)
lngRet = apiInetReadFile(hFTP, _
abytData(0), _
MAX_CHUNK, _
lngBytesRead)
Call apiWriteFile(hFile, abytData(0), MAX_CHUNK, _
lngBytesWritten, 0&)
lngTotalBytesWritten = lngTotalBytesWritten + lngBytesWritten
Call SysCmd(acSysCmdUpdateMeter , CInt(lngTotalBytesWritten / mlngSize))
Loop Until lngRet <> 0 And lngBytesRead = 0
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdRemoveMeter )
Exit Sub
ErrHandler:
Select Case Err.Number
Case conERR_GENERIC:
'Do Nothing
Case mconERR_WRONG_OPERATION:
Err.Raise mconERR_WRONG_OPERATION, "FTP::WriteFTPDataToFile", _
"Wrong transfer method selected."
Case Else:
Err.Raise Err.Number, "FTP::WriteFTPDataToFile", Err.Description
End Select
Resume ExitHere
End Sub
Public Property Let SourceFile(strFileName As String)
'Pass vbNullString for Common Dialog
If strFileName = vbNullString Then
If lnghWnd = 0 Then lnghWnd = apiGetActiveWindow()
mstrSrcFile = fGetNewFileName("Please select the" _
& " file to upload.", lnghWnd, True)
Else
mstrSrcFile = strFileName
End If
mblnUpload = True
mlngSize = FileLen(mstrSrcFile)
End Property
Private Sub Class_Initialize()
Dim lngFlags As Long
mintErrorTrap = Application.GetOption("Err or Trapping")
Call Application.SetOption("Err or Trapping", 2)
mblnConnectState = CBool(apiInetGetConnectedS tate(lngFl ags, 0&))
Set mcolRemoteDir = New Collection
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Call Application.SetOption("Err or Trapping", mintErrorTrap)
Call SysCmd(acSysCmdClearStatus )
Set mcolRemoteDir = Nothing
Call apiInetCloseHandle(hSessio n)
Call apiInetCloseHandle(hInet)
Call apiFlushFileBuffers(hFile)
Call apiCloseHandle(hFile)
mlngSize = 0
End Sub
Public Property Let UseProxy(blnYesNo As Boolean)
mblnUseProxy = blnYesNo
End Property
Public Property Let FtpURL(ByVal strURL As String)
mstrURL = strURL
End Property
Public Property Let hWnd(ByVal SourcehWnd As Long)
lnghWnd = SourcehWnd
End Property
Public Property Get FileExists() As Boolean
FileExists = Not (Dir(mstrDestination) = vbNullString)
End Property
Public Property Let OverwriteTarget(ByVal blnOverWrite As Boolean)
mblnOverWrite = blnOverWrite
End Property
Public Property Let DestinationFile(ByVal strFilePath As String)
mstrDestination = strFilePath
End Property
Public Property Get SpecifiedURL() As String
SpecifiedURL = mstrURL
End Property
Public Property Let PromptWithCommonDialog(bln YesNo As Boolean)
mblnPromptForFile = blnYesNo
End Property
Public Sub About()
DoCmd.OpenForm "wz_frm_About", windowmode:=acDialog
End Sub
Public Property Get SizeOfFile() As Long
SizeOfFile = mlngSize
End Property
Public Property Get IsConnected() As Boolean
IsConnected = mblnConnectState
End Property
Public Sub DialDefaultNumber()
Dim lngFlags As Long
Dim lngRet As Long
lngRet = apiInetGetConnectedState(l ngFlags, 0&)
If lngRet = 0 Then
If (lngFlags And INTERNET_CONNECTION_MODEM) Then
'Try a connect
lngRet = apiInetAutodial(INTERNET_A UTODIAL_FO RCE_UNATTE NDED, 0&)
mblnConnectState = Not (lngRet = 0)
End If
End If
End Sub
Private Function fCountWords(ByVal S As String, ByVal strDelim As String) As Integer
' Counts the words in a string that are separated by commas.
'Modified from MS KB
'
Dim WC As Integer, Pos As Integer
WC = 1
Pos = InStr(S, strDelim)
Do While Pos > 0
WC = WC + 1
Pos = InStr(Pos + 1, S, strDelim)
Loop
fCountWords = WC
End Function
Private Function fGetWord(ByVal S As String, Indx As Integer, strDelim As String)
' Returns the nth word in a specific field.
'Modified from MS KB
'
Dim WC As Integer, Count As Integer, SPos As Integer, EPos As Integer
WC = fCountWords(S, strDelim)
If Indx < 1 Or Indx > WC Then
fGetWord = vbNullString
Exit Function
End If
Count = 1
SPos = 1
For Count = 2 To Indx
SPos = InStr(SPos, S, strDelim) + 1
Next Count
EPos = InStr(SPos, S, strDelim) - 1
If EPos <= 0 Then EPos = Len(S)
fGetWord = Trim(Mid(S, SPos, EPos - SPos + 1))
End Function
Private Function fParseURL(tURLInfo As URL_COMPONENTS, ByVal strURL As String) As Boolean
Dim lngLen As Long, strBuffer As String
Dim lngRet As Long, strURLLocal As String
strBuffer = String$(MAX_BUFFER, 0)
lngLen = Len(strBuffer)
lngRet = apiInetCanonicalizeUrl(str URL, strBuffer, lngLen, ICU_BROWSER_MODE)
If Not lngRet = 0 Then
strURLLocal = Left$(strBuffer, lngLen)
With tURLInfo
.lpszScheme = String$(MAX_BUFFER, 0)
.dwSchemeLength = MAX_BUFFER
.nScheme = INTERNET_SCHEME_UNKNOWN
.lpszHostName = String$(MAX_BUFFER, 0)
.dwHostNameLength = MAX_BUFFER
.dwStructSize = Len(tURLInfo)
.nPort = 0
.lpszUserName = String$(MAX_BUFFER, 0)
.dwUserNameLength = MAX_BUFFER
.lpszPassword = String$(MAX_BUFFER, 0)
.dwPasswordLength = MAX_BUFFER
.lpszUrlPath = String$(MAX_BUFFER, 0)
.dwUrlPathLength = MAX_BUFFER
.lpszExtraInfo = String$(MAX_BUFFER, 0)
.dwExtraInfoLength = MAX_BUFFER
End With
lngRet = apiInetCrackUrl(strURLLoca l, Len(strURLLocal), _
ICU_ESCAPE, tURLInfo)
If lngRet = 0 Then
fParseURL = False
Else
fParseURL = True
With tURLInfo
.lpszExtraInfo = fTrimNull(.lpszExtraInfo)
.lpszHostName = fTrimNull(.lpszHostName)
.lpszPassword = fTrimNull(.lpszPassword)
.lpszScheme = fTrimNull(.lpszScheme)
.lpszUrlPath = fTrimNull(.lpszUrlPath)
.lpszUserName = fTrimNull(.lpszUserName)
End With
End If
End If
End Function
Private Function fInetError(ByVal lngErrCode As Long) As String
Dim lngLen As Long, strBuffer As String
Call apiInetGetLastResponse(lng ErrCode, vbNullString, lngLen)
strBuffer = String$(lngLen + 1, 0)
Call apiInetGetLastResponse(lng ErrCode, strBuffer, lngLen)
fInetError = strBuffer
End Function
Private Function fTrimNull(ByVal strIn As String) As String
fTrimNull = Left$(strIn, InStr(strIn, vbNullChar) - 1)
End Function
Private Function fGetNewFileName(strMsg As String, hWnd As Long, blnOpen As Boolean) As String
Dim clsDialog As cDialog
Set clsDialog = New cDialog
With clsDialog
.Title = strMsg
.hWnd = hWnd
.ModeOpen = blnOpen
.StartDir = CurDir()
fGetNewFileName = .Action
End With
Set clsDialog = Nothing
End Function
Private Function fAPIErr(ByVal lngErr As Long) As String
'Original Idea obtained from
'Hardcode Visual Basic 5
'by Bruce McKinney
'
Dim strMsg As String
Dim lngRet As Long
strMsg = String$(1024, 0)
lngRet = apiFormatMsgLong(FORMAT_ME SSAGE_FROM _SYSTEM, 0&, _
lngErr, 0&, strMsg, Len(strMsg), ByVal 0&)
If Not lngRet = 0 Then
fAPIErr = Left$(strMsg, lngRet)
End If
End Function
Option Compare Database
Option Explicit
' FTP Module
Private Type URL_COMPONENTS
dwStructSize As Long
lpszScheme As String
dwSchemeLength As Long
nScheme As Long
lpszHostName As String
dwHostNameLength As Long
nPort As Long
lpszUserName As String
dwUserNameLength As Long
lpszPassword As String
dwPasswordLength As Long
lpszUrlPath As String
dwUrlPathLength As Long
lpszExtraInfo As String
dwExtraInfoLength As Long
End Type
Private mstrURL As String
Private mstrDestination As String
Private mblnConnectState As Boolean
Private mblnOverWrite As Boolean
Private hFile As Long
Private hSession As Long
Private lnghWnd As Long
Private hInet As Long
Private hFTP As Long
Private hURL As Long
Private mlngSize As Long
Private mblnPromptForFile As Boolean
Private mtURLInfo As URL_COMPONENTS
Private mcolRemoteDir As Collection
Private mstrSrcFile As String
Private mblnUpload As Boolean
Private mblnUseProxy As Boolean
Private mblnCreateRemoteDir As Boolean
Private mintErrorTrap As Integer
Private Const mconERR_BAD_URL As Long = vbObjectError + 1000
Private Const mconERR_REQ_FAILED As Long = vbObjectError + 2000
Private Const mconERR_UNKNOWN = vbObjectError + 3000
Private Const mconERR_CONNECTION_FAIL = vbObjectError + 4001
Private Const mconERR_CANNOT_START_TRANS
Private Const mconERR_WRONG_OPERATION = vbObjectError + 5000
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
Private Const FTP_TRANSFER_TYPE_MASK = FTP_TRANSFER_TYPE_ASCII _
Or FTP_TRANSFER_TYPE_BINARY
Private Const ICU_NO_ENCODE = &H20000000 '// Don't convert unsafe characters to escape sequence
Private Const ICU_DECODE = &H10000000 '//Convert %XX escape sequences to characters
Private Const ICU_NO_META = &H8000000 '//Don't convert .. etc. meta path sequences
Private Const ICU_ENCODE_SPACES_ONLY = &H4000000 '// Encode spaces only
Private Const ICU_BROWSER_MODE = &H2000000
Private Const ICU_ESCAPE = &H80000000 '// (un)escape URL characters
Private Const MAX_CHUNK = 4096
Private Const MAX_PATH = 260
Private Const MAX_BUFFER = 1024
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const CREATE_ALWAYS = 2
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FORMAT_MESSAGE_FROM_SYSTEM
Private Const INTERNET_CONNECTION_MODEM = 1
Private Const INTERNET_CONNECTION_LAN = 2
Private Const INTERNET_CONNECTION_PROXY = 4
Private Const INTERNET_CONNECTION_MODEM_
Private Const INTERNET_AUTODIAL_FORCE_ON
Private Const INTERNET_AUTODIAL_FORCE_UN
Private Const INTERNET_FLAG_ASYNC = &H10000000
Private Const INTERNET_FLAG_EXISTING_CON
Private Const INTERNET_FLAG_RAW_DATA = &H40000000
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_DONT_CACHE = &H4000000
Private Const INTERNET_FLAG_MAKE_PERSIST
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_FLAG_NO_CACHE_WRI
Private Const INTERNET_FLAG_TRANSFER_BIN
Private Const INTERNET_SCHEME_UNKNOWN = -1
Private Const INTERNET_OPEN_TYPE_PRECONF
Private Const INTERNET_OPEN_TYPE_DIRECT = 1&
Private Const INTERNET_OPEN_TYPE_PROXY = 3&
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_INVALID_PORT_NUMB
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_SERVICE_GOPHER = 2
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_ERROR_BASE = 12000
Private Const ERROR_BAD_PATHNAME = 161
Private Const ERROR_INVALID_PARAMETER = &H87
Private Const ERROR_INTERNET_INVALID_URL
Private Const ERROR_INSUFFICIENT_BUFFER = 122
Private Const ERROR_NO_MORE_FILES = 18
Private Declare Function apiFormatMsgLong Lib "kernel32" _
Alias "FormatMessageA" _
(ByVal dwFlags As Long, _
ByVal lpSource As Long, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
Arguments As Long) _
As Long
Private Declare Function apiFtpOpenFile Lib "wininet.dll" _
Alias "FtpOpenFileA" _
(ByVal hFtpSession As Long, ByVal lpszFileName As String, _
ByVal fdwAccess As Long, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function apiFtpCreateDir Lib "wininet" _
Alias "FtpCreateDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) _
As Long
Private Declare Function apiFtpSetCurrentDir Lib "wininet" _
Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Private Declare Function apiFTPPutFile Lib "wininet.dll" _
Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function apiInetCrackUrl Lib "wininet.dll" _
Alias "InternetCrackUrlA" _
(ByVal lpszUrl As String, ByVal dwUrlLength As Long, _
ByVal dwFlags As Long, _
lpUrlComponents As URL_COMPONENTS) As Long
Private Declare Function apiInetCanonicalizeUrl Lib "wininet.dll" _
Alias "InternetCanonicalizeUrlA"
(ByVal lpszUrl As String, ByVal lpszBuffer As String, _
lpdwBufferLength As Long, ByVal dwFlags As Long) As Long
Private Declare Function apiInetGetConnectedState Lib "wininet.dll" _
Alias "InternetGetConnectedState
(ByVal lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiInetReadFile Lib "wininet.dll" _
Alias "InternetReadFile" _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal dwBytesToRead As Long, lpBytesRead As Long) As Long
Private Declare Function apiInetReadFileStr Lib "wininet.dll" _
Alias "InternetReadFile" _
(ByVal hFile As Long, ByVal lpBuffer As String, _
ByVal dwBytesToRead As Long, lpBytesRead As Long) As Long
Private Declare Function apiInetOpenURL Lib "wininet.dll" _
Alias "InternetOpenUrlA" _
(ByVal hInternet As Long, ByVal lpszUrl As String, _
ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function apiInetOpen Lib "wininet.dll" _
Alias "InternetOpenA" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, _
ByVal lpszProxy As String, ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Private Declare Function apiInetCloseHandle Lib "wininet.dll" _
Alias "InternetCloseHandle" _
(ByVal hInet As Long) As Long
Private Declare Function apiInetQueryDataAvailable Lib "wininet.dll" _
Alias "InternetQueryDataAvailabl
(ByVal hFile As Long, lpdwNumberOfBytesAvailable
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function apiInetGetLastResponse Lib "wininet.dll" _
Alias "InternetGetLastResponseIn
(lpdwError As Long, ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Long
Private Declare Function apiInetConnect Lib "wininet.dll" _
Alias "InternetConnectA" _
(ByVal hInternet As Long, ByVal lpszServerName As String, _
ByVal nServerPort As Integer, ByVal lpszUserName As String, _
ByVal lpszPassword As String, ByVal dwService As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function apiInetAutodial Lib "wininet.dll" _
Alias "InternetAutodial" _
(ByVal dwFlags As Long, ByVal dwReserved As Long) _
As Long
Private Declare Function apiCreateFile Lib "kernel32.dll" _
Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function apiWriteFile Lib "kernel32.dll" _
Alias "WriteFile" _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) _
As Long
Private Declare Function apiReadFile Lib "kernel32" _
Alias "ReadFile" (ByVal hFile As Long, _
lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function apiFlushFileBuffers Lib "kernel32.dll" _
Alias "FlushFileBuffers" _
(ByVal hFile As Long) As Long
Private Declare Function apiCloseHandle Lib "kernel32.dll" _
Alias "CloseHandle" (ByVal hObject As Long) As Long
Private Declare Function apiGetActiveWindow Lib "user32" _
Alias "GetActiveWindow" () As Long
Public Property Let AutoCreateRemoteDir(blnYes
mblnCreateRemoteDir = blnYesNo
End Property
Private Sub sChangeDir(ByVal strDir As String)
Dim intCount As Integer
Dim strExtract As String
Dim i As Integer
Dim lngRet As Long
Const conERR_COULD_NOT_CHANGE_DI
Const conERR_NO_SUCH_DIR = 12003
intCount = fCountWords(strDir, "/")
If intCount > 0 Then
For i = 2 To intCount - 1 'Last pos must be file, first one always /
strExtract = fGetWord(strDir, i, "/")
If strExtract = vbNullString Then
strExtract = "/"
End If
lngRet = apiFtpSetCurrentDir(hSessi
If lngRet = 0 Then
If Err.LastDllError = conERR_NO_SUCH_DIR Then
If mblnCreateRemoteDir Then
Call SysCmd(acSysCmdSetStatus, "Creating remote folder '" & strExtract & "'..")
'Create the directory automatically
lngRet = apiFtpCreateDir(hSession, strExtract)
lngRet = apiFtpSetCurrentDir(hSessi
Else
Err.Raise conERR_COULD_NOT_CHANGE_DI
"FTP", fInetError(Err.LastDllErro
End If
End If
End If
Next
End If
End Sub
Public Sub UploadFileToFTPServer()
On Error GoTo ErrHandler
Dim lngRet As Long
Dim abytData() As Long
Dim lngBytesWritten As Long
Dim lngBytesRead As Long
Dim lngTotalBytesWritten As Long
Const conERR_COULD_NOT_TRANSFER_
Call SysCmd(acSysCmdSetStatus, "Changing directories....")
Call sChangeDir(mstrDestination
Call SysCmd(acSysCmdSetStatus, "Uploading file. Please wait...")
lngRet = apiFTPPutFile(hSession, mstrSrcFile, mstrDestination, _
INTERNET_FLAG_TRANSFER_BIN
If lngRet = 0 Then Err.Raise conERR_COULD_NOT_TRANSFER_
Call SysCmd(acSysCmdSetStatus, "Done...")
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdClearStatus
Exit Sub
ErrHandler:
Select Case Err.Number
Case conERR_COULD_NOT_TRANSFER_
Err.Raise conERR_COULD_NOT_TRANSFER_
fInetError(Err.LastDllErro
Case Else
With Err
.Raise .Number, .Source, fInetError(.LastDllError)
End With
End Select
Resume ExitHere
End Sub
Public Sub ConnectToFTPHost( _
Optional strUserName As String = "anonymous", _
Optional strPassword As String = "homer@doh.com")
On Error GoTo ErrHandler
Dim lngRet As Long
Dim lngLen As Long
Dim strStatus As String
Dim lngFlags As Long
Dim strTmp As String
Dim lngFileMode As Long
If Not fParseURL(mtURLInfo, mstrURL) = False Then
If mtURLInfo.lpszHostName = vbNullString Then
Err.Raise mconERR_BAD_URL
End If
Else
Err.Raise mconERR_UNKNOWN
End If
If mblnUseProxy Then
lngFlags = INTERNET_OPEN_TYPE_PROXY
Else
lngFlags = INTERNET_OPEN_TYPE_PRECONF
End If
hInet = apiInetOpen("WinInet-FileT
lngFlags, _
vbNullChar, vbNullChar, 0&)
Call SysCmd(acSysCmdSetStatus, "Connecting to FTP Server '" & mtURLInfo.lpszHostName & "'...")
hSession = apiInetConnect(hInet, mtURLInfo.lpszHostName, _
INTERNET_INVALID_PORT_NUMB
CStr(strUserName), _
CStr(strPassword), INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, 0&)
If hSession = 0 Then Err.Raise mconERR_CONNECTION_FAIL
If mblnUpload Then
lngFileMode = GENERIC_WRITE
Call SysCmd(acSysCmdSetStatus, "Requesting upload information from server...")
Else
Call SysCmd(acSysCmdSetStatus, "Requesting download information from server...")
lngFileMode = GENERIC_READ
End If
If Not mblnUpload Then
With mtURLInfo
hFTP = apiFtpOpenFile(hSession, .lpszUrlPath, _
lngFileMode, FTP_TRANSFER_TYPE_BINARY Or _
INTERNET_FLAG_DONT_CACHE, 0&)
If hFTP = 0 Then Err.Raise mconERR_CANNOT_START_TRANS
lngRet = apiInetQueryDataAvailable(
If mlngSize = 0 Then mlngSize = 1
End With
End If
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdClearStatus
Exit Sub
ErrHandler:
Select Case Err.Number
Case mconERR_CANNOT_START_TRANS
Err.Raise mconERR_CANNOT_START_TRANS
"Cannot start file transfer from '" & mtURLInfo.lpszHostName & "'."
Case mconERR_CONNECTION_FAIL:
Err.Raise mconERR_CONNECTION_FAIL, "FTP::ConnectToFTPHost", _
"Couldn't connect to server '" & mtURLInfo.lpszHostName & "'."
Case mconERR_BAD_URL:
Err.Raise mconERR_BAD_URL, "FTP::ConnectToFTPHost", _
"Bad URL. " & vbCrLf & mstrURL & vbCrLf & _
"Please verify the hyperlink and try again."
Case mconERR_UNKNOWN:
Err.Raise mconERR_UNKNOWN, "FTP::ConnectToFTPHost", _
"An unknown error occurred."
Case Else:
Err.Raise Err.Number, Err.Source, Err.Description
End Select
Resume ExitHere
End Sub
Public Sub WriteFTPDataToFile()
On Error GoTo ErrHandler
Dim lngRet As Long
Dim lngBytesRead As Long
Dim lngFlags As Long
Dim lngBytesWritten As Long
Dim lngTotalBytesWritten As Long
Dim abytData() As Byte
Dim strHost As String
Dim strFile As String
Dim strDir As String
Const conERR_GENERIC = vbObjectError + 100
Const conFILE_EXISTS = vbObjectError + 200
If mblnUpload Then Err.Raise mconERR_WRONG_OPERATION
If (Me.FileExists And Not mblnOverWrite) Or mblnPromptForFile Then
If lnghWnd = 0 Then lnghWnd = apiGetActiveWindow()
mstrDestination = fGetNewFileName("Please select a" _
& " new name for the destination file.", lnghWnd, False)
If mstrDestination = vbNullString Then Err.Raise _
conERR_GENERIC
End If
Call SysCmd(acSysCmdInitMeter, "Downloading file '" & mtURLInfo.lpszUrlPath & "'...", 100)
'Create the destination file
hFile = apiCreateFile(mstrDestinat
GENERIC_READ Or GENERIC_WRITE, _
0&, 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
If hFile = INVALID_HANDLE_VALUE Then Err.Raise conERR_GENERIC
'Read in MAX_CHUNK Chunk
Do
ReDim abytData(MAX_CHUNK)
lngRet = apiInetReadFile(hFTP, _
abytData(0), _
MAX_CHUNK, _
lngBytesRead)
Call apiWriteFile(hFile, abytData(0), MAX_CHUNK, _
lngBytesWritten, 0&)
lngTotalBytesWritten = lngTotalBytesWritten + lngBytesWritten
Call SysCmd(acSysCmdUpdateMeter
Loop Until lngRet <> 0 And lngBytesRead = 0
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdRemoveMeter
Exit Sub
ErrHandler:
Select Case Err.Number
Case conERR_GENERIC:
'Do Nothing
Case mconERR_WRONG_OPERATION:
Err.Raise mconERR_WRONG_OPERATION, "FTP::WriteFTPDataToFile", _
"Wrong transfer method selected."
Case Else:
Err.Raise Err.Number, "FTP::WriteFTPDataToFile", Err.Description
End Select
Resume ExitHere
End Sub
Public Property Let SourceFile(strFileName As String)
'Pass vbNullString for Common Dialog
If strFileName = vbNullString Then
If lnghWnd = 0 Then lnghWnd = apiGetActiveWindow()
mstrSrcFile = fGetNewFileName("Please select the" _
& " file to upload.", lnghWnd, True)
Else
mstrSrcFile = strFileName
End If
mblnUpload = True
mlngSize = FileLen(mstrSrcFile)
End Property
Private Sub Class_Initialize()
Dim lngFlags As Long
mintErrorTrap = Application.GetOption("Err
Call Application.SetOption("Err
mblnConnectState = CBool(apiInetGetConnectedS
Set mcolRemoteDir = New Collection
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Call Application.SetOption("Err
Call SysCmd(acSysCmdClearStatus
Set mcolRemoteDir = Nothing
Call apiInetCloseHandle(hSessio
Call apiInetCloseHandle(hInet)
Call apiFlushFileBuffers(hFile)
Call apiCloseHandle(hFile)
mlngSize = 0
End Sub
Public Property Let UseProxy(blnYesNo As Boolean)
mblnUseProxy = blnYesNo
End Property
Public Property Let FtpURL(ByVal strURL As String)
mstrURL = strURL
End Property
Public Property Let hWnd(ByVal SourcehWnd As Long)
lnghWnd = SourcehWnd
End Property
Public Property Get FileExists() As Boolean
FileExists = Not (Dir(mstrDestination) = vbNullString)
End Property
Public Property Let OverwriteTarget(ByVal blnOverWrite As Boolean)
mblnOverWrite = blnOverWrite
End Property
Public Property Let DestinationFile(ByVal strFilePath As String)
mstrDestination = strFilePath
End Property
Public Property Get SpecifiedURL() As String
SpecifiedURL = mstrURL
End Property
Public Property Let PromptWithCommonDialog(bln
mblnPromptForFile = blnYesNo
End Property
Public Sub About()
DoCmd.OpenForm "wz_frm_About", windowmode:=acDialog
End Sub
Public Property Get SizeOfFile() As Long
SizeOfFile = mlngSize
End Property
Public Property Get IsConnected() As Boolean
IsConnected = mblnConnectState
End Property
Public Sub DialDefaultNumber()
Dim lngFlags As Long
Dim lngRet As Long
lngRet = apiInetGetConnectedState(l
If lngRet = 0 Then
If (lngFlags And INTERNET_CONNECTION_MODEM)
'Try a connect
lngRet = apiInetAutodial(INTERNET_A
mblnConnectState = Not (lngRet = 0)
End If
End If
End Sub
Private Function fCountWords(ByVal S As String, ByVal strDelim As String) As Integer
' Counts the words in a string that are separated by commas.
'Modified from MS KB
'
Dim WC As Integer, Pos As Integer
WC = 1
Pos = InStr(S, strDelim)
Do While Pos > 0
WC = WC + 1
Pos = InStr(Pos + 1, S, strDelim)
Loop
fCountWords = WC
End Function
Private Function fGetWord(ByVal S As String, Indx As Integer, strDelim As String)
' Returns the nth word in a specific field.
'Modified from MS KB
'
Dim WC As Integer, Count As Integer, SPos As Integer, EPos As Integer
WC = fCountWords(S, strDelim)
If Indx < 1 Or Indx > WC Then
fGetWord = vbNullString
Exit Function
End If
Count = 1
SPos = 1
For Count = 2 To Indx
SPos = InStr(SPos, S, strDelim) + 1
Next Count
EPos = InStr(SPos, S, strDelim) - 1
If EPos <= 0 Then EPos = Len(S)
fGetWord = Trim(Mid(S, SPos, EPos - SPos + 1))
End Function
Private Function fParseURL(tURLInfo As URL_COMPONENTS, ByVal strURL As String) As Boolean
Dim lngLen As Long, strBuffer As String
Dim lngRet As Long, strURLLocal As String
strBuffer = String$(MAX_BUFFER, 0)
lngLen = Len(strBuffer)
lngRet = apiInetCanonicalizeUrl(str
If Not lngRet = 0 Then
strURLLocal = Left$(strBuffer, lngLen)
With tURLInfo
.lpszScheme = String$(MAX_BUFFER, 0)
.dwSchemeLength = MAX_BUFFER
.nScheme = INTERNET_SCHEME_UNKNOWN
.lpszHostName = String$(MAX_BUFFER, 0)
.dwHostNameLength = MAX_BUFFER
.dwStructSize = Len(tURLInfo)
.nPort = 0
.lpszUserName = String$(MAX_BUFFER, 0)
.dwUserNameLength = MAX_BUFFER
.lpszPassword = String$(MAX_BUFFER, 0)
.dwPasswordLength = MAX_BUFFER
.lpszUrlPath = String$(MAX_BUFFER, 0)
.dwUrlPathLength = MAX_BUFFER
.lpszExtraInfo = String$(MAX_BUFFER, 0)
.dwExtraInfoLength = MAX_BUFFER
End With
lngRet = apiInetCrackUrl(strURLLoca
ICU_ESCAPE, tURLInfo)
If lngRet = 0 Then
fParseURL = False
Else
fParseURL = True
With tURLInfo
.lpszExtraInfo = fTrimNull(.lpszExtraInfo)
.lpszHostName = fTrimNull(.lpszHostName)
.lpszPassword = fTrimNull(.lpszPassword)
.lpszScheme = fTrimNull(.lpszScheme)
.lpszUrlPath = fTrimNull(.lpszUrlPath)
.lpszUserName = fTrimNull(.lpszUserName)
End With
End If
End If
End Function
Private Function fInetError(ByVal lngErrCode As Long) As String
Dim lngLen As Long, strBuffer As String
Call apiInetGetLastResponse(lng
strBuffer = String$(lngLen + 1, 0)
Call apiInetGetLastResponse(lng
fInetError = strBuffer
End Function
Private Function fTrimNull(ByVal strIn As String) As String
fTrimNull = Left$(strIn, InStr(strIn, vbNullChar) - 1)
End Function
Private Function fGetNewFileName(strMsg As String, hWnd As Long, blnOpen As Boolean) As String
Dim clsDialog As cDialog
Set clsDialog = New cDialog
With clsDialog
.Title = strMsg
.hWnd = hWnd
.ModeOpen = blnOpen
.StartDir = CurDir()
fGetNewFileName = .Action
End With
Set clsDialog = Nothing
End Function
Private Function fAPIErr(ByVal lngErr As Long) As String
'Original Idea obtained from
'Hardcode Visual Basic 5
'by Bruce McKinney
'
Dim strMsg As String
Dim lngRet As Long
strMsg = String$(1024, 0)
lngRet = apiFormatMsgLong(FORMAT_ME
lngErr, 0&, strMsg, Len(strMsg), ByVal 0&)
If Not lngRet = 0 Then
fAPIErr = Left$(strMsg, lngRet)
End If
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
I thought jschrisman's approach was easier to implement than anything that followed. We had a consultant build an app for us using the FTP control in VB. It worked, but had very little error detection, particularly if the transfer was aborted in progress. We eventually moved to the shell-command-with-script method. We directed the output of the shell to a log file, and we were sure to include a DIR command in the script, to pick up the size of the file on the FTP server after the upload. If that size does not match the original file size, then we have a problem. Our tests proved that the shell-command method was more reliable and could detect problems that eluded the ActuveX control. The simplicity can't be beat.
E-mailing the reports was not a bad idea, it just wasn't the question being asked. I presume the files are going into some kind of archive, which is probably a web server also. I implemented a Linux Bash script to automatically "read" new mail, extract any attachments, scan for certain file types, and copy the attachments to directories based on the content of the message. Again, this isn't the question being asked, but it explains my opinon about the usefulness of the "sticks-and-stones" shell method for FTP.
E-mailing the reports was not a bad idea, it just wasn't the question being asked. I presume the files are going into some kind of archive, which is probably a web server also. I implemented a Linux Bash script to automatically "read" new mail, extract any attachments, scan for certain file types, and copy the attachments to directories based on the content of the message. Again, this isn't the question being asked, but it explains my opinon about the usefulness of the "sticks-and-stones" shell method for FTP.
ASKER