Ik ben op zoek naar een manier om de weg te vinden naar een VBA-onderdeel dat in een tekening is ingevoegd.
Mijn scenario is als volgt:
Ik heb mijn kamer die open is, ik maak een tekening van mijn kamer en ik wil een automatische opname maken in een ander formaat. Maar ik zie niet in hoe ik de weg terug naar mijn stuk uit de tekening kan halen.
Heeft iemand van jullie de oplossing? Omdat hij zeker een oplossing heeft, heb ik geprobeerd te kijken, maar die heb ik nog niet gevonden...
Sub ExportDrawingWithReferencedPartToPDFandDXF()
' Déclaration des variables
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swModelInView As SldWorks.ModelDoc2
Dim partFilePath As String
Dim drawingFilePath As String
Dim exportPDFPath As String
Dim exportDXFPath As String
Dim errors As Long
Dim warnings As Long
' Initialisation de SolidWorks
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
' Vérification que le document actif est bien une mise en plan
If swModel.GetType <> swDocDRAWING Then
MsgBox "Le document actif n'est pas une mise en plan."
Exit Sub
End If
' Caster le document en tant que DrawingDoc
Set swDraw = swModel
' Récupérer la première vue contenant le modèle
Set swView = swDraw.GetFirstView
Set swView = swView.GetNextView ' Ignorer la vue de la feuille et prendre la première vue du modèle
' Vérifier si la vue fait référence à un modèle
If Not swView Is Nothing Then
Set swModelInView = swView.ReferencedDocument
If Not swModelInView Is Nothing Then
' Récupérer le chemin du fichier de la pièce référencée
partFilePath = swModelInView.GetPathName
If partFilePath <> "" Then
MsgBox "Le chemin du modèle inséré est : " & partFilePath
Else
MsgBox "La pièce n'a pas encore été enregistrée."
End If
Else
MsgBox "Aucun modèle n'est associé à cette vue."
Exit Sub
End If
End If
' Récupérer le chemin de la mise en plan (le fichier de dessin)
drawingFilePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, ".") - 1)
' Si la mise en plan n'a pas encore été enregistrée
If drawingFilePath = "" Then
MsgBox "La mise en plan n'a pas encore été enregistrée."
Exit Sub
End If
' Générer les chemins pour l'export PDF et DXF
exportPDFPath = drawingFilePath & ".pdf"
exportDXFPath = drawingFilePath & ".dxf"
' Exporter la mise en plan en PDF
swModel.SaveAs3 exportPDFPath, 0, 0
MsgBox "Exportation en PDF réussie : " & exportPDFPath
' Exporter la mise en plan en DXF
swModel.SaveAs4 exportDXFPath, swSaveAsDXF, swSaveAsOptions_Silent, errors, warnings
If errors = 0 Then
MsgBox "Exportation en DXF réussie : " & exportDXFPath
Else
MsgBox "Erreur lors de l'exportation en DXF."
End If
End Sub
Hallo @max59 Ik heb de vrijheid genomen om het bericht te bewerken om de macro terug te plaatsen tussen de tags, omdat de vertaler anders ... Het mooiste was aan het einde van de macro de vertaling van " End sub " door " einde van de onderzeeër ", het maakte mijn dag goed
