Poniżej makro które robi kopie rysunku i usuwa niepotrzebne arkusze:
Sub PodzialNaArkusze()
'sprawdzenie czy otwarte odpowiednie dokumenty
If ThisApplication.Documents.count = 0 Then MsgBox "Brak otwartych dokumentów": Exit Sub
If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then MsgBox "Otwarty dokument nie rysunkiem! ": Exit Sub
Dim oDoc As DrawingDocument
Set oDoc = ThisApplication.ActiveDocument
'Sprawdzenie czy otwary dokument ma wiecej niz jden arkusz
If oDoc.Sheets.count = 1 Then MsgBox "Arkusz posiada tylko jeden arkusz!": Exit Sub
'Nazwy nowych rysunkow
Dim i As Integer
Dim NeuName() As String
ReDim NeuName(1 To oDoc.Sheets.count)
Dim TN As String, ext As String
TN = Mid(oDoc.FullFileName, 1, InStrRev(oDoc.FullFileName, ".") - 1)
ext = Mid(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "."))
For i = LBound(NeuName) To UBound(NeuName)
NeuName(i) = TN & "-" & Replace(oDoc.Sheets.Item(i).name, ":", "_") & ext
If NeuName(i) = "" Then MsgBox "Blad nazwy :" & NeuName(i): Exit Sub
If Not Dir(NeuName(i)) = "" Then MsgBox "Plik o nazwie :" & NeuName(i) & " juz istnieje!": Exit Sub
Next i
'Robimy kopie rysunkow oraz usuwamy niepotrzebne arkusze
Dim oDocN As DrawingDocument
Dim sh As Sheet
For i = 1 To oDoc.Sheets.count
ThisApplication.SilentOperation = True
oDoc.Sheets.Item(i).Activate
oDoc.SaveAs NeuName(i), True
Set oDocN = ThisApplication.Documents.Open(NeuName(i))
'usuwanie arkuszy
For Each sh In oDocN.Sheets
If Not oDocN.ActiveSheet.name = sh.name Then sh.Delete
Next sh
oDocN.Save
oDocN.Close
ThisApplication.SilentOperation = False
Set oDocN = Nothing
Next i
End Sub |