精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● VFP>>〖外部引用〗>>* FP_FTP.PRG --- VFP FTP 通用函数、过程

主题:* FP_FTP.PRG --- VFP FTP 通用函数、过程
发信人: goodfrd(supervisor)
整理人: foxzz(2002-10-19 10:39:13), 站内信件
* FP_FTP.PRG --- VFP FTP 通用函数、过程
*
* Modification History:
*   2000.12.01  M.L.Y       Program Created, V1.0
*
*-----------------------------------------------------------------------------*
*** General WinINET Constants
#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_SERVICE_FTP                    1
#DEFINE INTERNET_DEFAULT_FTP_PORT               21

#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

*** 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_NORMAL                   0x00000080
#DEFINE FILE_ATTRIBUTE_READONLY                 0x00000001
#DEFINE FILE_ATTRIBUTE_HIDDEN                   0x00000002
#DEFINE FILE_ATTRIBUTE_SYSTEM                   0x00000004

*** Values for FormatMessage API
#DEFINE FORMAT_MESSAGE_FROM_SYSTEM              4096
#DEFINE FORMAT_MESSAGE_FROM_HMODULE             2048

*-----------------------------------------------------------------------------*
PROCEDURE FTP_Init

PUBLIC ghIPSession, ghFTPSession, gcServer, gcUsername, gcPassword
PUBLIC gnHTTPPort, gnHTTPConnectType, gnConnectTimeout
PUBLIC gnError, gcErrorMsg, glCancelFTP, gnFTPWorkBufferSize

ghIPSession = 0
ghFTPSession = 0
gcServer = ""
gcUsername = ""
gcPassword = ""
gnHTTPPort = 21
gnHTTPConnectType = 1
gnConnectTimeout = 5
gnError = 0
gcErrorMsg = ""
glCancelFTP = .F.
gnFTPWorkBufferSize = 4096

RETURN

*-----------------------------------------------------------------------------*
FUNCTION FTP_Close
DECLARE INTEGER InternetCloseHandle ;
    IN WININET.DLL ;
    INTEGER hIPSession

=InternetCloseHandle(ghFTPSession)
=InternetCloseHandle(ghIPSession)

ghFTPSession=0
ghIPSession=0

RETURN

*-----------------------------------------------------------------------------*
FUNCTION FTP_Connect
LPARAMETER lcServer, lcUsername, lcPassword
LOCAL lhIP, lhHTTP, lnError, lnHTTPPort

lcServer=IIF(!EMPTY(lcServer),lcServer,gcServer)
lcUsername=TRIM(IIF(!EMPTY(lcUsername),lcUsername,gcUsername))
lcPassword=TRIM(IIF(!EMPTY(lcPassword),lcPassword,gcPassword))

*** Assign Default Ports
IF gnHTTPPort = 0
    lnHTTPPort = INTERNET_DEFAULT_FTP_PORT
ELSE
    lnHTTPPort = gnHTTPPort
ENDIF

gcServer = lcServer
gnError=0
gcErrorMsg=""

DECLARE INTEGER InternetCloseHandle ;
    IN WinInet.DLL ;
    INTEGER

*!* DECLARE INTEGER GetLastError;
*!*     IN WIN32API

DECLARE INTEGER GetLastError;
    IN KERNEL32.DLL

DECLARE INTEGER InternetOpen ;
    IN WININET.DLL ;
    STRING,;
    INTEGER,;
    STRING, STRING, INTEGER

hInetConnection=;
    InternetOpen("West Wind Web Connection 3.00",;
    gnHTTPConnectType,;
    NULL,NULL,0)

IF hInetConnection = 0
    gnError=GetLastError()
    gcErrorMsg=GetSystemErrorMsg(gnError)
    RETURN gnError
ENDIF

ghIPSession=hInetConnection
= WinInetSetTimeout()

DECLARE INTEGER InternetConnect ;
    IN WININET.DLL ;
    INTEGER hIPHandle,;
    STRING lpzServer,;
    INTEGER dwPort, ;
    STRING lpzUserName,;
    STRING lpzPassword,;
    INTEGER dwServiceFlags,;
    INTEGER dwReserved,;
    INTEGER dwReserved

    lhFTPSession=;
        InternetConnect(hInetConnection,;
        lcServer,;
        lnHTTPPort,;
        lcUsername,;
        lcPassword,;
        INTERNET_SERVICE_FTP,;
        0,0)

IF (lhFTPSession = 0)
    lnError = 0
    lcErrMsg = SPACE(256)
    lnErrLen = LEN(lcErrMsg)
    DECLARE INTEGER InternetGetLastResponseInfo ;
        IN WININET.DLL ;
        INTEGER @dwError,;
        STRING @szBuffer,;
        INTEGER @dwBufferLength

    lnResult = InternetGetLastResponseInfo(@lnError,@lcErrMsg,@lnErrLen)

    =InternetCloseHandle(hInetConnection)
    gnError = GetLastError()
    IF gnError = 0
        gcErrorMsg = lcErrMsg
        gnError = 1
    ELSE
        gcErrorMsg = GetSystemErrorMsg()
    ENDIF
    RETURN gnError
