0 Members and 1 Guest are viewing this topic.
Private Sub CancelButton_Click()End'ends programEnd SubPrivate Sub MergeButton_Click()Dim BlkCol As ObjectDim BlkObj As ObjectDim Obj As ObjectDim Lay As ObjectDim AttObj As VariantDim item As ObjectDim FromLay As StringDim ToLay As StringDim reLay As ObjectDim I As IntegerDim intCount As Integer FromLay = FromLayerList.TextToLay = ToLayerList.TextSet Lay = ThisDrawing.Layers(FromLay)Set BlkCol = ThisDrawing.BlocksFor Each BlkObj In BlkCol If BlkObj.IsLayout = True Then For Each Obj In BlkObj If Obj.ObjectName = "AcDbBlockReference" Then If Obj.HasAttributes = True Then AttObj = Obj.GetAttributes For I = LBound(AttObj) To UBound(AttObj) If AttObj(I).Layer = FromLay Then AttObj(I).Layer = ToLay End If Next AttObj = Obj.GetConstantAttributes For I = LBound(AttObj) To UBound(AttObj) If AttObj(I).Layer = FromLay Then AttObj(I).Layer = ToLay End If Next End If End If If Obj.Layer = FromLay Then Obj.Layer = ToLay End If Next Else For Each item In BlkObj If item.Layer = FromLay Then item.Layer = ToLay End If Next End IfNextIf FromLay <> ToLay Then If FromLay <> "0" Then Lay.Delete End IfEnd IfintCount = FromLayerList.ListCount - 1For I = intCount To 0 Step -1If FromLayerList.Selected(I) = True ThenFromLayerList.RemoveItem IEnd IfNext'ThisDrawing.RegenEnd SubPrivate Sub UserForm_Initialize()Dim Lay As ObjectFor Each Lay In ThisDrawing.Layers FromLayerList.AddItem Lay.Name ToLayerList.AddItem Lay.NameNextEnd Sub
Sub MergeLayers()Dialog1.ShowEnd Sub