Hi all
I'm looking for a way to find the way to a VBA part that has been inserted into a drawing.
My scenario is as follows:
I have my room that is open, I create a drawing of my room and I want to do an automatic recording in different format.
But I don't see how to recover the way back to my piece from the drawing.
Do any of you have the solution?
Because he certainly has a solution, I tried to look, but I haven't found it yet...
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
Hello
@max59 I took the liberty of editing the post to put the macro back between the tags because otherwise the translator does...
The most beautiful thing being at the end of the macro the translation of " End sub " by " end of the submarine ", it made my day 
Hello
Maybe a lead: https://help.solidworks.com/2020/english/api/sldworksapi/Get_Components_Properties_in_Drawing_View_Example_VB.htm
In short, you keep everything from the code that is necessary to execute this line:
Debug.Print sPadStr & " File = " & swDrawComp.component.GetPathName