ENDIF

ghIPSession = hInetConnection
ghFTPSession = lhFTPSession

RETURN 0

*-----------------------------------------------------------------------------*
FUNCTION FTP_DeleteFile
LPARAMETERS lcfile

DECLARE INTEGER FtpDeleteFile ;
    IN WinInet.dll ;
    INTEGER hFTPSession,;
    STRING cFileName

IF FtpDeleteFile(ghFTPSession,lcFile) = 0
    gnError = GetLastError()
    gcErrorMsg = GetSystemErrorMsg()
    RETURN gnError
ENDIF

RETURN 0

*-----------------------------------------------------------------------------*
FUNCTION FTP_GetFile
LPARAMETERS lcFTPServer, lcSource, lcTarget, lnBinary, lcUsername, lcPassword

lnBinary=IIF(EMPTY(lnBinary),FTP_TRANSFER_TYPE_BINARY,lnBinary)

lnResult = FTP_Connect(lcFTPServer,lcUserName,lcPassWord)
IF lnResult # 0
    RETURN lnResult
ENDIF

DECLARE Integer FtpGetFile ;
    IN WinInet.dll ;
    Integer dwIPSession,;
    String cSource,;
    String cTarget, ;
    Integer bNoOverwrite,;
    INTEGER nAttributes, ;
    Integer nFlags, ;
    Integer nContext

lnResult = FtpGetFile(ghFTPSession,lcSource,;
                     lcTarget,0,FILE_ATTRIBUTE_NORMAL,;
                     lnBinary + INTERNET_FLAG_RELOAD,0)

IF lnResult = 0
    gnError = GetLastError()
    gcErrorMsg = GetSystemErrorMsg()
    = FTP_Close()
    RETURN gnError
ENDIF

= FTP_Close()

RETURN 0

*-----------------------------------------------------------------------------*
FUNCTION FTP_GetFileEx
LPARAMETER lcSourceFile, lcTargetFile

DECLARE INTEGER FtpOpenFile ;
    IN WININET.DLL ;
    INTEGER hIPSession,;
    STRING @lpszFileName,;
    INTEGER dwAcessFlags,;
    INTEGER dwServiceFlags,;
    INTEGER dwContext

DECLARE INTEGER InternetReadFile ;
    IN WININET.DLL ;
    INTEGER hFTPHandle,;
    STRING lcBuffer,;
    INTEGER cbBuffer,;
    INTEGER @cbBuffer

hFTPFile = FtpOpenFile(ghFTPSession,lcSourceFile,;
                       GENERIC_READ,;
                       INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY,0)

IF hFTPFile = 0
    gnError = GetLastError()
    gcErrorMsg = GetSystemErrorMsg()
    RETURN gnError
ENDIF

gnError = 0
gcErrorMsg = ""

*** Build the buffer dynamically
glCancelFTP = .F.
tcBuffer = ""
tnSize = 0
tnBufferSize = 0
lnRetVal = 0
lnBytesRead = 1
lnBufferReads = 0
DO WHILE .t.
    lcReadBuffer = SPACE(gnFTPWorkBufferSize)
    lnBytesRead = 0
    lnSize = LEN(lcReadBuffer)

    lnRetval=InternetReadFile(hFTPFile,;
        @lcReadBuffer,;
        lnSize,;
        @lnBytesRead)

    IF lnRetVal = 1 AND lnBytesRead > 0
        *** Update the input parameters - result buffer and size of buffer
        tcBuffer = tcBuffer + LEFT(lcReadBuffer, lnBytesRead)
        tnBufferSize = tnBufferSize + lnBytesRead
        lnBufferReads = lnBufferReads + 1
        = OnFTPBufferUpdate("Download",tnBufferSize,lnBufferReads, ;
                            @lcReadBuffer)
    ENDIF
    IF glCancelFTP
        tcBuffer = "Error: Download canceled"
        tnBufferSize = LEN(tcBuffer)
        gcErrorMsg = "Download canceled by user"
        gnError = -1
        EXIT
    ENDIF
    IF (lnRetVal = 1 AND lnBytesRead = 0) OR (lnRetVal = 0)
        EXIT
    ENDIF
ENDDO
lnBufferSize = tnBufferSize
IF gnError = 0
    = OnFTPBufferUpdate("Download",0,-1,"")
ENDIF

*** Write out the file to disk
lnHandle=FCREATE(lcTargetFile)
IF lnHandle=-1
    gnError = -2
    gcErrorMsg = "Can not create file."
    RETURN gnError
ENDIF
lnRetVal=FWRITE(lnHandle,tcBuffer)
*IF lnRetVal=0
*    gnError = -3
*    gcErrorMsg = "Can not write file."
*    = FCLOSE(lnHandle)
*    RETURN gnError
*ENDIF
IF !FCLOSE(lnHandle)
    gnError = -4
    gcErrorMsg = "Can not close file."
    RETURN gnError
ENDIF

RETURN gnError

*-----------------------------------------------------------------------------*
FUNCTION FTP_SendFileEx
LPARAMETER lcSourceFile, lcTargetFile
LOCAL lhFile, lnRetVal, lnBytesRead, lnBufferReads, lcWriteBuffer, hFTPFile

