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!!

On 5 nov, 11:20, "Juan M" wrote:

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!!

Juan muchisimas gracias, llevaba una par de dias dandome de cabezazos
contra los codigos y siempre pasaba algo
GRACIAS!