clsftpload.cls

VB税控的源代码 主要用于地方税务局的税控引用 有完整的控件和代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFtpLoad"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private mlOpenHandle As Long
Private mlConnectionHandle As Long
Private fso As New FileSystemObject
Private dwType As Long

'**********************************************************************************
'描述：连接FTP服务器，并把FTP服务器上(Get)下载一个文件到把定路径
'参数： 输入：
'                   vsFTPIPAdress      IP地址
'                   vsUid              用户名
'                   vsPwd              密码
'                   vsLocalFile        需上传的文件名及路径信息
'                   vsFtpFile          保存到FTP上的文件名
'                   vsFtpPath          FTP的绝对中径名
'编码/修改：
'   1.苏江  2002.01.25       创建
'**********************************************************************************
Public Function bConnectFtp(vsFTPIPAdress As String, _
                             vsUid As String, _
                             vsPwd As String, _
                             vsLocalFile As String, _
                             vsFtpFile As String, _
                             vsFtpPath As String) As Boolean
On Error GoTo ErrHandle
    Dim site As FtpInfo
    Dim bRet As Boolean
    
'    Dim clsPass As New ClsGetId
    
    site.FtpIP = vsFTPIPAdress
    site.UID = vsUid
    site.PWD = vsPwd
    
    bConnectFtp = False
    
    vsFtpFile = fso.GetFileName(vsFtpFile)
    If fso.FileExists(vsLocalFile) = False Then
        err.Raise vbObjectError, "UpLoadOneFile", "要上载的文件不存在！"
    End If
    
    mlOpenHandle = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, _
            vbNullString, 0)
    If mlOpenHandle = 0 Then Exit Function
    
    mlConnectionHandle = InternetConnect(mlOpenHandle, site.FtpIP, INTERNET_INVALID_PORT_NUMBER, _
            site.UID, site.PWD, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
    
    If mlConnectionHandle = 0 Then Exit Function
    
    vsFtpPath = CheckPath(vsFtpPath)
    FTPChangeDir vsFtpPath, True
    
    bRet = FtpPutFile(mlConnectionHandle, vsLocalFile, vsFtpFile, dwType, 0)
    
    bConnectFtp = True
    Exit Function
ErrHandle:

End Function

'********************************************************************************
'描述：检查路径是否合法
'备注：目录只检查是否有根路径信息
'********************************************************************************
Private Function CheckPath(ByVal vsPath As String) As String
    'Dim sTemp As String
    'sTemp = Mid(vsPath, 1, 1)
    vsPath = Replace(vsPath, "\", "/")
    
    If Right(vsPath, 1) = "/" Then vsPath = Left(vsPath, Len(vsPath) - 1)
    
    CheckPath = vsPath
End Function

'**********************************************************************************
'描述：改变FTP当前目录
'参数：输入：   pszDir      指定的路径
'                     bUpload   是否是上传是调用
'说明：上传时，如果路径不存在，则需建立
'**********************************************************************************

Private Sub FTPChangeDir(pszDir As String, Optional bUpload As Boolean = False)
    Dim bRet As Boolean
    
    If pszDir = "" Then Exit Sub
    
    bRet = FtpSetCurrentDirectory(mlConnectionHandle, pszDir)
    
    If bRet = False Then
        If bUpload Then
            BuildFtpFolder pszDir                                                                                             '建立上传文件需要的目录
'        Else
'            ErrorOut Err.LastDllError, "FTPChangeDir"
        End If
    End If

End Sub

'**********************************************************************************
'描述：建立FTP目录
'参数： 输入：  vsPath              要建立的绝对路径
'          输出：  BuildFtpFolder    是否成功
'说明：建立目录后，将FTP的当前目录设置为刚建立的目录
'**********************************************************************************
Private Function BuildFtpFolder(ByVal vsPath As String) As Boolean
    Dim sDir() As String
    Dim iPos As Integer
    Dim sCurrentDir As String
    Dim bRet As Boolean
    Dim lLastError As Long
    Dim bPathHasExist As Boolean
    
    sDir = Split(vsPath, "/")
                        
    bPathHasExist = True
                        
    For iPos = LBound(sDir) To UBound(sDir)
            
        sCurrentDir = IIf(sCurrentDir = "", sDir(iPos), sCurrentDir & "/" & sDir(iPos))

        If sCurrentDir <> "" Then
            If FtpSetCurrentDirectory(mlConnectionHandle, "/" + sCurrentDir) = False Then
    
                If err.LastDllError <> 1 Then
                    bRet = FtpCreateDirectory(mlConnectionHandle, sDir(iPos))
                    FtpSetCurrentDirectory mlConnectionHandle, sDir(iPos)
                    If bRet = False Then
                        bRet = FtpSetCurrentDirectory(mlConnectionHandle, vsPath)                                            '可能是有异步错误，如果能进入刚需建立的目录则认为已成功
                        If bRet = False Then
                            err.Raise vbObjectError, "BuildFtpFolder", "不能建立目录：“" & _
                                                                         sCurrentDir & "”"
                        Else
                            BuildFtpFolder = True
                            Exit Function
                        End If
                    End If
                End If
            End If
        End If
    Next iPos
            
    BuildFtpFolder = True
    
End Function