Option Explicit
Option Base 0
'FTP Const
Private Const FTP_RELOADS& = &H80000000
Private Const FTP_PASSIVE& = &H8000000
Private Const FTP_SERVICE& = 1
Private Const FTP_PORTNUM& = 21
Private Const FTP_DIRECT& = 1
Private Const FTP_READ& = &H80000000
Private Const FTP_ASYNC& = &H1
'HTTP Const
Private Const HTTP_ASYNC& = &H1
Private Const HTTP_NO_CACHE_WRITE& = &H4000000
Private Const HTTP_RESYNCHRONIZE& = &H800
Private Const HTTP_DIRECT = 1
'CreateFile,WriteFile Const
Private Const FILE_SHARE_WRITE = &H2
Private Const FILE_GENERIC_WRITE = &H40000000
Private Const FILE_CREATE_ALWAYS = 2
'Other Const
Private Const DW_CONTEXT& = 2
Private Const INVALID_CALLBACK& = -1
Private Const MAX_PATH As String = 260
Private Declare Function CreateFile Lib "kernel32" 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'FtpGetFile:
' Retrieves a file from the FTP serverand stores
' it under the specified file name, creating a
' new local file in the process.
Private Declare Function FtpGetFile Lib "WININET.DLL" Alias "FtpGetFileA" ( _
ByVal hConnect 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
'FtpPutFile:
' Stores a file on the FTP server
Private Declare Function FtpPutFileA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
'FtpSetCurrentDirectory:
' Changes to a different working directory on the FTP server.
Private Declare Function FtpSetCurrentDirectoryA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Long
'FtpGetCurrentDirectory:
' Retrieves the current directory for the specified FTP session.
Private Declare Function FtpGetCurrentDirectoryA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszCurrentDirectory As String, _
ByRef lpdwCurrentDirectory As Long) As Long
'FtpOpenFile:
' Initiates access to a remote file on an FTP server for reading or writing.
Private Declare Function FtpOpenFile Lib "WININET.DLL" Alias "FtpOpenFileA" ( _
ByVal hConnect As Long, _
ByVal lpszFileName As String, _
ByVal dwAccess As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
'FtpGetFileSize:
' Returns FileSize on FTP server
Private Declare Function FtpGetFileSize Lib "WININET.DLL" ( _
ByVal hFile As Long, _
ByRef lpdwFileSizeHigh As Long) As Long
'FtpDeleteFile:
' Deletes a file stored on the FTP server.
Private Declare Function FtpDeleteFileA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszFileName As String) As Long
'FtpCreateDirectory:
' Creates a new directory on the FTP server.
Private Declare Function FtpCreateDirectoryA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Long
'FtpRemoveDirectory
' Removes the specified directory on the FTP server.
Private Declare Function FtpRemoveDirectory Lib "WININET.DLL" Alias "FtpRemoveDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Long
'FtpRenameFile
' Renames a file stored on the FTP server.
Private Declare Function FtpRenameFileA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszExisting As String, _
ByVal lpNewFileName As String) As Long
Public Enum TransferTypes
FTP_TRANSFER_TYPE_UNKNOWN = &H0
FTP_TRANSFER_TYPE_ASCII = &H1
FTP_TRANSFER_TYPE_BINARY = &H2
End Enum
Public Server$ '// Ftp Servername
Public UserName$ '// Ftp Username
Public Password$ '// Ftp Password
Public AmIRegistered$
Private m_AsyncResult As INERNET_ASYNC_RESULT
Public Sub Connect(Optional AsyncMode As Boolean = True)
Dim Result As Long
mOpen = InternetOpenA( _
App.ProductName, _
FTP_DIRECT, _
vbNullString, _
vbNullString, _
FTP_ASYNC&)
If AsyncMode = True Then
Result = InternetSetStatusCallback(mOpen, AddressOf INTERNET_STATUS_CALLBACK)
End If
mConn = InternetConnectA( _
mOpen, _
Server, _
FTP_PORTNUM&, _
UserName, _
Password, _
FTP_SERVICE&, _
FTP_PASSIVE&, DW_CONTEXT&)
End Sub
Public Function Disconnect() As Boolean
'Clean up
Call InternetCloseHandle(mConn)
Call InternetCloseHandle(mOpen)
Call InternetCloseHandle(ReturnAddress)
End Function
Public Function FtpDownload(ByVal RemoteFile As String, _
ByVal LocalFile As String, _
ByVal TransferMode As TransferTypes) As Boolean
Dim Success As Boolean
Success = FtpGetFile(mConn, _
RemoteFile, _
LocalFile, _
False, ByVal 0&, _
TransferMode, DW_CONTEXT&)
FtpDownload = Success
End Function
Public Function FtpUpload(ByVal RemoteFile As String, _
ByVal LocalFile As String, _
ByVal TransferMode As TransferTypes) As Boolean
Dim Success As Boolean
Success = FtpPutFileA(mConn, _
LocalFile, _
RemoteFile, _
TransferMode, DW_CONTEXT&)
FtpUpload = Success
End Function
Public Function FtpGetDirectory() As String
Dim DirBuff As String
Dim strTemp As String
Dim Success As Boolean
DirBuff = String$(MAX_PATH, vbNullChar)
Success = FtpGetCurrentDirectoryA(mConn, DirBuff, Len(DirBuff))
FtpGetDirectory = RipNulls(DirBuff)
End Function
Friend Function FtpSetDirectory(ByVal SSetDir As String) As Boolean
Dim Success As Boolean
Success = FtpSetCurrentDirectoryA(mConn, SSetDir)
FtpSetDirectory = Success
End Function
Friend Function FtpFileDelete(ByVal sFileName As String) As Boolean
Dim Success As Boolean
Success = FtpDeleteFileA(mConn, sFileName)
FtpFileDelete = Success
End Function
Friend Function FtpFileRename(ByVal ExistingFileName As String, _
ByVal RenameFile As String) As Boolean
Dim Success As Boolean
Success = FtpRenameFileA(mConn, ExistingFileName, RenameFile)
FtpFileRename = Success
End Function
Friend Function FtpDirectoryCreate(ByVal CreateNewDirName As String) As Boolean
Dim Success As Boolean
Success = FtpCreateDirectoryA(mConn, CreateNewDirName)
FtpDirectoryCreate = Success
End Function
Friend Function FtpDirectoryRemove(ByVal RemoveDirectoryName As String) As Boolean
Dim Success As Boolean
Success = FtpRemoveDirectory(mConn, RemoveDirectoryName)
FtpDirectoryRemove = Success
End Function
Public Function Http_DownloadFile(ByVal FileName As String, _
ByVal WebURL As String, _
ByVal TransferMode As TransferTypes, _
Optional ChunkSize As Long = 8192)
Dim hLocalFile As Long
Dim Buffer() As Byte
Dim bytesRead As Long
Dim bytesWritten As Long
Dim bytesTransferred As Long
Dim boolCancel As Boolean
Dim lOpen As Long
Dim lHandle As Long
Dim Result As Long
lOpen = InternetOpenA(App.ProductName, _
HTTP_DIRECT, _
vbNullString, _
vbNullString, _
HTTP_ASYNC&)
Result = InternetSetStatusCallback(lOpen, AddressOf INTERNET_STATUS_CALLBACK)
lHandle = InternetOpenUrl(lOpen, _
WebURL, _
vbNullString, _
ByVal 0&, _
TransferMode, _
HTTP_NO_CACHE_WRITE& Or HTTP_RESYNCHRONIZE&)
hLocalFile = CreateFile(FileName, _
FILE_GENERIC_WRITE, _
FILE_SHARE_WRITE, _
ByVal 0&, FILE_CREATE_ALWAYS, 0, 0)
If hLocalFile <> 0 Then
ReDim Buffer(ChunkSize)
Do
If InternetReadFile(lHandle, _
ByVal VarPtr(Buffer(0)), _
ChunkSize, _
bytesRead) Then
If WriteFile(hLocalFile, _
ByVal VarPtr(Buffer(0)), _
bytesRead, _
bytesWritten, _
ByVal 0&) Then
bytesTransferred = bytesTransferred + bytesWritten
End If
Else
boolCancel = True
End If
DoEvents
Loop While bytesRead = ChunkSize And Not boolCancel
End If
Call CloseHandle(hLocalFile)
Call InternetCloseHandle(lHandle)
Call InternetCloseHandle(lOpen)
End Function
Mostrar Mensajes
