modftpoperation.bas

1、以DLL形式提供医生工作站 2、 根据【检查项目】

Attribute VB_Name = "modFtpOperation"
Option Explicit



Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0                     '// use registry configuration
Public Const INTERNET_OPEN_TYPE_DIRECT = 1                        '// direct to net
Public Const INTERNET_OPEN_TYPE_PROXY = 3                       '  // via named proxy
Public Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4  ' // prevent using java/script/INS


Public Const INTERNET_SERVICE_URL = 0
Public Const INTERNET_SERVICE_FTP = 1
Public Const INTERNET_SERVICE_GOPHER = 2
Public Const INTERNET_SERVICE_HTTP = 3


Public Const INTERNET_DEFAULT_FTP_PORT = 21

Public Const INTERNET_DEFAULT_FTP_USER_NAME = "test"
Public Const INTERNET_DEFAULT_FTP_PASSWORD = "test"


Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type


Public Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

Public Declare Function GetLastError Lib "Kernel32.dll" () As Integer

Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal LAccessType As Long, ByVal sProxyName As String, ByVal SProxyBypass As String, ByVal lFlags As Long) As Long

Public Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long

Public Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

Public Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

Public Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean

Public Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExsiting As String, ByVal lpszNew As String) As Boolean

Public Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

Public Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long

Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFndData As WIN32_FIND_DATA) As Long




Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long











'===从FTP下载文件=========================================================================
'strFtpIp:FTP服务器地址
'strPort:FTP服务器端口
'strUserName：FTP用户名
'strPassword：FTP用户密码
'strLocalFilePath：待保存的本地文件路径
'strRemFilePath：要下载的文件----FTP服务器上
Public Function GetFileFromFtp(ByVal strFtpIp As String, ByVal nPort As Long, ByVal strUserName As String, ByVal strPassword As String, ByVal strLocalFilePath As String, ByVal strRemFilePath As String) As Boolean
    On Error GoTo ErrHandler
    
    Const DEFAULT_FTP_IP = "127.0.0.1"
    Const DEFAULT_FTP_PORT = "21"
    Const DEFAULT_USERNAME = "anonymous"
    Const DEFAULT_PASSWORD = "[e-mail]"
    Const DEFAULT_LOCAL_FILE = "test.txt"
    
    Dim lnginet As Long
    Dim lnginetconn As Long
    
    Dim myUserName As String
    Dim myPassword As String
    If Trim(strFtpIp) = "" Then
        MsgBox "请指定FTP服务器地址!", vbExclamation, "提示"
        GetFileFromFtp = False
        Exit Function
    End If
    
    If Trim(strLocalFilePath) = "" Then
        MsgBox "请指定本地文件名!", vbExclamation, "提示"
        GetFileFromFtp = False
        Exit Function
    End If
    
    
    If Trim(strRemFilePath) = "" Then
        MsgBox "请指定要下载的文件名!", vbExclamation, "提示"
        GetFileFromFtp = False
        Exit Function
    End If
    
    
    
    If nPort < 0 Then
        nPort = INTERNET_DEFAULT_FTP_PORT
    End If
    If Trim(strUserName) = "" Then
        myUserName = DEFAULT_USERNAME
    Else
        myUserName = strUserName
    End If
    
    If Trim(strPassword) = "" Then
        myPassword = DEFAULT_PASSWORD
    Else
        myPassword = strPassword
    End If
    
    '====开始下载================================================
    Dim blnRC As Boolean
    
    lnginet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
        vbNullString, vbNullString, 0&)

    If lnginet = 0 Then
        Dim nErrNum As Integer
        nErrNum = GetLastError()
        'MsgBox "FTP连接创建失败, 错误号:" + CStr(nErrNum), vbExclamation, "提示"
        InternetCloseHandle lnginet
        GetFileFromFtp = False
        Exit Function
    Else
        lnginetconn = InternetConnect(lnginet, strFtpIp, nPort, _
            strUserName, strPassword, INTERNET_SERVICE_FTP, 0, 0)
        If lnginetconn = 0 Then
            'MsgBox "FTP服务器连接错误或用户名/密码错误!", vbExclamation, "提示"
            InternetCloseHandle lnginetconn
            InternetCloseHandle lnginet
            GetFileFromFtp = False
            Exit Function
        Else
            blnRC = FtpGetFile(lnginetconn, strRemFilePath, strLocalFilePath, 0, 0, 1, 0)
            If False = blnRC Then
                GetFileFromFtp = False
                Exit Function
            End If
            InternetCloseHandle lnginetconn
        End If
        
        InternetCloseHandle lnginet
    End If


    GetFileFromFtp = True
    Exit Function
ErrHandler:
    GetFileFromFtp = False
End Function






