小小处女作：自定义函数(从完整路径中分离文件名/路径/尾缀名)

yjh_27

opel-wong 发表于 2014-11-14 11:31
也不是很严谨, 测试发现, 路径返回的不正确.

FullPath = "F:\Funshion.Media\红高.粱-MP4\红高粱-第45 ...

已改，重新测试。

opel-wong

yjh_27 发表于 2014-11-14 11:32
已改，重新测试。

感谢指点, 不错, 学习了.
第2种方法, 由 坛友 yjh_27 大师进行改进，代码在9楼。

不过, Join 函数, 要改为 VBA.Join 才能使用.
我把代码再放一下吧，如下：

1. Public Function NameAndPath2(ByVal FullPath As String, myNo As Byte) As String
   
2.     Dim aa() As String: aa = Split(FullPath, "")
   
3.     Dim bb() As String: bb = Split(aa(UBound(aa)), ".")
   
4.     If myNo = 1 Then    ' 第二参数为1
   
5.         NameAndPath2 = "." & bb(UBound(bb))   ' 返回: 尾缀名
   
6.     ElseIf myNo = 2 Then    ' 第二参数为2
   
7.         ReDim Preserve bb((UBound(bb)) - 1)
   
8.         NameAndPath2 = VBA.Join(bb, ".")  ' 返回: 文件名
   
9.     ElseIf myNo = 3 Then    ' 第二参数为3
   
10.         NameAndPath2 = aa(UBound(aa))    ' 返回: 带后缀文件名
    
11.     ElseIf myNo = 4 Then    ' 第二参数为4
    
12.         If UBound(aa) = 0 Then
    
13.             NameAndPath2 = ""
    
14.         Else
    
15.             ReDim Preserve aa((UBound(aa)) - 1)
    
16.             NameAndPath2 = VBA.Join(aa, "")    ' 返回: 路径
    
17.         End If
    
18.     Else:
    
19.         NameAndPath2 = ""
    
20.     End If
    
21. End Function

复制代码

1楼的第一种，不需要修改，亦适应类似情况。

.




.

香川群子

新手练练手是好事。不过这个自定义函数完全没有用处。

因为一般只需要其中的一个结果，那么写一句代码就够了。不需要使用啰唆的函数。

opel-wong

香川群子 发表于 2014-11-14 13:21
新手练练手是好事。不过这个自定义函数完全没有用处。

因为一般只需要其中的一个结果，那么写一句代码就 ...

感谢女侠支持，纯属新手练手，呵呵 。

要不女侠给优化一下，我也想学习一下。谢谢。

香川群子

opel-wong 发表于 2014-11-14 14:20
感谢女侠支持，纯属新手练手，呵呵 。

要不女侠给优化一下，我也想学习一下。谢谢。

1. Function FileInf(FullName, Optional k = 0)
   
2.     If k = -1 Then FileInf = Left(FullName, InStrRev(FullName, "") - 1): Exit Function
   
3.     FileInf = Mid(FullName, InStrRev(FullName, "") + 1): If k = 0 Then Exit Function
   
4.     If k = 1 Then FileInf = Left(FileInf, InStrRev(FileInf, ".") - 1) Else FileInf = Mid(FileInf, InStrRev(FileInf, ".") + 1)
   
5. End Function
   

复制代码

对于输入【参数-1】ThisWorkbook.FullName 例如：【D:\Documents\Test.xls】

k=-1时，返回 【文件夹名】 如：【D:\Documents】
默认 k=0 时，返回带后缀  【文件全名】 如： 【Test.xls】
k=1 时，返回 【文件名】 如：【Test】
k=2 时，返回 【文件后缀名】 如： 【xls】

以上。

opel-wong

香川群子 发表于 2014-11-14 16:58
对于输入【参数-1】ThisWorkbook.FullName 例如：【D:\Documents\Test.xls】

k=-1时，返回 【文件夹名 ...

测试了一下,能达到效果.
代码精简,学习了.

.

香川群子

opel-wong 发表于 2014-11-14 17:05
测试了一下,能达到效果.
代码精简,学习了.

现实应用中，只要使用其中的1句代码即可……所以说写这个自定义函数是没有意义的。

opel-wong

香川群子 发表于 2014-11-14 17:12
现实应用中，只要使用其中的1句代码即可……所以说写这个自定义函数是没有意义的。

明白。谢谢指点。



.

joforn

其实Windows已经提供了相关的函数，下面的代码是通过API来实现的，仅供参考。因为在某些语言的系统中(如日文系统)路径分隔符并不是"\"，所以没有使用字符来判断分割或是提取。

1. 
   
2. #If VBA7 Then
   
3.     Private Declare PtrSafe Function PathRemoveFileSpec Lib "shlwapi.dll" Alias "PathRemoveFileSpecW" (ByVal pszPath As LongPtr) As Long
   
