Modifier les propriétés à partir d'Excel pour Solidworks avec l'API Document manager

Bonjour;
Je voudrais modifier les propriétés de mes projets Solidworks avec Excel pour cela j’ai pensé à utiliser L’API Solidworks « Document manager ».
J’ai donc adapté un code existant afin de pouvoir l’utiliser mais malheureusement, j’ai une erreur sur une fonction de la librairie « SolidWorks document manager » dont je trouve pas de solution.

« Un composant ActiveX ne peut pas créer d’objet »

La fonction en question :

Set swDmDoc = swDmApp.GetDocument(path, docType, readOnly, openDocErr)

Avec SwDmDoc = Nothing

voici le code (PS : le code a besoin d’une clé de licence perso que je ne peux pas vous montrer)

Const SW_DM_KEY As String = "Clé perso"

Sub main()
End Sub

Function ConnectToDm() As SwDocumentMgr.SwDMApplication

    Dim swDmClassFactory As SwDocumentMgr.swDmClassFactory
    Dim swDmApp As SwDocumentMgr.SwDMApplication
    
    Set swDmClassFactory = CreateObject("SwDocumentMgr.SwDMClassFactory")
        
    If Not swDmClassFactory Is Nothing Then
        Set swDmApp = swDmClassFactory.GetApplication(SW_DM_KEY)
        Set ConnectToDm = swDmApp
    Else
        Err.Raise vbError, "", "Document Manager SDK is not installed"
    End If
    
End Function

Function OpenDocument(swDmApp As SwDocumentMgr.SwDMApplication, path As String, readOnly As Boolean) As SwDocumentMgr.SwDMDocument10
    
    Dim ext As String
    ext = LCase(Right(path, Len(path) - InStrRev(path, ".")))
    
    Dim docType As SwDmDocumentType
    
    Select Case ext
        Case "sldlfp"
            docType = swDmDocumentPart
        Case "sldprt"
            docType = swDmDocumentPart
        Case "sldasm"
            docType = swDmDocumentAssembly
        Case "slddrw"
            docType = swDmDocumentDrawing
        Case Else
            Err.Raise vbError, "", "Unsupported file type: " & ext
    End Select
    
    Dim swDmDoc As SwDocumentMgr.SwDMDocument10
    Dim openDocErr As SwDmDocumentOpenError
    Set swDmDoc = swDmApp.GetDocument(path, docType, readOnly, openDocErr)
    
    If swDmDoc Is Nothing Then
        Err.Raise vbError, "", "Failed to open document: '" & path & "'. Error Code: " & openDocErr
    End If
    
    Set OpenDocument = swDmDoc
    
End Function

Public Function GETSWPRP(fileName As String, prpNames As Variant, Optional confName As String = "") As Variant
    
    Dim swDmApp As SwDocumentMgr.SwDMApplication
    Dim swDmDoc As SwDocumentMgr.SwDMDocument10
    
try_:
    On Error GoTo catch_
    
    Dim vNames As Variant
            
    If TypeName(prpNames) = "Range" Then
        vNames = RangeToArray(prpNames)
    Else
        vNames = Array(CStr(prpNames))
    End If
    
    Set swDmApp = ConnectToDm()
    Set swDmDoc = OpenDocument(swDmApp, fileName, True)
    
    Dim res() As String
    Dim i As Integer
    ReDim res(UBound(vNames))
    
    Dim prpType As SwDmCustomInfoType
    
    If confName = "" Then
        For i = 0 To UBound(vNames)
            res(i) = swDmDoc.GetCustomProperty(CStr(vNames(i)), prpType)
        Next
    Else
        Dim swDmConf As SwDocumentMgr.SwDMConfiguration10
        Set swDmConf = swDmDoc.ConfigurationManager.GetConfigurationByName(confName)
        If Not swDmConf Is Nothing Then
            For i = 0 To UBound(vNames)
                res(i) = swDmConf.GetCustomProperty(CStr(vNames(i)), prpType)
            Next
        Else
            Err.Raise vbError, "", "Failed to get configuration '" & confName & "' from '" & fileName & "'"
        End If
    End If
    
    GETSWPRP = res
    
    GoTo finally_
    
catch_:
    Debug.Print Err.Description
    Err.Raise Err.Number, Err.Source, Err.Description
