Domino LotusScript代码实现Ftp上传、下载



【背景】

随意应用系统使用，会有越来越多与第三方系统集成的需求，需要把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