VBS vs VBA проверяет открытый файл [дубликат]

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

Эта функция укажет, что доступ «запись» невозможен, если файл заблокирован другим процессом. Однако он не может отличить это условие от других условий, которые препятствуют доступу «писать». Например, доступ «write» также невозможен, если файл имеет свой бит только для чтения, установленный или имеющий ограничительные разрешения NTFS. Все эти условия приведут к «разрешению отказа» при попытке доступа «писать».

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

Исключение возникает, если какое-либо из этих условий найдено: «файл не найден», «путь не найден» или «незаконное имя файла» («неправильное имя файла» или число ').

Function IsWriteAccessible(sFilePath)
    ' Strategy: Attempt to open the specified file in 'append' mode.
    ' Does not appear to change the 'modified' date on the file.
    ' Works with binary files as well as text files.

    ' Only 'ForAppending' is needed here. Define these constants
    ' outside of this function if you need them elsewhere in
    ' your source file.
    Const ForReading = 1, ForWriting = 2, ForAppending = 8

    IsWriteAccessible = False

    Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next

    Dim nErr : nErr = 0
    Dim sDesc : sDesc = ""
    Dim oFile : Set oFile = oFso.OpenTextFile(sFilePath, ForAppending)
    If Err.Number = 0 Then
        oFile.Close
        If Err Then
            nErr = Err.Number
            sDesc = Err.Description
        Else
            IsWriteAccessible = True
        End if
    Else
        Select Case Err.Number
            Case 70
                ' Permission denied because:
                ' - file is open by another process
                ' - read-only bit is set on file, *or*
                ' - NTFS Access Control List settings (ACLs) on file
                '   prevents access

            Case Else
                ' 52 - Bad file name or number
                ' 53 - File not found
                ' 76 - Path not found

                nErr = Err.Number
                sDesc = Err.Description
        End Select
    End If

    ' The following two statements are superfluous. The VB6 garbage
    ' collector will free 'oFile' and 'oFso' when this function completes
    ' and they go out of scope. See Eric Lippert's article for more:
    '   http://blogs.msdn.com/b/ericlippert/archive/2004/04/28/when-are-you-required-to-set-objects-to-nothing.aspx

    'Set oFile = Nothing
    'Set oFso = Nothing

    On Error GoTo 0

    If nErr Then
        Err.Raise nErr, , sDesc
    End If
End Function

Пример Отлично работает, НО нужно следующее, иначе вы получите err 5 (Незаконная процедура)

Const ForReading = 1, ForWriting = 2, ForAppending = 8

Нижеприведенный сценарий пытается записать файл в течение 30 секунд и после этого сдаться. Мне это нужно, когда все наши пользователи должны были щелкнуть по сценарию. Скорее всего, несколько пользователей пытаются писать одновременно. OpenCSV () пытается открыть файл 30 раз с задержкой в ​​1 секунду.

  Const ForAppending = 8

  currentDate = Year(Now) & "-" & Month(Now) & "-" & Day(Now) & " " & Hour(Now) & ":" & Minute(Now) & ":" & Second(Now)
  filepath = "\\network\path\file.csv"
  Set oCSV = OpenCSV( filepath ) 
  oCSV.WriteLine( currentDate )
  oCSV.Close

  Function OpenCSV( path )
    Set oFS = CreateObject( "Scripting.FileSystemObject" )
    For i = 0 To 30
      On Error Resume Next
      Set oFile = oFS.OpenTextFile( path, ForAppending, True )
      If Not Err.Number = 70 Then
        Set OpenCSV = oFile
        Exit For
      End If
      On Error Goto 0
      Wscript.Sleep 1000
    Next
    Set oFS = Nothing
    Set oFile = Nothing
    If Err.Number = 70 Then
      MsgBox "File " & filepath & " is locked and timeout was exceeded.", vbCritical
      WScript.Quit
    End If
  End Function