Why do I get an Endless loop?

[Anonymous]

The following code gets stuck in an endless
loop?  It happens in the "Public Sub ListFilesInFolder(folder As
Scripting.folder)" section.

WATCH word wrap.

Option Explicit
Dim intcount As Integer
Dim
ACADApp As AcadApplication
Dim strSubdirectories As String

Public Sub ProcessFolder(path As
String)

    Dim fso As FileSystemObject,
folder As Scripting.folder
    Dim f As
Scripting.folder
   
    Set fso = New
FileSystemObject
    Set f =
fso.GetFolder(path)
    ListFilesInFolder f

End Sub

Public Sub ListFilesInFolder(folder As
Scripting.folder)

    Dim file As Scripting.file, f As
folder
    For Each file In
folder.Files
        If
LCase(GetAnExtension(file)) = "dwg"
Then
        Dim newtxtstyle As
AcadTextStyle
        Dim stdtxtstyle As
AcadTextStyle
       

            If
intcount = 0
Then
            Set
ACADApp =
ThisDrawing.Application
           
ACADApp.Documents.Close
        End
If
       

        Application.Documents.Open
file
        Set stdtxtstyle =
ThisDrawing.TextStyles.Item("STANDARD")
       
'    Set newtxtstyle =
ThisDrawing.TextStyles.Item("BOLD6")
       
'    newtxtstyle.fontFile =
"C:\Windows\Fonts\swiss.ttf"
       
'    ThisDrawing.Regen
(True)
'       
ThisDrawing.ActiveTextStyle =
stdtxtstyle
'        stdtxtstyle.fontFile
= "romans.shx"
        ThisDrawing.Regen
(True)
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ZoomExtents
'        Dim AcadX As
AcadXApplication
'        Set AcadX =
GetInterfaceObject("AcadX.Application")
       
ThisDrawing.Activate
'       
AcadX.MakePreviewImage ThisDrawing
       
ThisDrawing.Save
       
ThisDrawing.Close
        intcount =
intcount + 1
        End
If
    Debug.Print file.path
   
Next
   
    If strSubdirectories = "1"
Then
        For Each f In
folder.SubFolders
           
Call ListFilesInFolder(f)
       
Next
    End If
   

End Sub

Public Sub Purge()
    Dim
strFolder As String
    intcount = 0
   
strFolder = GetSetting("AutoCAD", "Purge Folder",
"Folder")
    strSubdirectories = GetSetting("AutoCAD", "Purge
Folder", "Subdirectory")
    If strFolder = ""
Then
        MsgBox "You must set a folder
to be purged.", vbInformation, "Set
Directory"
        Exit
Sub
    End If
    Call
ProcessFolder(strFolder)
    SaveSetting ACADApp.Name, "Purge
Count", "Number", CStr(intcount)
End Sub

Function GetAnExtension(DriveSpec)
  Dim
fso
  Set fso = CreateObject("Scripting.FileSystemObject")
 
GetAnExtension = fso.GetExtensionName(DriveSpec)
End Function

Private Sub Set_Folder()

    SaveSetting "AutoCAD", "Purge
Folder", "Folder", "C:\Gibco - Invitrogen\Drawings\Parts\Tubing"

End Sub

--
Thanks,
 
Dave Gardner
(remove na. to reply)
"It's never too late to be what you might have
been."
George Eliot

[Anonymous]

Probably because of this

If strSubdirectories = "1"
Then
        For Each f In
folder.SubFolders
           
Call ListFilesInFolder(f)
       
Next
    End If

I don't see where is being assigned a value to
come out of the loop.
--
Saludos,  Ing. Jorge Jimenez, SICAD
S.A., Costa Rica

style="PADDING-RIGHT: 0px; PADDING-LEFT: 5px; MARGIN-LEFT: 5px; BORDER-LEFT: #000000 2px solid; MARGIN-RIGHT: 0px">

"David M. Gardner" <
href="mailto:[email protected]">[email protected]>
wrote in message
href="news:[email protected]">news:0275B935D6BEDEF860BD146E77C......

The following code gets stuck in an endless
loop?  It happens in the "Public Sub ListFilesInFolder(folder As
Scripting.folder)" section.

WATCH word wrap.

Option Explicit
Dim intcount As Integer
Dim
ACADApp As AcadApplication
Dim strSubdirectories As String

Public Sub ProcessFolder(path As
String)

    Dim fso As FileSystemObject,
folder As Scripting.folder
    Dim f As
Scripting.folder
   
    Set fso = New
FileSystemObject
    Set f =
fso.GetFolder(path)
    ListFilesInFolder f

End Sub

Public Sub ListFilesInFolder(folder As
Scripting.folder)

    Dim file As Scripting.file, f
As folder
    For Each file In
folder.Files
        If
LCase(GetAnExtension(file)) = "dwg"
Then
        Dim newtxtstyle As
AcadTextStyle
        Dim stdtxtstyle As
AcadTextStyle
       

            If
intcount = 0
Then
            Set
ACADApp =
ThisDrawing.Application
           
ACADApp.Documents.Close
        End
If
       

        Application.Documents.Open
file
        Set stdtxtstyle =
ThisDrawing.TextStyles.Item("STANDARD")
       
'    Set newtxtstyle =
ThisDrawing.TextStyles.Item("BOLD6")
       
'    newtxtstyle.fontFile =
"C:\Windows\Fonts\swiss.ttf"
       
'    ThisDrawing.Regen
(True)
'       
ThisDrawing.ActiveTextStyle =
stdtxtstyle
'       
stdtxtstyle.fontFile =
"romans.shx"
        ThisDrawing.Regen
(True)
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ThisDrawing.PurgeAll
       
ZoomExtents
'        Dim AcadX As
AcadXApplication
'        Set AcadX =
GetInterfaceObject("AcadX.Application")
       
ThisDrawing.Activate
'       
AcadX.MakePreviewImage
ThisDrawing
       
ThisDrawing.Save
       
ThisDrawing.Close
        intcount =
intcount + 1
        End
If
    Debug.Print file.path
   
Next
   
    If strSubdirectories = "1"
Then
        For Each f In
folder.SubFolders
           
Call ListFilesInFolder(f)
       
Next
    End If
   

End Sub

Public Sub Purge()
    Dim
strFolder As String
    intcount = 0
   
strFolder = GetSetting("AutoCAD", "Purge Folder",
"Folder")
    strSubdirectories = GetSetting("AutoCAD",
"Purge Folder", "Subdirectory")
    If strFolder = ""
Then
        MsgBox "You must set a
folder to be purged.", vbInformation, "Set
Directory"
        Exit
Sub
    End If
    Call
ProcessFolder(strFolder)
    SaveSetting ACADApp.Name,
"Purge Count", "Number", CStr(intcount)
End Sub

Function GetAnExtension(DriveSpec)
  Dim
fso
  Set fso = CreateObject("Scripting.FileSystemObject")
 
GetAnExtension = fso.GetExtensionName(DriveSpec)
End Function

Private Sub Set_Folder()

    SaveSetting "AutoCAD", "Purge
Folder", "Folder", "C:\Gibco - Invitrogen\Drawings\Parts\Tubing"

End Sub

--
Thanks,
 
Dave Gardner
(remove na. to reply)
"It's never too late to be what you might have
been."
George Eliot