Po prostu szybko zakodowałem coś, co wydaje się działać.
Po prostu umieść w 2. wierszu ścieżkę do pliku drwdot.
Wtedy będzie musiał zostać ulepszony o pewne zabezpieczenia, aby w żaden sposób go nie uruchamiać.
W tej chwili musisz koniecznie otworzyć MEP, a następnie uruchomić makro (nie otwieraj w międzyczasie pliku, w przeciwnym razie znajdziesz wyodrębnione pliki w tym samym miejscu, co otwarty plik)
'Mettre ci-dessous le chemin vers le modèle de Fond de plan
Const sDrTemplateLaser As String = "U:\Modèle de documents\Mise en plan - Fonds de plan\A4-DECOUPE-b.DRWDOT"
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModel2 As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swDraw2 As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim vSheetNameArr As Variant
Dim vSheetName As Variant
Dim bRet As Boolean
Dim swExportPDFData As SldWorks.ExportPdfData
Dim lErrors As Long
Dim lWarnings As Long
Dim vSheetName2 As Variant
Dim i As Integer
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
' Is document active?
If swModel Is Nothing Then
swApp.SendMsgToUser2 "A Drawing document must be active.", swMbWarning, swMbOk
Exit Sub
End If
' Is it a Drawing document?
If swModel.GetType <> swDocDRAWING Then
swApp.SendMsgToUser2 "A Drawing document must be active.", swMbWarning, swMbOk
Exit Sub
End If
Set swDraw = swModel
Set swSheet = swDraw.GetCurrentSheet
vSheetNameArr = swDraw.GetSheetNames
For Each vSheetName In vSheetNameArr
bRet = swDraw.ActivateSheet(vSheetName): Debug.Assert bRet
swDraw.ViewZoomtofit2
swDraw.ActivateSheet vSheetName
'Debug.Print "Feuille active:" & sheetName
bRet = swDraw.Extension.SelectByID2(vSheetName, "SHEET", 0, 0, 0, False, 0, Nothing, 0)
swModel.EditCopy
Set swDraw2 = swApp.NewDocument(sDrTemplateLaser, 0, 0, 0)
'On supprime la 1ère feuille existantes
vSheetName2 = swDraw.GetSheetNames
Set swModel2 = swApp.ActiveDoc
Set swExt = swModel2.Extension
bRet = swDraw2.PasteSheet(swInsertOption_MoveToEnd, swRenameOption_No)
swDraw2.GetCurrentSheet.SetName vSheetName
Set swModel2 = swApp.ActiveDoc
'*********************************
'On supprime la 1ère feuille existantes
For i = 0 To UBound(vSheetName2) 'Boucle sur toutes les feuilles
Debug.Print vSheetName2(i)
If i = 0 Then
bRet = swExt.SelectByID2(vSheetName2(i), "SHEET", 0, 0, 0, False, 0, Nothing, 0)
'Supprimer la sélection
bRet = swExt.DeleteSelection2(0)
End If
Next
'********************************
swModel2.Extension.SaveAs Path & "\" & vSheetName & ".slddrw", 0, 0, Nothing, lErrors, lWarnings
Next vSheetName
End Sub
rzeczywiście!