MacroLabo, Autocad: BatchPrint Filename 2 DXF

Voeg deze code toe aan uw project .dvb-bestand.

U moet minstens een dwg of dxf openstaan hebben.

Dit mag echter niet 1 van de te bewerken tekeningen zijn.

Option Explicit

Public Sub FileNameStampDXF()

Dim BrowseFolder As String
Dim ShellApp As Object

'Maken van een file browser
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0)

'Indien er een fout optreed
On Error Resume Next

'Pad van de geselecteerde folder vastleggen.
BrowseFolder = ShellApp.self.Path

'De file browser uit het geheugen laden
Set ShellApp = Nothing

'de bestanden refereren als een collectie
Dim colFiles As New Collection

'Functie RecursiveDir oproepen
'dxf kan vervangen worden door dwg of andere formaten!!!
RecursiveDir colFiles, BrowseFolder, "*.dxf", True

'Referentie naar het bestand
Dim vFile As Variant

'Referentie voor de bestandsnaam
Dim FileName As String

'Referentie naar Het tekstveld die we willen plaatsen
Dim txtVeld As AcadText

'Het ACAD 2D punt vastleggen x=2mm,y=2mm
Dim Optn(2) As Double
Optn(0) = 2
Optn(1) = 2

'Loopen door elk bestand van de gekozen folder
For Each vFile In colFiles

'Het bestand met ACAD openen
Call Application.Documents.Open(vFile)

'Tekstveld invoegen
Set txtVeld = ThisDrawing.ModelSpace.AddText(Left(ThisDrawing.Name, InStr(ThisDrawing.Name, "_") - 1), Optn, 5)

'Volgend bestand
Next vFile

'Einde Sub
Exit Sub

'Foutenafhandeling
errorhandler:

If Err.Number = 5 Then
Exit Sub
Else
MsgBox "Er is een onbekendefout opgetreden.", vbOKOnly, "Foutmelding"
End If

End Sub

'2 Functies om de bestanden te vinden, openen, zoeken in subfolders, enz...)
Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)

    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

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