AutoCAD VBA help with files in dir

[RMS]

Hello Everyone!

I have some code that I am trying to fix, what this should do when ran is go through all the dxf files in a folder, make a layer, save and go to the next, oh and I am trying to delete paper space. I think its the File Search command its in MS Office but I am running this through AutoCAD2005 any help would be greatly appreciated. -Thanks



[vba]Option Explicit
Public Sub scopyfiles()
On Error GoTo errorhandler
Dim ofs As Object
Dim osearch As Object
Dim sdir, shold As String
Dim iouter, iinner As Integer
Dim icheck As Integer
Dim smessage As String
Dim layerObj As AcadLayer
Dim color As AcadAcCmColor
Dim st As String
Set layerObj = ThisDrawing.Layers.Add("ABC")
Set ofs = CreateObject("Scripting.FileSystemObject")
Set osearch = Application.FileSearch
For iouter = 1 To 900
osearch.lookin = "D:\Rob_Souza\Poly\VBATEST" ' location
osearch.FileName = "*.dxf"

If osearch.Execute > 0 Then
For iinner = 1 To osearch.foundfiles.Count
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
Call color.SetRGB(80, 100, 244)
layerObj.TrueColor = color
ZoomAll
End If
ofs.savefile
Next
End If
Next
MsgBox ("files changed")
Set ofs = Nothing
Set osearch = Nothing
DoCmd.Quit
Exit Sub
errorhandler:
Set ofs = Nothing
Set osearch = Nothing
MsgBox ("error encountered")
End Sub[/vba]

[fixo]

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'~

[RMS]

Hi Fatty!

Great Job, and thanks for helping me out with this. Its working good, though for some reason the paper space or layout tab does not delete and actually even manually I could not delete it. I am currently trying to get this code to also make the Model Space tab active before it saves in the new folder.

Rob

[lucas]

I don't think you can delete all of the model and paper space tabs. I think you must have one of each. Just as in Excel you can't delete all of the sheets...you must leave one.

[RMS]

I don't think you can delete all of the model and paper space tabs. I think you must have one of each. Just as in Excel you can't delete all of the sheets...you must leave one.

Interesting, in version 2000 I thought I could set it up with only a model space tab by not enabeling paper space durring MVsetup. I am using 2005 now and I think you are right. So what I will do is just activate the model tabe with this:

[VBA]ThisDrawing.ActiveSpace = acModelSpace [/VBA]

Thanks!

[fixo]

Hi Rob
Sorry for the late
Glad you solved this problem by yourself
Happy coding

~'J'~

[fixo]

I don't think you can delete all of the model and paper space tabs. I think you must have one of each. Just as in Excel you can't delete all of the sheets...you must leave one.

Thanks, Lucas
I agreed with you
Regards,

~'J'~

[lucas]

Hi fatty,
yeah I use this to delete all paperspace layouts except one...
[VBA]Option Explicit
Sub DeleteLayouts()
Dim adLayout As AcadLayout
On Error Resume Next
If ThisDrawing.ActiveSpace = acPaperSpace Then _
ThisDrawing.ActiveSpace = acModelSpace
For Each adLayout In ThisDrawing.Layouts
adLayout.Delete
Next adLayout
End Sub
[/VBA]

[fixo]

Hi lucas

I could not to delete the last layout
the same as you are
Just manually

Cheers

~'J'~

[RMS]

Hi Rob
Sorry for the late
Glad you solved this problem by yourself
Happy coding

~'J'~

Not a problem at all, I am just learning this stuff so I am struggaling along I am just glad there are people like yourself willing to help out.

[Tommy]

I hesitate to post when I am stuck in the 2000i world.
So with that being said, you have to have Model space and at least one Paper space. As already posted.

Why use scripting? Why not use DIR? IMHO having the reference to MS scripting adds overhead that is not neccessary.

[lucas]

Hi Tommy,
How's the hurricane belt?

[Tommy]

Hey Steve,

Everything's going South of me so far. I am prepared though. I can last a week primitive. After that I start getting worried.

No Gas, No Power, No Computer,

Guess I'll just have to go fishing

[RMS]

.....Why use scripting? Why not use DIR? IMHO having the reference to MS scripting adds overhead that is not neccessary.

