很久以前做的一部分代码~给你参考看看~
程序代码：
Option Explicit
Private Const PROGRESS_CANCEL = 1
Private Const PROGRESS_CONTINUE = 0
Private Const PROGRESS_QUIET = 3
Private Const PROGRESS_STOP = 2
Private Const COPY_FILE_FAIL_IF_EXISTS = &H1
Private Const COPY_FILE_RESTARTABLE = &H2
Private Const MOVEFILE_REPLACE_EXISTING = &H1 '相同的Volume下移动文件用
Private Const MOVEFILE_COPY_ALLOWED = &H2 '不同的Volume下移动文件用
'// 此 API 在 WIN9X 下不能使用
Private Declare Function CopyFileEx Lib "kernel32.dll" Alias "CopyFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal lpProgressRoutine As Long, lpData As Any, ByRef pbCancel As Long, ByVal dwCopyFlags As Long) As Long
'Private Declare Function CopyFileEx Lib "kernel32.dll" Alias "CopyFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByRef lpProgressRoutine As PROGRESS_ROUTINE, lpData As Any, ByRef pbCancel As Long, ByVal dwCopyFlags As Long) As Long
'Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
Private Declare Function MoveFileWithProgress Lib "kernel32.dll" Alias "MoveFileWithProgressA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByRef lpProgressRoutine As Long, lpData As Any, ByVal dwFlags As Long) As Long
'Private Declare Function MoveFileWithProgress Lib "kernel32.dll" Alias "MoveFileWithProgressA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByRef lpProgressRoutine As PROGRESS_ROUTINE, lpData As Any, ByVal dwFlags As Long) As Long
Private mlngCancel As Long
Private mprgState As Object
Private mlblState As Object
Public Function CopyProgressRoutine(ByVal TotalFileSize As Currency, _
ByVal TotalBytesTransferred As Currency, _
ByVal StreamSize As Currency, _
ByVal StreamBytesTransferred As Currency, _
ByVal dwStreamNumber As Long, _
ByVal dwCallbackReason As Long, _
ByVal hSourceFile As Long, _
ByVal hDestinationFile As Long, _
ByVal lpData As Long) As Long
'// 显示进度
mprgState.value = CLng((100 / TotalFileSize) * TotalBytesTransferred)
mlblState.Caption = "已完成: " & FormatPercent(mprgState.value / 100, 0)
'
DoEvents
'// 继续复制
CopyProgressRoutine = PROGRESS_CONTINUE
End Function
Public Function uCopyFile(ByVal strFrom As String, ByVal strTo As String, ByRef prgState As Object, ByRef lblState As Object) As Boolean
Dim lngReturn As Long
Set mprgState = prgState
Set mlblState = lblState
'// 开始复制
lngReturn = CopyFileEx(strFrom, strTo, AddressOf CopyProgressRoutine, ByVal 0&, mlngCancel, COPY_FILE_RESTARTABLE)
If lngReturn = 0 Then
uCopyFile = False
Else
uCopyFile = True
End If
End Function
Public Function uMoveFile(ByVal strFrom As String, ByVal strTo As String, ByRef prgState As Object, ByRef lblState As Object) As Boolean
Dim lngReturn As Long
Set mprgState = prgState
Set mlblState = lblState
'// 开始移动
lngReturn = MoveFileWithProgress(strFrom, strTo, AddressOf CopyProgressRoutine, Null, MOVEFILE_COPY_ALLOWED)
If lngReturn = 0 Then
uMoveFile = False
Else
uMoveFile = True
End If
End Function
Public Function FTPCopy(ByVal Mode As Long, ByVal strFrom As String, ByVal strTo As String, ByRef prgState As Object, ByRef lblState As Object, vTransferMode As FtpTransferModes) As Boolean
Dim strFileName As String, TempString As String, TargetPath As String, TargetPath1 As String
Dim lStartPoint As Long
On Error GoTo ErrorHandling
ChangFolder = False: TargetPath = "/" & "On_line_Trigger"
If Mode = 0 Then
TargetPath1 = "Copy_log"
ElseIf Mode = 1 Then
TargetPath1 = "Backup_log"
End If
If Len(strFrom) = 0 Then
TempString = strFrom & " can't be Found ."
Call ErrorWriteBuff(strFrom, 0, "FTPCopy", Err.Number, Err.Description, TempString)
Exit Function
End If
strFileName = Mid$(strFrom, InStrRev(strFrom, "\") + 1)
If Len(LotNumber) > 0 Then
If ChangFolder = False Then
If frmMain.m_FtpConnection.SetCurrentDirectory(TargetPath) = True Then
If frmMain.m_FtpConnection.SetCurrentDirectory(TargetPath1) = True Then
If CreateLotNumber(Mode) = False Then
If frmMain.m_FtpConnection.CreateDirectory(LotNumber) = False Then
' TempString = "Can't create new directory." '& vbCrLf & vbCrLf & "Server response: " & frmMain.m_FtpConnection.GetLastServerResponse & ", , Can't create directory"
' Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
CreateLotNumber(Mode) = True
End If
End If
ChangFolder = frmMain.m_FtpConnection.SetCurrentDirectory(LotNumber)
Else
TempString = TargetPath & TargetPath1 & "/ Folder is Empty !"
Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
End If
Else
TempString = TargetPath & " not Found !"
Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
End If
End If
If ChangFolder = True Then
m_lFileSize = FileLen(strFrom)
m_strFile = strFileName
If frmMain.m_FtpConnection.UploadFile(strFrom, strFileName, vTransferMode, lStartPoint) = True Then
FTPCopy = True ': Debug.Print "vTransferMode = " & vTransferMode
Else
FTPCopy = False
TempString = "Can't upload file." & vbCrLf & vbCrLf & "Server response: " & frmMain.m_FtpConnection.GetLastServerResponse & ", , Can't upload file"
Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
End If
End If
End If
Exit Function
ErrorHandling:
FTPCopy = False: TempString = "FTPCopy Error"
Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
Resume Next
End Function
2016-12-24 12:13
