Beyond Inventor Wizard... The Community!
Autodesk Inventor en AutoCAD Forum
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
Labels:
Toegevoegd door Stefaan Boel 0 Opmerkingen 0 Vindt leuk
Toegevoegd door pascal david 0 Opmerkingen 2 Vindt leuk
Toegevoegd door Patrick De Bruyn 2 Opmerkingen 2 Vindt leuk
© 2023 Gemaakt door Stefaan Boel.
Verzorgd door