支持搜索路径的问题
<DIV>我想将某一路径下的子文件夹都加入支持搜索路径，为什么这段程序会出错？是不是ThisDrawing.Application.Preferences.Files的长度有限制？还有是不是和子文件夹的数量多少有关?请指教!</DIV><DIV> </DIV>
<DIV>Public Sub AddSupportPath(ByVal Path As String)<BR> Dim curSupportPath As Variant<BR> Dim i As Integer<BR> Dim Support As Boolean</DIV>
<DIV> </DIV>
<DIV> Support = False<BR> curSupportPath = Split(ThisDrawing.Application.Preferences.Files, ";")</DIV>
<DIV> </DIV>
<DIV> For i = 0 To UBound(curSupportPath)<BR> If StrConv(curSupportPath(i), vbUpperCase) = StrConv(Path, vbUpperCase) Then<BR> Support = True<BR> Exit For<BR> End If<BR> Next</DIV>
<DIV> </DIV>
<DIV> If Not Support Then</DIV>
<DIV> </DIV>
<DIV>''''''''''''''''''''''''' 出错</DIV>
<DIV><BR> <FONT color=#ff0000>ThisDrawing.Application.Preferences.Files = ThisDrawing.Application.Preferences.Files & ";" & Path</FONT></DIV>
<DIV><BR> 'FrmMain.ListBox1.AddItem Path<BR> End If<BR>End Sub<BR></DIV> <DIV>我发现好像len(thisdrawing..Application.Preferences.Files)不能超过1000</DIV> '''对象模型没搞对。
Public Sub AddSupportPath(ByVal Path As String)<BR> Dim curSupportPath As Variant<BR> Dim i As Integer<BR> Dim Support As Boolean<BR> Support = False<BR> curSupportPath = Split(ThisDrawing.Application.Preferences.Files.SupportPath, ";")<BR> For i = 0 To UBound(curSupportPath)<BR> If StrConv(curSupportPath(i), vbUpperCase) = StrConv(Path, vbUpperCase) Then<BR> Support = True<BR> Exit For<BR> End If<BR> Next<BR> If Not Support Then<BR> ThisDrawing.Application.Preferences.Files.SupportPath = _<BR> ThisDrawing.Application.Preferences.Files.SupportPath & ";" & Path<BR> FrmMain.ListBox1.AddItem Path<BR> End If<BR>End Sub <DIV>还是不行啊，运行一会儿就自动关闭CAD了。帮我看看整段程序好吗？</DIV>
<DIV>Public Sub AddSupportPath(ByVal Path As String)<BR> Dim curSupportPath As Variant<BR> Dim i As Integer<BR> Dim Support As Boolean</DIV>
<DIV> </DIV>
<DIV> Support = False<BR> curSupportPath = Split(ThisDrawing.Application.Preferences.Files, ";")</DIV>
<DIV> </DIV>
<DIV> For i = 0 To UBound(curSupportPath)<BR> If StrConv(curSupportPath(i), vbUpperCase) = StrConv(Path, vbUpperCase) Then<BR> Support = True<BR> Exit For<BR> End If<BR> Next</DIV>
<DIV> </DIV>
<DIV> If Not Support Then<BR> <BR> Debug.Print ThisDrawing.Application.Preferences.Files<BR> Debug.Print Len(ThisDrawing.Application.Preferences.Files)<BR> Debug.Print Path<BR> Debug.Print Len(Path)<BR> <BR> ThisDrawing.Application.Preferences.Files = ThisDrawing.Application.Preferences.Files & ";" & Path<BR> 'FrmMain.ListBox1.AddItem Path<BR> End If<BR>End Sub</DIV>
<DIV> </DIV>
<DIV>'''指定路径下的所有文件夹<BR>Public Function GetAllFolder(ByVal root As String)</DIV>
<DIV> </DIV>
<DIV> Dim fsoSubFolder As Folder<BR> Dim astr As String<BR> Dim fsoSys As New Scripting.FileSystemObject<BR> Dim fsoRootFolder As Folder</DIV>
<DIV> </DIV>
<DIV> Set fsoRootFolder = fsoSys.GetFolder(root)<BR> '''添加搜索路径<BR> AddSupportPath (root)<BR> For Each fsoSubFolder In fsoRootFolder.SubFolders<BR> astr = fsoSubFolder.Path<BR> '''添加搜索路径<BR> AddSupportPath (astr)<BR> '''递归调用<BR> Call GetAllFolder(astr)<BR> <BR> Next<BR> Set fsoRootFolder = Nothing</DIV>
<DIV> </DIV>
<DIV>End Function</DIV> <DIV>添加SUPPORTPATH也不行的。如果说子文件夹的数目比较少的话还是可以的，但多了就自动退出CAD了。</DIV> 我加了41个子文件夹也没问题。
Option Explicit
Sub AddPaths()<BR>Dim SubFolders As Variant<BR>Dim I As Integer<BR>Dim RootFolderName As String<BR>RootFolderName = "F:\alin"<BR>AddSupportPath (RootFolderName)<BR>SubFolders = funcGetSubfolders(RootFolderName)<BR>For I = 0 To UBound(SubFolders)<BR> AddSupportPath (SubFolders(I))<BR>Next I<BR>End Sub
Public Sub AddSupportPath(ByVal Path As String)<BR> Dim curSupportPath As Variant<BR> Dim I As Integer<BR> Dim Support As Boolean<BR> Support = False<BR> curSupportPath = Split(ThisDrawing.Application.Preferences.Files.SupportPath, ";")<BR> For I = 0 To UBound(curSupportPath)<BR> If StrConv(curSupportPath(I), vbUpperCase) = StrConv(Path, vbUpperCase) Then<BR> Support = True<BR> Exit For<BR> End If<BR> Next<BR> If Not Support Then<BR> ThisDrawing.Application.Preferences.Files.SupportPath = _<BR> ThisDrawing.Application.Preferences.Files.SupportPath & ";" & Path<BR> End If<BR>End Sub<BR>'''Ö¸¶¨Â·¾¶ÏµÄËùÓÐÎļþ¼Ð By Thomas Gahler<BR>Public Function funcGetSubfolders(FolderToRead As String) As Variant<BR>Dim AllSubFolders(0) As Variant
On Error Resume Next<BR>'System.Cursor = wdCursorWait<BR>If (Right$(FolderToRead, 1) <> "\") Then<BR>FolderToRead = FolderToRead & "\"<BR>End If<BR>AllSubFolders(0) = FolderToRead<BR>funcGetSubfolders = funcGetAllSubFolders(AllSubFolders)<BR>'System.Cursor = wdCursorNormal<BR>'statusbar = ""<BR>On Error GoTo 0<BR>End Function
Private Function funcGetAllSubFolders(AllSubFoldersArray As Variant) As Variant<BR>Dim Counter As Integer<BR>Dim CurFolderName As String<BR>Dim SubFolderName As String<BR>Dim SubFolderList() As String
On Error Resume Next<BR>CurFolderName = CStr(AllSubFoldersArray(UBound(AllSubFoldersArray)))<BR>ReDim SubFolderList(0)<BR>SubFolderName = Dir$(CurFolderName, vbDirectory)<BR>Do While Len(SubFolderName) <> 0<BR>If SubFolderName <> "." And SubFolderName <> ".." Then<BR> If (GetAttr(CurFolderName & SubFolderName) _<BR> And vbDirectory) = vbDirectory Then<BR> ReDim Preserve SubFolderList(UBound(SubFolderList) + 1)<BR> SubFolderList(UBound(SubFolderList)) = SubFolderName<BR>' statusbar = "Reading Subfolders...(" _<BR>' & CurFolderName & ":->" & SubFolderName & ")"<BR> End If<BR>End If<BR>SubFolderName = Dir$()<BR>Loop
'If UBound(SubFolderList) > 0 Then<BR>' WordBasic.SortArray SubFolderList()<BR>'End If
For Counter = 1 To UBound(SubFolderList)<BR> ReDim Preserve AllSubFoldersArray(UBound(AllSubFoldersArray) + 1)<BR> AllSubFoldersArray(UBound(AllSubFoldersArray)) = _<BR> CurFolderName & SubFolderList(Counter) & "\"<BR> AllSubFoldersArray = funcGetAllSubFolders(AllSubFoldersArray)<BR>Next Counter<BR>funcGetAllSubFolders = AllSubFoldersArray<BR>On Error GoTo 0<BR>End Function 谢谢alin版主。不知什么原因，你发的程序在我机子上运行，还是会自动关闭CAD退出的。我只是把你的路径改为C:\了啊 Have you tried a sub folder , such as "C:\XXXX"? 你分路径是为了管理文件吗？
你也可以在你的程序来设定文件加载的路径。
页:
[1]