Selecting all

[Anonymous]

Hello,

I have a drawing in AutoCAD, now I;am trying to write a VBA Routine That selects the entire drawing, copies it and pastes it into a new drawing. My skills with AutoCAD VBA is so low I don't know how to do this. Can Someone please help me?

[Anonymous]

i'm curious why you don't do either a saveas and create a new copy of the
current document or make a copy of it within the windows environment.


wrote in message news:[email protected]...
Hello,

I have a drawing in AutoCAD, now I;am trying to write a VBA Routine That
selects the entire drawing, copies it and pastes it into a new drawing. My
skills with AutoCAD VBA is so low I don't know how to do this. Can Someone
please help me?

[Anonymous]

well, I shall explain it a little bit. I have an Excel Sheet with a couple of 10.000 file locations of AutoCAD Drawings. My VBA begins with opening the excel sheet and then he opens the first drawing. then I need to select everything and I have to copy it to a New sheet, which I then need to save from an AutoCAD 2007 to a 2000 drawing. Then it closes the drawing and opens the next with a loop.
I've got the VBA routine so far but I can't seem to find the select all, copy and paste actions. Tried a lot of things but I can't seem to get it working. That's Why I asked if someone knew

[Anonymous]

i think maybe the copyobjects method and select method with acSelectionSetAll is what you are looking for.

[ska67can]

instead of copy paste try this

Dim oPref As AcadPreferencesOpenSave

Set oPref = ThisDrawing.Application.Preferences.OpenSave

oPref.SaveAsType = ac2000_dwg

ThisDrawing.SaveAs (Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) & " (V2000).dwg")

[Anonymous]

this works, however, it is essential that I select everything and paste it to a new drawing. Because some drawings are over 10 MB. From those drawings The people make 2000 *.dxf files. These dxf files are needed for machines we use, Like a Laser cutting machine for plates. And these mchines load the dxf files. But they can't handle The dxf coming from the drawings we now have. Because those dxf files are over 5MB or more. When I select the drawing in 2007 and copy it to a new drawing and then save it as an 200 dwg my problem is solved. The 10MB drawing turn into a 5 mb drawing, and my dxf files into 100KB which the laser cutter can handle. So I need the select, copy paste into a new drawing.

[Anonymous]

I tried but I can't seem to make it work properly

[Anonymous]

Have you tried wblock (source 'entire drawing') to 2000 dxf format? Wblock will purge all objects not needed to support
the entities in the drawing.

wrote in message news:[email protected]...
this works, however, it is essential that I select everything and paste it to a new drawing. Because some drawings are over 10 MB.
From those drawings The people make 2000 *.dxf files. These dxf files are needed for machines we use, Like a Laser cutting machine
for plates. And these mchines load the dxf files. But they can't handle The dxf coming from the drawings we now have. Because those
dxf files are over 5MB or more. When I select the drawing in 2007 and copy it to a new drawing and then save it as an 200 dwg my
problem is solved. The 10MB drawing turn into a 5 mb drawing, and my dxf files into 100KB which the laser cutter can handle. So I
need the select, copy paste into a new drawing.

[Anonymous]

I know this is not a popular answer but have you looked at the copyobjects sample in the
help menu which shows how to copy objects to a new drawing...

wrote in message news:[email protected]...
I tried but I can't seem to make it work properly

[Anonymous]

wblock is not what I was looking for.
here is my vba code so far. It works untill the select part. And xxxxxxx is my blank spot where I must select, copy and paste it into a new drawing. But how?

Sub Example_Import()

Dim MyXL As Object ' Variable to hold reference
Dim MyXLSheet As Object
Dim r As Range
Dim n As Integer
Dim Acad As AcadApplication
Dim newdoc As AcadDocument
Dim oPref As AcadPreferencesOpenSave
Dim mode As Integer


'Opening Excel Sheet with drawings

Set MyXL = GetObject(, "Excel.Application")
Set MyXL = GetObject("G:\Probleem Tekeningen\macro_dwg_to_dwg.xls")

MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True

Set MyXLSheet = MyXL.ActiveSheet

'Pasting cells A & B Together

Set r = MyXLSheet.Range("C1:C36391")

For n = 1 To r.Rows.Count

r.Cells(n, 1) = "=CONCATENATE(RC[-1],RC[-2])"

' Open a new drawing

Set Acad = ThisDrawing.Application
Set newdoc = Acad.Documents.Add("acad.dwt")

' Opening Drawing

ThisDrawing.Application.Documents.Open (r.Cells(n, 1))
ThisDrawing.Application.ZoomAll


' Select everything



xxxxxxxxxxxxxxxxx



Set oPref = ThisDrawing.Application.Preferences.OpenSave

oPref.SaveAsType = ac2000_dwg

ThisDrawing.SaveAs (Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) & " (V2000).dwg")

ThisDrawing.Close
Next n

End Sub

[Anonymous]

The wblock was just an option until you got you copyobjects code working... If you post the copyobjects portion we'll take a look to see what's not working.

[Anonymous]

Sub Example_Import()

