Hi, Rob
SaveAs DXF method is difficult a bit
Here is semi-solution
All the changed dxf files should be saved in
the separate folder
You need to run this code from the drawing located
in other folder than your dxf files folder
Give this a shot
Option Explicit
Sub ProcDXFs()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' Requires reference to Microsoft Scripting Runtime
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Dim fs
Dim objFolder As Object
Dim objInFolder As Object
Dim newFolder As Object
Dim objFile As Object
Dim strOldFolder As String
Dim lngCount As Long, lngFolders As Long
Dim strFileType As String
Dim strFolders() As String
Dim n As Long
n = 0
strOldFolder = "D:\Rob_Souza\Poly\VBATEST"
On Error GoTo ErrHandler
Set fs = CreateObject("Scripting.FileSystemObject")
Set objFolder = fs.GetFolder(strOldFolder)
Set newFolder = fs.CreateFolder("D:\Rob_Souza\Poly\VBATEST\Edited")'<-- change new folder name to suit
ReDim strFiles(objFolder.Files.Count - 1) As String
For Each objFile In objFolder.Files
If UCase(objFile.Path) Like "*.DXF" Then
strFiles(n) = objFile.Path
n = n + 1
End If
Next
ThisDrawing.SetVariable "FILEDIA", 0
ThisDrawing.SetVariable "SDI", 0
Dim curName As String
curName = ThisDrawing.FullName
Dim olayout As AcadLayout
Dim layerObj As AcadLayer
Dim color As AcadAcCmColor
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
Dim pt(2) As Double
pt(0) = 0: pt(1) = 0: pt(2) = 0
For n = 0 To UBound(strFiles)
Dim aDoc As AcadDocument
Set aDoc = Documents.Open(strFiles(n), False)
On Error Resume Next
For Each olayout In ThisDrawing.Layouts
If olayout.Block.Name = "*PAPER_SPACE" Then
olayout.Delete
End If
If Err Then
Err.Clear
End If
Next
On Error GoTo 0
Set layerObj = aDoc.Layers.Add("NewLayer")
Call color.SetRGB(80, 100, 244)
layerObj.TrueColor = color
' do your other stuff here e.g. add text :
aDoc.ModelSpace.AddText "Test string must follows here", pt, 100#
ZoomAll
Dim sfileName As String
Dim sset As AcadSelectionSet
Set sset = aDoc.SelectionSets.Add("$ExportDXF$")
sset.Select acSelectionSetAll
sfileName = Replace(aDoc.Name, ".dwg", "")
aDoc.Export newFolder.Path & "\" & sfileName, "DXF", sset
Next
For Each aDoc In Documents
If aDoc.FullName <> curName Then
aDoc.Close False
End If
Next
Exit_Here:
ThisDrawing.SetVariable "FILEDIA", 1
Set color = Nothing
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Number & " : " & Err.Description
Resume Exit_Here
End If
End Sub
~'J'~