Can I find info on "DIR" in AutoCAD2005 VBA help? because I am not familiar with this.

[Tommy]

This is how I would have done the request. This will search the whole directory for dxf files, open them, add a layer, change some things about the layer, deleting all paper space, and save with another file name.
[VBA]
Sub FixMyDXF()
Dim mPath As String, mFileName As String, mNewLyr As AcadLayer
Dim mDoc As AcadDocument, sset As AcadSelectionSet
mPath = "D:\Rob_Souza\Poly\VBATEST\"
mFileName = "*.dxf"
mFileName = Dir(mPath & mFileName)
While mFileName <> ""
Set mDoc = Application.Documents.Open(mPath & mFileName)
DeleteLayouts mDoc
Set mNewLyr = mDoc.Layers.Add("LayerName")
'set layer attributes
mNewLyr.Color = acRed
mNewLyr.Linetype = "CONTINUOUS"
Set sset = mDoc.SelectionSets.Add("TEST")
mDoc.Export Replace(mPath & mFileName, ".DXF", "Rev"), "DXF", sset
mDoc.Close False
Set mDoc = Nothing
Set mNewLyr = Nothing
mFileName = Dir
Wend
End Sub
'Below contributed by lucas
Sub DeleteLayouts(iDoc As AcadDocument)
Dim adLayout As AcadLayout
On Error Resume Next
If iDoc.ActiveSpace = acPaperSpace Then _
iDoc.ActiveSpace = acModelSpace
For Each adLayout In iDoc.Layouts
adLayout.Delete
Next adLayout
Err.Clear
On Error GoTo 0
End Sub

[/VBA]

[RMS]

Tommy, nice job but is there a way to overwrite the existing file name? I have to keep this name the same. I have tried tweaking the code all kinds of ways but it wont overwrite ....

[Tommy]

I thought it was a one line change but it was 3.
If there is anything you don't understand I will be more than happy to explain.
[vba]
Sub FixMyDXF()
Dim mPath As String, mFileName As String, mNewLyr As AcadLayer
Dim mDoc As AcadDocument, sset As AcadSelectionSet, mFxdNm As String
mPath = "D:\Rob_Souza\Poly\VBATEST\"
mFileName = "*.dxf"
mFileName = Dir(mPath & mFileName)
While mFileName <> ""
Set mDoc = Application.Documents.Open(mPath & mFileName)
DeleteLayouts mDoc
Set mNewLyr = mDoc.Layers.Add("LayerName")
'set layer attributes
mNewLyr.Color = acRed
mNewLyr.Linetype = "CONTINUOUS"
Set sset = mDoc.SelectionSets.Add("TEST")
mFxdNm = Replace(mPath & mFileName, ".DXF", "Rev")
mDoc.Export mFxdNm, "DXF", sset
mDoc.Close False
'copy new file over exist file
FileCopy mFxdNm & ".DXF", mPath & mFileName
'delete the new file
Kill mFxdNm & ".DXF"
Set mDoc = Nothing
Set mNewLyr = Nothing
mFileName = Dir
Wend
End Sub[/vba]

EDIT: Changed the Path to the one posted

[RMS]

I thought it was a one line change but it was 3.
If there is anything you don't understand I will be more than happy to explain....

Thanks Tommy that did the trick, wow there is a lot to this stuff! One question though; what is this all about:

[VBA]Set sset = mDoc.SelectionSets.Add("TEST") [/VBA]

On a side note, tonight is my first class in C++, I wanted VB but it is not available this semester. I use AutoCAD alot so I need to know how to code it!

Thanks again,
Rob

[Tommy]

The sset is a selection set which has to be there for the export option to work. It is ignored (according to help) and I don't understand why it is neccessary unless internally they fill it and export it.

LOL C++ is arx in acad. It is actually an external program loaded into acad memory space. You'll need a SDK for that. Have you tried Lisp? Have you learned how to customize the menus?

[lucas]

LOL C++ is arx in acad. It is actually an external program loaded into acad memory space. You'll need a SDK for that. Have you tried Lisp? Have you learned how to customize the menus?

Hi Tommy, Rob will be taking advantage of your signature line if you keep this up Not sure he knows what he's getting himself into.