DATA EXPORT, NEED HELP PLEASE

[Kalsefar]

I face the same problem every time I export the data from Excel to AutoCAD which is a point exported on location X:0.00 , Y:0.00 , Z:0.00 I don't know why it exports a point in that location ?!

Can someone please help me?

 

This is the code :

_______________________________________________________________________________________________________

Private Sub CommandButton1_Click()

    TextHeight = TextBox30.Text
    If IsNumeric(TextHeight) = False Or TextHeight = 0 Then TextHeight = 0.25
    DeltaX = TextBox31.Text
    DeltaY = TextBox32.Text
    

    Dim qst
    Dim acadObj As Object
    Dim ExcelObj As Object
        On Error Resume Next
    Set acadObj = GetObject(, "AutoCAD.Application")
    If acadObj Is Nothing Then
    qst = MsgBox("AutoCAD Is Not Open. DoYou Want To Open AutoCAD With A New Drawing?", vbYesNo)
    If qst <> vbYes Then Exit Sub
    Set acadObj = CreateObject("AutoCAD.Application")
     Cells(2, 9) = ""
    Command6.Visible = True
    Command7.Visible = True
    End If
    If acadObj Is Nothing Then
    MsgBox "You Have No AutoCad Software In Your Computer." & " Sorry, You Can't Use This Programe Without AutoCad." & vbNewLine & "If You Are Sure You Have AutoCAD In Side Your Computer, Then Please Check VBA Enabeled In AutoCAD.", vbCritical, "CSV TO AUTOCAD"
    Exit Sub
    End If

    '**************************************************************8
If CheckBox5.Value = True Then
        Dim strLayerName1, strLayerName2, strLayerName3, strLayerName4 As String
    Dim objLayer1, objLayer2, objLayer3, objLayer4 As Object

    strLayerName1 = TextBox33.Text
    If "" = strLayerName1 Then Exit Sub       ' exit if no name entered

    On Error Resume Next                 ' handle exceptions inline
    'check to see if layer already exists
    Set objLayer1 = acadObj.ActiveDocument.Layers(strLayerName1)

    If objLayer1 Is Nothing Then
        Set objLayer1 = acadObj.ActiveDocument.Layers.Add(strLayerName1)
        If objLayer1 Is Nothing Then ' check if obj has been set
            lyt = "'" & strLayerName1 & "'" & vbNewLine
        Else
            'MsgBox "Added Layer '" & objLayer.Name & "'"
        End If
    Else
        'MsgBox "Layer already existed"
    End If
'************************************************************
     strLayerName2 = TextBox34.Text
    'If "" = strLayerName2 Then Exit Sub       ' exit if no name entered

    On Error Resume Next                 ' handle exceptions inline
    'check to see if layer already exists
    Set objLayer2 = acadObj.ActiveDocument.Layers(strLayerName2)

    If objLayer2 Is Nothing Then
        Set objLayer2 = acadObj.ActiveDocument.Layers.Add(strLayerName2)
        If objLayer2 Is Nothing Then ' check if obj has been set
            lyt = lyt & "'" & strLayerName2 & "'" & vbNewLine
        Else
            'MsgBox "Added Layer Layer '" & objLayer.Name & "'"
        End If
    Else
        'MsgBox "Layer already existed"
    End If
    End If
'******************************************************************
    Dim basePnt(0 To 2) As Double
    Dim insertPnt(0 To 2) As Double
            Dim strLayerName5 As String
    Dim objLayer5 As Object

    Set ExcelObj = GetObject(, "Excel.Application")
    Set acadObj = GetObject(, "AutoCAD.Application")
    ExcelObj.WindowState = xlMinimized
    acadObj.WindowState = vbMaximizedFocus
    
    Do
        i = i + 1
        If Range("START_1").Offset(i, 0).Value <> "x" And Range("START_1").Offset(i, 0).Value <> "X" Then
            '************************************************
            If CheckBox7.Value = True Then
objLayer5 = Empty
    strLayerName5 = Range("START_1").Offset(i, 4).Text
    If "" = strLayerName5 Then GoTo Dick      ' exit if no name entered

    On Error Resume Next                 ' handle exceptions inline
    'check to see if layer already exists
    Set objLayer5 = acadObj.ActiveDocument.Layers(strLayerName5)

    'If objLayer5 Is Nothing Then
        Set objLayer5 = acadObj.ActiveDocument.Layers.Add(strLayerName5)
        If objLayer5 Is Nothing Then ' check if obj has been set
            lyt = "'" & strLayerName5 & "'" & vbNewLine
        Else
            'MsgBox "Added Layer '" & objLayer.Name & "'"
        End If
    'Else
        'MsgBox "Layer already existed"
    'End If
    End If

        '*********************************************************
