Beyond Inventor Wizard... The Community!

Autodesk Inventor en AutoCAD Forum

Macro's Labo: Openen van alle idw's in een bepaalde folder

Wenst u alle bestanden een bepaald type in een folder te openen,

Dan kunt u onderstaande macro gebruiken.

De regel RecursiveDir colFiles, BrowseFolder, "*.idw", True kunt u aanpassen,

zodat u deze macro ook voor andere toepassingen met vba kunt gebruiken.

(office, autocad,...)

Sub OpenAllIdwInFolder()

Dim BrowseFolder As String
Dim ShellApp As Object
Dim oNewDocument As DrawingDocument
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0)
'Set the folder to that selected.  (On error in case cancelled)
On Error Resume Next
BrowseFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing

Dim colFiles As New Collection
'Hier wordt gefilterd op de extensie IDW
RecursiveDir colFiles, BrowseFolder, "*.idw", True
      
Dim vFile As Variant
For Each vFile In colFiles
    
      If InStr(vFile, ".0") = 0 Then
          On Error GoTo ErrorHandler
          Set oNewDocument = ThisApplication.Documents.Open(vFile)
      End If
   
Next vFile
ErrorHandler:
End Sub

'-------------------------------------------------------------------------
'-------------------------------------------------------------------------
'--Functies----------------------------------------------------------------
'-------------------------------------------------------------------------

Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
On Error GoTo ErrorHandler
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If
ErrorHandler:

End Function
Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

Aantal maal bekeken: 590

Hierop reageren

Interessante links

Word Fan!

Inventor Wizard Cartoons

Video's

  • Video's toevoegen
  • Alles weergeven

© 2021   Gemaakt door Stefaan Boel.   Verzorgd door

Banners  |  Een probleem rapporteren?  |  Algemene voorwaarden