finally_:
    If Not swDmDoc Is Nothing Then
        swDmDoc.CloseDoc
    End If

End Function

Public Function SETSWPRP(fileName As String, prpNames As Variant, prpVals As Variant, Optional confName As String = "")
    
    Dim swDmApp As SwDocumentMgr.SwDMApplication
    Dim swDmDoc As SwDocumentMgr.SwDMDocument10
    
try_:
    On Error GoTo catch_
    
    If TypeName(prpNames) <> TypeName(prpVals) Then
        Err.Raise vbError, "", "Property name and value must be of the same type, e.g. either range or cell"
    End If
    
    Dim vNames As Variant
    Dim vVals As Variant
        
    If TypeName(prpNames) = "Range" Then
        
        vNames = RangeToArray(prpNames)
        
        vVals = RangeToArray(prpVals)
        
        If UBound(vNames) <> UBound(vVals) Then
            Err.Raise vbError, "", "Number of cells in the name and value are not equal"
        End If
    Else
        vNames = Array(CStr(prpNames))
        vVals = Array(CStr(prpVals))
    End If
    
    Set swDmApp = ConnectToDm()
    Set swDmDoc = OpenDocument(swDmApp, fileName, False)
    
    Dim i As Integer
    
    If confName = "" Then
        For i = 0 To UBound(vNames)
            swDmDoc.AddCustomProperty CStr(vNames(i)), swDmCustomInfoText, CStr(vVals(i))
            swDmDoc.SetCustomProperty CStr(vNames(i)), CStr(vVals(i))
        Next
    Else
        Dim swDmConf As SwDocumentMgr.SwDMConfiguration10
        Set swDmConf = swDmDoc.ConfigurationManager.GetConfigurationByName(confName)
        
        If Not swDmConf Is Nothing Then
            For i = 0 To UBound(vNames)
                swDmConf.AddCustomProperty CStr(vNames(i)), swDmCustomInfoText, CStr(vVals(i))
                swDmConf.SetCustomProperty CStr(vNames(i)), CStr(vVals(i))
            Next
        Else
            Err.Raise vbError, "", "Failed to get configuration '" & confName & "' from '" & fileName & "'"
        End If
    End If
    
    swDmDoc.Save
    
    SETSWPRP = "OK"
    
    GoTo finally_
    
catch_:
    Debug.Print Err.Description
    Err.Raise Err.Number, Err.Source, Err.Description
finally_:
    If Not swDmDoc Is Nothing Then
        swDmDoc.CloseDoc
    End If
    
End Function

Private Function RangeToArray(vRange As Variant) As Variant
    
    If TypeName(vRange) = "Range" Then
        Dim excelRange As Range
        Set excelRange = vRange
        
        Dim i As Integer
        
        Dim valsArr() As String
        ReDim valsArr(excelRange.Cells.Count - 1)
        
        i = 0
        
        For Each cell In excelRange.Cells
            valsArr(i) = cell.Value
            i = i + 1
        Next
        
        RangeToArray = valsArr
        
    Else
        Err.Raise vbError, "", "Value is not a Range"
    End If
    
End Function

Code de base:

Je vous remercie par avance

Bonjour,
Vu que ce sont des fonctions, il faut les appeler dans la procédure Main sinon vous ne pouvez avoir qu’une valeur vide pour la variable SwDmDoc. Sinon il faut aussi gérer le statut ReadOnly sinon vous ne pourrez pas modifier les propriétés.

Bonjour;
Je suis d’accord avec @Cyril.f est j’ajouterai aussi de bien vérifier que vous chargez la référence :
SwDocumentMgr 2022Type Library
(2022 = version de Solidworks en cours)

Cordialement.

2 Likes

Bonjour Cyril.f et Maclane,

Merci pour vos retours, j’ai du mal à comprendre ce que vous entendez par : « les appeler dans la procédure main ».
J’ai essayé de les appeler en faisant: Call + nom de ma fonction ou seulement en mettant le nom de ma fonction (Exemple: OpenDocument) et cela me renvoie une erreur:

Pouvez-vous me donner un exemple de votre explication.

Merci d’avance

Bonjour,
Il faut appeler la fonction opendocument avec les arguments attendus soit si je ne fais pas d’erreur une ligne de ce type:

OpenDocument(connecttodm(),FilePath,true)

