支持搜索路径的问题

zhuxuhong

我想将某一路径下的子文件夹都加入支持搜索路径，为什么这段程序会出错？是不是ThisDrawing.Application.Preferences.Files的长度有限制？还有是不是和子文件夹的数量多少有关?请指教!

Public Sub AddSupportPath(ByVal Path As String)
Dim curSupportPath As Variant
Dim i As Integer
Dim Support As Boolean

Support = False
curSupportPath = Split(ThisDrawing.Application.Preferences.Files, ";")

For i = 0 To UBound(curSupportPath)
If StrConv(curSupportPath(i), vbUpperCase) = StrConv(Path, vbUpperCase) Then
Support = True
Exit For
End If
Next

If Not Support Then

''''''''''''''''''''''''' 出错

ThisDrawing.Application.Preferences.Files = ThisDrawing.Application.Preferences.Files & ";" & Path

'FrmMain.ListBox1.AddItem Path
End If
End Sub

zhuxuhong

我发现好像len(thisdrawing..Application.Preferences.Files)不能超过1000

alin

'''对象模型没搞对。 Public Sub AddSupportPath(ByVal Path As String)
Dim curSupportPath As Variant
Dim i As Integer
Dim Support As Boolean
Support = False
curSupportPath = Split(ThisDrawing.Application.Preferences.Files.SupportPath, ";")
For i = 0 To UBound(curSupportPath)
If StrConv(curSupportPath(i), vbUpperCase) = StrConv(Path, vbUpperCase) Then
Support = True
Exit For
End If
Next
If Not Support Then
ThisDrawing.Application.Preferences.Files.SupportPath = _
ThisDrawing.Application.Preferences.Files.SupportPath & ";" & Path
FrmMain.ListBox1.AddItem Path
End If
End Sub

zhuxuhong

还是不行啊，运行一会儿就自动关闭CAD了。帮我看看整段程序好吗？

Public Sub AddSupportPath(ByVal Path As String)
Dim curSupportPath As Variant
Dim i As Integer
Dim Support As Boolean

Support = False
curSupportPath = Split(ThisDrawing.Application.Preferences.Files, ";")

For i = 0 To UBound(curSupportPath)
If StrConv(curSupportPath(i), vbUpperCase) = StrConv(Path, vbUpperCase) Then
Support = True
Exit For
End If
Next

If Not Support Then

Debug.Print ThisDrawing.Application.Preferences.Files
Debug.Print Len(ThisDrawing.Application.Preferences.Files)
Debug.Print Path
Debug.Print Len(Path)

ThisDrawing.Application.Preferences.Files = ThisDrawing.Application.Preferences.Files & ";" & Path
'FrmMain.ListBox1.AddItem Path
End If
End Sub

'''指定路径下的所有文件夹
Public Function GetAllFolder(ByVal root As String)

Dim fsoSubFolder As Folder
Dim astr As String
Dim fsoSys As New Scripting.FileSystemObject
Dim fsoRootFolder As Folder

Set fsoRootFolder = fsoSys.GetFolder(root)
'''添加搜索路径
AddSupportPath (root)
For Each fsoSubFolder In fsoRootFolder.SubFolders
astr = fsoSubFolder.Path
'''添加搜索路径
AddSupportPath (astr)
'''递归调用
Call GetAllFolder(astr)

Next
Set fsoRootFolder = Nothing

End Function

zhuxuhong

添加SUPPORTPATH也不行的。如果说子文件夹的数目比较少的话还是可以的，但多了就自动退出CAD了。

alin

我加了41个子文件夹也没问题。 Option Explicit Sub AddPaths()
Dim SubFolders As Variant
Dim I As Integer
Dim RootFolderName As String
RootFolderName = "F:\alin"
AddSupportPath (RootFolderName)
SubFolders = funcGetSubfolders(RootFolderName)
For I = 0 To UBound(SubFolders)
AddSupportPath (SubFolders(I))
Next I
End Sub Public Sub AddSupportPath(ByVal Path As String)
Dim curSupportPath As Variant
Dim I As Integer
Dim Support As Boolean
Support = False
curSupportPath = Split(ThisDrawing.Application.Preferences.Files.SupportPath, ";")
For I = 0 To UBound(curSupportPath)
If StrConv(curSupportPath(I), vbUpperCase) = StrConv(Path, vbUpperCase) Then
Support = True
Exit For
End If
Next
If Not Support Then
ThisDrawing.Application.Preferences.Files.SupportPath = _
ThisDrawing.Application.Preferences.Files.SupportPath & ";" & Path
End If
End Sub
'''Ö¸¶¨Â·¾¶ÏµÄËùÓÐÎļþ¼Ð By Thomas Gahler
Public Function funcGetSubfolders(FolderToRead As String) As Variant
Dim AllSubFolders(0) As Variant On Error Resume Next
'System.Cursor = wdCursorWait
If (Right$(FolderToRead, 1) <> "\") Then
FolderToRead = FolderToRead & "\"
End If
AllSubFolders(0) = FolderToRead
funcGetSubfolders = funcGetAllSubFolders(AllSubFolders)
'System.Cursor = wdCursorNormal
'statusbar = ""
On Error GoTo 0
End Function Private Function funcGetAllSubFolders(AllSubFoldersArray As Variant) As Variant
Dim Counter As Integer
Dim CurFolderName As String
Dim SubFolderName As String
Dim SubFolderList() As String On Error Resume Next
CurFolderName = CStr(AllSubFoldersArray(UBound(AllSubFoldersArray)))
ReDim SubFolderList(0)
SubFolderName = Dir$(CurFolderName, vbDirectory)
Do While Len(SubFolderName) <> 0
If SubFolderName <> "." And SubFolderName <> ".." Then
If (GetAttr(CurFolderName & SubFolderName) _
And vbDirectory) = vbDirectory Then
ReDim Preserve SubFolderList(UBound(SubFolderList) + 1)
SubFolderList(UBound(SubFolderList)) = SubFolderName
' statusbar = "Reading Subfolders...(" _
' & CurFolderName & ":->" & SubFolderName & ")"
End If
End If
SubFolderName = Dir$()
Loop 'If UBound(SubFolderList) > 0 Then
' WordBasic.SortArray SubFolderList()
'End If For Counter = 1 To UBound(SubFolderList)
ReDim Preserve AllSubFoldersArray(UBound(AllSubFoldersArray) + 1)
AllSubFoldersArray(UBound(AllSubFoldersArray)) = _
CurFolderName & SubFolderList(Counter) & "\"
AllSubFoldersArray = funcGetAllSubFolders(AllSubFoldersArray)
Next Counter
funcGetAllSubFolders = AllSubFoldersArray
On Error GoTo 0
End Function

zhuxuhong

谢谢alin版主。不知什么原因，你发的程序在我机子上运行，还是会自动关闭CAD退出的。我只是把你的路径改为C:\了啊

alin

Have you tried a sub folder , such as "C:\XXXX"?

my_computer

你分路径是为了管理文件吗？


你也可以在你的程序来设定文件加载的路径。