回复 2楼 风吹过b
你说的大概就是StartProcess()的部分吧～之前写过旦是因为可用的功能太阳春了～就放弃了～贴上一部分代码来证明～
程序代码：
Public Function GetPCName() As String
Dim strComputerName As String
strComputerName = String(255, Chr$(0))
GetComputerName strComputerName, 255
GetPCName = Left(strComputerName, InStr(1, strComputerName, Chr$(0)) - 1)
End Function
Private Sub StartProcess()
Dim i As Integer, FileSize As Long, FileNum As Integer
Dim TempString As String, XMLFile As String, XMLFullFile As String, txtScript As String
Dim CompareStatus As Boolean
On Error GoTo ErrorHandling
CompareStatus = False
txtScript = App.Path & "\FTP.txt"
XMLFile = "Copy_" & Machine & "_" & Format(Now, "yyyymmdd") & ".xml"
XMLFullFile = LocalLogPath & XMLFile
With frmMain
For i = 0 To UBound(FileList)
Call ReFlashUI(i)
StartTime = Format(Now, "yyyymmddhhmmss"): FileSize = 0
.ProgressBar2.ToolTipText = "Copy " & FileList(i) & " To " & FTPData.FTPSite(0).ServerPath & " ~": FileNum = FreeFile
Open txtScript For Output As #FileNum
Print #FileNum, GetCode(0, FileList(i))
Close #FileNum
If Shell("CMD /k ftp -s:" & txtScript & " >>1.txt", vbHide) <> 0 Then 'Copy
.ProgressBar2.ToolTipText = "Move " & FileList(i) & " To Backup ~": FileNum = FreeFile
Open txtScript For Output As #FileNum
Print #FileNum, GetCode(1, FileList(i))
Close #FileNum
If Shell("CMD /k Move " & LocalFilePath & FileList(i) & " " & BackupFilePath & FileList(i) & ">>1.txt", vbHide) <> 0 Then 'Move
EndTime = Format(Now, "yyyymmddhhmmss")
Call CompareData(i, CompareStatus)
Call WriteXMLFile(i, XMLFullFile, FileSize, CompareStatus)
Else
TempString = "Move " & FileList(i) & " To Backup Error ~"
Call ErrorWriteBuff(FileList(i), i, "StartProcess", Err.Number, Err.Description, TempString)
End If
Else
TempString = "Copy " & FileList(i) & " To " & FTPData.FTPSite(0).ServerPath & " Error ~"
Call ErrorWriteBuff(FileList(i), i, "StartProcess", Err.Number, Err.Description, TempString)
End If
MyDoEvents (100)
Next i
.ProgressBar2.ToolTipText = "Copy " & XMLFile & " To " & FTPData.FTPSite(1).ServerPath & " ~": FileNum = FreeFile
Open txtScript For Output As #FileNum
Print #FileNum, GetCode(1, XMLFullFile)
Close #FileNum
If Shell("CMD /k ftp -s:" & txtScript & ">>1.txt", vbHide) <> 0 Then 'Copy
Shell "CMD /k Del " & txtScript, vbHide
Else
TempString = "FileCopy Error"
Call ErrorWriteBuff(FileList(i), i, "StartProcess", Err.Number, Err.Description, TempString)
End If
End With
Exit Sub
ErrorHandling:
TempString = "FileCopy Error"
Call ErrorWriteBuff(FileList(i), i, "StartProcess", Err.Number, Err.Description, TempString)
Resume Next
End Sub
Private Function GetCode(Mode As Integer, tmpFile As String) As String
Dim Temp() As String, TempString As String
Dim i As Integer
GetCode = "": TempString = ""
Temp = Split(LocalFilePath, "\")
For i = 0 To UBound(Temp) - 1
If i = 0 Then
TempString = TempString & vbCrLf & "lcd " & Temp(i) & "\" & " >>1.txt"
Else
TempString = TempString & vbCrLf & "lcd " & Temp(i) & "\" & " >>1.txt"
End If
Next i
If Mode = 0 Then
GetCode = "open " & FTPData.FTPSite(0).ServerPath & " 21" & vbCrLf & _
FTPData.FTPSite(0).UserName & vbCrLf & _
FTPData.FTPSite(0).UserPass & vbCrLf & _
"prompt" & vbCrLf & _
"ascii" & vbCrLf & _
"mkdir " & LotNumber & _
TempString & vbCrLf & _
"cd " & LotNumber & vbCrLf & _
"put " & tmpFile & vbCrLf & _
"bye" & vbCrLf
Else
GetCode = "open " & FTPData.FTPSite(0).ServerPath & " 21" & vbCrLf & _
FTPData.FTPSite(0).UserName & vbCrLf & _
FTPData.FTPSite(0).UserPass & vbCrLf & _
"prompt" & vbCrLf & _
"binary" & vbCrLf & _
"mkdir " & LotNumber & _
TempString & vbCrLf & _
"cd " & LotNumber & vbCrLf & _
"mput " & tmpFile & vbCrLf & _
"bye" & vbCrLf
End If
End Function
Private Sub CompareData(i As Integer, CompareStatus As Boolean)
Dim FileSize As Long
FileSize = FileLen(BackupFilePath & FileList(i))
If FileSize = ServerFileSize Then
CompareStatus = True
Else
CompareStatus = False
End If
End Sub
Private Sub WriteXMLFile(Findex As Integer, strFileName As String, FileSize As Long, CompareStatus As Boolean)
Dim FileNum As Integer, TempString As String
On Error GoTo ErrorHandling
FileNum = FreeFile
If IsFileExist(strFileName) = False Then
Open strFileName For Output As #FileNum
Print #FileNum, GetXMLData(Findex, FileSize, CompareStatus)
Close #FileNum
Else
Open strFileName For Append As #FileNum
Print #FileNum, GetXMLData(Findex, FileSize, CompareStatus)
Close #FileNum
End If
AllTime = CStr(CLng(AllTime) + CLng((CLng(EndTime) - CLng(StartTime))))
Exit Sub
ErrorHandling:
TempString = "Write XML Error"
Call ErrorWriteBuff(LocalFilePath & FileList(Findex), Findex, "WriteXMLFile", Err.Number, Err.Description, TempString)
Resume Next
End Sub
Private Function GetXMLData(i As Integer, FileSize As Long, CompareStatus As Boolean) As String
Dim Status As String, strVersion As String
strVersion = App.Major & "." & App.Minor & "." & App.Revision
Status = "": Status = IIf(CompareStatus = True, "PASS", "FAIL")
GetXMLData = "<DataLog>" & vbCrLf & _
" <JobVersion>" & strVersion & "</JovVersion>" & vbCrLf & _
" <LotNo>" & LotNumber & "</Lot No>" & vbCrLf & _
" <Tester>" & UCase(Machine) & "</Tester>" & vbCrLf & _
" <Path>" & LocalFilePath & "<\Path>" & vbCrLf & _
" <StartTime>" & StartTime & "</Start Time>" & vbCrLf & _
" <EndTime>" & EndTime & "</End Time>" & vbCrLf & _
" <FileName>" & FileList(i) & "</File Name>" & vbCrLf & _
" <FileSize>" & FileSize & "</File Size>" & vbCrLf & _
" <Status>" & Status & "</Status>" & vbCrLf & _
"</DataLog>" & vbCrLf
End Function
Public Sub WriteFiles(FileN As String)
Dim FileNum As Integer, i As Integer
Dim strFileName As String
If IsFolderExist(LOGSaveLocation) = False Then
MkDir (LOGSaveLocation)
End If
strFileName = LOGSaveLocation & FileN
FileNum = FreeFile
If IsFileExist(strFileName) = False Then
Open strFileName For Output As #FileNum
If ErrorCount > 0 Then
Print #FileNum, Format(Now) & "<<---------- Fail ---------->>"
For i = 0 To UBound(ErrorData)
Print #FileNum, ErrorData(i)
Next i
Else
Print #FileNum, Format(Now) & "<<---------- Pass ---------->>"
Print #FileNum, "Spend " & AllTime & " Seconds"
End If
Close #FileNum
Else
Open strFileName For Append As #FileNum
If ErrorCount > 0 Then
Print #FileNum, Format(Now) & "<<---------- Fail ---------->>"
For i = 0 To UBound(ErrorData)
Print #FileNum, ErrorData(i)
Next i
Else
Print #FileNum, Format(Now) & "<<---------- Pass ---------->>"
Print #FileNum, "Spend " & AllTime & " Seconds"
End If
Close #FileNum
End If
End Sub
Private Function MyDoEvents(Optional ByVal dwMilliseconds As Long = 1)
MyDoEvents = DoEvents()
Sleep dwMilliseconds
End Function
Private Sub ReFlashUI(Findex As Integer)
With frmMain
.LabFileCount.Caption = ""
.LabFileCount.Caption = Findex + 1 & " / " & UBound(FileList) + 1
.LabNowProgress.Caption = "處理第" & Findex + 1 & "個檔案"
.ProgressBar2.Value = (Findex / UBound(FileList)) * 100
.LabAccumulationPercent.Caption = .ProgressBar2.Value & "%"
End With
End Sub
Public Function IsFileExist(strFileName As String) As Boolean
Dim varFSO As Variant
Set varFSO = CreateObject("Scripting.FileSystemObject")
IsFileExist = varFSO.FileExists(strFileName)
Set varFSO = Nothing
End Function
Public Function IsFolderExist(strFolderName As String) As Boolean
Dim varFSO As Variant
Set varFSO = CreateObject("Scripting.FileSystemObject")
IsFolderExist = varFSO.FolderExists(strFolderName)
Set varFSO = Nothing
End Function
Private Function LoadLocalFile(strFolderName As String) As Integer
Dim varFSO As Variant, varFolder As Folder, varFile As File
Dim i As Integer, TempString As String
On Error GoTo ErrorHandling
Set varFSO = CreateObject("Scripting.FileSystemObject")
Set varFolder = varFSO.GetFolder(strFolderName)
For Each varFile In varFolder.Files
ReDim Preserve FileList(i)
FileList(i) = Trim(Mid(varFile, InStrRev(varFile, "\") + 1))
i = i + 1
Next
frmMain.LabFileCount.Caption = "0 / " & i
LoadLocalFile = i
Set varFSO = Nothing
Exit Function
ErrorHandling:
TempString = "Get File List Error"
Call ErrorWriteBuff(LocalFilePath & FileList(i), i, "LoadLocalFile", Err.Number, Err.Description, TempString)
Resume Next
End Function
Public Function ErrorWriteBuff(FileName As String, lines As Integer, FunctionName As String, code As Integer, Description As String, Remarks As String) As Boolean
If Description = "" Then
Description = "Null"
End If
ReDim Preserve ErrorData(ErrorCount)
ErrorData(ErrorCount) = FileName & ":" & Format(lines, "000") & " " & FunctionName & " " & "code :" & code & " Description :" & Description & ":" & Remarks
ErrorCount = ErrorCount + 1
End Function