Il faut, la connexion à la licence pour utiliser l’api, le chemin d’accès au fichier visé et mettre true ou false pour avoir le fichier en lecture seule ou non.

Merci pour votre aide mais cela fonctionne toujours pas, ma fonction « OpenDocument » est déjà appelée dans ma fonction GETSWPRP et si je l’appelle dans la main sa ne change rien.

Le path, docty, readonly ainsi que l’oppenDocErr son bien renseigner, mais j’ai toujours l’erreur « Un composant ActiveX ne peut pas créer d’objet »

j’ai vu que cela pouvait venir de la compatibilité entre mon Excel et Solidworks (32 bits et 64 bits).
Vous penser que je peux continuer ce projet VBA ou cela ne dépends pas de moi mais du système

cordialement

Est-ce que vous pouvez mettre votre code complet que je puisse tester ? (sans la clé bien évidemment)

Une Capture écran de vos librairies chargées serait également appréciable;
Je soupçonne un manque sur les:
Microsoft ActiveX data objets …library
et
Microsoft ActiveX data objets recordset …library

Il est possible que cela vienne aussi d’une erreur de copie de votre clef de Document manager.
VB n’accepte pas plus de 1023 caractères sur une ligne.
( le decoupage doit-être sous la forme de "texte puis espace puis underscore puis retours à la ligne puis la suite du texte…).

Cordialement.

3 Likes

Bonjour @Cyril.f et @Maclane,
merci pour votre réponse
mon code :

Const SW_DM_KEY As String = "<>"


Sub main()
'Call OpenDocument(ConnectToDm(), fileName, True)

End Sub

Function ConnectToDm() As SwDocumentMgr.SwDMApplication

    Dim swDmClassFactory As SwDocumentMgr.swDmClassFactory
    Dim swDmApp As SwDocumentMgr.SwDMApplication
    
    Set swDmClassFactory = CreateObject("SwDocumentMgr.SwDMClassFactory")
        
    If Not swDmClassFactory Is Nothing Then
        Set swDmApp = swDmClassFactory.GetApplication(SW_DM_KEY)
        Set ConnectToDm = swDmApp
    Else
        Err.Raise vbError, "", "Document Manager SDK is not installed"
    End If
    
End Function

Function OpenDocument(swDmApp As SwDocumentMgr.SwDMApplication, path As String, readOnly As Boolean) As SwDocumentMgr.SwDMDocument10
    
    Dim ext As String
    ext = LCase(Right(path, Len(path) - InStrRev(path, ".")))
    
    Dim docType As SwDmDocumentType
    
    Select Case ext
        Case "sldlfp"
            docType = swDmDocumentPart
        Case "sldprt"
            docType = swDmDocumentPart
        Case "sldasm"
            docType = swDmDocumentAssembly
        Case "slddrw"
            docType = swDmDocumentDrawing
        Case Else
            Err.Raise vbError, "", "Unsupported file type: " & ext
    End Select
    
    Dim swDmDoc As SwDocumentMgr.SwDMDocument10
    Dim openDocErr As SwDmDocumentOpenError
    Set swDmDoc = swDmApp.GetDocument(path, docType, readOnly, openDocErr)
    
    If swDmDoc Is Nothing Then
        Err.Raise vbError, "", "Failed to open document: '" & path & "'. Error Code: " & openDocErr
    End If
    
    Set OpenDocument = swDmDoc
    
End Function

Public Function GETSWPRP(fileName As String, prpNames As Variant, Optional confName As String = "") As Variant
    
    Dim swDmApp As SwDocumentMgr.SwDMApplication
    Dim swDmDoc As SwDocumentMgr.SwDMDocument10
    
try_:
    On Error GoTo catch_
    
    Dim vNames As Variant
            
    If TypeName(prpNames) = "Range" Then
        vNames = RangeToArray(prpNames)
    Else
        vNames = Array(CStr(prpNames))
    End If
    
    Set swDmApp = ConnectToDm()
    Set swDmDoc = OpenDocument(swDmApp, fileName, True)
    
    Dim res() As String
    Dim i As Integer
    ReDim res(UBound(vNames))
    
    Dim prpType As SwDmCustomInfoType
    
    If confName = "" Then
        For i = 0 To UBound(vNames)
            res(i) = swDmDoc.GetCustomProperty(CStr(vNames(i)), prpType)
        Next
    Else
        Dim swDmConf As SwDocumentMgr.SwDMConfiguration10
        Set swDmConf = swDmDoc.ConfigurationManager.GetConfigurationByName(confName)
        If Not swDmConf Is Nothing Then
            For i = 0 To UBound(vNames)
                res(i) = swDmConf.GetCustomProperty(CStr(vNames(i)), prpType)
            Next
        Else
            Err.Raise vbError, "", "Failed to get configuration '" & confName & "' from '" & fileName & "'"
        End If
    End If
    
    GETSWPRP = res
    
    GoTo finally_
    
catch_:
    Debug.Print Err.Description
    Err.Raise Err.Number, Err.Source, Err.Description
finally_:
    If Not swDmDoc Is Nothing Then
        swDmDoc.CloseDoc
    End If

End Function

Public Function SETSWPRP(fileName As String, prpNames As Variant, prpVals As Variant, Optional confName As String = "")
    
    Dim swDmApp As SwDocumentMgr.SwDMApplication
    Dim swDmDoc As SwDocumentMgr.SwDMDocument10
    
try_:
    On Error GoTo catch_
    
    If TypeName(prpNames) <> TypeName(prpVals) Then
        Err.Raise vbError, "", "Property name and value must be of the same type, e.g. either range or cell"
    End If
    
    Dim vNames As Variant
    Dim vVals As Variant
        
    If TypeName(prpNames) = "Range" Then
        
        vNames = RangeToArray(prpNames)
        
        vVals = RangeToArray(prpVals)
        
        If UBound(vNames) <> UBound(vVals) Then
            Err.Raise vbError, "", "Number of cells in the name and value are not equal"
        End If
    Else
        vNames = Array(CStr(prpNames))
        vVals = Array(CStr(prpVals))
    End If
    
    Set swDmApp = ConnectToDm()
    Set swDmDoc = OpenDocument(swDmApp, fileName, False)
    
    Dim i As Integer
    
    If confName = "" Then
        For i = 0 To UBound(vNames)
            swDmDoc.AddCustomProperty CStr(vNames(i)), swDmCustomInfoText, CStr(vVals(i))
            swDmDoc.SetCustomProperty CStr(vNames(i)), CStr(vVals(i))
        Next
    Else
        Dim swDmConf As SwDocumentMgr.SwDMConfiguration10
        Set swDmConf = swDmDoc.ConfigurationManager.GetConfigurationByName(confName)
        
        If Not swDmConf Is Nothing Then
            For i = 0 To UBound(vNames)
                swDmConf.AddCustomProperty CStr(vNames(i)), swDmCustomInfoText, CStr(vVals(i))
                swDmConf.SetCustomProperty CStr(vNames(i)), CStr(vVals(i))
            Next
        Else
            Err.Raise vbError, "", "Failed to get configuration '" & confName & "' from '" & fileName & "'"
        End If
    End If
    
    swDmDoc.Save
    
    SETSWPRP = "OK"
    
    GoTo finally_
    
catch_:
    Debug.Print Err.Description
    Err.Raise Err.Number, Err.Source, Err.Description
finally_:
    If Not swDmDoc Is Nothing Then
        swDmDoc.CloseDoc
    End If
    
End Function

Private Function RangeToArray(vRange As Variant) As Variant
    
    If TypeName(vRange) = "Range" Then
        Dim excelRange As Range
        Set excelRange = vRange
        
        Dim i As Integer
        
        Dim valsArr() As String
        ReDim valsArr(excelRange.Cells.Count - 1)
        
        i = 0
        
        For Each cell In excelRange.Cells
            valsArr(i) = cell.Value
            i = i + 1
        Next
        
        RangeToArray = valsArr
        
    Else
        Err.Raise vbError, "", "Value is not a Range"
    End If
    
End Function



ma clé est sous cette forme :

"Nom: swdocmgr_general-0000," & _
"swdocmgr_previews-0000," & _
"swdocmgr_dimxpert-0000," & _
"swdocmgr_geometry-0000," & _
"swdocmgr_xml-0000," & _
"swdocmgr_tessellation-0000"

il manqué bien les 2 librairie mais cela ne résous pas l’erreur :
image

Cordialement.

Bonjour,

Je suis en déplacement aujourd’hui, je verrai demain si j’ai de la dispo si personne n’est passé par là avant

1 Like

Bonjour,
Il me semble que « Microsoft Excel 15.0 Object Library » correspond à la version 2013 de Excel qui, si c’est bien le cas, n’est pas compatible avec le Solidworks 2021 que tu sembles avoir.
Cordialement,

3 Likes

Bonjour;
L’erreur mentionnée est commentée (ActiveX…) ici.

Cordialement.

3 Likes

Bonjour,
Alors je n’avais pas lu intégralement l’article de base. Donc je penche pour une incompatibilité d’Office. Probablement des compléments qui n’existent pas sur 2013.

2 Likes

Bonjour,
Je reviens après avoir voulu tester de mon côté document manager et donc je pense que votre problème est lié à votre clé.
J’avais omis de mettre le début de clé qui correspond au nom de ma société et j’avais cette erreur active x.
Probablement la même chose pour vous, faut prendre toute la clé transmise par SW qui est normalement codifiée ainsi : CompanyName :swdocmgr_general-00000-{31 times}

Bonjour,

j’ai un projet similaire de modification des propriétés SW depuis EXCEL.
Comme tous les gars de ma société doivent pouvoir utiliser le même template excel :

  • peut-on faire la même chose sans rentrer la clé SW ?
  • sinon, si j’utilise ma clé, fonctionnera-t-elle pour d’autres postes/collaborateurs ?

Par avance merci.

JnO

Bonjour;

Je dirai que tout dépend de l’ampleur des propriétés à modifier…
Techniquement il est possible de passer par Excel + Macro VBA mais l’utilisation d’un template commun me semble « curieuse » dans le cadre de modifications.
(voir tutoriel :Using Microsoft Excel with the SolidWorks API - SOLIDWORKS API, PDM API, Onshape FeatureScript, Onshape API Training and Services)
(en anglais)

Pour les clef Document Manager :
Une clef par poste (qu’il faut mettre à jour à chaque update de version de Solidworks)

Je vous orienterai plus vers des outils comme « Integration » (Visiativ) ou « Cad+ »( xarial.com) ou encore #TASK (Central Innovation), car même s’il faut cracher au bassinet, le gain global de productivité est considérable dans la plupart des cas.

Cordialement.

3 Likes

J’ai un besoin un peu spécifique effectivement. Nous travaillons à plusieurs mais sur des projets différents.
J’ai créé un outil pour exporter les BOMs depuis SW dans un fichier excel qui s’ouvre automatiquement et qui contient des macros pour réorganiser la BOM pour les achats.
On rencontre souvent des erreurs de propriétés lors de la relecture des fichiers excel, et il faut à chaque fois rouvrir les 3D pour modifier quelques propriétés et tenir à jour les 3D c’est pour celà que j’aimerais modifier les propriétés directement depuis ce fichier excel.

De ce que je comprends, pour éviter d’avoir à ouvrir SW je suis obligé de passer pas les clés Document Manager, et il en faut une par utilisateur. Donc mon fichier excel devra aller piocher la clé pour chaque utilisateur dans un dossier spécifique.

Merci pour ces informations et bon weekend !

1 Like

Salut,
Non. Une seule clé suffit. Elle concerne ton application.
C’est un des proncipaux intérêts de cette API. Elle te permet d’accéder aux propriétés des documents SW sur des postes sans le logiciel et donc sans licence.
j’ai developpé un utilitaire permettant de faire remonter les caractéristiques des éléments SW dans notre ERP sous forme de complément Excel. Il est déployé sur plusieurs postes de l’entreprise sans aucun problème.
Tu dois juste prévoir de mettre à jour l’API et la licence à chaque changement de version de SW.
Bonne journée.

2 Likes

Vous Confirmez @remrem ?
Parce que j’ai choisis de ne PAS me lancer dans le Document Manager suite à la réponse de notre revendeur Solidworks qui soutenait l’inverse!
(d’un autre coté ce sont ceux qui ont installés le poste de @Zozo_mp (il comprendra) :crazy_face: (nota: je n’ai pas trouvé le Smiley qui se tire une balle dan la tête)… alors j’ai des doutes maintenant.)

Cordialement.

Oui.
Tu as reçu ta clé ?
Tu peux faire un test sur un PC sans SW ?
Je n’ai pas facilement accès à un PC sans SW.