How to plot multiple line in different layers

hope somebody can help me. I have a spread sheet that automatically plots multiple cables in autocad. But macro only plots it on the active layer. Can anybody expand the macro that is I plot 500 cables, it will also create 500 layers (1 new layer per cable). Hope anybody can help. Much appreciated. the macro writes as below:

 

 

 

Public oACAD As Object

 

 

Public Sub Run() ' Run cable insertion

 

Dim dblInsertF(0 To 2) As Double

Dim dblInsertT(0 To 2) As Double

Dim dblInsertM(0 To 2) As Double

 

Dim Ang As Double

Dim objOffset As Variant

Dim junk As Variant

 

Dim objLine As AcadLine

Dim objText As AcadText

Dim layCurrent As AcadLayer

 

Dim oLastRow As Integer

Dim txtCabNo As String

 

Dim xDelta As Double

Dim yDelta As Double

 

oLastRow = Cells(Rows.Count, 1).End(xlUp).Row

 

Set oACAD = Nothing

Set oACAD = GetObject(, "AutoCAD.Application")

oACAD.Visible = True

 

For y = 5 To oLastRow

 

dblInsertF(0) = Cells(y, 4)

dblInsertF(1) = Cells(y, 5)

 

dblInsertT(0) = Cells(y, 6)

dblInsertT(1) = Cells(y, 7)

 

xDelta = ((Cells(y, 4) - Cells(y, 6)) / 2)

yDelta = ((Cells(y, 5) - Cells(y, 7)) / 2)

 

txtCabNo = Cells(y, 1)

 

oLayer = Cells(y, 2)

 

'-----------------------------------------------------------------------

' If the 'From' and 'To' points are the same, then highlight and MsgBox

If dblInsertF(0) = dblInsertT(0) Then

If dblInsertF(1) = dblInsertT(1) Then

MsgBox "From & To points are identical: Line " & y

Range(Cells(y, 4), Cells(y, 7)).Select

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.Color = 255

.TintAndShade = 0

.PatternTintAndShade = 0

End With

GoTo LastLine

End If

End If

'-----------------------------------------------------------------------

'Set objLayer = oACAD.ActiveDocument.ModelSpace.ActiveLayer = oLayer

Set objLine = oACAD.ActiveDocument.ModelSpace.AddLine(dblInsertF, dblInsertT)

'oACAD.ActiveDocument.ModelSpace.ActiveLayer = oLayer

'obj.Layer = 0

'obj.Color = acByLayer

 

objOffset = objLine.Offset(0.25)

junk = objOffset(0).EndPoint

dblInsertT(0) = junk(0)

dblInsertT(1) = junk(1)

junk = objOffset(0).StartPoint

dblInsertF(0) = junk(0)

dblInsertF(1) = junk(1)

oACAD.ActiveDocument.SendCommand "Erase" & vbCr & "Last" & vbCr & vbCr

dblInsertM(0) = dblInsertT(0) + xDelta

dblInsertM(1) = dblInsertT(1) + yDelta

 

Ang = objLine.Angle

Select Case Ang

Case 1.570796 To 4.712389

Ang = Ang + WorksheetFunction.Pi

End Select

 

Set objText = oACAD.ActiveDocument.ModelSpace.AddText(txtCabNo, dblInsertM, 0.25)

objText.StyleName = "Standard"

objText.Alignment = acAlignmentMiddleCenter

objText.TextAlignmentPoint = dblInsertM

objText.Rotate dblInsertM, Ang

objText.Update

 

LastLine:

Next

MsgBox " DONE! "

 

End Sub

 

 

Public Sub Clear()

 

Dim oLastRow As Integer

 

oLastRow = Cells(Rows.Count, 1).End(xlUp).Row

 

'If oLastRow = 5 Then Exit Sub

If Cells(5, 1) = "" Then Exit Sub

 

