Hi Breizh29
This might be worth a try.
The resulting drawing is very basic but it should be enough to demonstrate the principle.
1/. Open AutoCAD
2/. Press Alt + f11 to open the visual basic editor
Or Tools > Macros > Visual Basic Editor
3/. In the Editor
Insert > Module
4/. Copy and paste all of the code below into this empty module.
5/- Change this Sub to suit the full path name to where you have stored the Sample Excel File attached.
Sub DrawCables()
DrawCablesFromExcelFile "C:\Users\Alistair\AutoCAD\CableTrays.XLS", "Sheet1"
End Sub
5/. Close the editor.
6/. In AutoCAD
Press Alt + f8 to open the Macro Dialogue Box
Or Tools > Macro > Macros........
There will only be one Macro. Select it and Press Run
This routine will open Excel and open file CableTrays.XLS,
Loop through the table, draw each tray and fill it with cables to capacity of the tray.
The number of rows, number of cables per row/layer, and the total number of cables are entered in Excel
If Excel was open when the macro was run it will leave Excel open.
if not it will close the Application.
The cables are *stacked" not "nested" and are allowed to protrude above the tray lip by up to 50% of the cable diameter.
The code is a "mixture" of the two VBa types.
' Required API routines:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Sub DrawCables()
DrawCablesFromExcelFile "C:\Users\Alistair\AutoCAD\CableTrays.XLS", "Sheet1"
End Sub
Sub DrawCablesFromExcelFile(FileNameAndPath As String, SheetName As String)
Dim MyXL As Object
Dim ExcelFound As Boolean
' Check if Excel is running.
On Error Resume Next
Set MyXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then ExcelFound = True
Err.Clear ' Clear Err object in case error occurred.
ExcelFound = DetectExcel
' Set the object variable to reference the file you want to use.
Set MyXL = GetObject(FileNameAndPath)
' Show Microsoft Excel.
MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True
' Draw in AutoCAD
Dim TrayWidth As Double, TrayHeight As Double, CableDia As Double, offsetY As Double
Dim r As Integer
offsetY = 0
r = 2
With MyXL.sheets(SheetName)
.Activate
Do
TrayWidth = CDbl(.cells(r, "A"))
TrayHeight = CDbl(.cells(r, "B"))
CableDia = CDbl(.cells(r, "C"))
NoRows = Int(TrayHeight / CableDia)
If TrayHeight Mod CableDia >= CableDia / 2 Then
NoRows = NoRows + 1
End If
NoCols = Int(TrayWidth / CableDia)
' Enter in Excel
.cells(r, "D") = NoRows
.cells(r, "E") = NoCols
.cells(r, "F") = NoRows * NoCols
DrawTray TrayWidth, TrayHeight, offsetY
DrawCableArray TrayWidth, TrayHeight, CableDia, offsetY
offsetY = offsetY - (2 * TrayHeight)
r = r + 1
If .cells(r, "A") = "" Then Exit Do
Loop
End With
ZoomAll
' If Excel was not open Close Excel else leave it open
If Not ExcelFound Then
MyXL.Application.Quit
End If
' Release reference Excel and spreadsheet.
Set MyXL = Nothing
End Sub
Function DetectExcel() As Boolean
' Function to dectect a running Excel instance and register it.
Const WM_USER = 1024
Dim hWnd As Long
' If Excel running - API call to returns its handle.
hWnd = FindWindow("XLMAIN", 0)
If hWnd = 0 Then ' 0 = Excel not running.
DetectExcel = False
Exit Function
Else ' Excel is running - SendMessage API enters it in the Running Object Table.
SendMessage hWnd, WM_USER + 18, 0, 0
DetectExcel = True
End If
End Function
Private Sub DrawTray(TrayWidth As Double, TrayHeight As Double, offsetY As Double)
Dim aline As AcadLine
Dim startPt(0 To 2) As Double
Dim endPt(0 To 2) As Double
'TrayBase
startPt(0) = 0#: startPt(1) = offsetY: startPt(2) = 0#
endPt(0) = TrayWidth: endPt(1) = offsetY: endPt(2) = 0#
Set aline = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
aline.Update
'TrayWalls
endPt(0) = 0#: endPt(1) = TrayHeight + offsetY: endPt(2) = 0#
Set aline = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
aline.Update
startPt(0) = TrayWidth: startPt(1) = offsetY: startPt(2) = 0#
endPt(0) = TrayWidth: endPt(1) = TrayHeight + offsetY: endPt(2) = 0#
Set aline = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
aline.Update
End Sub
Private Sub DrawCableArray(TrayWidth As Double, TrayHeight As Double, CableDia As Double, offsetY As Double)
Dim cCable As AcadCircle
Dim Centre(0 To 2) As Double
Dim Radius As Double, CableOffset As Double
Radius = CableDia / 2
CableOffset = Int(TrayWidth / CableDia) * CableDia
CableOffset = (TrayWidth - CableOffset) / 2
'Draw first Cable
Centre(0) = Radius + CableOffset: Centre(1) = Radius + offsetY: Centre(2) = 0#
Set cCable = ThisDrawing.ModelSpace.AddCircle(Centre, Radius)
cCable.Update
' Define the Cable Array
Dim NoRows As Long
Dim NoCols As Long
Dim NoLevels As Long
Dim offsetRows As Double
Dim offsetCols As Double
Dim offsetLevels As Double
NoRows = Int(TrayHeight / CableDia)
If TrayHeight Mod CableDia >= CableDia / 2 Then
NoRows = NoRows + 1
End If
NoCols = Int(TrayWidth / CableDia)
NoLevels = 2
offsetRows = CableDia
offsetCols = CableDia
offsetLevels = 1
' Create the array of objects
Dim retObj As Variant
retObj = cCable.ArrayRectangular(NoRows, NoCols, NoLevels, offsetRows, offsetCols, offsetLevels)
ThisDrawing.Regen acActiveViewport
End Sub
I have only tried this in AutoCAD 2005 and Excel 2003, but it should be okay in other versions.
Hope this might be of some help.
LinkBack URL
About LinkBacks
Manipulating Shapes
Register To Reply
Bookmarks