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