VBA - 识别字符串是文件、文件夹还是网址
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/9724779/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA - Identifying whether a string is a file, a folder or a web url
提问by FrugalTPH
I need to perform a number of actions, initiated by the passing of a string, with the course of actions depending on whether the string is a file, a folder or a web url.
我需要执行许多操作，由传递字符串启动，操作过程取决于字符串是文件、文件夹还是 web url。
FYI - for a file I copy the file to a repository, for a folder I am making a shortcut .lnk and copy that to a repository, and for a web url I am making a shortcut .url and copy that to a repository.
仅供参考 - 对于文件，我将文件复制到存储库，对于文件夹，我正在制作快捷方式 .lnk 并将其复制到存储库，对于 web url，我正在制作快捷方式 .url 并将其复制到存储库。
I developed a solution, but it isn't robust enough; I get the occasional error from misidentifying the string. The method I used was to count the dots in the string, and apply the rule:
我开发了一个解决方案，但它不够健壮；我偶尔会因错误识别字符串而出错。我使用的方法是计算字符串中的点数，并应用规则：
If Dots = 1 Then... it's a file.
If Dots < 1 Then... it's a folder.
If Dots > 1 Then... it's a website.
I then improved this using a couple of functions I found on the web:
然后我使用我在网上找到的几个函数改进了它：
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
Trouble is, I am still having problems with 2 circumstances:
问题是，我仍然遇到两种情况的问题：
When filenames contain additional dots, e.g.
\Report.01.docWhen the string is a file or folder on a remote intranet location (I think this could be misidentifying as a web url).
当文件名包含额外的点时，例如
\Report.01.doc当字符串是远程 Intranet 位置上的文件或文件夹时（我认为这可能会被误认为是 web url）。
Any pointers in the right direction would be much appreciated.
任何指向正确方向的指针将不胜感激。
Tom H
汤姆·H
采纳答案by bPratik
This might solve your problem, or atleast lead you to one:
这可能会解决您的问题，或者至少会引导您解决一个问题：
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
