VBA - определение того, является ли строка файлом, папкой или веб-адресом

Question

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

FYI - для файла я копирую файл в хранилище, для папки я создаю ярлык .lnk и копирую его в хранилище, а для веб-адреса я делаю ярлык .url и копирую его в хранилище.

Я разработал решение, но оно недостаточно надежное; Я получаю случайную ошибку от неверного определения строки. Я использовал метод подсчета точек в строке и применения правила:

If Dots = 1 Then... it's a file.

If Dots < 1 Then... it's a folder.

If Dots > 1 Then... it's a website.

Затем я улучшил это, используя несколько функций, которые я нашел в Интернете:

Dots = Len(TargetPath) - Len(Replace(TargetPath, ".", ""))      ' Crude check for IsURL (by counting Dots)

If CheckFileExists(TargetPath) = True Then Dots = 1             ' Better check for IsFile

If CheckFolderExists(TargetPath) = True Then Dots = 0           ' Better check for IsFolder

Проблема в том, что у меня все еще проблемы с 2 обстоятельствами:

1. Когда имена файлов содержат дополнительные точки, например, \Report.01.doc

2. Когда строка представляет собой файл или папку в удаленном расположении в интрасети (я думаю, это может быть неверное определение в качестве веб-адреса).

Любые указатели в правильном направлении будут высоко оценены.

Том Н

Answer 1

Это может решить вашу проблему или, по крайней мере, привести вас к одному:

Function CheckPath(path) As String
    Dim retval
    retval = "I"
    If (retval = "I") And FileExists(path) Then retval = "F"
    If (retval = "I") And FolderExists(path) Then retval = "D"
    If (retval = "I") And HttpExists(path) Then retval = "F"
    ' I => Invalid | F => File | D => Directory | U => Valid Url
    CheckPath = retval
End Function
Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
    'Purpose:   Return True if the file exists, even if it is hidden.
    'Arguments: strFile: File name to look for. Current directory searched if no path included.
    '           bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
    'Note:      Does not look inside subdirectories for the file.
    'Author:    Allen Browne. http://allenbrowne.com June, 2006.
    Dim lngAttributes As Long

    'Include read-only files, hidden files, system files.
    lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
    If bFindFolders Then
        lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
    Else
        'Strip any trailing slash, so Dir does not look inside the folder.
        Do While Right$(strFile, 1) = "\"
            strFile = Left$(strFile, Len(strFile) - 1)
        Loop
    End If
    'If Dir() returns something, the file exists.
    On Error Resume Next
    FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
Function FolderExists(ByVal strPath As String) As Boolean
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0 Then
        If Right(varIn, 1) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function
Function HttpExists(ByVal sURL As String) As Boolean
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
    If Not UCase(sURL) Like "HTTP:*" Then
    sURL = "http://" & sURL
    End If
    On Error GoTo haveError
    oXHTTP.Open "HEAD", sURL, False
    oXHTTP.send
    HttpExists = IIf(oXHTTP.Status = 200, True, False)
    Exit Function
haveError:
    Debug.Print Err.Description
    HttpExists = False
End Function