VBA - 识别字符串是文件，文件夹还是网址url

Question

我需要通过传递一个字符串来执行一系列操作，操作过程取决于字符串是否是文件，一个文件夹或网址。

仅供参考 - 一个文件我将文件复制到存储库，一个文件夹我想提出一个快捷方式.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 

麻烦的是，我仍然有两种情况下的问题：

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

2. 当字符串是远程Intranet位置上的文件或文件夹（我认为这可能是错误识别为Web网址）。

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

汤姆^ 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