Here I am again.....
The "InsertButton_Click" is code posted by Barry Clark earlier in this post. I have been hacking away at this part with no luck. This will create the layer but does nothing after that....namely the insertion.
All of the files I am using are attached in the zip and the code is posted below for quick viewing.
Can anyone give me a clue?
Option Explicit
Dim arrName1() As Variant
Dim arrName2() As Variant
Dim arrName3() As Variant
Dim blkName As String
Dim blkColor As Integer
Dim blkLayer As String
Dim blkLType As String
Const MyPath As String = "C:\"
Private Sub UserForm_Initialize()
Dim arrType1() As String
Dim arrType2() As String
Dim arrType3() As String
Dim arrTmp As Variant
Dim strTmp As String
Dim fFile As Integer
Dim I As Long
ReDim arrType1(0 To 999)
ReDim arrType2(0 To 999)
ReDim arrType3(0 To 999)
fFile = FreeFile
'**** Type 1
Open MyPath & "_Type1.txt" For Input As #fFile
'Need to skip the first 4 lines
For I = 0 To 4
Line Input #fFile, strTmp
Next
I = 0
While strTmp <> "" 'this will stop it once it encounters a blank line
arrType1(I) = strTmp
I = 1 + I
Line Input #fFile, strTmp
Wend
Close #fFile
ReDim Preserve arrType1(0 To I - 1)
ReDim arrName1(0 To I - 1, 0 To 4)
For I = 0 To UBound(arrType1)
arrTmp = Split(arrType1(I), ",")
arrName1(I, 0) = arrTmp(0)
arrName1(I, 1) = arrTmp(1)
arrName1(I, 2) = arrTmp(2)
arrName1(I, 3) = arrTmp(3)
arrName1(I, 4) = arrTmp(4)
Next
'End of Type 1
'**** Type 2
Open MyPath & "_Type2.txt" For Input As #fFile
'Need to skip the first 4 lines
For I = 0 To 4
Line Input #fFile, strTmp
Next
I = 0
While strTmp <> "" 'this will stop it once it encounters a blank line
arrType2(I) = strTmp
I = 1 + I
Line Input #fFile, strTmp
Wend
Close #fFile
ReDim Preserve arrType2(0 To I - 1)
ReDim arrName2(0 To I - 1, 0 To 4)
For I = 0 To UBound(arrType2)
arrTmp = Split(arrType2(I), ",")
arrName2(I, 0) = arrTmp(0)
arrName2(I, 1) = arrTmp(1)
arrName2(I, 2) = arrTmp(2)
arrName2(I, 3) = arrTmp(3)
arrName2(I, 4) = arrTmp(4)
Next
'End of Type 2
'**** Type 3
Open MyPath & "_Type3.txt" For Input As #fFile
'Need to skip the first 4 lines
For I = 0 To 4
Line Input #fFile, strTmp
Next
I = 0
While strTmp <> "" 'this will stop it once it encounters a blank line
arrType2(I) = strTmp
I = 1 + I
Line Input #fFile, strTmp
Wend
Close #fFile
ReDim Preserve arrType2(0 To I - 1)
ReDim arrName3(0 To I - 1, 0 To 4)
For I = 0 To UBound(arrType2)
arrTmp = Split(arrType2(I), ",")
arrName3(I, 0) = arrTmp(0)
arrName3(I, 1) = arrTmp(1)
arrName3(I, 2) = arrTmp(2)
arrName3(I, 3) = arrTmp(3)
arrName3(I, 4) = arrTmp(4)
Next
'End of Type 3
''Provide a default button, usually the first in the list
OptionButton1.Value = True
End Sub
Private Sub ListBox1_Click()
Dim I As Integer
I = ListBox1.ListIndex
blkName = ListBox1.List(I, 1)
blkLayer = ListBox1.List(I, 2)
blkColor = ListBox1.List(I, 3)
blkLType = ListBox1.List(I, 4)
End Sub
Private Sub OptionButton1_Click()
If OptionButton1.Value = True Then
ListBox1.Clear
ListBox1.List = arrName1
ListBox1.ListIndex = 0
End If
End Sub
Private Sub OptionButton2_Click()
If OptionButton2.Value = True Then
ListBox1.Clear
ListBox1.List = arrName2
ListBox1.ListIndex = 0
End If
End Sub
Private Sub OptionButton3_Click()
If OptionButton3.Value = True Then
ListBox1.Clear
ListBox1.List = arrName3
ListBox1.ListIndex = 0
End If
End Sub
Private Sub CancelButton_Click()
Unload Me
End Sub
Sub InsertButton_Click()
Dim inspnt As Variant
Dim blkref As AcadBlockReference
Dim curLayer As String
curLayer = ThisDrawing.ActiveLayer.Name
Dim layer As AcadLayer
'''
On Error GoTo err_han
'''
For Each layer In ThisDrawing.Layers
If 0 = StrComp(layer.Name, blkLayer, vbTextCompare) Then
ThisDrawing.ActiveLayer = ThisDrawing.Layers(blkLayer)
Else: ThisDrawing.Layers.Add blkLayer
ThisDrawing.ActiveLayer = ThisDrawing.Layers(blkLayer)
End If
Next layer
For Each layer In ThisDrawing.Layers
If layer.Name = blkLayer Then
layer.color = blkColor
layer.Linetype = blkLType
End If
Next layer
If ThisDrawing.ActiveSpace = acModelSpace Then
inspnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Pick Insertion Point: ")
Set blkref = ThisDrawing.ModelSpace.InsertBlock(inspnt, blkName, 1, 1, 1, 0)
End If
If ThisDrawing.ActiveSpace = acPaperSpace Then
inspnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Pick Insertion Point: ")
Set blkref = ThisDrawing.PaperSpace.InsertBlock(inspnt, blkName, 1, 1, 1, 0)
End If
ThisDrawing.ActiveLayer = ThisDrawing.Layers(curLayer)
ThisDrawing.Application.Update
Exit Sub
err_han:
Debug.Print Err.Number & Err.Description
Exit Sub
End Sub