Dick:
            basePnt(0) = Range("START_1").Offset(i, 0).Value
            basePnt(1) = Range("START_1").Offset(i, 1).Value
            basePnt(2) = Range("START_1").Offset(i, 2).Value
        If TextBox33.Enabled = True Then acadObj.ActiveDocument.ActiveLayer = acadObj.ActiveDocument.Layers(strLayerName1)
                    If CheckBox7.Value = True Then
        If "" <> strLayerName5 Then acadObj.ActiveDocument.ActiveLayer = acadObj.ActiveDocument.Layers(strLayerName5)
          Else
          If TextBox34.Enabled = False Then acadObj.ActiveDocument.ActiveLayer = acadObj.ActiveDocument.Layers("0")
          End If
pointObj = Nothing
            Set pointObj = acadObj.ActiveDocument.ModelSpace.AddPoint(basePnt)
            If pointObj Is Nothing Then MsgBox ("AutoCAD Not Responding"): Exit Sub
            insertPnt(0) = basePnt(0) + DeltaX
            insertPnt(1) = basePnt(1) + DeltaY
            insertPnt(2) = 0
            
            If pointObj Is Nothing Then acadObj.WindowState = vbMinimizedFocus: ExcelObj.WindowState = xlMaximized: MsgBox "Sorry, AutoCad Application Is Not Responding.", vbCritical
            'Set pointText = acadObj.ActiveDocument.modelspace.AddText(Range("START_1").Offset(i, -1).Value, insertPnt, TextHeight)
        If TextBox34.Enabled = True Then acadObj.ActiveDocument.ActiveLayer = acadObj.ActiveDocument.Layers(strLayerName2)
          
            If CheckBox30.Value = True Then TEXT_POINT = Range("START_1").Offset(i, -1).Value & Chr(10)
            If CheckBox31.Value = True Then TEXT_POINT = TEXT_POINT & "X= " & basePnt(0) & Chr(10)
            If CheckBox32.Value = True Then TEXT_POINT = TEXT_POINT & "Y= " & basePnt(1) & Chr(10)
            If CheckBox33.Value = True Then TEXT_POINT = TEXT_POINT & "Z= " & basePnt(2)
            Set pointText = acadObj.ActiveDocument.ModelSpace.AddMText(insertPnt, 0, TEXT_POINT)
            pointText.Height = TextHeight
            TEXT_POINT = ""
            
            pointObj.Color = Range("START_1").Offset(i, 3).Value
        End If
    Loop Until Range("START_1").Offset(i, 0).Value = ""
    
    'ExcelObj.WindowState = xlMaximized
    'acadObj.WindowState = vbMinimizedFocus
    
    Dim jj
    jj = (i * 3) - 1
    Dim dblVertices() As Double
ReDim dblVertices(jj)
    If CheckBox34.Value = True Then
    'acadObj.Activedocument.ActiveLayer = acadObj.Activedocument.Layers(strLayerName4)
   ' Dim COUNT, CO As Integer
    co = 0
    For Count = 1 To i
    dblVertices(co) = Range("START_1").Offset(Count, 0).Value
    co = co + 1
    dblVertices(co) = Range("START_1").Offset(Count, 1).Value
    co = co + 1
    dblVertices(co) = Range("START_1").Offset(Count, 2).Value
    co = co + 1
    Next Count
    Set objEnt = acadObj.ActiveDocument.ModelSpace.Add3DPoly(dblVertices)

End If

End Sub

 

 

[PeterPan9720]

Hi @Kalsefar

what's the behavior if you ask to draw a line on Autocad area starting from 0,0 ? did you try ? just to check where are your 0,0 coords.

You can do this before running your code in order to understand if the issue it's on the drawing or in your code.

Reading your code Autocad could be open before or after running the excel procedure, so you can open Autocad, new drawing (or existing if required) and trace a line from 0,0 coordinates.

Your code, It's too complex to test only you know what the final scope.

Let us know

Edited October 25, 2020 by PeterPan9720

[goran]

 

Dim qst
    Dim acadObj As Object
    Dim ExcelObj As Object
        On Error Resume Next
    Set acadObj = GetObject(, "AutoCAD.Application")
    If acadObj Is Nothing Then
    qst = MsgBox("AutoCAD Is Not Open. DoYou Want To Open AutoCAD With A New Drawing?", vbYesNo)
    If qst <> vbYes Then Exit Sub

.......

Then again:

   

 Dim objLayer5 As Object

    Set ExcelObj = GetObject(, "Excel.Application")
    Set acadObj = GetObject(, "AutoCAD.Application")
    ExcelObj.WindowState = xlMinimized
    acadObj.WindowState = vbMaximizedFocus

 

From where do you run this code, from Ecel or Autocad?

You can put break point(s) in your code, try in Dick: () place, check what Range("START_1").Offset(i, 0).Value returns.

Another thing, attach Excel file so if anyone want's to try your code...

 

At the end

  For Count = 1 To i
    dblVertices(co) = Range("START_1").Offset(Count, 0).Value
    co = co + 1
    dblVertices(co) = Range("START_1").Offset(Count, 1).Value
    co = co + 1
    dblVertices(co) = Range("START_1").Offset(Count, 2).Value
    co = co + 1
    Next Count

Once again same Value thing, this is slow. Loop first from excel, colect all data and then loop through array maybe (in .Net there is Point3dCollection[] or Point2dCollection for lwpolylines).

 

Edited March 23, 2021 by goran