Ich habe immer mit der gleichen Datei getestet. das Zeichnen einer Mütze. Die Zeichnung befindet sich in einem anderen Ordner als die Teile, aber die Dateien haben denselben Namen.
Ich habe mir den Code bereits Schritt für Schritt angesehen, und da ich nicht allzu viel darüber weiß, weiß ich nicht, wie ich die Probleme richtig identifizieren soll.
Um das Makro zu starten, habe ich eine Schaltfläche erstellt und es auch mit der Play-Taste versucht.
Ja, für die Unterordner habe ich im Moment nichts anderes getan, als die 3 zu definierenden Variablen eingefügt zu haben. Denn ich versuche, den Code jedes Mal zum Laufen zu bringen. Ich habe den Basiscode genommen, ohne Änderungen vorzunehmen, außer die Revision im Dateinamen zu entfernen.
Es hat einmal funktioniert, ich habe die generierten Dateien gelöscht und neu gestartet und dort hatte ich den folgenden Fehler
Und nein, ich habe den Code der 4. Antwort noch nicht getestet @Cyril.f
Gute Nachricht. Alles, was bleibt, ist, die " Beste Antwort " zu validieren, um diese Diskussion zu schließen.
Und bis bald für neue Makros... In der Zwischenzeit rate ich Ihnen, verschiedene Websites zu konsultieren (nicht immer auf Französisch -Visual Basic- verpflichtet), aber oft didaktisch, um in die Programmierung einzusteigen:
Wenn Sie den Code der 5. Nachricht nehmen, werden die Dateien in die PDF-Verzeichnisse Dwg und Step gelegt. Ich denke, Sie mischen Pinsel mit den verschiedenen Versionen des Makros. Hier das oben bereits erwähnte Beispiel:
In der Tat, so viel für mich, ich habe es nicht gut angeschaut, sorry für all diesen Austausch!
Ich habe nur eine kurze Anmerkung, der STEP-Ordner wird im Zeichnungsordner erstellt, und ich möchte, dass er im Teileordner erstellt wird. Hier ist die Baumstruktur meiner Dateien: 1-Montage 2-teilig / STUFE 3-Zeichnung / PDF - /DWG
Das Hinzufügen von so etwas sollte besser sein (nicht getestet):
'On revient un dossier en arrière puis on ajoute le dossier Pièces
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePath = sFilePath & "Pièces\"
Der Speicherort, an dem der Code hinzugefügt werden soll:
Sicherlich ein \ zu viel oder weniger, was ist der Wert von sFilePath kurz davor? Falls erforderlich, um es zu überprüfen debug.print sFilepath hinzugefügt, direkt unter den vorherigen 3 Zeilen und schauen Sie sich den Wert im Fenster "Ausführung" über die Bearbeitung der Makroanzeige an
Existiert die Dokumentendatei immer und ist sie immer auf die gleiche Weise kodifiziert? Ist es zum Beispiel im Grunde genommen diese Art von Baum? C:\xxxx\Teile C:\xxxx\Zeichnungen
Grundsätzlich nicht optimiert und keine Prüfung, ob die Dateien bereits vorhanden sind:
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
Damit es funktioniert, müssen Sie in den Referenzen " Microsoft Scripting Runtime " auswählen:
In diesem Teil des Codes muss ich ändern, was das Makro funktioniert.
'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
