VBA
Discuss AutoCAD ActiveX and VBA (Visual Basic for Applications) questions here.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Extracting elevations from a 3D line

5 REPLIES 5
SOLVED
Reply
Message 1 of 6
OceanaPolynom
437 Views, 5 Replies

Extracting elevations from a 3D line

Given a 3D line object and a csv file  of 3D points, I want to find the elevation on the line that is nearest to each point.  The points are close to the line, <0.25 cm.

Thank you

John

 

5 REPLIES 5
Message 2 of 6
saboh12617
in reply to: OceanaPolynom

Hello,

  • Supposing the vertical axis is z.
  • Supposing you might have more points in your CSV than vertices on the 3DPolyline.
  • Supposing the CSV is organized such as column A: x values, B: y values, C: z values.
  • Supposing there is not a ton of points otherwise another algorithm would be faster.
  • Supposing the 3DPolyline is not vertical so the distance is not only checked on the z value but on the global 3D distance.
  • Supposing the CSV file is not ordered (so all points have to be checked).

You can check, for each point of the CSV, the distance to all the points in the line and find the closest one.
 
I wrote this code for an Excel VBA macro which should work, to give you an idea on how to deal with the problem. Since I never wrote macros for CSV files it converts it to an xlsx file. It creates a 2D array with, for each of the CSV Rows, the point coordinates on the line which is closest to the CSV row point. You can adapt it if you want to use it in a different way.
 
Probably some tweaking to do since you gave few informations.
Best regards.
 

 

 

 

 

Private xlsxFile As Workbook

Sub main()
  ' main function call, your CSV file path here
  getClosestPoints "C:\Book1.csv"
End Sub

