Macro Enregistrer Sous PDF/DWG/STEP

Bonjour,

Ne connaissant rien au codage, j'aurai besoin d'aide pour développer une macro sur solidworks permettant de créé un PDF, DXF et un fichier step via une mise en plan.
Je voudrai également pouvoir enregistrer des pdf avec le nom de la pièce sans faire de modification.

Merci de bien vouloir m'aider 

peut etre ce type de macro presente dans la réponse d'une question similaire

http://www.lynkoa.com/forum/cao/macro-d-enregistrement-en-pdf-et-dxf-dans-un-dossier-externe

 

4 « J'aime »

Bonjour,

apres quelque recherche, j'ai trouver une macro commande me permettant de créé un fichier PDF et DXF a partir de la mise en plan.

Je doit rajouter a cette commande un code pour créé un ficier step a partir de la piece, seul problème c'est que je n'est aucune idée de la chose a rajouter.

Un peu d'aide serai le bienvenue.

Bonjour,

Mets à disposition la macro nous te dirons ce qu'il manque.

1 « J'aime »

Grace a cette macro commande j'ai reussi a enregister en PDF et en DXF

Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim lErrors As Long
Dim lWarnings As Long

Sub main()

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
swModel.Extension.SaveAs GetFilename(swModel.GetPathName) & " " & swModel.GetCustomInfoValue("", "Révision") & ".pdf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings
swModel.Extension.SaveAs GetFilename(swModel.GetPathName) & " " & swModel.GetCustomInfoValue("", "Révision") & ".dxf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings
End Sub

Function GetFilename(strPath As String) As String
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
GetFilename = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function

Bonjour,

Ci-joint le code correspondant

Option Explicit

Public Enum swDocumentTypes_e
    swDocNONE = 0       ' Used to be TYPE_NONE

    swDocPART = 1       ' Used to be TYPE_PART

    swDocASSEMBLY = 2   ' Used to be TYPE_ASSEMBLY

    swDocDRAWING = 3    ' Used to be TYPE_DRAWING
End Enum
 
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

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
swModel.Extension.SaveAs GetFilename(swModel.GetPathName) & " " & swModel.GetCustomInfoValue("", "Révision") & ".pdf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings
swModel.Extension.SaveAs GetFilename(swModel.GetPathName) & " " & swModel.GetCustomInfoValue("", "Révision") & ".dxf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings

Call ExportStep

End Sub

Function GetFilename(strPath As String) As String
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
GetFilename = Left$(strTemp, InStrRev(strTemp, ".") - 1)


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 = swModel.GetPathName & ".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

 

Ca ne traite que des fichiers sldprt. Pour sldasm faut modifier un peu le code. il y a quelques commentaires ça devrait aider pour la reprise si besoin.

1 « J'aime »

Merci beaucoup de votre aide

De rien, c'est le but du forum

1 « J'aime »