clsftp.cls

本系统可用于医院和专业体检中心的健康体检管理

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'调用方式：
'FtpGet "210.26.53.171", "www", "wwwwww", "210.26.53.171", "运行环境.txt", "c:"
Option Explicit

Private 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
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private 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
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private 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
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean

Private Const scUserAgent = "vb wininet"

Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMBER = 0

Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
                
Private Const ERROR_INTERNET_EXTENDED_ERROR = 12003

Private Const INTERNET_SERVICE_FTP = 1

Private Const INTERNET_FLAG_RELOAD = &H80000000

Private hOpen As Long, hConnection As Long

Private Const txtProxy = ""
Private Const chkPassive = 1

'打开ftp连接
Public Sub InternetOpening()
    If Len(txtProxy) <> 0 Then
        hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY, txtProxy, vbNullString, 0)
    Else
        hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    End If
    If hOpen = 0 Then ErrorOut Err.LastDllError, "InternetOpen"
End Sub

'关闭ftp连接
Public Sub InternetClose()
    If hConnection <> 0 Then InternetCloseHandle hConnection
    If hOpen <> 0 Then InternetCloseHandle hOpen
    hConnection = 0
    hOpen = 0
End Sub

'建立ftp连接
Public Function FtpConnect(ftpServer As String, ftpUser As String, ftpPass As String) As Boolean
    FtpConnect = False
    
    Call InternetOpening
    
    If hOpen <> 0 Then
        
        Dim nFlag As Long
        If chkPassive = 1 Then
            nFlag = INTERNET_FLAG_PASSIVE
        Else
            nFlag = 0
        End If
        hConnection = InternetConnect(hOpen, ftpServer, INTERNET_INVALID_PORT_NUMBER, ftpUser, ftpPass, INTERNET_SERVICE_FTP, nFlag, 0)
        If hConnection = 0 Then
'            ErrorOut Err.LastDllError, "InternetConnect"
        Else
            FtpConnect = True
       End If
    End If
End Function

'获取ftp上的文件
Public Function FTPGET(ByVal ftpServer As String, ByVal ftpUser As String, ByVal ftpPass As String, ByVal szDirRemote As String, ByVal szFileRemote As String, ByVal szDirLocal As String, Optional ByVal szFileLocal As String) As Boolean
    Dim bRet As Boolean
    
    FTPGET = False
    
    Call FtpConnect(ftpServer, ftpUser, ftpPass)
    
    rcd szDirRemote, ftpServer
    If szFileLocal = "" Then
        '如果未传递本地文件名，则默认为远程文件名
        szFileLocal = szFileRemote
    Else
        '可以检测后缀名是否一致
    End If
    bRet = FtpGetFile(hConnection, szFileRemote, szDirLocal & szFileLocal, False, INTERNET_FLAG_RELOAD, FTP_TRANSFER_TYPE_BINARY, 0)
        
    DoEvents
    Call InternetClose

    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpGetFile"
    Else
        FTPGET = True
    End If
End Function

'获取ftp错误信息
Public Sub rcd(pszDir As String, ftpServer As String)
    Dim sPathFromRoot As String
    Dim bRet As Boolean
    
    If InStr(1, pszDir, ftpServer) Then
        sPathFromRoot = Mid(pszDir, Len(ftpServer) + 1, Len(pszDir) - Len(ftpServer))
    Else
        sPathFromRoot = pszDir
    End If
    If sPathFromRoot = "" Then sPathFromRoot = "/"
    
    bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot)
    
'    If bRet = False Then ErrorOut Err.LastDllError, "rcd"
End Sub

'显示ftp错误
Public Function ErrorOut(dError As Long, szCallFunction As String)
    Dim dwIntError As Long, dwLength As Long
    Dim strBuffer As String
    
    If dError = ERROR_INTERNET_EXTENDED_ERROR Then
        InternetGetLastResponseInfo dwIntError, vbNullString, dwLength
        strBuffer = String(dwLength + 1, 0)
        InternetGetLastResponseInfo dwIntError, strBuffer, dwLength
        
        MsgBox szCallFunction & " Extd Err: " & dwIntError & " " & strBuffer
        
    End If
    If MsgBox(szCallFunction & " Err: " & dError & _
        vbCrLf & "要关闭ftp连接吗?", vbQuestion + vbYesNo) = vbYes Then
        If hConnection Then InternetCloseHandle hConnection
        
        If hOpen Then InternetCloseHandle hOpen
        
        hConnection = 0
        hOpen = 0
    End If
End Function

'加密
Public Function Encrypt(ByVal strInput As String) As String
    Dim i As Long
    Dim strRet As String
    Dim strTemp As String
    
    If strInput = "" Then Exit Function
    
    strInput = StrConv(strInput, vbUnicode)
    For i = 1 To Len(strInput)
        If Len(Hex(Asc(Mid(strInput, i, 1)))) = 1 Then
            strTemp = strTemp & "0" & Hex(Asc(Mid(strInput, i, 1)))
        Else
            strTemp = strTemp & Hex(Asc(Mid(strInput, i, 1)))
        End If
    Next
    
    For i = Len(strTemp) To 1 Step -1
        strRet = strRet & Mid(strTemp, i, 1)
    Next
    
    Encrypt = strRet
End Function

'解密
Public Function Decrypt(ByVal strInput As String) As String
    Dim i As Long
    Dim strRet As String
    Dim strTemp As String
    
    If strInput = "" Then Exit Function
    
    For i = Len(strInput) To 1 Step -1
        strTemp = strTemp & Mid(strInput, i, 1)
    Next
    
    For i = 1 To Int(Len(strTemp) / 2)
        strRet = strRet & Chr(Val("&H" & Mid(strTemp, i * 2 - 1, 2)))
    Next
    
    strRet = StrConv(strRet, vbFromUnicode)
    
    Decrypt = strRet
End Function