Sub openCSV(csvFilePath As String)
  Set xlsxFile = Workbooks.Open(csvFilePath, local:=True)
  xlsxFile.SaveAs Filename:=Replace(csvFilePath, ".csv", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

Function getClosestPoints(csvFilePath As String) As Double()

  ' converting the CSV file to a excel file for ease of use
  openCSV csvFilePath
  
  Dim acadApp As AcadApplication, ThisDrawing As AcadDocument
  Set acadApp = GetObject(, "AutoCAD.Application")
  Set ThisDrawing = acadApp.ActiveDocument

  AppActivate acadApp.Caption
  acadApp.ZoomAll

  ' picking the line in the drawing
  On Error GoTo pickline
  Dim line As Acad3DPolyline
pickline:
  ThisDrawing.Utility.GetEntity line, ptx
  On Error GoTo 0
  
  Dim linePts As Variant
  linePts = line.Coordinates

  Dim endI As Long, endJ As Long
  endI = xlsxFile.Worksheets(1).Range("A1").End(xlDown).row
  endJ = (UBound(linePts) + 1) \ 3 - 1
  
  Dim closePtsList() As Double
  ReDim closePtsList(1 To endI, 0 To 2)
  Dim minDist As Double, indexDist As Long, currentDist As Double
  Dim i As Long, j As Long, k As Long
  
  
  ' reading all the lines of the CSV
  For i = 1 To endI
    minDist = 1000000#
    ' reading the points of the line
    For j = 0 To endJ
      ' calculating the distance from the CSV point to the line point
      currentDist = distance( _
        CDbl(linePts(3 * j)), CDbl(linePts(3 * j + 1)), CDbl(linePts(3 * j + 2)), _
        getCSVXYZ(i, 1), getCSVXYZ(i, 2), getCSVXYZ(i, 3) _
      )
      ' if current distance is minimal, save its index
      If minDist > currenDist Then
        minDist = currentDist
        indexDist = j
      End If
    Next j
    
    ' copying the point in the return list, or copy it to your workbook if you prefer
    For k = 0 To 2
      closePtsList(i, k) = CDbl(linePts(3 * indexDist + k))
      ' Debug.Print closePtsList(i, k)
    Next k
    
  Next i

  ' returning the array
  getClosestPoints = closePtsList
End Function

Function getCSVXYZ(row As Long, col As Long) As Double
  getCSVXYZ = xlsxFile.Worksheets(1).Cells(row, col).Value
End Function

Function distance(x1 As Double, y1 As Double, z1 As Double, _
  x2 As Double, y2 As Double, z2 As Double) As Double
  ' Returns the distance between two 3D points
  ' pt1 and pt2 are (x: Double, y: Double, z: Double)
  distance = Sqr( _
    (x1 - x2) ^ 2 + _
    (y1 - y2) ^ 2 + _
    (z1 - z2) ^ 2 _
  )
End Function

 

 

 

 

 
Message 3 of 6
OceanaPolynom
in reply to: saboh12617

I solved this problem with VBA inside AutoCad.  I will post soon

 

Thank you

John

Message 4 of 6

I solved this problem using VBA inside AutoCad.  I have attached 3 files. Create a UserForm and on it put a Textbox called TextBoxMaxOff with a default value of 1, and a CommandButton called CommandButtonInverse.  The chainage of the start point of the line is -11.684 as indicated on Design Center Line 01.dwg.  To run the example first load Design Center Line 01.dwg into Autocad.  Click CommandButtonInverse to run the code.

Private Sub CommandButtonInverse_Click()
    Dim startPoint As Variant
    Dim endPoint As Variant
    Dim returnobj As AcadObject
    Dim centerPoint As Variant
    Dim TxtObj As AcadText
    Dim TextPosition(0 To 2) As Double
 FileName$ = testShell: ' pick file name and path
   
    If Trim(FileName$) = "" Then
        MsgBox ("You must select a file")
        Exit Sub
    End If
  
  
  Open FileName$ For Input As #1
   
   outfile$ = Left(FileName, Len(FileName) - 4)
   outfile$ = outfile$ & "OUT.csv"
   
   Open outfile$ For Output As #2
   cov! = Val(TextBoxMaxOff)
   pi# = 3.14159265358979
RETRY:
    
    UserForm7.Hide
    getentityprompt$ = "Select a Line Object or Arc Object or a Text Object"
    
     ThisDrawing.Utility.GetEntity returnobj, startPoint, getentityprompt$
    
    If escendflag Then
        ' no object selected
        Err.Clear
        'MsgBox "No Object Selected", , "Select Text"
        GoTo RETRY
    Else
        'some object selected
        returnobj.Update
        
        returnobj.Update
        GoTo wichobject
    End If
    
    GoTo RETRY
    
wichobject:
        If TypeOf returnobj Is AcadLine Then
            'MsgBox "Life is Good"
            'added on May 28, 2024
            startchainage# = InputBox("Input the Chainage of the Start Point")
            'end of addition May 28, 2024
            Set lineObj = returnobj
            startPoint = lineObj.startPoint
            endPoint = lineObj.endPoint
            ya# = startPoint(0)
            xa# = startPoint(1)
            yb# = endPoint(0)
            xb# = endPoint(1)
            GoSub azimuth
            If az < 0 Then az = az + 2 * pi
            azatob# = az
            dab! = d
            'added on May 28, 2024
            za# = startPoint(2)
            zb# = endPoint(2)
            slope# = (zb - za) / dab
            'end of addition May 28, 2024
           
            Do
                Input #1, ptr$, yb#, xb#, zp!
                'June 22 2023
                yp# = yb#: xp# = xb#
                '
                GoSub azimuth: '  azimuth A to P
                If az < 0 Then az = az + 2 * pi
                If az > azatob Then
                    ang# = az - azatob#
                Else
                    ang# = azatob# - az
                End If
                off! = Sin(ang#) * d
                online! = Cos(ang#) * d
                'added on May 28, 2024
                zd# = za + (d * slope)
                chain# = startchainage + online
                'end of addition May 28, 2024
                If online! > 0 And online! < dab! And ang# < pi# / 2 Then
                    
                    'output ptr and horizontal deviation and design elevation and chainage
                    If (off! < cov!) Then Print #2, ptr$ & " , " & Format(off!, "###0.000") & " , " & Format(zd, "###0.000") & " , " & Format(chain, "###0.000")
                    'June 22 2023
                    
                    If (off! < cov!) Then
                        TextPosition(0) = yp#: TextPosition(1) = xp#: TextPosition(2) = 0#
                        
                        'print horizontzal deviation and design elevation and chainage in Autocad
                        ts$ = Format(off!, "###0.000") & "  " & Format(zd, "###0.000") & "  " & Format(chain, "###0.000")
                        Set TxtObj = ThisDrawing.ModelSpace.AddText(ts$, TextPosition, 0.12)
                        
                    End If
                    '
                End If
                'End If
            Loop Until EOF(1)
            Close 2
            
            
            
            openfiled (outfile$)
            'make breakpoint on close 1 until you solve the problem
            Close 1
            GoTo getout
            'Open FileName For Input As #1
            'Open outfile$ For Output As #2
            GoTo RETRY
    End If
    MsgBox "You must select a line"
getout:    Exit Sub
            '***************************************************subroutines******************************************************************************
azimuth:
900 dx = xb - xa: dy = yb - ya
    d = Sqr((dx * dx) + (dy * dy))
    If dx <> 0 And dy <> 0 Then az = Atn(dy / dx)
910 If dx = 0 And dy = 0 Then MsgBox ("station and target have same name or co-ordinates")
920 If dx = 0 And dy > 0 Then az = pi# / 2: Exit Sub
930 If dx = 0 And dy < 0 Then az = 1.5 * pi#: Exit Sub
940 If dy = 0 And dx > 0 Then az = 0: Exit Sub
950 If dy = 0 And dx < 0 Then az = pi#: Exit Sub
960 If dy < 0 And dx < 0 Or dy > 0 And dx < 0 Then az = az + pi#: ' Exit Sub Else Exit Sub
Return
End Sub
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
      Private Declare Function ShellExecute Lib "shell32.dll" Alias _
      "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _
      String, ByVal lpszFile As String, ByVal lpszParams As String, _
      ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
    Sub openfiled(instring$)
                Dim r As Long, msg As String
          'r = StartDoc("C:\John\downloads\170313\P_Biz_A_451_37_5.dwg")
          r = StartDoc(instring$)
          If r <= 32 Then
              'There was an error
              Select Case r
                  Case SE_ERR_FNF
                      msg = "File not found"
                  Case SE_ERR_PNF
                      msg = "Path not found"
                  Case SE_ERR_ACCESSDENIED
                      msg = "Access denied"
                  Case SE_ERR_OOM
                      msg = "Out of memory"
                  Case SE_ERR_DLLNOTFOUND
                      msg = "DLL not found"
                  Case SE_ERR_SHARE
                      msg = "A sharing violation occurred"
                  Case SE_ERR_ASSOCINCOMPLETE
                      msg = "Incomplete or invalid file association"
                  Case SE_ERR_DDETIMEOUT
                      msg = "DDE Time out"
                  Case SE_ERR_DDEFAIL
                      msg = "DDE transaction failed"
                  Case SE_ERR_DDEBUSY
                      msg = "DDE busy"
                  Case SE_ERR_NOASSOC
                      msg = "No association for file extension"
                  Case ERROR_BAD_FORMAT
                      msg = "Invalid EXE file or error in EXE image"
                  Case Else
                      msg = "Unknown error"
              End Select
              MsgBox msg
          End If
End Sub


     Function StartDoc(DocName As String) As Long
          Dim Scr_hDC As Long
          Scr_hDC = GetDesktopWindow()
          StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
          "", "C:\", SW_SHOWNORMAL)
      End Function
Function testShell()
'https://stackoverflow.com/questions/21559775/vbscript-to-open-a-dialog-to-select-a-filepath
Set wShell = CreateObject("WScript.Shell")
Set oExec = wShell.Exec("mshta.exe ""about:<input type=file id=FILE><script>FILE.click();new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);</script>""")
sFileSelected = oExec.StdOut.ReadLine
testShell = sFileSelected
End Function
Message 5 of 6
Ed.Jobe
in reply to: OceanaPolynom

Glad you figured it out, but you don't need to declare most of those api's. They have VBA type libraries that you can reference, e.g. Microsoft Shell Controls and Automation for shell32.dll, Microsoft Scripting Runtime for scrrun.dll. Plus, AutoCAD has a builtin SHELL command. VBA has the built in Scripting.FileSystemObject  you can use to read/write files. Also, you have a lot of variables that are not declared. If you put "Option Explicit" in your module's header, it will alert you when you use a variable that is not declared.

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 6 of 6
OceanaPolynom
in reply to: Ed.Jobe

Thanks very much for the update
John

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Technology Administrators


Autodesk Design & Make Report