desde Excel a Autocad

Hola guihe,

Te paso un codigo adaptado que empleo para hacer las elipses:
Supone que en B4:G4 tienes los titulos
coord x, coord y, coord z (del centro), radio mayor, angulo girado (grados),
radio menor

Apartir de B5:G5 en cada linea introduces los datos.

El codigo te pide un nombre, crea un archivo en la misma carpeta donde
tienes el fichero de excel donde reside el codigo.
Genera una Layer (capa Puntos) donde va a dibujar las elipses.

Observa la conversion de grados a radianes.
Por otra parte, aparentemente falta la definicion de un procedimiento, o eso
parece, Zoomall.

Si quieres comenta en que lineas se produce el error de tu codigo.


Un saludo,
Juan

Inicio codigo -

Dim WasOpen As Boolean ' To indicate if Acad was already open so You won't
close it in this case

Private Function ConnToAcad() As AcadApplication

Dim Ac As AcadApplication

On Error Resume Next
Err.Clear
Set Ac = GetObject(, "Autocad.Application")
' the error number I've got was 429 for no running Acad.
' "Autocad.Application.16" = 2005
WasOpen = True
If Err Then ' Acad wasn't open
On Error GoTo ConnToAcadError
Set Ac = New AcadApplication
WasOpen = False
End If
On Error GoTo ConnToAcadError

Set ConnToAcad = Ac

On Error GoTo 0
Exit Function

ConnToAcadError:
MsgBox "Error " & Err.Number & " (" & Err.Description & _
") in procedure OpenExcl of Class Module ExcelHandlerCls"
On Error GoTo 0
End Function


Sub Elipse()
Const PI As Double = 3.14159265358979
Dim Cad As AcadApplication
Dim insPoint(0 To 2) As Double 'Declare insertion point
Dim rmax(0 To 2) As Double, ratio As Double

Dim txtStr As String 'Nombre Archivo

Dim i As Integer
Dim nombre As String, respuesta As String
Dim Elipse As AcadEllipse

Dim CapaPuntos As AcadLayer

nombre = InputBox("Introduzca el nombre del proyecto", "Proyecto")
If nombre = "" Then
respuesta = MsgBox("Debe introducir un nombre", vbOKOnly,
"Atención")
Exit Sub
End If

Set Cad = ConnToAcad
Cad.Visible = True 'to test if it's really there.
Set CapaPuntos = Cad.ActiveDocument.Layers.Add("Puntos")

i = 5
Do While Cells(i, 2) <> ""
insPoint(0) = Cells(i, 2)
insPoint(1) = Cells(i, 3)
insPoint(2) = Cells(i, 4)
rmax(0) = Cells(i, 2) + Cells(i, 5) * Cos(Cells(i, 6) * (PI / 180))
rmax(1) = Cells(i, 3) + Cells(i, 5) * Sin(Cells(i, 6) * (PI / 180))
rmax(2) = 0

ratio = Cells(i, 7) / Cells(i, 5)

Set Elipse = Cad.ActiveDocument.ModelSpace.AddEllipse(insPoint,
rmax, ratio)
Elipse.Layer = "Puntos"

i = i + 1
Loop

Cad.ZoomExtents
txtStr = ThisWorkbook.Path & "\" & nombre & ".dwg"
Cad.ActiveDocument.SaveAs txtStr

End Sub
- Fin Codigo


Consulta Original

"guihe" escribió
Hola a todos, tengo una macro escrita en VBA Excel y no me funciona,
el caso es que es similar a una que encontré en la web que si funciona
y la adapté a mis necesidades. El caso es que el codigo inicial crea
unas lineas y yo lo adapté a las elipses y no reconoce el objeto. Os
pongo primero la que SI funciona y después mi adaptación que NO
funciona.
************** Codigo Original *************
' :: Ejemplo para usar AutoCAD desde Excel ::
' :: HispaCAD ::
' :: René ::
' :: Abril 2005 ::

' Nota: dentro del ambiente Editor de Visual Basic debe cargar las
' librerías de AutoCAD en Herramientas > Referencias.

Dim objCad As AcadApplication
Dim objDwg As AcadDocument
Private Function Activar_AutoCAD() As Boolean
On Error Resume Next
Err.Clear
Set objCad = GetObject(, "AutoCAD.Application")
If Err.Number <> 0 Then
answ = MsgBox("Abra AutoCAD!", vbCritical, "Error")
Else
Set objDwg = objCad.ActiveDocument
If Err.Number <> 0 Then
answ = MsgBox("Active un DWG!", vbCritical, "Error")
End If
End If
If Err.Number = 0 Then Activar_AutoCAD = True
If Err.Number <> 0 Then Activar_AutoCAD = False
End Function
Private Sub Dibuja_lineas()
Dim objLine As AcadLine
Dim iniPto(0 To 2) As Double
Dim finPto(0 To 2) As Double
fin = False
fil = 1
Do
fil = fil + 1
xi = Trim(Cells(fil, 1).Value)
yi = Trim(Cells(fil, 2).Value)
xf = Trim(Cells(fil, 3).Value)
yf = Trim(Cells(fil, 4).Value)
If xi = "" Or yi = "" Or xf = "" Or yf = "" Then
fin = True
Else
iniPto(0) = Val(xi)
iniPto(1) = Val(yi)
iniPto(2) = 0
finPto(0) = Val(xf)
finPto(1) = Val(yf)
finPto(2) = 0
Set objLine = objDwg.ModelSpace.AddLine(iniPto, finPto)
End If
Loop Until fin
ZoomAll
End Sub
Private Sub btnInicio_Click()
If Activar_AutoCAD = True Then Call Dibuja_lineas
End Sub
Private Sub btnSalir_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub

************* Codigo adaptado ************
Sub ejec_CAD()
Dim Ejecutar
Ejecutar = Shell("C:\Archivos de programa\AutoCAD 2007\acad.exe",
vbMaximizedFocus)
Call Dibuja_elip
End Sub
Sub Dibuja_elip()
Dim ObjElip As AcadEllipse
Dim Centro(0 To 2) As Double
Dim EjeM(0 To 2) As Double
Dim PropRad As Double
Dim PI
PI = 4 * Atn(1)

For i = 1 To 20
Centro(0) = Cells(i + 1, 15).Value: Centro(1) = Cells(i + 1,
16).Value: Centro(2) = 0
EjeM(0) = (Cells(i + 1, 11).Value / 2) * Cos(Cells(i + 1, 6) *
(180 / PI))
EjeM(1) = (Cells(i + 1, 11).Value / 2) * Sin(Cells(i + 1, 6) *
(180 / PI))
EjeM(2) = 0
diam1 = Cells(i + 1, 11).Value
diam2 = Cells(i + 1, 12).Value
If (diam1 / diam2) < 1 Then
PropRad = (diam1 / diam2)
Else
PropRad = (diam2 / diam1)
End If

'creamos las elipses en Model Space
Set ObjElip = ThisDrawing.ModelSpace.AddEllipse(Centro, EjeM,
PropRad)
Next i
Zoomall
End Sub
*******************************************************
muchas gracias!!