FtpLib.PRG -- VFP FTP 通信函数库
* FtpLib.PRG -- VFP FTP 通信函数库
*
* 代码编写: fireghost57
* 维护日期: 2012.10.16
*
*----------------------------------------------------------------------------*
*** General WinINET Constants
#Define INTERNET_DEFAULT_FTP_PORT 21
#Define INTERNET_OPEN_TYPE_PRECONFIG 0
#Define INTERNET_OPEN_TYPE_DIRECT 1
#Define INTERNET_OPEN_TYPE_PROXY 3
#Define INTERNET_OPTION_CONNECT_TIMEOUT 2
#Define INTERNET_OPTION_CONNECT_RETRIES 3
#Define INTERNET_OPTION_DATA_SEND_TIMEOUT 7
#Define INTERNET_OPTION_DATA_RECEIVE_TIMEOUT 8
#Define INTERNET_OPTION_LISTEN_TIMEOUT 11
#Define INTERNET_CONNECTION_MODEM 1
#Define INTERNET_CONNECTION_LAN 2
#Define INTERNET_CONNECTION_PROXY 4
#Define INTERNET_CONNECTION_MODEM_BUSY 8
#Define INTERNET_RAS_INSTALLED 16
#Define INTERNET_CONNECTION_OFFLINE 32
#Define INTERNET_CONNECTION_CONFIGURED 64
#Define INTERNET_SERVICE_FTP 1
#Define INTERNET_FLAG_NEED_FILE 16
#Define ERROR_INTERNET_EXTENDED_ERROR 12003
*** FTP WinInet Service Flags
#Define INTERNET_FLAG_RELOAD 2147483648
#Define INTERNET_FLAG_SECURE 8388608
#Define FTP_TRANSFER_TYPE_ASCII 1
#Define FTP_TRANSFER_TYPE_BINARY 2
#Define FTP_TRANSFER_TARGET_EXIST 0 && do not stop if the target already exists
*** Win32 API Constants
#Define ERROR_SUCCESS 0
*** Access Flags
#Define GENERIC_READ 0x80000000
#Define GENERIC_WRITE 0x40000000
#Define GENERIC_EXECUTE 0x20000000
#Define GENERIC_ALL 0x10000000
*** File Attribute Flags
#Define FILE_ATTRIBUTE_DIRECTORY 16
#Define FILE_ATTRIBUTE_HIDDEN 0x00000002
#Define FILE_ATTRIBUTE_NORMAL 128 && 0x00000080
#Define FILE_ATTRIBUTE_READONLY 0x00000001
#Define FILE_ATTRIBUTE_SYSTEM 0x00000004
*** Values for FormatMessage API
#Define FORMAT_MESSAGE_FROM_SYSTEM 4096
#Define FORMAT_MESSAGE_FROM_HMODULE 2048
*** CLASS Struct Define
Define CLASS struct_WIN32_FIND_DATA As Custom
* 模拟 WIN32_FIND_DATA 结构的类
Value = ""
fileAttributes = 0
creationTimeLo = 0
creationTimeHi = 0
lastAccessTimeHi = 0
lastAccessTimeLo = 0
lastWriteTimeHi = 0
lastWriteTimeLo = 0
fileSizeLo = 0
fileName = ""
creationTime = CTOT("")
lastAccessTime = CTOT("")
lastWriteTime = CTOT("")
PROCEDURE setValue(lcValue)
* 转换缓冲内容到对象属性
This.value = lcValue
This.fileAttributes = THIS.buf2num(THIS.value, 0, 4)
This.creationTimeLo = THIS.buf2num(THIS.value, 4, 4)
This.creationTimeHi = THIS.buf2num(THIS.value, 8, 4)
This.lastAccessTimeHi = THIS.buf2num(THIS.value, 12, 4)
This.lastAccessTimeLo = THIS.buf2num(THIS.value, 16, 4)
This.lastWriteTimeHi = THIS.buf2num(THIS.value, 20, 4)
This.lastWriteTimeLo = THIS.buf2num(THIS.value, 24, 4)
This.fileSizeLo = THIS.buf2num(THIS.value, 32, 4)
This.creationTime = THIS.ftime2dtime(SUBSTR(THIS.value, 5, 8))
This.lastAccessTime = THIS.ftime2dtime(SUBSTR(THIS.value, 13, 8))
This.lastWriteTime = THIS.ftime2dtime(SUBSTR(THIS.value, 21, 8))
This.fileName = ALLTRIM(SUBSTR(THIS.value, 45,250))
If AT(Chr(0), THIS.fileName) <> 0
This.fileName = SUBSTR(THIS.fileName, 1, AT(Chr(0), THIS.fileName)-1)
Endif
ENDPROC
FUNCTION isDirectory
Return bitAnd(THIS.fileAttributes,FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY
ENDFUNC
Protected FUNCTION buf2num(lcBuffer, lnOffset, lnBytes)
* 从缓冲转换 bytes 到一个数值
lnResult = 0
For ftp_lnIndex = 1 TO lnBytes
lnResult = lnResult +;
bitlshift(Asc(SUBSTR(lcBuffer, lnOffset + ftp_lnIndex, 1)), (ftp_lnIndex - 1)*8)
Endfor
Return lnResult
Protected FUNCTION ftime2dtime(lcFileTime)
lcSystemTime = REPLICATE(Chr(0), 16)
Declare INTEGER FileTimeToSystemTime IN kernel32.dll;
STRING @ lpFileTime,;
STRING @ lpSystemTime
FileTimeToSystemTime(@lcFileTime, @lcSystemTime)
wYear = THIS.buf2num(lcSystemTime, 0, 2)
wMonth = THIS.buf2num(lcSystemTime, 2, 2)
wDay = THIS.buf2num(lcSystemTime, 6, 2)
wHour = THIS.buf2num(lcSystemTime, 8, 2)
wMinute = THIS.buf2num(lcSystemTime, 10, 2)
wSecond = THIS.buf2num(lcSystemTime, 12, 2)
lcDate = STRTRAN(STR(wMonth,2) + "/" + STR(wDay,2) + "/" + STR(wYear,4), " ","0")
lcTime = STRTRAN(STR(wHour,2) + ":" + STR(wMinute,2) + ":" + STR(wSecond,2), " ","0")
lcStoredSet = SET("DATE")
Set DATE TO MDY
ltResult = CTOT(lcDate + " " + lcTime)
Set DATE TO &lcStoredSet
Return ltResult
EndDefine
*----------------------------------------------------------------------------*
PROCEDURE FTP_Init
PUBLIC ghIPSession, ghFTPSession, gcServer, gcUsername, gcPassword
PUBLIC gnHTTPPort, gnHTTPConnectType, gnConnectTimeout
PUBLIC gnError, gcErrorMsg
PUBLIC glCancelFTP, gnFTPTransferBufferSize
ghIPSession = 0
ghFTPSession = 0
gcServer = ""
gcUsername = ""
gcPassword = ""
gnHTTPPort = 21
gnHTTPConnectType = 1
gnConnectTimeout = 5
gnError = 0
gcErrorMsg = ""
glCancelFTP = .F.
gnFTPTransferBufferSize = 1024*1024
ENDPROC
*----------------------------------------------------------------------------*
FUNCTION IsConnected()
local lnFlags,lcConnectionName
Declare INTEGER InternetGetConnectedStateEx IN wininet.dll;
INTEGER @ lpdwFlags,;
STRING @ lpszConnectionName,;
INTEGER dwNameLen,;
INTEGER dwReserved
lnFlags = 0
lcConnectionName = REPLICATE(CHR(0),250)
if InternetGetConnectedStateEx(@lnFlags,;
@lcConnectionName,;
LEN(lcConnectionName),0) == 1
RETURN .T.
else
RETURN .F.
endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION IsCanConnect(lcRemoteIP)
local lnResult
toShell = CREATEOBJECT("WScript.Shell")
lnResult = toShell.Run("ping " + lcRemoteIP, 0, 1)
If lnResult == 0
RETURN .T.
Else
RETURN .F.
ENDIF
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_Connect(lcServer, lcUsername, lcPassword)
local lnFlags,lcConnectionName,lhIP, lhHTTP, lnHTTPPort, lnError, lcErrMsg, lnErrLen
Declare INTEGER InternetOpen IN wininet.dll;
STRING sAgent,;
INTEGER lAccessType,;
STRING sProxyName,;
STRING sProxyBypass,;
INTEGER dwFlags
Declare INTEGER InternetGetConnectedStateEx IN wininet.dll;
INTEGER @ lpdwFlags,;
STRING @ lpszConnectionName,;
INTEGER dwNameLen,;
INTEGER dwReserved
Declare INTEGER InternetConnect IN wininet.dll;
INTEGER hInternetSession,;
STRING sServerName,;
INTEGER nServerPort,;
STRING sUsername,;
STRING sPassword,;
INTEGER lService,;
INTEGER dwFlags,;
INTEGER dwContext
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
Declare INTEGER GetLastError IN kernel32.dll
* 检查网络连接
lnFlags = 0
lcConnectionName = REPLICATE(CHR(0),250)
if InternetGetConnectedStateEx(@lnFlags,;
@lcConnectionName,;
LEN(lcConnectionName),0) == 0
gcErrorMsg = "Network Connection Not Ready"
RETURN .F.
endif
* 检查登录信息
lcServer = IIF(!EMPTY(lcServer),lcServer,gcServer)
lcUsername = TRIM(IIF(!EMPTY(lcUsername),lcUsername,gcUsername))
lcPassword = TRIM(IIF(!EMPTY(lcPassword),lcPassword,gcPassword))
* 存储登陆信息
gcServer = lcServer
gcUsername = lcUsername
gcPassword = lcPassword
* 设置默认端口
if gnHTTPPort == 0
lnHTTPPort = INTERNET_DEFAULT_FTP_PORT
else
lnHTTPPort = gnHTTPPort
endif
* 重置错误信息
gnError = 0
gcErrorMsg = ""
* 打开网络连接
ghIPSession = InternetOpen("vfp", gnHTTPConnectType, NULL,NULL,0)
if ghIPSession == 0
* 返回错误信息
gnError = GetLastError()
gcErrorMsg = GetSystemErrorMsg(gnError)
if gnError == 0
gcErrorMsg = "Create IP Session Failed"
endif
return .F.
endif
* 登录FTP服务器
ghFTPSession = InternetConnect(ghIPSession, lcServer, lnHTTPPort, lcUsername, lcPassword, INTERNET_SERVICE_FTP, 0, 0)
if ghFTPSession == 0
* 关网络连接
InternetCloseHandle(ghIPSession)
* 返回错误信息
gnError = GetLastError()
gcErrorMsg = GetSystemErrorMsg(gnError)
if gnError == 0
gcErrorMsg = "Connect FTP Server Failed"
endif
return .F.
endif
return .T.
ENDFUNC
*----------------------------------------------------------------------------*
PROCEDURE FTP_Close
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hIPSession
InternetCloseHandle(ghFTPSession)
InternetCloseHandle(ghIPSession)
ghFTPSession = 0
ghIPSession = 0
ENDPROC
*----------------------------------------------------------------------------*
FUNCTION FTP_ErrorMessage()
RETURN gcErrorMsg
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_Command(lcCommand, lnExpectResponse)
local lhFTPCmd, lnResult, lnBufferSize, lcBuffer, laFileList
Declare INTEGER FtpCommand IN wininet.dll;
INTEGER hConnect,;
INTEGER fExpectResponse,;
INTEGER dwFlags,;
STRING lpszCommand,;
STRING @ dwContext,;
INTEGER @ phFtpCommand
Declare INTEGER InternetReadFile IN wininet.dll;
INTEGER hFile,;
STRING lpBuffer,;
INTEGER dwNumberOfBytesToRead,;
INTEGER @ lpdwNumberOfBytesRead
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
* note that ASCII type is hard-coded
lnResult = FtpCommand(ghFTPSession, lnExpectResponse,;
FTP_TRANSFER_TYPE_ASCII,;
lcCommand, 0, @lhFTPCmd)
If lnResult == 0
Return .F.
Endif
If lhFTPCmd
* if there is a return - display it on the screen
Set MEMOWIDTH TO 100
lnBufferSize = 128 && reading buffer size
?
laFileList = chr(13) + chr(10)
Do WHILE .T.
lcBuffer = REPLICATE(Chr(0), lnBufferSize)
tnBytesRead = 0
If InternetReadFile(lhFTPCmd, @lcBuffer, lnBufferSize, @tnBytesRead) == 1
lcBuffer = LEFT(lcBuffer, tnBytesRead)
?? lcBuffer
laFileList = laFileList + lcBuffer
If tnBytesRead < lnBufferSize
Exit
Endif
Else
Exit
Endif
Enddo
InternetCloseHandle(lhFTPCmd)
Endif
Return .T.
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_OpenFile(lcRemoteFile, lcOpenMode)
local lnMode,lhFileHandle
Declare INTEGER FtpOpenFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszFileName,;
INTEGER dwAccess,;
INTEGER dwFlags,;
INTEGER dwContext
DO CASE
* GENERIC_READ
CASE UPPER(lcOpenMode) == "R"
lnMode = GENERIC_READ
* GENERIC_WRITE
CASE UPPER(lcOpenMode) == "W"
lnMode = GENERIC_WRITE
* GENERIC_EXECUTE
CASE UPPER(lcOpenMode) == "E"
lnMode = GENERIC_EXECUTE
* GENERIC_ALL
CASE UPPER(lcOpenMode) == "A"
lnMode = GENERIC_ALL
ENDCASE
lhFileHandle = FtpOpenFile(ghFTPSession, lcRemoteFile,;
lnMode,;
INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY, 0)
return lhFileHandle
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_ReadFile(lhFileHandle,lcReadBuffer,lnReadSize)
local lnReadBytes
Declare INTEGER InternetReadFile IN wininet.dll;
INTEGER hFile,;
STRING lpBuffer,;
INTEGER dwNumberOfBytesToRead,;
INTEGER @ lpdwNumberOfBytesRead
lcReadBuffer = SPACE(lnReadSize)
lnReadBytes = 0
InternetReadFile(lhFileHandle, @lcReadBuffer, lnReadSize, @lnReadBytes)
return lnReadBytes
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_WriteFile(lhFileHandle,lcWriteBuffer,lnWriteSize)
local lnWriteBytes
Declare INTEGER InternetWriteFile IN wininet.dll;
INTEGER hFile,;
STRING lpBuffer,;
INTEGER dwNumberOfBytesToWrite,;
INTEGER @ lpdwNumberOfBytesWritten
lnWriteBytes = 0
lnWriteSize = IIF(lnWriteSize > LEN(lcWriteBuffer), LEN(lcWriteBuffer), lnWriteSize)
InternetWriteFile(lhFileHandle, lcWriteBuffer, lnWriteSize, @lnWriteBytes)
return lnWriteBytes
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_CloseFile(lhFileHandle)
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
return InternetCloseHandle(lhFileHandle)
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_GetFileSize(lcRemoteFile)
local lhFTPFile, lnResult
Declare INTEGER FtpOpenFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszFileName,;
INTEGER dwAccess,;
INTEGER dwFlags,;
INTEGER dwContext
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
Declare INTEGER FtpGetFileSize IN wininet.dll;
INTEGER hFile,;
INTEGER @ lpdwFileSizeHigh
lhFTPFile = FtpOpenFile(ghFTPSession, lcRemoteFile,;
GENERIC_READ,;
INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY, 0)
if lhFTPFile == 0
return -1
endif
lnResult = FtpGetFileSize(lhFTPFile, 0)
InternetCloseHandle(lhFTPFile)
return lnResult
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_GetFile(lcRemoteFile, lcLocalFile)
local lhFTPFile, lnRemoteFileSize, lnLocalFileSize, lnResult
Declare INTEGER FtpOpenFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszFileName,;
INTEGER dwAccess,;
INTEGER dwFlags,;
INTEGER dwContext
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
Declare INTEGER FtpGetFileSize IN wininet.dll;
INTEGER hFile,;
INTEGER @ lpdwFileSizeHigh
Declare INTEGER FtpGetFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszRemoteFile,;
STRING lpszNewFile,;
INTEGER fFailIfExists,;
INTEGER dwFlagsAndAttributes,;
INTEGER dwFlags,;
INTEGER dwContext
* 读网络文件大小
lhFTPFile = FtpOpenFile(ghFTPSession, lcRemoteFile,;
GENERIC_READ,;
INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY, 0)
if lhFTPFile == 0
return .F.
endif
lnRemoteFileSize = FtpGetFileSize(lhFTPFile, 0)
InternetCloseHandle(lhFTPFile)
* 下载网络文件
lnResult = FtpGetFile(ghFTPSession, lcRemoteFile, lcLocalFile,;
FTP_TRANSFER_TARGET_EXIST,;
FILE_ATTRIBUTE_NORMAL,;
FTP_TRANSFER_TYPE_ASCII, 0)
if lnResult == 0
return .F.
endif
* 读本地文件大小
if not file(lcLocalFile)
return .F.
else
set compatible on
lnLocalFileSize = fsize(lcLocalFile)
set compatible off
endif
* 对比接收文件大小
if lnRemoteFileSize == lnLocalFileSize
return .T.
else
return .F.
endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_PutFile(lcLocalFile, lcRemoteFile)
local lhFTPFile, lnRemoteFileSize, lnLocalFileSize, lnResult
Declare INTEGER FtpOpenFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszFileName,;
INTEGER dwAccess,;
INTEGER dwFlags,;
INTEGER dwContext
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
Declare INTEGER FtpGetFileSize IN wininet.dll;
INTEGER hFile,;
INTEGER @ lpdwFileSizeHigh
Declare INTEGER FtpPutFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszLocalFile,;
STRING lpszNewRemoteFile,;
INTEGER dwFlags,;
INTEGER dwContext
* 读本地文件大小
if not file(lcLocalFile)
return .F.
else
set compatible on
lnLocalFileSize = fsize(lcLocalFile)
set compatible off
endif
* 上传网络文件
lnResult = FtpPutFile(ghFTPSession, lcLocalFile, lcRemoteFile,;
FTP_TRANSFER_TYPE_BINARY, 0)
if lnResult == 0
return .F.
endif
* 读网络文件大小
lhFTPFile = FtpOpenFile(ghFTPSession, lcRemoteFile,;
GENERIC_READ,;
INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY, 0)
if lhFTPFile == 0
return .F.
endif
lnRemoteFileSize = FtpGetFileSize(lhFTPFile, 0)
InternetCloseHandle(lhFTPFile)
* 对比接收文件大小
if lnLocalFileSize == lnRemoteFileSize
return .T.
else
return .F.
endif
ENDFUNC
*-----------------------------------------------------------------------------*
FUNCTION FTP_RecvFile(lcRemoteFile, lcLocalFile, lnShowTimeout)
LOCAL lhFTPFile,lhFile,;
lnFileSize,lnResult,lnBufferReadCount
Declare INTEGER FtpOpenFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszFileName,;
INTEGER dwAccess,;
INTEGER dwFlags,;
INTEGER dwContext
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
Declare INTEGER FtpGetFileSize IN wininet.dll;
INTEGER hFile,;
INTEGER @ lpdwFileSizeHigh
Declare INTEGER InternetReadFile IN wininet.dll;
INTEGER hFile,;
STRING lpBuffer,;
INTEGER dwNumberOfBytesToRead,;
INTEGER @ lpdwNumberOfBytesRead
Declare INTEGER GetLastError IN kernel32.dll
gnError = 0
gcErrorMsg = ""
* 从服务器打开文件
lhFTPFile = FtpOpenFile(ghFTPSession, lcRemoteFile,;
GENERIC_READ,;
INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY, 0)
IF lhFTPFile == 0
gnError = GetLastError()
gcErrorMsg = GetSystemErrorMsg()
RETURN gnError
ENDIF
* 获取服务器文件大小
lnFileSize = FtpGetFileSize(lhFTPFile, 0)
* 从磁盘创建文件
lhFile = FCREATE(lcLocalFile)
IF lhFile == -1
gnError = -2
gcErrorMsg = "Can not create file."
InternetCloseHandle(lhFTPFile)
RETURN gnError
ENDIF
glCancelFTP = .F.
tcWriteBuffer = SPACE(gnFTPTransferBufferSize)
tnFileReadBytes = 0
lnResult = 0
lnBufferReadCount = 0
DO WHILE .T.
* 从服务器读文件到写缓存
tnReadBytes = 0
lnResult = InternetReadFile(lhFTPFile, @tcWriteBuffer, LEN(tcWriteBuffer), @tnReadBytes)
* 将写缓存写入磁盘文件
IF lnResult == 1 AND tnReadBytes > 0
IF FWRITE(lhFile,LEFT(tcWriteBuffer, tnReadBytes)) == 0
gnError = -3
gcErrorMsg = "Can not write file."
InternetCloseHandle(lhFTPFile)
FCLOSE(lhFile)
RETURN gnError
ENDIF
tnFileReadBytes = tnFileReadBytes + tnReadBytes
lnBufferReadCount = lnBufferReadCount + 1
OnFTPTransmitting("Download", lcRemoteFile, tnFileReadBytes, lnFileSize, lnShowTimeout)
ENDIF
IF glCancelFTP
gcErrorMsg = "Download canceled by user"
gnError = -1
EXIT
ENDIF
IF (lnResult == 1 AND tnReadBytes == 0) OR (lnResult == 0)
EXIT
ENDIF
ENDDO
IF gnError == 0
OnFTPTransmitting("Download", lcRemoteFile, lnFileSize, lnFileSize, lnShowTimeout)
ENDIF
InternetCloseHandle(lhFTPFile)
FCLOSE(lhFile)
RETURN gnError
ENDFUNC
*-----------------------------------------------------------------------------*
FUNCTION FTP_SendFile(lcLocalFile, lcRemoteFile, lnShowTimeout)
LOCAL lhFTPFile,lhFile,;
lnFileSize,lnResult,lnBufferWriteCount
Declare INTEGER FtpOpenFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszFileName,;
INTEGER dwAccess,;
INTEGER dwFlags,;
INTEGER dwContext
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
Declare INTEGER InternetWriteFile IN wininet.dll;
INTEGER hFile,;
STRING lpBuffer,;
INTEGER dwNumberOfBytesToWrite,;
INTEGER @ lpdwNumberOfBytesWritten
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
* 从服务器打开文件
lhFTPFile = FtpOpenFile(ghFTPSession, lcRemoteFile,;
GENERIC_WRITE,;
INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY, 0)
IF lhFTPFile == 0
gnError = GetLastError()
gcErrorMsg = GetSystemErrorMsg()
RETURN gnError
ENDIF
* 从磁盘打开文件
lhFile = FOPEN(lcLocalFile)
IF lhFile == -1
gcErrorMsg = "Source file doesn't exist or is in use..."
gnError = 1
InternetCloseHandle(lhFTPFile)
RETURN gnError
ENDIF
* 获取磁盘文件大小
ADIR(taADIR, lcLocalFile)
lnFileSize = taADIR[1,2]
gnError = 0
gcErrorMsg = ""
tnFileWriteBytes = 0
lnBufferWriteCount = 0
DO WHILE .T.
* 从磁盘读文件到写缓存
tcWriteBuffer = FRead(lhFile,gnFTPTransferBufferSize)
IF LEN(tcWriteBuffer) == 0
OnFTPTransmitting("Upload", lcLocalFile, lnFileSize, lnFileSize, lnShowTimeout)
EXIT
ENDIF
* 将写缓存写入服务器文件
tnWriteBytes = 0
lnResult = InternetWriteFile(lhFTPFile, tcWriteBuffer, LEN(tcWriteBuffer), @tnWriteBytes)
IF lnResult == 1 AND tnWriteBytes > 0
tnFileWriteBytes = tnFileWriteBytes + tnWriteBytes
lnBufferWriteCount = lnBufferWriteCount + 1
OnFTPTransmitting("Upload", lcLocalFile, tnFileWriteBytes, lnFileSize, lnShowTimeout)
ENDIF
IF glCancelFTP
gcErrorMsg = "Upload canceled by user"
gnError = -1
EXIT
ENDIF
IF (lnResult == 1 AND tnWriteBytes == 0) OR (lnResult == 0)
EXIT
ENDIF
ENDDO
InternetCloseHandle(lhFTPFile)
FCLOSE(lhFile)
RETURN gnError
ENDFUNC
*-----------------------------------------------------------------------------*
FUNCTION OnFTPTransmitting(lcShowText, lcFileName, lnCurrentBytes, lnFinishBytes, lnShowTimeout)
LOCAL lcProcess,;
lnSegment,lnDegree
lnSegment = 25
lnCurrentBytes = IIF(lnCurrentBytes>lnFinishBytes,lnFinishBytes,lnCurrentBytes)
lnDegree = (lnCurrentBytes/lnFinishBytes)*lnSegment
* 大于零显示进度和完成提示
if lnShowTimeout > 0
if lnDegree < lnSegment
lcProcess = SPACE(lnSegment)
for ftp_lnIndex = 1 to lnDegree
lcProcess = STUFF(lcProcess ,ftp_lnIndex,1,">")
endfor
wait window lcShowText + ":" + lcFileName + " [" + lcProcess + "]" nowait
else
wait window lcShowText + " Finished" timeout lnShowTimeout
endif
endif
* 等于零只显示完成提示
if lnShowTimeout == 0
if lnDegree == lnSegment
wait window lcShowText + " Finished" nowait
endif
endif
* 等于 -1 只显示进度
if lnShowTimeout == -1
lcProcess = SPACE(lnSegment)
for ftp_lnIndex = 1 to lnDegree
lcProcess = STUFF(lcProcess ,ftp_lnIndex,1,">")
endfor
wait window lcShowText + ":" + lcFileName + " [" + lcProcess + "]" nowait
endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_RenameFile(lcRemoteFile, lcRename)
Declare INTEGER FtpRenameFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszExisting,;
STRING lpszNew
if FtpRenameFile(ghFTPSession, lcRemoteFile, lcRename) == 1
return .T.
else
return .F.
endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_DeleteFile(lcRemoteFile)
Declare INTEGER FtpDeleteFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszFileName
if FtpDeleteFile(ghFTPSession, lcRemoteFile) == 1
return .T.
else
return .F.
endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_CreateDir(lcRemotePath)
local lcDirectory, lnLen
Declare INTEGER FtpCreateDirectory IN wininet.dll;
INTEGER hConnect,;
STRING @ lpszCurrentDirectory
Declare INTEGER FtpSetCurrentDirectory IN wininet.dll;
INTEGER hConnect,;
STRING @ lpszDirectory
Declare INTEGER FtpGetCurrentDirectory IN wininet.dll;
INTEGER hConnect,;
STRING @ lpszCurrentDirectory,;
INTEGER @ lpdwCurrentDirectory
tcCreatePath = lcRemotePath
DO WHILE AT("/",tcCreatePath) <> 0
FtpCreateDirectory(ghFTPSession, LEFT(tcCreatePath,AT("/",tcCreatePath)-1))
FtpSetCurrentDirectory(ghFTPSession, LEFT(tcCreatePath,AT("/",tcCreatePath)-1))
tcCreatePath = SUBSTR(tcCreatePath,AT("/",tcCreatePath)+1)
ENDDO
if LEN(tcCreatePath) <> 0
FtpCreateDirectory(ghFTPSession, tcCreatePath)
FtpSetCurrentDirectory(ghFTPSession, tcCreatePath)
endif
lcDirectory = SPACE(256)
lnLen = Len(lcDirectory)
If FtpGetCurrentDirectory(ghFTPSession, @lcDirectory, @lnLen) == 1
Return LEFT(lcDirectory, lnLen)
Else
Return ""
Endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_RemoveDir(lcRemotePath)
Declare INTEGER FtpRemoveDirectory IN wininet.dll;
INTEGER hConnect,;
STRING @ lpszDirectory
if FtpRemoveDirectory(ghFTPSession, @lcRemotePath) == 1
return .T.
else
return .F.
endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_GetCurrentDir()
local lcDirectory, lnLen
Declare INTEGER FtpGetCurrentDirectory IN wininet.dll;
INTEGER hConnect,;
STRING @ lpszCurrentDirectory,;
INTEGER @ lpdwCurrentDirectory
lcDirectory = SPACE(256)
lnLen = Len(lcDirectory)
If FtpGetCurrentDirectory(ghFTPSession, @lcDirectory, @lnLen) == 1
Return LEFT(lcDirectory, lnLen)
Else
Return ""
Endif
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION FTP_SetCurrentDir(lcRemotePath)
Declare INTEGER FtpSetCurrentDirectory IN wininet.dll;
INTEGER hConnect,;
STRING @ lpszDirectory
if FtpSetCurrentDirectory(ghFTPSession, @lcRemotePath) == 1
return .T.
else
return .F.
endif
ENDFUNC
*----------------------------------------------------------------------------*
* 需要调用函数,此函数用于清除从路径层到第一层文件夹内所有指定文件,不清除文件夹
FUNCTION FTP_CleanupDir(lcRemotePath, lcSuffixes)
local lnDirLayer,lnFileCount,lcCurrentPath,laFileArray
* 计算文件夹深度
lnDirLayer = 0
tcPathRemain = lcRemotePath
DO WHILE AT("/",tcPathRemain) <> 0
lnDirLayer = lnDirLayer + 1
tcPathRemain = SUBSTR(tcPathRemain,AT("/",tcPathRemain)+1)
ENDDO
* 设定当前路径
if FTP_GetCurrentDir() <> lcRemotePath
if not FTP_SetCurrentDir(lcRemotePath)
return .F.
endif
endif
* 删除当前路径所有文件
lnFileCount = FTP_GetFileList(lcRemotePath,lcSuffixes,@laFileArray)
if lnFileCount <> 0
for ftp_lnIndex = 1 to lnFileCount
if UPPER(lcSuffixes) == "D"
FTP_RemoveDir(laFileArray[ftp_lnIndex,1])
else
FTP_DeleteFile(laFileArray[ftp_lnIndex,1])
endif
endfor
endif
* 执行深度删除
lcCurrentPath = lcRemotePath
DO WHILE lnDirLayer <> 0
* 路径向上
lcCurrentPath = LEFT(lcCurrentPath,AT("/",lcCurrentPath,lnDirLayer)-1)
FTP_SetCurrentDir(lcCurrentPath)
lnDirLayer = lnDirLayer - 1
* 删除当前路径所有文件
lnFileCount = FTP_GetFileList(lcCurrentPath,lcSuffixes,@laFileArray)
if lnFileCount <> 0
for ftp_lnIndex = 1 to lnFileCount
if UPPER(lcSuffixes) == "D"
FTP_RemoveDir(laFileArray[ftp_lnIndex,1])
else
FTP_DeleteFile(laFileArray[ftp_lnIndex,1])
endif
endfor
endif
ENDDO
return FTP_GetCurrentDir()
ENDFUNC
*----------------------------------------------------------------------------*
* 需要调用函数,若 lcSuffixes 为 "D" 则列出目录,否则按照扩展名列出相应文件,存储到数组变量中
FUNCTION FTP_GetFileList(lcRemotePath, lcSuffixes, laFileArray)
local lcStoredPath, lnPathLen, lnFound, lcFindFileData, lhFind
Declare INTEGER FtpFindFirstFile IN wininet.dll;
INTEGER hConnect,;
STRING lpszSearchFile,;
STRING @ lpFindFileData,;
INTEGER dwFlags,;
INTEGER dwContext
Declare INTEGER InternetFindNextFile IN wininet.dll;
INTEGER hFind,;
STRING @ lpvFindData
Declare INTEGER InternetCloseHandle IN wininet.dll;
INTEGER hInet
* 储存当前路径并设置目标路径
lcStoredPath = FTP_GetCurrentDir()
If lcStoredPath == ""
Return -1 && 路径错误
Endif
if not FTP_SetCurrentDir(lcRemotePath)
Return -1 && 路径错误
endif
* 创建 API 结构对象
toFileData = CREATEOBJECT("struct_WIN32_FIND_DATA")
* 找到第一个文件
lnFound = 0
lcFindFileData = REPLICATE(Chr(0), 320)
if UPPER(lcSuffixes) == "D"
lhFind = FtpFindFirstFile(ghFTPSession, "*.*", @lcFindFileData, INTERNET_FLAG_NEED_FILE, 0)
else
lhFind = FtpFindFirstFile(ghFTPSession, lcSuffixes, @lcFindFileData, INTERNET_FLAG_NEED_FILE, 0)
endif
* 存储目录信息
If lhFind <> 0
Do WHILE .T.
toFileData.setValue(lcFindFileData)
if UPPER(lcSuffixes) == "D"
If toFileData.isDirectory()
lnFound = lnFound + 1
Dimen laFileArray[lnFound, 3]
laFileArray[lnFound, 1] = toFileData.fileName
laFileArray[lnFound, 2] = toFileData.fileSizeLo
laFileArray[lnFound, 3] = toFileData.lastWriteTime
Endif
else
If Not toFileData.isDirectory()
lnFound = lnFound + 1
Dimen laFileArray[lnFound, 3]
laFileArray[lnFound, 1] = toFileData.fileName
laFileArray[lnFound, 2] = toFileData.fileSizeLo
laFileArray[lnFound, 3] = toFileData.lastWriteTime
Endif
endif
* 找下一个文件
If InternetFindNextFile(lhFind, @lcFindFileData) <> 1
Exit
Endif
Enddo
Endif
* 释放 API 结构对象
RELEASE toFileData
* 关闭文件
InternetCloseHandle(lhFind)
if not FTP_SetCurrentDir(lcStoredPath)
Return -1 && 路径错误
endif
Return lnFound
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION ByteSize(lnByteNum)
Declare STRING StrFormatByteSize IN shlwapi.dll;
INTEGER dw,;
STRING @ pszBuf,;
INTEGER cchBuf
pszBuf = SPACE(64)
Return StrFormatByteSize(lnByteNum, @pszBuf, Len(pszBuf))
ENDFUNC
*----------------------------------------------------------------------------*
PROCEDURE WinInetSetTimeout(dwTimeoutSecs)
dwTimeoutSecs = IIF(type("dwTimeoutSecs") = "N", dwTimeoutSecs, gnConnectTimeout)
Declare INTEGER InternetSetOption IN wininet.dll;
INTEGER ,;
INTEGER ,;
INTEGER @ ,;
INTEGER
dwTimeoutSecs = dwTimeoutSecs * 1000 && to milliseconds
llRetVal = InternetSetOption(ghIPSession, INTERNET_OPTION_CONNECT_TIMEOUT, @dwTimeoutSecs, 4)
llRetVal = InternetSetOption(ghIPSession, INTERNET_OPTION_DATA_RECEIVE_TIMEOUT, @dwTimeOutSecs, 4)
llRetVal = InternetSetOption(ghIPSession, INTERNET_OPTION_DATA_SEND_TIMEOUT, @dwTimeOutSecs, 4)
dwTimeoutSecs = 1 &&// Retry only 1 time
llRetVal = InternetSetOption(ghIPSession, INTERNET_OPTION_CONNECT_RETRIES, @dwTimeoutSecs, 4)
ENDPROC
*-----------------------------------------------------------------------------*
FUNCTION GetLastInternetError(lnError)
local lcErrorMsg, lnSize
lnError = IIF(type("lnError")="N",lnError,gnError)
DECLARE INTEGER InternetGetLastResponseInfo IN wininet.dll;
INTEGER @ lpdwError,;
STRING @ lpszBuffer,;
INTEGER @ lpdwBufferLength
lcErrorMsg = SPACE(1024)
lnSize = LEN(lcErrorMsg)
InterNetGetLastResponseInfo(@lnError, @lcErrorMsg, @lnSize)
IF lnSize < 2
RETURN ""
ENDIF
RETURN SUBSTR(lcErrorMsg,1,lnSize)
ENDFUNC
*----------------------------------------------------------------------------*
FUNCTION GetSystemErrorMsg(lnErrorNo, llAPI)
LOCAL szMsgBuffer,lnSize
lnErrorNo = IIF(type("lnErrorNo") = "N",lnErrorNo,gnError)
if lnErrorNo == ERROR_INTERNET_EXTENDED_ERROR
RETURN GetLastInternetError()
endif
szMsgBuffer = SPACE(512)
Declare INTEGER FormatMessage IN kernel32.dll;
INTEGER dwFlags ,;
INTEGER lpvSource,;
INTEGER dwMsgId,;
INTEGER dwLangId,;
STRING @ lpBuffer,;
INTEGER nSize,;
INTEGER Arguments
Declare INTEGER GetModuleHandle IN kernel32.dll;
STRING
lnModule = GetModuleHandle("wininet.dll")
if lnModule <> 0 AND !llAPI
lnSize = FormatMessage(FORMAT_MESSAGE_FROM_HMODULE,lnModule,lnErrorNo,0,@szMsgBuffer,LEN(szMsgBuffer),0)
ELSE
lnSize = 0
endif
if lnSize > 2
szMsgBuffer = SUBSTR(szMsgBuffer,1,lnSize-2)
ELSE
*** REtry with 12000 less - WinInet return Windows API file error codes
lnSize = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,0,lnErrorNo,0,@szMsgBuffer,LEN(szMsgBuffer),0)
if lnSize > 2
szMsgBuffer = "Win32 API: " + SUBSTR(szMsgBuffer,1,lnSize-2)
ELSE
szMsgBuffer = ""
endif
endif
RETURN szMsgBuffer
ENDFUNC
*----------------------------------------------------------------------------*
* End of program.