Sub CopyLayoutSub()
If Not GetCivilObject() Then Exit Sub
If LCase(GetCurrentLayoutName) = "model" Then
AcEd.WriteMessage(vbLf & "Необходимо открыть лист которую хотите копировать ")
Exit Sub
End If
Dim AcLayoutMng As LayoutManager = LayoutManager.Current
Dim AcLayoutName As String = AcLayoutMng.CurrentLayout
'Dim CurLayoutNumber As Short =
Dim BlockNameArr() As String
Dim Delimiter As String = "_"
Dim Prefix As String = ""
Dim Suffix As String = ""
Dim StartSheetNumber As Short
Dim EndSheetNumber As Short
Dim PrIntOpt As PromptIntegerOptions = New PromptIntegerOptions(vbLf & "Введите конечный номер листа: ")
PrIntOpt.Keywords.Add("Разделитель")
PrIntOpt.AppendKeywordsToMessage = True
PrIntOpt.AllowZero = False
PrIntOpt.AllowNegative = False
Do
Dim PrIntRes As PromptIntegerResult = AcEd.GetInteger(PrIntOpt)
If PrIntRes.Status = PromptStatus.OK Then
EndSheetNumber = PrIntRes.Value
Exit Do
ElseIf PrIntRes.Status = PromptStatus.Keyword Then
Dim PrStrRes As PromptResult = AcEd.GetString(vbLf & "Введите разделитель префикса или суффикса '" &
Delimiter & "' ")
If PrStrRes.Status = PromptStatus.OK Then
If Len(PrStrRes.StringResult) <> 1 Then
AcEd.WriteMessage(vbLf & "Разделитель должен состоять из одного символа. Оставлен разделитель по умолчанию. ")
Else
Delimiter = PrStrRes.StringResult
End If
End If
Else
Exit Sub
End If
Loop
'Далее получаем номер текущего листа и определяем есть ли у него префикс или суффикс
BlockNameArr = GetNumberPrefixSuffix(AcLayoutName, Delimiter)
If IsNumeric(BlockNameArr(0)) Then 'Если в имени листа есть номер
StartSheetNumber = BlockNameArr(0)
If BlockNameArr(1) <> "" Then
Prefix = BlockNameArr(1) 'Номеру листа предшествует префикс
ElseIf BlockNameArr(2) <> "" Then
Suffix = BlockNameArr(2) 'После номера есть суффикс
End If
Else
AcEd.WriteMessage(vbLf & "Имя данного листа не содержит номера или имя слишком сложное. ")
Exit Sub
End If
If StartSheetNumber > EndSheetNumber Then
AcEd.WriteMessage(vbLf & "Номер введенного конечного листа меньше чем значение данного листа. ")
Exit Sub
End If
For i = StartSheetNumber To EndSheetNumber
Dim NewlayoutName As String
If Prefix <> "" Then
NewlayoutName = Prefix & i
ElseIf Suffix <> "" Then
NewlayoutName = i & Suffix
Else
NewlayoutName = i
End If
Copylayout(AcLayoutName, NewlayoutName)
AcLayoutName = NewlayoutName
Next
End Sub
Sub Copylayout(OldName As String, NewName As String)
Using AcTr As Transaction = AcDb.TransactionManager.StartTransaction()
Dim lytDict As DBDictionary = AcTr.GetObject(AcDb.LayoutDictionaryId, OpenMode.ForRead)
'Смортим есть ли такой лист уже в чертеже
If lytDict.Contains(NewName) Then
AcEd.WriteMessage(vbLf & "Лист " & NewName & " уже есть в чертеже. ")
AcTr.Commit()
Return
End If
AcTr.Commit()
End Using
Dim LytMgr As LayoutManager = LayoutManager.Current()
Dim NewLayoutId As ObjectId = LytMgr.CreateLayout(NewName)
Using AcTr As Transaction = AcDb.TransactionManager.StartTransaction()
Dim NewLayout As Layout = AcTr.GetObject(NewLayoutId, OpenMode.ForWrite)
Dim OldlayoutId As ObjectId = LytMgr.GetLayoutId(OldName)
Dim OldLayout As Layout = AcTr.GetObject(OldlayoutId, OpenMode.ForRead)
NewLayout.CopyFrom(OldLayout)
NewLayout.TabOrder = OldLayout.TabOrder + 1
Dim blkTableRec As BlockTableRecord = AcTr.GetObject(OldLayout.BlockTableRecordId, OpenMode.ForRead)
Dim objIdCol As New ObjectIdCollection()
For Each objId As ObjectId In blkTableRec
objIdCol.Add(objId)
Next
Dim idMap As IdMapping = New IdMapping()
AcDb.DeepCloneObjects(objIdCol, NewLayout.BlockTableRecordId,
idMap, False)
AcTr.Commit()
End Using
AcDoc.Editor.Regen()
End Sub