vba - VBA，如何快速检查文件是否存在（网络上的文件）

Question

我正在尝试检查网络上是否存在文件。但有时网络未连接，应用程序冻结。

Private Function FileExistsSlow(ByVal path_ As String) As Boolean
    On Error Resume Next
    FileExists = False
    FileExists = (Len(Dir(path_)) > 0)
End Function

标签： vbawinapi

Answer 1

这是快速变体

添加具有以下代码的模块：

#If VBA7 Then
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

#Else
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

#End If

Public Const INFINITE = &HFFFF
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
public Const SYNCHRONIZE = &H100000


Sub test()
 If FileExistsFast("c:\Windows\win.ini") Then
  MsgBox "exists"
 Else
  MsgBox "not"
 End If
End Sub

Sub test_hard()
 Dim file
 file = "\\random" & Mid(Str(Rnd()), 3, 5) & "\Windows\win.ini"
 'msgbox file
 If FileExistsFast(file) Then
  MsgBox "exists"
 Else
  MsgBox "not"
 End If
End Sub

Public Function FileExistsFast(file)
    FileExistsFast = False
    Dim Cmd As String
    Cmd = "cmd /c dir """ & file & """"
    lTaskID = Shell(Cmd, 0)
    ' Get process handle

    ' lPID = OpenProcess(PROCESS_ALL_ACCESS, True, lTaskID)
    lPID = OpenProcess(SYNCHRONIZE, True, lTaskID) ' suggested by a comment from IInspectable not sure if it works, should work
    If lPID Then
        'Wait for process to finish
        Dim result As Integer

        result = WaitForSingleObject(lPID, 1000) ' set tiemout for 1000 ms
        If result > 240 Then ' 258 process not closed yet , 259 status of process is not closed
               'MsgBox "not returned "
        Else
            'Get Exit Process
            If GetExitCodeProcess(lPID, lexitcode) Then
                'Received value
                'MsgBox "Successfully returned " & lExitCode, vbInformation
                If lexitcode = 0 Then
                    FileExistsFast = True
                End If
            Else
                MsgBox "Failed: " & DLLErrorText(Err.LastDllError), vbCritical
            End If
        End If
        lTaskID = CloseHandle(lPID)
    Else
        lTaskID = 0
        MsgBox "Failed: " & DLLErrorText(Err.LastDllError), vbCritical
    End If
End Function



Public Function DLLErrorText(ByVal lLastDLLError As Long) As String
    Dim sBuff As String * 256
    Dim lCount As Long
    Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100, FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
    Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_STRING = &H400
    Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000, FORMAT_MESSAGE_IGNORE_INSERTS = &H200
    Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF

    lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)
    If lCount Then
        DLLErrorText = Left$(sBuff, lCount - 2) \\Remove line feeds
    End If

End Function