PDA

View Full Version : How to get object from AutoCAD



Robert
03-29-2007, 09:23 PM
I use VBA to create many objects, but now comes a problem.

Because CAD operater draw some points by hand and random, and if I want to know these coordination, it will take me long time to pick one by one. So I wonder if there's a method to read these exist points and show the coordination directly by VBA?

Tommy
03-30-2007, 12:36 PM
Hi Robert,:hi:

Welcome to VBAX!


draw some points by hand and random
I don't understand this. If you are keeping track of the entities you create you should be able to pull out the ones the CAD person has created.

As to showing the cordinates of an object? That can be done.

I will not be able to post back until Sunday pm.

fixo
03-31-2007, 10:21 AM
I don't understand you exactly too
Do you mean that you have some point
objects?
If so you can use something like this:



Option Explicit
Sub ShowPointCoords()
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim acPoint As AcadPoint
Dim fcode(0) As Integer
Dim fData(0) As Variant
Dim dxfcode, dxfdata
Dim i As Integer
Dim setName As String
' build the filter to select points
fcode(0) = 0
fData(0) = "POINT"
dxfcode = fcode
dxfdata = fData
setName = "$Points$"
' make sure selection set does not exist
For i = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(i).Name = setName Then
ThisDrawing.SelectionSets.Item(i).Delete
Exit For
End If
Next i
Set oSset = ThisDrawing.SelectionSets.Add(setName)
oSset.SelectOnScreen dxfcode, dxfdata
' process each point
For Each oEnt In oSset
Set acPoint = oEnt
Dim dblCoor As Variant
dblCoor = acPoint.Coordinates
MsgBox "X = " & Replace(CStr(dblCoor(0)), ",", ".") & vbNewLine & _
"Y = " & Replace(CStr(dblCoor(1)), ",", ".") & vbNewLine & _
"Z = " & Replace(CStr(dblCoor(2)), ",", ".")
Next
ThisDrawing.Regen acActiveViewport
End Sub


Hope that helps

~'J'~

