I am at a complete loss, if I use a "Do While...Loop" I get the error "out of memory" If I use a "For Each....Next" loop and try to build a collection without specifing a range I get "out memory" error and if I specify a range I get a type "mismatch error" what am i doing wrong. It seems like this should be something really simple.
Code:
Sub AddLayers()
Dim layerObj As AcadLayer
Dim color As AcadAcCmColor
Dim LayerName As String
Dim LTname As String
Dim col As New AcadAcCmColor
Dim colLayerList As New Collection
Dim i As Integer
Dim LayerValue As Variant
Dim LayerList As Range
Set xlbook = GetObject(SupPath & "06Layers.xls")
'set reference to Excel file
Set xlsheet = xlbook.Sheets("MasterLayerList")
'set reference to the worksheet
Dim entry As AcadLineType
Dim found As Boolean
found = False
col.ColorMethod = AutoCAD.acColorMethodByACI
Do While xlsheet.Cells <> "" Or xlsheet.Cells <> 0
i = i + 1
LayerName = xlsheet.Cells(i, 3)
Set layerObj = ThisDrawing.Layers.Add(LayerName)
Set col = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
col.ColorIndex = xlsheet.Cells(i, 4)
layerObj.TrueColor = col
LTname = xlsheet.Cells(i, 5)
layerObj.Linetype = LTname
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, LTname, 1) = 0 Then
found = True
Exit For
End If
Next
If Not (found) Then ThisDrawing.Linetypes.Load LTname, "acad.lin"
Loop
End Sub
or
Code:
Sub AddLayers()
Dim layerObj As AcadLayer
Dim color As AcadAcCmColor
Dim LayerName As String
Dim LTname As String
Dim col As New AcadAcCmColor
Dim colLayerList As New Collection
Dim i As Integer
Dim LayerValue As Variant
Dim LayerList As Range
Set xlbook = GetObject(SupPath & "06Layers.xls")
'set reference to Excel file
Set xlsheet = xlbook.Sheets("MasterLayerList")
'set reference to the worksheet
Dim entry As AcadLineType
Dim found As Boolean
found = False
col.ColorMethod = AutoCAD.acColorMethodByACI
colLayerList.Add xlsheet.Cells.Value
For Each LayerValue In colLayerList
i = i + 1
LayerName = xlsheet.Cells(i, 3)
Set layerObj = ThisDrawing.Layers.Add(LayerName)
Set col = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
col.ColorIndex = xlsheet.Cells(i, 4)
layerObj.TrueColor = col
LTname = xlsheet.Cells(i, 5)
layerObj.Linetype = LTname
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, LTname, 1) = 0 Then
found = True
Exit For
End If
Next
If Not (found) Then ThisDrawing.Linetypes.Load LTname, "acad.lin"
Next
End Sub