Dibujar en AutoCAD con VBA
Publicado por José A. (6 intervenciones) el 28/12/2021 18:00:46
He descargado un video de youtube (Emacro) Dibujando Líneas.
El video funciona correctamente, escribo el código (creo que igual que en el vídeo) y me salta error.
El código es:
Public Sub DrawLineObjets()
Dim dblStart(2) As Double
Dim dblEnd(2) As Double
Dim startPoint As Point
Dim endPoint As Point
Dim objEnt As AcadLine
Dim points As Variant
Dim k As Integer
Set points = GetRectangle()
'Set points = getStar()
'Set points = getPolygon()
For i = 1 To points.Count
Set startPoint = Point(i)
If (i = points.Count) Then
Set endPoint = Point(i)
Else
Set endPoint = Point(i + 1)
End If
dblStar(0) = startPoint.x: dblStar(1) = startPoint.y: dblStar(2) = 0
dblEnd(0) = endPoint.x: dblEnd(1) = endPoint.y: dblStar(2) = 0
ThisDrawing.Utility.Prompt ("x: " & CStr(startPoint.x) & CStr(startPoint.y)) & vbNewLine
Set objEnt = ThisDrawing.ModelSpace.AddLine(dblStar, dblEnd)
objEnt.Update
ZoomExtents
End Sub
Function GetRectangle()
Dim pnt1 As New Point
Dim pnt2 As New Point
Dim pnt3 As New Point
Dim pnt4 As New Point
Dim points As New Collection
pnt1.SetCoordinates 0, 0, 0
pnt1.SetCoordinates 0, 10, 0
pnt1.SetCoordinates 10, 10, 0
pnt1.SetCoordinates 10, 0, 0
points.Add pnt1
points.Add pnt2
points.Add pnt3
points.Add pnt4
Set GetRectangle = points
End Function
Alguien me puede decir porqué no me funciona.
El video funciona correctamente, escribo el código (creo que igual que en el vídeo) y me salta error.
El código es:
Public Sub DrawLineObjets()
Dim dblStart(2) As Double
Dim dblEnd(2) As Double
Dim startPoint As Point
Dim endPoint As Point
Dim objEnt As AcadLine
Dim points As Variant
Dim k As Integer
Set points = GetRectangle()
'Set points = getStar()
'Set points = getPolygon()
For i = 1 To points.Count
Set startPoint = Point(i)
If (i = points.Count) Then
Set endPoint = Point(i)
Else
Set endPoint = Point(i + 1)
End If
dblStar(0) = startPoint.x: dblStar(1) = startPoint.y: dblStar(2) = 0
dblEnd(0) = endPoint.x: dblEnd(1) = endPoint.y: dblStar(2) = 0
ThisDrawing.Utility.Prompt ("x: " & CStr(startPoint.x) & CStr(startPoint.y)) & vbNewLine
Set objEnt = ThisDrawing.ModelSpace.AddLine(dblStar, dblEnd)
objEnt.Update
ZoomExtents
End Sub
Function GetRectangle()
Dim pnt1 As New Point
Dim pnt2 As New Point
Dim pnt3 As New Point
Dim pnt4 As New Point
Dim points As New Collection
pnt1.SetCoordinates 0, 0, 0
pnt1.SetCoordinates 0, 10, 0
pnt1.SetCoordinates 10, 10, 0
pnt1.SetCoordinates 10, 0, 0
points.Add pnt1
points.Add pnt2
points.Add pnt3
points.Add pnt4
Set GetRectangle = points
End Function
Alguien me puede decir porqué no me funciona.
Valora esta pregunta
0