Robert
04-01-2007, 05:40 PM
I desrcibe wrong, I means Circle.
Assume I put some circel on the drawing, and now I want to know these circle's radius and coordinations on Excel file, how could I do?
I try a program, but it have to pick up circel one by one, can't select whole at one time. It takes time and sometimes miss some circles...
And I have to open an Excel file because I want to put these informations on that.(or I don't need that?)



Sub ShowCirclePoint()
Dim MyXL As Object
Set MyXL = GetObject("D:\My Documents\AutoCAD testing.xls")
Set xlsheet = MyXL.Worksheets("AutoCAD")
xlsheet.cells(1, 1) = "No."
xlsheet.cells(1, 2) = "Easting"
xlsheet.cells(1, 3) = "Northing"
xlsheet.cells(1, 4) = "Elevation"
xlsheet.cells(1, 5) = "Radius"
Dim objAcadEntity As AcadEntity
Dim centerPoint(0 To 2) As Double
Dim circleObj As AcadCircle
Dim radius As Double
Dim cPoint As Variant
Dim mCir As Double
For mCir = 1 To 65000
ThisDrawing.Utility.GetEntity objAcadEntity, varPickedPoint, "Please select Circle"
If TypeOf objAcadEntity Is AcadCircle Then
Set circleObj = objAcadEntity
radius = circleObj.radius
cPoint = circleObj.center
End If
xlsheet.cells(mCir + 1, 1) = mCir
xlsheet.cells(mCir + 1, 2) = cPoint(0)
xlsheet.cells(mCir + 1, 3) = cPoint(1)
xlsheet.cells(mCir + 1, 4) = cPoint(2)
xlsheet.cells(mCir + 1, 5) = radius
Next
End Sub

fixo
04-02-2007, 01:33 AM
Hi Robert
In this case try another routine
Attn: Both Acad and Excel must be open,
just minimize an Excel window


Option Explicit
Sub ShowCirclePoint()
Dim MyXL As Object
Dim xlsheet As Object
Dim xlFileName As String
xlFileName = "D:\My Documents\AutoCAD testing.xls"
Set MyXL = GetObject(xlFileName)
Set xlsheet = MyXL.Worksheets("AutoCAD")
Dim oSset As AcadSelectionSet
Dim fcode(0) As Integer
Dim fData(0) As Variant
Dim dxfcode, dxfdata
Dim i As Integer
Dim setName As String
Dim objAcadEntity As AcadEntity
Dim centerPoint(0 To 2) As Double
Dim circleObj As AcadCircle
Dim radius As Double
Dim cPoint As Variant
Dim mCir As Long
'Build filter to select circles
fcode(0) = 0
fData(0) = "CIRCLE" '<--entity type
dxfcode = fcode
dxfdata = fData
setName = "$Circle$"
On Error GoTo Err_Control
ZoomAll
'Make sure selection set does not exist
For i = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(i).Name = setName Then
ThisDrawing.SelectionSets.Item(i).Delete
Exit For
End If
Next i
Set oSset = ThisDrawing.SelectionSets.Add(setName)
oSset.Select acSelectionSetAll, , , dxfcode, dxfdata
MsgBox "Wait... "
xlsheet.Cells(1, 1) = "No."
xlsheet.Cells(1, 2) = "Easting"
xlsheet.Cells(1, 3) = "Northing"
xlsheet.Cells(1, 4) = "Elevation"
xlsheet.Cells(1, 5) = "Radius"
mCir = 1
'Process each citrcle
For Each objAcadEntity In oSset
Set circleObj = objAcadEntity
radius = circleObj.radius
cPoint = circleObj.Center
xlsheet.Cells(mCir + 1, 1) = mCir
xlsheet.Cells(mCir + 1, 2) = cPoint(0)
xlsheet.Cells(mCir + 1, 3) = cPoint(1)
xlsheet.Cells(mCir + 1, 4) = cPoint(2)
xlsheet.Cells(mCir + 1, 5) = radius
mCir = mCir + 1
Next
xlsheet.UsedRange.Columns.AutoFit
MyXL.SaveAs xlFileName, , , , False
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub


Hth

~'J'~

Robert
04-02-2007, 07:27 PM
Thank you, it really works!

Now I think further more, if I want to know the other type object, I just change the "obj" type and put the right elements, is that right?

Regards,
Robert

fixo
04-02-2007, 11:24 PM
Thank you, it really works!

Now I think further more, if I want to know the other type object, I just change the "obj" type and put the right elements, is that right?

Regards,
Robert
Yes, of course, you are right
Btw, you can to build filter to select several types
something like this:


fcode(0) = 0
fData(0) = "CIRCLE,ELLIPSE,ARC,LINE" '<--entity types separated by comma


Let us know if you need some help again

~'J'~

taj2501
09-05-2016, 12:11 AM
can you tell me basic of vba , suggest any doucument.i am waiting for your good reply

Robert
09-05-2016, 09:32 AM
can you tell me basic of vba , suggest any doucument.i am waiting for your good reply


Suggest you open MicroSoft Office Excel, then press ALT+F11, you will see the VBA windows.

You can use "Help"(F1), copy few code and then test.

Good luck!

burgDD
01-31-2017, 12:15 PM
Ungroup everything in the drawing (i.e., select all and then UNGROUP). Zoom to extents and then delete miscellaneous arcs throughout the drawing.

Yazzo
09-10-2017, 03:43 AM
HI EXPERT VBA CAD

I have one drawing files, VBA code need to export text into excel worksheet, here with some condition. Text on drawing can have specified layer, text should be selected by mouse in order.. one selection text or group (two, three,etc mouse selection as group) text selection with some guide( some enter or what ever step break identification their, to going next selection of one or group text) Those should be put in different specified cells in excel.
ex: one selection text as title (First Column-"A")
four group selection as any remarks (Range "B","C","D","E") - the group of selected text within the cell tab or comma delimiter
i am also trying to do this task, but i am newly in vba cad.. due to time problem, So i expecting from user .. if its possible please give good answer..
and also expecting further related cad vba guide..

Thanks..
Yazzo