FileSystemObject вызывает выполнение ... слишком быстро?

Question

Я работаю над системой, которая изменяет файл «на месте». Использование кавычек связано с тем, что фактический процесс выглядит следующим образом:

1. Внести изменения в новый файл с временным именем.
2. Переместить исходный файл (переименовать) с расширением «.bak»
3. Переместить (переименовать) новый файл в имя исходного файла.
4. Удалить промежуточный файл.

Этот процесс включает использование PDFtk для изменения файлов PDF. Проблема в том, что когда я запускаю код, он иногда «пропускает» шаг в какой-то момент на пути, иногда приводя к ошибке, связанной с одним из предыдущих шагов, которые не происходят.

Когда я просматриваю код с помощью отладчика, все работает отлично каждый раз. Если я добавлю следующий код между каждым вызовом файловой системы, он также работает.

Public Sub Wait(seconds As Integer) 
Dim dTimer As Double 

    dTimer = Timer 
    Do While Timer < dTimer + seconds 
     DoEvents 
    Loop 

End Sub 

(Кредит: this VBForums post)

Я действительно не хочу, чтобы это сделать, потому что он добавляет к времени выполнения, и я действительно не могу сказать, как долго паузы «достаточно «для различных клиентов, которые будут использовать это приложение. Есть ли лучший способ обеспечить правильную работу вышеуказанных функций? Возможно, вообще не используя FileSystemObject?

Вот код, который я работаю с:

If LCase$(inputFilename) = LCase$(outputFilename) Then 
     ' Saving changes to original file. 
     Set fso = New FileSystemObject 
     tempPath = fso.GetParentFolderName(outputFilename) & "\" & _ 
      Format$(Now, "mm_dd_yyyy_hh_nn_ss") & ".pdf" 
     ' Create temp file 
     CreateSubsetFromPDF = Shell("""" & App.Path & "\pdftk"" """ & inputFilename & _ 
      """ cat " & pages & " output """ & tempPath & """", vbHide) 
     ' Copy temp file to actual destination, overwriting. 
     fso.CopyFile tempPath, outputFilename, True 
     fso.DeleteFile tempPath 
End If 

Answer 1

Я подозреваю, ваша проблема в том, что возвращается оболочка сразу после запуска (или не начала) процесс. Я бы предложил использовать API-вызов CreateProcess и ждать хотя бы немного, чтобы процесс возвращал результат. Я использую это достаточно, я создал метод для этого. Иногда мне приходится ждать до нескольких часов для запуска программ, чтобы мой метод использовал бесконечное ожидание. Поскольку вы только ожидаете подождать несколько секунд, я бы изменил время ожидания, чтобы подойти самому. Время ожидания - это то, как долго он будет ждать до сбоя. В противном случае он возвращается, как только закончится процесс.

Private Type STARTUPINFO 
    cb As Long 
    lpReserved As String 
    lpDesktop As String 
    lpTitle As String 
    dwX As Long 
    dwY As Long 
    dwXSize As Long 
    dwYSize As Long 
    dwXCountChars As Long 
    dwYCountChars As Long 
    dwFillAttribute As Long 
    dwFlags As Long 
    wShowWindow As Integer 
    cbReserved2 As Integer 
    lpReserved2 As Long 
    hStdInput As Long 
    hStdOutput As Long 
    hStdError As Long 
End Type 

Private Type PROCESS_INFORMATION 
    hProcess As Long 
    hThread As Long 
    dwProcessId As Long 
    dwThreadID As Long 
End Type 

Private Declare Function WaitForSingleObjectEx Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long 
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long 
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal _ 
    lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _ 
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _ 
    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _ 
    lpStartupInfo As STARTUPINFO, lpProcessInformation As _ 
    PROCESS_INFORMATION) As Long 

Private Const INFINITE = -1& 
Private Const NORMAL_PRIORITY_CLASS = &H20& 
Private Const SW_SHOW = 5 
Private Const STARTF_USESHOWWINDOW = &H1 

Public Function ExecAndWait(ByVal Program As String, Optional ByVal Parms As Variant, _ 
           Optional ByVal hStdOutput As Long) As Long 
    Dim proc As PROCESS_INFORMATION 
    Dim start As STARTUPINFO 
    Dim RET As Long 
    Dim strCommandLine As String 
    Dim lExitCode As Long 
    Dim lWaitTime As Long 

    On Error GoTo errExecAndWait 

    ' quote the commandline and parameters if necessary 
    If InStr(Program, """") = 0 Then ' if quotes are found assume that any necessary quoting has already been done 
     If InStr(Program, " ") > 0 Then 
     'do not include any Program parms (" /parm" in the quotes 
     If InStr(Program, " /") > 0 Then 
      strCommandLine = Chr$(34) & Left$(Program, InStr(Program, " /") - 1) & Chr$(34) & Right$(Program, Len(Program) - InStr(Program, " /") + 1) 
     Else 
      strCommandLine = Chr$(34) & Program & Chr$(34) 
     End If 
     Else 
     strCommandLine = Program 
     End If 
    Else 
     strCommandLine = Program 
    End If 

    If Not IsMissing(Parms) Then 
     If Len(Parms) > 0 Then 
     If InStr(Program, """") = 0 Then ' if quotes are found assume that any necessary quoting has already been done 
      If InStr(Parms, " ") > 0 Then 
       strCommandLine = strCommandLine & " " & Chr$(34) & Parms & Chr$(34) 
      Else 
       strCommandLine = strCommandLine & " " & Parms 
      End If 
     Else 
      strCommandLine = strCommandLine & " " & Parms 
     End If 
     End If 
    End If 

    start.dwFlags = STARTF_USESHOWWINDOW 
    start.wShowWindow = SW_SHOW 

    lWaitTime = INFINITE 'forever 
    ' Initialize the STARTUPINFO structure: 
    start.cb = Len(start) 

    ' Start the shelled application: 
    RET& = CreateProcessA(vbNullString, strCommandLine, 0&, 0&, 1&, _ 
         NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc) 
    ' change the return value to 0 if the dll returned other than 0 else return the dll error 
    If RET& = 0 Then 'error 
     ExecAndWait = 0 
     Err.Raise Err.LastDllError, strCommandLine, Translate_DLL_Error(Err.LastDllError) 
    Else 
     Call Sleep(2000) ' Wait for the shelled application to get going: 
     RET& = WaitForSingleObjectEx(proc.hProcess, lWaitTime, False) 
     RET& = GetExitCodeProcess(proc.hProcess, lExitCode) 
     ExecAndWait = RET& 
     RET& = CloseHandle(proc.hProcess) 
     RET& = CloseHandle(proc.hThread) 
    End If 

    Exit Function 

errExecAndWait: 
    Err.Raise Err.Number, Err.Source & ":ExecAndWait", Err.Description 

End Function