【背景】
随意应用系统使用,会有越来越多与第三方系统集成的需求,需要把Domino数据库的附件上传给第三方系统。附件的集成方式一般有:通过二进制流直接写入关系数据库中、通过FTP方式上传到指定Ftp服务器上。本文介绍采用Lotusscript代码方式实现Ftp上传、下载功能。
【要求】
系统:windows
linux平台我是通过java方式实现的,后面的文章进行分享,如果有LS linux平台的方式可分享给我。
【参考代码】
%REM
Library FTPUpDownLS
Created 2012-6-6 by admin/OACCP
Description: Comments for Library
%END REM
Option Public
Option Declare
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
'调用设置环境
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
'连接服务器
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
'上传函数
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
'下载函数
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
'创建文件夹目录
Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
'关闭
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
'创建文件夹
Function fnTestConnect(sIp As String, sUserName As String, sPassword As String) As Boolean
On Error GoTo errhandle
fnTestConnect = False
Dim hOpen As Long
Dim hConnection As Long
'Dim lul_dwflags As Long
Dim ls_parmf As String
Dim ls_parmt As String
Dim ls_text As String
Dim sLocalFilePath As String
'lul_dwflags = 8388608
ls_parmf = Space(0)
ls_parmt = Space(0)
ls_text = "ftp"
hOpen = InternetOpen(ls_text, 1, ls_parmf, ls_parmt, 0)
If hOpen <> 0 Then
hConnection = InternetConnect(hOpen, sIp, 0, sUserName, sPassword, 1, INTERNET_FLAG_PASSIVE, 0)
If hConnection <> 0 Then '连接正常
fnTestConnect = True
End If
End If
Exit Function
errhandle:
MsgBox "fnTestConnect执行出错,出错信息:," & Error & "出错行:" & CStr(Erl())
Exit Function
End Function
'FTP下载文件
Function DownLoadFile(sIp As String, sRemoteFileName As String, sLocalFileName As String, sUserName As String, sPassword As String)
On Error GoTo errhandle
Dim ret As Boolean
Dim hOpen As Long
Dim hConnection As Long
'Dim lul_dwflags As Long
Dim ls_parmf As String
Dim ls_parmt As String
Dim ls_text As String
'lul_dwflags = 8388608
ls_parmf = Space(0)
ls_parmt = Space(0)
ls_text = "ftp"
hOpen = InternetOpen(ls_text, 1, ls_parmf, ls_parmt, 0)
'hOpen = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If hOpen <> 0 Then
hConnection = InternetConnect(hOpen, sIp, 0, sUserName, sPassword, 1, INTERNET_FLAG_PASSIVE, 0)
If hConnection <> 0 Then '连接正常
ret = FtpGetFile(hConnection, sRemoteFileName, sLocalFileName, 0, 0, 1, 0)
DownLoadFile = ret
Else '无法连接
DownLoadFile = False
MsgBox "用户名或密码错误,或网络故障"'
End If
Else
DownLoadFile = False
End If
InternetCloseHandle hConnection
InternetCloseHandle hOpen
Exit Function
errhandle:
MsgBox "DownLoadFile执行出错,出错信息:," & Error & "出错行:" & CStr(Erl())
Exit Function
End Function
'创建文件夹
Function CreateFileDir(hConnections As Long,LocalFilePath As String) As Boolean
On Error GoTo errhandle
CreateFileDir = False
Dim vFilePath As Variant
Dim sFilePathName As String
Dim lReturn As Long
Dim i As Integer
'文件夹为空直接退出
If LocalFilePath = "" Then
CreateFileDir = True
Exit function
End If
'去掉右边的"\"
If Right(LocalFilePath,1)="\" Then
LocalFilePath = StrLeftBack(LocalFilePath,"\")
End If
'去掉左边的“\”
If Left(LocalFilePath,1)="\" Then
LocalFilePath = StrRight(LocalFilePath,"\")
End If
'文件夹为空直接退出
If LocalFilePath = "" Then
CreateFileDir = True
Exit Function
End If
'分拆生成目录
vFilePath = Split(LocalFilePath,"\")
For i=0 To UBound(vFilePath)
If i=0 Then
sFilePathName = vFilePath(0)
Else
sFilePathName = sFilePathName & "\" & vFilePath(i)
End If
'循环创建文件夹
lReturn = FtpCreateDirectory(hConnections, sFilePathName)
Next
CreateFileDir = True
Exit Function
errhandle:
MsgBox "CreateFileDir执行出错,出错信息:," & Error & "出错行:" & CStr(Erl())
Exit Function
End Function
'上传文件模块
Function UpLoadFile(sIp As String, sRemoteFileName As String, sLocalFileName As String, sUserName As String, sPassword As String) As Boolean
On Error GoTo errhandle
Dim ret As Boolean
Dim hOpen As Long
Dim hConnection As Long
'Dim lul_dwflags As Long
Dim ls_parmf As String
Dim ls_parmt As String
Dim ls_text As String
Dim sLocalFilePath As String
'lul_dwflags = 8388608
ls_parmf = Space(0)
ls_parmt = Space(0)
ls_text = "ftp"
hOpen = InternetOpen(ls_text, 1, ls_parmf, ls_parmt, 0)
'hOpen = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If hOpen <> 0 Then
hConnection = InternetConnect(hOpen, sIp, 0, sUserName, sPassword, 1, INTERNET_FLAG_PASSIVE, 0)
If hConnection <> 0 Then '连接正常
sLocalFilePath = StrLeftback(sRemoteFileName,"\")
'创建文件夹、上传文档
If CreateFileDir(hConnection,sLocalFilePath) Then
ret = FtpPutFile(hConnection, sLocalFileName, sRemoteFileName, 2, 0)
UpLoadFile = ret
End If
Else '无法连接
UpLoadFile = False
MsgBox "FTP用户名或密码错误,或网络故障"
End If
Else
UpLoadFile = False
End If
InternetCloseHandle hConnection
InternetCloseHandle hOpen
Exit function
errhandle:
MsgBox "UpLoadFile执行出错,出错信息:," & Error & "出错行:" & CStr(Erl())
Exit Function
End Function