williamferenal Posted September 26, 2015 Share Posted September 26, 2015 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 Quote Link to comment Share on other sites More sharing options...
Cad64 Posted September 26, 2015 Share Posted September 26, 2015 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 Quote Link to comment Share on other sites More sharing options...
BIGAL Posted September 27, 2015 Share Posted September 27, 2015 (edited) 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 Quote Link to comment Share on other sites More sharing options...
williamferenal Posted September 27, 2015 Author Share Posted September 27, 2015 I did not write the code. I was hoping somebody could add that add layer for me. Quote Link to comment Share on other sites More sharing options...
RICVBA Posted September 27, 2015 Share Posted September 27, 2015 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 Quote Link to comment Share on other sites More sharing options...
williamferenal Posted September 27, 2015 Author Share Posted September 27, 2015 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. Quote Link to comment Share on other sites More sharing options...
BIGAL Posted September 27, 2015 Share Posted September 27, 2015 not really a draftee but an engineerI 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" Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.