string - VBA - 识别字符串是文件、文件夹还是网址

Question

我需要执行许多操作，由传递字符串启动，操作过程取决于字符串是文件、文件夹还是 web url。

仅供引用 - 对于文件，我将文件复制到存储库，对于文件夹，我正在制作快捷方式 .lnk 并将其复制到存储库，对于 web url，我正在制作快捷方式 .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

问题是，我仍然遇到两种情况的问题:

当文件名包含额外的点时，例如\Report.01.doc

当字符串是远程 Intranet 位置上的文件或文件夹时(我认为这可能会被误认为是 web url)。

任何指向正确方向的指针将不胜感激。

汤姆·H

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