4.     Private Declare PtrSafe Function PathRemoveBackslashW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
   
5.     Private Declare PtrSafe Function PathAddBackslashW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
   
6.     Private Declare PtrSafe Function PathStripPath Lib "shlwapi.dll" Alias "PathStripPathW" (ByVal pszPath As LongPtr) As Long
   
7.     Private Declare PtrSafe Function PathRemoveExtension Lib "shlwapi.dll" Alias "PathRemoveExtensionW" (ByVal pszPath As LongPtr) As Long
   
8.     Private Declare PtrSafe Function PathFindExtension Lib "shlwapi.dll" Alias "PathFindExtensionW" (ByVal pszPath As LongPtr) As Long
   
9.     Private Declare PtrSafe Sub CopyMemoryString Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
   
10.     Private Declare PtrSafe Function lStrLen Lib "kernel32.dll" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    
11. #Else
    
12.     Private Declare Function PathRemoveFileSpec Lib "shlwapi.dll" Alias "PathRemoveFileSpecW" (ByVal pszPath As Long) As Long
    
13.     Private Declare Function PathRemoveBackslashW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
    
14.     Private Declare Function PathAddBackslashW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
    
15.     Private Declare Function PathStripPath Lib "shlwapi.dll" Alias "PathStripPathW" (ByVal pszPath As Long) As Long
    
16.     Private Declare Function PathRemoveExtension Lib "shlwapi.dll" Alias "PathRemoveExtensionW" (ByVal pszPath As Long) As Long
    
17.     Private Declare Function PathFindExtension Lib "shlwapi.dll" Alias "PathFindExtensionW" (ByVal pszPath As Long) As Long
    
18.     Private Declare Sub CopyMemoryString Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    
19.     Private Declare Function lStrLen Lib "kernel32.dll" Alias "lstrlenW" (ByVal lpString As Long) As Long
    
20. #End If
    
21. 
    
22. '从路径中提取目录
    
23. Public Function ExtractPathDirctory(ByVal sPath As String) As String
    
24.   Dim I As Long
    
25.   
    
26.   sPath = sPath & String(5, vbNullChar)
    
27.   PathRemoveBackslashW StrPtr(sPath)
    
28.   PathRemoveFileSpec StrPtr(sPath)
    
29.   PathAddBackslashW StrPtr(sPath)
    
30.   I = InStr(sPath, vbNullChar)
    
31.   If I > 0 Then sPath = Left$(sPath, I - 1)
    
32.   ExtractPathDirctory = sPath
    
33. End Function
    
34. 
    
35. '从路径中提取文件名,去掉了路径中的目录。
    
36. Public Function ExtractFileName(ByVal sPath As String, Optional ByVal ExtensionReturn As Boolean = True) As String
    
37.   Dim I       As Long, J As Long
    
38.   Dim strPath As String
    
39.   
    
40.   sPath = sPath & String(5, vbNullChar)
    
41.   PathRemoveBackslashW StrPtr(sPath)
    
42.   PathStripPath StrPtr(sPath)
    
43.   If Not ExtensionReturn Then PathRemoveExtension StrPtr(sPath)
    
44.   I = InStr(sPath, vbNullChar)
    
45.   If I > 0 Then sPath = Left$(sPath, I - 1)
    
46.   ExtractFileName = sPath
    
47. End Function
    
48. 
    
49. '从路径提取文件后缀名
    
50. Public Function ExtractFileExtension(ByVal sPath As String) As String
    
51.   Dim ptrExt As Long
    
52.   Dim ExtLen As Long
    
53.   
    
54.   sPath = sPath & vbNullChar
    
55.   ptrExt = PathFindExtension(StrPtr(sPath))
    
56.   If ptrExt Then
    
57.     ExtLen = lStrLen(ptrExt)
    
58.     If ExtLen > 0 Then
    
59.       ExtractFileExtension = String(ExtLen, vbNullChar)
    
60.       CopyMemoryString StrPtr(ExtractFileExtension), ptrExt, LenB(ExtractFileExtension)
    
61.     End If
    
62.   End If
    
63. End Function
    
64. 
    
65. Sub Test()
    
66.     Const FileName As String = "C:\Windows.Old\1.TXT\ABC.123.后缀名有点怪"
    
67.     Debug.Print "文件全路径名：""" & FileName & """"
    
68.     Debug.Print "文件所在路径：""" & ExtractPathDirctory(FileName) & """"
    
69.     Debug.Print "带后缀文件名：""" & ExtractFileName(FileName) & """ 不带后缀文件名：""" & ExtractFileName(FileName, False) & """"
    
70.     Debug.Print "文件后缀名为：""" & ExtractFileExtension(FileName) & """"
    
71. End Sub
    

复制代码

aman1516

正是抛砖引用玉，学习一下……