Dim filenam,newfileloc As String
Dim ftplo,oldf As String
Dim newname As String
ftplo= "PRquotations"
oldf=Args(0)
Dim Val2 As String = Date.now.Tooadate
filenam=ProjectPath & "tempfile\zipfs\" & Val2 & ".zip"
Dim ftp1 As New FtpClient
ftp1.utf8=True
Dim madr As DataRow
madr=DataTables("Mailinfo").SQLFind("FTPUSER is not null and FTPHOST is not null and FTPPASSWORD is not null")
If madr IsNot Nothing Then
ftp1.Host=madr("FTPHOST")
ftp1.Account = madr("FTPUSER")
ftp1.Password =madr("FTPPASSWORD")
ftp1.utf8=True
If ftp1.Connected = False '如果FTP没有连接
If ftp1.Connect=False Then '连接FTP
Messagebox.show("连接FTP失败!检查密码和账户信息","提示",MessageBoxButtons.OK,MessageBoxIcon.Information)
Return Nothing
End If
End If
Else
MessageBox.Show("FTP信息缺失,请检查FTP设置")
Return Nothing
End If
If ftplo<>"" Then
Dim dlg As New OpenFileDialog
dlg.MultiSelect = False
Dim fileToZip As String
If dlg.ShowDialog =DialogResult.OK Then
If oldf<>"" Then
If ftp1.FileExists(oldf) Then '''删除旧文件
ftp1.DeleteFile(oldf)
End If
End If
fileToZip = dlg.FileName
Dim th1 As Threading.Thread
Dim th2 As Threading.Thread
'Vars("loadingtext")="压缩上传附件中,请等待...."
th1 = New Threading.Thread(AddressOf setA)
th2 = New Threading.Thread(AddressOf setB)
th1.Start()
Dim sdt As Date = Date.Now
Dim ifo As new FileInfo(fileToZip)
If ifo.length > 6940032 Then
th2.Start()
MessageBox.Show("上传文件超过6Mb.请压缩或分为2个报价单上传.") 当我选择超过体积的文件后，这里报错，function正确返回空值。
Return Nothing
End If
newname = ftplo & "\" & Val2 & ".zip"
Do While ftp1.FileExists(newname)
Val2 = Date.now.Tooadate
filenam=ProjectPath & "tempfile\zipfs\" & Val2 & ".zip"
newname = ftplo & "\" & Val2 & ".zip"
Loop
''''''''=============
Dim zipedFile As String = filenam
Using fs As io.FileStream = io.File.OpenRead(fileToZip)
Dim buffer As Byte() = New Byte(fs.Length - 1) {}
fs.Read(buffer, 0, buffer.Length)
fs.Close()
Using ZipFile As io.FileStream = io.File.Create(zipedFile)
Using ZipStream As ICSharpCode.SharpZipLib.zip.ZipOutputStream = New ICSharpCode.SharpZipLib.zip.ZipOutputStream(ZipFile)
Dim fileName As String = fileToZip.SubString(fileToZip.LastIndexOf("\") + 1)
Dim ZipEntry = New ICSharpCode.SharpZipLib.zip.ZipEntry(fileName)
ZipStream.PutNextEntry(ZipEntry)
ZipStream.SetLevel(7)
ZipStream.Write(buffer, 0, buffer.Length)
ZipStream.Finish()
ZipStream.Close()
End Using
End Using
End Using
'''''''''''=================
newname =FileSys.GetName(filenam)
newname = ftplo & "\" & newname
If ftp1.DirExists(ftplo)=False Then
ftp1.MakeDir(ftplo)
End If
If ftp1.Upload(filenam,newname) = True Then
If oldf<>"" Then
If ftp1.FileExists(oldf) Then '''删除旧文件
If ftp1.DeleteFile(oldf) = True Then
'MessageBox.Show("新文件上传完成!旧文件删除成功") 但是原先在FTP里面的老文件还是被删除了，为啥？
End If
End If
Else
'Messagebox.show("上传完成!","提示",MessageBoxButtons.OK,MessageBoxIcon.Information)
End If
Else
While Date.Now < sdt.AddSeconds(0.3)
Application.DoEvents
End While
th2.Start()
Messagebox.show("上传失败!","提示",MessageBoxButtons.OK,MessageBoxIcon.Information)
End If
ftp1.close
End If
End If
Return newname
加好友 
发短信
Post By：2020/4/3 11:17:00 [只看该作者]
