Ik heb altijd op hetzelfde bestand getest. de tekening van een pet. De tekening staat in een andere map dan de onderdelen, maar de bestanden hebben dezelfde naam.
Ik heb de code al bekeken door het stap voor stap te doen, en aangezien ik er niet al te veel van weet, weet ik niet hoe ik de problemen correct kan identificeren.
Om de macro te starten heb ik een knop gemaakt en ik heb het ook geprobeerd met de play toets.
Ja, voor de submappen heb ik op dit moment niets anders gedaan dan de 3 te definiëren variabelen plakken. Omdat ik elke keer probeer de code te laten werken. Ik heb de basiscode genomen zonder enige wijzigingen aan te brengen, behalve om de revisie in de bestandsnaam te verwijderen.
Het werkte een keer, ik verwijderde de gegenereerde bestanden en begon opnieuw en daar had ik de onderstaande fout
En nee, ik heb de code van het 4e antwoord nog niet getest @Cyril_f
Goed nieuws. Het enige dat overblijft is het valideren van het " Beste antwoord " om deze discussie af te sluiten.
En tot ziens voor nieuwe macro's... In de tussentijd raad ik je aan om verschillende sites te raadplegen (niet altijd in het Frans -Visual Basic- verplicht) maar vaak didactisch om aan de slag te gaan met programmeren:
Als u de code van het 5e bericht neemt, worden de bestanden in de pdf-mappen Dwg en Step geplaatst. Ik denk dat je het mengen van penselen met de verschillende versies van de macro. Hier is het voorbeeld dat hierboven al is genoemd:
Inderdaad, zoveel voor mij heb ik er niet goed naar gekeken, sorry voor al deze uitwisselingen!
Ik heb even een korte notitie, de STEP-map is gemaakt in de map Tekening en ik zou graag willen dat deze wordt gemaakt in de onderdelenmap. Hier is de boomstructuur van mijn bestanden: 1-Vergadering 2-delig / STEP 3-tekening / PDF - /DWG
Het toevoegen van zoiets als dit zou beter moeten zijn (niet getest):
'On revient un dossier en arrière puis on ajoute le dossier Pièces
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePath = sFilePath & "Pièces\"
Zeker een \ te veel of minder, wat is de waarde van sFilePath net ervoor? Indien nodig om het te verifiëren debug.print sFilepath toegevoegd, net onder de vorige 3 regels en kijk naar de waarde in het venster "Uitvoering" via bewerking van de macroweergave
Bestaat het documentenbestand altijd en is het altijd op dezelfde manier gecodificeerd? Kortom, is het bijvoorbeeld dit type boom? C:\xxxx\Onderdelen C:\xxxx\Tekeningen
Kortom, niet geoptimaliseerd en er wordt niet gecontroleerd of de bestanden al bestaan:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swConfig As SldWorks.Configuration
Dim vSheetNameArr As Variant
Dim vSheetName As Variant
Dim I As Long
Dim nDocType As Long
Dim op As Long
Dim suppr As Long
Dim lErrors As Long
Dim lWarnings As Long
Dim boolstatus As Boolean
Dim bRet As Boolean
Dim FileConnu As Boolean
Dim nbConnu As Integer
Dim sModelName As String
Dim sPathName As String
Dim TabConnu(10000) As String
Dim sConfigName As String
Dim sModelFullPath As String
Dim sFilePath As String
Dim sFilePathStep As String
Dim sFileName As String
Dim sFileNameWithoutExtension As String
Dim fs As Scripting.FileSystemObject
Const dxfSubFolder = "dwg\"
Const pdfSubFolder = "pdf\"
Const stepSubFolder = "2 - Pieces\step\"
Sub main()
Set swApp = Application.SldWorks
boolstatus = swApp.SetUserPreferenceIntegerValue(swStepAP, 214) 'Force la version AP214
boolstatus = swApp.SetUserPreferenceIntegerValue(swStepExportPreference, swAcisOutputGeometryPreference_e.swAcisOutputAsSolidAndSurface) 'Force l'export en format Solid/Surface Geometry
Set swModel = swApp.ActiveDoc
' PathName of current model document
sModelFullPath = swModel.GetPathName
' get path name without filename
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePathStep = Left(sFilePath, InStrRev(sFilePath, "\", Len(sFilePath) - 1))
Debug.Print sFilePathStep
' get filename and extension
sFileName = Right(sModelFullPath, Len(sModelFullPath) - InStrRev(sModelFullPath, "\"))
' get filename without extension
sFileNameWithoutExtension = Left(sFileName, InStrRev(sFileName, ".") - 1)
Debug.Print sFilePath & pdfSubFolder & sFileNameWithoutExtension & ".pdf"
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePath & pdfSubFolder)
swModel.Extension.SaveAs sFilePath & pdfSubFolder & sFileNameWithoutExtension & ".pdf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePath & dxfSubFolder)
swModel.Extension.SaveAs sFilePath & dxfSubFolder & sFileNameWithoutExtension & ".dwg", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePathStep & stepSubFolder)
Call ExportStep
End Sub
Function CreateRep(sRep As String)
Set fs = New Scripting.FileSystemObject
If Not fs.FolderExists(sRep) Then
fs.CreateFolder (sRep)
End If
Set fs = Nothing
End Function
Sub ExportStep()
Set swDraw = swModel
vSheetName = swDraw.GetSheetNames
vSheetNameArr = swDraw.GetSheetNames
For Each vSheetName In vSheetNameArr
bRet = swDraw.ActivateSheet(vSheetName): Debug.Assert bRet
Set swView = swDraw.GetFirstView 'Sélectionne le fond de plan
Set swView = swView.GetNextView 'Passe à la vue suivante pour exclure le fond de plan
While Not swView Is Nothing
' Determine if this is a view of a part or assembly
sModelName = swView.GetReferencedModelName
sModelName = LCase(sModelName)
sConfigName = swView.ReferencedConfiguration
FileConnu = False
If InStr(sModelName, "sldprt") > 0 Then
nDocType = swDocPART
ElseIf InStr(sModelName, "slasm") > 0 Then
nDocType = swDocASSEMBLY
Else
nDocType = swDocNONE
Exit Sub
End If
If nDocType = 1 Then
For I = 1 To nbConnu
If UCase(sModelName) & " - " & UCase(sConfigName) = TabConnu(I) Then
FileConnu = True
End If
Next
If Not FileConnu Then
nbConnu = nbConnu + 1
TabConnu(nbConnu) = UCase(sModelName) & " - " & UCase(sConfigName)
Call Export
End If
End If
Set swView = swView.GetNextView
Wend
Next vSheetName
End Sub
Sub Export()
Set swModel = swApp.ActivateDoc3(sModelName, True, swOpenDocOptions_Silent, lErrors)
Set swModel = swApp.ActiveDoc
boolstatus = swModel.ShowConfiguration2(sConfigName)
Set swConfig = swModel.GetActiveConfiguration
sPathName = sFilePathStep & stepSubFolder & sFileNameWithoutExtension & ".step"
If Dir(sPathName, vbHidden) <> "" Then 'Test l'existence du fichier
suppr = MsgBox("Le fichier " & sPathName & " existe déjà, voulez vous le supprimer?", vbYesNo) 'Message utilisateur confirmation de suppression oui/non
If suppr = vbYes Then 'Réponse Oui
Kill (sPathName) 'Suppression du fichier existant
swModel.SaveAs2 sPathName, 0, True, False 'Enregistrement du fichier
op = MsgBox("Le fichier a été enregistré sous " & sPathName & vbNewLine)
Else 'Réponse NON
MsgBox ("Fichier conservé") 'Message utilisateur
End If
Else
swModel.SaveAs2 sPathName, 0, True, False 'Enregistrement du fichier
op = MsgBox("Le fichier a été enregistré sous " & sPathName) 'Message utilisateur
End If
swApp.CloseDoc (sModelName)
Set swModel = swApp.ActiveDoc
End Sub
Om het te laten werken, moet u " Microsoft Scripting Runtime " selecteren in de referenties:
Op dit deel van de code moet ik veranderen wat voor de macro om te werken?
'On revient un dossier en arrière puis on ajoute le dossier Pièces
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePath = sFilePath & "2 - Pièces\"
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier STEP
If Dir(sFilePath & "Step\", vbDirectory) = vbNullString Then
MkDir sFilePath & "Step\"
End If
