Отправлено: 28.09.07 12:27. Заголовок: Разделение многолистовых чертежей на отдельные листы

Вашему вниманию предлагается макрос по разделению многолистовых чертежей Инвентора на отдельные файлы, содержащие по одному листу. Тестировалось на AIP 11 SP3. Работает с текущим чертежом.

Sub SplitIDW()
' Set a reference to the drawing document.
' This assumes a drawing document is active.
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument

Dim str1 As String

str1 = oDrawDoc.FullFileName

Dim s As Sheet

For Each s In oDrawDoc.Sheets

Dim oDrawDoc1 As DrawingDocument

Set oDrawDoc1 = ThisApplication.Documents.Add(kDrawingDocumentObject)

Call s.CopyTo(oDrawDoc1)

oDrawDoc1.Sheets.Item(1).Delete

Dim str As String

str = s.DrawingViews.Item(1).ReferencedDocumentDescriptor.FullDocumentName

str = Right(str, Len(str) - InStrRev(str, "\"))

str = Left(str, Len(str) - 4)

Dim fname As String

fname = Replace(str1, ".idw", "_" & Replace(s.Name, ":", "_") & "_" & str & ".idw")

Call oDrawDoc1.SaveAs(fname, False)

Call oDrawDoc1.Close
Next
End Sub

 Отправлено: 10.10.07 06:54. Заголовок: Re:

Немного доработал. Добавил активацию листа перед копированием.

Sub SplitIDW()
' Set a reference to the drawing document.
' This assumes a drawing document is active.
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument

Dim str1 As String

str1 = oDrawDoc.FullFileName

Dim s As Sheet

For Each s In oDrawDoc.Sheets

s.Activate

Dim oDrawDoc1 As DrawingDocument

Set oDrawDoc1 = ThisApplication.Documents.Add(kDrawingDocumentObject)

Call s.CopyTo(oDrawDoc1)

oDrawDoc1.Sheets.Item(1).Delete

Dim str As String

str = s.DrawingViews.Item(1).ReferencedDocumentDescriptor.FullDocumentName

str = Right(str, Len(str) - InStrRev(str, "\"))

str = Left(str, Len(str) - 4)

Dim fname As String

fname = Replace(str1, ".idw", "_" & Replace(s.Name, ":", "_") & "_" & str & ".idw")

Call oDrawDoc1.SaveAs(fname, False)

Call oDrawDoc1.Close
Next
End Sub