Dim MyXL As Object ' Variable to hold reference
Dim MyXLSheet As Object
Dim r As Range
Dim n As Integer
Dim Acad As AcadApplication
Dim newdoc As AcadDocument
Dim oPref As AcadPreferencesOpenSave
Dim mode As Integer
Dim DOC0 As AcadDocument
Dim objCollection(0 To 1) As Object
Dim retObjects As Variant
Dim Drawing As AcadDocument
Dim DrawingCopy As AcadDocument
Dim Doc1MSpace As AcadModelSpace
Dim DOC1 As AcadDocument

'Opening Excel Sheet with drawings

Set MyXL = GetObject(, "Excel.Application")
Set MyXL = GetObject("G:\Probleem Tekeningen\macro_dwg_to_dwg.xls")

MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True

Set MyXLSheet = MyXL.ActiveSheet

'Pasting cells A & B Together

Set r = MyXLSheet.Range("C1:C2")

For n = 1 To r.Rows.Count

r.Cells(n, 1) = "=CONCATENATE(RC[-1],RC[-2])"


' Opening Drawing
ThisDrawing.Application.Documents.Open (r.Cells(n, 1))
ThisDrawing.Application.ZoomAll


' Save pointer to the current drawing
Set DOC0 = ThisDrawing.Application.ActiveDocument

' Copy objects
Set objCollection(0) = Drawing


' Create a new drawing and point to its model space
Set DOC1 = Documents.Add
Set Doc1MSpace = DOC1.ModelSpace

' Copy the objects into the model space of the new drawing.
retObjects = DOC0.CopyObjects(objCollection, Doc1MSpace)


' Get the newly created object collection and apply new
' properties to the copies.
Set DrawingCopy = retObjects(0)

ThisDrawing.Application.ZoomAll

MsgBox "Drawing copied."



Set oPref = ThisDrawing.Application.Preferences.OpenSave

oPref.SaveAsType = ac2000_dwg

ThisDrawing.SaveAs (Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) & " (V2000).dwg")

ThisDrawing.Close
Next n

End Sub



This is what I've got, but it will probably don't make any sense.
I don't understand how I should set the whole drawing to the object collection?

[Anonymous]

try this idea...

[code]
Sub test()

Dim ss As AcadSelectionSet
Dim ssName As String
ssName = "ss"
Set ss = ssAll(ssName)

If ss.Count <> 0 Then

ReDim objColl(ss.Count - 1) As Object
Dim i As Integer 'Long if necessary.
For i = 0 To ss.Count - 1

Set objColl(i) = ss(i)

Next i

End If

ss.Delete

End Sub
'Check dxf code 67 if you want paperspace entities.
Function ssAll(ssName As String) As AcadSelectionSet
ssDelete (ssName)
Set ssAll = ThisDrawing.SelectionSets.Add(ssName)
ssAll.Select acSelectionSetAll
End Function

Sub ssDelete(ssName As String)
On Error Resume Next
ThisDrawing.SelectionSets(ssName).Delete
End Sub
[/code]

wrote in message news:[email protected]...
Sub Example_Import()

Dim MyXL As Object ' Variable to hold reference
Dim MyXLSheet As Object
Dim r As Range
Dim n As Integer
Dim Acad As AcadApplication
Dim newdoc As AcadDocument
Dim oPref As AcadPreferencesOpenSave
Dim mode As Integer
Dim DOC0 As AcadDocument
Dim objCollection(0 To 1) As Object
Dim retObjects As Variant
Dim Drawing As AcadDocument
Dim DrawingCopy As AcadDocument
Dim Doc1MSpace As AcadModelSpace
Dim DOC1 As AcadDocument

'Opening Excel Sheet with drawings

Set MyXL = GetObject(, "Excel.Application")
Set MyXL = GetObject("G:\Probleem Tekeningen\macro_dwg_to_dwg.xls")

MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True

Set MyXLSheet = MyXL.ActiveSheet

'Pasting cells A & B Together

Set r = MyXLSheet.Range("C1:C2")

For n = 1 To r.Rows.Count

r.Cells(n, 1) = "=CONCATENATE(RC[-1],RC[-2])"


' Opening Drawing
ThisDrawing.Application.Documents.Open (r.Cells(n, 1))
ThisDrawing.Application.ZoomAll


' Save pointer to the current drawing
Set DOC0 = ThisDrawing.Application.ActiveDocument

' Copy objects
Set objCollection(0) = Drawing


' Create a new drawing and point to its model space
Set DOC1 = Documents.Add
Set Doc1MSpace = DOC1.ModelSpace

' Copy the objects into the model space of the new drawing.
retObjects = DOC0.CopyObjects(objCollection, Doc1MSpace)


' Get the newly created object collection and apply new
' properties to the copies.
Set DrawingCopy = retObjects(0)

ThisDrawing.Application.ZoomAll

MsgBox "Drawing copied."



Set oPref = ThisDrawing.Application.Preferences.OpenSave

oPref.SaveAsType = ac2000_dwg

ThisDrawing.SaveAs (Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) & " (V2000).dwg")

ThisDrawing.Close
Next n

End Sub



This is what I've got, but it will probably don't make any sense.
I don't understand how I should set the whole drawing to the object collection?