'===向FTP上传文件=========================================================================
'strFtpIp:FTP服务器地址
'strPort:FTP服务器端口
'strUserName：FTP用户名
'strPassword：FTP用户密码
'strLocalFilePath：要上传的本地文件路径
'strRemFilePath：要保存的文件----FTP服务器上
Public Function PutFileToFtp(ByVal strFtpIp As String, ByVal nPort As Long, ByVal strUserName As String, _
    ByVal strPassword As String, ByVal strLocalFilePath As String, ByVal strRemFilePath As String) As Boolean
    On Error GoTo ErrHandler
    
    Const DEFAULT_FTP_IP = "127.0.0.1"
    Const DEFAULT_FTP_PORT = "21"
    Const DEFAULT_USERNAME = "anonymous"
    Const DEFAULT_PASSWORD = "[e-mail]"
    Const DEFAULT_LOCAL_FILE = "test.txt"
    
    Dim lnginet As Long
    Dim lnginetconn As Long
    
    Dim myUserName As String
    Dim myPassword As String
    If Trim(strFtpIp) = "" Then
        MsgBox "请指定FTP服务器地址!", vbExclamation, "提示"
        PutFileToFtp = False
        Exit Function
    End If
    
    If Trim(strLocalFilePath) = "" Then
        MsgBox "请指定本地文件名!", vbExclamation, "提示"
        PutFileToFtp = False
        Exit Function
    End If
    
    
    If Trim(strRemFilePath) = "" Then
        MsgBox "请指定要下载的文件名!", vbExclamation, "提示"
        PutFileToFtp = False
        Exit Function
    End If
    
    
    
    If nPort < 0 Then
        nPort = INTERNET_DEFAULT_FTP_PORT
    End If
    If Trim(strUserName) = "" Then
        myUserName = DEFAULT_USERNAME
    Else
        myUserName = strUserName
    End If
    
    If Trim(strPassword) = "" Then
        myPassword = DEFAULT_PASSWORD
    Else
        myPassword = strPassword
    End If
    
    '====开始上传================================================
    Dim blnRC As Boolean
    
    lnginet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
        vbNullString, vbNullString, 0&)

    If lnginet = 0 Then
        Dim nErrNum As Integer
        nErrNum = GetLastError()
        MsgBox "FTP连接创建失败, 错误号:" + CStr(nErrNum), vbExclamation, "提示"
        InternetCloseHandle lnginet
        PutFileToFtp = False
        Exit Function
    Else
        lnginetconn = InternetConnect(lnginet, strFtpIp, nPort, _
            strUserName, strPassword, INTERNET_SERVICE_FTP, 0, 0)
        If lnginetconn = 0 Then
            MsgBox "FTP服务器连接错误或用户名/密码错误!", vbExclamation, "提示"
            InternetCloseHandle lnginetconn
            InternetCloseHandle lnginet
            PutFileToFtp = False
            Exit Function
        Else
            blnRC = FtpPutFile(lnginetconn, strLocalFilePath, strRemFilePath, 0, 0)
            If False = blnRC Then
                PutFileToFtp = False
                Exit Function
            End If
            InternetCloseHandle lnginetconn
        End If
        
        InternetCloseHandle lnginet
    End If


    PutFileToFtp = True
    Exit Function
ErrHandler:
    PutFileToFtp = False
End Function

'创建文件目录
'创建之前首先判断目录是否存在，如果存在则不创建返回TRUE
'strFtpIp:FTP服务器地址
'nPort:FTP服务器端口
'strUserName：FTP用户名
'strPassword：FTP用户密码
'strFilePath：要创建的文件路径
Public Function CreateFTPDirectory(ByVal strFtpIp As String, ByVal nPort As Long, _
ByVal strUserName As String, ByVal strPassword As String, ByVal strFilePath As String) As Boolean
On Error GoTo ErrHandler
    Const DEFAULT_FTP_IP = "127.0.0.1"
    Const DEFAULT_FTP_PORT = "21"
    Const DEFAULT_USERNAME = "anonymous"
    Const DEFAULT_PASSWORD = "[e-mail]"
    Const DEFAULT_LOCAL_FILE = "test.txt"
    
    Dim lnginet As Long
    Dim lnginetconn As Long
    
    Dim myUserName As String
    Dim myPassword As String
    If Trim(strFtpIp) = "" Then
        MsgBox "请指定FTP服务器地址!", vbExclamation, "提示"
        CreateFTPDirectory = False
        Exit Function
    End If
    
    If Trim(strFilePath) = "" Then
        MsgBox "请指定路径名!", vbExclamation, "提示"
        CreateFTPDirectory = False
        Exit Function
    End If
    
    
    If nPort < 0 Then
        nPort = INTERNET_DEFAULT_FTP_PORT
    End If
    If Trim(strUserName) = "" Then
        myUserName = DEFAULT_USERNAME
    Else
        myUserName = strUserName
    End If
    
    If Trim(strPassword) = "" Then
        myPassword = DEFAULT_PASSWORD
    Else
        myPassword = strPassword
    End If
    
    Dim blnRC As Boolean
    
    lnginet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
        vbNullString, vbNullString, 0&)

    If lnginet = 0 Then
        Dim nErrNum As Integer
        nErrNum = GetLastError()
        'MsgBox "FTP连接创建失败, 错误号:" + CStr(nErrNum), vbExclamation, "提示"
        InternetCloseHandle lnginet
        CreateFTPDirectory = False
        Exit Function
    Else
        lnginetconn = InternetConnect(lnginet, strFtpIp, nPort, _
            strUserName, strPassword, INTERNET_SERVICE_FTP, 0, 0)
        If lnginetconn = 0 Then
            'MsgBox "FTP服务器连接错误或用户名/密码错误!", vbExclamation, "提示"
            InternetCloseHandle lnginetconn
            InternetCloseHandle lnginet
            CreateFTPDirectory = False
            Exit Function
        Else
            Dim wfd As WIN32_FIND_DATA
            blnRC = FtpFindFirstFile(lnginetconn, strFilePath, wfd, 0, 0)
            If blnRC = True Then
                CreateFTPDirectory = True
                Exit Function
            End If
            blnRC = FtpCreateDirectory(lnginetconn, strFilePath)
            If False = blnRC Then
                CreateFTPDirectory = False
                Exit Function
            End If
            InternetCloseHandle lnginetconn
        End If
        
        InternetCloseHandle lnginet
    End If
    CreateFTPDirectory = True
    
    Exit Function
ErrHandler:
    MsgBox Err.Description, vbExclamation, "tishi"
    CreateFTPDirectory = False
End Function