DECLARE INTEGER FtpOpenFile ;
    IN WININET.DLL ;
    INTEGER hIPSession,;
    STRING @lpszFileName,;
    INTEGER dwAcessFlags,;
    INTEGER dwServiceFlags,;
    INTEGER dwContext

DECLARE INTEGER InternetWriteFile ;
    IN WININET.DLL ;
    INTEGER hFTPHandle,;
    STRING lcBuffer,;
    INTEGER cbBuffer,;
    INTEGER @cbBuffer

hFTPFile = FtpOpenFile(ghFTPSession,lcTargetFile,;
                       GENERIC_WRITE,;
                       INTERNET_FLAG_RELOAD + FTP_TRANSFER_TYPE_BINARY,0)
IF hFTPFile = 0
    gnError = GetLastError()
    gcErrorMsg = GetSystemErrorMsg()
    RETURN gnError
ENDIF

*** Read the file from disk
lhFile = FOPEN(lcSourceFile)
IF lhFile = -1
    gcErrorMsg = "Source file doesn't exist or is in use..."
    gnError = 1
    RETURN gnError
ENDIF

gnError = 0
gcErrorMsg = ""
tnBufferSize = 0
lnBufferReads = 0
DO WHILE .T.
    *** Read one chunk at a time
    lcWriteBuffer = FRead(lhFile,gnFTPWorkBufferSize)
    IF LEN(lcWriteBuffer) = 0
        = OnFTPBufferUpdate("Upload",0,-1,"")
        EXIT
    ENDIF

    *** And write out each chunk
    lnSize=LEN(lcWriteBuffer)
    lnBytesRead = 0
    lnRetval=InternetWriteFile(hFTPFile,;
        lcWriteBuffer,;
        lnSize,;
        @lnBytesRead)

    IF lnRetVal = 1 AND lnBytesRead > 0
        *** Update the input parameters - result buffer and size of buffer
        tnBufferSize = tnBufferSize + lnBytesRead
        lnBufferReads = lnBufferReads + 1
        = OnFTPBufferUpdate("Upload", tnBufferSize,lnBufferReads,"")
    ENDIF
    IF glCancelFTP
        gcErrorMsg = "Upload canceled by user"
        gnError = -1
        EXIT
    ENDIF
    IF (lnRetVal = 1 AND lnBytesRead = 0) OR (lnRetVal = 0)
        EXIT
    ENDIF
ENDDO

= FCLOSE(lhFile)
= InternetCloseHandle(ghFTPSession)

RETURN gnError

*-----------------------------------------------------------------------------*
FUNCTION OnFTPBufferUpdate
LPARAMETERS lcUpDownLoad, lnBytesXfered,lnBufferReads,lcCurrentChunk

DO CASE
    CASE lnBufferReads > 0
        wait window lcUpDownLoad + "ed: " + STR(lnBytesXfered)+ ;
            " bytes (Alt-X to cancel)" nowait
    CASE lnBufferReads = -1
        wait window "FTP transfer finished..." timeout 2
ENDCASE
RETURN

*-----------------------------------------------------------------------------*
FUNCTION GetLastInternetError
LPARAMETERS lnError

lnError=IIF(type("lnError")="N",lnError,gnError)

DECLARE INTEGER InternetGetLastResponseInfo ;
    IN WININET.DLL ;
    INTEGER @lpdwError,;
    STRING @lpszBuffer,;
    INTEGER @lpcbSize

lcErrorMsg=SPACE(1024)
lnSize=LEN(lcErrorMsg)

=InterNetGetLastResponseInfo(@lnError,@lcErrorMsg,@lnSize)

IF lnSize < 2
RETURN ""
ENDIF

RETURN SUBSTR(lcErrorMsg,1,lnSize)

*-----------------------------------------------------------------------------*
FUNCTION GetSystemErrorMsg
LPARAMETERS lnErrorNo, llAPI
LOCAL szMsgBuffer,lnSize

lnErrorNo=IIF(type("lnErrorNo")="N",lnErrorNo,gnError)

IF lnErrorNo = ERROR_INTERNET_EXTENDED_ERROR
RETURN GetLastInternetError()
ENDIF

szMsgBuffer=SPACE(500)
*!* DECLARE INTEGER FormatMessage ;
*!* IN WIN32API ;

DECLARE INTEGER FormatMessage ;
IN KERNEL32.DLL ;
INTEGER dwFlags ,;
INTEGER lpvSource,;
INTEGER dwMsgId,;
INTEGER dwLangId,;
STRING @lpBuffer,;
INTEGER nSize,;
INTEGER Arguments

*!* DECLARE INTEGER GetModuleHandle ;
*!* IN WIN32API ;
*!* STRING

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

*-----------------------------------------------------------------------------*
PROCEDURE WinInetSetTimeout
LPARAMETERS 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)

RETURN

*** End of program.



----
欢迎光临良友程序库:http://0d0a.126.com http://f12.my163.com,免费提供我的各种Source Code

兄弟我抛出几块砖,有玉的赶紧亮出来啊!
 

[关闭][返回]