cette macro recupère le modèle utiliser dans la mise en plan, ainsi que la configuration activé du composant
l'ouvre recupère la propriété test lié à la configuration
et enregistre le plan en PDF dans le même chemin que le composant avec comme nom, la valeur de la propriété
en espérant avoir répondu à ta demande
Option Explicit Dim swApp As SldWorks.SldWorks Dim swModel As SldWorks.ModelDoc2 Dim swDraw As SldWorks.DrawingDoc Dim cusPropMgr As SldWorks.CustomPropertyManager Dim swView As SldWorks.View Dim swModelDocExt As SldWorks.ModelDocExtension Dim config As SldWorks.Configuration Dim Nameproperties As String Dim Lerrors As Long Dim Lwarnings As Long Dim configname As String Dim lRetVal As Long Dim ValOut As String Dim ResolvedValOut As String Dim wasResolved As Boolean Dim strRefModelPath As String Dim NamePlan As String Dim chemin As String
Sub main() Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc If swModel.GetType = 3 Then Set swDraw = swModel Set swView = swDraw.GetFirstView NamePlan = swModel.GetTitle 'BOUCLE POUR RECUPERER LE MODELE Do While Not swView Is Nothing strRefModelPath = swView.GetReferencedModelName 'recupere le chemin complet du fichier configname = swView.ReferencedConfiguration 'recupere la configuration de la vue If strRefModelPath <> "" Then chemin = Left(strRefModelPath, InStrRev(strRefModelPath, "\") - 1) 'recupere le chemin sans le nom de fichier swApp.ActivateDoc (strRefModelPath) Set swModel = swApp.ActiveDoc swModel.ShowConfiguration2 (configname) 'affiche la configuration du plan Set config = swModel.GetActiveConfiguration 'recupere la configuration active du composant Set cusPropMgr = config.CustomPropertyManager Nameproperties = CopyCustProps("TEST") 'recupere la valeur de la proprieté test qui est spécifique à la configuration Exit Do End If Set swView = swView.GetNextView Loop
Else MsgBox "Veuillez activer une mise en plan", vbInformation, "Erreur type de document" End If 'reactivation du plan swApp.ActivateDoc NamePlan Set swModel = swApp.ActiveDoc Set swModelDocExt = swModel.Extension 'définition du noma d'enregistrement NamePlan = chemin & "\" & Nameproperties & ".pdf" 'enregistrement pdf wasResolved = swModelDocExt.SaveAs(NamePlan, 0, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, Lerrors, Lwarnings) End Sub
Function CopyCustProps(PropertyName) As String lRetVal = cusPropMgr.Get5(PropertyName, False, ValOut, ResolvedValOut, wasResolved) CopyCustProps = ResolvedValOut End Function
Même demande que d.roger. Si la propriété est utilisée dans le plan il est plus simple de boucler dans les notes du cartouche que de récupérer les informations via une vue et le 3D qui y est rattaché (pour peu qu'il y ait différentes vue avec différents modèles rattachés ça devient vite compliqué).
En gros:
Const cProp = "$PRPSHEET:""ENREGISTREMENT"""
Dim sFilename as string
Set swDraw = swModel
Set swView = swDraw.GetFirstView 'Active le fond de plan
Set swNote = swView.GetFirstNote
swModel.ClearSelection2 (True)
Do While Not swNote Is Nothing
Set swAnn = swNote.GetAnnotation
If swNote.PropertyLinkedText = cProp Then
sFilename = swNote.GetText 'ajouter le traitement pour formater correctement le nom d'enregistrement
End If
Set swNote = swNote.GetNext
Loop
gdm j'ai une erreur "compilation : variable non définie" avec "swSaveAsOptions_e"
Bien entendu d.roger ci-dessous la partie code pour l'enregistrement.
Cyril.f oui la propriété et utilisée dans la mise en plan, j'ai créeée une Note avec le Nom de l'attribut "INFO_QUALITE05"
Set swApp = Application.SldWorks Set Part = swApp.ActiveDoc ' ajout controle du bon fichier If Part Is Nothing Then MsgBox "Aucun fichier n'est actuellement ouvert." Exit Sub ' If no model is currently loaded, then exit End If ' Determine the document type. If the document is a drawing, then send a message to the user. If (Part.GetType <> 3) Then '1Part 2Assembly 3Document MsgBox "Cette macro ne s'applique que sur une mise en plan" Exit Sub End If File = Part.GetPathName If File = "" Then MsgBox "Cette macro necessite que le fichier soit préalablement enregistré" Exit Sub End If
Set swModelDocExt = Part.Extension Set swExportPDFData = swApp.GetExportFileData(1) Set swdraw = Part vSheetNames = swdraw.GetSheetNames Dim i As Long Dim j As Long j = 0 ReDim strSheetName(UBound(vSheetNames)) For i = 0 To UBound(vSheetNames) If InStr(vSheetNames(i), "Plan") <> 0 Then strSheetName(j) = vSheetNames(i) j = j + 1 End If Next varSheetName = strSheetName If swExportPDFData Is Nothing Then MsgBox "Nothing" boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, varSheetName)
'Ajout pour propriete de la piece Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc Set swdraw = swModel Set swview = swdraw.GetFirstView Set swview = swview.GetNextView v = swview.GetVisibleComponents Set comp = v(0) Set swmod = comp.GetModelDoc2 Propname = swmod.GetCustomInfoNames Set swCustPropMgr = swModel.Extension.CustomPropertyManager("") Debug.Print swmod.GetCustomInfoValue(config, "DESCRIPTION")
Merci gdm, c'est OK pour ce passage en remplacent par 1 dans le code je suis sous Solidworks 2013.
Il reste une autre erreur d'exécution '438': Propriété ou méthode non gérée ^par cet objet au niveau de lRetVal = cusPropMgr.Get5(PropertyName, False, ValOut, ResolvedValOut, wasResolved)
La fonction Get5 n'existait pas encore pour la version 2013, à remplacer par Get4 et forcément il faut changer le nombre d'arguments de la fonction !!!