[Anonymous]

you could just iterate modelspace if you like... I prefer the ss method.

Dim ent as AcadEntity
For Each ent in ThisDrawing.Modelspace
...
Next ent

"Paul Richardson" wrote in message news:[email protected]...
try this idea...

[code]
Sub test()

Dim ss As AcadSelectionSet
Dim ssName As String
ssName = "ss"
Set ss = ssAll(ssName)

If ss.Count <> 0 Then

ReDim objColl(ss.Count - 1) As Object
Dim i As Integer 'Long if necessary.
For i = 0 To ss.Count - 1

Set objColl(i) = ss(i)

Next i

End If

ss.Delete

End Sub
'Check dxf code 67 if you want paperspace entities.
Function ssAll(ssName As String) As AcadSelectionSet
ssDelete (ssName)
Set ssAll = ThisDrawing.SelectionSets.Add(ssName)
ssAll.Select acSelectionSetAll
End Function

Sub ssDelete(ssName As String)
On Error Resume Next
ThisDrawing.SelectionSets(ssName).Delete
End Sub
[/code]

wrote in message news:[email protected]...
Sub Example_Import()

Dim MyXL As Object ' Variable to hold reference
Dim MyXLSheet As Object
Dim r As Range
Dim n As Integer
Dim Acad As AcadApplication
Dim newdoc As AcadDocument
Dim oPref As AcadPreferencesOpenSave
Dim mode As Integer
Dim DOC0 As AcadDocument
Dim objCollection(0 To 1) As Object
Dim retObjects As Variant
Dim Drawing As AcadDocument
Dim DrawingCopy As AcadDocument
Dim Doc1MSpace As AcadModelSpace
Dim DOC1 As AcadDocument

'Opening Excel Sheet with drawings

Set MyXL = GetObject(, "Excel.Application")
Set MyXL = GetObject("G:\Probleem Tekeningen\macro_dwg_to_dwg.xls")

MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True

Set MyXLSheet = MyXL.ActiveSheet

'Pasting cells A & B Together

Set r = MyXLSheet.Range("C1:C2")

For n = 1 To r.Rows.Count

r.Cells(n, 1) = "=CONCATENATE(RC[-1],RC[-2])"


' Opening Drawing
ThisDrawing.Application.Documents.Open (r.Cells(n, 1))
ThisDrawing.Application.ZoomAll


' Save pointer to the current drawing
Set DOC0 = ThisDrawing.Application.ActiveDocument

' Copy objects
Set objCollection(0) = Drawing


' Create a new drawing and point to its model space
Set DOC1 = Documents.Add
Set Doc1MSpace = DOC1.ModelSpace

' Copy the objects into the model space of the new drawing.
retObjects = DOC0.CopyObjects(objCollection, Doc1MSpace)


' Get the newly created object collection and apply new
' properties to the copies.
Set DrawingCopy = retObjects(0)

ThisDrawing.Application.ZoomAll

MsgBox "Drawing copied."



Set oPref = ThisDrawing.Application.Preferences.OpenSave

oPref.SaveAsType = ac2000_dwg

ThisDrawing.SaveAs (Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) & " (V2000).dwg")

ThisDrawing.Close
Next n

End Sub



This is what I've got, but it will probably don't make any sense.
I don't understand how I should set the whole drawing to the object collection?

[Anonymous]

I got it working! I just used the send command option to select, copy and paste. Now it does everything I want and it works in production!! thanks for your help!!

[Anonymous]

I thought it was working, and it did. Except I get a memory leak somewhere. After every drawing my memory keeps increasing, and doesn't decrease. and after 10 drawings my memory is 2 GB and autocad crashes. What might be the problem? this is my current code

Sub Example_Import()

Dim MyXL As Object ' Variable to hold reference
Dim MyXLSheet As Object
Dim r As Range
Dim n As Integer
Dim Acad As AcadApplication
Dim newdoc As AcadDocument
On Error Resume Next

'Opening Excel Sheet with drawings

Set MyXL = GetObject(, "Excel.Application")
Set MyXL = GetObject("C:\Probleem Tekeningen\macro_dwg_to_dwg.xls")

MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True

Set MyXLSheet = MyXL.ActiveSheet

'Pasting cells A & B Together

Set r = MyXLSheet.Range("C1:C74")

For n = 1 To r.Rows.Count

r.Cells(n, 1) = "=CONCATENATE(RC[-1],RC[-2])"


'Opening Drawing
ThisDrawing.Application.Documents.Open (r.Cells(n, 1))
ThisDrawing.Application.ZoomAll

ThisDrawing.SendCommand "_ai_selall "
ThisDrawing.SendCommand "_copyclip "

ThisDrawing.Close

Set Acad = ThisDrawing.Application
Set newdoc = Acad.Documents.Add("acad.dwt")

ThisDrawing.SendCommand "_pasteclip Specify insertion point: 0,0 "

ThisDrawing.Application.ZoomAll

'Name = r.Cells(n, 1)

ThisDrawing.SaveAs (r.Cells(n, 1))
ThisDrawing.Close
Next n

End Sub