Range(Cells(5, 1), Cells(oLastRow, ).Select

Selection.ClearContents

With Selection.Interior

.Pattern = xlNone

.TintAndShade = 0

.PatternTintAndShade = 0

End With

 

End Sub

 

'--------------------------------------------------------------------------------------------------------------------------------------------

' Load Data from CCMS

'--------------------------------------------------------------------------------------------------------------------------------------------

Sub Load_CCMS_Data()

 

Dim oSheet As Object

Dim oPath As String

 

Dim oDestBook As String

Dim oSrceSheet As String

Dim oSrceBook As String

Dim oDestSheet As String

Dim oCellVal As String

 

Dim ofound As Integer

 

Dim oRowDestBook As Long

Dim oRowSrceBook As Long

Dim oLastRow As Long

Dim oLastRow2 As Long

 

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

 

On Error GoTo ErrorHandler

 

 

oLastRow = Cells(Rows.Count, 1).End(xlUp).Row

 

oDestBook = ActiveWorkbook.Name

oSrceSheet = ActiveSheet.Name

 

 

'Activate Reference Sheet

Set oSheet = Application.FileDialog(3)

oSheet.InitialFileName = "K:\CS - Construction & Programme\CS74 Electrical\CS74-CCMS\CCMS DUMP" 'Starting directory to find file

oSheet.AllowMultiSelect = False 'Only allow opening of one file

oSheet.Show

 

oPath = oSheet.SelectedItems.Item(1)

 

Workbooks.Open Filename:=oPath, UpdateLinks:=True, ReadOnly:=True 'Open file as read only

oSrceBook = ActiveWorkbook.Name

oDestSheet = ActiveSheet.Name

 

 

'Start Referencing

 

oLastRow2 = Cells(Rows.Count, 1).End(xlUp).Row

 

Windows(oSrceBook).Activate

 

For oRowDestBook = 5 To oLastRow

oCableID = Workbooks(oDestBook).Sheets(oSrceSheet).Cells(oRowDestBook, 1)

 

For oRowSrceBook = 7 To oLastRow2

oCellVal = Workbooks(oSrceBook).Sheets(oDestSheet).Cells(oRowSrceBook, 1)

ofound = StrComp(oCableID, oCellVal, vbTextCompare)

Select Case ofound

Case 0

' Destination Worksheet ' Source Worksheet

Workbooks(oDestBook).Sheets(oSrceSheet).Cells(oRowDestBook, 4) = Workbooks(oSrceBook).Sheets(oDestSheet).Cells(oRowSrceBook, 45) 'Fom Easting

Workbooks(oDestBook).Sheets(oSrceSheet).Cells(oRowDestBook, 5) = Workbooks(oSrceBook).Sheets(oDestSheet).Cells(oRowSrceBook, 46) 'From Northing

Workbooks(oDestBook).Sheets(oSrceSheet).Cells(oRowDestBook, 6) = Workbooks(oSrceBook).Sheets(oDestSheet).Cells(oRowSrceBook, 51) 'To Easting

Workbooks(oDestBook).Sheets(oSrceSheet).Cells(oRowDestBook, 7) = Workbooks(oSrceBook).Sheets(oDestSheet).Cells(oRowSrceBook, 52) 'To Northing

 

GoTo Skip

Case Else

GoTo Skip

End Select

Skip:

Next oRowSrceBook

 

Next oRowDestBook

 

Workbooks(oSrceBook).Close

'MsgBox "Complete"

ErrorHandler:

 

Application.Calculation = xlCalculationAutomatic

 

Application.ScreenUpdating = True

 

End Sub

This is a question about VBA, not lisp, so I have moved your thread to the .NET, ObjectARX & VBA section: http://www.cadtutor.net/forum/forumdisplay.php?69-.NET-ObjectARX-amp-VBA

 

Also, please read the code posting guidelines and edit your post to include code tags around your code: http://www.cadtutor.net/forum/showthread.php?9184-Code-posting-guidelines

If you wrote the code then you have an understanding of Autocad and Vba so "add layer" is the obvious answer. If you did not write code then google "add layer VBA Autocad" and its a good time to learn what the code is doing and include a new sub "addlayer".

 

a quick google

Public Sub AddLayer()

Dim strLayerName As String

Dim objLayer As AcadLayer

 

You can find the rest.

Edited September 27, 2015 by BIGAL

I did not write the code. I was hoping somebody could add that add layer for me.

I think BIGAL gave you two great pieces of advice

 

the first being a strong suggestion as to what you should actually do:

- add a sub (some 'sub AddLayer(layerName as string)' ) by calling which you can add the proper layer after the creation of each new line (i.e. after that 'Set objLine = oACAD.ActiveDocument.ModelSpace.AddLine(dblInsertF , dblInsertT)' statement)

this new sub would be quite straightforward as you can easily find the AcadLayers class "Add" method you need (try googling or via "Autodesk Autocad Active X Reference Guide" that you should be able to reach by simply pressing F1 key provided the cursor is inside any valid VBA autocad statament in any opened module in VBA editor)

you may also want to:

. keep the new layer name connected with your iterator counter (y) so as not to incur in any duplicated name

. precede the above-mentioned "Add" method statement with an "on Error Resume Next" one and also follow it with a "On Error GoTo 0" one, just to prevent your code to stop if trying to add a layer which is already there (unless you don't want that to happen)

- set the new line layer (some 'objLine.Layer=...' statement, where you'd have to put the actual layer name in its right part) to the new one you just created by means of your new 'AddLayer' sub

 

the second, and to my opinion the most important, being to take your time and learn about what you're writing

to give you thorough grasp of what you're doing and, in the end, keep you safe from unwanted behavior

gentlemen thanks for the advise. First I did not write the code], I know nothing of writing the code. I am not really a draftee but an engineer trying to use CAD.

 

"the second, and to my opinion the most important, being to take your time and learn about what you're writing

to give you thorough grasp of what you're doing and, in the end, keep you safe from unwanted behavior"...huh? what are you on about? anyway gentlemen again the replies are much appreciated.

not really a draftee but an engineer

I am an engineer of some 30 + years self taught for most stuff like lisp & VBA. I just Googled and found the addlayer code within a few seconds. Like Ricvba the complete code checks if the layer exists. Setting the current layer can be done by setting the Autocad variable "Clayer" again something you may want to google "setting Autocad Variable"