Zapisywanie makr jako pliku PDF 3D

Out of category
1

Witam, szukam makra do zapisania pod zespołem lub częścią w formacie PDF 3D, ale nie wiem, jak to zrobić. Znalazłem coś z "ExportAs3D", ale nie wiem, jak zintegrować to z moim kodem. Czy ktoś ma rozwiązanie?

Option Explicit
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim swExportData          As SldWorks.ExportPdfData
    Dim boolstatus          As Boolean
    Dim filename            As String
    Dim lErrors             As Long
    Dim lWarnings           As Long
    Dim ActiveConfig As String
    
'Dim instance As IExportPdfData
'Dim value As System.Boolean
'
'instance.ExportAs3D = value
'value = instance.ExportAs3D
    
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        MsgBox "Aucun assemblage ou pièce en cours", vbCritical
        End
    End If
    If swModel.GetType <> swDocASSEMBLY And swModel.GetType <> swDocPART Then
        MsgBox "Cette Macro ne fonctionne que sur les Assemblages ou les pièces", vbCritical
        End
    End If
    Set swModelDocExt = swModel.Extension
    Set swExportData = swApp.GetExportFileData(swExportPdfData)
    filename = swModel.GetPathName
    If filename = "" Then
        MsgBox "Sauvegarder d'abord le fichier et réessayez", vbCritical
        End
    End If
       
    ActiveConfig = swApp.GetActiveConfigurationName(filename)
    
    Dim NomDossierDestination As String
    NomDossierDestination = "C:\Users\Edouard\Desktop\"
  
    swModel.ForceRebuild3 True
    swModel.ShowNamedView2 "Dimetric", 9
    swModel.ViewZoomtofit2
  
    filename = NomDossierDestination & ActiveConfig & ".PDF"
    
    '-------------------------------------------------------------------------------------

    boolstatus = swExportData.SetSheets(swExportData_ExportAllSheets, 1)
    boolstatus = swModelDocExt.SaveAs(filename, 0, 0, swExportData, lErrors, lWarnings)
    If boolstatus Then
        MsgBox "Enregistrement au format PDF 3D réussi" & vbNewLine & filename
    Else
        MsgBox "Echec de l'enregistrement au format PDF 3D, Error code:" & lErrors
    End If
End Sub

 

2

Witam, powinno być tak:

Option Explicit
Sub main()
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim swExportData        As SldWorks.ExportPdfData
    Dim boolstatus          As Boolean
    Dim filename            As String
    Dim lErrors             As Long
    Dim lWarnings           As Long
    Dim ActiveConfig As String
    Dim NomDossierDestination As String
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        MsgBox "Aucun assemblage ou pièce en cours", vbCritical
        End
    End If
    If swModel.GetType <> swDocASSEMBLY And swModel.GetType <> swDocPART Then
        MsgBox "Cette Macro ne fonctionne que sur les Assemblages ou les pièces", vbCritical
        End
    End If
    Set swModelDocExt = swModel.Extension
    Set swExportData = swApp.GetExportFileData(1)
    swExportData.ExportAs3D = True
    
    filename = swModel.GetPathName
    If filename = "" Then
        MsgBox "Sauvegarder d'abord le fichier et réessayez", vbCritical
        End
    End If

    ActiveConfig = swApp.GetActiveConfigurationName(filename)

    NomDossierDestination = "C:\Users\Edouard\Desktop\"
    filename = NomDossierDestination & ActiveConfig & ".PDF"
    swModel.ForceRebuild3 True
    swModel.ShowNamedView2 "Dimetric", 9
    swModel.ViewZoomtofit2
    boolstatus = swModelDocExt.SaveAs(filename, 0, 0, swExportData, lErrors, lWarnings)
    If boolstatus Then
        MsgBox "Enregistrement au format PDF 3D réussi" & vbNewLine & filename
    Else
        MsgBox "Echec de l'enregistrement au format PDF 3D, Error code:" & lErrors
    End If
End Sub

 

2 polubienia
3

dziękuję JeromeP to dokładnie to :)

4

Witam, świetne makro ! Odzyskałem go  , aby zrobić własny, ale z kilkoma modyfikacjami. Zmodyfikowałem tak, aby dokument zmieniał nazwę na nazwę pliku i zapisywał się w tym samym dokumencie, co ten, który utworzyłem . Chcę tylko dodać PDF3D na końcu mojego pliku wyjściowego, ale nie mogę. Jestem wielkim nowicjuszem , jeśli chodzi o tworzenie makr, czy możesz mi powiedzieć lub zmodyfikować to, co stworzyłem  , aby działało? 

 Opcja jawna
Dim swApp               jako SldWorks.SldWorks   
Dim swModel             As SldWorks.ModelDoc2   
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim swExportData        As SldWorks.ExportPdfData
Dim sPathName           As Ciąg   
Dim boolstatus          As Boolean   
Przyciemnij nazwę            pliku jako ciąg   
    Dim lErrors             tak długo
Dim lOstrzeżenia           tak długo   
    Dim ActiveConfig As Ciąg
    Dim FolderNameDestination As String
    
Sub main()
    Ustaw swApp = Application.SldWorks
    Ustaw swModel = swApp.ActiveDoc
    Jeśli swModel jest niczym, to
        MsgBox "Brak montażu lub części w toku", vbCritical
        Koniec
    Zakończ jeżeli:
    Jeśli swModel.GetType <> swDocASSEMBLY And swModel.GetType <> swDocPART to
        MsgBox "To makro działa tylko na zespołach lub częściach", vbCritical
        Koniec
    Zakończ jeżeli:
    Ustaw swModelDocExt = swModel.Extension
    Ustaw swExportData = swApp.GetExportFileData(1)
    swExportData.ExportAs3D = Prawda
    
    filename = swModel.GetPathName
    Jeśli nazwa_pliku = "" Następnie
        MsgBox "Najpierw zapisz plik i spróbuj ponownie", vbCritical
        Koniec
    Zakończ jeżeli:
    
ActiveConfig = swApp.GetActiveConfigurationName(nazwa pliku)

    NazwaFolderuDocelowego = "C:\Użytkownicy\Pozycja5\Dokumenty\Projekty\"
    filename = swModel.GetPathName
    filename = Strings.Left(nazwa_pliku, Len(nazwa_pliku) - 7) + ".PDF"
    swModel.ForceRebuild3 Prawda
    swModel.ShowNamedView2 "Dimetryczny", 9
    swModel.ViewZoomtofit2
    boolstatus = swModelDocExt.SaveAs(nazwa pliku, 0, 0, swExportData, lErrors, lWarnings)

    Jeśli boolstatus Wtedy
        MsgBox "Pomyślna rejestracja pliku PDF 3D" & vbNewLine & nazwa pliku
    Inaczej
        MsgBox "Nie udało się zapisać jako pliku PDF 3D, kod błędu:" & lErrors
    Zakończ jeżeli:
Koniec subwoofera

5

filename = Strings.Left(nazwa_pliku, Len(nazwa_pliku) - 7) + "-PDF3D.PDF"

Coś takiego powinno działać

1 polubienie
6

Dziękuję!!