Drawing 3d poly via excel vba code

Drawing 3d poly via excel vba code

savic767
Observer Observer
594 Views
1 Reply
Message 1 of 2

Drawing 3d poly via excel vba code

savic767
Observer
Observer

Greetings and help needed
I have vba excel code for drawing 3dpoly, but I can't set the condition from which point to draw a line for me. The condition is in column "F" as "SL" (startline) and "EL" as endline. Which means he wants me to draw a line from SL to EL. Thank you in advance

Sub otac()

Dim acadApp As Object
Dim acadDoc As Object
Dim LastRow As Long
Dim i As Long
Dim Point() As Double
Dim j As Long
Dim linija As Acad3DPolyline
Dim k As Long
Dim kod As Range
Dim kodv As Variant
Dim kode As Long
Dim kods As Long
Dim x As Long
Dim cell As Range


With Sheets("Coordinates")
     .Activate
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  End With
  
  If LastRow < 2 Then
  MsgBox "Nema koordinata!", vbCritical, "Upozorenje"
  Exit Sub
  End If
  
  On Error Resume Next
  Set acadApp = GetObject(, "AutoCAD.Application")
  
  If acadApp Is Nothing Then
  Set acadApp = CreateObject("AutoCAD.Application")
  acadApp.Visible = True
  End If
  
  On Error Resume Next
  Set acadDoc = acadApp.ActiveDocument
  If acadDoc Is Nothing Then
  Set acadDoc = acadApp.Documents.Add
  End If
  
  If acadDoc.ActiveSpace = 0 Then
  acadDoc.ActiveSpace = 1
  End If
  
  ReDim Point(3 * (LastRow - 1) - 1)
    
    'Pass the coordinates to array.
    Set kod = Range("F").Value
    
    
    k = 0
    For i = 2 To LastRow
        For j = 2 To 4
            Point(k) = Sheets("Coordinates").Cells(i, j)
            k = k + 1
         
        
        
        Next j
    Next i
    
   Set linija = acadDoc.ModelSpace.Add3DPoly(Point)
    linija.Closed = False
    linija.Update

        
    
    
 
      
  acadApp.ZoomExtents
  
  Set acadDoc = Nothing
  Set acadApp = Nothing
  

MsgBox "KARTIRANO", vbInformation, "INFO"



End Sub
0 Likes
595 Views
1 Reply
Reply (1)
Message 2 of 2

Ray-Sync
Advocate
Advocate

El código me funciona perfecto. Permite dibujar polilíneas en 3d.

jefer_ing_0-1665330998872.pngjefer_ing_1-1665331072253.pngjefer_ing_2-1665331095502.png

 

jefferson
0 Likes